From 28b7b9657b25a576c1fcc965a700e9ac99992a16 Mon Sep 17 00:00:00 2001 From: Andrew Tolmach Date: Fri, 10 Nov 2023 11:04:22 -0800 Subject: [PATCH 01/83] initial working port of events --- common/Events.v | 580 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 509 insertions(+), 71 deletions(-) diff --git a/common/Events.v b/common/Events.v index 845e6c6f96..2142e2c2ef 100644 --- a/common/Events.v +++ b/common/Events.v @@ -43,7 +43,10 @@ Set Warnings "-unsupported-attributes". we use the following type for events. Each event represents either: - A system call (e.g. an input/output operation), recording the - name of the system call, its parameters, and its result. + name of the system call, its parameters, the contents of any memory + buffers it writes, its result, and the contents of any memory buffers + it reads. We do not bother recording the addresses of the buffers, which + can (presumably) be inferred from the parameters. - A volatile load from a global memory location, recording the chunk and address being read and the value just read. @@ -68,7 +71,7 @@ Inductive eventval: Type := | EVptr_global: ident -> ptrofs -> eventval. Inductive event: Type := - | Event_syscall: string -> list eventval -> eventval -> event + | Event_syscall: string -> list eventval -> list (list byte) -> eventval -> list (list byte) -> event | Event_vload: memory_chunk -> ident -> ptrofs -> eventval -> event | Event_vstore: memory_chunk -> ident -> ptrofs -> eventval -> event | Event_annot: string -> list eventval -> event @@ -499,10 +502,74 @@ Qed. End EVENTVAL_INJECT. +(** * Semantics of external functions *) + +(** For each external function, its behavior is defined by a predicate relating: +- the global symbol environment +- the values of the arguments passed to this function +- the memory state before the call +- the result value of the call +- the memory state after the call +- the trace generated by the call (can be empty). + +*) + +Definition extcall_sem : Type := + Senv.t -> list val -> mem -> trace -> val -> mem -> Prop. + +(** Semantics of all the external functions, indexed by name and signature *) +Definition extcalls_sem: Type := + String.string -> signature -> extcall_sem. + + +(* APT: Following are dead? *) +(* (** This invariant guarantees that external calls performed to [cp] can *) +(* correctly use either [cp1] or [cp2] to find out who the calling compartment *) +(* is. *) *) +(* Definition uptodate_caller (cp cp1 cp2: compartment) := *) +(* needs_calling_comp cp = true -> *) +(* cp1 = cp2. *) + +(* Definition extcall_caller_independent (cp: compartment) (sem: extcall_sem) := *) +(* forall ge cp1 cp2 args m t v m', *) +(* uptodate_caller cp cp1 cp2 -> *) +(* sem ge cp1 args m t v m' -> *) +(* sem ge cp2 args m t v m'. *) + +(** To define trace matching, we need a notion of well-formed syscall events. + Some system calls enforce that certain relationships hold between + arguments and results; for example, a `read` call never reads more bytes + than requested. When defining receptivity of a call, it only make sense + to consider such well-formed events; the stronger notion of receptivity + in vanilla CompCert would fail. + + Clearly, the definition of well-formedness must depend on the particular + system call in question. It would be possible to define an independent + notion of well-formedness indexed by function id, but we instead observe + that well-formedness is a corollary of obeying the semantics of the call. + So we say that an event is well-formed if it _could_ possibly be produced + by the call behavior for _some_ choice of environment and memories. + + This makes the definition of trace equivalence, and hence statement and proof + of the generic extcall_properties, dependent on the choice of extcalls_sems. *) + +Inductive well_formed_syscall_event + (ecs_sem: extcalls_sem) + (id:String.string) (sg: signature) (eargs: list eventval) (reads: list (list byte)) + (eres: eventval) (writes: list (list byte)) : Prop := +| wfse_intro: forall m m' args res env, + eventval_list_match env eargs sg.(sig_args) args -> + eventval_match env eres (proj_rettype sg.(sig_res)) res -> + ecs_sem id sg env args m (Event_syscall id eargs reads eres writes :: nil) res m' -> + well_formed_syscall_event ecs_sem id sg eargs reads eres writes. + + (** * Matching traces. *) Section MATCH_TRACES. +Variable ecs_sem: extcalls_sem. + Variable ge: Senv.t. (** Matching between traces corresponding to single transitions. @@ -513,9 +580,15 @@ Variable ge: Senv.t. Inductive match_traces: trace -> trace -> Prop := | match_traces_E0: match_traces nil nil +(* was: | match_traces_syscall: forall id args res1 res2, eventval_valid ge res1 -> eventval_valid ge res2 -> eventval_type res1 = eventval_type res2 -> match_traces (Event_syscall id args res1 :: nil) (Event_syscall id args res2 :: nil) + *) + | match_traces_syscall: forall id sg args res1 res2 reads writes1 writes2, + well_formed_syscall_event ecs_sem id sg args reads res1 writes1 -> + well_formed_syscall_event ecs_sem id sg args reads res2 writes2 -> + match_traces (Event_syscall id args reads res1 writes1 :: nil) (Event_syscall id args reads res2 writes2:: nil) | match_traces_vload: forall chunk id ofs res1 res2, eventval_valid ge res1 -> eventval_valid ge res2 -> eventval_type res1 = eventval_type res2 -> match_traces (Event_vload chunk id ofs res1 :: nil) (Event_vload chunk id ofs res2 :: nil) @@ -534,15 +607,17 @@ End MATCH_TRACES. Section MATCH_TRACES_INV. +Variable ecs_sem: extcalls_sem. + Variables ge1 ge2: Senv.t. Hypothesis public_preserved: forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id. Lemma match_traces_preserved: - forall t1 t2, match_traces ge1 t1 t2 -> match_traces ge2 t1 t2. + forall t1 t2, match_traces ecs_sem ge1 t1 t2 -> match_traces ecs_sem ge2 t1 t2. Proof. - induction 1; constructor; auto; eapply eventval_valid_preserved; eauto. + induction 1; econstructor; try eapply eventval_valid_preserved; eauto. Qed. End MATCH_TRACES_INV. @@ -552,7 +627,7 @@ End MATCH_TRACES_INV. Definition output_event (ev: event) : Prop := match ev with - | Event_syscall _ _ _ => False + | Event_syscall _ _ _ _ _ => False | Event_vload _ _ _ _ => False | Event_vstore _ _ _ _ => True | Event_annot _ _ => True @@ -610,38 +685,8 @@ Inductive volatile_store (ge: Senv.t) (cp: compartment): Mem.store chunk m b (Ptrofs.unsigned ofs) v cp = Some m' -> volatile_store ge cp chunk m b ofs v E0 m'. -(** * Semantics of external functions *) -(** For each external function, its behavior is defined by a predicate relating: -- the global symbol environment -- the calling compartment -- the values of the arguments passed to this function -- the memory state before the call -- the result value of the call -- the memory state after the call -- the trace generated by the call (can be empty). - -Most external calls do not use the calling compartment, as formalized -in extcall_caller_independent. -*) - -Definition extcall_sem : Type := - Senv.t -> list val -> mem -> trace -> val -> mem -> Prop. - -(* (** This invariant guarantees that external calls performed to [cp] can *) -(* correctly use either [cp1] or [cp2] to find out who the calling compartment *) -(* is. *) *) -(* Definition uptodate_caller (cp cp1 cp2: compartment) := *) -(* needs_calling_comp cp = true -> *) -(* cp1 = cp2. *) - -(* Definition extcall_caller_independent (cp: compartment) (sem: extcall_sem) := *) -(* forall ge cp1 cp2 args m t v m', *) -(* uptodate_caller cp cp1 cp2 -> *) -(* sem ge cp1 args m t v m' -> *) -(* sem ge cp2 args m t v m'. *) - -(** We now specify the expected properties of this predicate. *) +(** We now specify the expected properties of the extcall_sem predicate. *) Definition loc_out_of_bounds (m: mem) (b: block) (ofs: Z) : Prop := ~Mem.perm m b ofs Max Nonempty. @@ -664,7 +709,7 @@ Definition inject_separated (f f': meminj) (m1 m2: mem): Prop := f b1 = None -> f' b1 = Some(b2, delta) -> ~Mem.valid_block m1 b1 /\ ~Mem.valid_block m2 b2. -Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : Prop := +Record extcall_properties (ecs_sem: extcalls_sem) (sem: extcall_sem) (cp: compartment) (sg: signature) : Prop := mk_extcall_properties { (** The return value of an external call must agree with its signature. *) @@ -771,14 +816,14 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : (** External calls must be receptive to changes of traces by another, matching trace. *) ec_receptive: forall ge vargs m t1 vres1 m1 t2, - sem ge vargs m t1 vres1 m1 -> match_traces ge t1 t2 -> + sem ge vargs m t1 vres1 m1 -> match_traces ecs_sem ge t1 t2 -> exists vres2, exists m2, sem ge vargs m t2 vres2 m2; (** External calls must be deterministic up to matching between traces. *) ec_determ: forall ge vargs m t1 vres1 m1 t2 vres2 m2, sem ge vargs m t1 vres1 m1 -> sem ge vargs m t2 vres2 m2 -> - match_traces ge t1 t2 /\ (t1 = t2 -> vres1 = vres2 /\ m1 = m2); + match_traces ecs_sem ge t1 t2 /\ (t1 = t2 -> vres1 = vres2 /\ m1 = m2); (** External calls cannot produce [Event_call] or [Event_return] events *) ec_no_crossing: @@ -854,8 +899,8 @@ Proof. Qed. Lemma volatile_load_receptive: - forall ge cp chunk m b ofs t1 t2 v1, - volatile_load ge cp chunk m b ofs t1 v1 -> match_traces ge t1 t2 -> + forall wfse ge cp chunk m b ofs t1 t2 v1, + volatile_load ge cp chunk m b ofs t1 v1 -> match_traces wfse ge t1 t2 -> exists v2, volatile_load ge cp chunk m b ofs t2 v2. Proof. intros. inv H; inv H0. @@ -865,8 +910,8 @@ Proof. Qed. Lemma volatile_load_ok: - forall chunk cp, - extcall_properties (volatile_load_sem cp chunk) + forall ecs_sem chunk cp , + extcall_properties ecs_sem (volatile_load_sem cp chunk) cp (mksignature (Tptr :: nil) (rettype_of_chunk chunk) cc_default). Proof. intros; constructor; intros. @@ -1036,15 +1081,15 @@ Proof. Qed. Lemma volatile_store_receptive: - forall ge cp chunk m b ofs v t1 m1 t2, - volatile_store ge cp chunk m b ofs v t1 m1 -> match_traces ge t1 t2 -> t1 = t2. + forall wfse ge cp chunk m b ofs v t1 m1 t2, + volatile_store ge cp chunk m b ofs v t1 m1 -> match_traces wfse ge t1 t2 -> t1 = t2. Proof. intros. inv H; inv H0; auto. Qed. Lemma volatile_store_ok: - forall cp chunk, - extcall_properties (volatile_store_sem cp chunk) + forall ecs_sem cp chunk, + extcall_properties ecs_sem (volatile_store_sem cp chunk) cp (mksignature (Tptr :: type_of_chunk chunk :: nil) Tvoid cc_default). Proof. intros; constructor; intros. @@ -1102,8 +1147,8 @@ Inductive extcall_malloc_sem (cp: compartment) (ge: Senv.t): extcall_malloc_sem cp ge (Vptrofs sz :: nil) m E0 (Vptr b Ptrofs.zero) m''. Lemma extcall_malloc_ok: - forall cp, - extcall_properties (extcall_malloc_sem cp) + forall ecs_sem cp, + extcall_properties ecs_sem (extcall_malloc_sem cp) cp (mksignature (Tptr :: nil) Tptr cc_default). Proof. intros. @@ -1215,8 +1260,8 @@ Inductive extcall_free_sem (cp: compartment) (ge: Senv.t): extcall_free_sem cp ge (Vnullptr :: nil) m E0 Vundef m. Lemma extcall_free_ok: - forall cp, - extcall_properties (extcall_free_sem cp) + forall ecs_sem cp, + extcall_properties ecs_sem (extcall_free_sem cp) cp (mksignature (Tptr :: nil) Tvoid cc_default). Proof. intros. @@ -1343,8 +1388,8 @@ Inductive extcall_memcpy_sem (cp: compartment) (sz al: Z) (ge: Senv.t): extcall_memcpy_sem cp sz al ge (Vptr bdst odst :: Vptr bsrc osrc :: nil) m E0 Vundef m'. Lemma extcall_memcpy_ok: - forall cp sz al, - extcall_properties (extcall_memcpy_sem cp sz al) + forall ecs_sem cp sz al, + extcall_properties ecs_sem (extcall_memcpy_sem cp sz al) cp (mksignature (Tptr :: Tptr :: nil) Tvoid cc_default). Proof. intros. constructor. @@ -1481,8 +1526,8 @@ Inductive extcall_annot_sem (cp: compartment) (text: string) (targs: list typ) ( extcall_annot_sem cp text targs ge vargs m (Event_annot text args :: E0) Vundef m. Lemma extcall_annot_ok: - forall cp text targs, - extcall_properties (extcall_annot_sem cp text targs) + forall ecs_sem cp text targs, + extcall_properties ecs_sem (extcall_annot_sem cp text targs) cp (mksignature targs Tvoid cc_default). Proof. intros; constructor; intros. @@ -1535,8 +1580,8 @@ Inductive extcall_annot_val_sem (cp: compartment) (text: string) (targ: typ) (ge extcall_annot_val_sem cp text targ ge (varg :: nil) m (Event_annot text (arg :: nil) :: E0) varg m. Lemma extcall_annot_val_ok: - forall cp text targ, - extcall_properties (extcall_annot_val_sem cp text targ) + forall ecs_sem cp text targ, + extcall_properties ecs_sem (extcall_annot_val_sem cp text targ) cp (mksignature (targ :: nil) targ cc_default). Proof. intros; constructor; intros. @@ -1588,8 +1633,8 @@ Inductive extcall_debug_sem (cp: compartment) (ge: Senv.t): extcall_debug_sem cp ge vargs m E0 Vundef m. Lemma extcall_debug_ok: - forall cp targs, - extcall_properties (extcall_debug_sem cp) + forall ecs_sem cp targs, + extcall_properties ecs_sem (extcall_debug_sem cp) cp (mksignature targs Tvoid cc_default). Proof. intros; constructor; intros. @@ -1646,8 +1691,8 @@ Inductive known_builtin_sem (bf: builtin_function) (ge: Senv.t): builtin_function_sem bf vargs = Some vres -> known_builtin_sem bf ge vargs m E0 vres m. -Lemma known_builtin_ok: forall bf cp, - extcall_properties (known_builtin_sem bf) cp (builtin_function_sig bf). +Lemma known_builtin_ok: forall ecs_sem bf cp, + extcall_properties ecs_sem (known_builtin_sem bf) cp (builtin_function_sig bf). Proof. intros. set (bsem := builtin_function_sem bf). constructor; intros. (* well typed *) @@ -1709,7 +1754,7 @@ Qed. Parameter external_functions_sem: compartment -> String.string -> signature -> extcall_sem. Axiom external_functions_properties: - forall id sg cp, extcall_properties (external_functions_sem cp id sg) cp sg. + forall id sg cp, extcall_properties (external_functions_sem cp) (external_functions_sem cp id sg) cp sg. (* Axiom external_functions_caller_independent: *) (* forall cp id sg, extcall_caller_independent cp (external_functions_sem id sg). *) @@ -1720,7 +1765,7 @@ Axiom external_functions_properties: Parameter inline_assembly_sem: compartment -> String.string -> signature -> extcall_sem. Axiom inline_assembly_properties: - forall cp id sg, extcall_properties (inline_assembly_sem cp id sg) cp sg. + forall cp id sg, extcall_properties (external_functions_sem cp) (inline_assembly_sem cp id sg) cp sg. (* Axiom inline_assembly_caller_independent: *) (* forall cp id sg, extcall_caller_independent cp (inline_assembly_sem id sg). *) @@ -1735,7 +1780,7 @@ Definition builtin_or_external_sem cp name sg := end. Lemma builtin_or_external_sem_ok: forall name sg cp, - extcall_properties (builtin_or_external_sem cp name sg) cp sg. + extcall_properties (external_functions_sem cp) (builtin_or_external_sem cp name sg) cp sg. Proof. unfold builtin_or_external_sem; intros. destruct (lookup_builtin_function name sg) as [bf|] eqn:L. @@ -1783,11 +1828,11 @@ Definition external_call (ef: external_function): extcall_sem := | EF_debug cp kind txt targs => extcall_debug_sem cp end. -Ltac external_call_caller_independent := - intros ????????? CALL; - inv CALL; - econstructor; - eauto. +(* Ltac external_call_caller_independent := *) +(* intros ????????? CALL; *) +(* inv CALL; *) +(* econstructor; *) +(* eauto. *) (* Lemma external_call_caller_independent: *) (* forall ef: external_function, *) @@ -1833,7 +1878,7 @@ Ltac external_call_caller_independent := Theorem external_call_spec: forall ef, - extcall_properties (external_call ef) (comp_of ef) (ef_sig ef). + extcall_properties (external_functions_sem (comp_of ef)) (external_call ef) (comp_of ef) (ef_sig ef). Proof. intros. unfold external_call, ef_sig; destruct ef. apply external_functions_properties. @@ -1929,7 +1974,7 @@ Lemma external_call_match_traces: forall ef ge vargs m t1 vres1 m1 t2 vres2 m2, external_call ef ge vargs m t1 vres1 m1 -> external_call ef ge vargs m t2 vres2 m2 -> - match_traces ge t1 t2. + match_traces (external_functions_sem (comp_of ef)) ge t1 t2. Proof. intros. exploit external_call_determ. eexact H. eexact H0. tauto. Qed. @@ -2238,3 +2283,396 @@ Section INFORM_TRACES_PRESERVED. Qed. End INFORM_TRACES_PRESERVED. + + +Module SyscallSanityChecks. + + (* A couple of example calls to check that the extended Event_syscall definition makes sense + and that we can indeed prove receptivity and determinacy for them. *) + + + (** ** Semantics of read syscall *) + + (* From the man page: + ssize_t read(int fildes, void *buf, size_t nbyte) + read() attempts to read nbyte bytes of data from the object referenced by + the descriptor fildes into the buffer pointed to by buf. + Upon successful completion, read() returns + the number of bytes actually read and placed in the buffer. The system + guarantees to read the number of bytes requested if the descriptor + references a normal file that has that many bytes left before the end-of- + file, but in no other case. + read() will fail if the parameter nbyte exceeds INT_MAX; [it does] + not attempt a partial read. + If successful, the number of bytes actually read is returned. Upon reading + end-of-file, zero is returned. Otherwise, a -1 is returned and the global + variable errno is set to indicate the error. [NB: We do not model errrno.] + + We further restrict buf to be a writeable global, and we require it to be big enough to + hold nbyte bytes. + *) + + Definition read_sg := mksignature (Tint :: Tptr :: Tlong :: nil) Tlong cc_default. + + Inductive extcall_read_sem (cp: compartment) (ge: Senv.t): + list val -> mem -> trace -> val -> mem -> Prop := + | extcall_read_sem_ok: forall fd bytes sz (sz':Z) m m' bdst odst id, + Senv.find_symbol ge id = Some bdst -> + Senv.public_symbol ge id = true -> + Mem.range_perm m bdst (Ptrofs.unsigned odst) + (Ptrofs.unsigned odst + Int64.unsigned sz) Cur Writable -> (* needed for receptivity *) + Mem.storebytes m bdst (Ptrofs.unsigned odst) (map Byte bytes) cp = Some m' -> + sz' = Z_of_nat (length bytes) -> + Int64.unsigned sz <= Int64.max_signed -> (* see man page excerpt *) + sz' <= Int64.unsigned sz -> + extcall_read_sem + cp ge (Vint fd :: Vptr bdst odst :: Vlong sz :: nil) m + (Event_syscall "read" (EVint fd :: EVptr_global id odst :: EVlong sz :: nil) + nil (EVlong (Int64.repr sz')) (bytes :: nil) :: nil) + (Vlong (Int64.repr sz')) m' + | extcall_read_sem_fail: forall fd sz m bdst odst id, + Senv.find_symbol ge id = Some bdst -> + Senv.public_symbol ge id = true -> + Mem.range_perm m bdst (Ptrofs.unsigned odst) + (Ptrofs.unsigned odst + Int64.unsigned sz) Cur Writable -> (* needed for receptivity *) + Mem.can_access_block m bdst (Some cp) -> (* needed for receptivity *) + extcall_read_sem + cp ge (Vint fd :: Vptr bdst odst :: Vlong sz :: nil) m + (Event_syscall "read" (EVint fd :: EVptr_global id odst :: EVlong sz :: nil) + nil (EVlong (Int64.repr (-1))) nil :: nil) + (Vlong (Int64.repr (-1))) m + . + + + Lemma extcall_read_ok: forall (ecs_sem: extcalls_sem) (cp:compartment), + (forall sg, ecs_sem "read"%string sg = extcall_read_sem cp) -> (* a bit bogus *) + extcall_properties ecs_sem (extcall_read_sem cp) cp read_sg. + Proof. + intros ec_sems cp EQ. + constructor; intros. + (* well typed *) + - inv H; simpl; auto. + (* symbols preserved *) + - inv H0. + + econstructor; eauto. + * rewrite <- H1; eapply H. + * rewrite <- H2; eapply H. + + econstructor; eauto. + * rewrite <- H1; eapply H. + * rewrite <- H2; eapply H. + (* valid block *) + - inv H; eauto with mem. + (* accessiblity *) + - inv H. + + eapply Mem.storebytes_can_access_block_inj_1; eauto. + + auto. + (* perms *) + - inv H; eauto with mem. + (* readonly *) + - eapply unchanged_on_readonly; eauto. + inv H. + + eapply Mem.storebytes_unchanged_on; eauto. + intros. unfold loc_not_writable. intro X; apply X; clear X . + exploit Mem.storebytes_range_perm; eauto. + intro. apply Mem.perm_cur_max; auto. + + eapply Mem.unchanged_on_refl; eauto. + (* mem alloc *) + - inv H. + + pose proof (Mem.storebytes_valid_block_2 _ _ _ _ _ _ H5 _ H1). congruence. + + congruence. + (* outside cp *) + - inv H. + + pose proof (Mem.storebytes_can_access_block_1 _ _ _ _ _ _ H3). + eapply Mem.storebytes_unchanged_on; eauto. + + eapply Mem.unchanged_on_refl. + (* mem extends *) + - inv H. + + pose proof (Val.lessdef_list_inv _ _ H1). destruct H. + 2: { inv H. congruence. inv H6. congruence. inv H. congruence. inv H6. } + subst vargs'. + assert (list_forall2 memval_lessdef (map Byte bytes) (map Byte bytes)). + { clear. + induction bytes. + - simpl. econstructor. + - simpl. econstructor. + + apply memval_lessdef_refl. + + auto. } + destruct (Mem.storebytes_within_extends _ _ _ _ _ _ _ _ H0 H5 H) as [m2' [P1 P2]]. + econstructor; eauto. econstructor; eauto. split;[|split;[|split]]. + * econstructor; eauto. + unfold Mem.range_perm in H4 |-*. + intros. eapply Mem.perm_extends; eauto. + * eapply Val.lessdef_refl. + * auto. + * eapply Mem.storebytes_unchanged_on; eauto. + intros. unfold loc_out_of_bounds. intro X; apply X; clear X. + clear P1. + exploit Mem.storebytes_range_perm; eauto. + intro. apply Mem.perm_cur_max; auto. + eapply Mem.perm_implies; eauto. econstructor. + + pose proof (Val.lessdef_list_inv _ _ H1). destruct H. + 2: { inv H. congruence. inv H6. congruence. inv H. congruence. inv H6. } + subst vargs'. + exists (Vlong (Int64.repr (-1))). exists m1'. + split;[|split;[|split]]; eauto. + * econstructor; eauto. + -- unfold Mem.range_perm in H4 |-*. + intros. eapply Mem.perm_extends; eauto. + -- inv H0. + eapply Mem.can_access_block_inj; eauto. unfold inject_id. eauto. + * apply Mem.unchanged_on_refl. + (* mem injects *) + - inv H0. + + inv H2. inv H12. inv H13. inv H14. + inv H10. inv H7. inv H11. + inv H. destruct H2. + destruct (H id bdst b2 delta H10 H3) as [P1 P2]. subst delta. + replace (Ptrofs.add odst (Ptrofs.repr 0)) with odst by (rewrite Ptrofs.add_zero; auto). + edestruct Mem.storebytes_mapped_inject as [m2' [Q1 Q2]]; eauto. + instantiate (1 := (map Byte bytes)). + { clear - bytes. + induction bytes. simpl. econstructor. + simpl. econstructor. constructor. auto. } + inv H1. + econstructor; econstructor; econstructor; [split;[|split;[|split;[|split;[|split;[|split;[|split]]]]]]] . + * econstructor; eauto. + -- eapply Mem.range_perm_inj in H5. + 2,3: eauto. repeat rewrite Z.add_0_r in H5. eauto. + -- rewrite Z.add_0_r in Q1. eapply Q1. + * instantiate (1:= f). econstructor. + * eauto. + * eapply Mem.storebytes_unchanged_on; eauto. + intros. + unfold loc_unmapped. rewrite H10. intros; discriminate. + * eapply Mem.storebytes_unchanged_on; eauto. + intros. + unfold loc_out_of_reach. intro. eapply H7. eauto. + replace (i - 0) with i by lia. + pose proof (Mem.storebytes_range_perm _ _ _ _ _ _ H6). + unfold Mem.range_perm in H11. + eapply Mem.perm_cur_max. + eapply Mem.perm_implies with Writable. 2: constructor. + eapply H11. lia. + * apply inject_incr_refl. + * unfold inject_separated. intros. rewrite H1 in H7; discriminate. + * intros. + exfalso. apply H1. eapply Mem.storebytes_valid_block_2; eauto. + + inv H2. inv H10. inv H11. inv H12. + inv H7. inv H9. inv H8. + inv H. destruct H2. + destruct (H id bdst b2 delta H10 H3) as [P1 P2]. subst delta. + replace (Ptrofs.add odst (Ptrofs.repr 0)) with odst by (rewrite Ptrofs.add_zero; auto). + econstructor. exists (Vlong (Int64.repr (-1))). exists m1'. + split;[|split;[|split;[|split;[|split;[|split;[|split]]]]]]. + * econstructor; eauto. + -- eapply Mem.range_perm_inj in H5. + 2,3: eauto. repeat rewrite Z.add_0_r in H5. eauto. + inv H1. auto. + -- inv H1. + eapply Mem.can_access_block_inj; eauto. + * instantiate (1:= f). econstructor. + * auto. + * eapply Mem.unchanged_on_refl. + * eapply Mem.unchanged_on_refl. + * apply inject_incr_refl. + * unfold inject_separated. intros. rewrite H7 in H8; discriminate. + * intros. congruence. + (* trace length *) + - inv H; simpl; lia. + (* receptive *) + - inv H. + + inv H0. + inv H12. inv H13. + rewrite EQ in H10. + inv H10. + * exists (Vlong (Int64.repr (Z.of_nat (length bytes0)))). + assert (Mem.range_perm m bdst (Ptrofs.unsigned odst) + (Ptrofs.unsigned odst + (Z.of_nat (length (map Byte bytes0)))) Cur Writable). + { unfold Mem.range_perm in H3 |-*. + intros. eapply H3. rewrite map_length in H10. lia. } + assert (exists m1', Mem.storebytes m bdst (Ptrofs.unsigned odst) (map Byte bytes0) cp = Some m1'). + { eapply Mem.range_perm_storebytes in H10. destruct H10. + eexists. eapply e. eapply Mem.storebytes_can_access_block_1; eauto. } + destruct H11 as [m1' P]. + exists m1'. + econstructor; eauto. + * exists (Vlong (Int64.repr (-1))). exists m. + econstructor; eauto. + eapply Mem.storebytes_can_access_block_1; eauto. + + inv H0. + inv H10. inv H11. + rewrite EQ in H8. + inv H8. + * exists (Vlong (Int64.repr (Z.of_nat (length bytes)))). + assert (Mem.range_perm m1 bdst (Ptrofs.unsigned odst) + (Ptrofs.unsigned odst + (Z.of_nat (length (map Byte bytes)))) Cur Writable). + { unfold Mem.range_perm in H3 |-*. + intros. eapply H3. rewrite map_length in H8. lia. } + assert (exists m1', Mem.storebytes m1 bdst (Ptrofs.unsigned odst) (map Byte bytes) cp = Some m1'). + { eapply Mem.range_perm_storebytes in H8. destruct H8. + eexists. eapply e. eauto. } + destruct H9 as [m1' P]. + exists m1'. + econstructor; eauto. + * exists (Vlong (Int64.repr (-1))). exists m1. + econstructor; eauto. + (* determ *) + - split. + + inv H; inv H0; + rewrite (@Senv.find_symbol_injective ge id id0 bdst); eauto; + apply match_traces_syscall with (sg := read_sg); econstructor; try rewrite EQ; repeat econstructor; eauto. + + intro; subst t1. + inv H; inv H0; split; auto. + rewrite H4 in H19. inv H19. auto. + (* no cross *) + - inv H; auto. + Qed. + +(* From the man page: + ssize_t write(int fildes, const void *buf, size_t nbyte) + write() attempts to read nbyte of data to the object referenced by + the descriptor fildes from the buffer pointed to by buf. + write() will fail if the parameter nbyte exceeds INT_MAX; and [it does] + not attempt a partial read. + When using non-blocking I/O on objects, such as sockets, that are subject + to flow control, write() and writev() may write fewer bytes than requested; + the return value must be noted, and the remainder of the operation should + be retried when possible. + Upon successful completion the number of bytes which were written is + returned. Otherwise, a -1 is returned and the global variable errno is set + to indicate the error. [NB: we do not model errno.] + + We further restrict buf to be a readable global of size at least nbytes, + and we require it to contain only plain bytes (not pointer fragments). + *) + + +Definition write_sg := mksignature (Tint :: Tptr :: Tlong :: nil) Tlong cc_default. + +Inductive extcall_write_sem (cp: compartment) (ge: Senv.t): + list val -> mem -> trace -> val -> mem -> Prop := +| extcall_write_sem_intro: forall fd bytes sz sz' m bsrc osrc id mvs, + Senv.find_symbol ge id = Some bsrc -> + Senv.public_symbol ge id = true -> + Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) (Int64.unsigned sz) (Some cp) = Some mvs -> + proj_bytes mvs = Some bytes -> + Int64.unsigned sz <= Int64.max_signed -> (* see man page *) + -1 <= sz' <= Int64.unsigned sz -> + extcall_write_sem cp + ge (Vint fd :: Vptr bsrc osrc :: Vlong sz :: nil) m + (Event_syscall "write" (EVint fd :: EVptr_global id osrc :: EVlong sz :: nil) + (bytes :: nil) (EVlong (Int64.repr sz')) nil :: nil) + (Vlong (Int64.repr sz')) m +. + + +Lemma proj_bytes_inject: forall mvs bs f mvs', + proj_bytes mvs = Some bs -> + list_forall2 (memval_inject f) mvs mvs' -> + mvs = mvs'. +Proof. + induction mvs; intros. + - inv H0; auto. + - inv H0. + simpl in H. destruct a; try discriminate. inv H3. + f_equal. destruct (proj_bytes mvs) eqn:?; try inv H. + eapply IHmvs; eauto. +Qed. + +Lemma proj_bytes_lessdef: forall mvs bs mvs', + proj_bytes mvs = Some bs -> + list_forall2 memval_lessdef mvs mvs' -> + mvs = mvs'. +Proof. + intros. + eapply proj_bytes_inject; eauto. +Qed. + +Lemma extcall_write_ok: forall (ecs_sem: extcalls_sem) (cp:compartment), + (forall sg, ecs_sem "write"%string sg = extcall_write_sem cp) -> (* a bit bogus *) + extcall_properties ecs_sem (extcall_write_sem cp) cp write_sg. +Proof. + intros ec_sems cp EQ. + constructor; intros. + (* well typed *) + - inv H; simpl; auto. + (* symbols preserved *) + - inv H0. + econstructor; eauto. + * rewrite <- H1; eapply H. + * rewrite <- H2; eapply H. + (* valid block *) + - inv H; eauto with mem. + (* accessiblity *) + - inv H; auto. + (* perms *) + - inv H; eauto with mem. + (* readonly *) + - eapply unchanged_on_readonly; eauto. + inv H; eapply Mem.unchanged_on_refl. + (* mem alloc *) + - inv H. congruence. + (* outside cp *) + - inv H. + eapply Mem.unchanged_on_refl. + (* mem extends *) + - inv H. + pose proof (Val.lessdef_list_inv _ _ H1). destruct H. + 2: { inv H. congruence. inv H8. congruence. inv H. congruence. inv H8. } + subst vargs'. + econstructor; eauto. econstructor; eauto. split;[|split;[|split]]. + * econstructor; eauto. + destruct (Mem.loadbytes_extends _ _ _ _ _ _ _ H0 H4) as [mvs' [P1 P2]]. + erewrite proj_bytes_lessdef with (mvs:= mvs); eauto. + * eapply Val.lessdef_refl. + * auto. + * apply Mem.unchanged_on_refl. + (* mem injects *) + - inv H0. + inv H2. inv H12. inv H13. inv H14. + inv H10. inv H9. inv H11. + inv H. destruct H2. + destruct (H id bsrc b2 delta H10 H3) as [P1 P2]. subst delta. + replace (Ptrofs.add osrc (Ptrofs.repr 0)) with osrc by (rewrite Ptrofs.add_zero; auto). + econstructor; econstructor; econstructor; [split;[|split;[|split;[|split;[|split;[|split;[|split]]]]]]] . + * econstructor; eauto. + destruct (Mem.loadbytes_inject _ _ _ _ _ _ _ _ _ _ H1 H5 H10) as [mvs' [Q1 Q2]]. + replace (Ptrofs.unsigned osrc + 0) with (Ptrofs.unsigned osrc) in Q1 by lia. + erewrite proj_bytes_inject with (mvs := mvs); eauto. + * instantiate (1:= f). econstructor. + * eauto. + * eapply Mem.unchanged_on_refl. + * eapply Mem.unchanged_on_refl. + * apply inject_incr_refl. + * unfold inject_separated. intros. rewrite H9 in H11; discriminate. + * intros. congruence. + (* trace length *) + - inv H; simpl; lia. + (* receptive *) + - inv H. + inv H0. + inv H13. + rewrite EQ in H7. inv H7. + exists (Vlong (Int64.repr sz'0)). exists m1. + econstructor; eauto. + (* determ *) + - split. + + inv H; inv H0. + rewrite (@Senv.find_symbol_injective ge id id0 bsrc); eauto. + rewrite H3 in H12. inv H12. + rewrite H4 in H17. inv H17. + apply match_traces_syscall with (sg := read_sg); econstructor; try rewrite EQ; repeat econstructor; eauto; try lia. + + intro; subst t1. + inv H. inv H0. (* not sure what's going on here with H12! *) + split; auto. f_equal. + destruct (Int64.repr sz'0). + destruct (Int64.repr sz'). + generalize intrange. intro intrange'. + subst intval. f_equal. + apply Axioms.proof_irr. + (* no cross *) + - inv H; auto. +Qed. + +End SyscallSanityChecks. + From 45d476cd445f62926373b2c96e4942120cdc992a Mon Sep 17 00:00:00 2001 From: Andrew Tolmach Date: Fri, 10 Nov 2023 12:15:00 -0800 Subject: [PATCH 02/83] a fairly clean version --- backend/Cminor.v | 2 +- cfrontend/Cexec.v | 4 +- cfrontend/Cstrategy.v | 4 +- common/Determinism.v | 18 ++--- common/Events.v | 182 +++++++++++++++++++----------------------- common/Exec.v | 4 +- common/Smallstep.v | 12 +-- riscV/Asm.v | 4 +- 8 files changed, 108 insertions(+), 122 deletions(-) diff --git a/backend/Cminor.v b/backend/Cminor.v index 60c57cc413..114f120502 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -651,7 +651,7 @@ Qed. Ltac Determ := try congruence; match goal with - | [ |- match_traces _ E0 E0 /\ (_ -> _) ] => + | [ |- match_traces _ _ E0 E0 /\ (_ -> _) ] => split; [constructor|intros _; Determ] | [ H: is_call_cont ?k |- _ ] => contradiction || (clear H; Determ) diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index ebe64533a4..c2155175b2 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -273,11 +273,11 @@ Variable do_external_function: Hypothesis do_external_function_sound: forall cp id sg ge vargs m t vres m' w w', do_external_function cp id sg ge w vargs m = Some(w', t, vres, m') -> - external_functions_sem cp id sg ge vargs m t vres m' /\ possible_trace w t w'. + external_functions_sem id sg cp ge vargs m t vres m' /\ possible_trace w t w'. Hypothesis do_external_function_complete: forall cp id sg ge vargs m t vres m' w w', - external_functions_sem cp id sg ge vargs m t vres m' -> + external_functions_sem id sg cp ge vargs m t vres m' -> possible_trace w t w' -> do_external_function cp id sg ge w vargs m = Some(w', t, vres, m'). diff --git a/cfrontend/Cstrategy.v b/cfrontend/Cstrategy.v index 21ee307288..03f3533b55 100644 --- a/cfrontend/Cstrategy.v +++ b/cfrontend/Cstrategy.v @@ -1472,7 +1472,7 @@ Qed. Remark deref_loc_receptive: forall ge cp ty m b ofs bf ev1 t1 v ev2, deref_loc ge cp ty m b ofs bf (ev1 :: t1) v -> - match_traces ge (ev1 :: nil) (ev2 :: nil) -> + match_traces wf_syscall_event ge (ev1 :: nil) (ev2 :: nil) -> t1 = nil /\ exists v', deref_loc ge cp ty m b ofs bf (ev2 :: nil) v'. Proof. intros. @@ -1492,7 +1492,7 @@ Qed. Remark assign_loc_receptive: forall ge cp ty m b ofs bf ev1 t1 v m' v' ev2, assign_loc ge cp ty m b ofs bf v (ev1 :: t1) m' v' -> - match_traces ge (ev1 :: nil) (ev2 :: nil) -> + match_traces wf_syscall_event ge (ev1 :: nil) (ev2 :: nil) -> ev1 :: t1 = ev2 :: nil. Proof. intros. diff --git a/common/Determinism.v b/common/Determinism.v index 8c6cc690ad..3f26230b6c 100644 --- a/common/Determinism.v +++ b/common/Determinism.v @@ -42,13 +42,13 @@ Require Import Behaviors. the world to [w]. *) CoInductive world: Type := - World (io: string -> list eventval -> option (eventval * world)) + World (io: string -> list eventval -> list (list byte) -> option (eventval * list (list byte) * world)) (vload: memory_chunk -> ident -> ptrofs -> option (eventval * world)) (vstore: memory_chunk -> ident -> ptrofs -> eventval -> option world). -Definition nextworld_io (w: world) (evname: string) (evargs: list eventval) : - option (eventval * world) := - match w with World io vl vs => io evname evargs end. +Definition nextworld_io (w: world) (evname: string) (evargs: list eventval) (reads : list (list byte)) : + option (eventval * list (list byte) * world) := + match w with World io vl vs => io evname evargs reads end. Definition nextworld_vload (w: world) (chunk: memory_chunk) (id: ident) (ofs: ptrofs) : option (eventval * world) := @@ -69,9 +69,9 @@ Definition nextworld_vstore (w: world) (chunk: memory_chunk) (id: ident) (ofs: p *) Inductive possible_event: world -> event -> world -> Prop := - | possible_event_syscall: forall w1 evname evargs evres w2, - nextworld_io w1 evname evargs = Some (evres, w2) -> - possible_event w1 (Event_syscall evname evargs evres) w2 + | possible_event_syscall: forall w1 evname evargs reads evres writes w2, + nextworld_io w1 evname evargs reads = Some (evres, writes, w2) -> + possible_event w1 (Event_syscall evname evargs reads evres writes) w2 | possible_event_vload: forall w1 chunk id ofs evres w2, nextworld_vload w1 chunk id ofs = Some (evres, w2) -> possible_event w1 (Event_vload chunk id ofs evres) w2 @@ -111,12 +111,12 @@ Qed. Lemma match_possible_traces: forall ge t1 t2 w0 w1 w2, - match_traces ge t1 t2 -> possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> + match_traces wf_syscall_event ge t1 t2 -> possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> t1 = t2 /\ w1 = w2. Proof. intros. inv H; inv H1; inv H0. auto. - inv H7; inv H6. inv H9; inv H10. split; congruence. + inv H6; inv H5. inv H8; inv H9. split; congruence. inv H7; inv H6. inv H9; inv H10. split; congruence. inv H4; inv H3. inv H6; inv H7. split; congruence. inv H4; inv H3. inv H7; inv H6. auto. diff --git a/common/Events.v b/common/Events.v index 2142e2c2ef..9c471fb0b8 100644 --- a/common/Events.v +++ b/common/Events.v @@ -502,73 +502,23 @@ Qed. End EVENTVAL_INJECT. -(** * Semantics of external functions *) -(** For each external function, its behavior is defined by a predicate relating: -- the global symbol environment -- the values of the arguments passed to this function -- the memory state before the call -- the result value of the call -- the memory state after the call -- the trace generated by the call (can be empty). - -*) - -Definition extcall_sem : Type := - Senv.t -> list val -> mem -> trace -> val -> mem -> Prop. - -(** Semantics of all the external functions, indexed by name and signature *) -Definition extcalls_sem: Type := - String.string -> signature -> extcall_sem. - - -(* APT: Following are dead? *) -(* (** This invariant guarantees that external calls performed to [cp] can *) -(* correctly use either [cp1] or [cp2] to find out who the calling compartment *) -(* is. *) *) -(* Definition uptodate_caller (cp cp1 cp2: compartment) := *) -(* needs_calling_comp cp = true -> *) -(* cp1 = cp2. *) - -(* Definition extcall_caller_independent (cp: compartment) (sem: extcall_sem) := *) -(* forall ge cp1 cp2 args m t v m', *) -(* uptodate_caller cp cp1 cp2 -> *) -(* sem ge cp1 args m t v m' -> *) -(* sem ge cp2 args m t v m'. *) +(** * Matching traces. *) (** To define trace matching, we need a notion of well-formed syscall events. Some system calls enforce that certain relationships hold between arguments and results; for example, a `read` call never reads more bytes than requested. When defining receptivity of a call, it only make sense to consider such well-formed events; the stronger notion of receptivity - in vanilla CompCert would fail. - - Clearly, the definition of well-formedness must depend on the particular - system call in question. It would be possible to define an independent - notion of well-formedness indexed by function id, but we instead observe - that well-formedness is a corollary of obeying the semantics of the call. - So we say that an event is well-formed if it _could_ possibly be produced - by the call behavior for _some_ choice of environment and memories. - - This makes the definition of trace equivalence, and hence statement and proof - of the generic extcall_properties, dependent on the choice of extcalls_sems. *) + in vanilla CompCert would fail. Clearly, the definition of well-formedness + must depend on the particular system call in question. *) -Inductive well_formed_syscall_event - (ecs_sem: extcalls_sem) - (id:String.string) (sg: signature) (eargs: list eventval) (reads: list (list byte)) - (eres: eventval) (writes: list (list byte)) : Prop := -| wfse_intro: forall m m' args res env, - eventval_list_match env eargs sg.(sig_args) args -> - eventval_match env eres (proj_rettype sg.(sig_res)) res -> - ecs_sem id sg env args m (Event_syscall id eargs reads eres writes :: nil) res m' -> - well_formed_syscall_event ecs_sem id sg eargs reads eres writes. - - -(** * Matching traces. *) +Definition well_formed_syscall_event_spec := + String.string -> signature -> compartment -> list eventval -> list (list byte) -> eventval -> list (list byte) -> Prop. Section MATCH_TRACES. -Variable ecs_sem: extcalls_sem. +Variable wfse: well_formed_syscall_event_spec. Variable ge: Senv.t. @@ -585,9 +535,9 @@ Inductive match_traces: trace -> trace -> Prop := eventval_valid ge res1 -> eventval_valid ge res2 -> eventval_type res1 = eventval_type res2 -> match_traces (Event_syscall id args res1 :: nil) (Event_syscall id args res2 :: nil) *) - | match_traces_syscall: forall id sg args res1 res2 reads writes1 writes2, - well_formed_syscall_event ecs_sem id sg args reads res1 writes1 -> - well_formed_syscall_event ecs_sem id sg args reads res2 writes2 -> + | match_traces_syscall: forall id sg cp args res1 res2 reads writes1 writes2, + wfse id sg cp args reads res1 writes1 -> + wfse id sg cp args reads res2 writes2 -> match_traces (Event_syscall id args reads res1 writes1 :: nil) (Event_syscall id args reads res2 writes2:: nil) | match_traces_vload: forall chunk id ofs res1 res2, eventval_valid ge res1 -> eventval_valid ge res2 -> eventval_type res1 = eventval_type res2 -> @@ -607,7 +557,7 @@ End MATCH_TRACES. Section MATCH_TRACES_INV. -Variable ecs_sem: extcalls_sem. +Variable wfse: well_formed_syscall_event_spec. Variables ge1 ge2: Senv.t. @@ -615,7 +565,7 @@ Hypothesis public_preserved: forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id. Lemma match_traces_preserved: - forall t1 t2, match_traces ecs_sem ge1 t1 t2 -> match_traces ecs_sem ge2 t1 t2. + forall t1 t2, match_traces wfse ge1 t1 t2 -> match_traces wfse ge2 t1 t2. Proof. induction 1; econstructor; try eapply eventval_valid_preserved; eauto. Qed. @@ -686,6 +636,21 @@ Inductive volatile_store (ge: Senv.t) (cp: compartment): volatile_store ge cp chunk m b ofs v E0 m'. +(** * Semantics of external functions *) + +(** For each external function, its behavior is defined by a predicate relating: +- the global symbol environment +- the values of the arguments passed to this function +- the memory state before the call +- the result value of the call +- the memory state after the call +- the trace generated by the call (can be empty). + +*) + +Definition extcall_sem : Type := + Senv.t -> list val -> mem -> trace -> val -> mem -> Prop. + (** We now specify the expected properties of the extcall_sem predicate. *) Definition loc_out_of_bounds (m: mem) (b: block) (ofs: Z) : Prop := @@ -709,7 +674,8 @@ Definition inject_separated (f f': meminj) (m1 m2: mem): Prop := f b1 = None -> f' b1 = Some(b2, delta) -> ~Mem.valid_block m1 b1 /\ ~Mem.valid_block m2 b2. -Record extcall_properties (ecs_sem: extcalls_sem) (sem: extcall_sem) (cp: compartment) (sg: signature) : Prop := +Record extcall_properties (wfse: well_formed_syscall_event_spec) + (sem: extcall_sem) (cp: compartment) (sg: signature) : Prop := mk_extcall_properties { (** The return value of an external call must agree with its signature. *) @@ -816,14 +782,14 @@ Record extcall_properties (ecs_sem: extcalls_sem) (sem: extcall_sem) (cp: compar (** External calls must be receptive to changes of traces by another, matching trace. *) ec_receptive: forall ge vargs m t1 vres1 m1 t2, - sem ge vargs m t1 vres1 m1 -> match_traces ecs_sem ge t1 t2 -> + sem ge vargs m t1 vres1 m1 -> match_traces wfse ge t1 t2 -> exists vres2, exists m2, sem ge vargs m t2 vres2 m2; (** External calls must be deterministic up to matching between traces. *) ec_determ: forall ge vargs m t1 vres1 m1 t2 vres2 m2, sem ge vargs m t1 vres1 m1 -> sem ge vargs m t2 vres2 m2 -> - match_traces ecs_sem ge t1 t2 /\ (t1 = t2 -> vres1 = vres2 /\ m1 = m2); + match_traces wfse ge t1 t2 /\ (t1 = t2 -> vres1 = vres2 /\ m1 = m2); (** External calls cannot produce [Event_call] or [Event_return] events *) ec_no_crossing: @@ -910,8 +876,8 @@ Proof. Qed. Lemma volatile_load_ok: - forall ecs_sem chunk cp , - extcall_properties ecs_sem (volatile_load_sem cp chunk) + forall wfse chunk cp , + extcall_properties wfse (volatile_load_sem cp chunk) cp (mksignature (Tptr :: nil) (rettype_of_chunk chunk) cc_default). Proof. intros; constructor; intros. @@ -1088,8 +1054,8 @@ Proof. Qed. Lemma volatile_store_ok: - forall ecs_sem cp chunk, - extcall_properties ecs_sem (volatile_store_sem cp chunk) + forall wfse cp chunk, + extcall_properties wfse (volatile_store_sem cp chunk) cp (mksignature (Tptr :: type_of_chunk chunk :: nil) Tvoid cc_default). Proof. intros; constructor; intros. @@ -1147,8 +1113,8 @@ Inductive extcall_malloc_sem (cp: compartment) (ge: Senv.t): extcall_malloc_sem cp ge (Vptrofs sz :: nil) m E0 (Vptr b Ptrofs.zero) m''. Lemma extcall_malloc_ok: - forall ecs_sem cp, - extcall_properties ecs_sem (extcall_malloc_sem cp) + forall wfse cp, + extcall_properties wfse (extcall_malloc_sem cp) cp (mksignature (Tptr :: nil) Tptr cc_default). Proof. intros. @@ -1260,8 +1226,8 @@ Inductive extcall_free_sem (cp: compartment) (ge: Senv.t): extcall_free_sem cp ge (Vnullptr :: nil) m E0 Vundef m. Lemma extcall_free_ok: - forall ecs_sem cp, - extcall_properties ecs_sem (extcall_free_sem cp) + forall wfse cp, + extcall_properties wfse (extcall_free_sem cp) cp (mksignature (Tptr :: nil) Tvoid cc_default). Proof. intros. @@ -1388,8 +1354,8 @@ Inductive extcall_memcpy_sem (cp: compartment) (sz al: Z) (ge: Senv.t): extcall_memcpy_sem cp sz al ge (Vptr bdst odst :: Vptr bsrc osrc :: nil) m E0 Vundef m'. Lemma extcall_memcpy_ok: - forall ecs_sem cp sz al, - extcall_properties ecs_sem (extcall_memcpy_sem cp sz al) + forall wfse cp sz al, + extcall_properties wfse (extcall_memcpy_sem cp sz al) cp (mksignature (Tptr :: Tptr :: nil) Tvoid cc_default). Proof. intros. constructor. @@ -1526,8 +1492,8 @@ Inductive extcall_annot_sem (cp: compartment) (text: string) (targs: list typ) ( extcall_annot_sem cp text targs ge vargs m (Event_annot text args :: E0) Vundef m. Lemma extcall_annot_ok: - forall ecs_sem cp text targs, - extcall_properties ecs_sem (extcall_annot_sem cp text targs) + forall wfse cp text targs, + extcall_properties wfse (extcall_annot_sem cp text targs) cp (mksignature targs Tvoid cc_default). Proof. intros; constructor; intros. @@ -1580,8 +1546,8 @@ Inductive extcall_annot_val_sem (cp: compartment) (text: string) (targ: typ) (ge extcall_annot_val_sem cp text targ ge (varg :: nil) m (Event_annot text (arg :: nil) :: E0) varg m. Lemma extcall_annot_val_ok: - forall ecs_sem cp text targ, - extcall_properties ecs_sem (extcall_annot_val_sem cp text targ) + forall wfse cp text targ, + extcall_properties wfse (extcall_annot_val_sem cp text targ) cp (mksignature (targ :: nil) targ cc_default). Proof. intros; constructor; intros. @@ -1633,8 +1599,8 @@ Inductive extcall_debug_sem (cp: compartment) (ge: Senv.t): extcall_debug_sem cp ge vargs m E0 Vundef m. Lemma extcall_debug_ok: - forall ecs_sem cp targs, - extcall_properties ecs_sem (extcall_debug_sem cp) + forall wfse cp targs, + extcall_properties wfse (extcall_debug_sem cp) cp (mksignature targs Tvoid cc_default). Proof. intros; constructor; intros. @@ -1691,8 +1657,8 @@ Inductive known_builtin_sem (bf: builtin_function) (ge: Senv.t): builtin_function_sem bf vargs = Some vres -> known_builtin_sem bf ge vargs m E0 vres m. -Lemma known_builtin_ok: forall ecs_sem bf cp, - extcall_properties ecs_sem (known_builtin_sem bf) cp (builtin_function_sig bf). +Lemma known_builtin_ok: forall wfse bf cp, + extcall_properties wfse (known_builtin_sem bf) cp (builtin_function_sig bf). Proof. intros. set (bsem := builtin_function_sem bf). constructor; intros. (* well typed *) @@ -1751,11 +1717,28 @@ Qed. are not described in [Builtins]. *) -Parameter external_functions_sem: compartment -> String.string -> signature -> extcall_sem. +Parameter external_functions_sem: String.string -> signature -> compartment -> extcall_sem. + +(** We say a syscall event is well-formed if it could possibly be produced by + the behavior of that call for _some_ choice of environment and memories. *) + +Inductive well_formed_syscall_event + (efs_sem: String.string -> signature -> compartment -> extcall_sem) + (id:String.string) (sg: signature) (cp: compartment) (eargs: list eventval) (reads: list (list byte)) + (eres: eventval) (writes: list (list byte)) : Prop := +| wfse_intro: forall m m' args res env, + eventval_list_match env eargs sg.(sig_args) args -> + eventval_match env eres (proj_rettype sg.(sig_res)) res -> + efs_sem id sg cp env args m (Event_syscall id eargs reads eres writes :: nil) res m' -> + well_formed_syscall_event efs_sem id sg cp eargs reads eres writes. + +Definition wf_syscall_event : well_formed_syscall_event_spec := well_formed_syscall_event external_functions_sem. Axiom external_functions_properties: - forall id sg cp, extcall_properties (external_functions_sem cp) (external_functions_sem cp id sg) cp sg. + forall id sg cp, extcall_properties wf_syscall_event (external_functions_sem id sg cp) cp sg. + +(* APT: Dead? *) (* Axiom external_functions_caller_independent: *) (* forall cp id sg, extcall_caller_independent cp (external_functions_sem id sg). *) (* Hint Resolve external_functions_caller_independent : caller_independent. *) @@ -1765,8 +1748,9 @@ Axiom external_functions_properties: Parameter inline_assembly_sem: compartment -> String.string -> signature -> extcall_sem. Axiom inline_assembly_properties: - forall cp id sg, extcall_properties (external_functions_sem cp) (inline_assembly_sem cp id sg) cp sg. + forall cp id sg, extcall_properties wf_syscall_event (inline_assembly_sem cp id sg) cp sg. +(* APT: Dead? *) (* Axiom inline_assembly_caller_independent: *) (* forall cp id sg, extcall_caller_independent cp (inline_assembly_sem id sg). *) (* Hint Resolve inline_assembly_caller_independent : caller_independent. *) @@ -1776,11 +1760,11 @@ Axiom inline_assembly_properties: Definition builtin_or_external_sem cp name sg := match lookup_builtin_function name sg with | Some bf => known_builtin_sem bf - | None => external_functions_sem cp name sg + | None => external_functions_sem name sg cp end. Lemma builtin_or_external_sem_ok: forall name sg cp, - extcall_properties (external_functions_sem cp) (builtin_or_external_sem cp name sg) cp sg. + extcall_properties wf_syscall_event (builtin_or_external_sem cp name sg) cp sg. Proof. unfold builtin_or_external_sem; intros. destruct (lookup_builtin_function name sg) as [bf|] eqn:L. @@ -1814,7 +1798,7 @@ This predicate is used in the semantics of all CompCert languages. *) Definition external_call (ef: external_function): extcall_sem := match ef with - | EF_external cp name sg => external_functions_sem cp name sg + | EF_external cp name sg => external_functions_sem name sg cp | EF_builtin cp name sg => builtin_or_external_sem cp name sg | EF_runtime cp name sg => builtin_or_external_sem cp name sg | EF_vload cp chunk => volatile_load_sem cp chunk @@ -1828,6 +1812,7 @@ Definition external_call (ef: external_function): extcall_sem := | EF_debug cp kind txt targs => extcall_debug_sem cp end. +(* APT: DEAD? *) (* Ltac external_call_caller_independent := *) (* intros ????????? CALL; *) (* inv CALL; *) @@ -1878,7 +1863,7 @@ Definition external_call (ef: external_function): extcall_sem := Theorem external_call_spec: forall ef, - extcall_properties (external_functions_sem (comp_of ef)) (external_call ef) (comp_of ef) (ef_sig ef). + extcall_properties wf_syscall_event (external_call ef) (comp_of ef) (ef_sig ef). Proof. intros. unfold external_call, ef_sig; destruct ef. apply external_functions_properties. @@ -1974,7 +1959,7 @@ Lemma external_call_match_traces: forall ef ge vargs m t1 vres1 m1 t2 vres2 m2, external_call ef ge vargs m t1 vres1 m1 -> external_call ef ge vargs m t2 vres2 m2 -> - match_traces (external_functions_sem (comp_of ef)) ge t1 t2. + match_traces wf_syscall_event ge t1 t2. Proof. intros. exploit external_call_determ. eexact H. eexact H0. tauto. Qed. @@ -2344,9 +2329,10 @@ Module SyscallSanityChecks. . - Lemma extcall_read_ok: forall (ecs_sem: extcalls_sem) (cp:compartment), - (forall sg, ecs_sem "read"%string sg = extcall_read_sem cp) -> (* a bit bogus *) - extcall_properties ecs_sem (extcall_read_sem cp) cp read_sg. + Lemma extcall_read_ok: forall (efs_sem: String.string -> signature -> compartment -> extcall_sem) + (cp:compartment), + (forall sg, efs_sem "read"%string sg = extcall_read_sem) -> (* a bit bogus *) + extcall_properties (well_formed_syscall_event efs_sem) (extcall_read_sem cp) cp read_sg. Proof. intros ec_sems cp EQ. constructor; intros. @@ -2520,7 +2506,7 @@ Module SyscallSanityChecks. - split. + inv H; inv H0; rewrite (@Senv.find_symbol_injective ge id id0 bdst); eauto; - apply match_traces_syscall with (sg := read_sg); econstructor; try rewrite EQ; repeat econstructor; eauto. + apply match_traces_syscall with (sg := read_sg) (cp:= cp); econstructor; try rewrite EQ; repeat econstructor; eauto. + intro; subst t1. inv H; inv H0; split; auto. rewrite H4 in H19. inv H19. auto. @@ -2588,9 +2574,9 @@ Proof. eapply proj_bytes_inject; eauto. Qed. -Lemma extcall_write_ok: forall (ecs_sem: extcalls_sem) (cp:compartment), - (forall sg, ecs_sem "write"%string sg = extcall_write_sem cp) -> (* a bit bogus *) - extcall_properties ecs_sem (extcall_write_sem cp) cp write_sg. +Lemma extcall_write_ok: forall (efs_sem: String.string -> signature -> compartment -> extcall_sem) (cp:compartment), + (forall sg, efs_sem "write"%string sg = extcall_write_sem) -> (* a bit bogus *) + extcall_properties (well_formed_syscall_event efs_sem) (extcall_write_sem cp) cp write_sg. Proof. intros ec_sems cp EQ. constructor; intros. @@ -2661,7 +2647,7 @@ Proof. rewrite (@Senv.find_symbol_injective ge id id0 bsrc); eauto. rewrite H3 in H12. inv H12. rewrite H4 in H17. inv H17. - apply match_traces_syscall with (sg := read_sg); econstructor; try rewrite EQ; repeat econstructor; eauto; try lia. + apply match_traces_syscall with (sg := read_sg) (cp:=cp); econstructor; try rewrite EQ; repeat econstructor; eauto; try lia. + intro; subst t1. inv H. inv H0. (* not sure what's going on here with H12! *) split; auto. f_equal. diff --git a/common/Exec.v b/common/Exec.v index 687083fcc1..459f27b2d2 100644 --- a/common/Exec.v +++ b/common/Exec.v @@ -306,11 +306,11 @@ Variable do_external_function: Hypothesis do_external_function_sound: forall cp id sg ge vargs m t vres m' w w', do_external_function cp id sg ge w vargs m = Some(w', t, vres, m') -> - external_functions_sem cp id sg ge vargs m t vres m' /\ possible_trace w t w'. + external_functions_sem id sg cp ge vargs m t vres m' /\ possible_trace w t w'. Hypothesis do_external_function_complete: forall cp id sg ge vargs m t vres m' w w', - external_functions_sem cp id sg ge vargs m t vres m' -> + external_functions_sem id sg cp ge vargs m t vres m' -> possible_trace w t w' -> do_external_function cp id sg ge w vargs m = Some(w', t, vres, m'). diff --git a/common/Smallstep.v b/common/Smallstep.v index ce60bea975..d23b4b3c76 100644 --- a/common/Smallstep.v +++ b/common/Smallstep.v @@ -1054,7 +1054,7 @@ Definition single_events (L: semantics) : Prop := Record receptive (L: semantics) : Prop := Receptive { sr_receptive: forall s t1 s1 t2, - Step L s t1 s1 -> match_traces (symbolenv L) t1 t2 -> exists s2, Step L s t2 s2; + Step L s t1 s1 -> match_traces wf_syscall_event (symbolenv L) t1 t2 -> exists s2, Step L s t2 s2; sr_traces: single_events L }. @@ -1063,7 +1063,7 @@ Record determinate (L: semantics) : Prop := Determinate { sd_determ: forall s t1 s1 t2 s2, Step L s t1 s1 -> Step L s t2 s2 -> - match_traces (symbolenv L) t1 t2 /\ (t1 = t2 -> s1 = s2); + match_traces wf_syscall_event (symbolenv L) t1 t2 /\ (t1 = t2 -> s1 = s2); sd_traces: single_events L; sd_initial_determ: forall s1 s2, @@ -1081,7 +1081,7 @@ Hypothesis DET: determinate L. Lemma sd_determ_1: forall s t1 s1 t2 s2, - Step L s t1 s1 -> Step L s t2 s2 -> match_traces (symbolenv L) t1 t2. + Step L s t1 s1 -> Step L s t2 s2 -> match_traces wf_syscall_event (symbolenv L) t1 t2. Proof. intros. eapply sd_determ; eauto. Qed. @@ -1685,10 +1685,10 @@ Lemma f2b_determinacy_inv: forall s2 t' s2' t'' s2'', Step L2 s2 t' s2' -> Step L2 s2 t'' s2'' -> (t' = E0 /\ t'' = E0 /\ s2' = s2'') - \/ (t' <> E0 /\ t'' <> E0 /\ match_traces (symbolenv L1) t' t''). + \/ (t' <> E0 /\ t'' <> E0 /\ match_traces wf_syscall_event (symbolenv L1) t' t''). Proof. intros. - assert (match_traces (symbolenv L2) t' t''). + assert (match_traces wf_syscall_event (symbolenv L2) t' t''). eapply sd_determ_1; eauto. destruct (silent_or_not_silent t'). subst. inv H1. @@ -2135,7 +2135,7 @@ Record strongly_receptive (L: semantics) : Prop := Strongly_receptive { ssr_receptive: forall s ev1 t1 s1 ev2, Step L s (ev1 :: t1) s1 -> - match_traces (symbolenv L) (ev1 :: nil) (ev2 :: nil) -> + match_traces wf_syscall_event (symbolenv L) (ev1 :: nil) (ev2 :: nil) -> exists s2, exists t2, Step L s (ev2 :: t2) s2; ssr_well_behaved: well_behaved_traces L diff --git a/riscV/Asm.v b/riscV/Asm.v index e8b7bbf796..da75e663dc 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1584,11 +1584,11 @@ Section ExecSem. Hypothesis do_external_function_sound: forall cp id sg ge vargs m t vres m' w w', do_external_function cp id sg ge w vargs m = Some(w', t, vres, m') -> - external_functions_sem cp id sg ge vargs m t vres m' /\ possible_trace w t w'. + external_functions_sem id sg cp ge vargs m t vres m' /\ possible_trace w t w'. Hypothesis do_external_function_complete: forall cp id sg ge vargs m t vres m' w w', - external_functions_sem cp id sg ge vargs m t vres m' -> + external_functions_sem id sg cp ge vargs m t vres m' -> possible_trace w t w' -> do_external_function cp id sg ge w vargs m = Some(w', t, vres, m'). From 8fb5bb568133dc0135f2e5af51c0e8f7e248654a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Thu, 16 Nov 2023 19:04:35 +0100 Subject: [PATCH 03/83] Start removing the cross-compartment calls. Remove all compartments from external functions --- common/AST.v | 111 ++++++++-------------- common/Builtins.v | 8 +- common/Builtins0.v | 21 +---- common/Events.v | 224 +++++++++++++++++++++------------------------ common/Exec.v | 124 ++++++++++++------------- common/Linking.v | 40 ++------ 6 files changed, 218 insertions(+), 310 deletions(-) diff --git a/common/AST.v b/common/AST.v index c5e8e012b1..953d9395fd 100644 --- a/common/AST.v +++ b/common/AST.v @@ -723,80 +723,71 @@ Qed. and associated operations. *) Inductive external_function : Type := - | EF_external (cp: compartment) (name: string) (sg: signature) + | EF_external (name: string) (sg: signature) (** A system call or library function. Produces an event in the trace. *) - | EF_builtin (cp: compartment) (name: string) (sg: signature) + | EF_builtin (name: string) (sg: signature) (** A compiler built-in function. Behaves like an external, but can be inlined by the compiler. *) - | EF_runtime (cp: compartment) (name: string) (sg: signature) + | EF_runtime (name: string) (sg: signature) (** A function from the run-time library. Behaves like an external, but must not be redefined. *) - | EF_vload (cp: compartment) (chunk: memory_chunk) + | EF_vload (chunk: memory_chunk) (** A volatile read operation. If the address given as first argument points within a volatile global variable, generate an event and return the value found in this event. Otherwise, produce no event and behave like a regular memory load. *) - | EF_vstore (cp: compartment) (chunk: memory_chunk) + | EF_vstore (chunk: memory_chunk) (** A volatile store operation. If the address given as first argument points within a volatile global variable, generate an event. Otherwise, produce no event and behave like a regular memory store. *) - | EF_malloc (cp: compartment) + | EF_malloc (** Dynamic memory allocation. Takes the requested size in bytes as argument; returns a pointer to a fresh block of the given size. Produces no observable event. *) - | EF_free (cp: compartment) + | EF_free (** Dynamic memory deallocation. Takes a pointer to a block allocated by an [EF_malloc] external call and frees the corresponding block. Produces no observable event. *) - | EF_memcpy (cp: compartment) (sz: Z) (al: Z) + | EF_memcpy (sz: Z) (al: Z) (** Block copy, of [sz] bytes, between addresses that are [al]-aligned. *) - | EF_annot (cp: compartment) (kind: positive) (text: string) (targs: list typ) + | EF_annot (kind: positive) (text: string) (targs: list typ) (** A programmer-supplied annotation. Takes zero, one or several arguments, produces an event carrying the text and the values of these arguments, and returns no value. *) - | EF_annot_val (cp: compartment) (kind: positive) (text: string) (targ: typ) + | EF_annot_val (kind: positive) (text: string) (targ: typ) (** Another form of annotation that takes one argument, produces an event carrying the text and the value of this argument, and returns the value of the argument. *) - | EF_inline_asm (cp: compartment) (text: string) (sg: signature) (clobbers: list string) + | EF_inline_asm (text: string) (sg: signature) (clobbers: list string) (** Inline [asm] statements. Semantically, treated like an annotation with no parameters ([EF_annot text nil]). To be used with caution, as it can invalidate the semantic preservation theorem. Generated only if [-finline-asm] is given. *) - | EF_debug (cp: compartment) (kind: positive) (text: ident) (targs: list typ). + | EF_debug (kind: positive) (text: ident) (targs: list typ). (** Transport debugging information from the front-end to the generated assembly. Takes zero, one or several arguments like [EF_annot]. Unlike [EF_annot], produces no observable event. *) -Instance has_comp_external_function : has_comp (external_function) := - fun ef => - match ef with - | EF_external cp _ _ | EF_builtin cp _ _ | EF_runtime cp _ _ - | EF_malloc cp| EF_free cp | EF_vload cp _ | EF_vstore cp _ | EF_memcpy cp _ _ - | EF_annot cp _ _ _ | EF_annot_val cp _ _ _ | EF_inline_asm cp _ _ _ - | EF_debug cp _ _ _ => cp - end. - (** The type signature of an external function. *) Definition ef_sig (ef: external_function): signature := match ef with - | EF_external _ name sg => sg - | EF_builtin _ name sg => sg - | EF_runtime _ name sg => sg - | EF_vload _ chunk => mksignature (Tptr :: nil) (rettype_of_chunk chunk) cc_default - | EF_vstore _ chunk => mksignature (Tptr :: type_of_chunk chunk :: nil) Tvoid cc_default - | EF_malloc _ => mksignature (Tptr :: nil) Tptr cc_default - | EF_free _ => mksignature (Tptr :: nil) Tvoid cc_default - | EF_memcpy _ sz al => mksignature (Tptr :: Tptr :: nil) Tvoid cc_default - | EF_annot _ kind text targs => mksignature targs Tvoid cc_default - | EF_annot_val _ kind text targ => mksignature (targ :: nil) targ cc_default - | EF_inline_asm _ text sg clob => sg - | EF_debug _ kind text targs => mksignature targs Tvoid cc_default + | EF_external name sg => sg + | EF_builtin name sg => sg + | EF_runtime name sg => sg + | EF_vload chunk => mksignature (Tptr :: nil) (rettype_of_chunk chunk) cc_default + | EF_vstore chunk => mksignature (Tptr :: type_of_chunk chunk :: nil) Tvoid cc_default + | EF_malloc => mksignature (Tptr :: nil) Tptr cc_default + | EF_free => mksignature (Tptr :: nil) Tvoid cc_default + | EF_memcpy sz al => mksignature (Tptr :: Tptr :: nil) Tvoid cc_default + | EF_annot kind text targs => mksignature targs Tvoid cc_default + | EF_annot_val kind text targ => mksignature (targ :: nil) targ cc_default + | EF_inline_asm text sg clob => sg + | EF_debug kind text targs => mksignature targs Tvoid cc_default end. @@ -804,26 +795,26 @@ Definition ef_sig (ef: external_function): signature := Definition ef_inline (ef: external_function) : bool := match ef with - | EF_external _ name sg => false - | EF_builtin _ name sg => true - | EF_runtime _ name sg => false - | EF_vload _ chunk => true - | EF_vstore _ chunk => true - | EF_malloc _ => false - | EF_free _ => false - | EF_memcpy _ sz al => true - | EF_annot _ kind text targs => true - | EF_annot_val _ kind Text rg => true - | EF_inline_asm _ text sg clob => true - | EF_debug _ kind text targs => true + | EF_external name sg => false + | EF_builtin name sg => true + | EF_runtime name sg => false + | EF_vload chunk => true + | EF_vstore chunk => true + | EF_malloc => false + | EF_free => false + | EF_memcpy sz al => true + | EF_annot kind text targs => true + | EF_annot_val kind Text rg => true + | EF_inline_asm text sg clob => true + | EF_debug kind text targs => true end. (** Whether an external function must reload its arguments. *) -Definition ef_reloads(ef: external_function) : bool := +Definition ef_reloads (ef: external_function) : bool := match ef with - | EF_annot _ kind text targs => false - | EF_debug _ kind text targs => false + | EF_annot kind text targs => false + | EF_debug kind text targs => false | _ => true end. @@ -844,13 +835,6 @@ Inductive fundef (F: Type): Type := Arguments External [F]. -Instance has_comp_fundef F {CF: has_comp F} : has_comp (fundef F) := - fun fd => - match fd with - | Internal f => comp_of f - | External ef => comp_of ef - end. - Section TRANSF_FUNDEF. Variable A B: Type. @@ -862,14 +846,6 @@ Definition transf_fundef (fd: fundef A): fundef B := | External ef => External ef end. -Global Instance comp_transf_fundef: - forall {CA: has_comp A} {CB: has_comp B} - {CAB: has_comp_transl transf}, - has_comp_transl transf_fundef. -Proof. - intros CA CB CAB [f|ef]; simpl; eauto using comp_transl. -Qed. - End TRANSF_FUNDEF. Section TRANSF_PARTIAL_FUNDEF. @@ -883,15 +859,6 @@ Definition transf_partial_fundef (fd: fundef A): res (fundef B) := | External ef => OK (External ef) end. -Global Instance comp_transf_partial_fundef: - forall {CA: has_comp A} {CB: has_comp B} - {CAB: has_comp_transl_partial transf_partial}, - has_comp_transl_partial transf_partial_fundef. -Proof. - intros CA CB CAB [f|ef] tf H; simpl in *; monadInv H; trivial. - eauto using comp_transl_partial. -Qed. - End TRANSF_PARTIAL_FUNDEF. (** * Register pairs *) diff --git a/common/Builtins.v b/common/Builtins.v index 082317571a..facff72697 100644 --- a/common/Builtins.v +++ b/common/Builtins.v @@ -36,8 +36,8 @@ Definition builtin_function_sem (b: builtin_function) : builtin_sem (sig_res (bu | BI_platform b => platform_builtin_sem b end. -Definition lookup_builtin_function (name: string) (cp: compartment) (sg: signature) : option builtin_function := - match lookup_builtin standard_builtin_sig (standard_builtin_name name cp) sg (standard_builtin_table cp) with +Definition lookup_builtin_function (name: string) (sg: signature) : option builtin_function := + match lookup_builtin standard_builtin_sig name sg standard_builtin_table with | Some b => Some (BI_standard b) | None => match lookup_builtin platform_builtin_sig name sg platform_builtin_table with @@ -46,10 +46,10 @@ Definition lookup_builtin_function (name: string) (cp: compartment) (sg: signatu end end. Lemma lookup_builtin_function_sig: - forall name cp sg b, lookup_builtin_function name cp sg = Some b -> builtin_function_sig b = sg. + forall name sg b, lookup_builtin_function name sg = Some b -> builtin_function_sig b = sg. Proof. unfold lookup_builtin_function; intros. - destruct (lookup_builtin standard_builtin_sig (standard_builtin_name name cp) sg (standard_builtin_table cp)) as [bs|] eqn:E. + destruct (lookup_builtin standard_builtin_sig name sg standard_builtin_table) as [bs|] eqn:E. inv H. simpl. eapply lookup_builtin_sig; eauto. destruct (lookup_builtin platform_builtin_sig name sg platform_builtin_table) as [bp|] eqn:E'. inv H. simpl. eapply lookup_builtin_sig; eauto. diff --git a/common/Builtins0.v b/common/Builtins0.v index 26e2746471..d192229710 100644 --- a/common/Builtins0.v +++ b/common/Builtins0.v @@ -325,9 +325,6 @@ Qed. (** Looking up builtins by name and signature *) -(* NOTE: Here we have a choice to parameterize everything by a -compartment, or just the bare minimum. Currently we go with the former *) - Section LOOKUP. Context {A: Type} (sig_of: A -> signature). @@ -386,14 +383,7 @@ Inductive standard_builtin : Type := Local Open Scope string_scope. -Fixpoint builtin_suffix (p: positive) : string := - match p with - | xI p' => String (Ascii.ascii_of_nat 73) (builtin_suffix p') - | xO p' => String (Ascii.ascii_of_nat 79) (builtin_suffix p') - | xH => String (Ascii.ascii_of_nat 72) EmptyString - end. - -Definition standard_builtin_table' : list (string * standard_builtin) := +Definition standard_builtin_table : list (string * standard_builtin) := ("__builtin_sel", BI_select Tint) :: ("__builtin_sel", BI_select Tlong) :: ("__builtin_sel", BI_select Tfloat) @@ -428,15 +418,6 @@ Definition standard_builtin_table' : list (string * standard_builtin) := :: ("__compcert_i64_utof", BI_i64_utof) :: nil. -Definition standard_builtin_name (name: string) (cp: compartment) : string := - name ++ "_" ++ builtin_suffix cp. - -Definition standard_builtin_table (cp: compartment) - : list (string * standard_builtin) := - List.map - (fun '(s, b) => (standard_builtin_name s cp, b)) - standard_builtin_table'. - Definition standard_builtin_sig (b: standard_builtin) : signature := match b with | BI_select t => diff --git a/common/Events.v b/common/Events.v index 25b0d5e114..1aa2ba3735 100644 --- a/common/Events.v +++ b/common/Events.v @@ -626,7 +626,7 @@ in extcall_caller_independent. *) Definition extcall_sem : Type := - Senv.t -> list val -> mem -> trace -> val -> mem -> Prop. + Senv.t -> compartment -> list val -> mem -> trace -> val -> mem -> Prop. (* (** This invariant guarantees that external calls performed to [cp] can *) (* correctly use either [cp1] or [cp2] to find out who the calling compartment *) @@ -670,21 +670,21 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : (** The return value of an external call must agree with its signature. *) ec_well_typed: forall ge vargs m1 t vres m2, - sem ge vargs m1 t vres m2 -> + sem ge cp vargs m1 t vres m2 -> Val.has_rettype vres sg.(sig_res); (** The semantics is invariant under change of global environment that preserves symbols. *) ec_symbols_preserved: forall ge1 ge2 vargs m1 t vres m2, Senv.equiv ge1 ge2 -> - sem ge1 vargs m1 t vres m2 -> - sem ge2 vargs m1 t vres m2; + sem ge1 cp vargs m1 t vres m2 -> + sem ge2 cp vargs m1 t vres m2; (** External calls cannot invalidate memory blocks. (Remember that freeing a block does not invalidate its block identifier.) *) ec_valid_block: forall ge vargs m1 t vres m2 b, - sem ge vargs m1 t vres m2 -> + sem ge cp vargs m1 t vres m2 -> Mem.valid_block m1 b -> Mem.valid_block m2 b; (** External calls cannot change the ownership of memory blocks. @@ -692,50 +692,51 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : notion of [can_access_block] must be completely changed anyway *) ec_can_access_block: - forall ge vargs m1 t vres m2 b cp, - sem ge vargs m1 t vres m2 -> - Mem.can_access_block m1 b cp -> Mem.can_access_block m2 b cp; + forall ge vargs m1 t vres m2 b ocp, + sem ge cp vargs m1 t vres m2 -> + Mem.can_access_block m1 b ocp -> Mem.can_access_block m2 b ocp; (** External calls cannot increase the max permissions of a valid block. They can decrease the max permissions, e.g. by freeing. *) ec_max_perm: forall ge vargs m1 t vres m2 b ofs p, - sem ge vargs m1 t vres m2 -> + sem ge cp vargs m1 t vres m2 -> Mem.valid_block m1 b -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p; (** External call cannot modify memory unless they have [Max, Writable] permissions. *) ec_readonly: - forall ge vargs m1 t vres m2 b ofs n bytes cp, - sem ge vargs m1 t vres m2 -> + forall ge vargs m1 t vres m2 b ofs n bytes ocp, + sem ge cp vargs m1 t vres m2 -> Mem.valid_block m1 b -> - Mem.loadbytes m2 b ofs n cp = Some bytes -> + Mem.loadbytes m2 b ofs n ocp = Some bytes -> (forall i, ofs <= i < ofs + n -> ~Mem.perm m1 b i Max Writable) -> - Mem.loadbytes m1 b ofs n cp = Some bytes; + Mem.loadbytes m1 b ofs n ocp = Some bytes; (** External call can only allocate in the calling compartment *) ec_new_valid: forall ge vargs m1 t vres m2 b, - sem ge vargs m1 t vres m2 -> + sem ge cp vargs m1 t vres m2 -> ~ Mem.valid_block m1 b -> Mem.valid_block m2 b -> Mem.block_compartment m2 b = Some cp; (** TODO: External call should not be able to modify other compartment's memory *) +(** TODO: Is this an acceptable axiom? *) ec_mem_outside_compartment: forall ge vargs m1 t vres m2, - sem ge vargs m1 t vres m2 -> + sem ge cp vargs m1 t vres m2 -> Mem.unchanged_on (loc_not_in_compartment cp m1) m1 m2; (** External calls must commute with memory extensions, in the following sense. *) ec_mem_extends: forall ge vargs m1 t vres m2 m1' vargs', - sem ge vargs m1 t vres m2 -> + sem ge cp vargs m1 t vres m2 -> Mem.extends m1 m1' -> Val.lessdef_list vargs vargs' -> exists vres', exists m2', - sem ge vargs' m1' t vres' m2' + sem ge cp vargs' m1' t vres' m2' /\ Val.lessdef vres vres' /\ Mem.extends m2 m2' /\ Mem.unchanged_on (loc_out_of_bounds m1) m1' m2'; @@ -745,18 +746,18 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : ec_mem_inject: forall ge1 ge2 vargs m1 t vres m2 f m1' vargs', symbols_inject f ge1 ge2 -> - sem ge1 vargs m1 t vres m2 -> + sem ge1 cp vargs m1 t vres m2 -> Mem.inject f m1 m1' -> Val.inject_list f vargs vargs' -> exists f', exists vres', exists m2', - sem ge2 vargs' m1' t vres' m2' + sem ge2 cp 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' /\ - (* TODO: redundancy with [ec_new_valid]? *) + (* TODO: is this a redundancy with [ec_new_valid]? *) (forall b, ~ Mem.valid_block m1 b -> Mem.valid_block m2 b -> @@ -766,24 +767,24 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : (** External calls produce at most one event. *) ec_trace_length: forall ge vargs m t vres m', - sem ge vargs m t vres m' -> (length t <= 1)%nat; + sem ge cp vargs m t vres m' -> (length t <= 1)%nat; (** External calls must be receptive to changes of traces by another, matching trace. *) ec_receptive: forall ge vargs m t1 vres1 m1 t2, - sem ge vargs m t1 vres1 m1 -> match_traces ge t1 t2 -> - exists vres2, exists m2, sem ge vargs m t2 vres2 m2; + sem ge cp vargs m t1 vres1 m1 -> match_traces ge t1 t2 -> + exists vres2, exists m2, sem ge cp vargs m t2 vres2 m2; (** External calls must be deterministic up to matching between traces. *) ec_determ: forall ge vargs m t1 vres1 m1 t2 vres2 m2, - sem ge vargs m t1 vres1 m1 -> sem ge vargs m t2 vres2 m2 -> + sem ge cp vargs m t1 vres1 m1 -> sem ge cp vargs m t2 vres2 m2 -> match_traces ge t1 t2 /\ (t1 = t2 -> vres1 = vres2 /\ m1 = m2); (** External calls cannot produce [Event_call] or [Event_return] events *) ec_no_crossing: forall ge vargs m t vres m', - sem ge vargs m t vres m' -> + sem ge cp vargs m t vres m' -> match t with | Event_call _ _ _ _ :: _ | Event_return _ _ _ :: _ => False @@ -793,11 +794,11 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : (** ** Semantics of volatile loads *) -Inductive volatile_load_sem (cp: compartment) (chunk: memory_chunk) (ge: Senv.t) : +Inductive volatile_load_sem (chunk: memory_chunk) (ge: Senv.t) (cp: compartment) : list val -> mem -> trace -> val -> mem -> Prop := | volatile_load_sem_intro: forall b ofs m t v, volatile_load ge cp chunk m b ofs t v -> - volatile_load_sem cp chunk ge (Vptr b ofs :: nil) m t v m. + volatile_load_sem chunk ge cp (Vptr b ofs :: nil) m t v m. Lemma volatile_load_preserved: forall ge1 ge2 cp chunk m b ofs t v, @@ -866,7 +867,7 @@ Qed. Lemma volatile_load_ok: forall chunk cp, - extcall_properties (volatile_load_sem cp chunk) + extcall_properties (volatile_load_sem chunk) cp (mksignature (Tptr :: nil) (rettype_of_chunk chunk) cc_default). Proof. intros; constructor; intros. @@ -920,11 +921,11 @@ Qed. (* JT: Note: Same remarks as for volatile loads *) -Inductive volatile_store_sem (cp: compartment) (chunk: memory_chunk)(ge: Senv.t): +Inductive volatile_store_sem (chunk: memory_chunk) (ge: Senv.t) (cp: compartment): list val -> mem -> trace -> val -> mem -> Prop := | volatile_store_sem_intro: forall b ofs m1 v t m2, volatile_store ge cp chunk m1 b ofs v t m2 -> - volatile_store_sem cp chunk ge (Vptr b ofs :: v :: nil) m1 t Vundef m2. + volatile_store_sem chunk ge cp (Vptr b ofs :: v :: nil) m1 t Vundef m2. Lemma volatile_store_preserved: forall ge1 ge2 cp chunk m1 b ofs v t m2, @@ -1044,7 +1045,7 @@ Qed. Lemma volatile_store_ok: forall cp chunk, - extcall_properties (volatile_store_sem cp chunk) + extcall_properties (volatile_store_sem chunk) cp (mksignature (Tptr :: type_of_chunk chunk :: nil) Tvoid cc_default). Proof. intros; constructor; intros. @@ -1094,16 +1095,16 @@ Qed. (* JT: NOTE: Same remarks as for volatile loads and stores *) -Inductive extcall_malloc_sem (cp: compartment) (ge: Senv.t): +Inductive extcall_malloc_sem (ge: Senv.t) (cp: compartment): list val -> mem -> trace -> val -> mem -> Prop := | extcall_malloc_sem_intro: forall sz m m' b m'', Mem.alloc m cp (- size_chunk Mptr) (Ptrofs.unsigned sz) = (m', b) -> Mem.store Mptr m' b (- size_chunk Mptr) (Vptrofs sz) cp = Some m'' -> - extcall_malloc_sem cp ge (Vptrofs sz :: nil) m E0 (Vptr b Ptrofs.zero) m''. + extcall_malloc_sem ge cp (Vptrofs sz :: nil) m E0 (Vptr b Ptrofs.zero) m''. Lemma extcall_malloc_ok: forall cp, - extcall_properties (extcall_malloc_sem cp) + extcall_properties (extcall_malloc_sem) cp (mksignature (Tptr :: nil) Tptr cc_default). Proof. intros. @@ -1204,19 +1205,19 @@ Qed. (* JT: NOTE: Same remarks as before. *) -Inductive extcall_free_sem (cp: compartment) (ge: Senv.t): +Inductive extcall_free_sem (ge: Senv.t) (cp: compartment): list val -> mem -> trace -> val -> mem -> Prop := | extcall_free_sem_ptr: forall b lo sz m m', Mem.load Mptr m b (Ptrofs.unsigned lo - size_chunk Mptr) (Some cp) = Some (Vptrofs sz) -> Ptrofs.unsigned sz > 0 -> Mem.free m b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz) cp = Some m' -> - extcall_free_sem cp ge (Vptr b lo :: nil) m E0 Vundef m' + extcall_free_sem ge cp (Vptr b lo :: nil) m E0 Vundef m' | extcall_free_sem_null: forall m, - extcall_free_sem cp ge (Vnullptr :: nil) m E0 Vundef m. + extcall_free_sem ge cp (Vnullptr :: nil) m E0 Vundef m. Lemma extcall_free_ok: forall cp, - extcall_properties (extcall_free_sem cp) + extcall_properties extcall_free_sem cp (mksignature (Tptr :: nil) Tvoid cc_default). Proof. intros. @@ -1329,7 +1330,7 @@ Qed. (* RB: NOTE: This operation seems particularly interesting in the sense that it copies between two blocks, and their respective ownerships must agree. *) -Inductive extcall_memcpy_sem (cp: compartment) (sz al: Z) (ge: Senv.t): +Inductive extcall_memcpy_sem (sz al: Z) (ge: Senv.t) (cp: compartment): list val -> mem -> trace -> val -> mem -> Prop := | extcall_memcpy_sem_intro: forall bdst odst bsrc osrc m bytes m', al = 1 \/ al = 2 \/ al = 4 \/ al = 8 -> sz >= 0 -> (al | sz) -> @@ -1340,11 +1341,11 @@ Inductive extcall_memcpy_sem (cp: compartment) (sz al: Z) (ge: Senv.t): \/ Ptrofs.unsigned odst + sz <= Ptrofs.unsigned osrc -> Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz (Some cp) = Some bytes -> Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes cp = Some m' -> - extcall_memcpy_sem cp sz al ge (Vptr bdst odst :: Vptr bsrc osrc :: nil) m E0 Vundef m'. + extcall_memcpy_sem sz al ge cp (Vptr bdst odst :: Vptr bsrc osrc :: nil) m E0 Vundef m'. Lemma extcall_memcpy_ok: forall cp sz al, - extcall_properties (extcall_memcpy_sem cp sz al) + extcall_properties (extcall_memcpy_sem sz al) cp (mksignature (Tptr :: Tptr :: nil) Tvoid cc_default). Proof. intros. constructor. @@ -1474,15 +1475,15 @@ Qed. (* JT: NOTE: Same as before *) -Inductive extcall_annot_sem (cp: compartment) (text: string) (targs: list typ) (ge: Senv.t): +Inductive extcall_annot_sem (text: string) (targs: list typ) (ge: Senv.t) (cp: compartment): list val -> mem -> trace -> val -> mem -> Prop := | extcall_annot_sem_intro: forall vargs m args, eventval_list_match ge args targs vargs -> - extcall_annot_sem cp text targs ge vargs m (Event_annot text args :: E0) Vundef m. + extcall_annot_sem text targs ge cp vargs m (Event_annot text args :: E0) Vundef m. Lemma extcall_annot_ok: forall cp text targs, - extcall_properties (extcall_annot_sem cp text targs) + extcall_properties (extcall_annot_sem text targs) cp (mksignature targs Tvoid cc_default). Proof. intros; constructor; intros. @@ -1528,15 +1529,15 @@ Proof. - inv H; simpl; auto. Qed. -Inductive extcall_annot_val_sem (cp: compartment) (text: string) (targ: typ) (ge: Senv.t): +Inductive extcall_annot_val_sem (text: string) (targ: typ) (ge: Senv.t) (cp: compartment): list val -> mem -> trace -> val -> mem -> Prop := | extcall_annot_val_sem_intro: forall varg m arg, eventval_match ge arg targ varg -> - extcall_annot_val_sem cp text targ ge (varg :: nil) m (Event_annot text (arg :: nil) :: E0) varg m. + extcall_annot_val_sem text targ ge cp (varg :: nil) m (Event_annot text (arg :: nil) :: E0) varg m. Lemma extcall_annot_val_ok: forall cp text targ, - extcall_properties (extcall_annot_val_sem cp text targ) + extcall_properties (extcall_annot_val_sem text targ) cp (mksignature (targ :: nil) targ cc_default). Proof. intros; constructor; intros. @@ -1582,14 +1583,14 @@ Proof. - inv H; simpl; auto. Qed. -Inductive extcall_debug_sem (cp: compartment) (ge: Senv.t): +Inductive extcall_debug_sem (ge: Senv.t) (cp: compartment): list val -> mem -> trace -> val -> mem -> Prop := | extcall_debug_sem_intro: forall vargs m, - extcall_debug_sem cp ge vargs m E0 Vundef m. + extcall_debug_sem ge cp vargs m E0 Vundef m. Lemma extcall_debug_ok: forall cp targs, - extcall_properties (extcall_debug_sem cp) + extcall_properties extcall_debug_sem cp (mksignature targs Tvoid cc_default). Proof. intros; constructor; intros. @@ -1640,11 +1641,11 @@ Qed. as defined in the [Builtin] modules. These built-in functions have no observable effects and do not access memory. *) -Inductive known_builtin_sem (bf: builtin_function) (ge: Senv.t): +Inductive known_builtin_sem (bf: builtin_function) (ge: Senv.t) (cp: compartment): list val -> mem -> trace -> val -> mem -> Prop := | known_builtin_sem_intro: forall vargs vres m, builtin_function_sem bf vargs = Some vres -> - known_builtin_sem bf ge vargs m E0 vres m. + known_builtin_sem bf ge cp vargs m E0 vres m. Lemma known_builtin_ok: forall bf cp, extcall_properties (known_builtin_sem bf) cp (builtin_function_sig bf). @@ -1706,56 +1707,36 @@ Qed. are not described in [Builtins]. *) -Parameter external_functions_sem: compartment -> String.string -> signature -> extcall_sem. +Parameter external_functions_sem: String.string -> signature -> extcall_sem. Axiom external_functions_properties: - forall id sg cp, extcall_properties (external_functions_sem cp id sg) cp sg. - -(* Axiom external_functions_caller_independent: *) -(* forall cp id sg, extcall_caller_independent cp (external_functions_sem id sg). *) -(* Hint Resolve external_functions_caller_independent : caller_independent. *) + forall id sg cp, extcall_properties (external_functions_sem id sg) cp sg. (** We treat inline assembly similarly. *) -Parameter inline_assembly_sem: compartment -> String.string -> signature -> extcall_sem. +Parameter inline_assembly_sem: String.string -> signature -> extcall_sem. Axiom inline_assembly_properties: - forall cp id sg, extcall_properties (inline_assembly_sem cp id sg) cp sg. - -(* Axiom inline_assembly_caller_independent: *) -(* forall cp id sg, extcall_caller_independent cp (inline_assembly_sem id sg). *) -(* Hint Resolve inline_assembly_caller_independent : caller_independent. *) + forall cp id sg, extcall_properties (inline_assembly_sem id sg) cp sg. (** ** Combined semantics of external calls *) -Definition builtin_or_external_sem name cp sg := - match lookup_builtin_function name cp sg with +Definition builtin_or_external_sem name sg := + match lookup_builtin_function name sg with | Some bf => known_builtin_sem bf - | None => external_functions_sem cp name sg + | None => external_functions_sem name sg end. -Lemma builtin_or_external_sem_ok: forall name sg cp, - extcall_properties (builtin_or_external_sem name cp sg) cp sg. +Lemma builtin_or_external_sem_ok: forall cp name sg, + extcall_properties (builtin_or_external_sem name sg) cp sg. Proof. unfold builtin_or_external_sem; intros. - destruct (lookup_builtin_function name cp sg) as [bf|] eqn:L. + destruct (lookup_builtin_function name sg) as [bf|] eqn:L. - exploit lookup_builtin_function_sig; eauto. intros EQ; subst sg. apply known_builtin_ok. - apply external_functions_properties. Qed. -(* Lemma builtin_or_external_caller_independent: *) -(* forall cp name sg, *) -(* extcall_caller_independent cp (builtin_or_external_sem name sg). *) -(* Proof. *) -(* unfold builtin_or_external_sem. *) -(* intros cp name sg. *) -(* destruct (lookup_builtin_function name sg). *) -(* - now intros ????????? H; inv H; constructor. *) -(* - now apply external_functions_caller_independent. *) -(* Qed. *) -(* Hint Resolve builtin_or_external_caller_independent : caller_independent. *) - (** Combining the semantics given above for the various kinds of external calls, we define the predicate [external_call] that relates: - the external function being invoked @@ -1769,18 +1750,18 @@ This predicate is used in the semantics of all CompCert languages. *) Definition external_call (ef: external_function): extcall_sem := match ef with - | EF_external cp name sg => external_functions_sem cp name sg - | EF_builtin cp name sg => builtin_or_external_sem name cp sg - | EF_runtime cp name sg => builtin_or_external_sem name cp 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_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 cp kind txt targs => extcall_debug_sem cp + | EF_external name sg => external_functions_sem name sg + | EF_builtin name sg => builtin_or_external_sem name sg + | EF_runtime name sg => builtin_or_external_sem name sg + | EF_vload chunk => volatile_load_sem chunk + | EF_vstore chunk => volatile_store_sem chunk + | EF_malloc => extcall_malloc_sem + | EF_free => extcall_free_sem + | EF_memcpy sz al => extcall_memcpy_sem sz al + | EF_annot kind txt targs => extcall_annot_sem txt targs + | EF_annot_val kind txt targ => extcall_annot_val_sem txt targ + | EF_inline_asm txt sg clb => inline_assembly_sem txt sg + | EF_debug kind txt targs => extcall_debug_sem end. Ltac external_call_caller_independent := @@ -1832,8 +1813,8 @@ Ltac external_call_caller_independent := (* Qed. *) Theorem external_call_spec: - forall ef, - extcall_properties (external_call ef) (comp_of ef) (ef_sig ef). + forall ef cp, + extcall_properties (external_call ef) cp (ef_sig ef). Proof. intros. unfold external_call, ef_sig; destruct ef. apply external_functions_properties. @@ -1850,23 +1831,23 @@ Proof. apply extcall_debug_ok. Qed. -Definition external_call_well_typed_gen ef := ec_well_typed (external_call_spec ef). -Definition external_call_symbols_preserved ef := ec_symbols_preserved (external_call_spec ef). -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_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). -Definition external_call_trace_length ef := ec_trace_length (external_call_spec ef). -Definition external_call_receptive ef := ec_receptive (external_call_spec ef). -Definition external_call_determ ef := ec_determ (external_call_spec ef). +Definition external_call_well_typed_gen ef cp := ec_well_typed (external_call_spec ef cp). +Definition external_call_symbols_preserved ef cp := ec_symbols_preserved (external_call_spec ef cp). +Definition external_call_valid_block ef cp := ec_valid_block (external_call_spec ef cp). +Definition external_call_can_access_block ef cp := ec_can_access_block (external_call_spec ef cp). +Definition external_call_max_perm ef cp := ec_max_perm (external_call_spec ef cp). +Definition external_call_readonly ef cp := ec_readonly (external_call_spec ef cp). +Definition external_call_mem_extends ef cp := ec_mem_extends (external_call_spec ef cp). +Definition external_call_mem_inject_gen ef cp := ec_mem_inject (external_call_spec ef cp). +Definition external_call_trace_length ef cp := ec_trace_length (external_call_spec ef cp). +Definition external_call_receptive ef cp := ec_receptive (external_call_spec ef cp). +Definition external_call_determ ef cp := ec_determ (external_call_spec ef cp). (** Corollary of [external_call_well_typed_gen]. *) Lemma external_call_well_typed: - forall ef ge vargs m1 t vres m2, - external_call ef ge vargs m1 t vres m2 -> + forall ef ge cp vargs m1 t vres m2, + external_call ef ge cp vargs m1 t vres m2 -> Val.has_type vres (proj_sig_res (ef_sig ef)). Proof. intros. apply Val.has_proj_rettype. eapply external_call_well_typed_gen; eauto. @@ -1875,8 +1856,8 @@ Qed. (** Corollary of [external_call_valid_block]. *) Lemma external_call_nextblock: - forall ef ge vargs m1 t vres m2, - external_call ef ge vargs m1 t vres m2 -> + forall ef ge cp vargs m1 t vres m2, + external_call ef ge cp vargs m1 t vres m2 -> Ple (Mem.nextblock m1) (Mem.nextblock m2). Proof. intros. destruct (plt (Mem.nextblock m2) (Mem.nextblock m1)). @@ -1893,13 +1874,13 @@ Definition meminj_preserves_globals (F V: Type) (ge: Genv.t F V) (f: block -> op /\ (forall b1 b2 delta gv, Genv.find_var_info ge b2 = Some gv -> f b1 = Some(b2, delta) -> b2 = b1). Lemma external_call_mem_inject: - forall ef F V (ge: Genv.t F V) vargs m1 t vres m2 f m1' vargs', + forall ef F V (ge: Genv.t F V) cp vargs m1 t vres m2 f m1' vargs', meminj_preserves_globals ge f -> - external_call ef ge vargs m1 t vres m2 -> + external_call ef ge cp vargs m1 t vres m2 -> Mem.inject f m1 m1' -> Val.inject_list f vargs vargs' -> exists f', exists vres', exists m2', - external_call ef ge vargs' m1' t vres' m2' + external_call ef ge cp vargs' m1' t vres' m2' /\ Val.inject f' vres vres' /\ Mem.inject f' m2 m2' /\ Mem.unchanged_on (loc_unmapped f) m1 m2 @@ -1909,7 +1890,7 @@ Lemma external_call_mem_inject: /\ (forall b : block, ~ Mem.valid_block m1 b -> Mem.valid_block m2 b -> - exists b' : block, f' b = Some (b', 0) /\ Mem.block_compartment m2 b = Some (comp_of ef)). + exists b' : block, f' b = Some (b', 0) /\ Mem.block_compartment m2 b = Some cp). Proof. intros. destruct H as (A & B & C). eapply external_call_mem_inject_gen with (ge1 := ge); eauto. repeat split; intros. @@ -1926,18 +1907,18 @@ Qed. (** Corollaries of [external_call_determ]. *) Lemma external_call_match_traces: - forall ef ge vargs m t1 vres1 m1 t2 vres2 m2, - external_call ef ge vargs m t1 vres1 m1 -> - external_call ef ge vargs m t2 vres2 m2 -> + forall ef ge cp vargs m t1 vres1 m1 t2 vres2 m2, + external_call ef ge cp vargs m t1 vres1 m1 -> + external_call ef ge cp vargs m t2 vres2 m2 -> match_traces ge t1 t2. Proof. intros. exploit external_call_determ. eexact H. eexact H0. tauto. Qed. Lemma external_call_deterministic: - forall ef ge vargs m t vres1 m1 vres2 m2, - external_call ef ge vargs m t vres1 m1 -> - external_call ef ge vargs m t vres2 m2 -> + forall ef ge cp vargs m t vres1 m1 vres2 m2, + external_call ef ge cp vargs m t vres1 m1 -> + external_call ef ge cp vargs m t vres2 m2 -> vres1 = vres2 /\ m1 = m2. Proof. intros. exploit external_call_determ. eexact H. eexact H0. intuition. @@ -1949,6 +1930,7 @@ Section EVAL_BUILTIN_ARG. Variable A: Type. Variable ge: Senv.t. +Variable cp: compartment. Variable e: A -> val. Variable sp: val. Variable m: mem. diff --git a/common/Exec.v b/common/Exec.v index 660bf538d1..6cf75f68ca 100644 --- a/common/Exec.v +++ b/common/Exec.v @@ -301,54 +301,54 @@ Qed. (** External calls *) Variable do_external_function: - compartment -> string -> signature -> Senv.t -> world -> list val -> mem -> option (world * trace * val * mem). + string -> signature -> Senv.t -> compartment -> world -> list val -> mem -> option (world * trace * val * mem). Hypothesis do_external_function_sound: - forall cp id sg ge vargs m t vres m' w w', - do_external_function cp id sg ge w vargs m = Some(w', t, vres, m') -> - external_functions_sem cp id sg ge vargs m t vres m' /\ possible_trace w t w'. + forall id sg ge cp vargs m t vres m' w w', + do_external_function id sg ge cp w vargs m = Some(w', t, vres, m') -> + external_functions_sem id sg ge cp vargs m t vres m' /\ possible_trace w t w'. Hypothesis do_external_function_complete: - forall cp id sg ge vargs m t vres m' w w', - external_functions_sem cp id sg ge vargs m t vres m' -> + forall id sg ge cp vargs m t vres m' w w', + external_functions_sem id sg ge cp vargs m t vres m' -> possible_trace w t w' -> - do_external_function cp id sg ge w vargs m = Some(w', t, vres, m'). + do_external_function id sg ge cp w vargs m = Some(w', t, vres, m'). Variable do_inline_assembly: - compartment -> string -> signature -> Senv.t -> world -> list val -> mem -> option (world * trace * val * mem). + string -> signature -> Senv.t -> compartment -> world -> list val -> mem -> option (world * trace * val * mem). Hypothesis do_inline_assembly_sound: - forall cp txt sg ge vargs m t vres m' w w', - do_inline_assembly cp txt sg ge w vargs m = Some(w', t, vres, m') -> - inline_assembly_sem cp txt sg ge vargs m t vres m' /\ possible_trace w t w'. + forall txt sg ge cp vargs m t vres m' w w', + do_inline_assembly txt sg ge cp w vargs m = Some(w', t, vres, m') -> + inline_assembly_sem txt sg ge cp vargs m t vres m' /\ possible_trace w t w'. Hypothesis do_inline_assembly_complete: - forall cp txt sg ge vargs m t vres m' w w', - inline_assembly_sem cp txt sg ge vargs m t vres m' -> + forall txt sg ge cp vargs m t vres m' w w', + inline_assembly_sem txt sg ge cp vargs m t vres m' -> possible_trace w t w' -> - do_inline_assembly cp txt sg ge w vargs m = Some(w', t, vres, m'). + do_inline_assembly txt sg ge cp w vargs m = Some(w', t, vres, m'). -Definition do_ef_volatile_load (cp: compartment) (chunk: memory_chunk) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := +Definition do_ef_volatile_load (chunk: memory_chunk) + (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match vargs with | Vptr b ofs :: nil => do w',t,v <- do_volatile_load w chunk cp m b ofs; Some(w',t,v,m) | _ => None end. -Definition do_ef_volatile_store (cp: compartment) (chunk: memory_chunk) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := +Definition do_ef_volatile_store (chunk: memory_chunk) + (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match vargs with | Vptr b ofs :: v :: nil => do w',t,m',v' <- do_volatile_store w chunk cp m b ofs v; Some(w',t,Vundef,m') | _ => None end. -Definition do_ef_volatile_load_global (cp: compartment) (chunk: memory_chunk) (id: ident) (ofs: ptrofs) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - do b <- Genv.find_symbol ge id; do_ef_volatile_load cp chunk w (Vptr b ofs :: vargs) m. +Definition do_ef_volatile_load_global (chunk: memory_chunk) (id: ident) (ofs: ptrofs) + (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + do b <- Genv.find_symbol ge id; do_ef_volatile_load chunk cp w (Vptr b ofs :: vargs) m. -Definition do_ef_volatile_store_global (cp: compartment) (chunk: memory_chunk) (id: ident) (ofs: ptrofs) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - do b <- Genv.find_symbol ge id; do_ef_volatile_store cp chunk w (Vptr b ofs :: vargs) m. +Definition do_ef_volatile_store_global (chunk: memory_chunk) (id: ident) (ofs: ptrofs) + (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + do b <- Genv.find_symbol ge id; do_ef_volatile_store chunk cp w (Vptr b ofs :: vargs) m. Definition do_alloc_size (v: val) : option ptrofs := match v with @@ -396,8 +396,8 @@ Definition memcpy_args_ok /\ (sz > 0 -> (al | odst)) /\ (bsrc <> bdst \/ osrc = odst \/ osrc + sz <= odst \/ odst + sz <= osrc). -Definition do_ef_memcpy (cp: compartment) (sz al: Z) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := +Definition do_ef_memcpy (sz al: Z) + (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match vargs with | Vptr bdst odst :: Vptr bsrc osrc :: nil => if decide (memcpy_args_ok sz al bdst (Ptrofs.unsigned odst) bsrc (Ptrofs.unsigned osrc)) then @@ -408,13 +408,13 @@ Definition do_ef_memcpy (cp: compartment) (sz al: Z) | _ => None end. -Definition do_ef_annot (cp: compartment) (text: string) (targs: list typ) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := +Definition do_ef_annot (text: string) (targs: list typ) + (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := do args <- list_eventval_of_val vargs targs; Some(w, Event_annot text args :: E0, Vundef, m). -Definition do_ef_annot_val (cp: compartment) (text: string) (targ: typ) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := +Definition do_ef_annot_val (text: string) (targ: typ) + (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match vargs with | varg :: nil => do arg <- eventval_of_val varg targ; @@ -422,48 +422,48 @@ Definition do_ef_annot_val (cp: compartment) (text: string) (targ: typ) | _ => None end. -Definition do_ef_debug (cp: compartment) (kind: positive) (text: ident) (targs: list typ) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := +Definition do_ef_debug (kind: positive) (text: ident) (targs: list typ) + (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := Some(w, E0, Vundef, m). -Definition do_builtin_or_external (name: string) (cp: compartment) (sg: signature) +Definition do_builtin_or_external (name: string) (sg: signature) (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - match lookup_builtin_function name cp sg with + match lookup_builtin_function name sg with | Some bf => match builtin_function_sem bf vargs with Some v => Some(w, E0, v, m) | None => None end - | None => do_external_function cp name sg ge w vargs m + | None => do_external_function name sg ge cp w vargs m end. Definition do_external (ef: external_function): - world -> list val -> mem -> option (world * trace * val * mem) := + compartment -> world -> list val -> mem -> option (world * trace * val * mem) := match ef with - | EF_external cp name sg => do_external_function cp name sg ge - | EF_builtin cp name sg => do_builtin_or_external name cp sg - | EF_runtime cp name sg => do_builtin_or_external name cp sg - | EF_vload cp chunk => do_ef_volatile_load cp chunk - | EF_vstore cp chunk => do_ef_volatile_store cp chunk - | EF_malloc cp => do_ef_malloc cp - | EF_free cp => do_ef_free cp - | EF_memcpy cp sz al => do_ef_memcpy cp sz al - | EF_annot cp kind text targs => do_ef_annot cp text targs - | EF_annot_val cp kind text targ => do_ef_annot_val cp text targ - | EF_inline_asm cp text sg clob => do_inline_assembly cp text sg ge - | EF_debug cp kind text targs => do_ef_debug cp kind text targs + | EF_external name sg => do_external_function name sg ge + | EF_builtin name sg => do_builtin_or_external name sg + | EF_runtime name sg => do_builtin_or_external name sg + | EF_vload chunk => do_ef_volatile_load chunk + | EF_vstore chunk => do_ef_volatile_store chunk + | EF_malloc => do_ef_malloc + | EF_free => do_ef_free + | EF_memcpy sz al => do_ef_memcpy sz al + | EF_annot kind text targs => do_ef_annot text targs + | EF_annot_val kind text targ => do_ef_annot_val text targ + | EF_inline_asm text sg clob => do_inline_assembly text sg ge + | EF_debug kind text targs => do_ef_debug kind text targs end. Lemma do_ef_external_sound: - forall ef w vargs m w' t vres m', - do_external ef w vargs m = Some(w', t, vres, m') -> - external_call ef ge vargs m t vres m' /\ possible_trace w t w'. + forall ef cp w vargs m w' t vres m', + do_external ef cp w vargs m = Some(w', t, vres, m') -> + external_call ef ge cp vargs m t vres m' /\ possible_trace w t w'. Proof with try congruence. intros until m'. assert (SIZE: forall v sz, do_alloc_size v = Some sz -> v = Vptrofs sz). { intros until sz; unfold Vptrofs; destruct v; simpl; destruct Archi.ptr64 eqn:SF; intros EQ; inv EQ; f_equal; symmetry; eauto with ptrofs. } - assert (BF_EX: forall name cp sg, - do_builtin_or_external name cp sg w vargs m = Some (w', t, vres, m') -> - builtin_or_external_sem name cp sg ge vargs m t vres m' /\ possible_trace w t w'). + assert (BF_EX: forall name sg, + do_builtin_or_external name sg cp w vargs m = Some (w', t, vres, m') -> + builtin_or_external_sem name sg ge cp vargs m t vres m' /\ possible_trace w t w'). { unfold do_builtin_or_external, builtin_or_external_sem; intros. - destruct (lookup_builtin_function name cp sg ) as [bf|]. + destruct (lookup_builtin_function name sg ) as [bf|]. - destruct (builtin_function_sem bf vargs) as [vres1|] eqn:BF; inv H. split. constructor; auto. constructor. - eapply do_external_function_sound; eauto. @@ -518,20 +518,20 @@ Proof with try congruence. Qed. Lemma do_ef_external_complete: - forall ef w vargs m w' t vres m', - external_call ef ge vargs m t vres m' -> possible_trace w t w' -> - do_external ef w vargs m = Some(w', t, vres, m'). + forall ef cp w vargs m w' t vres m', + external_call ef ge cp vargs m t vres m' -> possible_trace w t w' -> + do_external ef cp w vargs m = Some(w', t, vres, m'). Proof. intros. assert (SIZE: forall n, do_alloc_size (Vptrofs n) = Some n). { unfold Vptrofs, do_alloc_size; intros; destruct Archi.ptr64 eqn:SF. rewrite Ptrofs.of_int64_to_int64; auto. rewrite Ptrofs.of_int_to_int; auto. } - assert (BF_EX: forall name cp sg, - builtin_or_external_sem name cp sg ge vargs m t vres m' -> - do_builtin_or_external name cp sg w vargs m = Some (w', t, vres, m')). + assert (BF_EX: forall name sg, + builtin_or_external_sem name sg ge cp vargs m t vres m' -> + do_builtin_or_external name sg cp w vargs m = Some (w', t, vres, m')). { unfold do_builtin_or_external, builtin_or_external_sem; intros. - destruct (lookup_builtin_function name cp sg) as [bf|]. + destruct (lookup_builtin_function name sg) as [bf|]. - inv H1. inv H0. rewrite H2. auto. - eapply do_external_function_complete; eauto. } diff --git a/common/Linking.v b/common/Linking.v index e31dc382ed..ceb6401682 100644 --- a/common/Linking.v +++ b/common/Linking.v @@ -62,25 +62,19 @@ Definition link_fundef {F: Type} {CF: has_comp F} (fd1 fd2: fundef F) := if external_function_eq ef1 ef2 then Some (External ef1) else None | Internal f, External ef => match ef with - | EF_external cp id sg => - if eq_compartment cp (comp_of f) - then Some (Internal f) - else None + | EF_external id sg => Some (Internal f) | _ => None end | External ef, Internal f => match ef with - | EF_external cp id sg => - if eq_compartment cp (comp_of f) - then Some (Internal f) - else None + | EF_external id sg => Some (Internal f) | _ => None end end. Inductive linkorder_fundef {F: Type} {CF: has_comp F} : fundef F -> fundef F -> Prop := | linkorder_fundef_refl: forall fd, linkorder_fundef fd fd - | linkorder_fundef_ext_int: forall f id sg, linkorder_fundef (External (EF_external (comp_of f) id sg)) (Internal f). + | linkorder_fundef_ext_int: forall f id sg, linkorder_fundef (External (EF_external id sg)) (Internal f). Global Program Instance Linker_fundef (F: Type) {CP: has_comp F}: Linker (fundef F) := { link := link_fundef; @@ -96,12 +90,8 @@ Next Obligation. destruct x, y; simpl in H. + discriminate. + destruct e; inv H. - destruct eq_compartment; try easy. - subst cp. inv H1. split; constructor. + destruct e; inv H. - destruct eq_compartment; try easy. - subst cp. inv H1. split; constructor. + destruct (external_function_eq e e0); inv H. split; constructor. Defined. @@ -768,16 +758,12 @@ Local Transparent Linker_fundef. simpl; intros. destruct f1 as [f1|ef1], f2 as [f2|ef2]; simpl in *; monadInv H0; monadInv H1. - discriminate. - destruct ef2; inv H. - destruct eq_compartment; try easy. - subst cp. inv H1. exists (Internal x); split. - rewrite (CAB1 _ _ EQ). simpl. now rewrite dec_eq_true. + reflexivity. left; simpl; rewrite EQ; auto. - destruct ef1; inv H. - destruct eq_compartment; try easy. - subst cp. inv H1. exists (Internal x). split. - rewrite (CAB2 _ _ EQ). simpl. now rewrite dec_eq_true. + reflexivity. right; simpl; rewrite EQ; auto. - destruct (external_function_eq ef1 ef2); inv H. exists (External ef2); split; auto. simpl. rewrite dec_eq_true; auto. Qed. @@ -831,14 +817,10 @@ Proof. - intros. subst. destruct f1, f2; simpl in *. + discriminate. + destruct e; try easy. - destruct eq_compartment; try easy. - subst cp. inv H2. - rewrite CAB, dec_eq_true. + inv H2. econstructor; eauto. + destruct e; try easy. - destruct eq_compartment; try easy. - subst cp. inv H2. - rewrite CAB, dec_eq_true. + inv H2. econstructor; eauto. + destruct (external_function_eq e e0); inv H2. econstructor; eauto. - intros; subst. exists v; auto. @@ -859,14 +841,10 @@ Proof. - intros. subst. destruct f1, f2; simpl in *. + discriminate. + destruct e; try easy. - destruct eq_compartment; try easy. - subst cp. inv H2. - rewrite CAB, dec_eq_true. + inv H2. econstructor; eauto. + destruct e; try easy. - destruct eq_compartment; try easy. - subst cp. inv H2. - rewrite CAB, dec_eq_true. + inv H2. econstructor; eauto. + destruct (external_function_eq e e0); inv H2. econstructor; eauto. - intros; subst. exists v; auto. From 2d16557c7c9117c707679042de9517a74b84ef82 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 20 Nov 2023 17:43:43 +0100 Subject: [PATCH 04/83] =?UTF-8?q?[Compartment=20model]=C2=A0Continue=20gen?= =?UTF-8?q?eralizing=20the=20compartment=20model?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- backend/Cminor.v | 27 +- common/AST.v | 123 ++++++--- common/Globalenvs.v | 292 ++++++++++++---------- common/Linking.v | 6 +- common/Memory.v | 591 +++++++++++++++++++++----------------------- common/Memtype.v | 53 ++-- common/Separation.v | 6 +- lib/Maps.v | 18 ++ 8 files changed, 593 insertions(+), 523 deletions(-) diff --git a/backend/Cminor.v b/backend/Cminor.v index 60c57cc413..5dd212e673 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -239,7 +239,8 @@ Inductive state: Type := forall (f: fundef) (**r function to invoke *) (args: list val) (**r arguments provided by caller *) (k: cont) (**r what to do next *) - (m: mem), (**r memory state *) + (m: mem) (**r memory state *) + (cp: option compartment), (**r optionally, the compartment that lead to this [Callstate]. /!\ This is not necessary [call_comp k] *) state | Returnstate: (**r Return from a function *) forall (v: val) (**r Return value *) @@ -476,30 +477,26 @@ Inductive step: state -> trace -> state -> Prop := Genv.find_funct ge vf = Some fd -> funsig fd = sig -> (* Check that the call to the function pointer is allowed *) - forall (ALLOWED: Genv.allowed_call ge (comp_of f) vf), + forall (ALLOWED: Genv.allowed_call ge (comp_of f) ()), forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall -> Forall not_ptr vargs), forall (EV: call_trace ge (comp_of f) (comp_of fd) vf vargs (sig_args sig) t), step (State f (Scall optid sig a bl) k sp e m) - t (Callstate fd vargs (Kcall optid f sp e k) m) + t (Callstate fd vargs (Kcall optid f sp e k) m (Some (comp_of f))) | step_tailcall: forall f sig a bl k sp e m vf vargs fd m', eval_expr (Vptr sp Ptrofs.zero) e m (comp_of f) a vf -> eval_exprlist (Vptr sp Ptrofs.zero) e m (comp_of f) bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> - forall (COMP: comp_of fd = (comp_of f)), + forall (COMP: comp_of fd = comp_of f), forall (SIG: sig_res (fn_sig f) = sig_res sig), - (* forall (ALLOWED: needs_calling_comp (comp_of f) = false), *) - (* forall (ALLOWED': Genv.allowed_call ge (comp_of f) vf), *) (* Not needed: call is allowed because we don't change compartment (hypothesis COMP) *) Mem.free m sp 0 f.(fn_stackspace) (comp_of f) = Some m' -> - (* forall (EV: call_trace ge (comp_of f) (Genv.find_comp ge vf) vf vargs (sig_args sig) t), *) step (State f (Stailcall sig a bl) k (Vptr sp Ptrofs.zero) e m) - E0 (Callstate fd vargs (call_cont k) m') + E0 (Callstate fd vargs (call_cont k) m' (Some (comp_of f))) | step_builtin: forall f optid ef bl k sp e m vargs t vres m', eval_exprlist sp e m (comp_of f) bl vargs -> - external_call ef ge vargs m t vres m' -> - forall ALLOWED: comp_of ef = comp_of f, + external_call ef ge (comp_of f) vargs m t vres m' -> step (State f (Sbuiltin optid ef bl) k sp e m) t (State f Sskip k sp (set_optvar optid vres e) m') @@ -556,14 +553,14 @@ Inductive step: state -> trace -> state -> Prop := step (State f (Sgoto lbl) k sp e m) E0 (State f s' k' sp e m) - | step_internal_function: forall f vargs k m m' sp e, + | step_internal_function: forall f vargs k m cp m' sp e, Mem.alloc m (comp_of f) 0 f.(fn_stackspace) = (m', sp) -> set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> - step (Callstate (Internal f) vargs k m) + step (Callstate (Internal f) vargs k m cp) E0 (State f f.(fn_body) k (Vptr sp Ptrofs.zero) e m') - | step_external_function: forall ef vargs k m t vres m', - external_call ef ge vargs m t vres m' -> - step (Callstate (External ef) vargs k m) + | step_external_function: forall ef vargs k m cp t vres m', + external_call ef ge cp vargs m t vres m' -> + step (Callstate (External ef) vargs k m (Some cp)) t (Returnstate vres k m' (sig_res (ef_sig ef)) (comp_of ef)) | step_return: forall v optid f sp e cp k m ty t, diff --git a/common/AST.v b/common/AST.v index 953d9395fd..ad0d4f0568 100644 --- a/common/AST.v +++ b/common/AST.v @@ -35,22 +35,77 @@ Definition ident_eq := peq. (** Programs entities can be grouped into compartments, which remain isolated from each other during execution. *) -Definition compartment : Type := positive. -Definition privileged_compartment : compartment := 1%positive. -Notation default_compartment := privileged_compartment. (* TODO: fix this *) -Definition eq_compartment (c1 c2: compartment) := - peq c1 c2. +(* Definition compartment : Type := positive. *) +(* Definition privileged_compartment : compartment := 1%positive. *) +(* Notation default_compartment := privileged_compartment. (* TODO: fix this *) *) +(* Definition eq_compartment (c1 c2: compartment) := *) +(* peq c1 c2. *) + +Parameter compartment: Type. +Parameters top bottom: compartment. +Parameter flowsto: compartment -> compartment -> Prop. +Notation "c '⊆' c'" := (flowsto c c') (no associativity, at level 95). +Notation "c '⊈' c'" := (not (flowsto c c')) (no associativity, at level 95). +Axiom flowsto_dec: forall cp cp', {cp ⊆ cp'} + {cp ⊈ cp'}. +Axiom flowsto_refl: forall cp, cp ⊆ cp. +Axiom flowsto_antisym: forall cp cp', cp ⊆ cp' -> cp' ⊆ cp -> cp = cp'. +Axiom flowsto_trans: forall cp cp' cp'', cp ⊆ cp' -> cp' ⊆ cp'' -> cp ⊆ cp''. + +Lemma cp_eq_dec: forall (cp cp': compartment), {cp = cp'} + {cp <> cp'}. + intros cp cp'. + destruct (flowsto_dec cp cp') as [f1 | n1]; destruct (flowsto_dec cp' cp) as [f2 | n2]. + - left; eapply flowsto_antisym; eauto. + - right; intros ?; subst cp'; contradiction. + - right; intros ?; subst cp'; contradiction. + - right; intros ?; subst cp'; apply n1; now eapply flowsto_refl. +Qed. + +Parameter comp_to_pos: compartment -> positive. +Axiom comp_to_pos_inj: forall x y: compartment, comp_to_pos x = comp_to_pos y -> x = y. + +Module COMPARTMENT_INDEXED_TYPE <: INDEXED_TYPE. + Definition t := compartment. + Definition index := comp_to_pos. + Definition index_inj := comp_to_pos_inj. + Definition eq := cp_eq_dec. +End COMPARTMENT_INDEXED_TYPE. + +Module CompTree := ITree (COMPARTMENT_INDEXED_TYPE). -(** Calls into certain compartments cannot be inlined or transformed into tail - calls because they need to know who the calling compartment is. These - compartments are recorded in the following map. *) +Axiom bottom_flowsto: forall cp, bottom ⊆ cp. +Axiom flowsto_top: forall cp, cp ⊆ top. -Definition needs_calling_comp_map : PMap.t bool := - let comps := privileged_compartment :: nil in - fold_left (fun m cp => PMap.set cp true m) comps (PMap.init false). +Parameters join meet: compartment -> compartment -> compartment. +Notation "c '∪' c'" := (join c c') (left associativity, at level 40). +Notation "c '∩' c'" := (meet c c') (left associativity, at level 40). +Axiom join_comm: forall cp cp', cp ∪ cp' = cp' ∪ cp. +Axiom meet_comm: forall cp cp', cp ∩ cp' = cp' ∩ cp. +Axiom join_assoc: forall cp cp' cp'', cp ∪ (cp' ∪ cp'') = (cp ∪ cp') ∪ cp''. +Axiom meet_assoc: forall cp cp' cp'', cp ∩ (cp' ∩ cp'') = (cp ∩ cp') ∩ cp''. +Axiom join_absorbs_meet: forall cp cp', cp ∪ (cp ∩ cp') = cp. +Axiom meet_absorbs_join: forall cp cp', cp ∩ (cp ∪ cp') = cp. -Definition needs_calling_comp (cp: compartment) : bool := - PMap.get cp needs_calling_comp_map. +Lemma join_idempotent: forall cp, cp ∪ cp = cp. +Proof. + intros cp. + rewrite <- (meet_absorbs_join cp cp) at 2; rewrite join_absorbs_meet; reflexivity. +Qed. + +Lemma meet_idempotent: forall cp, cp ∩ cp = cp. +Proof. + intros cp. + rewrite <- (join_absorbs_meet cp cp) at 2; rewrite meet_absorbs_join; reflexivity. +Qed. + +Axiom flowsto_join1: forall cp cp', cp ⊆ cp ∪ cp'. +Axiom flowsto_join2: forall cp cp', cp' ⊆ cp ∪ cp'. +Axiom meet_flowsto1: forall cp cp', cp ∩ cp' ⊆ cp. +Axiom meet_flowsto2: forall cp cp', cp ∩ cp' ⊆ cp'. + +Create HintDb comps. +#[export] Hint Resolve flowsto_refl flowsto_antisym flowsto_trans bottom_flowsto flowsto_top + join_comm meet_comm join_assoc meet_assoc flowsto_join1 flowsto_join2 meet_flowsto1 meet_flowsto2: comps. +#[export] Hint Rewrite join_idempotent meet_idempotent join_absorbs_meet meet_absorbs_join: comps. Set Typeclasses Strict Resolution. (** An instance of [has_comp] represents a syntactic entity that belongs to a @@ -59,6 +114,8 @@ Set Typeclasses Strict Resolution. Class has_comp (T: Type) := comp_of: T -> compartment. Unset Typeclasses Strict Resolution. +Arguments comp_of _ _ !_ /. + Class has_comp_transl {T S: Type} {CT: has_comp T} {CS: has_comp S} (f : T -> S) := @@ -379,16 +436,16 @@ Instance has_comp_globvar V : has_comp (globvar V) := @gvar_comp _. Module Policy. Record t: Type := mkpolicy { - policy_export: PTree.t (list ident); - policy_import: PTree.t (list (compartment * ident)) + policy_export: CompTree.t (list ident); + policy_import: CompTree.t (list (compartment * ident)) }. Definition in_pub_exports (pol: t) (pubs: list ident) : Prop := - forall cp exps, (policy_export pol) ! cp = Some exps -> + forall cp exps, CompTree.get cp (policy_export pol) = Some exps -> forall id, In id exps -> In id pubs. Definition in_pub_imports (pol: t) (pubs: list ident) : Prop := - forall cp imps, (policy_import pol) ! cp = Some imps -> + forall cp imps, CompTree.get cp (policy_import pol) = Some imps -> forall cp' id, In (cp', id) imps -> In id pubs. Definition in_pub (pol: t) (pubs: list ident) : Prop := @@ -399,11 +456,11 @@ Module Policy. have performance impacts in compilation. *) Definition enforce_in_pub (pol: t) (pubs: list ident) := {| policy_export := - PTree.map1 + CompTree.map1 (filter (fun id : ident => in_dec ident_eq id pubs)) pol.(policy_export); policy_import := - PTree.map1 + CompTree.map1 (filter (fun p : compartment * ident => in_dec ident_eq (snd p) pubs)) pol.(policy_import); |}. @@ -413,19 +470,19 @@ Module Policy. in_pub (enforce_in_pub pol pubs) pubs. Proof. split. - - intros cp imps. simpl. rewrite PTree.gmap1. - destruct PTree.get as [exps|] eqn:pol_cp; simpl; try congruence. + - intros cp imps. simpl. rewrite CompTree.gmap1. + destruct CompTree.get as [exps|] eqn:pol_cp; simpl; try congruence. intros e. injection e as e. rewrite <- e. clear e. intros id. rewrite filter_In. intros [_ Hin]. now destruct in_dec. - - intros cp exps. simpl. rewrite PTree.gmap1. - destruct PTree.get as [imps|] eqn:pol_cp; simpl; try congruence. + - intros cp exps. simpl. rewrite CompTree.gmap1. + destruct CompTree.get as [imps|] eqn:pol_cp; simpl; try congruence. intros e. injection e as e. rewrite <- e. clear e. intros cp' id. rewrite filter_In. simpl. intros [_ Hin]. now destruct in_dec. Qed. (* The empty policy is the policy where there is no imported procedure and no exported procedure for all compartments *) - Definition empty_pol: t := mkpolicy (PTree.empty (list ident)) (PTree.empty (list (compartment * ident))). + Definition empty_pol: t := mkpolicy (CompTree.empty (list ident)) (CompTree.empty (list (compartment * ident))). (* Decidable equality for the elements contained in the policies *) Definition list_id_eq: forall (x y: list ident), @@ -443,14 +500,14 @@ Module Policy. decide equality. decide equality. apply Pos.eq_dec. - apply Pos.eq_dec. + apply cp_eq_dec. Qed. (* Defines an equivalence between two policies: two policies are equivalent iff for each compartment, they define the same exported and imported procedures *) Definition eqb (t1 t2: t): bool := - PTree.beq list_id_eq t1.(policy_export) t2.(policy_export) && - PTree.beq list_cpt_id_eq t1.(policy_import) t2.(policy_import). + CompTree.beq list_id_eq t1.(policy_export) t2.(policy_export) && + CompTree.beq list_cpt_id_eq t1.(policy_import) t2.(policy_import). (* Properties of an equivalence relation: reflexivity, commutativity, transitivity *) Lemma eqb_refl: forall pol, eqb pol pol = true. @@ -461,6 +518,7 @@ Module Policy. rewrite PTree.beq_correct. intros x. destruct ((policy_export pol) ! x); auto. destruct (list_id_eq l l); auto. + unfold CompTree.beq. rewrite H. simpl. rewrite PTree.beq_correct. intros x. destruct ((policy_import pol) ! x); auto. @@ -486,6 +544,7 @@ Module Policy. destruct (list_cpt_id_eq l0 l); subst. destruct (list_cpt_id_eq l l); auto. destruct (list_cpt_id_eq l l0); auto. + unfold CompTree.beq. rewrite H1', H2'. auto. Qed. @@ -521,6 +580,7 @@ Module Policy. destruct (list_cpt_id_eq l l1); auto. now subst. } + unfold CompTree.beq. rewrite H3, H3'. auto. Qed. @@ -573,8 +633,9 @@ Definition prog_defs_names (F V: Type) (p: program F V) : list ident := Definition prog_defmap (F V: Type) (p: program F V) : PTree.t (globdef F V) := PTree_Properties.of_list p.(prog_defs). -Definition list_comp (F V: Type) (p: program F V) {CF: has_comp F}: list compartment := - List.map (fun x => comp_of (snd x)) p.(prog_defs). (* TODO: filter out duplicate compartments from this list *) +(* FIXME: I don't think this is needed anymore *) +(* Definition list_comp (F V: Type) (p: program F V) {CF: has_comp F}: list compartment := *) +(* List.map (fun x => comp_of (snd x)) p.(prog_defs). *) Section DEFMAP. @@ -772,6 +833,10 @@ Inductive external_function : Type := Unlike [EF_annot], produces no observable event. *) +(** External functions don't have compartment *) +Instance has_comp_external_function : has_comp (external_function) := fun _ => bottom. + + (** The type signature of an external function. *) Definition ef_sig (ef: external_function): signature := diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 54269fb953..7e55534231 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -193,8 +193,8 @@ Definition public_symbol (ge: t) (id: ident) : bool := Definition find_def (ge: t) (b: block) : option (globdef F V) := PTree.get b ge.(genv_defs). -(** [find_funct_ptr ge b] returns the function description associated with - the given address. *) +(** [find_funct_ptr ge b] returns the function description associated with *) +(* the given address. *) Definition find_funct_ptr (ge: t) (b: block) : option F := match find_def ge b with Some (Gfun f) => Some f | _ => None end. @@ -210,32 +210,43 @@ Definition find_funct (ge: t) (v: val) : option F := (** [find_comp_of_block ge b] *) -Definition find_comp_of_block (ge: t) (b: block) : option compartment := +Definition find_comp_of_block (ge: t) (b: block) : compartment := match find_def ge b with - | Some def => Some (comp_of def) - | None => None + | Some def => comp_of def + | None => bottom end. -Definition find_comp_of_ident (ge: t) (id: ident) : option compartment := +(* We do not define an instance of [comp_of] for [block], because there is two ways of + getting the compartment of a block: through the global environment and through the + memory. We do not want to mix the two by mistake. *) + + +Definition find_comp_of_ident (ge: t) (id: ident) : compartment := match find_symbol ge id with | Some b => find_comp_of_block ge b - | None => None + | None => bottom end. -(** [find_comp ge v] finds the compartment associated with the pointer [v] as it +Global Instance has_comp_ident (ge: t): has_comp ident := + find_comp_of_ident ge. + +(** [find_comp_in_genv ge v] finds the compartment associated with the pointer [v] as it is recorded in [ge]. *) -Definition find_comp (ge: t) (v: val) : option compartment := +(* We also do not define an instance of [comp_of] for [value], because there is two ways of + getting the compartment of a block: through the global environment and through the + memory. We do not want to mix the two by mistake. *) +Definition find_comp_in_genv (ge: t) (v: val) : compartment := match v with | Vptr b _ => find_comp_of_block ge b - | _ => None + | _ => bottom end. -Lemma find_funct_find_comp : forall ge v fd, +Lemma find_funct_find_comp_in_genv : forall ge v fd, find_funct ge v = Some fd -> - find_comp ge v = Some (comp_of fd). + find_comp_in_genv ge v = comp_of fd. Proof. - unfold find_comp, find_funct, find_comp_of_block, find_funct_ptr. + unfold find_comp_in_genv, find_funct, find_comp_of_block, find_funct_ptr. intros ? v fd. destruct v; try easy. destruct Ptrofs.eq_dec as [_|_]; try easy. destruct find_def as [def|]; try easy. @@ -243,9 +254,9 @@ Proof. intros e. now injection e as ->. Qed. -Lemma find_comp_null: forall ge, find_comp ge Vnullptr = None. +Lemma find_comp_in_genv_null: forall ge, find_comp_in_genv ge Vnullptr = bottom. Proof. - unfold find_comp, Vnullptr. + unfold find_comp_in_genv, Vnullptr. now destruct Archi.ptr64. Qed. @@ -457,7 +468,7 @@ Qed. Lemma find_funct_ptr_find_comp_of_block: forall ge b fd, find_funct_ptr ge b = Some fd -> - find_comp_of_block ge b = Some (comp_of fd). + find_comp_of_block ge b = comp_of fd. Proof. intros ge b fd find. rewrite find_funct_ptr_iff in find. @@ -547,20 +558,20 @@ Proof. - unfold find_symbol. simpl. now rewrite PTree.gempty. Qed. -Lemma find_symbol_find_comp : - forall p id, - let ge := globalenv p in - find_symbol ge id <> None -> - exists cp, find_comp_of_ident ge id = Some cp. -Proof. - intros p id ge ge_id. - unfold find_comp_of_ident, find_comp_of_block. - destruct find_symbol as [b|] eqn:ge_id_b; try congruence. - destruct (find_symbol_find_def_inversion _ _ ge_id_b) - as [def ge_b]. - exists (comp_of def). simpl. unfold ge. - now rewrite ge_b. -Qed. +(* Lemma find_symbol_find_comp_in_genv : *) +(* forall p id, *) +(* let ge := globalenv p in *) +(* find_symbol ge id <> None -> *) +(* exists cp, find_comp_of_ident ge id = Some cp. *) +(* Proof. *) +(* intros p id ge ge_id. *) +(* unfold find_comp_of_ident, find_comp_of_block. *) +(* destruct find_symbol as [b|] eqn:ge_id_b; try congruence. *) +(* destruct (find_symbol_find_def_inversion _ _ ge_id_b) *) +(* as [def ge_b]. *) +(* exists (comp_of def). simpl. unfold ge. *) +(* now rewrite ge_b. *) +(* Qed. *) Theorem find_def_inversion: forall p b g, @@ -812,8 +823,9 @@ Definition perm_globvar (gv: globvar V) : permission := Definition alloc_global (m: mem) (idg: ident * globdef F V): option mem := match idg with | (id, 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) + let cp := comp_of f in + let (m1, b) := Mem.alloc m cp 0 1 in + Mem.drop_perm m1 b 0 1 Nonempty cp | (id, Gvar v) => let init := v.(gvar_init) in let comp := v.(gvar_comp) in @@ -882,7 +894,8 @@ Proof. unfold alloc_global. intros. destruct g as [id [f|v]]. - (* function *) - destruct (Mem.alloc m _ 0 1) as [m1 b] eqn:?. + (* destruct (comp_of f); try discriminate; simpl in H. *) + destruct (Mem.alloc m (comp_of f) 0 1) as [m1 b] eqn:?. erewrite Mem.nextblock_drop; eauto. now erewrite Mem.nextblock_alloc; eauto. - (* variable *) @@ -953,7 +966,7 @@ Remark alloc_global_block_compartment: forall m idg m' b, alloc_global m idg = Some m' -> Mem.block_compartment m' b = - if eq_block b (Mem.nextblock m) then Some (comp_of idg#2) + if eq_block b (Mem.nextblock m) then comp_of idg#2 else Mem.block_compartment m b. Proof. intros m [id [v|f]] m' b ALLOCGLOB; simpl in *. @@ -972,11 +985,11 @@ intros m [id [v|f]] m' b ALLOCGLOB; simpl in *. Qed. Fixpoint alloc_globals_block_compartment_spec - dflt b0 (gl : list (ident * globdef F V)) b : option block := + dflt b0 (gl : list (ident * globdef F V)) b : compartment := match gl with | nil => dflt | g :: gl => - let dflt' := if eq_block b b0 then Some (comp_of g#2) + let dflt' := if eq_block b b0 then comp_of g#2 else dflt in alloc_globals_block_compartment_spec dflt' (Pos.succ b0) gl b end. @@ -1128,16 +1141,16 @@ Qed. (** Properties related to [loadbytes] *) -Definition readbytes_as_zero (m: mem) (b: block) (ofs len: Z) (cp: option compartment) : Prop := +Definition readbytes_as_zero (m: mem) (b: block) (ofs len: Z) (cp: compartment) : Prop := forall p n, ofs <= p -> p + Z.of_nat n <= ofs + len -> Mem.loadbytes m b p (Z.of_nat n) cp = Some (List.repeat (Byte Byte.zero) n). Lemma store_zeros_loadbytes: forall m b p n cp m', - Mem.can_access_block m b (Some cp) -> + Mem.can_access_block m b cp -> store_zeros m b p n cp = Some m' -> - readbytes_as_zero m' b p n (Some cp) /\ Mem.can_access_block m' b (Some cp). + readbytes_as_zero m' b p n cp /\ Mem.can_access_block m' b cp. Proof. intros until cp. functional induction (store_zeros m b p n cp). @@ -1199,8 +1212,8 @@ Qed. Lemma store_init_data_loadbytes: forall m b p i cp m', store_init_data m b p i cp = Some m' -> - readbytes_as_zero m b p (init_data_size i) (Some cp) -> - Mem.loadbytes m' b p (init_data_size i) (Some cp) = Some (bytes_of_init_data i). + readbytes_as_zero m b p (init_data_size i) cp -> + Mem.loadbytes m' b p (init_data_size i) cp = Some (bytes_of_init_data i). Proof. intros; destruct i; simpl in H; try apply (Mem.loadbytes_store_same _ _ _ _ _ _ _ H). - inv H. simpl. @@ -1221,10 +1234,10 @@ Fixpoint bytes_of_init_data_list (il: list init_data): list memval := Lemma store_init_data_list_loadbytes: forall b il m p cp m', - Mem.can_access_block m b (Some cp) -> + Mem.can_access_block m b cp -> store_init_data_list m b p il cp = Some m' -> - readbytes_as_zero m b p (init_data_list_size il) (Some cp) -> - Mem.loadbytes m' b p (init_data_list_size il) (Some cp) = Some (bytes_of_init_data_list il). + readbytes_as_zero m b p (init_data_list_size il) cp -> + Mem.loadbytes m' b p (init_data_list_size il) cp = Some (bytes_of_init_data_list il). Proof. induction il as [ | i1 il]; simpl; intros. - apply Mem.loadbytes_empty. lia. inv H0; eauto. @@ -1252,7 +1265,7 @@ Qed. (** Properties related to [load] *) -Definition read_as_zero (m: mem) (b: block) (ofs len: Z) (cp: option compartment) : Prop := +Definition read_as_zero (m: mem) (b: block) (ofs len: Z) (cp: compartment) : Prop := forall chunk p, ofs <= p -> p + size_chunk chunk <= ofs + len -> (align_chunk chunk | p) -> @@ -1278,9 +1291,9 @@ Qed. Lemma store_zeros_read_as_zero: forall m b p n cp m', - Mem.can_access_block m b (Some cp) -> + Mem.can_access_block m b cp -> store_zeros m b p n cp = Some m' -> - read_as_zero m' b p n (Some cp). + read_as_zero m' b p n cp. Proof. intros; red; intros. transitivity (Some(decode_val chunk (List.repeat (Byte Byte.zero) (size_chunk_nat chunk)))). @@ -1289,7 +1302,7 @@ Proof. f_equal. destruct chunk; unfold decode_val; unfold decode_int; unfold rev_if_be; destruct Archi.big_endian; reflexivity. Qed. -Fixpoint load_store_init_data (m: mem) (b: block) (p: Z) (il: list init_data) (cp: option compartment) {struct il} : Prop := +Fixpoint load_store_init_data (m: mem) (b: block) (p: Z) (il: list init_data) (cp: compartment) {struct il} : Prop := match il with | nil => True | Init_int8 n :: il' => @@ -1321,13 +1334,13 @@ Fixpoint load_store_init_data (m: mem) (b: block) (p: Z) (il: list init_data) (c Lemma store_init_data_list_charact: forall b il m p cp m', store_init_data_list m b p il cp = Some m' -> - read_as_zero m b p (init_data_list_size il) (Some cp) -> - load_store_init_data m' b p il (Some cp). + read_as_zero m b p (init_data_list_size il) cp -> + load_store_init_data m' b p il cp. Proof. assert (A: forall chunk v m b p m1 il cp m', Mem.store chunk m b p v cp = Some m1 -> store_init_data_list m1 b (p + size_chunk chunk) il cp = Some m' -> - Mem.load chunk m' b p (Some cp) = Some(Val.load_result chunk v)). + Mem.load chunk m' b p cp = Some(Val.load_result chunk v)). { intros. eapply Mem.load_unchanged_on with (P := fun b' ofs' => ofs' < p + size_chunk chunk). @@ -1417,13 +1430,15 @@ Qed. Remark load_store_init_data_invariant: forall m m' b, - (forall chunk ofs cp, Mem.load chunk m' b ofs cp = Mem.load chunk m b ofs cp) -> + (forall chunk ofs cp v, Mem.load chunk m b ofs cp = Some v -> + Mem.load chunk m' b ofs cp = Some v) -> forall il p cp, load_store_init_data m b p il cp -> load_store_init_data m' b p il cp. Proof. induction il; intro p; simpl. auto. - intros. rewrite ! H. destruct a; intuition. red; intros; rewrite H; auto. + intros. destruct a; intuition. red; intros; intuition. + destruct H1 as [b' [? ?]]. exists b'; intuition. Qed. Definition globals_initialized (g: t) (m: mem) := @@ -1437,8 +1452,8 @@ Definition globals_initialized (g: t) (m: mem) := Mem.range_perm m b 0 (init_data_list_size v.(gvar_init)) Cur (perm_globvar v) /\ (forall ofs k p, Mem.perm m b ofs k p -> 0 <= ofs < init_data_list_size v.(gvar_init) /\ perm_order (perm_globvar v) p) - /\ (v.(gvar_volatile) = false -> load_store_init_data m b 0 v.(gvar_init) (Some v.(gvar_comp))) - /\ (v.(gvar_volatile) = false -> Mem.loadbytes m b 0 (init_data_list_size v.(gvar_init)) (Some v.(gvar_comp)) = Some (bytes_of_init_data_list v.(gvar_init))) + /\ (v.(gvar_volatile) = false -> load_store_init_data m b 0 v.(gvar_init) v.(gvar_comp)) + /\ (v.(gvar_volatile) = false -> Mem.loadbytes m b 0 (init_data_list_size v.(gvar_init)) v.(gvar_comp) = Some (bytes_of_init_data_list v.(gvar_init))) end. Lemma alloc_global_initialized: @@ -1480,17 +1495,20 @@ Proof. split; auto. eapply Mem.perm_drop_2; eauto. split. intros NOTVOL. apply load_store_init_data_invariant with m3. - intros. eapply Mem.load_drop; eauto. right; right; right. + intros. erewrite Mem.load_drop; eauto. right; right; right. unfold perm_globvar. rewrite NOTVOL. destruct (gvar_readonly v); auto with mem. eapply store_init_data_list_charact; eauto. - eapply store_zeros_read_as_zero; eauto. eapply Mem.owned_new_block; eauto. + eapply store_zeros_read_as_zero; eauto. + simpl. erewrite Mem.owned_new_block; eauto using flowsto_refl. intros NOTVOL. - transitivity (Mem.loadbytes m3 b 0 sz (Some v.(gvar_comp))). + transitivity (Mem.loadbytes m3 b 0 sz v.(gvar_comp)). eapply Mem.loadbytes_drop; eauto. right; right; right. unfold perm_globvar. rewrite NOTVOL. destruct (gvar_readonly v); auto with mem. eapply store_init_data_list_loadbytes; eauto. - eapply store_zeros_loadbytes; eauto. eapply Mem.owned_new_block; eauto. - eapply store_zeros_loadbytes; eauto. eapply Mem.owned_new_block; eauto. + eapply store_zeros_loadbytes; eauto. + simpl; erewrite Mem.owned_new_block; eauto using flowsto_refl. + eapply store_zeros_loadbytes; eauto. + simpl; erewrite Mem.owned_new_block; eauto using flowsto_refl. + assert (U: Mem.unchanged_on (fun _ _ => True) m m') by (eapply alloc_global_unchanged; eauto). assert (VALID: Mem.valid_block m b). { red. rewrite <- H. eapply genv_defs_range; eauto. } @@ -1503,7 +1521,8 @@ Proof. red; intros. eapply Mem.perm_unchanged_on; eauto. exact I. intros. eapply B. eapply Mem.perm_unchanged_on_2; eauto. exact I. intros. apply load_store_init_data_invariant with m; auto. - intros. eapply Mem.load_unchanged_on_1; eauto. intros; exact I. + intros. eapply Mem.load_unchanged_on; eauto. + intros; exact I. intros. eapply Mem.loadbytes_unchanged_on; eauto. intros; exact I. - simpl. congruence. Qed. @@ -1531,29 +1550,29 @@ Lemma init_mem_find_def: forall p m b g, init_mem p = Some m -> find_def (globalenv p) b = Some g -> - Mem.block_compartment m b = Some (comp_of g). + Mem.block_compartment m b = comp_of g. Proof. intros p m b g. unfold init_mem, find_def. intros ALLOC. rewrite (alloc_globals_block_compartment _ _ _ ALLOC). clear ALLOC. unfold globalenv. - assert (Mem.block_compartment Mem.empty b = None) as ->. - { rewrite <- Mem.block_compartment_valid_block. + assert (Mem.block_compartment Mem.empty b = top) as ->. + { erewrite <- Mem.block_compartment_valid_block. reflexivity. unfold Mem.valid_block. rewrite Mem.nextblock_empty. now destruct b. } simpl. set (ge := @empty_genv _ _ _). change 1%positive with (genv_next ge). assert (forall g', (genv_defs ge) ! b = Some g' -> - None = Some (comp_of g')) as INV. + top = comp_of g') as INV. { intros g'. unfold ge. simpl. now rewrite PTree.gempty. } - generalize ge (@None compartment) INV. clear ge INV. + generalize ge top INV. clear ge INV. generalize (prog_defs p). clear p. intros idgl. induction idgl as [|idg idgl IH]; simpl. - - eauto. + - intros. exploit INV; eauto. - intros ge o INV. apply IH. clear IH g. - intros g. simpl. destruct eq_block as [->|neq]. + intros g. simpl. edestruct eq_block as [->|neq]. + rewrite PTree.gss. intros H. now injection H as <-. + rewrite PTree.gso; trivial. apply INV. Qed. @@ -1622,9 +1641,9 @@ Theorem init_mem_characterization: /\ (forall ofs k p, Mem.perm m b ofs k p -> 0 <= ofs < init_data_list_size gv.(gvar_init) /\ perm_order (perm_globvar gv) p) /\ (gv.(gvar_volatile) = false -> - load_store_init_data (globalenv p) m b 0 gv.(gvar_init) (Some gv.(gvar_comp))) + load_store_init_data (globalenv p) m b 0 gv.(gvar_init) gv.(gvar_comp)) /\ (gv.(gvar_volatile) = false -> - Mem.loadbytes m b 0 (init_data_list_size gv.(gvar_init)) (Some gv.(gvar_comp)) = Some (bytes_of_init_data_list (globalenv p) gv.(gvar_init))). + Mem.loadbytes m b 0 (init_data_list_size gv.(gvar_init)) gv.(gvar_comp) = Some (bytes_of_init_data_list (globalenv p) gv.(gvar_init))). Proof. intros. rewrite find_var_info_iff in H. exploit init_mem_characterization_gen; eauto. @@ -1855,7 +1874,7 @@ Variable ge: t. Lemma store_zeros_exists: forall m b p n cp, Mem.range_perm m b p (p + n) Cur Writable -> - Mem.can_access_block m b (Some cp) -> + Mem.can_access_block m b cp -> exists m', store_zeros m b p n cp = Some m'. Proof. intros until cp. functional induction (store_zeros m b p n cp); intros PERM ACC. @@ -1871,7 +1890,7 @@ Qed. Lemma store_init_data_exists: forall m b p i cp, Mem.range_perm m b p (p + init_data_size i) Cur Writable -> - forall OWN : Mem.can_access_block m b (Some cp), + forall OWN : Mem.can_access_block m b cp, (init_data_alignment i | p) -> (forall id ofs, i = Init_addrof id ofs -> exists b, find_symbol ge id = Some b) -> exists m', store_init_data ge m b p i cp = Some m'. @@ -1894,7 +1913,7 @@ Qed. Lemma store_init_data_list_exists: forall b il m p cp, Mem.range_perm m b p (p + init_data_list_size il) Cur Writable -> - forall OWN : Mem.can_access_block m b (Some cp), + forall OWN : Mem.can_access_block m b cp, init_data_list_aligned p il -> (forall id ofs, In (Init_addrof id ofs) il -> exists b, find_symbol ge id = Some b) -> exists m', store_init_data_list ge m b p il cp = Some m'. @@ -1928,7 +1947,7 @@ Proof. - destruct (Mem.alloc m _ 0 1) as [m1 b] eqn:ALLOC. destruct (Mem.range_perm_drop_2 m1 b 0 1 (comp_of f) Nonempty) as [m2 DROP]. red; intros; eapply Mem.perm_alloc_2; eauto. - eapply Mem.owned_new_block; eauto. + simpl; erewrite Mem.owned_new_block; eauto. now apply flowsto_refl. exists m2; auto. - destruct H as [P Q]. set (sz := init_data_list_size (gvar_init v)). @@ -1936,21 +1955,23 @@ Proof. assert (P1: Mem.range_perm m1 b 0 sz Cur Freeable) by (red; intros; eapply Mem.perm_alloc_2; eauto). destruct (@store_zeros_exists m1 b 0 sz (gvar_comp v)) as [m2 ZEROS]. red; intros. apply Mem.perm_implies with Freeable; auto with mem. - eapply Mem.owned_new_block; eauto. + simpl; erewrite Mem.owned_new_block; eauto. now apply flowsto_refl. rewrite ZEROS. assert (P2: Mem.range_perm m2 b 0 sz Cur Freeable). { red; intros. erewrite <- store_zeros_perm by eauto. eauto. } destruct (@store_init_data_list_exists b (gvar_init v) m2 0 (gvar_comp v)) as [m3 STORE]; auto. red; intros. apply Mem.perm_implies with Freeable; auto with mem. eapply store_zeros_block_compartment with (b' := b) in ZEROS. - unfold Mem.can_access_block. rewrite ZEROS. eapply Mem.owned_new_block. eauto. + unfold Mem.can_access_block. rewrite ZEROS. + simpl; erewrite Mem.owned_new_block; eauto. now apply flowsto_refl. rewrite STORE. assert (P3: Mem.range_perm m3 b 0 sz Cur Freeable). { red; intros. erewrite <- store_init_data_list_perm by eauto. eauto. } destruct (Mem.range_perm_drop_2 m3 b 0 sz (gvar_comp v) (perm_globvar v)) as [m4 DROP]; auto. eapply store_init_data_list_block_compartment with (b' := b) in STORE. eapply store_zeros_block_compartment with (b' := b) in ZEROS. - unfold Mem.can_access_block. rewrite STORE, ZEROS. eapply Mem.owned_new_block. eauto. + unfold Mem.can_access_block. rewrite STORE, ZEROS. + simpl; erewrite Mem.owned_new_block; eauto. now apply flowsto_refl. exists m4; auto. Qed. @@ -1978,12 +1999,12 @@ Definition allowed_cross_call (ge: t) (cp: compartment) (vf: val) := | Vptr b _ => exists i cp', invert_symbol ge b = Some i /\ - find_comp ge vf = Some cp' /\ - match (Policy.policy_import ge.(genv_policy)) ! cp with + find_comp_in_genv ge vf = cp' /\ + match CompTree.get cp (Policy.policy_import ge.(genv_policy)) with | Some l => In (cp', i) l | None => False end /\ - match (Policy.policy_export ge.(genv_policy)) ! cp' with + match CompTree.get cp' (Policy.policy_export ge.(genv_policy)) with | Some l => In i l | None => False end @@ -1991,14 +2012,11 @@ Definition allowed_cross_call (ge: t) (cp: compartment) (vf: val) := end. Definition allowed_addrof (ge: t) (cp: compartment) (id: ident) := - find_comp_of_ident ge id = Some cp \/ + (find_comp_of_ident ge id ⊆ cp) \/ public_symbol ge id = true. Definition allowed_addrof_b (ge: t) (cp: compartment) (id: ident) : bool := - match find_comp_of_ident ge id with - | Some cp' => eq_compartment cp cp' : bool - | None => false - end || public_symbol ge id. + flowsto_dec (find_comp_of_ident ge id) cp || public_symbol ge id. Lemma allowed_addrof_b_reflect : forall ge cp id, @@ -2011,7 +2029,7 @@ Variant call_type := | CrossCompartmentCall. Definition type_of_call (cp: compartment) (cp': compartment): call_type := - if Pos.eqb cp cp' then InternalCall + if flowsto_dec cp cp' then InternalCall else CrossCompartmentCall. (* Lemma type_of_call_cp_default: *) @@ -2023,20 +2041,22 @@ Definition type_of_call (cp: compartment) (cp': compartment): call_type := (* Qed. *) Lemma type_of_call_same_cp: - forall cp, type_of_call cp cp <> CrossCompartmentCall. + forall cp, type_of_call cp cp = InternalCall. Proof. intros; unfold type_of_call. - now rewrite Pos.eqb_refl. + destruct flowsto_dec; auto. + exfalso; apply n; auto with comps. Qed. +(* TODO: documentaton *) (* A call is allowed if any of these 3 cases holds: (1) the procedure being called belongs to the default compartment (2) the procedure being called belongs to the same compartment as the caller (3) the call is an inter-compartment call and is allowed by the policy *) Definition allowed_call (ge: t) (cp: compartment) (vf: val) := - (* default_compartment = find_comp ge vf \/ (* TODO: does this mean we allow all compartment to perform IO calls? *) *) - Some cp = find_comp ge vf \/ + (* default_compartment = find_comp_in_genv ge vf \/ (* TODO: does this mean we allow all compartment to perform IO calls? *) *) + (find_comp_in_genv ge vf ⊆ cp) \/ allowed_cross_call ge cp vf. Lemma comp_ident_eq_dec: forall (x y: compartment * ident), @@ -2045,30 +2065,28 @@ Proof. intros x y. decide equality. eapply Pos.eq_dec. - eapply Pos.eq_dec. + eapply cp_eq_dec. Qed. Definition allowed_call_b (ge: t) (cp: compartment) (vf: val): bool := - match find_comp ge vf with - | Some 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 - | None => false - end - | None => false - end - | None => false - end - | _ => false - end - | None => false + let c := find_comp_in_genv ge vf in + flowsto_dec c cp + || match vf with + | Vptr b _ => match invert_symbol ge b with + | Some i => + match CompTree.get cp (Policy.policy_import ge.(genv_policy)) with + | Some imps => + match CompTree.get c (Policy.policy_export ge.(genv_policy)) 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 + | _ => false end. Lemma allowed_call_reflect: forall ge cp vf, @@ -2077,24 +2095,24 @@ Proof. intros ge cp vf. unfold allowed_call, allowed_call_b, allowed_cross_call. destruct vf as [|?|?|?|?|b ofs]; simpl; - try now intuition (easy || congruence). - destruct (find_comp_of_block ge _) as [cp'|] eqn:find_vf; - try now intuition (firstorder || congruence). + try now split; intuition; destruct (flowsto_dec); auto. split. - intros [e | (i' & cp'' & A & B & C & D)]. - + injection e as <-. now rewrite Pos.eqb_refl. - + assert (cp'' = cp') as -> by congruence. clear B. - rewrite A. - destruct ((Policy.policy_import (genv_policy ge)) ! cp) as [imps |]; auto. - destruct ((Policy.policy_export (genv_policy ge)) ! cp') as [exps |]; auto. - destruct (in_dec comp_ident_eq_dec (cp', i') imps); + + destruct flowsto_dec; auto. + + rewrite B, A. + (* assert (cp'' = cp') as -> by congruence. clear B. *) + (* rewrite A. *) + destruct (CompTree.get cp (Policy.policy_import (genv_policy ge))) as [imps |]; auto. + destruct (CompTree.get cp'' (Policy.policy_export (genv_policy ge))) as [exps |]; auto. + destruct (in_dec comp_ident_eq_dec (cp'', i') imps); destruct (in_dec Pos.eq_dec i' exps); simpl; auto. now rewrite orb_true_r. - - destruct (Pos.eqb_spec cp' cp) as [->|ne]; eauto. + - destruct flowsto_dec as [| n]; auto. + (* destruct (Pos.eqb_spec cp' cp) as [->|ne]; eauto. *) simpl. 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)) ! cp') eqn:C; try discriminate. + destruct (CompTree.get cp (Policy.policy_import (genv_policy ge))) eqn:B; try discriminate. + destruct (CompTree.get _ (Policy.policy_export (genv_policy ge))) eqn:C; try discriminate. intros H. apply andb_prop in H. destruct H as (D & E). right. eexists; eexists; split; [reflexivity | split; [reflexivity |]]. rewrite C. @@ -2115,7 +2133,7 @@ Proof. apply invert_find_symbol in ge_id. exists id, b, off; split; trivial; split; trivial. destruct (genv_pol_pub ge) as [Hexp Himp]. - destruct ((Policy.policy_export _) ! cp') as [exps|] eqn:exp_cp'; try easy. + destruct (CompTree.get cp' (Policy.policy_export _)) as [exps|] eqn:exp_cp'; try easy. specialize (Hexp _ _ exp_cp' _ exp). unfold public_symbol. rewrite ge_id. destruct (in_dec _ _) as [H|contra]; trivial. @@ -2354,12 +2372,12 @@ Proof. - now inv MATCH. Qed. -Lemma match_genvs_find_comp: +Lemma match_genvs_find_comp_in_genv: forall vf, - find_comp (globalenv p) vf = find_comp (globalenv tp) vf. + find_comp_in_genv (globalenv p) vf = find_comp_in_genv (globalenv tp) vf. Proof. intros vf. - unfold find_comp. + unfold find_comp_in_genv. destruct vf; try easy. now rewrite match_genvs_find_comp_of_block. Qed. @@ -2403,11 +2421,11 @@ Lemma match_genvs_allowed_calls: Proof. intros cp vf. unfold allowed_call. - rewrite !match_genvs_find_comp. + rewrite !match_genvs_find_comp_in_genv. intros [H1 | H1]; auto. right. unfold allowed_cross_call in *. - rewrite match_genvs_find_comp in H1. + rewrite match_genvs_find_comp_in_genv in H1. destruct vf; auto. destruct H1 as [i0 [cp' [? [? [? ?]]]]]. exists i0; exists cp'; split; [| split; [| split]]. @@ -2423,13 +2441,15 @@ Proof. rewrite genv_pol_add_globals in H1. unfold Policy.eqb in EQPOL. apply andb_prop in EQPOL. destruct EQPOL as [EQPOL1 EQPOL2]. - simpl in *. - rewrite PTree.beq_correct in EQPOL2. specialize (EQPOL2 cp). - destruct ((Policy.policy_import prog_pol0) ! cp); - destruct ((Policy.policy_import prog_pol) ! cp); auto. + eapply CompTree.beq_sound with (x := cp) in EQPOL1. + eapply CompTree.beq_sound with (x := cp) in EQPOL2. + (* rewrite PTree.beq_correct in EQPOL2. *) + (* specialize (EQPOL2 cp). *) + destruct (CompTree.get cp (Policy.policy_import prog_pol0)); + destruct (CompTree.get cp (Policy.policy_import prog_pol)); 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_genv in H0. destruct p, tp; simpl in *; subst. unfold globalenv. unfold globalenv in H2. simpl in *. clear -H2 EQPOL CF2. @@ -2577,7 +2597,7 @@ Qed. Lemma find_comp_transf_partial: forall v, - find_comp (globalenv p) v = find_comp (globalenv tp) v. + find_comp_in_genv (globalenv p) v = find_comp_in_genv (globalenv tp) v. Proof. unfold find_comp. intros v. case v; try easy. intros b _. apply find_comp_of_block_transf_partial. @@ -2743,7 +2763,7 @@ Qed. Lemma find_comp_transf: forall v, - find_comp (globalenv p) v = find_comp (globalenv tp) v. + find_comp_in_genv (globalenv p) v = find_comp_in_genv (globalenv tp) v. Proof. intros v. case v; simpl; try easy. intros b _. apply find_comp_of_block_transf. diff --git a/common/Linking.v b/common/Linking.v index ceb6401682..caca70fec9 100644 --- a/common/Linking.v +++ b/common/Linking.v @@ -166,7 +166,7 @@ Definition link_vardef {V: Type} {LV: Linker V} (v1 v2: globvar V) := match link v1.(gvar_init) v2.(gvar_init) with | None => None | Some init => - if eq_compartment v1.(gvar_comp) v2.(gvar_comp) + if cp_eq_dec v1.(gvar_comp) v2.(gvar_comp) (* FIXME: use the meet or join!! (figure out which one makes sense) *) && eqb v1.(gvar_readonly) v2.(gvar_readonly) && eqb v1.(gvar_volatile) v2.(gvar_volatile) then Some {| gvar_info := info; gvar_init := init; @@ -198,7 +198,7 @@ Next Obligation. destruct x as [f1 c1 i1 r1 v1], y as [f2 c2 i2 r2 v2]; simpl. destruct (link f1 f2) as [f|] eqn:LF; try discriminate. destruct (link i1 i2) as [i|] eqn:LI; try discriminate. - destruct (eq_compartment c1 c2) eqn:EC; try discriminate. + destruct (cp_eq_dec c1 c2) eqn:EC; try discriminate. destruct (eqb r1 r2) eqn:ER; try discriminate. destruct (eqb v1 v2) eqn:EV; intros EQ; inv EQ. apply eqb_prop in ER; apply eqb_prop in EV; subst r2 v2. @@ -649,7 +649,7 @@ Proof. simpl; intros. unfold link_vardef in *. inv H0; inv H1; simpl in *. destruct (link i1 i0) as [info'|] eqn:LINFO; try discriminate. destruct (link init init0) as [init'|] eqn:LINIT; try discriminate. - destruct (eq_compartment c c0 && eqb ro ro0 && eqb vo vo0); inv H. + destruct (cp_eq_dec c c0 && eqb ro ro0 && eqb vo vo0); inv H. exploit link_match_varinfo; eauto. intros (tinfo & P & Q). rewrite P. econstructor; split. eauto. constructor. auto. Qed. diff --git a/common/Memory.v b/common/Memory.v index 0c7dd627b5..40671b9f5e 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -66,7 +66,7 @@ Record mem' : Type := mkmem { mem_contents: PMap.t (ZMap.t memval); (**r [block -> offset -> memval] *) mem_access: PMap.t (Z -> perm_kind -> option permission); (**r [block -> offset -> kind -> option permission] *) - mem_compartments: PTree.t compartment; (**r [block -> compartment] *) + mem_compartments: PMap.t (compartment); (**r [block -> compartment] *) nextblock: block; access_max: forall b ofs, perm_order'' (mem_access#b ofs Max) (mem_access#b ofs Cur); @@ -75,7 +75,7 @@ Record mem' : Type := mkmem { contents_default: forall b, fst mem_contents#b = Undef; nextblock_compartments: - forall b, ~Plt b nextblock <-> mem_compartments!b = None; + forall b, ~Plt b nextblock -> mem_compartments#b = top; }. Definition mem := mem'. @@ -109,38 +109,38 @@ Local Hint Resolve valid_not_valid_diff: mem. [b] in the memory [m], or [None] if [b] is not allocated in [m]. *) Definition block_compartment (m: mem) (b: block) := - m.(mem_compartments)!b. + m.(mem_compartments)#b. Theorem block_compartment_valid_block: forall m b, - ~valid_block m b <-> - block_compartment m b = None. + ~valid_block m b -> + block_compartment m b = top. Proof. apply nextblock_compartments. Qed. -Definition val_compartment (m: mem) (v: val): option compartment := +Definition val_compartment (m: mem) (v: val): compartment := match v with | Vptr b _ => block_compartment m b - | _ => None + | _ => top end. -Lemma nextblock_compartments_pos: - forall m b, - Plt b (nextblock m) <-> exists cp, block_compartment m b = Some cp. -Proof. - unfold block_compartment. intros m b. split; intro H. - - destruct ((mem_compartments m) ! b) as [cp |] eqn:Hcase. - + exists cp. reflexivity. - + apply nextblock_compartments in Hcase. contradiction. - - destruct (plt b (nextblock m)) as [Hlt | Hlt]. - + assumption. - + apply PTree.get_not_none_get_some in H. - pose proof nextblock_compartments m b as Hcomp. - apply not_iff_compat in Hcomp. - apply Hcomp in H. - contradiction. -Qed. +(* Lemma nextblock_compartments_pos: *) +(* forall m b, *) +(* Plt b (nextblock m) <-> exists cp, block_compartment m b = Some cp. *) +(* Proof. *) +(* unfold block_compartment. intros m b. split; intro H. *) +(* - destruct ((mem_compartments m) ! b) as [cp |] eqn:Hcase. *) +(* + exists cp. reflexivity. *) +(* + apply nextblock_compartments in Hcase. contradiction. *) +(* - destruct (plt b (nextblock m)) as [Hlt | Hlt]. *) +(* + assumption. *) +(* + apply PTree.get_not_none_get_some in H. *) +(* pose proof nextblock_compartments m b as Hcomp. *) +(* apply not_iff_compat in Hcomp. *) +(* apply Hcomp in H. *) +(* contradiction. *) +(* Qed. *) (** Permissions *) @@ -267,22 +267,20 @@ Defined. components. *) -Definition can_access_block (m: mem) (b: block) (cp: option compartment): Prop := - match cp with - | None => True - | Some cp => block_compartment m b = Some cp - end. +Definition can_access_block (m: mem) (b: block) (cp: compartment): Prop := + block_compartment m b ⊆ cp. + +Arguments can_access_block /. + +#[export] Hint Unfold can_access_block: comps. + Remark can_access_block_dec: forall m b cp, {can_access_block m b cp} + {~can_access_block m b cp}. Proof. unfold can_access_block. - intros m b [cp |]; [| left; trivial]. - destruct (block_compartment m b) as [cp' |] eqn:Heq. - - destruct (Pos.eq_dec cp cp'). - + left. subst. reflexivity. - + right. intro Hcontra. inv Hcontra. easy. - - right. easy. + intros m b cp. + destruct (flowsto_dec (block_compartment m b) cp); auto. Defined. (** [valid_access m chunk b ofs p cp] holds if a memory access @@ -294,7 +292,7 @@ Defined. - The offset [ofs] is aligned. *) -Definition valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) (p: permission) (cp: option compartment): Prop := +Definition valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) (p: permission) (cp: compartment): Prop := range_perm m b ofs (ofs + size_chunk chunk) Cur p /\ can_access_block m b cp /\ (align_chunk chunk | ofs). @@ -379,39 +377,41 @@ Proof. intuition congruence. Qed. -Theorem valid_pointer_valid_access_nonpriv: +Theorem valid_pointer_valid_access: forall m b cp ofs, - block_compartment m b = Some cp -> - valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty (Some cp). + block_compartment m b ⊆ cp -> + valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty cp. Proof. intros. rewrite valid_pointer_nonempty_perm. split; intros. split. simpl; red; intros. replace ofs0 with ofs by lia. auto. - split; auto. + split; [unfold can_access_block; auto with comps|]. simpl. apply Z.divide_1_l. - destruct H. apply H0. simpl. lia. -Qed. - -Theorem valid_pointer_valid_access_priv: - forall m b ofs, - valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty None. -Proof. - intros. rewrite valid_pointer_nonempty_perm. - split; intros. - split. simpl; red; intros. replace ofs0 with ofs by lia. auto. - split; auto. reflexivity. - simpl. apply Z.divide_1_l. - destruct H. apply H. simpl. lia. -Qed. - -Theorem valid_pointer_valid_access: - forall m b ocp ofs, - can_access_block m b ocp -> - valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty ocp. -Proof. - intros. - destruct ocp; auto using valid_pointer_valid_access_nonpriv, valid_pointer_valid_access_priv. -Qed. + destruct H0. apply H0. simpl. lia. +Qed. + +(* Theorem valid_pointer_valid_access_priv: *) +(* forall m b ofs, *) +(* valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty top. *) +(* Proof. *) +(* intros. rewrite valid_pointer_nonempty_perm. *) +(* split; intros. *) +(* split. simpl; red; intros. replace ofs0 with ofs by lia. auto. *) +(* split; auto. unfold can_access_block. destruct (block_compartment m b); auto with comps. *) +(* simpl. apply Z.divide_1_l. *) +(* destruct H. apply H. simpl. lia. *) +(* Qed. *) + +(* Theorem valid_pointer_valid_access: *) +(* forall m b cp ofs, *) +(* can_access_block m b cp -> *) +(* valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty cp. *) +(* Proof. *) +(* intros. *) +(* destruct (cp_eq_dec cp top); subst; auto using valid_pointer_valid_access_priv. *) +(* destruct (Mem.block_compartment m b) eqn:?; *) +(* auto using valid_pointer_valid_access_nonpriv, valid_pointer_valid_access_priv with comps. *) +(* Qed. *) (** C allows pointers one past the last element of an array. These are not valid according to the previously defined [valid_pointer]. The property @@ -438,48 +438,48 @@ Qed. (** Some useful facts relating the various notions of validity and access permissions. *) -Theorem valid_block_can_access_block: - forall m b, - valid_block m b -> - exists cp, - can_access_block m b (Some cp). -Proof. - unfold valid_block, can_access_block. intros m b Hvalid. - apply nextblock_compartments_pos in Hvalid. - assumption. -Qed. +(* Theorem valid_block_can_access_block: *) +(* forall m b, *) +(* valid_block m b -> *) +(* exists cp, *) +(* can_access_block m b (Some cp). *) +(* Proof. *) +(* unfold valid_block, can_access_block. intros m b Hvalid. *) +(* apply nextblock_compartments_pos in Hvalid. *) +(* assumption. *) +(* Qed. *) Theorem valid_block_can_access_block_priv: forall m b, valid_block m b -> - can_access_block m b None. -Proof. - simpl; trivial. -Qed. - -Theorem can_access_block_valid_block: - forall m b cp, - can_access_block m b (Some cp) -> - valid_block m b. -Proof. - unfold valid_block, can_access_block. intros m b cp Hown. - apply nextblock_compartments_pos. exists cp. assumption. -Qed. - -Theorem valid_pointer_can_access_block: - forall m b ofs, - valid_pointer m b ofs = true -> - exists cp, - can_access_block m b (Some cp). -Proof. - unfold valid_pointer. intros m b ofs Hperm. - destruct (perm_dec m b ofs Cur Nonempty) as [Hperm' | Hperm']; - simpl in Hperm. - - apply perm_valid_block in Hperm'. - apply valid_block_can_access_block in Hperm'. - assumption. - - congruence. -Qed. + can_access_block m b top. +Proof. + unfold can_access_block. simpl; trivial with comps. +Qed. + +(* Theorem can_access_block_valid_block: *) +(* forall m b cp, *) +(* can_access_block m b cp -> *) +(* valid_block m b. *) +(* Proof. *) +(* unfold valid_block, can_access_block. intros m b cp Hown. *) +(* apply nextblock_compartments_pos. exists cp. assumption. *) +(* Qed. *) + +(* Theorem valid_pointer_can_access_block: *) +(* forall m b ofs, *) +(* valid_pointer m b ofs = true -> *) +(* exists cp, *) +(* can_access_block m b (Some cp). *) +(* Proof. *) +(* unfold valid_pointer. intros m b ofs Hperm. *) +(* destruct (perm_dec m b ofs Cur Nonempty) as [Hperm' | Hperm']; *) +(* simpl in Hperm. *) +(* - apply perm_valid_block in Hperm'. *) +(* apply valid_block_can_access_block in Hperm'. *) +(* assumption. *) +(* - congruence. *) +(* Qed. *) (** * Operations over memory stores *) @@ -488,16 +488,8 @@ Qed. Program Definition empty: mem := mkmem (PMap.init (ZMap.init Undef)) (PMap.init (fun ofs k => None)) - (PTree.empty _) + (PMap.init top) 1%positive _ _ _ _. -Next Obligation. - unfold Plt. - rewrite PTree.gempty. - split; trivial. - intros _. - apply Pos.nlt_1_r. -Qed. - (** Allocation of a fresh block with the given bounds. Return an updated memory state and the address of the fresh block, which initially contains undefined cells. Note that allocation never fails: we model an @@ -510,7 +502,7 @@ Program Definition alloc (m: mem) (c: compartment) (lo hi: Z) := (PMap.set m.(nextblock) (fun ofs k => if zle lo ofs && zlt ofs hi then Some Freeable else None) m.(mem_access)) - (PTree.set m.(nextblock) c m.(mem_compartments)) + (PMap.set m.(nextblock) c m.(mem_compartments)) (Pos.succ m.(nextblock)) _ _ _ _, m.(nextblock)). @@ -529,16 +521,13 @@ Next Obligation. rewrite PMap.gsspec. destruct (peq b (nextblock m)). auto. apply contents_default. Qed. Next Obligation. - rewrite PTree.gsspec. + rewrite PMap.gsspec. destruct (peq b (nextblock m)) as [->|ne]. -- split; try easy. - intros H. exfalso. apply H. apply Plt_succ. -- rewrite <- nextblock_compartments; split. -+ intros H. contradict H. +- exfalso. apply H. apply Plt_succ. +- erewrite <- nextblock_compartments. reflexivity. + intros H'. + apply H. now apply Plt_trans_succ. -+ intros H. contradict H. - apply Plt_succ_inv in H. - destruct H; trivial; congruence. Qed. (** Freeing a block between the given bounds. @@ -573,7 +562,7 @@ Qed. Definition free (m: mem) (b: block) (lo hi: Z) (cp: compartment): option mem := if range_perm_dec m b lo hi Cur Freeable && - can_access_block_dec m b (Some cp) + can_access_block_dec m b cp then Some(unchecked_free m b lo hi) else None. @@ -603,7 +592,7 @@ Fixpoint getN (n: nat) (p: Z) (c: ZMap.t memval) {struct n}: list memval := memory chunk at that address. [None] is returned if the accessed bytes are not readable. *) -Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (cp: option compartment): option val := +Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (cp: compartment): option val := if valid_access_dec m chunk b ofs Readable cp then Some(decode_val chunk (getN (size_chunk_nat chunk) ofs (m.(mem_contents)#b))) else None. @@ -611,7 +600,7 @@ Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (cp: option c (** [loadv chunk m addr cp] is similar, but the address and offset are given as a single value [addr], which must be a pointer value. *) -Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) (cp: option compartment) : option val := +Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) (cp: compartment) : option val := match addr with | Vptr b ofs => load chunk m b (Ptrofs.unsigned ofs) cp | _ => None @@ -621,7 +610,7 @@ Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) (cp: option compartm location [(b, ofs)]. Returns [None] if the accessed locations are not readable. *) -Definition loadbytes (m: mem) (b: block) (ofs n: Z) (cp: option compartment): option (list memval) := +Definition loadbytes (m: mem) (b: block) (ofs n: Z) (cp: compartment): option (list memval) := if range_perm_dec m b ofs (ofs + n) Cur Readable && can_access_block_dec m b cp then Some (getN (Z.to_nat n) ofs (m.(mem_contents)#b)) @@ -709,7 +698,7 @@ Qed. are not writable. *) Program Definition store (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val) (cp : compartment): option mem := - if valid_access_dec m chunk b ofs Writable (Some cp) then + if valid_access_dec m chunk b ofs Writable cp then Some (mkmem (PMap.set b (setN (encode_val chunk v) ofs (m.(mem_contents)#b)) m.(mem_contents)) @@ -727,7 +716,7 @@ Next Obligation. apply contents_default. Qed. Next Obligation. - eapply nextblock_compartments. + eapply nextblock_compartments; eauto. Qed. (** [storev chunk m addr v cp] is similar, but the address and offset are given @@ -745,7 +734,7 @@ Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) (cp : compartment Program Definition storebytes (m: mem) (b: block) (ofs: Z) (bytes: list memval) (cp: compartment) : option mem := if range_perm_dec m b ofs (ofs + Z.of_nat (length bytes)) Cur Writable && - can_access_block_dec m b (Some cp) + can_access_block_dec m b cp then Some (mkmem (PMap.set b (setN bytes ofs (m.(mem_contents)#b)) m.(mem_contents)) @@ -776,7 +765,7 @@ Qed. funny [Program Definition] misbehavior in the second [Obligation]. *) Program Definition drop_perm (m: mem) (b: block) (lo hi: Z) (p: permission) (cp: compartment): option mem := if range_perm_dec m b lo hi Cur Freeable then - if can_access_block_dec m b (Some cp) then + if can_access_block_dec m b cp then Some (mkmem m.(mem_contents) (PMap.set b (fun ofs k => if zle lo ofs && zlt ofs hi then Some p else m.(mem_access)#b ofs k) @@ -858,18 +847,18 @@ Qed. Lemma load_Some_None: forall chunk m sp ofs cp v, Mem.load chunk m sp ofs cp = Some v -> - Mem.load chunk m sp ofs None = Some v. + Mem.load chunk m sp ofs top = Some v. Proof. - intros. destruct cp as [cp |]; [|auto]. + intros. destruct (cp_eq_dec cp top) as [e | n0]; [subst; auto|]. unfold load in *. - destruct (Mem.valid_access_dec m chunk sp ofs Readable (Some cp)); try discriminate. + destruct (Mem.valid_access_dec m chunk sp ofs Readable cp); try discriminate. inv H. destruct v0 as [? [? ?]]. - destruct (Mem.valid_access_dec m chunk sp ofs Readable None). + destruct (Mem.valid_access_dec m chunk sp ofs Readable top). reflexivity. apply Classical_Prop.not_and_or in n as [? | n]; try contradiction. apply Classical_Prop.not_and_or in n as [? | ?]; try contradiction. - simpl in H2. contradiction. + unfold can_access_block in H2. pose proof (flowsto_top (block_compartment m sp)); contradiction. Qed. Local Hint Resolve load_valid_access valid_access_load: mem. @@ -1181,7 +1170,7 @@ Qed. Theorem valid_access_store: forall m1 chunk b ofs cp v, - valid_access m1 chunk b ofs Writable (Some cp) -> + valid_access m1 chunk b ofs Writable cp -> { m2: mem | store chunk m1 b ofs v cp = Some m2 }. Proof. intros. @@ -1259,7 +1248,7 @@ Theorem store_valid_access_1: Proof. intros. inv H. destruct H1 as [H1 H2]. constructor; try red; auto with mem. split. - unfold store in STORE. - destruct (valid_access_dec m1 chunk b ofs Writable (Some cp)); [| congruence]. + destruct (valid_access_dec m1 chunk b ofs Writable cp); [| congruence]. inv STORE. auto. - auto. Qed. @@ -1270,25 +1259,25 @@ Theorem store_valid_access_2: Proof. intros. inv H. destruct H1 as [H1 H2]. constructor; try red; auto with mem. split. - unfold store in STORE. - destruct (valid_access_dec m1 chunk b ofs Writable (Some cp)); [| congruence]. + destruct (valid_access_dec m1 chunk b ofs Writable cp); [| congruence]. inv STORE. auto. - auto. Qed. Theorem store_valid_access_3: - valid_access m1 chunk b ofs Writable (Some cp). + valid_access m1 chunk b ofs Writable cp. Proof. - unfold store in STORE. destruct (valid_access_dec m1 chunk b ofs Writable (Some cp)). + unfold store in STORE. destruct (valid_access_dec m1 chunk b ofs Writable cp). auto. congruence. Qed. Theorem store_valid_access_4: - valid_access m1 chunk b ofs Writable None. + valid_access m1 chunk b ofs Writable top. Proof. unfold store in STORE. - destruct (valid_access_dec m1 chunk b ofs Writable (Some cp)) as [[? [? ?]] |]. - split; [| split]; now simpl. + destruct (valid_access_dec m1 chunk b ofs Writable cp) as [[? [? ?]] |]. + split; [| split]; try now simpl; auto with comps. congruence. Qed. @@ -1309,12 +1298,12 @@ Theorem load_store_similar: forall chunk', size_chunk chunk' = size_chunk chunk -> align_chunk chunk' <= align_chunk chunk -> - exists v', load chunk' m2 b ofs (Some cp) = Some v' /\ decode_encode_val v chunk chunk' v'. + exists v', load chunk' m2 b ofs cp = Some v' /\ decode_encode_val v chunk chunk' v'. Proof. intros. exploit (valid_access_load m2 chunk'). eapply valid_access_compat. symmetry; eauto. auto. - instantiate (1 := Some cp). eauto with mem. + instantiate (1 := cp). eauto with mem. intros [v' LOAD]. exists v'; split; auto. exploit load_result; eauto. intros B. @@ -1331,14 +1320,14 @@ Theorem load_store_similar_2: size_chunk chunk' = size_chunk chunk -> align_chunk chunk' <= align_chunk chunk -> type_of_chunk chunk' = type_of_chunk chunk -> - load chunk' m2 b ofs (Some cp) = Some (Val.load_result chunk' v). + load chunk' m2 b ofs cp = Some (Val.load_result chunk' v). Proof. intros. destruct (load_store_similar chunk') as [v' [A B]]; auto. rewrite A. decEq. eapply decode_encode_val_similar with (chunk1 := chunk); eauto. Qed. Theorem load_store_same: - load chunk m2 b ofs (Some cp) = Some (Val.load_result chunk v). + load chunk m2 b ofs cp = Some (Val.load_result chunk v). Proof. apply load_store_similar_2; auto. lia. Qed. @@ -1364,11 +1353,11 @@ Proof. Qed. Theorem loadbytes_store_same: - loadbytes m2 b ofs (size_chunk chunk) (Some cp) = Some(encode_val chunk v). + loadbytes m2 b ofs (size_chunk chunk) cp = Some(encode_val chunk v). Proof. intros. - assert (valid_access m2 chunk b ofs Readable (Some cp)) by eauto with mem. - destruct (can_access_block_dec m2 b (Some cp)); + assert (valid_access m2 chunk b ofs Readable cp) by eauto with mem. + destruct (can_access_block_dec m2 b cp); [ | inversion H as [_ [Hcontra _]]; contradiction]. unfold loadbytes. rewrite andb_lazy_alt. setoid_rewrite pred_dec_true. setoid_rewrite pred_dec_true. @@ -1382,11 +1371,11 @@ Proof. Qed. Theorem loadbytes_store_same_priv: - loadbytes m2 b ofs (size_chunk chunk) None = Some(encode_val chunk v). + loadbytes m2 b ofs (size_chunk chunk) top = Some(encode_val chunk v). Proof. intros. - assert (valid_access m2 chunk b ofs Readable None) by (eauto with mem). - destruct (can_access_block_dec m2 b None); + assert (valid_access m2 chunk b ofs Readable top) by (eauto with mem). + destruct (can_access_block_dec m2 b top); [ | inversion H as [_ [Hcontra _]]; contradiction]. unfold loadbytes. rewrite andb_lazy_alt. setoid_rewrite pred_dec_true. setoid_rewrite pred_dec_true. @@ -1410,24 +1399,24 @@ Proof. destruct (range_perm_dec m2 b' ofs' (ofs' + n) Cur Readable); try contradiction; try assumption; (unfold store in STORE; - destruct (valid_access_dec m1 chunk b ofs Writable (Some cp)); + destruct (valid_access_dec m1 chunk b ofs Writable cp); inv STORE; now auto). Qed. Remark store_can_access_block_1 : - can_access_block m1 b (Some cp). + can_access_block m1 b cp. Proof. unfold store in STORE. - destruct (valid_access_dec m1 chunk b ofs Writable (Some cp)) + destruct (valid_access_dec m1 chunk b ofs Writable cp) as [[_ [OWN _]] |]; easy. Qed. Remark store_can_access_block_2 : - can_access_block m2 b (Some cp). + can_access_block m2 b cp. Proof. unfold store in STORE. - destruct (Mem.valid_access_dec m1 chunk b ofs Writable (Some cp)) + destruct (Mem.valid_access_dec m1 chunk b ofs Writable cp) as [[_ [OWN _]] |]; try discriminate. inv STORE. easy. Qed. @@ -1441,7 +1430,7 @@ Proof. destruct (can_access_block_dec m2 b' cp'); try contradiction; try assumption; (unfold store in STORE; - destruct (valid_access_dec m1 chunk b ofs Writable (Some cp)); + destruct (valid_access_dec m1 chunk b ofs Writable cp); inv STORE; now auto). Qed. @@ -1736,7 +1725,7 @@ Qed. Theorem range_perm_storebytes: forall m1 b ofs bytes cp, range_perm m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writable -> - can_access_block m1 b (Some cp) -> + can_access_block m1 b cp -> { m2 : mem | storebytes m1 b ofs bytes cp = Some m2 }. Proof. intros. unfold storebytes. @@ -1752,7 +1741,7 @@ Theorem storebytes_store: store chunk m1 b ofs v cp = Some m2. Proof. unfold storebytes, store. intros. - destruct (can_access_block_dec m1 b (Some cp)); [| rewrite andb_false_r in H; now inversion H]. + destruct (can_access_block_dec m1 b cp); [| rewrite andb_false_r in H; now inversion H]. destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (length (encode_val chunk v))) Cur Writable); inv H. destruct (valid_access_dec m1 chunk b ofs Writable). f_equal. apply mkmem_ext; auto. @@ -1768,7 +1757,7 @@ Proof. unfold storebytes, store. intros. destruct (valid_access_dec m1 chunk b ofs Writable); inv H. inversion v0 as [_ [Hown _]]. - destruct (can_access_block_dec m1 b (Some cp)); [| contradiction]. + destruct (can_access_block_dec m1 b cp); [| contradiction]. destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (length (encode_val chunk v))) Cur Writable). simpl. f_equal. apply mkmem_ext; auto. @@ -1785,22 +1774,22 @@ Variable cp: compartment. Variable m2: mem. Hypothesis STORE: storebytes m1 b ofs bytes cp = Some m2. -Lemma storebytes_can_access_block_1 : can_access_block m1 b (Some cp). +Lemma storebytes_can_access_block_1 : can_access_block m1 b cp. Proof. unfold storebytes in STORE. destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (Datatypes.length bytes)) Cur Writable); [| now inversion STORE]. - destruct (can_access_block_dec m1 b (Some cp)); + destruct (can_access_block_dec m1 b cp); [| now inversion STORE]. assumption. Qed. -Lemma storebytes_can_access_block_2 : can_access_block m2 b (Some cp). +Lemma storebytes_can_access_block_2 : can_access_block m2 b cp. Proof. unfold storebytes in STORE. destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (Datatypes.length bytes)) Cur Writable); [| now inversion STORE]. - destruct (can_access_block_dec m1 b (Some cp)); + destruct (can_access_block_dec m1 b cp); inv STORE. assumption. Qed. @@ -1814,7 +1803,7 @@ Proof. unfold can_access_block, storebytes in *; intros b' cp' H; destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (Datatypes.length bytes)) Cur Writable); - destruct (can_access_block_dec m1 b (Some cp)); + destruct (can_access_block_dec m1 b cp); inv STORE; assumption. Qed. @@ -1825,7 +1814,7 @@ Proof. unfold can_access_block, storebytes in *; intros b' cp' H; destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (Datatypes.length bytes)) Cur Writable); - destruct (can_access_block_dec m1 b (Some cp)); + destruct (can_access_block_dec m1 b cp); inv STORE; assumption. Qed. @@ -1834,7 +1823,7 @@ Lemma storebytes_access: mem_access m2 = mem_access m1. Proof. unfold storebytes in STORE. destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writable); - destruct (can_access_block_dec m1 b (Some cp)); + destruct (can_access_block_dec m1 b cp); inv STORE. auto. Qed. @@ -1844,7 +1833,7 @@ Lemma storebytes_mem_contents: Proof. unfold storebytes in STORE. destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writable); - destruct (can_access_block_dec m1 b (Some cp)); + destruct (can_access_block_dec m1 b cp); inv STORE. auto. Qed. @@ -1901,7 +1890,7 @@ Proof. intros. unfold storebytes in STORE. destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writable); - destruct (can_access_block_dec m1 b (Some cp)); + destruct (can_access_block_dec m1 b cp); inv STORE. auto. Qed. @@ -1931,11 +1920,11 @@ Proof. Qed. Theorem loadbytes_storebytes_same: - loadbytes m2 b ofs (Z.of_nat (length bytes)) (Some cp) = Some bytes. + loadbytes m2 b ofs (Z.of_nat (length bytes)) cp = Some bytes. Proof. intros. assert (STORE2:=STORE). unfold storebytes in STORE2. unfold loadbytes. destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writable); - destruct (can_access_block_dec m1 b (Some cp)); + destruct (can_access_block_dec m1 b cp); try discriminate. setoid_rewrite pred_dec_true. simpl. decEq. inv STORE2; simpl. rewrite PMap.gss. rewrite Nat2Z.id. @@ -1945,17 +1934,17 @@ Proof. Qed. Theorem loadbytes_storebytes_same_None: - loadbytes m2 b ofs (Z.of_nat (length bytes)) None = Some bytes. + loadbytes m2 b ofs (Z.of_nat (length bytes)) top = Some bytes. Proof. intros. assert (STORE2:=STORE). unfold storebytes in STORE2. unfold loadbytes. destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writable); - destruct (can_access_block_dec m1 b (Some cp)); + destruct (can_access_block_dec m1 b cp); try discriminate. setoid_rewrite pred_dec_true. simpl. decEq. inv STORE2; simpl. rewrite PMap.gss. rewrite Nat2Z.id. apply getN_setN_same. red; eauto with mem. - reflexivity. + simpl; auto with comps. Qed. Theorem loadbytes_storebytes_disjoint: @@ -2042,16 +2031,15 @@ Proof. intros. generalize H; intro ST1. generalize H0; intro ST2. unfold storebytes; unfold storebytes in ST1; unfold storebytes in ST2. destruct (range_perm_dec m b ofs (ofs + Z.of_nat(length bytes1)) Cur Writable); - destruct (can_access_block_dec m b (Some cp)); + destruct (can_access_block_dec m b cp); simpl in *; try congruence. - destruct (range_perm_dec m1 b (ofs + Z.of_nat(length bytes1)) (ofs + Z.of_nat(length bytes1) + Z.of_nat(length bytes2)) Cur Writable); + destruct (range_perm_dec m1 b (ofs + Z.of_nat(length bytes1)) + (ofs + Z.of_nat(length bytes1) + Z.of_nat(length bytes2)) Cur Writable); simpl in *; try congruence. - destruct (can_access_block_dec m1 b (Some cp)) eqn:rewr; simpl in rewr; rewrite rewr in ST2; - simpl in *; - try congruence. - destruct (range_perm_dec m b ofs (ofs + Z.of_nat (length (bytes1 ++ bytes2))) Cur Writable). - inv ST1; inv ST2; simpl. decEq. apply mkmem_ext; auto. + destruct (can_access_block_dec m1 b cp) eqn:rewr; simpl in *; try congruence. + destruct (range_perm_dec m b ofs (ofs + Z.of_nat (length (bytes1 ++ bytes2))) Cur Writable); simpl in *. + inv ST1; inv ST2; simpl in *; try congruence. decEq. apply mkmem_ext; auto. rewrite PMap.gss. rewrite setN_concat. symmetry. apply PMap.set2. elim n. rewrite app_length. rewrite Nat2Z.inj_add. red; intros. @@ -2121,7 +2109,7 @@ Qed. (* RB: NOTE: Maybe add these new lemmas to hint databases. *) Lemma block_compartment_nextblock m: - block_compartment m (nextblock m) = None. + block_compartment m (nextblock m) = top. Proof. destruct m. simpl in *. apply nextblock_compartments0. apply Plt_strict. @@ -2170,20 +2158,21 @@ Proof. Qed. Theorem unowned_fresh_block: - forall c', ~can_access_block m1 b (Some c'). + forall c', can_access_block m1 b c' -> c' = top. Proof. unfold can_access_block. intros c'. injection ALLOC as _ <-. rewrite block_compartment_nextblock. - congruence. + intros ?. assert (c' ⊆ top) by now apply flowsto_top. + exploit flowsto_antisym; eauto. Qed. Theorem owned_new_block: - can_access_block m2 b (Some c). + Mem.block_compartment m2 b = c. Proof. - unfold can_access_block. + unfold block_compartment. unfold alloc in ALLOC. destruct m1. inv ALLOC. simpl in *. - apply PTree.gss. + rewrite PMap.gss; auto with comps. Qed. Local Hint Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. @@ -2247,35 +2236,36 @@ Local Hint Resolve perm_alloc_1 perm_alloc_2 perm_alloc_3 perm_alloc_4: mem. Theorem alloc_block_compartment: forall b', block_compartment m2 b' = - if eq_block b' b then Some c else block_compartment m1 b'. + if eq_block b' b then c else block_compartment m1 b'. Proof. intros b'. injection ALLOC as <- <-. unfold block_compartment. simpl. destruct eq_block as [->|neq]. -- now rewrite PTree.gss. -- now rewrite PTree.gso. +- now rewrite PMap.gss; auto with comps. +- now rewrite PMap.gso. Qed. -Lemma alloc_can_access_block_inj : - forall b' c', can_access_block m1 b' (Some c') -> b <> b'. -Proof. - intros b' c' Hown Heq; subst b'. - unfold can_access_block in Hown. - now rewrite alloc_result, block_compartment_nextblock in Hown. -Qed. +(* Lemma alloc_can_access_block_inj : *) +(* forall b' c', can_access_block m1 b' c' -> b <> b'. *) +(* Proof. *) +(* intros b' c' Hown Heq; subst b'. *) +(* unfold can_access_block in Hown. *) +(* now rewrite alloc_result, block_compartment_nextblock in Hown. *) +(* Qed. *) Lemma alloc_can_access_block_other_inj_1 : forall b' c', can_access_block m1 b' c' -> can_access_block m2 b' c'. Proof. - unfold can_access_block. intros b' [c' |] Hown; [| trivial]. + unfold can_access_block. intros b' c' Hown. rewrite alloc_block_compartment. destruct eq_block as [->|neq]; trivial. - now rewrite alloc_result, block_compartment_nextblock in Hown. + rewrite alloc_result, block_compartment_nextblock in Hown. + eapply flowsto_trans. eapply flowsto_top. eauto. Qed. Lemma alloc_can_access_block_other_inj_2 : forall b' c', b' <> b -> can_access_block m2 b' c' -> can_access_block m1 b' c'. Proof. - unfold can_access_block. intros b' [c' |] Hneq Hown; [| trivial]. + unfold can_access_block. intros b' c' Hneq Hown. rewrite alloc_block_compartment in Hown. destruct eq_block; congruence. Qed. @@ -2295,12 +2285,12 @@ Qed. Theorem valid_access_alloc_same: forall chunk ofs, lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) -> - valid_access m2 chunk b ofs Freeable (Some c). + valid_access m2 chunk b ofs Freeable c. Proof. intros. constructor; auto with mem. red; intros. apply perm_alloc_2. lia. split. - apply owned_new_block. + simpl; rewrite owned_new_block; auto with comps. auto. Qed. @@ -2369,10 +2359,10 @@ Qed. known facts. *) Theorem load_alloc_same': forall chunk ofs, - lo <= ofs -> ofs + size_chunk chunk <= hi -> can_access_block m2 b (Some c) -> (align_chunk chunk | ofs) -> - load chunk m2 b ofs (Some c) = Some Vundef. + lo <= ofs -> ofs + size_chunk chunk <= hi -> can_access_block m2 b c -> (align_chunk chunk | ofs) -> + load chunk m2 b ofs c = Some Vundef. Proof. - intros. assert (exists v, load chunk m2 b ofs (Some c) = Some v). + intros. assert (exists v, load chunk m2 b ofs c = Some v). apply valid_access_load. constructor; auto. red; intros. eapply perm_implies. apply perm_alloc_2. lia. auto with mem. destruct H3 as [v LOAD]. rewrite LOAD. decEq. @@ -2428,7 +2418,7 @@ Local Hint Resolve valid_access_alloc_other valid_access_alloc_same: mem. Theorem range_perm_free: forall m1 b lo hi cp, range_perm m1 b lo hi Cur Freeable -> - can_access_block m1 b (Some cp) -> + can_access_block m1 b cp -> { m2: mem | free m1 b lo hi cp = Some m2 }. Proof. intros; unfold free. econstructor. setoid_rewrite pred_dec_true; auto. simpl. eauto. @@ -2447,7 +2437,7 @@ Theorem free_range_perm: range_perm m1 bf lo hi Cur Freeable. Proof. unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Cur Freeable); auto. - destruct (can_access_block_dec m1 bf (Some cp)); simpl in FREE; + destruct (can_access_block_dec m1 bf cp); simpl in FREE; congruence. Qed. @@ -2456,7 +2446,7 @@ Lemma free_result: Proof. unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Cur Freeable); - destruct (can_access_block_dec m1 bf (Some cp)); + destruct (can_access_block_dec m1 bf cp); simpl in FREE; congruence. Qed. @@ -2526,20 +2516,20 @@ Proof. destruct (zlt ofs hi); simpl; auto. Qed. -Lemma free_can_access_block_1 : can_access_block m1 bf (Some cp). +Lemma free_can_access_block_1 : can_access_block m1 bf cp. Proof. unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Cur Freeable); - destruct (can_access_block_dec m1 bf (Some cp)); + destruct (can_access_block_dec m1 bf cp); simpl in FREE; congruence. Qed. -Lemma free_can_access_block_2 : can_access_block m2 bf (Some cp). +Lemma free_can_access_block_2 : can_access_block m2 bf cp. Proof. unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Cur Freeable); - destruct (can_access_block_dec m1 bf (Some cp)); + destruct (can_access_block_dec m1 bf cp); inv FREE. unfold unchecked_free; destruct (zle hi lo); assumption. Qed. @@ -2548,24 +2538,24 @@ Lemma free_can_access_block_inj_1 : forall b cp', can_access_block m1 b cp' -> can_access_block m2 b cp'. Proof. unfold can_access_block. - intros b [cp' |] Hown; [| trivial]. + intros b cp' Hown. unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Cur Freeable); [| simpl in FREE; congruence]. - destruct (can_access_block_dec m1 bf (Some cp)); [| simpl in FREE; congruence]. - inv FREE. rewrite <- Hown. - unfold unchecked_free; destruct (zle hi lo); reflexivity. + destruct (can_access_block_dec m1 bf cp); [| simpl in FREE; congruence]. + inv FREE. (* rewrite <- Hown. *) + unfold unchecked_free; destruct (zle hi lo); auto. Qed. Lemma free_can_access_block_inj_2 : forall b cp', can_access_block m2 b cp' -> can_access_block m1 b cp'. Proof. unfold can_access_block. - intros b [cp' |] Hown; [| trivial]. + intros b cp' Hown. unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Cur Freeable); [| simpl in FREE; congruence]. - destruct (can_access_block_dec m1 bf (Some cp)); [| simpl in FREE; congruence]. - inv FREE. rewrite <- Hown. - unfold unchecked_free; destruct (zle hi lo); reflexivity. + destruct (can_access_block_dec m1 bf cp); [| simpl in FREE; congruence]. + inv FREE. (* rewrite <- Hown. *) + unfold unchecked_free in *; destruct (zle hi lo); auto. Qed. Theorem valid_access_free_1: @@ -2703,12 +2693,12 @@ Qed. Theorem range_perm_drop_2: forall m b lo hi cp p, range_perm m b lo hi Cur Freeable -> - can_access_block m b (Some cp) -> + can_access_block m b cp -> {m' | drop_perm m b lo hi p cp = Some m' }. Proof. unfold drop_perm; intros. destruct (range_perm_dec m b lo hi Cur Freeable). -- destruct (can_access_block_dec m b (Some cp)). +- destruct (can_access_block_dec m b cp). + econstructor. eauto. + contradiction. - contradiction. @@ -2729,7 +2719,7 @@ Theorem nextblock_drop: Proof. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); - destruct (can_access_block_dec m b (Some cp)); + destruct (can_access_block_dec m b cp); inv DROP; auto. Qed. @@ -2760,7 +2750,7 @@ Proof. intros. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); - destruct (can_access_block_dec m b (Some cp)); + destruct (can_access_block_dec m b cp); inv DROP. unfold perm. simpl. rewrite PMap.gss. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. simpl. constructor. @@ -2773,7 +2763,7 @@ Proof. intros. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); - destruct (can_access_block_dec m b (Some cp)); + destruct (can_access_block_dec m b cp); inv DROP. revert H0. unfold perm; simpl. rewrite PMap.gss. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. simpl. auto. @@ -2786,7 +2776,7 @@ Proof. intros. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); - destruct (can_access_block_dec m b (Some cp)); + destruct (can_access_block_dec m b cp); inv DROP. unfold perm; simpl. rewrite PMap.gsspec. destruct (peq b' b). subst b'. unfold proj_sumbool. destruct (zle lo ofs). destruct (zlt ofs hi). @@ -2800,7 +2790,7 @@ Proof. intros. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); - destruct (can_access_block_dec m b (Some cp)); + destruct (can_access_block_dec m b cp); inv DROP. revert H. unfold perm; simpl. rewrite PMap.gsspec. destruct (peq b' b). subst b'. unfold proj_sumbool. destruct (zle lo ofs). destruct (zlt ofs hi). @@ -2815,7 +2805,7 @@ Proof. unfold can_access_block. intros b' cp' Hown. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); [| now inversion DROP]. - destruct (can_access_block_dec m b (Some cp)); [| now inversion DROP]. + destruct (can_access_block_dec m b cp); [| now inversion DROP]. inv DROP. assumption. Qed. @@ -2825,23 +2815,23 @@ Proof. unfold can_access_block. intros b' cp' Hown. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); [| now inversion DROP]. - destruct (can_access_block_dec m b (Some cp)); [| now inversion DROP]. + destruct (can_access_block_dec m b cp); [| now inversion DROP]. inv DROP. assumption. Qed. Theorem can_access_block_drop_3: - can_access_block m b (Some cp). + can_access_block m b cp. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); [| congruence]. - destruct (can_access_block_dec m b (Some cp)); [| congruence]. + destruct (can_access_block_dec m b cp); [| congruence]. assumption. Qed. Theorem can_access_block_drop_4: - can_access_block m' b (Some cp). + can_access_block m' b cp. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); [| congruence]. - destruct (can_access_block_dec m b (Some cp)); [| congruence]. + destruct (can_access_block_dec m b cp); [| congruence]. inv DROP. destruct m. unfold can_access_block in *. simpl in *. assumption. Qed. @@ -2884,7 +2874,7 @@ Proof. rewrite pred_dec_true. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); - destruct (can_access_block_dec m b (Some cp)); + destruct (can_access_block_dec m b cp); inv DROP. simpl. auto. eapply valid_access_drop_1; eauto. rewrite pred_dec_false. auto. @@ -2903,7 +2893,7 @@ Proof. + setoid_rewrite pred_dec_true. * unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); - destruct (can_access_block_dec m b (Some cp)); + destruct (can_access_block_dec m b cp); inv DROP. simpl. auto. * red; intros. destruct (eq_block b' b). subst b'. @@ -3107,7 +3097,7 @@ Lemma store_mapped_inj: /\ mem_inj f n1 n2. Proof. intros. - assert (valid_access m2 chunk b2 (ofs + delta) Writable (Some cp)). + assert (valid_access m2 chunk b2 (ofs + delta) Writable cp). eapply valid_access_inj; eauto with mem. destruct (valid_access_store _ _ _ _ _ v2 H4) as [n2 STORE]. exists n2; split. auto. @@ -3377,9 +3367,9 @@ Qed. (* RB: NOTE: Move up, use in previous proofs. *) 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'. + forall m b cp cp', can_access_block m b cp -> can_access_block m b cp' -> can_access_block m b (cp ∪ cp'). Proof. - congruence. + simpl. intros. eapply flowsto_trans; eauto with comps. Qed. Lemma alloc_left_unmapped_inj: @@ -3421,7 +3411,7 @@ Lemma alloc_left_mapped_inj: inj_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), + forall OWN : can_access_block m2 b2 c, mem_inj f m1' m2. Proof. intros. inversion H. constructor. @@ -3430,12 +3420,15 @@ Proof. 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). + intros. destruct (eq_block b0 b1). { + (* assert (Mem.block_compartment m2 b3 = Mem.block_compartment m1' b1). *) + (* { subst b0. unfold block_compartment. *) + (* } *) 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. + apply owned_new_block in H0. simpl in *. + rewrite H0 in H6. + now eapply flowsto_trans; eauto. } { eapply mi_own0; eauto. eapply alloc_can_access_block_other_inj_2; eassumption. @@ -3533,7 +3526,7 @@ Proof. apply mi_memval0; auto. eapply perm_drop_4; eauto. unfold drop_perm in H0; destruct (range_perm_dec m1 b lo hi Cur Freeable); - destruct (can_access_block_dec m1 b (Some cp)); + destruct (can_access_block_dec m1 b cp); inv H0; auto. Qed. @@ -3607,11 +3600,11 @@ Proof. apply mi_memval0; auto. eapply perm_drop_4; eauto. unfold drop_perm in DROP; destruct (range_perm_dec m2 b2 (lo + delta) (hi + delta) Cur Freeable); - destruct (can_access_block_dec m2 b2 (Some cp)); + destruct (can_access_block_dec m2 b2 cp); inv DROP; auto. unfold drop_perm in H0; destruct (range_perm_dec m1 b1 lo hi Cur Freeable); - destruct (can_access_block_dec m1 b1 (Some cp)); + destruct (can_access_block_dec m1 b1 cp); inv H0; auto. Qed. @@ -3641,7 +3634,7 @@ Proof. apply mi_memval0; auto. unfold drop_perm in H0; destruct (range_perm_dec m2 b lo hi Cur Freeable); - destruct (can_access_block_dec m2 b (Some cp)); + destruct (can_access_block_dec m2 b cp); inv H0; auto. Qed. @@ -3833,7 +3826,7 @@ Proof. eapply perm_implies with Freeable; auto with mem. eapply perm_alloc_2; eauto. lia. - eapply owned_new_block; eassumption. + simpl. apply owned_new_block in ALLOC; subst; auto with comps. intros. eapply perm_alloc_inv in H; eauto. generalize (perm_alloc_inv _ _ _ _ _ _ H0 b0 ofs Max Nonempty); intros PERM. destruct (eq_block b0 b). @@ -3942,11 +3935,10 @@ Theorem valid_pointer_extends: extends m1 m2 -> valid_pointer m1 b ofs = true -> valid_pointer m2 b ofs = true. Proof. intros m1 m2 b ofs Hextend Hvalid. - destruct (valid_pointer_can_access_block _ _ _ Hvalid) as [cp Hown1]. - rewrite valid_pointer_valid_access_nonpriv in Hvalid; [| eassumption]. + eapply valid_pointer_valid_access in Hvalid; eauto. destruct (valid_access_extends _ _ _ _ _ _ _ Hextend Hvalid) as [Hperm [Hown2 Halign]]. - rewrite valid_pointer_valid_access_nonpriv; [| eassumption]. - split; auto. + rewrite valid_pointer_valid_access; eauto . + repeat (split; simpl); eauto with comps. eapply flowsto_refl. Qed. Theorem weak_valid_pointer_extends: @@ -3966,7 +3958,7 @@ Qed. is itself valid; - the memory value associated in [m1] to an accessible address must inject into [m2]'s memory value at the corersponding address; -- unallocated blocks in [m1] must be mapped to [None] by [f]; +- unallocated blocks in [m1] must be mapped to [top] 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; @@ -4068,12 +4060,10 @@ Theorem valid_pointer_inject: 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_inject; eauto. - inv H0. inv mi_inj0. eapply mi_own0 with (cp := Some cp); eauto. + eapply valid_pointer_valid_access in H1; eauto using flowsto_refl. + eapply valid_access_inject in H1; eauto. + eapply valid_pointer_valid_access in H1; eauto. + inv H0. inv mi_inj0. eapply mi_own0; eauto. now apply flowsto_refl. Qed. Theorem weak_valid_pointer_inject: @@ -4150,11 +4140,11 @@ Theorem valid_pointer_inject_val: valid_pointer m2 b' (Ptrofs.unsigned ofs') = true. Proof. intros. inv H1. - pose proof valid_pointer_can_access_block _ _ _ H0 as [cp Hown]. + (* pose proof valid_pointer_can_access_block _ _ _ H0 as [cp Hown]. *) erewrite address_inject'; eauto. eapply valid_pointer_inject; eauto. - rewrite valid_pointer_valid_access_nonpriv in H0. eauto. - eauto. + rewrite valid_pointer_valid_access in H0. eauto. + now eapply flowsto_refl. Qed. Theorem weak_valid_pointer_inject_val: @@ -4200,18 +4190,16 @@ Theorem different_pointers_inject: 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_inject' _ _ _ _ _ _ (Some cp1) _ _ H H1 H3). - rewrite (address_inject' _ _ _ _ _ _ (Some cp2) _ _ H H2 H4). + (* 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 in H1; eauto using flowsto_refl. + rewrite valid_pointer_valid_access in H2; eauto using flowsto_refl. + rewrite (address_inject' _ _ _ _ _ _ _ _ _ H H1 H3). + rewrite (address_inject' _ _ _ _ _ _ _ _ _ H H2 H4). inv H1. simpl in H5. inv H2. simpl in H1. eapply mi_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_inject: @@ -4597,7 +4585,7 @@ Theorem alloc_left_mapped_inject: inject f m1 m2 -> alloc m1 c lo hi = (m1', b1) -> valid_block m2 b2 -> - forall OWN : can_access_block m2 b2 (Some c), + forall OWN : can_access_block m2 b2 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) -> @@ -4624,9 +4612,9 @@ Proof. 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). + unfold f'; intros. destruct (eq_block b0 b1). inversion H8. subst b0 b3 delta0. - apply unowned_fresh_block with (c' := cp) in H0. contradiction. + apply unowned_fresh_block with (c' := cp) in H0; eauto. subst. now apply flowsto_top. eapply mi_own0; eauto. unfold f'; intros. destruct (eq_block b0 b1). inversion H8. subst b0 b3 delta0. @@ -4705,7 +4693,7 @@ Proof. eapply alloc_right_inject; eauto. eauto. instantiate (1 := b2). eauto with mem. - eapply owned_new_block; eauto. + eapply owned_new_block in ALLOC; subst; eauto with comps. instantiate (1 := 0). unfold Ptrofs.max_unsigned. generalize Ptrofs.modulus_pos; lia. auto. intros. apply perm_implies with Freeable; auto with mem. @@ -5068,9 +5056,10 @@ Proof. unfold flat_inj; intros. destruct (plt b1 thr); inv H. replace (ofs + 0) with ofs by lia; auto. (* own *) - intros. destruct cp as [cp| ]; [| trivial]. + intros. unfold can_access_block, block_compartment in H0. - now rewrite PTree.gempty in H0. + unfold empty in H0. simpl in H0. + rewrite PMap.gi in H0. eapply flowsto_trans; eauto with comps. (* align *) unfold flat_inj; intros. destruct (plt b1 thr); inv H. apply Z.divide_0_r. (* mem_contents *) @@ -5093,7 +5082,7 @@ Proof. eapply perm_alloc_2; eauto. lia. unfold flat_inj. apply pred_dec_true. rewrite (alloc_result _ _ _ _ _ _ H). auto. - eapply owned_new_block; eauto. + eapply owned_new_block in H; subst; eauto with comps. Qed. Theorem store_inject_neutral: @@ -5144,9 +5133,8 @@ Record unchanged_on (m_before m_after: mem) : Prop := mk_unchanged_on { ZMap.get ofs (PMap.get b m_before.(mem_contents)); unchanged_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) + (* valid_block m_before b -> (* Adjust preconditions as needed. *) *) + (can_access_block m_before b cp -> can_access_block m_after b cp) }. Lemma unchanged_on_refl: @@ -5187,8 +5175,7 @@ Proof. eapply valid_block_unchanged_on; eauto. - intros. transitivity (ZMap.get ofs (mem_contents m2)#b); apply unchanged_on_contents; auto. eapply perm_unchanged_on; eauto. -- intros. transitivity (can_access_block m2 b cp); apply unchanged_on_own; auto. - eapply valid_block_unchanged_on; eauto. +- intros. eapply unchanged_on_own; eauto. eapply unchanged_on_own; eauto. Qed. Lemma loadbytes_unchanged_on_1: @@ -5202,7 +5189,8 @@ Proof. intros. destruct (zle n 0). - erewrite ! loadbytes_empty; try easy. - inv H. apply unchanged_on_own0; auto. + inv H. eapply unchanged_on_own0; eauto. + (* eapply H1; eauto. lia. *) - unfold loadbytes. destruct H. destruct (range_perm_dec m b ofs (ofs + n) Cur Readable). + destruct (can_access_block_dec m b cp). @@ -5211,10 +5199,7 @@ Proof. apply unchanged_on_contents0; auto. red; intros. apply unchanged_on_perm0; auto. apply unchanged_on_own0; auto. -* setoid_rewrite pred_dec_false at 2. - rewrite andb_comm. reflexivity. - intro Hcontra. apply n0. - apply unchanged_on_own0; auto. +* contradiction. + setoid_rewrite pred_dec_false at 1. auto. red; intros; elim n0; red; intros. apply <- unchanged_on_perm0; auto. Qed. @@ -5242,9 +5227,7 @@ Proof. pose proof loadbytes_can_access_block_inj _ _ _ _ _ _ H1 as Hown. destruct (zle n 0). + erewrite loadbytes_empty in *; try assumption. - destruct cp as [cp |]; [| trivial]. inv H. eapply unchanged_on_own0; eauto. - eapply can_access_block_valid_block. eassumption. + rewrite <- H1. apply loadbytes_unchanged_on_1; auto. exploit loadbytes_range_perm; eauto. instantiate (1 := ofs). lia. intros. eauto with mem. @@ -5254,6 +5237,7 @@ Lemma load_unchanged_on_1: forall m m' chunk b cp ofs, unchanged_on m m' -> valid_block m b -> + forall (OWN: can_access_block m b cp), (forall i, ofs <= i < ofs + size_chunk chunk -> P b i) -> load chunk m' b ofs cp = load chunk m b ofs cp. Proof. @@ -5265,8 +5249,6 @@ Proof. destruct H. eapply unchanged_on_own0; eauto. - rewrite pred_dec_false. auto. red; intros [A [B C]]; elim n; split; auto. red; intros; eapply perm_unchanged_on_2; eauto. - split; auto. - destruct H. eapply unchanged_on_own0; eauto. Qed. Lemma load_unchanged_on: @@ -5277,6 +5259,8 @@ Lemma load_unchanged_on: load chunk m' b ofs cp = Some v. Proof. intros. rewrite <- H1. eapply load_unchanged_on_1; eauto with mem. + unfold load in H1. destruct (valid_access_dec m chunk b ofs Readable cp) as [v0 | ?]; try congruence. + destruct v0 as [? [? ?]]; auto. Qed. Lemma store_unchanged_on: @@ -5294,7 +5278,7 @@ Proof. destruct (zlt ofs0 ofs); auto. destruct (zlt ofs0 (ofs + size_chunk chunk)); auto. elim (H0 ofs0). lia. auto. -- eapply store_can_access_block_inj; eauto. +- rewrite <- store_can_access_block_inj; eauto. Qed. Lemma storebytes_unchanged_on: @@ -5311,9 +5295,7 @@ Proof. destruct (zlt ofs0 ofs); auto. destruct (zlt ofs0 (ofs + Z.of_nat (length bytes))); auto. elim (H0 ofs0). lia. auto. -- split. - eapply storebytes_can_access_block_inj_1; eauto. - eapply storebytes_can_access_block_inj_2; eauto. +- eapply storebytes_can_access_block_inj_1; eauto. Qed. Lemma alloc_unchanged_on: @@ -5330,10 +5312,8 @@ Proof. - injection H; intros A B. rewrite <- B; simpl. rewrite PMap.gso; auto. rewrite A. 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. ++ subst b0. eapply unowned_fresh_block with (c' := cp) in H; subst; auto with comps. ++ eapply alloc_can_access_block_other_inj_1; eauto. Qed. Lemma free_unchanged_on: @@ -5351,11 +5331,9 @@ Proof. eapply perm_free_3; eauto. - unfold free in H. destruct (range_perm_dec m b lo hi Cur Freeable); - destruct (can_access_block_dec m b (Some cp)); + destruct (can_access_block_dec m b cp); inv H. unfold unchecked_free; destruct (zle hi lo); simpl; auto. -- split. - eapply free_can_access_block_inj_1; eauto. - eapply free_can_access_block_inj_2; eauto. +- eapply free_can_access_block_inj_1; eauto. Qed. Lemma drop_perm_unchanged_on: @@ -5374,11 +5352,9 @@ Proof. eapply perm_drop_4; eauto. - unfold drop_perm in H. destruct (range_perm_dec m b lo hi Cur Freeable); - destruct (can_access_block_dec m b (Some cp)); + destruct (can_access_block_dec m b cp); inv H; simpl. auto. -- split. - eapply can_access_block_drop_1; eauto. - eapply can_access_block_drop_2; eauto. +- eapply can_access_block_drop_1; eauto. Qed. End UNCHANGED_ON. @@ -5400,10 +5376,7 @@ Qed. Section SECURITY. #[export] Instance has_side_block: has_side block := - { in_side '(s, m) := fun b δ => match Mem.block_compartment m b with - | Some cp => s cp = δ - | _ => False - end }. + { in_side '(s, m) := fun b δ => s (Mem.block_compartment m b) = δ }. #[export] Instance has_side_value: has_side val := {| in_side := fun '(s, m) v δ => match v with diff --git a/common/Memtype.v b/common/Memtype.v index 06ec295ecf..a51c7ecb7e 100644 --- a/common/Memtype.v +++ b/common/Memtype.v @@ -114,7 +114,7 @@ Parameter free: forall (m: mem) (b: block) (lo hi: Z) (cp: compartment), option addresses [b, ofs] to [b, ofs + size_chunk chunk - 1] belonging to compartment [cp] in memory state [m]. Returns the value read, or [None] if the accessed addresses are not readable. *) -Parameter load: forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (cp: option compartment), option val. +Parameter load: forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (cp: compartment), option val. (** [store chunk m b ofs v cp] writes value [v] as memory quantity [chunk] from addresses [b, ofs] to [b, ofs + size_chunk chunk - 1] in memory state @@ -126,7 +126,7 @@ Parameter store: forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: v (** [loadv] and [storev] are variants of [load] and [store] where the address being accessed is passed as a value (of the [Vptr] kind). *) -Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) (cp: option compartment) : option val := +Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) (cp: compartment) : option val := match addr with | Vptr b ofs => load chunk m b (Ptrofs.unsigned ofs) cp | _ => None @@ -144,7 +144,7 @@ Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) (cp: compartment) [None] is returned if the accessed addresses are not readable, which includes the case where the reading compartment [cp] does not own block [b]. *) -Parameter loadbytes: forall (m: mem) (b: block) (ofs n: Z) (cp: option compartment), option (list memval). +Parameter loadbytes: forall (m: mem) (b: block) (ofs n: Z) (cp: compartment), option (list memval). (** [storebytes m b ofs bytes cp] stores the given list of bytes [bytes] starting at location [(b, ofs)]. Returns updated memory state @@ -192,17 +192,17 @@ Axiom valid_not_valid_diff: (** [block_compartment m b] returns the compartment associated with the block [b] in the memory [m], or [None] if [b] is not allocated in [m]. *) -Parameter block_compartment: forall (m: mem) (b: block), option compartment. +Parameter block_compartment: forall (m: mem) (b: block), compartment. Axiom block_compartment_valid_block: forall (m: mem) (b: block), - ~valid_block m b <-> - block_compartment m b = None. + ~valid_block m b -> + block_compartment m b = top. -Definition val_compartment (m: mem) (v: val): option compartment := +Definition val_compartment (m: mem) (v: val): compartment := match v with | Vptr b _ => block_compartment m b - | _ => None + | _ => top end. (** [perm m b ofs k p] holds if the address [b, ofs] in memory state [m] @@ -248,18 +248,15 @@ Axiom range_perm_implies: (** [can_access_block m b (Some cp)] holds if block [b] is mapped to compartment [cp] in memory [m]. *) -Definition can_access_block (m: mem) (b: block) (cp: option compartment): Prop := - match cp with - | None => True - | Some cp => block_compartment m b = Some cp - end. +Definition can_access_block (m: mem) (b: block) (cp: compartment): Prop := + block_compartment m b ⊆ cp. (** An access to a memory quantity [chunk] at address [b, ofs] with permission [p] is valid in [m] if the accessed addresses all have current permission [p] and moreover the offset is properly aligned and the block, [b], belongs to compartment [cp]. *) Definition valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) - (p: permission) (cp: option compartment): Prop := + (p: permission) (cp: compartment): Prop := range_perm m b ofs (ofs + size_chunk chunk) Cur p /\ can_access_block m b cp /\ (align_chunk chunk | ofs). @@ -450,7 +447,7 @@ Axiom perm_store_2: Axiom valid_access_store: forall m1 chunk b ofs cp v, - valid_access m1 chunk b ofs Writable (Some cp) -> + valid_access m1 chunk b ofs Writable cp -> { m2: mem | store chunk m1 b ofs v cp = Some m2 }. Axiom store_valid_access_1: forall chunk m1 b ofs v cp m2, store chunk m1 b ofs v cp = Some m2 -> @@ -462,7 +459,7 @@ Axiom store_valid_access_2: valid_access m2 chunk' b' ofs' p cp' -> valid_access m1 chunk' b' ofs' p cp'. Axiom store_valid_access_3: forall chunk m1 b ofs v cp m2, store chunk m1 b ofs v cp = Some m2 -> - valid_access m1 chunk b ofs Writable (Some cp). + valid_access m1 chunk b ofs Writable cp. Axiom store_block_compartment: forall chunk m1 b ofs v cp m2, store chunk m1 b ofs v cp = Some m2 -> @@ -476,11 +473,11 @@ Axiom load_store_similar: forall chunk', size_chunk chunk' = size_chunk chunk -> align_chunk chunk' <= align_chunk chunk -> - exists v', load chunk' m2 b ofs (Some cp) = Some v' /\ decode_encode_val v chunk chunk' v'. + exists v', load chunk' m2 b ofs cp = Some v' /\ decode_encode_val v chunk chunk' v'. Axiom load_store_same: forall chunk m1 b ofs v cp m2, store chunk m1 b ofs v cp = Some m2 -> - load chunk m2 b ofs (Some cp) = Some (Val.load_result chunk v). + load chunk m2 b ofs cp = Some (Val.load_result chunk v). Axiom load_store_other: forall chunk m1 b ofs v cp m2, store chunk m1 b ofs v cp = Some m2 -> @@ -524,7 +521,7 @@ Axiom load_pointer_store: Axiom loadbytes_store_same: forall chunk m1 b ofs v cp m2, store chunk m1 b ofs v cp = Some m2 -> - loadbytes m2 b ofs (size_chunk chunk) (Some cp) = Some(encode_val chunk v). + loadbytes m2 b ofs (size_chunk chunk) cp = Some(encode_val chunk v). Axiom loadbytes_store_other: forall chunk m1 b ofs v cp m2, store chunk m1 b ofs v cp = Some m2 -> forall b' ofs' n cp', @@ -567,7 +564,7 @@ Axiom store_int16_sign_ext: Axiom range_perm_storebytes: forall m1 b ofs bytes cp, range_perm m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writable -> - can_access_block m1 b (Some cp) -> + can_access_block m1 b cp -> { m2 : mem | storebytes m1 b ofs bytes cp = Some m2 }. Axiom storebytes_range_perm: forall m1 b ofs bytes cp m2, storebytes m1 b ofs bytes cp = Some m2 -> @@ -613,7 +610,7 @@ Axiom store_storebytes: Axiom loadbytes_storebytes_same: forall m1 b ofs bytes cp m2, storebytes m1 b ofs bytes cp = Some m2 -> - loadbytes m2 b ofs (Z.of_nat (length bytes)) (Some cp) = Some bytes. + loadbytes m2 b ofs (Z.of_nat (length bytes)) cp = Some bytes. Axiom loadbytes_storebytes_other: forall m1 b ofs bytes cp m2, storebytes m1 b ofs bytes cp = Some m2 -> forall b' ofs' len cp', @@ -697,7 +694,7 @@ Axiom perm_alloc_inv: Axiom alloc_block_compartment: forall m1 c lo hi m2 b, alloc m1 c lo hi = (m2, b) -> forall b', block_compartment m2 b' = - if eq_block b' b then Some c else block_compartment m1 b'. + if eq_block b' b then c else block_compartment m1 b'. (** Effect of [alloc] on access validity. *) @@ -710,7 +707,7 @@ Axiom valid_access_alloc_same: forall m1 c lo hi m2 b, alloc m1 c lo hi = (m2, b) -> forall chunk ofs, lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) -> - valid_access m2 chunk b ofs Freeable (Some c). + valid_access m2 chunk b ofs Freeable c. Axiom valid_access_alloc_inv: forall m1 c lo hi m2 b, alloc m1 c lo hi = (m2, b) -> forall chunk b' ofs p c', @@ -740,9 +737,9 @@ Axiom load_alloc_same': forall m1 c lo hi m2 b, alloc m1 c lo hi = (m2, b) -> forall chunk ofs, lo <= ofs -> ofs + size_chunk chunk <= hi -> - can_access_block m2 b (Some c) -> + can_access_block m2 b c -> (align_chunk chunk | ofs) -> - load chunk m2 b ofs (Some c) = Some Vundef. + load chunk m2 b ofs c = Some Vundef. (** ** Properties of [free]. *) @@ -752,7 +749,7 @@ Axiom load_alloc_same': Axiom range_perm_free: forall m1 b lo hi cp, range_perm m1 b lo hi Cur Freeable -> - can_access_block m1 b (Some cp) -> + can_access_block m1 b cp -> { m2: mem | free m1 b lo hi cp = Some m2 }. Axiom free_range_perm: forall m1 bf lo hi cp m2, free m1 bf lo hi cp = Some m2 -> @@ -840,7 +837,7 @@ Axiom range_perm_drop_1: Axiom range_perm_drop_2: forall m b lo hi cp p, range_perm m b lo hi Cur Freeable -> - can_access_block m b (Some cp) -> + can_access_block m b cp -> { m' | drop_perm m b lo hi p cp = Some m' }. Axiom perm_drop_1: @@ -1209,7 +1206,7 @@ Axiom alloc_left_mapped_inject: inject f m1 m2 -> alloc m1 c lo hi = (m1', b1) -> valid_block m2 b2 -> - can_access_block m2 b2 (Some c) -> + can_access_block m2 b2 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) -> diff --git a/common/Separation.v b/common/Separation.v index cc3327fe0a..70919da823 100644 --- a/common/Separation.v +++ b/common/Separation.v @@ -870,12 +870,12 @@ Proof. Qed. Lemma external_call_parallel_rule: - forall (F V: Type) ef (ge: Genv.t F V) vargs1 m1 t vres1 m1' m2 j P vargs2, - external_call ef ge vargs1 m1 t vres1 m1' -> + forall (F V: Type) ef (ge: Genv.t F V) cp vargs1 m1 t vres1 m1' m2 j P vargs2, + external_call ef ge cp vargs1 m1 t vres1 m1' -> m2 |= minjection j m1 ** globalenv_inject ge j ** P -> Val.inject_list j vargs1 vargs2 -> exists j' vres2 m2', - external_call ef ge vargs2 m2 t vres2 m2' + external_call ef ge cp vargs2 m2 t vres2 m2' /\ Val.inject j' vres1 vres2 /\ m2' |= minjection j' m1' ** globalenv_inject ge j' ** P /\ inject_incr j j' diff --git a/lib/Maps.v b/lib/Maps.v index 7f75846988..61df802afe 100644 --- a/lib/Maps.v +++ b/lib/Maps.v @@ -170,6 +170,14 @@ Module Type MAP. Axiom gmap: forall (A B: Type) (f: A -> B) (i: elt) (m: t A), get i (map f m) = f(get i m). + + (* (** Extensional equality between trees. *) *) + (* Parameter beq: forall (A: Type), (A -> A -> bool) -> t A -> t A -> bool. *) + (* Axiom beq_correct: *) + (* forall (A: Type) (eqA: A -> A -> bool) (t1 t2: t A), *) + (* beq eqA t1 t2 = true <-> *) + (* (forall (x: elt), *) + (* eqA (get x t1) = eqA (get x t2)). *) End MAP. (** * An implementation of trees over type [positive] *) @@ -1558,6 +1566,16 @@ Module ITree(X: INDEXED_TYPE). Proof. intros. apply PTree.gcombine. auto. Qed. + + Definition map1 {A B} (f: A -> B) (m: t A) : t B := PTree.map1 f m. + + Theorem gmap1: + forall {A B} (f: A -> B) (i: elt) (m: t A), + get i (map1 f m) = option_map f (get i m). + Proof. + intros. eapply PTree.gmap1. + Qed. + End ITree. Module ZTree := ITree(ZIndexed). From cb74dc2f17082eb11b30fad0a4787e9564b77428 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Thu, 23 Nov 2023 15:55:36 +0100 Subject: [PATCH 05/83] [Compartments] Continue fixing the compartment model, with changes in the builtins --- backend/Cminor.v | 59 +++---- backend/CminorSel.v | 32 ++-- backend/Cminortyping.v | 4 +- backend/LTL.v | 16 +- backend/SelectDiv.vp | 11 +- backend/SelectDivproof.v | 18 +-- backend/Selection.v | 108 +++++-------- backend/Selectionproof.v | 329 +++++++++++++++------------------------ backend/SplitLong.vp | 9 +- backend/SplitLongproof.v | 198 ++++++++++------------- cfrontend/Ctypes.v | 24 ++- common/AST.v | 10 +- common/Events.v | 212 ++++++++++++------------- common/Exec.v | 13 +- common/Globalenvs.v | 44 ++---- common/Memory.v | 115 ++++++++++---- common/Separation.v | 31 ++-- riscV/Machregs.v | 20 +-- riscV/SelectLong.vp | 13 +- riscV/SelectLongproof.v | 22 +-- 20 files changed, 596 insertions(+), 692 deletions(-) diff --git a/backend/Cminor.v b/backend/Cminor.v index 5dd212e673..3b5909ebe3 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -240,7 +240,9 @@ Inductive state: Type := (args: list val) (**r arguments provided by caller *) (k: cont) (**r what to do next *) (m: mem) (**r memory state *) - (cp: option compartment), (**r optionally, the compartment that lead to this [Callstate]. /!\ This is not necessary [call_comp k] *) + (cp: compartment), (**r the compartment that lead to this [Callstate]. /!\ This is not necessary [call_comp k] *) + (* this is because of tailcalls: after a tailcall, we are calling from the current comp, + but [call_comp k] return the previous caller's compartment (which might be different )*) state | Returnstate: (**r Return from a function *) forall (v: val) (**r Return value *) @@ -384,7 +386,7 @@ Inductive eval_expr: expr -> val -> Prop := eval_expr (Ebinop op a1 a2) v | eval_Eload: forall chunk addr vaddr v, eval_expr addr vaddr -> - Mem.loadv chunk m vaddr (Some cp) = Some v -> + Mem.loadv chunk m vaddr cp = Some v -> eval_expr (Eload chunk addr) v. Inductive eval_exprlist: list expr -> list val -> Prop := @@ -477,11 +479,11 @@ Inductive step: state -> trace -> state -> Prop := Genv.find_funct ge vf = Some fd -> funsig fd = sig -> (* Check that the call to the function pointer is allowed *) - forall (ALLOWED: Genv.allowed_call ge (comp_of f) ()), + forall (ALLOWED: Genv.allowed_call ge (comp_of f) vf), forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall -> Forall not_ptr vargs), forall (EV: call_trace ge (comp_of f) (comp_of fd) vf vargs (sig_args sig) t), step (State f (Scall optid sig a bl) k sp e m) - t (Callstate fd vargs (Kcall optid f sp e k) m (Some (comp_of f))) + t (Callstate fd vargs (Kcall optid f sp e k) m (comp_of f)) | step_tailcall: forall f sig a bl k sp e m vf vargs fd m', eval_expr (Vptr sp Ptrofs.zero) e m (comp_of f) a vf -> @@ -492,7 +494,7 @@ Inductive step: state -> trace -> state -> Prop := forall (SIG: sig_res (fn_sig f) = sig_res sig), Mem.free m sp 0 f.(fn_stackspace) (comp_of f) = Some m' -> step (State f (Stailcall sig a bl) k (Vptr sp Ptrofs.zero) e m) - E0 (Callstate fd vargs (call_cont k) m' (Some (comp_of f))) + E0 (Callstate fd vargs (call_cont k) m' (comp_of f)) | step_builtin: forall f optid ef bl k sp e m vargs t vres m', eval_exprlist sp e m (comp_of f) bl vargs -> @@ -560,8 +562,8 @@ Inductive step: state -> trace -> state -> Prop := E0 (State f f.(fn_body) k (Vptr sp Ptrofs.zero) e m') | step_external_function: forall ef vargs k m cp t vres m', external_call ef ge cp vargs m t vres m' -> - step (Callstate (External ef) vargs k m (Some cp)) - t (Returnstate vres k m' (sig_res (ef_sig ef)) (comp_of ef)) + step (Callstate (External ef) vargs k m cp) + t (Returnstate vres k m' (sig_res (ef_sig ef)) bottom) | step_return: forall v optid f sp e cp k m ty t, forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) cp = Genv.CrossCompartmentCall -> not_ptr v), @@ -583,7 +585,7 @@ Inductive initial_state (p: program): state -> Prop := Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = signature_main -> - initial_state p (Callstate f nil Kstop m0). + initial_state p (Callstate f nil Kstop m0 top). (** A final state is a [Returnstate] with an empty continuation. *) @@ -610,7 +612,7 @@ Proof. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. exists (State f Sskip k sp (set_optvar optid vres2 e) m2). econstructor; eauto. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. - exists (Returnstate vres2 k m2 (sig_res (ef_sig ef)) (comp_of ef)). econstructor; eauto. + exists (Returnstate vres2 k m2 (sig_res (ef_sig ef)) bottom). econstructor; eauto. inv EV; inv H0; eexists; eauto. (* trace length *) red; intros; inv H; simpl; try lia; try now eapply external_call_trace_length; eauto. @@ -679,7 +681,7 @@ Proof. apply B in H; destruct H; congruence. + subst. inv H2; inv H13; auto. + subst. inv H2; inv H14; reflexivity. - + exploit external_call_determ. eexact H1. eexact H7. + + exploit external_call_determ. eexact H1. eexact H8. intros (A & B). split; intros; auto. apply B in H; destruct H; congruence. + subst. @@ -774,7 +776,7 @@ Inductive eval_funcall: eval_funcall cp m (Internal f) vargs t m3 vres | eval_funcall_external: forall ef cp m args t res m', - external_call ef ge args m t res m' -> + external_call ef ge cp args m t res m' -> eval_funcall cp m (External ef) args t m' res (** Execution of a statement: [exec_stmt ge f sp e m s t e' m' out] @@ -817,9 +819,9 @@ with exec_stmt: | exec_Sbuiltin: forall f sp e m optid ef bl t m' vargs vres e', eval_exprlist ge sp e m (comp_of f) bl vargs -> - external_call ef ge vargs m t vres m' -> + external_call ef ge (comp_of f) vargs m t vres m' -> e' = set_optvar optid vres e -> - forall ALLOWED: comp_of ef = comp_of f, + (* forall ALLOWED: comp_of ef = comp_of f, *) exec_stmt f sp e m (Sbuiltin optid ef bl) t e' m' Out_normal | exec_Sifthenelse: forall f sp e m a s1 s2 v b t e' m' out, @@ -897,13 +899,14 @@ Combined Scheme eval_funcall_exec_stmt_ind2 *) CoInductive evalinf_funcall: + compartment -> mem -> fundef -> list val -> traceinf -> Prop := | evalinf_funcall_internal: - forall m f vargs m1 sp e t, + forall cp m f vargs m1 sp e t, Mem.alloc m (comp_of f) 0 f.(fn_stackspace) = (m1, sp) -> set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> execinf_stmt f (Vptr sp Ptrofs.zero) e m1 f.(fn_body) t -> - evalinf_funcall m (Internal f) vargs t + evalinf_funcall cp m (Internal f) vargs t (** [execinf_stmt ge sp e m s t] means that statement [s] diverges. [e] is the initial environment, [m] is the initial memory state, @@ -917,7 +920,7 @@ with execinf_stmt: eval_exprlist ge sp e m (comp_of f) bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> - evalinf_funcall m fd vargs t -> + evalinf_funcall (comp_of f) m fd vargs t -> forall (ALLOWED: Genv.allowed_call ge (comp_of f) vf), forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall -> Forall not_ptr vargs), forall (EV: call_trace ge (comp_of f) (comp_of fd) vf vargs (sig_args sig) t'), @@ -960,10 +963,9 @@ with execinf_stmt: funsig fd = sig -> forall (COMP: comp_of fd = (comp_of f)), forall (SIG: sig_res (fn_sig f) = sig_res sig), - forall (ALLOWED: needs_calling_comp (comp_of f) = false), - forall (ALLOWED': Genv.allowed_call ge (comp_of f) vf), + forall (ALLOWED: Genv.allowed_call ge (comp_of f) vf), Mem.free m sp 0 f.(fn_stackspace) (comp_of f) = Some m' -> - evalinf_funcall m' fd vargs t -> + evalinf_funcall (comp_of f) m' fd vargs t -> (* forall (EV: call_trace ge (comp_of f) (Genv.find_comp ge vf) vf vargs (sig_args sig) t'), *) execinf_stmt f (Vptr sp Ptrofs.zero) e m (Stailcall sig a bl) t. @@ -979,7 +981,7 @@ Inductive bigstep_program_terminates (p: program): trace -> int -> Prop := Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = signature_main -> - eval_funcall ge default_compartment m0 f nil t m (Vint r) -> + eval_funcall ge top m0 f nil t m (Vint r) -> bigstep_program_terminates p t r. Inductive bigstep_program_diverges (p: program): traceinf -> Prop := @@ -990,7 +992,7 @@ Inductive bigstep_program_diverges (p: program): traceinf -> Prop := Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = signature_main -> - evalinf_funcall ge m0 f nil t -> + evalinf_funcall ge top m0 f nil t -> bigstep_program_diverges p t. Definition bigstep_semantics (p: program) := @@ -1046,9 +1048,8 @@ Lemma eval_funcall_exec_stmt_steps: (forall cp m fd args t m' res, eval_funcall ge cp m fd args t m' res -> forall k, - (* forall UPD: cp = call_comp k, *) is_call_cont k -> - star step ge (Callstate fd args k m) + star step ge (Callstate fd args k m cp) t (Returnstate res k m' (sig_res (funsig fd)) (comp_of fd))) /\(forall f sp e m s t e' m' out, exec_stmt ge f sp e m s t e' m' out -> @@ -1204,7 +1205,7 @@ Proof. (* tailcall *) econstructor; split. eapply star_left. econstructor; eauto. - apply H5; eauto; try apply is_call_cont_call_cont. simpl. + apply H5 ;eauto; try apply is_call_cont_call_cont. traceEq. rewrite COMP. subst sig. rewrite <- SIG. econstructor. @@ -1215,7 +1216,7 @@ Lemma eval_funcall_steps: eval_funcall ge cp m fd args t m' res -> forall k, is_call_cont k -> - star step ge (Callstate fd args k m) + star step ge (Callstate fd args k m cp) t (Returnstate res k m' (sig_res (funsig fd)) (comp_of fd)). Proof. exact (proj1 eval_funcall_exec_stmt_steps). Qed. @@ -1229,9 +1230,9 @@ Lemma exec_stmt_steps: Proof. exact (proj2 eval_funcall_exec_stmt_steps). Qed. Lemma evalinf_funcall_forever: - forall m fd args T k, - evalinf_funcall ge m fd args T -> - forever_plus step ge (Callstate fd args k m) T. + forall cp m fd args T k, + evalinf_funcall ge cp m fd args T -> + forever_plus step ge (Callstate fd args k m cp) T. Proof. cofix CIH_FUN. assert (forall sp e m s T f k, @@ -1303,7 +1304,7 @@ Proof. (* termination *) inv H. econstructor; econstructor. split. econstructor; eauto. - split. eapply (eval_funcall_steps default_compartment); try red; eauto. + split. eapply (eval_funcall_steps top); try red; eauto. econstructor. (* divergence *) inv H. econstructor. diff --git a/backend/CminorSel.v b/backend/CminorSel.v index e3245080f5..7f5eb8fea8 100644 --- a/backend/CminorSel.v +++ b/backend/CminorSel.v @@ -146,7 +146,8 @@ Inductive state: Type := forall (f: fundef) (**r fundef to invoke *) (args: list val) (**r arguments provided by caller *) (k: cont) (**r what to do next *) - (m: mem), (**r memory state *) + (m: mem) (**r memory state *) + (cp: compartment), (**r calling compartment (cf comment in Cminor.v) *) state | Returnstate: forall (v: val) (**r return value *) @@ -182,7 +183,7 @@ Inductive eval_expr: letenv -> expr -> val -> Prop := | eval_Eload: forall le chunk addr al vl vaddr v, eval_exprlist le al vl -> eval_addressing ge sp addr vl = Some vaddr -> - Mem.loadv chunk m vaddr (Some cp) = Some v -> + Mem.loadv chunk m vaddr cp = Some v -> eval_expr le (Eload chunk addr al) v | eval_Econdition: forall le a b c va v, eval_condexpr le a va -> @@ -197,16 +198,14 @@ Inductive eval_expr: letenv -> expr -> val -> Prop := eval_expr le (Eletvar n) v | eval_Ebuiltin: forall le ef al vl v, eval_exprlist le al vl -> - external_call ef ge vl m E0 v m -> - comp_of ef = cp -> + external_call ef ge cp vl m E0 v m -> eval_expr le (Ebuiltin ef al) v | eval_Eexternal: forall le id sg al b ef vl v, Genv.find_symbol ge id = Some b -> Genv.find_funct_ptr ge b = Some (External ef) -> ef_sig ef = sg -> eval_exprlist le al vl -> - external_call ef ge vl m E0 v m -> - forall (INTRA: Genv.type_of_call cp (comp_of ef) <> Genv.CrossCompartmentCall), + external_call ef ge cp vl m E0 v m -> eval_expr le (Eexternal id sg al) v with eval_exprlist: letenv -> exprlist -> list val -> Prop := @@ -386,7 +385,7 @@ Inductive step: state -> trace -> state -> Prop := forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall -> Forall not_ptr vargs), forall (EV: call_trace ge (comp_of f) (comp_of fd) vf vargs (sig_args sig) t), step (State f (Scall optid sig a bl) k sp e m) - t (Callstate fd vargs (Kcall optid f sp e k) m) + t (Callstate fd vargs (Kcall optid f sp e k) m (comp_of f)) | step_tailcall: forall f sig a bl k sp e m vf vargs fd m', eval_expr_or_symbol (Vptr sp Ptrofs.zero) e (comp_of f) m nil a vf -> @@ -397,12 +396,11 @@ Inductive step: state -> trace -> state -> Prop := forall (SIG: sig_res (fn_sig f) = sig_res sig), Mem.free m sp 0 f.(fn_stackspace) (comp_of f) = Some m' -> step (State f (Stailcall sig a bl) k (Vptr sp Ptrofs.zero) e m) - E0 (Callstate fd vargs (call_cont k) m') + E0 (Callstate fd vargs (call_cont k) m' (comp_of f)) | step_builtin: forall f res ef al k sp e m vl t v m', - comp_of ef = comp_of f -> list_forall2 (eval_builtin_arg sp e (comp_of f) m) al vl -> - external_call ef ge vl m t v m' -> + external_call ef ge (comp_of f) vl m t v m' -> step (State f (Sbuiltin res ef al) k sp e m) t (State f Sskip k sp (set_builtin_res res v e) m') @@ -461,15 +459,15 @@ Inductive step: state -> trace -> state -> Prop := step (State f (Sgoto lbl) k sp e m) E0 (State f s' k' sp e m) - | step_internal_function: forall f vargs k m m' sp e, + | step_internal_function: forall f vargs k m cp m' sp e, Mem.alloc m (comp_of f) 0 f.(fn_stackspace) = (m', sp) -> set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> - step (Callstate (Internal f) vargs k m) + step (Callstate (Internal f) vargs k m cp) E0 (State f f.(fn_body) k (Vptr sp Ptrofs.zero) e m') - | step_external_function: forall ef vargs k m t vres m', - external_call ef ge vargs m t vres m' -> - step (Callstate (External ef) vargs k m) - t (Returnstate vres k m' (sig_res (ef_sig ef)) (comp_of ef)) + | step_external_function: forall ef vargs k m cp t vres m', + external_call ef ge cp vargs m t vres m' -> + step (Callstate (External ef) vargs k m cp) + t (Returnstate vres k m' (sig_res (ef_sig ef)) bottom) | step_return: forall v optid f sp e cp k m ty t, forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) cp = Genv.CrossCompartmentCall -> not_ptr v), @@ -486,7 +484,7 @@ Inductive initial_state (p: program): state -> Prop := Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = signature_main -> - initial_state p (Callstate f nil Kstop m0). + initial_state p (Callstate f nil Kstop m0 top). Inductive final_state: state -> int -> Prop := | final_state_intro: forall r m sg cp, diff --git a/backend/Cminortyping.v b/backend/Cminortyping.v index 31dce275bd..534a581f2d 100644 --- a/backend/Cminortyping.v +++ b/backend/Cminortyping.v @@ -449,11 +449,11 @@ Inductive wt_state: state -> Prop := (WT_ENV: wt_env env e) (DEF_ENV: def_env f e), wt_state (State f s k sp e m) - | wt_call_state: forall f args k m + | wt_call_state: forall f args k m cp (WT_FD: wt_fundef f) (WT_ARGS: Val.has_type_list args (funsig f).(sig_args)) (WT_CONT: wt_cont_call k (funsig f).(sig_res)), - wt_state (Callstate f args k m) + wt_state (Callstate f args k m cp) | wt_return_state: forall v k m cp tret sg (WT_RES: Val.has_type v (proj_rettype tret)) (WT_CONT: wt_cont_call k tret), diff --git a/backend/LTL.v b/backend/LTL.v index 48216997a0..721a541e5d 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -216,10 +216,10 @@ Inductive state : Type := (cp: compartment), (**r compartment we're returning from *) state. -Definition call_comp (stack: list stackframe) : option compartment := +Definition call_comp (stack: list stackframe) : compartment := match stack with - | nil => None - | Stackframe f _ _ _ _ :: _ => Some (comp_of f) + | nil => bottom + | Stackframe f _ _ _ _ :: _ => comp_of f end. Section RELSEM. @@ -307,7 +307,7 @@ Inductive step: state -> trace -> state -> Prop := E0 (Block s f sp bb rs' m) | exec_Lload: forall s f sp chunk addr args dst bb rs m a v rs', eval_addressing ge sp addr (reglist rs args) = Some a -> - Mem.loadv chunk m a (Some (comp_of f)) = Some v -> + Mem.loadv chunk m a (comp_of f) = Some v -> rs' = Locmap.set (R dst) v (undef_regs (destroyed_by_load chunk addr) rs) -> step (Block s f sp (Lload chunk addr args dst :: bb) rs m) E0 (Block s f sp bb rs' m) @@ -351,9 +351,9 @@ Inductive step: state -> trace -> state -> Prop := E0 (Callstate s fd sig rs' m') | exec_Lbuiltin: forall s f sp ef args res bb rs m vargs t vres rs' m', eval_builtin_args ge rs sp m args vargs -> - external_call ef ge vargs m t vres m' -> + external_call ef ge (comp_of f) vargs m t vres m' -> rs' = Locmap.setres res vres (undef_regs (destroyed_by_builtin ef) rs) -> - forall ALLOWED: comp_of f = comp_of ef, + (* forall ALLOWED: comp_of f = comp_of ef, *) step (Block s f sp (Lbuiltin ef args res :: bb) rs m) t (Block s f sp bb rs' m') | exec_Lbranch: forall s f sp pc bb rs m, @@ -388,10 +388,10 @@ Inductive step: state -> trace -> state -> Prop := E0 (State s f (Vptr sp Ptrofs.zero) f.(fn_entrypoint) rs' m') | exec_function_external: forall s ef t args res rs m rs' sig m', args = map (fun p => Locmap.getpair p rs) (loc_arguments (ef_sig ef)) -> - external_call ef ge args m t res m' -> + external_call ef ge (call_comp s) args m t res m' -> rs' = Locmap.setpair (loc_result (ef_sig ef)) res (undef_caller_save_regs rs) -> step (Callstate s (External ef) sig rs m) - t (Returnstate s rs' m' (comp_of ef)) + t (Returnstate s rs' m' (call_comp s)) | exec_return: forall f sp rs1 bb s rs m cp sig t, forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) cp = Genv.CrossCompartmentCall -> diff --git a/backend/SelectDiv.vp b/backend/SelectDiv.vp index 15ab4ace3e..d91797c59f 100644 --- a/backend/SelectDiv.vp +++ b/backend/SelectDiv.vp @@ -224,10 +224,9 @@ Definition mods (e1: expr) (e2: expr) := Section SELECT. Context {hf: helper_functions}. -Context (cp: compartment). Definition modl_from_divl (equo: expr) (n: int64) := - subl cp (Eletvar O) (mullimm cp n equo). + subl (Eletvar O) (mullimm n equo). Definition divlu_mull (p: Z) (m: Z) := shrluimm (mullhu (Eletvar O) (Int64.repr m)) (Int.repr p). @@ -270,8 +269,8 @@ Definition divls_mull (p: Z) (m: Z) := let e2 := mullhs (Eletvar O) (Int64.repr m) in let e3 := - if zlt m Int64.half_modulus then e2 else addl cp e2 (Eletvar O) in - addl cp (shrlimm e3 (Int.repr p)) + if zlt m Int64.half_modulus then e2 else addl e2 (Eletvar O) in + addl (shrlimm e3 (Int.repr p)) (shrluimm (Eletvar O) (Int.repr (Int64.zwordsize - 1))). Definition divls (e1 e2: expr) := @@ -280,7 +279,7 @@ Definition divls (e1 e2: expr) := | Some n2, _ => match Int64.is_power2' n2 with | Some l => if Int.ltu l (Int.repr 63) - then shrxlimm cp e1 l + then shrxlimm e1 l else divls_base e1 e2 | None => if optim_for_size tt then divls_base e1 e2 @@ -299,7 +298,7 @@ Definition modls (e1 e2: expr) := | Some n2, _ => match Int64.is_power2' n2 with | Some l => if Int.ltu l (Int.repr 63) - then Elet e1 (modl_from_divl (shrxlimm cp (Eletvar O) l) n2) + then Elet e1 (modl_from_divl (shrxlimm (Eletvar O) l) n2) else modls_base e1 e2 | None => if optim_for_size tt then modls_base e1 e2 diff --git a/backend/SelectDivproof.v b/backend/SelectDivproof.v index 3338eb9587..0921739d74 100644 --- a/backend/SelectDivproof.v +++ b/backend/SelectDivproof.v @@ -486,11 +486,11 @@ Section CMCONSTRS. Variable prog: program. Variable hf: helper_functions. +Hypothesis HELPERS: helper_functions_declared prog hf. Let ge := Genv.globalenv prog. Variable sp: val. Variable e: env. Variable cp: compartment. -Hypothesis HELPERS: helper_functions_declared prog hf cp. Variable m: mem. Lemma is_intconst_sound: @@ -746,7 +746,7 @@ Lemma eval_modl_from_divl: forall le a n x y, eval_expr ge sp e cp m le a (Vlong y) -> nth_error le O = Some (Vlong x) -> - eval_expr ge sp e cp m le (modl_from_divl cp a n) (Vlong (Int64.sub x (Int64.mul y n))). + eval_expr ge sp e cp m le (modl_from_divl a n) (Vlong (Int64.sub x (Int64.mul y n))). Proof. unfold modl_from_divl; intros. exploit eval_mullimm; eauto. instantiate (1 := n). intros (v1 & A1 & B1). @@ -802,7 +802,7 @@ Theorem eval_modlu: eval_expr ge sp e cp m le a x -> eval_expr ge sp e cp m le b y -> Val.modlu x y = Some z -> - exists v, eval_expr ge sp e cp m le (modlu cp a b) v /\ Val.lessdef z v. + exists v, eval_expr ge sp e cp m le (modlu a b) v /\ Val.lessdef z v. Proof. unfold modlu; intros. destruct (is_longconst b) as [n2|] eqn:N2. @@ -830,22 +830,22 @@ Lemma eval_divls_mull: forall le x y p M, divls_mul_params (Int64.signed y) = Some(p, M) -> nth_error le O = Some (Vlong x) -> - eval_expr ge sp e cp m le (divls_mull cp p M) (Vlong (Int64.divs x y)). + eval_expr ge sp e cp m le (divls_mull p M) (Vlong (Int64.divs x y)). Proof. intros. unfold divls_mull. assert (A0: eval_expr ge sp e cp m le (Eletvar O) (Vlong x)). { constructor; auto. } exploit eval_mullhs. try apply HELPERS. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1). - exploit eval_addl. eauto. eexact A1. eexact A0. intros (v2 & A2 & B2). + exploit eval_addl. auto. eexact A1. eexact A0. intros (v2 & A2 & B2). exploit eval_shrluimm. try apply HELPERS. eexact A0. instantiate (1 := Int.repr 63). intros (v3 & A3 & B3). set (a4 := if zlt M Int64.half_modulus then mullhs (Eletvar 0) (Int64.repr M) - else addl cp (mullhs (Eletvar 0) (Int64.repr M)) (Eletvar 0)). + else addl (mullhs (Eletvar 0) (Int64.repr M)) (Eletvar 0)). set (v4 := if zlt M Int64.half_modulus then v1 else v2). assert (A4: eval_expr ge sp e cp m le a4 v4). { unfold a4, v4; destruct (zlt M Int64.half_modulus); auto. } exploit eval_shrlimm. try apply HELPERS. eexact A4. instantiate (1 := Int.repr p). intros (v5 & A5 & B5). - exploit eval_addl. eauto. eexact A5. eexact A3. intros (v6 & A6 & B6). + exploit eval_addl. auto. eexact A5. eexact A3. intros (v6 & A6 & B6). assert (RANGE: forall x, 0 <= x < 64 -> Int.ltu (Int.repr x) Int64.iwordsize' = true). { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto. assert (64 < Int.max_unsigned) by (compute; auto). lia. } @@ -868,7 +868,7 @@ Theorem eval_divls: eval_expr ge sp e cp m le a x -> eval_expr ge sp e cp m le b y -> Val.divls x y = Some z -> - exists v, eval_expr ge sp e cp m le (divls cp a b) v /\ Val.lessdef z v. + exists v, eval_expr ge sp e cp m le (divls a b) v /\ Val.lessdef z v. Proof. unfold divls; intros. destruct (is_longconst b) as [n2|] eqn:N2. @@ -899,7 +899,7 @@ Theorem eval_modls: eval_expr ge sp e cp m le a x -> eval_expr ge sp e cp m le b y -> Val.modls x y = Some z -> - exists v, eval_expr ge sp e cp m le (modls cp a b) v /\ Val.lessdef z v. + exists v, eval_expr ge sp e cp m le (modls a b) v /\ Val.lessdef z v. Proof. unfold modls; intros. destruct (is_longconst b) as [n2|] eqn:N2. diff --git a/backend/Selection.v b/backend/Selection.v index 7b5a478dc2..60d0851362 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -70,7 +70,6 @@ Section SELECTION. Definition globdef := AST.globdef Cminor.fundef unit. Variable defmap: PTree.t globdef. Context {hf: helper_functions}. -Context (cp: compartment). Definition sel_constant (cst: Cminor.constant) : expr := match cst with @@ -104,7 +103,7 @@ Definition sel_unop (op: Cminor.unary_operation) (arg: expr) : expr := | Cminor.Ointuofsingle => intuofsingle arg | Cminor.Osingleofint => singleofint arg | Cminor.Osingleofintu => singleofintu arg - | Cminor.Onegl => negl cp arg + | Cminor.Onegl => negl arg | Cminor.Onotl => notl arg | Cminor.Ointoflong => intoflong arg | Cminor.Olongofint => longofint arg @@ -142,13 +141,13 @@ Definition sel_binop (op: Cminor.binary_operation) (arg1 arg2: expr) : expr := | Cminor.Osubfs => subfs arg1 arg2 | Cminor.Omulfs => mulfs arg1 arg2 | Cminor.Odivfs => divfs arg1 arg2 - | Cminor.Oaddl => addl cp arg1 arg2 - | Cminor.Osubl => subl cp arg1 arg2 - | Cminor.Omull => mull cp arg1 arg2 - | Cminor.Odivl => divls cp arg1 arg2 + | Cminor.Oaddl => addl arg1 arg2 + | Cminor.Osubl => subl arg1 arg2 + | Cminor.Omull => mull arg1 arg2 + | Cminor.Odivl => divls arg1 arg2 | Cminor.Odivlu => divlu arg1 arg2 - | Cminor.Omodl => modls cp arg1 arg2 - | Cminor.Omodlu => modlu cp arg1 arg2 + | Cminor.Omodl => modls arg1 arg2 + | Cminor.Omodlu => modlu arg1 arg2 | Cminor.Oandl => andl arg1 arg2 | Cminor.Oorl => orl arg1 arg2 | Cminor.Oxorl => xorl arg1 arg2 @@ -211,7 +210,7 @@ Definition classify_call (e: Cminor.expr) : call_kind := | None => Call_default | Some id => match defmap!id with - | Some(Gfun (External ef)) => if ef_inline ef && Pos.eq_dec (comp_of ef) cp then Call_builtin ef else Call_imm id + | Some(Gfun (External ef)) => if ef_inline ef then Call_builtin ef else Call_imm id | _ => Call_imm id end end. @@ -269,8 +268,8 @@ Definition sel_builtin_default (optid: option ident) (ef: external_function) Definition sel_builtin (optid: option ident) (ef: external_function) (args: list Cminor.expr) := match ef with - | EF_builtin cp name sg => - match lookup_builtin_function name cp sg with + | EF_builtin name sg => + match lookup_builtin_function name sg with | Some bf => match optid with | Some id => @@ -330,7 +329,7 @@ Definition sel_switch_long := sel_switch (fun arg n => cmpl Ceq arg (longconst (Int64.repr n))) (fun arg n => cmplu Clt arg (longconst (Int64.repr n))) - (fun arg ofs => subl cp arg (longconst (Int64.repr ofs))) + (fun arg ofs => subl arg (longconst (Int64.repr ofs))) lowlong. (** "If conversion": conversion of certain if-then-else statements @@ -350,7 +349,7 @@ Fixpoint classify_stmt (s: Cminor.stmt) : stmt_class := match s with | Cminor.Sskip => SCskip | Cminor.Sassign id a => SCassign id a - | Cminor.Sbuiltin None (EF_debug _ _ _ _) _ => SCskip + | Cminor.Sbuiltin None (EF_debug _ _ _) _ => SCskip | Cminor.Sseq s1 s2 => match classify_stmt s1, classify_stmt s2 with | SCskip, c2 => c2 @@ -453,11 +452,10 @@ Definition known_id (f: Cminor.function) : known_idents := List.fold_left add f.(Cminor.fn_vars) (List.fold_left add f.(Cminor.fn_params) (PTree.empty unit)). -Definition sel_function (dm: PTree.t globdef) (hf: compartment -> res helper_functions) (f: Cminor.function) : res function := +Definition sel_function (dm: PTree.t globdef) (hf: helper_functions) (f: Cminor.function) : res function := let ki := known_id f in do env <- Cminortyping.type_function f; - do hf_c <- hf f.(Cminor.fn_comp); - do body' <- sel_stmt dm f.(Cminor.fn_comp) ki env f.(Cminor.fn_body); + do body' <- sel_stmt dm ki env f.(Cminor.fn_body); OK (mkfunction f.(Cminor.fn_comp) f.(Cminor.fn_sig) @@ -466,7 +464,7 @@ Definition sel_function (dm: PTree.t globdef) (hf: compartment -> res helper_fun f.(Cminor.fn_stackspace) body'). -Definition sel_fundef (dm: PTree.t globdef) (hf: compartment -> res helper_functions) (f: Cminor.fundef) : res fundef := +Definition sel_fundef (dm: PTree.t globdef) (hf: helper_functions) (f: Cminor.fundef) : res fundef := transf_partial_fundef (sel_function dm hf) f. (** Setting up the helper functions. *) @@ -478,86 +476,64 @@ Definition sel_fundef (dm: PTree.t globdef) (hf: compartment -> res helper_funct This ensures that the mapping remains small and that [lookup_helper] below is efficient. *) -(* NOTE: [cp] argument and check should not be needed at the moment *) -Definition globdef_of_interest (gd: globdef) (cp: compartment) : bool := +Definition globdef_of_interest (gd: globdef) : bool := match gd with - | Gfun (External (EF_runtime cp' name sg)) => Pos.eqb cp cp' + | Gfun (External (EF_runtime name sg)) => true | _ => false end. -Definition record_globdefs (defmap: PTree.t globdef) (cp: compartment) : PTree.t globdef := +Definition record_globdefs (defmap: PTree.t globdef) : PTree.t globdef := PTree.fold - (fun m id gd => if globdef_of_interest gd cp then PTree.set id gd m else m) + (fun m id gd => if globdef_of_interest gd then PTree.set id gd m else m) defmap (PTree.empty globdef). -(* Definition record_globdefs (defmap: Cminor.program) (cp: compartment) : PTree.t globdef := *) -(* List.fold_left *) -(* (fun m '(id, gd) => if globdef_of_interest gd cp then PTree.set id gd m else m) *) -(* defmap.(prog_defs) (PTree.empty globdef). *) - Definition lookup_helper_aux - (cp: compartment) (name: String.string) (sg: signature) (res: option ident) + (name: String.string) (sg: signature) (res: option ident) (id: ident) (gd: globdef) := match gd with - | Gfun (External (EF_runtime cp' name' sg')) => - if Pos.eqb cp cp' && String.string_dec name name' && signature_eq sg sg' + | Gfun (External (EF_runtime name' sg')) => + if String.string_dec name name' && signature_eq sg sg' then Some id else res | _ => res end. Definition lookup_helper (globs: PTree.t globdef) - (cp: compartment) (name: String.string) (sg: signature) : res (ident) := - match PTree.fold (lookup_helper_aux cp name sg) globs None with + (name: String.string) (sg: signature) : res ident := + match PTree.fold (lookup_helper_aux name sg) globs None with | Some id => OK id | None => Error (MSG name :: MSG ": missing or incorrect declaration" :: nil) end. Local Open Scope string_scope. -Definition get_helpers (defmap: PTree.t globdef) (cp: compartment): res helper_functions := -(* Definition get_helpers (defmap: Cminor.program) (cp: compartment): res helper_functions := *) - let globs := record_globdefs defmap cp in - do i64_dtos <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_dtos" cp) sig_f_l ; - do i64_dtou <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_dtou" cp) sig_f_l ; - do i64_stod <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_stod" cp) sig_l_f ; - do i64_utod <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_utod" cp) sig_l_f ; - do i64_stof <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_stof" cp) sig_l_s ; - do i64_utof <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_utof" cp) sig_l_s ; - do i64_sdiv <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_sdiv" cp) sig_ll_l ; - do i64_udiv <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_udiv" cp) sig_ll_l ; - do i64_smod <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_smod" cp) sig_ll_l ; - do i64_umod <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_umod" cp) sig_ll_l ; - do i64_shl <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_shl" cp) sig_li_l ; - do i64_shr <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_shr" cp) sig_li_l ; - do i64_sar <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_sar" cp) sig_li_l ; - do i64_umulh <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_umulh" cp) sig_ll_l ; - do i64_smulh <- lookup_helper globs cp (standard_builtin_name "__compcert_i64_smulh" cp) sig_ll_l ; +Definition get_helpers (defmap: PTree.t globdef) : res helper_functions := + let globs := record_globdefs defmap in + do i64_dtos <- lookup_helper globs "__compcert_i64_dtos" sig_f_l ; + do i64_dtou <- lookup_helper globs "__compcert_i64_dtou" sig_f_l ; + do i64_stod <- lookup_helper globs "__compcert_i64_stod" sig_l_f ; + do i64_utod <- lookup_helper globs "__compcert_i64_utod" sig_l_f ; + do i64_stof <- lookup_helper globs "__compcert_i64_stof" sig_l_s ; + do i64_utof <- lookup_helper globs "__compcert_i64_utof" sig_l_s ; + do i64_sdiv <- lookup_helper globs "__compcert_i64_sdiv" sig_ll_l ; + do i64_udiv <- lookup_helper globs "__compcert_i64_udiv" sig_ll_l ; + do i64_smod <- lookup_helper globs "__compcert_i64_smod" sig_ll_l ; + do i64_umod <- lookup_helper globs "__compcert_i64_umod" sig_ll_l ; + do i64_shl <- lookup_helper globs "__compcert_i64_shl" sig_li_l ; + do i64_shr <- lookup_helper globs "__compcert_i64_shr" sig_li_l ; + do i64_sar <- lookup_helper globs "__compcert_i64_sar" sig_li_l ; + do i64_umulh <- lookup_helper globs "__compcert_i64_umulh" sig_ll_l ; + do i64_smulh <- lookup_helper globs "__compcert_i64_smulh" sig_ll_l ; OK (mk_helper_functions i64_dtos i64_dtou i64_stod i64_utod i64_stof i64_utof i64_sdiv i64_udiv i64_smod i64_umod i64_shl i64_shr i64_sar i64_umulh i64_smulh). -Definition get_all_helpers (defmap: PTree.t globdef) (ls: list compartment): compartment -> res helper_functions := -(* Definition get_all_helpers (defmap: Cminor.program) (ls: list compartment): compartment -> res helper_functions := *) - fun cp => - if @in_dec compartment Pos.eq_dec cp ls then - do hf <- get_helpers defmap cp; - OK hf - else - Error (MSG "Error: missing or incorrect declaration - [get_all_helpers]" :: nil) -. - (** Conversion of programs. *) Definition sel_program (p: Cminor.program) : res program := - (* FIXME: [prog_defmap] hides the multiple copies of the helper - functions, which share a name but live in different - compartments. A namespacing fix at that level may be worth - looking into. *) let dm := prog_defmap p in - let hf := get_all_helpers dm (AST.list_comp p) in - (* let hf := get_all_helpers p (AST.list_comp p) in *) + do hf <- get_helpers dm; transform_partial_program (sel_fundef dm hf) p. diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 940b3d907c..6dd831fd93 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -26,9 +26,8 @@ Local Open Scope error_monad_scope. (** * Relational specification of instruction selection *) Definition match_fundef (cunit: Cminor.program) (f: Cminor.fundef) (tf: CminorSel.fundef) : Prop := - exists hf hf_c, - hf (comp_of f) = OK hf_c /\ - helper_functions_declared cunit hf_c (comp_of f) /\ sel_fundef (prog_defmap cunit) hf f = OK tf. + exists hf_c, + helper_functions_declared cunit hf_c /\ sel_fundef (prog_defmap cunit) hf_c f = OK tf. Definition match_prog (p: Cminor.program) (tp: CminorSel.program) := match_program match_fundef eq p tp. @@ -40,10 +39,9 @@ Proof. intros f tf H; try monadInv H; trivial. Qed. -#[global] -Instance comp_match_fundef: has_comp_match match_fundef. +#[global] Instance comp_match_fundef: has_comp_match match_fundef. Proof. - intros cunit f tf (hf & hf_c & G & _ & H). + intros cunit f tf (hf_C & G & H). destruct f as [f|ef]; monadInv H; trivial. exact (comp_transl_partial _ EQ). Qed. @@ -51,10 +49,10 @@ Qed. (** Processing of helper functions *) Lemma record_globdefs_sound: - forall dm cp id gd, (record_globdefs dm cp)!id = Some gd -> dm!id = Some gd. + forall dm id gd, (record_globdefs dm)!id = Some gd -> dm!id = Some gd. Proof. intros. - set (f := fun m id gd => if globdef_of_interest gd cp then PTree.set id gd m else m) in *. + set (f := fun m id gd => if globdef_of_interest gd then PTree.set id gd m else m) in *. set (P := fun m m' => m'!id = Some gd -> m!id = Some gd). assert (X: P dm (PTree.fold f dm (PTree.empty _))). { apply PTree_Properties.fold_rec. @@ -72,115 +70,60 @@ Qed. (* Admitted. *) Lemma lookup_helper_correct_1: - forall globs cp name sg id, - lookup_helper globs cp name sg = OK id -> - globs!id = Some (Gfun (External (EF_runtime cp name sg))). + forall globs name sg id, + lookup_helper globs name sg = OK id -> + globs!id = Some (Gfun (External (EF_runtime name sg))). Proof. intros. - set (P := fun (m: PTree.t globdef) res => res = Some id -> m!id = Some(Gfun (External (EF_runtime cp name sg)))). - assert (P globs (PTree.fold (lookup_helper_aux cp name sg) globs None)). + set (P := fun (m: PTree.t globdef) res => res = Some id -> m!id = Some(Gfun (External (EF_runtime name sg)))). + assert (P globs (PTree.fold (lookup_helper_aux name sg) globs None)). { apply PTree_Properties.fold_rec; red; intros. - rewrite <- H0. apply H1; auto. - discriminate. - - assert (EITHER: k = id /\ v = Gfun (External (EF_runtime cp name sg)) + - assert (EITHER: k = id /\ v = Gfun (External (EF_runtime name sg)) \/ a = Some id). { unfold lookup_helper_aux in H3. destruct v; auto. destruct f; auto. destruct e; auto. - destruct (Pos.eqb cp cp0) eqn:?; auto. destruct (String.string_dec name name0); auto. destruct (signature_eq sg sg0); auto. - inversion H3. left; split; auto. repeat f_equal; auto. symmetry; now apply Peqb_true_eq. } + inversion H3. left; split; auto. repeat f_equal; auto. } destruct EITHER as [[X Y] | X]. subst k v. apply PTree.gss. apply H2 in X. rewrite PTree.gso by congruence. auto. } red in H0. unfold lookup_helper in H. - destruct (PTree.fold (lookup_helper_aux cp name sg) globs None); inv H. auto. + destruct (PTree.fold (lookup_helper_aux name sg) globs None); inv H. auto. Qed. Lemma lookup_helper_correct: - forall p cp name sg id, - lookup_helper (record_globdefs (prog_defmap p) cp) cp name sg = OK id -> - helper_declared p id cp name sg. + forall p name sg id, + lookup_helper (record_globdefs (prog_defmap p)) name sg = OK id -> + helper_declared p id name sg. Proof. intros. apply lookup_helper_correct_1 in H. apply record_globdefs_sound in H. auto. Qed. -(* Lemma lookup_helper_correct: *) -(* forall p cp name sg id, *) -(* lookup_helper (record_globdefs p cp) cp name sg = OK id -> *) -(* helper_declared p id cp name sg. *) -(* Proof. *) -(* intros. apply lookup_helper_correct_1 in H. apply record_globdefs_sound in H. *) -(* Admitted. *) - Lemma get_helpers_correct: - forall p cp hf, - get_helpers (prog_defmap p) cp = OK hf -> - helper_functions_declared p hf cp. + forall p hf, + get_helpers (prog_defmap p) = OK hf -> + helper_functions_declared p hf. Proof. intros. monadInv H. red; simpl. auto 20 using lookup_helper_correct. Qed. -(* Lemma get_helpers_correct: *) -(* forall p cp hf, *) -(* get_helpers p cp = OK hf -> *) -(* helper_functions_declared p hf cp. *) -(* Proof. *) -(* intros. monadInv H. red; simpl. auto 20 using lookup_helper_correct. *) -(* Qed. *) - Theorem transf_program_match: forall p tp, sel_program p = OK tp -> match_prog p tp. Proof. - intros. - eapply match_transform_partial_program_contextual. eexact H. - (* eexact EQ0. *) - intros. - exists (get_all_helpers (prog_defmap p) (list_comp p)). - assert (exists hf_c, get_all_helpers (prog_defmap p) (list_comp p) (comp_of f) = OK hf_c) as [hf_c ?]. - { assert (List.In (comp_of f) (list_comp p)). - admit. - unfold sel_fundef in *. unfold sel_function in *. simpl in *. - unfold get_all_helpers in *. destruct in_dec; try congruence. - destruct (get_helpers (prog_defmap p) (comp_of f)); eauto. - admit. - } - exists hf_c. split; auto. split; auto. - apply get_helpers_correct; auto. - unfold get_all_helpers in H1. - destruct in_dec; try congruence. - monadInv H1. auto. -Admitted. - -(* Theorem transf_program_match: *) -(* forall p tp, sel_program p = OK tp -> match_prog p tp. *) -(* Proof. *) -(* intros. *) -(* eapply match_transform_partial_program_contextual. eexact H. *) -(* (* eexact EQ0. *) *) -(* intros. *) -(* exists (get_all_helpers p (list_comp p)). *) -(* assert (exists hf_c, get_all_helpers p (list_comp p) (comp_of f) = OK hf_c) as [hf_c ?]. *) -(* { assert (List.In (comp_of f) (list_comp p)). *) -(* admit. *) -(* unfold sel_fundef in *. unfold sel_function in *. simpl in *. *) -(* unfold get_all_helpers in *. destruct in_dec; try congruence. *) -(* destruct (get_helpers p (comp_of f)); eauto. *) -(* admit. *) -(* } *) -(* exists hf_c. split; auto. split; auto. *) -(* apply get_helpers_correct; auto. *) -(* unfold get_all_helpers in H1. *) -(* destruct in_dec; try congruence. *) -(* monadInv H1. auto. *) -(* Admitted. *) + intros. monadInv H. + eapply match_transform_partial_program_contextual. eexact EQ0. + intros. exists x; split; auto. apply get_helpers_correct; auto. +Qed. Lemma helper_functions_declared_linkorder: - forall (p p': Cminor.program) hf_c cp, - helper_functions_declared p hf_c cp -> linkorder p p' -> helper_functions_declared p' hf_c cp. + forall (p p': Cminor.program) hf, + helper_functions_declared p hf -> linkorder p p' -> helper_functions_declared p' hf. Proof. intros. - assert (X: forall id cp name sg, helper_declared p id cp name sg -> helper_declared p' id cp name sg). + assert (X: forall id name sg, helper_declared p id name sg -> helper_declared p' id name sg). { unfold helper_declared; intros. destruct (prog_defmap_linkorder _ _ _ _ H0 H1) as (gd & P & Q). inv Q. inv H3. auto. } @@ -202,7 +145,7 @@ Proof. red; intros. destruct TRANSF as [A _]. exploit list_forall2_in_left; eauto. intros ((i' & gd') & B & (C & D)). simpl in *. inv D. - destruct H2 as (hf & P & Q & R & S). destruct f; monadInv S. + destruct H2 as (hf & P & Q). destruct f; monadInv Q. - monadInv EQ. econstructor; apply type_function_sound; eauto. - constructor. Qed. @@ -235,15 +178,15 @@ Qed. Lemma comp_function_translated: forall cu f tf, match_fundef cu f tf -> comp_of f = comp_of tf. Proof. - intros cu f tf (hf & P & Q & R & S). - destruct f; monadInv S; eauto. + intros cu f tf (hf & P & Q). + destruct f; monadInv Q; eauto. monadInv EQ; eauto. Qed. Lemma sig_function_translated: forall cu f tf, match_fundef cu f tf -> funsig tf = Cminor.funsig f. Proof. - intros. destruct H as (hf & P & Q & R & S). destruct f; monadInv S; auto. monadInv EQ; auto. + intros. destruct H as (hf & P & Q). destruct f; monadInv Q; auto. monadInv EQ; auto. Qed. Lemma stackspace_function_translated: @@ -253,13 +196,13 @@ Proof. Qed. Lemma helper_functions_preserved: - forall hf_c cp, helper_functions_declared prog hf_c cp -> helper_functions_declared tprog hf_c cp. + forall hf, helper_functions_declared prog hf -> helper_functions_declared tprog hf. Proof. - assert (X: forall id cp name sg, helper_declared prog id cp name sg -> helper_declared tprog id cp name sg). + assert (X: forall id name sg, helper_declared prog id name sg -> helper_declared tprog id name sg). { unfold helper_declared; intros. generalize (match_program_defmap _ _ _ _ _ TRANSF id). unfold Cminor.fundef; rewrite H; intros R; inv R. inv H2. - destruct H4 as (cu & A & B & C & D). monadInv D. auto. } + destruct H4 as (cu & A & B). monadInv B. auto. } unfold helper_functions_declared; intros. decompose [Logic.and] H; clear H. auto 20. Qed. @@ -280,22 +223,14 @@ Lemma find_comp_translated: forall vf vf' fd, Val.lessdef vf vf' -> Genv.find_funct ge vf = Some fd -> - Genv.find_comp ge vf = Genv.find_comp tge vf'. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf'. Proof. intros vf vf' fd' LESSDEF FIND. inv LESSDEF. - - eapply (Genv.match_genvs_find_comp TRANSF). + - eapply (Genv.match_genvs_find_comp_in_genv TRANSF). - inv FIND. Qed. -Lemma type_of_call_translated: - forall cp cp', - Genv.type_of_call cp cp' = Genv.type_of_call cp cp'. -Proof. - intros cp cp'. - eapply Genv.match_genvs_type_of_call. -Qed. - Lemma call_trace_translated: forall cp cp' vf vf' vargs tvargs tyargs t, Val.lessdef_list vargs tvargs -> @@ -333,9 +268,9 @@ Variable e: env. Variable cp: compartment. Variable m: mem. -Hypothesis HF: helper_functions_declared cunit hf cp. +Hypothesis HF: helper_functions_declared cunit hf. -Let HF': helper_functions_declared tprog hf cp. +Let HF': helper_functions_declared tprog hf. Proof. apply helper_functions_preserved. eapply helper_functions_declared_linkorder; eauto. Qed. @@ -378,7 +313,7 @@ Qed. Lemma eval_load: forall le a v chunk v', eval_expr tge sp e cp m le a v -> - Mem.loadv chunk m v (Some cp) = Some v' -> + Mem.loadv chunk m v cp = Some v' -> eval_expr tge sp e cp m le (load chunk a) v'. Proof. intros. generalize H0; destruct v; simpl; intro; try discriminate. @@ -409,7 +344,7 @@ Lemma eval_sel_unop: forall le op a1 v1 v, eval_expr tge sp e cp m le a1 v1 -> eval_unop op v1 = Some v -> - exists v', eval_expr tge sp e cp m le (sel_unop cp op a1) v' /\ Val.lessdef v v'. + exists v', eval_expr tge sp e cp m le (sel_unop op a1) v' /\ Val.lessdef v v'. Proof. destruct op; simpl; intros; FuncInv; try subst v. apply eval_cast8unsigned; auto. @@ -452,7 +387,7 @@ Lemma eval_sel_binop: eval_expr tge sp e cp m le a1 v1 -> eval_expr tge sp e cp m le a2 v2 -> eval_binop op v1 v2 m = Some v -> - exists v', eval_expr tge sp e cp m le (sel_binop cp op a1 a2) v' /\ Val.lessdef v v'. + exists v', eval_expr tge sp e cp m le (sel_binop op a1 a2) v' /\ Val.lessdef v v'. Proof. destruct op; simpl; intros; FuncInv; try subst v. apply eval_add; auto. @@ -542,7 +477,7 @@ Proof. simpl in SEM; inv SEM. apply eval_absf; auto. + (* fabsf *) inv ARGS; try discriminate. inv H0; try discriminate. - inv SEL. + inv SEL. simpl in SEM; inv SEM. apply eval_absfs; auto. - eapply eval_platform_builtin; eauto. Qed. @@ -567,10 +502,10 @@ Lemma classify_call_correct: linkorder unit prog -> Cminor.eval_expr ge sp e m cp a v -> Genv.find_funct ge v = Some fd -> - match classify_call (prog_defmap unit) cp a with + match classify_call (prog_defmap unit) a with | Call_default => True | Call_imm id => exists b, Genv.find_symbol ge id = Some b /\ v = Vptr b Ptrofs.zero - | Call_builtin ef => fd = External ef /\ comp_of ef = cp + | Call_builtin ef => fd = External ef end. Proof. unfold classify_call; intros. @@ -582,7 +517,6 @@ Proof. assert (DFL: exists b1, Genv.find_symbol ge id = Some b1 /\ Vptr b Ptrofs.zero = Vptr b1 Ptrofs.zero) by (exists b; auto). unfold globdef; destruct (prog_defmap unit)!id as [[[f|ef] |gv] |] eqn:G; auto. destruct (ef_inline ef) eqn:INLINE; - destruct (Pos.eq_dec (comp_of ef) cp) as [eq | neq]; simpl; auto. destruct (prog_defmap_linkorder _ _ _ _ H G) as (gd & P & Q). @@ -694,9 +628,9 @@ Variable cunit: Cminor.program. Variable cp: compartment. Variable hf: helper_functions. Hypothesis LINK: linkorder cunit prog. -Hypothesis HF: helper_functions_declared cunit hf cp. +Hypothesis HF: helper_functions_declared cunit hf. -Let HF': helper_functions_declared tprog hf cp. +Let HF': helper_functions_declared tprog hf. Proof. apply helper_functions_preserved. eapply helper_functions_declared_linkorder; eauto. Qed. @@ -744,7 +678,7 @@ Lemma sel_switch_long_correct: forall dfl cases arg sp e m i t le, validate_switch Int64.modulus dfl cases t = true -> eval_expr tge sp e cp m le arg (Vlong i) -> - eval_exitexpr tge sp e cp m le (XElet arg (sel_switch_long cp O t)) (switch_target (Int64.unsigned i) dfl cases). + eval_exitexpr tge sp e cp m le (XElet arg (sel_switch_long O t)) (switch_target (Int64.unsigned i) dfl cases). Proof. intros. eapply sel_switch_correct with (R := Rlong); eauto. - intros until n; intros EVAL R RANGE. @@ -877,14 +811,14 @@ Hypothesis LINK: linkorder cunit prog. Section WithCP. Variable hf: helper_functions. Variable cp: compartment. -Hypothesis HF: helper_functions_declared cunit hf cp. +Hypothesis HF: helper_functions_declared cunit hf. Lemma sel_expr_correct: forall sp e m a v, Cminor.eval_expr ge sp e m cp a v -> forall e' le m', env_lessdef e e' -> Mem.extends m m' -> - exists v', eval_expr tge sp e' cp m' le (sel_expr cp a) v' /\ Val.lessdef v v'. + exists v', eval_expr tge sp e' cp m' le (sel_expr a) v' /\ Val.lessdef v v'. Proof. induction 1; intros; simpl. (* Evar *) @@ -906,7 +840,7 @@ Proof. exploit IHeval_expr1; eauto. intros [v1' [A B]]. exploit IHeval_expr2; eauto. intros [v2' [C D]]. exploit eval_binop_lessdef; eauto. intros [v' [E F]]. - assert (G: exists v'', eval_expr tge sp e' cp m' le (sel_binop cp op (sel_expr cp a1) (sel_expr cp a2)) v'' /\ Val.lessdef v' v'') + assert (G: exists v'', eval_expr tge sp e' cp m' le (sel_binop op (sel_expr a1) (sel_expr a2)) v'' /\ Val.lessdef v' v'') by (eapply eval_sel_binop; eauto). destruct G as [v'' [P Q]]. exists v''; split; eauto. eapply Val.lessdef_trans; eauto. @@ -921,7 +855,7 @@ Lemma sel_exprlist_correct: Cminor.eval_exprlist ge sp e m cp a v -> forall e' le m', env_lessdef e e' -> Mem.extends m m' -> - exists v', eval_exprlist tge sp e' cp m' le (sel_exprlist cp a) v' /\ Val.lessdef_list v v'. + exists v', eval_exprlist tge sp e' cp m' le (sel_exprlist a) v' /\ Val.lessdef_list v v'. Proof. induction 1; intros; simpl. exists (@nil val); split; auto. constructor. @@ -932,7 +866,7 @@ Qed. Lemma sel_select_opt_correct: forall ty cond a1 a2 a sp e m vcond v1 v2 b e' m' le, - sel_select_opt cp ty cond a1 a2 = Some a -> + sel_select_opt ty cond a1 a2 = Some a -> Cminor.eval_expr ge sp e m cp cond vcond -> Cminor.eval_expr ge sp e m cp a1 v1 -> Cminor.eval_expr ge sp e m cp a2 v2 -> @@ -941,7 +875,7 @@ Lemma sel_select_opt_correct: exists v', eval_expr tge sp e' cp m' le a v' /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v'. Proof. unfold sel_select_opt; intros. - destruct (condition_of_expr (sel_expr cp cond)) as [cnd args] eqn:C. + destruct (condition_of_expr (sel_expr cond)) as [cnd args] eqn:C. exploit sel_expr_correct. eexact H0. eauto. eauto. intros (vcond' & EVC & LDC). exploit sel_expr_correct. eexact H1. eauto. eauto. intros (v1' & EV1 & LD1). exploit sel_expr_correct. eexact H2. eauto. eauto. intros (v2' & EV2 & LD2). @@ -958,13 +892,13 @@ Lemma sel_builtin_arg_correct: env_lessdef e e' -> Mem.extends m m' -> Cminor.eval_expr ge sp e m cp a v -> exists v', - CminorSel.eval_builtin_arg tge sp e' cp m' (sel_builtin_arg cp a c) v' + CminorSel.eval_builtin_arg tge sp e' cp m' (sel_builtin_arg a c) v' /\ Val.lessdef v v'. Proof. intros. unfold sel_builtin_arg. exploit sel_expr_correct; eauto. intros (v1 & A & B). exists v1; split; auto. - destruct (builtin_arg_ok (builtin_arg (sel_expr cp a)) c). + destruct (builtin_arg_ok (builtin_arg (sel_expr a)) c). apply eval_builtin_arg; eauto. constructor; auto. Qed. @@ -977,7 +911,7 @@ Lemma sel_builtin_args_correct: forall cl, exists vl', list_forall2 (CminorSel.eval_builtin_arg tge sp e' cp m') - (sel_builtin_args cp al cl) + (sel_builtin_args al cl) vl' /\ Val.lessdef_list vl vl'. Proof. @@ -1001,16 +935,15 @@ End WithCP. Section WithFunction. Variable f: function. Variable hf: helper_functions. -Hypothesis HF: helper_functions_declared cunit hf (comp_of f). +Hypothesis HF: helper_functions_declared cunit hf. Lemma sel_builtin_default_correct: forall optid ef al sp e1 m1 vl t v m2 e1' m1' k, - comp_of ef = comp_of f -> Cminor.eval_exprlist ge sp e1 m1 (comp_of f) al vl -> - external_call ef ge vl m1 t v m2 -> + external_call ef ge (comp_of f) vl m1 t v m2 -> env_lessdef e1 e1' -> Mem.extends m1 m1' -> exists e2' m2', - plus step tge (State f (sel_builtin_default (comp_of f) optid ef al) k sp e1' m1') + plus step tge (State f (sel_builtin_default optid ef al) k sp e1' m1') t (State f Sskip k sp e2' m2') /\ env_lessdef (set_optvar optid v e1) e2' /\ Mem.extends m2 m2'. @@ -1028,13 +961,12 @@ Qed. Lemma sel_builtin_correct: forall optid ef al sp e1 m1 vl t v m2 e1' m1' k, - comp_of ef = comp_of f -> Cminor.eval_exprlist ge sp e1 m1 (comp_of f) al vl -> - external_call ef ge vl m1 t v m2 -> + external_call ef ge (comp_of f) vl m1 t v m2 -> env_lessdef e1 e1' -> Mem.extends m1 m1' -> (* forall ALLOWED: Policy.allowed_call (comp_of f) (External ef), *) exists e2' m2', - plus step tge (State f (sel_builtin (comp_of f) optid ef al) k sp e1' m1') + plus step tge (State f (sel_builtin optid ef al) k sp e1' m1') t (State f Sskip k sp e2' m2') /\ env_lessdef (set_optvar optid v e1) e2' /\ Mem.extends m2 m2'. @@ -1044,10 +976,10 @@ Proof. exploit external_call_mem_extends; eauto. intros (v' & m2' & D & E & F & _). unfold sel_builtin. destruct ef; eauto using sel_builtin_default_correct. - destruct (lookup_builtin_function name cp sg) as [bf|] eqn:LKUP; eauto using sel_builtin_default_correct. + destruct (lookup_builtin_function name sg) as [bf|] eqn:LKUP; eauto using sel_builtin_default_correct. simpl in D. red in D. rewrite LKUP in D. inv D. destruct optid as [id|]; eauto using sel_builtin_default_correct. -- destruct (sel_known_builtin bf (sel_exprlist (comp_of f) al)) as [a|] eqn:SKB; eauto using sel_builtin_default_correct. +- destruct (sel_known_builtin bf (sel_exprlist al)) as [a|] eqn:SKB; eauto using sel_builtin_default_correct. exploit eval_sel_known_builtin; eauto. intros (v'' & U & V). econstructor; exists m2'; split. apply plus_one. econstructor. reflexivity. eexact U. @@ -1127,12 +1059,12 @@ Qed. Section WithCminorFunction. Variable f: Cminor.function. Variable hf: helper_functions. -Hypothesis HF: helper_functions_declared cunit hf (comp_of f). +Hypothesis HF: helper_functions_declared cunit hf. Lemma if_conversion_base_correct: forall env cond id ifso ifnot s e ty vb b sp m tf tk e' m', forall (COMP: comp_of f = comp_of tf), - if_conversion_base (comp_of f) (known_id f) env cond id ifso ifnot = Some s -> + if_conversion_base (known_id f) env cond id ifso ifnot = Some s -> def_env f e -> wt_env env e -> env id = ty -> wt_expr env ifso ty -> @@ -1151,7 +1083,7 @@ Proof. safe_expr (known_id f) ifso && safe_expr (known_id f) ifnot && if_conversion_heuristic cond ifso ifnot ty) eqn:C; try discriminate. - destruct (sel_select_opt (comp_of f) ty cond ifso ifnot) as [a'|] eqn:SSO; simpl in H; inv H. + destruct (sel_select_opt ty cond ifso ifnot) as [a'|] eqn:SSO; simpl in H; inv H. InvBooleans. destruct (eval_safe_expr ge f sp e m (comp_of f) ifso) as (v1 & EV1); auto. destruct (eval_safe_expr ge f sp e m (comp_of f) ifnot) as (v2 & EV2); auto. @@ -1166,7 +1098,7 @@ Qed. Lemma if_conversion_correct: forall env tyret cond ifso ifnot s vb b k f' k' sp e m e' m', forall (COMP: comp_of f = comp_of f'), - if_conversion (comp_of f) (known_id f) env cond ifso ifnot = Some s -> + if_conversion (known_id f) env cond ifso ifnot = Some s -> def_env f e -> wt_env env e -> wt_stmt env tyret ifso -> wt_stmt env tyret ifnot -> @@ -1216,7 +1148,7 @@ End EXPRESSIONS. Inductive match_cont: Cminor.program -> helper_functions -> known_idents -> typenv -> compartment -> Cminor.cont -> CminorSel.cont -> Prop := | match_cont_seq: forall cunit hf ki env s s' k k' cp, - sel_stmt (prog_defmap cunit) cp ki env s = OK s' -> + sel_stmt (prog_defmap cunit) ki env s = OK s' -> match_cont cunit hf ki env cp k k' -> match_cont cunit hf ki env cp (Cminor.Kseq s k) (Kseq s' k') | match_cont_block: forall cunit hf ki env k k' cp, @@ -1229,41 +1161,39 @@ Inductive match_cont: Cminor.program -> helper_functions -> known_idents -> type with match_call_cont: Cminor.cont -> CminorSel.cont -> Prop := | match_cont_stop: match_call_cont Cminor.Kstop Kstop - | match_cont_call: forall cunit hf hf_c env id f sp e k f' e' k', + | match_cont_call: forall cunit hf env id f sp e k f' e' k', linkorder cunit prog -> - helper_functions_declared cunit hf_c f.(Cminor.fn_comp) -> - hf f.(Cminor.fn_comp) = OK hf_c -> + helper_functions_declared cunit hf -> sel_function (prog_defmap cunit) hf f = OK f' -> type_function f = OK env -> - match_cont cunit hf_c (known_id f) env f.(Cminor.fn_comp) k k' -> + match_cont cunit hf (known_id f) env f.(Cminor.fn_comp) k k' -> env_lessdef e e' -> f.(Cminor.fn_comp) = f'.(fn_comp) -> match_call_cont (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k'). Inductive match_states: Cminor.state -> CminorSel.state -> Prop := - | match_state: forall cunit hf hf_c f f' s k s' k' sp e m e' m' env + | match_state: forall cunit hf f f' s k s' k' sp e m e' m' env (LINK: linkorder cunit prog) - (HF: helper_functions_declared cunit hf_c (comp_of f)) - (HF_C: hf (comp_of f) = OK hf_c) + (HF: helper_functions_declared cunit hf) (TF: sel_function (prog_defmap cunit) hf f = OK f') (TYF: type_function f = OK env) - (TS: sel_stmt (prog_defmap cunit) (comp_of f) (known_id f) env s = OK s') - (MC: match_cont cunit hf_c (known_id f) env (comp_of f) k k') + (TS: sel_stmt (prog_defmap cunit) (known_id f) env s = OK s') + (MC: match_cont cunit hf (known_id f) env (comp_of f) k k') (LD: env_lessdef e e') (ME: Mem.extends m m') (CPT: comp_of f = comp_of f'), match_states (Cminor.State f s k sp e m) (State f' s' k' sp e' m') - | match_callstate: forall cunit f f' args args' k k' m m' + | match_callstate: forall cunit f f' args args' k k' m m' cp (LINK: linkorder cunit prog) (TF: match_fundef cunit f f') (MC: match_call_cont k k') (LD: Val.lessdef_list args args') (ME: Mem.extends m m'), match_states - (Cminor.Callstate f args k m) - (Callstate f' args' k' m') + (Cminor.Callstate f args k m cp) + (Callstate f' args' k' m' cp) | match_returnstate: forall v v' k k' m m' ty cp (MC: match_call_cont k k') (LD: Val.lessdef v v') @@ -1271,38 +1201,29 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := match_states (Cminor.Returnstate v k m ty cp) (Returnstate v' k' m' ty cp) - | match_builtin_1: forall cunit hf hf_c ef args optid f sp e k m al f' e' k' m' env + | match_builtin_1: forall cunit hf ef args optid f sp e k m al f' e' k' m' env (LINK: linkorder cunit prog) - (HF: helper_functions_declared cunit hf_c (comp_of f)) - (HF_C: hf (comp_of f) = OK hf_c) + (HF: helper_functions_declared cunit hf) (TF: sel_function (prog_defmap cunit) hf f = OK f') - (* (HF: helper_functions_declared cunit hf) *) - (* (TF: sel_function (prog_defmap cunit) hf f = OK f') *) (TYF: type_function f = OK env) - (MC: match_cont cunit hf_c (known_id f) env (comp_of f) k k') + (MC: match_cont cunit hf (known_id f) env (comp_of f) k k') (EA: Cminor.eval_exprlist ge sp e m (comp_of f) al args) (LDE: env_lessdef e e') (ME: Mem.extends m m') - (CPT: comp_of f = comp_of f') - (CPT': comp_of f = comp_of ef), - (* (CP_DEF: comp_of ef = default_compartment), *) + (CPT: comp_of f = comp_of f'), match_states - (Cminor.Callstate (External ef) args (Cminor.Kcall optid f sp e k) m) - (State f' (sel_builtin (comp_of f) optid ef al) k' sp e' m') - | match_builtin_2: forall cunit hf hf_c v v' optid f sp e k m f' e' m' k' env ty + (Cminor.Callstate (External ef) args (Cminor.Kcall optid f sp e k) m (comp_of f)) + (State f' (sel_builtin optid ef al) k' sp e' m') + | match_builtin_2: forall cunit hf v v' optid f sp e k m f' e' m' k' env ty (LINK: linkorder cunit prog) - (HF: helper_functions_declared cunit hf_c (comp_of f)) - (HF_C: hf (comp_of f) = OK hf_c) + (HF: helper_functions_declared cunit hf) (TF: sel_function (prog_defmap cunit) hf f = OK f') - (* (HF: helper_functions_declared cunit hf) *) - (* (TF: sel_function (prog_defmap cunit) hf f = OK f') *) (TYF: type_function f = OK env) - (MC: match_cont cunit hf_c (known_id f) env (comp_of f) k k') + (MC: match_cont cunit hf (known_id f) env (comp_of f) k k') (LDV: Val.lessdef v v') (LDE: env_lessdef (set_optvar optid v e) e') (ME: Mem.extends m m') (CPT: comp_of f = comp_of f'), - (* (CP_DEF: cp = default_compartment), *) match_states (Cminor.Returnstate v (Cminor.Kcall optid f sp e k) m ty (comp_of f)) (State f' Sskip k' sp e' m'). @@ -1363,19 +1284,19 @@ Proof. red; intros; simpl. rewrite CL1; apply CL2. Qed. -Lemma if_conversion_base_nolabel: forall (hf: helper_functions) cp ki env a id a1 a2 s, - if_conversion_base cp ki env a id a1 a2 = Some s -> +Lemma if_conversion_base_nolabel: forall (hf: helper_functions) ki env a id a1 a2 s, + if_conversion_base ki env a id a1 a2 = Some s -> nolabel' s. Proof. unfold if_conversion_base; intros. destruct (is_known ki id && safe_expr ki a1 && safe_expr ki a2 && if_conversion_heuristic a a1 a2 (env id)); try discriminate. - destruct (sel_select_opt cp (env id) a a1 a2); inv H. + destruct (sel_select_opt (env id) a a1 a2); inv H. red; auto. Qed. -Lemma if_conversion_nolabel: forall (hf: helper_functions) cp ki env a s1 s2 s, - if_conversion cp ki env a s1 s2 = Some s -> +Lemma if_conversion_nolabel: forall (hf: helper_functions) ki env a s1 s2 s, + if_conversion ki env a s1 s2 = Some s -> nolabel s1 /\ nolabel s2 /\ nolabel' s. Proof. unfold if_conversion; intros. @@ -1391,7 +1312,7 @@ Proof. Qed. Remark sel_builtin_nolabel: - forall (hf: helper_functions) cp optid ef args, nolabel' (sel_builtin cp optid ef args). + forall (hf: helper_functions) optid ef args, nolabel' (sel_builtin optid ef args). Proof. unfold sel_builtin; intros; red; intros. destruct ef; auto. destruct lookup_builtin_function; auto. @@ -1401,21 +1322,21 @@ Qed. Remark find_label_commut: forall cp cunit hf ki env lbl s k s' k', match_cont cunit hf ki env cp k k' -> - sel_stmt (prog_defmap cunit) cp ki env s = OK s' -> + sel_stmt (prog_defmap cunit) ki env s = OK s' -> match Cminor.find_label lbl s k, find_label lbl s' k' with | None, None => True - | Some(s1, k1), Some(s1', k1') => sel_stmt (prog_defmap cunit) cp ki env s1 = OK s1' /\ match_cont cunit hf ki env cp k1 k1' + | Some(s1, k1), Some(s1', k1') => sel_stmt (prog_defmap cunit) ki env s1 = OK s1' /\ match_cont cunit hf ki env cp k1 k1' | _, _ => False end. Proof. induction s; intros until k'; simpl; intros MC SE; try (monadInv SE); simpl; auto. (* store *) - unfold store. destruct (addressing m (sel_expr cp e)); simpl; auto. + unfold store. destruct (addressing m (sel_expr e)); simpl; auto. (* call *) - destruct (classify_call (prog_defmap cunit) cp e); simpl; auto. + destruct (classify_call (prog_defmap cunit) e); simpl; auto. rewrite sel_builtin_nolabel; auto. (* tailcall *) - destruct (classify_call (prog_defmap cunit) cp e); simpl; auto. + destruct (classify_call (prog_defmap cunit) e); simpl; auto. (* builtin *) rewrite sel_builtin_nolabel; auto. (* seq *) @@ -1424,7 +1345,7 @@ Proof. destruct (find_label lbl x (Kseq x0 k')) as [[sy ky] | ]; intuition. apply IHs2; auto. (* ifthenelse *) - destruct (if_conversion cp ki env e s1 s2) as [s|] eqn:IFC. + destruct (if_conversion ki env e s1 s2) as [s|] eqn:IFC. inv SE. exploit if_conversion_nolabel; eauto. intros (A & B & C). rewrite A, B, C. auto. monadInv SE; simpl. @@ -1452,7 +1373,7 @@ Qed. Definition measure (s: Cminor.state) : nat := match s with - | Cminor.Callstate _ _ _ _ => 0%nat + | Cminor.Callstate _ _ _ _ _ => 0%nat | Cminor.State _ _ _ _ _ _ => 1%nat | Cminor.Returnstate _ _ _ _ _ => 2%nat end. @@ -1476,9 +1397,8 @@ Proof. left; econstructor; split. apply plus_one; econstructor. eapply match_is_call_cont; eauto. erewrite stackspace_function_translated, <- CPT; eauto. - monadInv TF. simpl. rewrite <- CPT. + monadInv TF. simpl. econstructor; eauto. - assert (x0 = hf_c). { unfold comp_of in *. simpl in *; congruence. } subst x0. eapply match_is_call_cont; eauto. - (* assign *) exploit sel_expr_correct; eauto. intros [v' [A B]]. @@ -1497,7 +1417,7 @@ Proof. econstructor; eauto. - (* Scall *) exploit classify_call_correct; eauto. - destruct (classify_call (prog_defmap cunit) (comp_of f) a) as [ | id | ef]. + destruct (classify_call (prog_defmap cunit) a) as [ | id | ef]. + (* indirect *) exploit sel_expr_correct; eauto. intros [vf' [A B]]. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. @@ -1514,6 +1434,7 @@ Proof. erewrite comp_function_translated; eauto. erewrite <- CPT, <- comp_function_translated; eauto. eapply call_trace_translated; eauto. + rewrite <- CPT. eapply match_callstate with (cunit := cunit'); eauto. eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. + (* direct *) @@ -1534,18 +1455,19 @@ Proof. subst vf. rewrite <- CPT, <- (comp_function_translated _ _ _ Y). apply call_trace_translated with (vf := Vptr b Ptrofs.zero) (vargs := vargs); auto. + rewrite <- CPT. eapply match_callstate with (cunit := cunit'); eauto. eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. + (* turned into Sbuiltin *) - intros [EQ EQ']; subst fd. - (* intros [EQ EQ']. subst fd. *) + intros EQ; subst fd. right; left; split. simpl; lia. split; auto. inv EV. auto. simpl in *. - unfold Genv.find_comp, Genv.find_funct in *. + unfold Genv.find_comp_in_genv, Genv.find_funct in *. destruct (Ptrofs.eq_dec ofs Ptrofs.zero); try congruence. - rewrite <- EQ' in H2. - eapply Genv.type_of_call_same_cp in H2; contradiction. + (* rewrite <- EQ' in H2. *) + destruct (flowsto_dec bottom (comp_of f)); try now auto. + pose proof (bottom_flowsto (comp_of f)); contradiction. econstructor; eauto. - (* Stailcall *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. @@ -1586,19 +1508,21 @@ Proof. rewrite <- CPT; trivial. (* rewrite CPT in ALLOWED'; eauto. *) (* eapply allowed_call_translated; eauto. *) - (* rewrite <- CPT; eauto. *) + rewrite <- CPT; eauto. eapply match_callstate with (cunit := cunit'); eauto. eapply call_cont_commut; eauto. - (* Sbuiltin *) exploit sel_builtin_correct; eauto; try (now erewrite <- CPT; eauto). intros (e2' & m2' & P & Q & R). - left; econstructor; split. rewrite CPT. eexact P. econstructor; eauto. + left; econstructor; split. + (* rewrite CPT. *) + eexact P. econstructor; eauto. - (* Seq *) left; econstructor; split. apply plus_one; constructor. econstructor; eauto. constructor; auto. - (* Sifthenelse *) - simpl in TS. destruct (if_conversion (comp_of f) (known_id f) env a s1 s2) as [s|] eqn:IFC; monadInv TS. + simpl in TS. destruct (if_conversion (known_id f) env a s1 s2) as [s|] eqn:IFC; monadInv TS. + inv WTS. inv WT_FN. assert (env0 = env) by congruence. subst env0. inv WT_STMT. exploit if_conversion_correct; eauto. set (s0 := if b then s1 else s2). intros (n & e1 & e1' & A & B & C). @@ -1646,8 +1570,7 @@ Proof. eauto. rewrite <- CPT. monadInv TF. econstructor; eauto. - assert (x0 = hf_c). { rewrite CPT in HF_C; unfold comp_of in *; simpl in *. congruence. } - subst x0. eapply call_cont_commut; eauto. + eapply call_cont_commut; eauto. - (* Sreturn Some *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. erewrite <- stackspace_function_translated in P by eauto. @@ -1656,16 +1579,14 @@ Proof. apply plus_one; econstructor; eauto. monadInv TF. econstructor; eauto. - assert (x0 = hf_c). { rewrite CPT in HF_C; unfold comp_of in *; simpl in *. congruence. } - subst x0. eapply call_cont_commut; eauto. + eapply call_cont_commut; eauto. - (* Slabel *) left; econstructor; split. apply plus_one; constructor. econstructor; eauto. - (* Sgoto *) - assert (sel_stmt (prog_defmap cunit) (Cminor.fn_comp f) (known_id f) env (Cminor.fn_body f) = OK (fn_body f')). + assert (sel_stmt (prog_defmap cunit) (known_id f) env (Cminor.fn_body f) = OK (fn_body f')). { monadInv TF; simpl. - assert (x0 = hf_c). { rewrite CPT in HF_C; unfold comp_of in *; simpl in *. congruence. } - subst x0. congruence. } - exploit (find_label_commut (Cminor.fn_comp f) cunit hf_c (known_id f) env lbl (Cminor.fn_body f) (Cminor.call_cont k)). + congruence. } + exploit (find_label_commut (Cminor.fn_comp f) cunit hf (known_id f) env lbl (Cminor.fn_body f) (Cminor.call_cont k)). apply match_cont_other. eapply call_cont_commut; eauto. eauto. rewrite H. destruct (find_label lbl (fn_body f') (call_cont k'0)) @@ -1675,19 +1596,17 @@ Proof. apply plus_one; econstructor; eauto. econstructor; eauto. - (* internal function *) - destruct TF as (hf & hf_c & HF_C & HF & TF). + destruct TF as (hf & HF & TF). monadInv TF. generalize EQ; intros TF; monadInv TF. exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. intros [m2' [A B]]. left; econstructor; split. apply plus_one; econstructor; simpl; eauto. - assert (x1 = hf_c). { replace (comp_of (Internal f)) with (Cminor.fn_comp f) in HF_C by reflexivity. congruence. } - subst x1. econstructor; simpl; eauto. apply match_cont_other; auto. apply set_locals_lessdef. apply set_params_lessdef; auto. - (* external call *) - destruct TF as (hf & hf_c & HF_C & HF & TF). + destruct TF as (hf & HF & TF). monadInv TF. exploit external_call_mem_extends; eauto. intros [vres' [m2 [A [B [C D]]]]]. @@ -1697,10 +1616,10 @@ Proof. - (* external call turned into a Sbuiltin *) exploit sel_builtin_correct; eauto. rewrite <- CPT; eauto. rewrite <- CPT; eauto. - rewrite <- CPT; eauto. intros (e2' & m2' & P & Q & R). - left; econstructor; split. rewrite CPT. eexact P. - rewrite <- CPT'. econstructor; eauto. + left; econstructor; split. eexact P. + replace bottom with (@comp_of _ (@has_comp_fundef function has_comp_function) (External ef)). + econstructor; eauto. - (* return *) inv MC. left; econstructor; split. diff --git a/backend/SplitLong.vp b/backend/SplitLong.vp index 3747ed1cd8..0ea811d009 100644 --- a/backend/SplitLong.vp +++ b/backend/SplitLong.vp @@ -55,7 +55,6 @@ Definition sig_ii_l := mksignature (Tint :: Tint :: nil) Tlong cc_default. Section SELECT. Context {hf: helper_functions}. -Context (cp: compartment). Definition makelong (h l: expr): expr := Eop Omakelong (h ::: l ::: Enil). @@ -126,7 +125,7 @@ Definition longofintu (e: expr) := Definition negl (e: expr) := match is_longconst e with | Some n => longconst (Int64.neg n) - | None => Ebuiltin (EF_builtin cp (standard_builtin_name "__builtin_negl" cp) sig_l_l) (e ::: Enil) + | None => Ebuiltin (EF_builtin "__builtin_negl" sig_l_l) (e ::: Enil) end. Definition notl (e: expr) := @@ -220,7 +219,7 @@ Definition shrl (e1 e2: expr) := end. Definition addl (e1 e2: expr) := - let default := Ebuiltin (EF_builtin cp (standard_builtin_name "__builtin_addl" cp) sig_ll_l) (e1 ::: e2 ::: Enil) in + let default := Ebuiltin (EF_builtin "__builtin_addl" sig_ll_l) (e1 ::: e2 ::: Enil) in match is_longconst e1, is_longconst e2 with | Some n1, Some n2 => longconst (Int64.add n1 n2) | Some n1, _ => if Int64.eq n1 Int64.zero then e2 else default @@ -229,7 +228,7 @@ Definition addl (e1 e2: expr) := end. Definition subl (e1 e2: expr) := - let default := Ebuiltin (EF_builtin cp (standard_builtin_name "__builtin_subl" cp) sig_ll_l) (e1 ::: e2 ::: Enil) in + let default := Ebuiltin (EF_builtin "__builtin_subl" sig_ll_l) (e1 ::: e2 ::: Enil) in match is_longconst e1, is_longconst e2 with | Some n1, Some n2 => longconst (Int64.sub n1 n2) | Some n1, _ => if Int64.eq n1 Int64.zero then negl e2 else default @@ -239,7 +238,7 @@ Definition subl (e1 e2: expr) := Definition mull_base (e1 e2: expr) := splitlong2 e1 e2 (fun h1 l1 h2 l2 => - Elet (Ebuiltin (EF_builtin cp (standard_builtin_name "__builtin_mull" cp) sig_ii_l) (l1 ::: l2 ::: Enil)) + Elet (Ebuiltin (EF_builtin "__builtin_mull" sig_ii_l) (l1 ::: l2 ::: Enil)) (makelong (add (add (Eop Ohighlong (Eletvar O ::: Enil)) (mul (lift l1) (lift h2))) diff --git a/backend/SplitLongproof.v b/backend/SplitLongproof.v index dceeb12e25..38becfdbef 100644 --- a/backend/SplitLongproof.v +++ b/backend/SplitLongproof.v @@ -23,25 +23,25 @@ Local Open Scope string_scope. (** * Properties of the helper functions *) -Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (cp: compartment) (name: string) (sg: signature) : Prop := - (prog_defmap p)!id = Some (Gfun (External (EF_runtime cp name sg))). - -Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) V) (hf: helper_functions) (cp: compartment): Prop := - helper_declared p i64_dtos cp (standard_builtin_name "__compcert_i64_dtos" cp) sig_f_l - /\ helper_declared p i64_dtou cp (standard_builtin_name "__compcert_i64_dtou" cp) sig_f_l - /\ helper_declared p i64_stod cp (standard_builtin_name "__compcert_i64_stod" cp) sig_l_f - /\ helper_declared p i64_utod cp (standard_builtin_name "__compcert_i64_utod" cp) sig_l_f - /\ helper_declared p i64_stof cp (standard_builtin_name "__compcert_i64_stof" cp) sig_l_s - /\ helper_declared p i64_utof cp (standard_builtin_name "__compcert_i64_utof" cp) sig_l_s - /\ helper_declared p i64_sdiv cp (standard_builtin_name "__compcert_i64_sdiv" cp) sig_ll_l - /\ helper_declared p i64_udiv cp (standard_builtin_name "__compcert_i64_udiv" cp) sig_ll_l - /\ helper_declared p i64_smod cp (standard_builtin_name "__compcert_i64_smod" cp) sig_ll_l - /\ helper_declared p i64_umod cp (standard_builtin_name "__compcert_i64_umod" cp) sig_ll_l - /\ helper_declared p i64_shl cp (standard_builtin_name "__compcert_i64_shl" cp) sig_li_l - /\ helper_declared p i64_shr cp (standard_builtin_name "__compcert_i64_shr" cp) sig_li_l - /\ helper_declared p i64_sar cp (standard_builtin_name "__compcert_i64_sar" cp) sig_li_l - /\ helper_declared p i64_umulh cp (standard_builtin_name "__compcert_i64_umulh" cp) sig_ll_l - /\ helper_declared p i64_smulh cp (standard_builtin_name "__compcert_i64_smulh" cp) sig_ll_l. +Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := + (prog_defmap p)!id = Some (Gfun (External (EF_runtime name sg))). + +Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) V) (hf: helper_functions) : Prop := + helper_declared p i64_dtos "__compcert_i64_dtos" sig_f_l + /\ helper_declared p i64_dtou "__compcert_i64_dtou" sig_f_l + /\ helper_declared p i64_stod "__compcert_i64_stod" sig_l_f + /\ helper_declared p i64_utod "__compcert_i64_utod" sig_l_f + /\ helper_declared p i64_stof "__compcert_i64_stof" sig_l_s + /\ helper_declared p i64_utof "__compcert_i64_utof" sig_l_s + /\ helper_declared p i64_sdiv "__compcert_i64_sdiv" sig_ll_l + /\ helper_declared p i64_udiv "__compcert_i64_udiv" sig_ll_l + /\ helper_declared p i64_smod "__compcert_i64_smod" sig_ll_l + /\ helper_declared p i64_umod "__compcert_i64_umod" sig_ll_l + /\ helper_declared p i64_shl "__compcert_i64_shl" sig_li_l + /\ helper_declared p i64_shr "__compcert_i64_shr" sig_li_l + /\ helper_declared p i64_sar "__compcert_i64_sar" sig_li_l + /\ helper_declared p i64_umulh "__compcert_i64_umulh" sig_ll_l + /\ helper_declared p i64_smulh "__compcert_i64_smulh" sig_ll_l. (** * Correctness of the instruction selection functions for 64-bit operators *) @@ -49,20 +49,20 @@ Section CMCONSTR. Variable prog: program. Variable hf: helper_functions. +Hypothesis HELPERS: helper_functions_declared prog hf. Let ge := Genv.globalenv prog. Variable sp: val. Variable e: env. Variable cp: compartment. -Hypothesis HELPERS: helper_functions_declared prog hf cp. Variable m: mem. Ltac DeclHelper := red in HELPERS; decompose [Logic.and] HELPERS; eauto. Lemma eval_helper: - forall bf le id name cp sg args vargs vres, + forall bf le id name sg args vargs vres, eval_exprlist ge sp e cp m le args vargs -> - helper_declared prog id cp name sg -> - lookup_builtin_function name cp sg = Some bf -> + helper_declared prog id name sg -> + lookup_builtin_function name sg = Some bf -> builtin_function_sem bf vargs = Some vres -> eval_expr ge sp e cp m le (Eexternal id sg args) vres. Proof. @@ -71,58 +71,53 @@ Proof. rewrite <- Genv.find_funct_ptr_iff in Q. econstructor; eauto. simpl. red. rewrite H1. constructor; auto. - unfold Genv.type_of_call. simpl. unfold ge, Genv.find_comp. - rewrite Pos.eqb_refl. congruence. Qed. Corollary eval_helper_1: - forall bf le id name cp sg arg1 varg1 vres, + forall bf le id name sg arg1 varg1 vres, eval_expr ge sp e cp m le arg1 varg1 -> - helper_declared prog id cp name sg -> - lookup_builtin_function name cp sg = Some bf -> + helper_declared prog id name sg -> + lookup_builtin_function name sg = Some bf -> builtin_function_sem bf (varg1 :: nil) = Some vres -> - (* forall (ALLOWED: Policy.allowed_call cp (External (EF_runtime name sg))), *) eval_expr ge sp e cp m le (Eexternal id sg (arg1 ::: Enil)) vres. Proof. intros. eapply eval_helper; eauto. constructor; auto. constructor. Qed. Corollary eval_helper_2: - forall bf le id name cp sg arg1 arg2 varg1 varg2 vres, + forall bf le id name sg arg1 arg2 varg1 varg2 vres, eval_expr ge sp e cp m le arg1 varg1 -> eval_expr ge sp e cp m le arg2 varg2 -> - helper_declared prog id cp name sg -> - lookup_builtin_function name cp sg = Some bf -> + helper_declared prog id name sg -> + lookup_builtin_function name sg = Some bf -> builtin_function_sem bf (varg1 :: varg2 :: nil) = Some vres -> - (* forall (ALLOWED: Policy.allowed_call cp (External (EF_runtime name sg))), *) eval_expr ge sp e cp m le (Eexternal id sg (arg1 ::: arg2 ::: Enil)) vres. Proof. intros. eapply eval_helper; eauto. constructor; auto. constructor; auto. constructor. Qed. Remark eval_builtin_1: - forall bf le id cp sg arg1 varg1 vres, + forall bf le id sg arg1 varg1 vres, eval_expr ge sp e cp m le arg1 varg1 -> - lookup_builtin_function id cp sg = Some bf -> + lookup_builtin_function id sg = Some bf -> builtin_function_sem bf (varg1 :: nil) = Some vres -> (* forall (ALLOWED: Policy.allowed_call cp (External (EF_builtin id sg))), *) - (* eval_expr ge sp e cp m le (Ebuiltin (EF_builtin cp id sg) (arg1 ::: Enil)) vres. *) - eval_expr ge sp e cp m le (Ebuiltin (EF_builtin cp id sg) (arg1 ::: Enil)) vres. + eval_expr ge sp e cp m le (Ebuiltin (EF_builtin id sg) (arg1 ::: Enil)) vres. Proof. intros. econstructor. econstructor. eauto. constructor. - simpl. red. rewrite H0. constructor. auto. auto. + simpl. red. rewrite H0. constructor. auto. Qed. Remark eval_builtin_2: - forall bf le id cp sg arg1 arg2 varg1 varg2 vres, + forall bf le id sg arg1 arg2 varg1 varg2 vres, eval_expr ge sp e cp m le arg1 varg1 -> eval_expr ge sp e cp m le arg2 varg2 -> - lookup_builtin_function id cp sg = Some bf -> + lookup_builtin_function id sg = Some bf -> builtin_function_sem bf (varg1 :: varg2 :: nil) = Some vres -> - eval_expr ge sp e cp m le (Ebuiltin (EF_builtin cp id sg) (arg1 ::: arg2 ::: Enil)) vres. + eval_expr ge sp e cp m le (Ebuiltin (EF_builtin id sg) (arg1 ::: arg2 ::: Enil)) vres. Proof. intros. econstructor. constructor; eauto. constructor; eauto. constructor. - simpl. red. rewrite H1. constructor. auto. auto. + simpl. red. rewrite H1. constructor. auto. Qed. Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := @@ -368,16 +363,14 @@ Proof. f_equal. destruct (zlt (i0 - Int.zwordsize + (Int.zwordsize - 1)) Int.zwordsize); lia. Qed. -Theorem eval_negl: unary_constructor_sound (negl cp) Val.negl. +Theorem eval_negl: unary_constructor_sound negl Val.negl. Proof. unfold negl; red; intros. destruct (is_longconst a) eqn:E. - econstructor; split. apply eval_longconst. exploit is_longconst_sound; eauto. intros EQ; subst x. simpl. auto. - exists (Val.negl x); split; auto. eapply (eval_builtin_1 (BI_standard BI_negl)); eauto. - admit. -(* Qed. *) -Admitted. +Qed. Theorem eval_notl: unary_constructor_sound notl Val.notl. Proof. @@ -400,8 +393,7 @@ Proof. intros; unfold longoffloat. econstructor; split. eapply (eval_helper_1 (BI_standard BI_i64_dtos)); eauto. DeclHelper. auto. auto. -(* Qed. *) -Admitted. +Qed. Theorem eval_longuoffloat: forall le a x y, @@ -411,8 +403,7 @@ Theorem eval_longuoffloat: Proof. intros; unfold longuoffloat. econstructor; split. eapply (eval_helper_1 (BI_standard BI_i64_dtou)); eauto. DeclHelper. auto. auto. -(* Qed. *) -Admitted. +Qed. Theorem eval_floatoflong: forall le a x y, @@ -422,10 +413,8 @@ Theorem eval_floatoflong: Proof. intros; unfold floatoflong. exists y; split; auto. eapply (eval_helper_1 (BI_standard BI_i64_stod)); eauto. DeclHelper. auto. - admit. simpl. destruct x; simpl in H0; inv H0; auto. -(* Qed. *) -Admitted. +Qed. Theorem eval_floatoflongu: forall le a x y, @@ -435,10 +424,8 @@ Theorem eval_floatoflongu: Proof. intros; unfold floatoflongu. exists y; split; auto. eapply (eval_helper_1 (BI_standard BI_i64_utod)); eauto. DeclHelper. auto. - admit. simpl. destruct x; simpl in H0; inv H0; auto. -(* Qed. *) -Admitted. +Qed. Theorem eval_longofsingle: forall le a x y, @@ -476,10 +463,8 @@ Theorem eval_singleoflong: Proof. intros; unfold singleoflong. exists y; split; auto. eapply (eval_helper_1 (BI_standard BI_i64_stof)); eauto. DeclHelper. auto. - admit. simpl. destruct x; simpl in H0; inv H0; auto. -(* Qed. *) -Admitted. +Qed. Theorem eval_singleoflongu: forall le a x y, @@ -489,10 +474,8 @@ Theorem eval_singleoflongu: Proof. intros; unfold singleoflongu. exists y; split; auto. eapply (eval_helper_1 (BI_standard BI_i64_utof)); eauto. DeclHelper. auto. - admit. simpl. destruct x; simpl in H0; inv H0; auto. -(* Qed. *) -Admitted. +Qed. Theorem eval_andl: binary_constructor_sound andl Val.andl. Proof. @@ -619,10 +602,9 @@ Proof. rewrite Int64.ofwords_recompose. auto. auto. + (* n >= 64 *) econstructor; split. - eapply eval_helper_2; eauto. EvalOp. DeclHelper. instantiate (1 := BI_standard BI_i64_shl); admit. (* reflexivity. *) reflexivity. + eapply eval_helper_2; eauto. EvalOp. DeclHelper. reflexivity. reflexivity. auto. -(* Qed. *) -Admitted. +Qed. Theorem eval_shll: binary_constructor_sound shll Val.shll. Proof. @@ -632,9 +614,8 @@ Proof. exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0. eapply eval_shllimm; eauto. - (* General case *) - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. instantiate (1 := BI_standard BI_i64_shl); admit. (* reflexivity. *) reflexivity. auto. -(* Qed. *) -Admitted. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. reflexivity. auto. +Qed. Lemma eval_shrluimm: forall n, @@ -668,10 +649,9 @@ Proof. rewrite Int64.ofwords_recompose. auto. auto. + (* n >= 64 *) econstructor; split. - eapply eval_helper_2; eauto. EvalOp. DeclHelper. instantiate (1 := BI_standard BI_i64_shr); admit. (* reflexivity. *) reflexivity. + eapply eval_helper_2; eauto. EvalOp. DeclHelper. reflexivity. reflexivity. auto. -(* Qed. *) -Admitted. +Qed. Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu. Proof. @@ -681,9 +661,8 @@ Proof. exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0. eapply eval_shrluimm; eauto. - (* General case *) - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. instantiate (1 := BI_standard BI_i64_shr); admit. (* reflexivity. *) reflexivity. auto. -(* Qed. *) -Admitted. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. reflexivity. auto. +Qed. Lemma eval_shrlimm: forall n, @@ -721,10 +700,9 @@ Proof. rewrite Int64.ofwords_recompose. auto. auto. + (* n >= 64 *) econstructor; split. - eapply eval_helper_2; eauto. EvalOp. DeclHelper. instantiate (1 := BI_standard BI_i64_sar); admit. (* reflexivity. *) reflexivity. + eapply eval_helper_2; eauto. EvalOp. DeclHelper. reflexivity. reflexivity. auto. -(* Qed. *) -Admitted. +Qed. Theorem eval_shrl: binary_constructor_sound shrl Val.shrl. Proof. @@ -734,18 +712,17 @@ Proof. exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0. eapply eval_shrlimm; eauto. - (* General case *) - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. instantiate (1 := BI_standard BI_i64_sar); admit. (* reflexivity. *) reflexivity. auto. -(* Qed. *) -Admitted. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. reflexivity. auto. +Qed. -Theorem eval_addl: Archi.ptr64 = false -> binary_constructor_sound (addl cp) Val.addl. +Theorem eval_addl: Archi.ptr64 = false -> binary_constructor_sound addl Val.addl. Proof. unfold addl; red; intros. - set (default := Ebuiltin (EF_builtin cp (standard_builtin_name "__builtin_addl" cp) sig_ll_l) (a ::: b ::: Enil)). + set (default := Ebuiltin (EF_builtin "__builtin_addl" sig_ll_l) (a ::: b ::: Enil)). assert (DEFAULT: exists v, eval_expr ge sp e cp m le default v /\ Val.lessdef (Val.addl x y) v). { - econstructor; split. eapply eval_builtin_2; eauto. instantiate (1 := BI_standard BI_addl); admit. (* reflexivity. *) reflexivity. auto. + econstructor; split. eapply eval_builtin_2; eauto. reflexivity. reflexivity. auto. } destruct (is_longconst a) as [p|] eqn:LC1; destruct (is_longconst b) as [q|] eqn:LC2. @@ -759,17 +736,16 @@ Proof. subst q. exploit (is_longconst_sound le b); eauto. intros EQ; subst y. exists x; split; auto. unfold Val.addl; rewrite H; destruct x; simpl; auto. rewrite Int64.add_zero; auto. - auto. -(* Qed. *) -Admitted. +Qed. -Theorem eval_subl: Archi.ptr64 = false -> binary_constructor_sound (subl cp) Val.subl. +Theorem eval_subl: Archi.ptr64 = false -> binary_constructor_sound subl Val.subl. Proof. unfold subl; red; intros. - set (default := Ebuiltin (EF_builtin cp (standard_builtin_name "__builtin_subl" cp) sig_ll_l) (a ::: b ::: Enil)). + set (default := Ebuiltin (EF_builtin "__builtin_subl" sig_ll_l) (a ::: b ::: Enil)). assert (DEFAULT: exists v, eval_expr ge sp e cp m le default v /\ Val.lessdef (Val.subl x y) v). { - econstructor; split. eapply eval_builtin_2; eauto. instantiate (1 := BI_standard BI_subl); admit. (* reflexivity. *) reflexivity. auto. + econstructor; split. eapply eval_builtin_2; eauto. reflexivity. reflexivity. auto. } destruct (is_longconst a) as [p|] eqn:LC1; destruct (is_longconst b) as [q|] eqn:LC2. @@ -784,10 +760,9 @@ Proof. subst q. exploit (is_longconst_sound le b); eauto. intros EQ; subst y. exists x; split; auto. unfold Val.subl; rewrite H; destruct x; simpl; auto. rewrite Int64.sub_zero_l; auto. - auto. -(* Qed. *) -Admitted. +Qed. -Lemma eval_mull_base: binary_constructor_sound (mull_base cp) Val.mull. +Lemma eval_mull_base: binary_constructor_sound mull_base Val.mull. Proof. unfold mull_base; red; intros. apply eval_splitlong2; auto. - intros. @@ -801,16 +776,15 @@ Proof. exploit eval_add. eexact E2. eexact E3. intros [v5 [E5 L5]]. exploit eval_add. eexact E5. eexact E4. intros [v6 [E6 L6]]. exists (Val.longofwords v6 (Val.loword p)); split. - EvalOp. eapply eval_builtin_2; eauto. instantiate (1 := BI_standard BI_mull); admit. (* reflexivity. *) reflexivity. + EvalOp. eapply eval_builtin_2; eauto. reflexivity. reflexivity. intros. unfold le1, p in *; subst; simpl in *. inv L3. inv L4. inv L5. simpl in L6. inv L6. simpl. f_equal. symmetry. apply Int64.decompose_mul. - destruct x; auto; destruct y; auto. -(* Qed. *) -Admitted. +Qed. Lemma eval_mullimm: - forall n, unary_constructor_sound (mullimm cp n) (fun v => Val.mull v (Vlong n)). + forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). Proof. unfold mullimm; red; intros. predSpec Int64.eq Int64.eq_spec n Int64.zero. @@ -829,7 +803,7 @@ Proof. apply eval_mull_base; auto. apply eval_longconst. Qed. -Theorem eval_mull: binary_constructor_sound (mull cp) Val.mull. +Theorem eval_mull: binary_constructor_sound mull Val.mull. Proof. unfold mull; red; intros. destruct (is_longconst a) as [p|] eqn:LC1; @@ -850,24 +824,22 @@ Theorem eval_mullhu: forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)). Proof. unfold mullhu; intros; red; intros. econstructor; split; eauto. - eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper. instantiate (1 := BI_standard BI_i64_umulh); admit. (* reflexivity. *) reflexivity. -(* Qed. *) -Admitted. + eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper. reflexivity. reflexivity. +Qed. Theorem eval_mullhs: forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)). Proof. unfold mullhs; intros; red; intros. econstructor; split; eauto. - eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper. instantiate (1 := BI_standard BI_i64_smulh); admit. (* reflexivity. *) reflexivity. -(* Qed. *) -Admitted. + eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper. reflexivity. reflexivity. +Qed. Theorem eval_shrxlimm: forall le a n x z, Archi.ptr64 = false -> eval_expr ge sp e cp m le a x -> Val.shrxl x (Vint n) = Some z -> - exists v, eval_expr ge sp e cp m le (shrxlimm cp a n) v /\ Val.lessdef z v. + exists v, eval_expr ge sp e cp m le (shrxlimm a n) v /\ Val.lessdef z v. Proof. intros. apply Val.shrxl_shrl_2 in H1. unfold shrxlimm. @@ -901,9 +873,8 @@ Theorem eval_divlu_base: exists v, eval_expr ge sp e cp m le (divlu_base a b) v /\ Val.lessdef z v. Proof. intros; unfold divlu_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. instantiate (1 := BI_standard BI_i64_udiv); admit. (* reflexivity. *) eassumption. auto. -(* Qed. *) -Admitted. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto. +Qed. Theorem eval_modlu_base: forall le a b x y z, @@ -913,9 +884,8 @@ Theorem eval_modlu_base: exists v, eval_expr ge sp e cp m le (modlu_base a b) v /\ Val.lessdef z v. Proof. intros; unfold modlu_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. instantiate (1 := BI_standard BI_i64_umod); admit. (* reflexivity. *) eassumption. auto. -(* Qed. *) -Admitted. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto. +Qed. Theorem eval_divls_base: forall le a b x y z, @@ -925,9 +895,8 @@ Theorem eval_divls_base: exists v, eval_expr ge sp e cp m le (divls_base a b) v /\ Val.lessdef z v. Proof. intros; unfold divls_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. instantiate (1 := BI_standard BI_i64_sdiv); admit. (* reflexivity. *) eassumption. auto. -(* Qed. *) -Admitted. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto. +Qed. Theorem eval_modls_base: forall le a b x y z, @@ -937,9 +906,8 @@ Theorem eval_modls_base: exists v, eval_expr ge sp e cp m le (modls_base a b) v /\ Val.lessdef z v. Proof. intros; unfold modls_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. instantiate (1 := BI_standard BI_i64_smod); admit. (* reflexivity. *) eassumption. auto. -(* Qed. *) -Admitted. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto. +Qed. Remark decompose_cmpl_eq_zero: forall h l, diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index 805255d94e..95935a4cdb 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -1794,16 +1794,14 @@ Definition link_fundef {F: Type} {CF: has_comp F} (fd1 fd2: fundef F) := else None | Internal f, External ef targs tres cc => match ef with - | EF_external cp id sg => - if eq_compartment cp (comp_of f) then Some (Internal f) - else None + | EF_external id sg => + Some (Internal f) | _ => None end | External ef targs tres cc, Internal f => match ef with - | EF_external cp id sg => - if eq_compartment cp (comp_of f) then Some (Internal f) - else None + | EF_external id sg => + Some (Internal f) | _ => None end end. @@ -1812,7 +1810,7 @@ Inductive linkorder_fundef {F: Type} {CF: has_comp F}: fundef F -> fundef F -> P | linkorder_fundef_refl: forall fd, linkorder_fundef fd fd | linkorder_fundef_ext_int: forall f id sg targs tres cc, - linkorder_fundef (External (EF_external (comp_of f) id sg) targs tres cc) (Internal f). + linkorder_fundef (External (EF_external id sg) targs tres cc) (Internal f). Global Program Instance Linker_fundef (F: Type) {CF: has_comp F}: Linker (fundef F) := { link := link_fundef; @@ -1828,12 +1826,10 @@ Next Obligation. destruct x, y; simpl in H. + discriminate. + destruct e; try easy. - destruct eq_compartment; try easy. - subst cp. inv H. + inv H. split; constructor. + destruct e; try easy. - destruct eq_compartment; try easy. - subst cp. inv H. + inv H. split; constructor. + destruct (external_function_eq e e0 && typelist_eq t t1 && type_eq t0 t2 && calling_convention_eq c c0) eqn:A; inv H. InvBooleans. subst. split; constructor. @@ -1844,11 +1840,9 @@ Remark link_fundef_either: Proof. simpl; intros. unfold link_fundef in H. destruct f1, f2; try discriminate. - destruct e; try easy. - destruct eq_compartment; try easy. - subst cp. inv H; eauto. + inv H; eauto. - destruct e; try easy. - destruct eq_compartment; try easy. - subst cp. inv H; eauto. + inv H; eauto. - destruct (external_function_eq e e0 && typelist_eq t t1 && type_eq t0 t2 && calling_convention_eq c c0); inv H; auto. Qed. diff --git a/common/AST.v b/common/AST.v index ad0d4f0568..9b047f080c 100644 --- a/common/AST.v +++ b/common/AST.v @@ -833,8 +833,8 @@ Inductive external_function : Type := Unlike [EF_annot], produces no observable event. *) -(** External functions don't have compartment *) -Instance has_comp_external_function : has_comp (external_function) := fun _ => bottom. +(* (** External functions don't have compartment *) *) +(* Instance has_comp_external_function : has_comp (external_function) := fun _ => bottom. *) (** The type signature of an external function. *) @@ -899,6 +899,12 @@ Inductive fundef (F: Type): Type := | External: external_function -> fundef F. Arguments External [F]. +#[export] Instance has_comp_fundef F {CF: has_comp F}: has_comp (fundef F) := + fun fd => + match fd with + | Internal f => comp_of f + | External ef => bottom + end. Section TRANSF_FUNDEF. diff --git a/common/Events.v b/common/Events.v index 1aa2ba3735..08bf151e2e 100644 --- a/common/Events.v +++ b/common/Events.v @@ -591,8 +591,8 @@ Inductive volatile_load (ge: Senv.t) (cp: compartment): (Val.load_result chunk v) | volatile_load_nonvol: forall chunk m b ofs v, Senv.block_is_volatile ge b = false -> - forall OWN : Mem.can_access_block m b (Some cp), - Mem.load chunk m b (Ptrofs.unsigned ofs) (Some cp) = Some v -> + forall OWN : Mem.can_access_block m b cp, + Mem.load chunk m b (Ptrofs.unsigned ofs) cp = Some v -> volatile_load ge cp chunk m b ofs E0 v. Inductive volatile_store (ge: Senv.t) (cp: compartment): @@ -606,7 +606,7 @@ Inductive volatile_store (ge: Senv.t) (cp: compartment): m | volatile_store_nonvol: forall chunk m b ofs v m', Senv.block_is_volatile ge b = false -> - forall OWN : Mem.can_access_block m b (Some cp), + forall OWN : Mem.can_access_block m b cp, Mem.store chunk m b (Ptrofs.unsigned ofs) v cp = Some m' -> volatile_store ge cp chunk m b ofs v E0 m'. @@ -657,7 +657,7 @@ Definition loc_out_of_reach (f: meminj) (m: mem) (b: block) (ofs: Z): Prop := f b0 = Some(b, delta) -> ~Mem.perm m b0 (ofs - delta) Max Nonempty. Definition loc_not_in_compartment (cp: compartment) (m: mem) (b: block) (ofs: Z): Prop := - Mem.block_compartment m b <> Some cp. + Mem.block_compartment m b <> cp. Definition inject_separated (f f': meminj) (m1 m2: mem): Prop := forall b1 b2 delta, @@ -709,24 +709,25 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : forall ge vargs m1 t vres m2 b ofs n bytes ocp, sem ge cp vargs m1 t vres m2 -> Mem.valid_block m1 b -> + Mem.can_access_block m1 b ocp -> Mem.loadbytes m2 b ofs n ocp = Some bytes -> (forall i, ofs <= i < ofs + n -> ~Mem.perm m1 b i Max Writable) -> Mem.loadbytes m1 b ofs n ocp = Some bytes; -(** External call can only allocate in the calling compartment *) - ec_new_valid: - forall ge vargs m1 t vres m2 b, - sem ge cp vargs m1 t vres m2 -> - ~ Mem.valid_block m1 b -> - Mem.valid_block m2 b -> - Mem.block_compartment m2 b = Some cp; - -(** TODO: External call should not be able to modify other compartment's memory *) -(** TODO: Is this an acceptable axiom? *) - ec_mem_outside_compartment: - forall ge vargs m1 t vres m2, - sem ge cp vargs m1 t vres m2 -> - Mem.unchanged_on (loc_not_in_compartment cp m1) m1 m2; +(* (** External call can only allocate in the calling compartment *) *) +(* ec_new_valid: *) +(* forall ge vargs m1 t vres m2 b, *) +(* sem ge cp vargs m1 t vres m2 -> *) +(* ~ Mem.valid_block m1 b -> *) +(* Mem.valid_block m2 b -> *) +(* Mem.block_compartment m2 b = cp; *) + +(* (** TODO: External call should not be able to modify other compartment's memory *) *) +(* (** TODO: Is this an acceptable axiom? *) *) +(* ec_mem_outside_compartment: *) +(* forall ge vargs m1 t vres m2, *) +(* sem ge cp vargs m1 t vres m2 -> *) +(* Mem.unchanged_on (loc_not_in_compartment cp m1) m1 m2; *) (** External calls must commute with memory extensions, in the following sense. *) @@ -756,12 +757,13 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : /\ 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' /\ - (* TODO: is this a redundancy with [ec_new_valid]? *) - (forall b, - ~ Mem.valid_block m1 b -> - Mem.valid_block m2 b -> - exists b', f' b = Some (b', 0) /\ Mem.block_compartment m2 b = Some cp); + /\ inject_separated f f' m1 m1'; + (* /\ *) + (* (* TODO: is this a redundancy with [ec_new_valid]? *) *) + (* (forall b, *) + (* ~ Mem.valid_block m1 b -> *) + (* Mem.valid_block m2 b -> *) + (* exists b', f' b = Some (b', 0) /\ Mem.block_compartment m2 b = cp); *) (** External calls produce at most one event. *) @@ -821,7 +823,7 @@ Proof. econstructor; split; eauto. econstructor; eauto. exploit Mem.load_extends; eauto. intros [v' [A B]]. exists v'; split; auto. econstructor; eauto. Local Transparent Mem.load. - unfold Mem.load in A. destruct (Mem.valid_access_dec m' chunk b (Ptrofs.unsigned ofs) Readable (Some cp)); try discriminate. + unfold Mem.load in A. destruct (Mem.valid_access_dec m' chunk b (Ptrofs.unsigned ofs) Readable cp); try discriminate. Local Opaque Mem.load. inv v0. intuition. Qed. @@ -849,7 +851,7 @@ Proof. econstructor; eauto. inv VI. erewrite D; eauto. Local Transparent Mem.load. - unfold Mem.load in X. destruct (Mem.valid_access_dec m' chunk b' (Ptrofs.unsigned ofs') Readable (Some cp)); try discriminate. + unfold Mem.load in X. destruct (Mem.valid_access_dec m' chunk b' (Ptrofs.unsigned ofs') Readable cp); try discriminate. Local Opaque Mem.load. inv v0. intuition. Qed. @@ -884,10 +886,10 @@ Proof. - inv H; auto. (* readonly *) - inv H; auto. -(* mem alloc *) -- inv H; congruence. -(* outside cp *) -- inv H; apply Mem.unchanged_on_refl. +(* (* mem alloc *) *) +(* - inv H; congruence. *) +(* (* outside cp *) *) +(* - inv H; apply Mem.unchanged_on_refl. *) (* mem extends *) - inv H. inv H1. inv H6. inv H4. exploit volatile_load_extends; eauto. intros [v' [A B]]. @@ -942,15 +944,14 @@ Lemma unchanged_on_readonly: forall m1 m2 b ofs n cp bytes, Mem.unchanged_on (loc_not_writable m1) m1 m2 -> Mem.valid_block m1 b -> + Mem.can_access_block m1 b cp -> Mem.loadbytes m2 b ofs n cp = Some bytes -> (forall i, ofs <= i < ofs + n -> ~Mem.perm m1 b i Max Writable) -> Mem.loadbytes m1 b ofs n cp = Some bytes. Proof. intros. - rewrite <- H1. symmetry. + rewrite <- H2. symmetry. apply Mem.loadbytes_unchanged_on_1 with (P := loc_not_writable m1); auto. - eapply Mem.unchanged_on_own; eauto. - eapply Mem.loadbytes_can_access_block_inj ; eauto. Qed. Lemma volatile_store_readonly: @@ -1061,12 +1062,14 @@ Proof. - inv H. inv H2. auto. eauto with mem. (* readonly *) - inv H. eapply unchanged_on_readonly; eauto. eapply volatile_store_readonly; eauto. -(* mem alloc *) -- inv H. inv H2. congruence. - exploit Mem.store_valid_block_2; eauto. congruence. -(* outside cp *) -- inv H. inv H0. apply Mem.unchanged_on_refl. - eapply Mem.store_unchanged_on; eauto. + +(* (* mem alloc *) *) +(* - inv H. inv H2. congruence. *) +(* exploit Mem.store_valid_block_2; eauto. congruence. *) +(* (* outside cp *) *) +(* - inv H. inv H0. apply Mem.unchanged_on_refl. *) +(* eapply Mem.store_unchanged_on; eauto. *) + (* mem extends*) - inv H. inv H1. inv H6. inv H7. inv H4. exploit volatile_store_extends; eauto. intros [m2' [A [B C]]]. @@ -1075,7 +1078,7 @@ Proof. - inv H0. inv H2. inv H7. inv H8. inversion H5; subst. exploit volatile_store_inject; eauto. intros [m2' [A [B [C D]]]]. exists f; exists Vundef; exists m2'; intuition. constructor; auto. red; intros; congruence. - inv H3. congruence. eapply Mem.store_valid_block_2 in H2; eauto. congruence. + (* inv H3. congruence. eapply Mem.store_valid_block_2 in H2; eauto. congruence. *) (* trace length *) - inv H; inv H0; simpl; lia. (* receptive *) @@ -1136,17 +1139,18 @@ Proof. rewrite dec_eq_false. auto. apply Mem.valid_not_valid_diff with m1; eauto with mem. (* readonly *) -- inv H. eapply unchanged_on_readonly; eauto. -(* mem alloc *) -- inv H. - destruct (eq_block b0 b). - subst b0. - { erewrite Mem.store_block_compartment; eauto. - erewrite Mem.alloc_block_compartment; eauto. rewrite peq_true. eauto. } - exploit Mem.store_valid_block_2; eauto. intros ?. - exploit Mem.valid_block_alloc_inv; eauto. intros [|]; congruence. -(* outside cp *) -- inv H. eapply UNCHANGED; eauto. +- inv H. eapply unchanged_on_readonly; eauto. + +(* (* mem alloc *) *) +(* - inv H. *) +(* destruct (eq_block b0 b). *) +(* subst b0. *) +(* { erewrite Mem.store_block_compartment; eauto. *) +(* erewrite Mem.alloc_block_compartment; eauto. rewrite peq_true. eauto. } *) +(* exploit Mem.store_valid_block_2; eauto. intros ?. *) +(* exploit Mem.valid_block_alloc_inv; eauto. intros [|]; congruence. *) +(* (* outside cp *) *) +(* - inv H. eapply UNCHANGED; eauto. *) (* mem extends *) - inv H. inv H1. inv H7. assert (SZ: v2 = Vptrofs sz). @@ -1177,12 +1181,12 @@ Proof. red; intros. destruct (eq_block b1 b). subst b1. rewrite C in H2. inv H2. eauto with mem. rewrite D in H2 by auto. congruence. - destruct (eq_block b0 b); subst. - { erewrite Mem.store_block_compartment; eauto. - erewrite Mem.alloc_block_compartment; eauto. rewrite peq_true. eauto. } - eapply Mem.store_valid_block_2 in H2; eauto. - clear ALLOC. - exploit Mem.valid_block_alloc_inv; eauto. intros [ | ]; congruence. + (* destruct (eq_block b0 b); subst. *) + (* { erewrite Mem.store_block_compartment; eauto. *) + (* erewrite Mem.alloc_block_compartment; eauto. rewrite peq_true. eauto. } *) + (* eapply Mem.store_valid_block_2 in H2; eauto. *) + (* clear ALLOC. *) + (* exploit Mem.valid_block_alloc_inv; eauto. intros [ | ]; congruence. *) (* trace length *) - inv H; simpl; lia. (* receptive *) @@ -1208,7 +1212,7 @@ Qed. Inductive extcall_free_sem (ge: Senv.t) (cp: compartment): list val -> mem -> trace -> val -> mem -> Prop := | extcall_free_sem_ptr: forall b lo sz m m', - Mem.load Mptr m b (Ptrofs.unsigned lo - size_chunk Mptr) (Some cp) = Some (Vptrofs sz) -> + Mem.load Mptr m b (Ptrofs.unsigned lo - size_chunk Mptr) cp = Some (Vptrofs sz) -> Ptrofs.unsigned sz > 0 -> Mem.free m b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz) cp = Some m' -> extcall_free_sem ge cp (Vptr b lo :: nil) m E0 Vundef m' @@ -1235,18 +1239,18 @@ Proof. (* readonly *) - eapply unchanged_on_readonly; eauto. inv H. + eapply Mem.free_unchanged_on; eauto. - intros. red; intros. elim H6. + intros. red; intros. elim H7. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.free_range_perm; eauto. + apply Mem.unchanged_on_refl. -(* mem alloc *) -- inv H; try congruence. - exploit Mem.valid_block_free_2; eauto. congruence. -(* outside cp *) -- inv H. - eapply Mem.free_unchanged_on; eauto. intros. unfold loc_not_in_compartment. - exploit Mem.free_can_access_block_1; eauto. - eapply Mem.unchanged_on_refl. +(* (* mem alloc *) *) +(* - inv H; try congruence. *) +(* exploit Mem.valid_block_free_2; eauto. congruence. *) +(* (* outside cp *) *) +(* - inv H. *) +(* eapply Mem.free_unchanged_on; eauto. intros. unfold loc_not_in_compartment. *) +(* exploit Mem.free_can_access_block_1; eauto. *) +(* eapply Mem.unchanged_on_refl. *) (* mem extends *) - inv H. + inv H1. inv H8. inv H6. @@ -1339,7 +1343,7 @@ Inductive extcall_memcpy_sem (sz al: Z) (ge: Senv.t) (cp: compartment): 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 cp) = Some bytes -> + Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz cp = Some bytes -> Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes cp = Some m' -> extcall_memcpy_sem sz al ge cp (Vptr bdst odst :: Vptr bsrc osrc :: nil) m E0 Vundef m'. @@ -1362,16 +1366,16 @@ Proof. - (* readonly *) intros. inv H. eapply unchanged_on_readonly; eauto. eapply Mem.storebytes_unchanged_on; eauto. - intros; red; intros. elim H11. + intros; red; intros. elim H12. apply Mem.perm_cur_max. eapply Mem.storebytes_range_perm; eauto. -- (* new blocks *) - intros. - inv H. - exploit Mem.storebytes_valid_block_2; eauto. congruence. -(* outside cp *) -- intros. inv H. - eapply Mem.storebytes_unchanged_on; eauto. intros. unfold loc_not_in_compartment. - exploit Mem.storebytes_can_access_block_1; eauto. +(* - (* new blocks *) *) +(* intros. *) +(* inv H. *) +(* exploit Mem.storebytes_valid_block_2; eauto. congruence. *) +(* (* outside cp *) *) +(* - intros. inv H. *) +(* eapply Mem.storebytes_unchanged_on; eauto. intros. unfold loc_not_in_compartment. *) +(* exploit Mem.storebytes_can_access_block_1; eauto. *) - (* extensions *) intros. inv H. inv H1. inv H13. inv H14. inv H10. inv H11. @@ -1393,7 +1397,7 @@ Proof. destruct (zeq sz 0). + (* special case sz = 0 *) assert (bytes = nil). - { exploit (Mem.loadbytes_empty m1 bsrc (Ptrofs.unsigned osrc) sz (Some cp)). lia. + { exploit (Mem.loadbytes_empty m1 bsrc (Ptrofs.unsigned osrc) sz cp). lia. eapply Mem.loadbytes_can_access_block_inj; eauto. congruence. } subst. @@ -1500,11 +1504,11 @@ Proof. - inv H; auto. (* readonly *) - inv H; auto. -(* mem alloc *) -- inv H. congruence. -(* outside cp *) -- intros. inv H. - eapply Mem.unchanged_on_refl. +(* (* mem alloc *) *) +(* - inv H. congruence. *) +(* (* outside cp *) *) +(* - intros. inv H. *) +(* eapply Mem.unchanged_on_refl. *) (* mem extends *) - inv H. exists Vundef; exists m1'; intuition. @@ -1554,11 +1558,11 @@ Proof. - inv H; auto. (* readonly *) - inv H; auto. -(* mem alloc *) -- inv H; congruence. -(* outside cp *) -- intros. inv H. - eapply Mem.unchanged_on_refl. +(* (* mem alloc *) *) +(* - inv H; congruence. *) +(* (* outside cp *) *) +(* - intros. inv H. *) +(* eapply Mem.unchanged_on_refl. *) (* mem extends *) - inv H. inv H1. inv H6. exists v2; exists m1'; intuition. @@ -1606,11 +1610,11 @@ Proof. - inv H; auto. (* readonly *) - inv H; auto. -(* mem alloc *) -- inv H; congruence. -(* outside cp *) -- intros. inv H. - eapply Mem.unchanged_on_refl. +(* (* mem alloc *) *) +(* - inv H; congruence. *) +(* (* outside cp *) *) +(* - intros. inv H. *) +(* eapply Mem.unchanged_on_refl. *) (* mem extends *) - inv H. exists Vundef; exists m1'; intuition. @@ -1666,11 +1670,11 @@ Proof. - inv H; auto. (* readonly *) - inv H; auto. -(* mem alloc *) -- inv H; congruence. -(* outside cp *) -- intros. inv H. - eapply Mem.unchanged_on_refl. +(* (* mem alloc *) *) +(* - inv H; congruence. *) +(* (* outside cp *) *) +(* - intros. inv H. *) +(* eapply Mem.unchanged_on_refl. *) (* mem extends *) - inv H. fold bsem in H2. apply val_inject_list_lessdef in H1. specialize (bs_inject _ bsem _ _ _ H1). @@ -1886,11 +1890,11 @@ Lemma external_call_mem_inject: /\ 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' - /\ (forall b : block, - ~ Mem.valid_block m1 b -> - Mem.valid_block m2 b -> - exists b' : block, f' b = Some (b', 0) /\ Mem.block_compartment m2 b = Some cp). + /\ inject_separated f f' m1 m1'. + (* /\ (forall b : block, *) + (* ~ Mem.valid_block m1 b -> *) + (* Mem.valid_block m2 b -> *) + (* exists b' : block, f' b = Some (b', 0) /\ Mem.block_compartment m2 b = cp). *) Proof. intros. destruct H as (A & B & C). eapply external_call_mem_inject_gen with (ge1 := ge); eauto. repeat split; intros. @@ -2094,7 +2098,7 @@ Lemma call_trace_same_cp: t = E0. Proof. intros. inv H; auto. - now apply Genv.type_of_call_same_cp in H0. + now rewrite Genv.type_of_call_same_cp in H0. Qed. Inductive return_trace: compartment -> compartment -> val -> rettype -> trace -> Prop := diff --git a/common/Exec.v b/common/Exec.v index 6cf75f68ca..54dfba62e9 100644 --- a/common/Exec.v +++ b/common/Exec.v @@ -173,7 +173,7 @@ Lemma get_call_trace_eq: Proof. intros. split. - intros H. unfold get_call_trace. - inv H; simpl. destruct (Genv.type_of_call cp cp'); try congruence. + inv H. destruct (Genv.type_of_call cp cp'); try congruence. erewrite H0, H2, list_eventval_of_val_complete; eauto. - unfold get_call_trace. intros H. @@ -203,7 +203,7 @@ Lemma get_return_trace_eq: Proof. intros. split. - intros H. unfold get_return_trace. - inv H; simpl. destruct (Genv.type_of_call cp cp'); try congruence. + inv H. destruct (Genv.type_of_call cp cp'); try congruence. rewrite H0. rewrite (eventval_of_val_complete res); auto. - unfold get_return_trace. intros H. @@ -229,7 +229,7 @@ Definition do_volatile_load (w: world) (chunk: memory_chunk) (cp: compartment) ( Some(w', Event_vload chunk id ofs res :: nil, Val.load_result chunk vres) end else - do v <- Mem.load chunk m b (Ptrofs.unsigned ofs) (Some cp); + do v <- Mem.load chunk m b (Ptrofs.unsigned ofs) cp; Some(w, E0, v). Definition do_volatile_store (w: world) (chunk: memory_chunk) (cp: compartment) (m: mem) (b: block) (ofs: ptrofs) (v: val) @@ -261,7 +261,8 @@ Proof. Qed. Lemma do_volatile_load_complete: - forall w chunk cp m b ofs w' t v, + forall w chunk cp m b ofs w' t v +, volatile_load ge cp chunk m b ofs t v -> possible_trace w t w' -> do_volatile_load w chunk cp m b ofs = Some(w', t, v). Proof. @@ -372,7 +373,7 @@ Definition do_ef_free (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match vargs with | Vptr b lo :: nil => - do vsz <- Mem.load Mptr m b (Ptrofs.unsigned lo - size_chunk Mptr) (Some cp); + do vsz <- Mem.load Mptr m b (Ptrofs.unsigned lo - size_chunk Mptr) cp; do sz <- do_alloc_size vsz; check (zlt 0 (Ptrofs.unsigned sz)); do m' <- Mem.free m b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz) cp; @@ -401,7 +402,7 @@ Definition do_ef_memcpy (sz al: Z) match vargs with | Vptr bdst odst :: Vptr bsrc osrc :: nil => if decide (memcpy_args_ok sz al bdst (Ptrofs.unsigned odst) bsrc (Ptrofs.unsigned osrc)) then - do bytes <- Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz (Some cp); + do bytes <- Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz cp; do m' <- Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes cp; Some(w, E0, Vundef, m') else None diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 7e55534231..17dd23a331 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -2028,10 +2028,13 @@ Variant call_type := | InternalCall | CrossCompartmentCall. +(* A call is internal if the callee has strictly less privilege than the caller *) Definition type_of_call (cp: compartment) (cp': compartment): call_type := - if flowsto_dec cp cp' then InternalCall + if flowsto_dec cp' cp then InternalCall else CrossCompartmentCall. +#[global] Arguments type_of_call /. + (* Lemma type_of_call_cp_default: *) (* forall ge cp, type_of_call ge cp default_compartment <> CrossCompartmentCall. *) (* Proof. *) @@ -2445,6 +2448,7 @@ Proof. eapply CompTree.beq_sound with (x := cp) in EQPOL2. (* rewrite PTree.beq_correct in EQPOL2. *) (* specialize (EQPOL2 cp). *) + simpl in *. destruct (CompTree.get cp (Policy.policy_import prog_pol0)); destruct (CompTree.get cp (Policy.policy_import prog_pol)); auto. destruct (Policy.list_cpt_id_eq l l0); subst; simpl in *; auto; try discriminate. contradiction. @@ -2457,20 +2461,16 @@ Proof. rewrite genv_pol_add_globals in H2. unfold Policy.eqb in EQPOL. apply andb_prop in EQPOL. destruct EQPOL as [EQPOL1 EQPOL2]. + set (cp := find_comp_of_block (add_globals (empty_genv F1 V1 prog_pol_pub) prog_defs) b). + fold cp in H2. + eapply CompTree.beq_sound with (x := cp) in EQPOL1. + eapply CompTree.beq_sound with (x := cp) in EQPOL2. + (* rewrite PTree.beq_correct in EQPOL2. *) + (* specialize (EQPOL2 cp). *) simpl in *. - rewrite PTree.beq_correct in EQPOL1. - specialize (EQPOL1 cp'). - destruct ((Policy.policy_export prog_pol0) ! cp'); - destruct ((Policy.policy_export prog_pol) ! cp'); auto; try contradiction. - destruct (Policy.list_id_eq l l0); subst; simpl in *; auto; try discriminate. -Qed. - -(* FIXME: This lemma should not be needed. *) -Lemma match_genvs_type_of_call: - forall cp cp', - type_of_call cp cp' = type_of_call cp cp'. -Proof. - intros. reflexivity. + destruct (CompTree.get cp (Policy.policy_export prog_pol0)); + destruct (CompTree.get cp (Policy.policy_export prog_pol)); auto. + destruct (Policy.list_id_eq l l0); subst; simpl in *; auto; try discriminate. contradiction. Qed. Lemma match_genvs_not_ptr_inj: @@ -2599,7 +2599,7 @@ Lemma find_comp_transf_partial: forall v, find_comp_in_genv (globalenv p) v = find_comp_in_genv (globalenv tp) v. Proof. - unfold find_comp. intros v. case v; try easy. + unfold find_comp_in_genv. intros v. case v; try easy. intros b _. apply find_comp_of_block_transf_partial. Qed. @@ -2629,13 +2629,6 @@ Proof. eapply (match_genvs_allowed_calls progmatch). Qed. -Theorem type_of_call_transf_partial: - forall cp cp', - type_of_call cp cp' = type_of_call cp cp'. -Proof. - eapply (match_genvs_type_of_call). -Qed. - Lemma not_ptr_transf_partial_inj: forall j cp cp' v v', Val.inject j v v' -> @@ -2769,13 +2762,6 @@ Proof. intros b _. apply find_comp_of_block_transf. Qed. -Theorem type_of_call_transf: - forall cp cp', - type_of_call cp cp' = type_of_call cp cp'. -Proof. - eapply (match_genvs_type_of_call). -Qed. - Lemma not_ptr_transf_inj: forall j cp cp' v v', Val.inject j v v' -> diff --git a/common/Memory.v b/common/Memory.v index 40671b9f5e..fac31447a0 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -1421,19 +1421,30 @@ Proof. inv STORE. easy. Qed. -Remark store_can_access_block_inj : - forall b' cp', - can_access_block m1 b' cp' <-> can_access_block m2 b' cp'. +Remark store_preserves_comp : + forall b', + block_compartment m1 b' = block_compartment m2 b'. Proof. - split; intros; - destruct (can_access_block_dec m1 b' cp'); - destruct (can_access_block_dec m2 b' cp'); - try contradiction; try assumption; + intros; (unfold store in STORE; destruct (valid_access_dec m1 chunk b ofs Writable cp); inv STORE; now auto). Qed. +Remark store_can_access_block_inj : + forall b' cp', + can_access_block m1 b' cp' <-> can_access_block m2 b' cp'. +Proof. + intros b' cp'; simpl. rewrite store_preserves_comp; intuition. +Qed. + + +Lemma store_can_access_block_inj_1 : + forall b' cp', can_access_block m1 b' cp' -> can_access_block m2 b' cp'. +Proof. + simpl; intros; rewrite <- store_preserves_comp; eauto. +Qed. + Theorem loadbytes_store_other: forall b' ofs' n cp', b' <> b @@ -1456,9 +1467,9 @@ Proof. apply getN_setN_outside. rewrite encode_val_length. rewrite <- size_chunk_conv. rewrite Z2Nat.id. auto. lia. auto. - apply store_can_access_block_inj; auto. + simpl; rewrite <- store_preserves_comp; auto. * setoid_rewrite pred_dec_false; auto. - intro Hcontra. apply store_can_access_block_inj in Hcontra. contradiction. + simpl; rewrite <- store_preserves_comp; auto. + red; intros. eauto with mem. - setoid_rewrite pred_dec_false at 1. + auto. @@ -1794,6 +1805,15 @@ Proof. assumption. Qed. +Lemma storebytes_preserves_comp: + forall b', block_compartment m1 b' = block_compartment m2 b'. +Proof. + unfold storebytes in *. intros b'. + destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (Datatypes.length bytes)) Cur Writable); + destruct (can_access_block_dec m1 b cp); + inv STORE; simpl in *. reflexivity. +Qed. + (* RB: NOTE: Names and split adapted from storebytes_valid_block_1 and _2 below, similar auxiliary results could follow the same pattern (with preservation suffix, see lemmas above). *) @@ -2252,6 +2272,15 @@ Qed. (* now rewrite alloc_result, block_compartment_nextblock in Hown. *) (* Qed. *) +Lemma alloc_lowers_comp: + forall b', block_compartment m2 b' ⊆ block_compartment m1 b'. +Proof. + intros b'. + rewrite alloc_block_compartment. + destruct eq_block as [->|neq]; auto with comps. + rewrite alloc_result, block_compartment_nextblock; auto with comps. +Qed. + Lemma alloc_can_access_block_other_inj_1 : forall b' c', can_access_block m1 b' c' -> can_access_block m2 b' c'. Proof. @@ -2534,6 +2563,17 @@ Proof. unfold unchecked_free; destruct (zle hi lo); assumption. Qed. +Lemma free_preserves_comp: + forall b, block_compartment m1 b = block_compartment m2 b. +Proof. + intros b. + unfold free in FREE. + destruct (range_perm_dec m1 bf lo hi Cur Freeable); [| simpl in FREE; congruence]. + destruct (can_access_block_dec m1 bf cp); [| simpl in FREE; congruence]. + inv FREE. + unfold unchecked_free; destruct (zle hi lo); auto. +Qed. + Lemma free_can_access_block_inj_1 : forall b cp', can_access_block m1 b cp' -> can_access_block m2 b cp'. Proof. @@ -2799,6 +2839,16 @@ Proof. auto. auto. auto. Qed. +Lemma drop_preserves_comp: + forall b', block_compartment m b' = block_compartment m' b'. +Proof. + intros b'. + unfold drop_perm in DROP. + destruct (range_perm_dec m b lo hi Cur Freeable); [| now inversion DROP]. + destruct (can_access_block_dec m b cp); [| now inversion DROP]. + inv DROP. reflexivity. +Qed. + Theorem can_access_block_drop_1: forall b' cp', can_access_block m b' cp' -> can_access_block m' b' cp'. Proof. @@ -3108,10 +3158,9 @@ Proof. eapply perm_store_2; eauto. (* own *) intros. - apply (proj1 (store_can_access_block_inj _ _ _ _ _ _ _ STORE _ _)). + simpl. rewrite <- (store_preserves_comp _ _ _ _ _ _ _ STORE); eauto. eapply mi_own; try eassumption. - apply (proj2 (store_can_access_block_inj _ _ _ _ _ _ _ H0 _ _)). - assumption. + simpl. erewrite (store_preserves_comp _ _ _ _ _ _ _ H0); eauto. (* align *) intros. eapply mi_align with (ofs := ofs0) (p := p); eauto. red; intros; eauto with mem. @@ -3153,8 +3202,7 @@ Proof. (* own *) intros. eapply mi_own; eauto. (* RB: NOTE: Should be solvable by properly extended hint databases. *) - apply (proj2 (store_can_access_block_inj _ _ _ _ _ _ _ H0 _ _)). - assumption. + simpl. erewrite store_preserves_comp; eauto. (* align *) intros. eapply mi_align with (ofs := ofs0) (p := p); eauto. red; intros; eauto with mem. @@ -3181,7 +3229,8 @@ Proof. (* own *) intros. (* RB: NOTE: Ditto re: hint databases. *) - apply (proj1 (store_can_access_block_inj _ _ _ _ _ _ _ H1 _ _)); eauto. + simpl; rewrite <- (store_preserves_comp _ _ _ _ _ _ _ H1); eauto. + eapply mi_own0; eauto. (* access *) intros; eapply mi_align0; eauto. (* mem_contents *) @@ -3253,7 +3302,6 @@ Proof. rewrite (list_forall2_length H3). lia. eauto 6 with mem. destruct H9. congruence. lia. - (* block <> b1, block <> b2 *) eauto. Qed. @@ -5132,15 +5180,16 @@ Record unchanged_on (m_before m_after: mem) : Prop := mk_unchanged_on { ZMap.get ofs (PMap.get b m_after.(mem_contents)) = ZMap.get ofs (PMap.get b m_before.(mem_contents)); unchanged_on_own: - forall b cp, + forall b, + block_compartment m_after b ⊆ block_compartment m_before b (* valid_block m_before b -> (* Adjust preconditions as needed. *) *) - (can_access_block m_before b cp -> can_access_block m_after b cp) + (* (can_access_block m_before b cp -> can_access_block m_after b cp) *) }. Lemma unchanged_on_refl: forall m, unchanged_on m m. Proof. - intros; constructor. apply Ple_refl. tauto. tauto. tauto. + intros; constructor. apply Ple_refl. tauto. tauto. auto with comps. Qed. Lemma valid_block_unchanged_on: @@ -5175,7 +5224,8 @@ Proof. eapply valid_block_unchanged_on; eauto. - intros. transitivity (ZMap.get ofs (mem_contents m2)#b); apply unchanged_on_contents; auto. eapply perm_unchanged_on; eauto. -- intros. eapply unchanged_on_own; eauto. eapply unchanged_on_own; eauto. +- intros. eapply flowsto_trans; eauto using unchanged_on_own. + (* eapply unchanged_on_own; eauto. eapply unchanged_on_own; eauto. *) Qed. Lemma loadbytes_unchanged_on_1: @@ -5189,8 +5239,8 @@ Proof. intros. destruct (zle n 0). - erewrite ! loadbytes_empty; try easy. - inv H. eapply unchanged_on_own0; eauto. - (* eapply H1; eauto. lia. *) + simpl. eapply flowsto_trans; eauto using unchanged_on_own. + (* eapply unchanged_on_own0; eauto. *) - unfold loadbytes. destruct H. destruct (range_perm_dec m b ofs (ofs + n) Cur Readable). + destruct (can_access_block_dec m b cp). @@ -5198,7 +5248,8 @@ Proof. apply getN_exten. intros. rewrite Z2Nat.id in H by lia. apply unchanged_on_contents0; auto. red; intros. apply unchanged_on_perm0; auto. - apply unchanged_on_own0; auto. + simpl. eapply flowsto_trans; eauto. + (* apply unchanged_on_own0; auto. *) * contradiction. + setoid_rewrite pred_dec_false at 1. auto. red; intros; elim n0; red; intros. apply <- unchanged_on_perm0; auto. @@ -5227,7 +5278,8 @@ Proof. pose proof loadbytes_can_access_block_inj _ _ _ _ _ _ H1 as Hown. destruct (zle n 0). + erewrite loadbytes_empty in *; try assumption. - inv H. eapply unchanged_on_own0; eauto. + inv H. + simpl. eapply flowsto_trans; eauto. + rewrite <- H1. apply loadbytes_unchanged_on_1; auto. exploit loadbytes_range_perm; eauto. instantiate (1 := ofs). lia. intros. eauto with mem. @@ -5246,7 +5298,7 @@ Proof. rewrite <- size_chunk_conv in H4. eapply unchanged_on_contents; eauto. split; auto. red; intros. eapply perm_unchanged_on; eauto. split; auto. - destruct H. eapply unchanged_on_own0; eauto. + simpl; eapply flowsto_trans; eauto using unchanged_on_own. - rewrite pred_dec_false. auto. red; intros [A [B C]]; elim n; split; auto. red; intros; eapply perm_unchanged_on_2; eauto. Qed. @@ -5278,7 +5330,7 @@ Proof. destruct (zlt ofs0 ofs); auto. destruct (zlt ofs0 (ofs + size_chunk chunk)); auto. elim (H0 ofs0). lia. auto. -- rewrite <- store_can_access_block_inj; eauto. +- erewrite <- store_preserves_comp; eauto with comps. Qed. Lemma storebytes_unchanged_on: @@ -5295,7 +5347,7 @@ Proof. destruct (zlt ofs0 ofs); auto. destruct (zlt ofs0 (ofs + Z.of_nat (length bytes))); auto. elim (H0 ofs0). lia. auto. -- eapply storebytes_can_access_block_inj_1; eauto. +- erewrite <- storebytes_preserves_comp; eauto with comps. Qed. Lemma alloc_unchanged_on: @@ -5312,8 +5364,9 @@ Proof. - injection H; intros A B. rewrite <- B; simpl. rewrite PMap.gso; auto. rewrite A. eapply valid_not_valid_diff; eauto with mem. - destruct (peq b0 b). -+ subst b0. eapply unowned_fresh_block with (c' := cp) in H; subst; auto with comps. -+ eapply alloc_can_access_block_other_inj_1; eauto. ++ subst b0. eapply unowned_fresh_block with (c' := block_compartment m b) in H; try rewrite H; auto with comps. ++ eapply alloc_lowers_comp; eauto. + (* eapply alloc_can_access_block_other_inj_1; eauto. *) Qed. Lemma free_unchanged_on: @@ -5333,7 +5386,7 @@ Proof. destruct (range_perm_dec m b lo hi Cur Freeable); destruct (can_access_block_dec m b cp); inv H. unfold unchecked_free; destruct (zle hi lo); simpl; auto. -- eapply free_can_access_block_inj_1; eauto. +- erewrite <- free_preserves_comp; eauto with comps. Qed. Lemma drop_perm_unchanged_on: @@ -5354,7 +5407,7 @@ Proof. destruct (range_perm_dec m b lo hi Cur Freeable); destruct (can_access_block_dec m b cp); inv H; simpl. auto. -- eapply can_access_block_drop_1; eauto. +- erewrite <- drop_preserves_comp; eauto with comps. Qed. End UNCHANGED_ON. diff --git a/common/Separation.v b/common/Separation.v index 70919da823..7031f3dee7 100644 --- a/common/Separation.v +++ b/common/Separation.v @@ -418,8 +418,8 @@ Qed. Program Definition contains (chunk: memory_chunk) (b: block) (ofs: Z) (cp: compartment) (spec: val -> Prop) : massert := {| m_pred := fun m => 0 <= ofs <= Ptrofs.max_unsigned - /\ Mem.valid_access m chunk b ofs Freeable (Some cp) - /\ exists v, Mem.load chunk m b ofs (Some cp) = Some v /\ spec v; + /\ Mem.valid_access m chunk b ofs Freeable cp + /\ exists v, Mem.load chunk m b ofs cp = Some v /\ spec v; m_footprint := fun b' ofs' => b' = b /\ ofs <= ofs' < ofs + size_chunk chunk |}. Next Obligation. @@ -428,8 +428,8 @@ Next Obligation. - destruct H1; split; auto. red; intros; eapply Mem.perm_unchanged_on; eauto. simpl; auto. destruct H2. split. - eapply (Mem.unchanged_on_own _ _ _ H0); eauto. - eapply @Mem.can_access_block_valid_block; eauto. + simpl. + simpl; eapply flowsto_trans; eapply Mem.unchanged_on_own with (b := b) in H0; eauto. easy. - exists v. split; auto. eapply Mem.load_unchanged_on; eauto. simpl; auto. Qed. @@ -447,7 +447,7 @@ Qed. Lemma contains_valid_access: forall spec m chunk b ofs cp, m |= contains chunk b ofs cp spec -> - Mem.valid_access m chunk b ofs Freeable (Some cp). + Mem.valid_access m chunk b ofs Freeable cp. Proof. intros. destruct H as (D & E & v & F & G). assumption. @@ -456,7 +456,7 @@ Qed. Lemma load_rule: forall spec m chunk b cp ofs, m |= contains chunk b ofs cp spec -> - exists v, Mem.load chunk m b ofs (Some cp) = Some v /\ spec v. + exists v, Mem.load chunk m b ofs cp = Some v /\ spec v. Proof. intros. destruct H as (D & E & v & F & G). exists v; auto. @@ -465,7 +465,7 @@ Qed. Lemma loadv_rule: forall spec m chunk b ofs cp, m |= contains chunk b ofs cp spec -> - exists v, Mem.loadv chunk m (Vptr b (Ptrofs.repr ofs)) (Some cp) = Some v /\ spec v. + exists v, Mem.loadv chunk m (Vptr b (Ptrofs.repr ofs)) cp = Some v /\ spec v. Proof. intros. exploit load_rule; eauto. intros (v & A & B). exists v; split; auto. simpl. rewrite Ptrofs.unsigned_repr; auto. eapply contains_no_overflow; eauto. @@ -479,7 +479,7 @@ Lemma store_rule: Mem.store chunk m b ofs v cp = Some m' /\ m' |= contains chunk b ofs cp spec ** P. Proof. intros. destruct H as (A & B & C). destruct A as (D & E & v0 & F & G). - assert (H: Mem.valid_access m chunk b ofs Writable (Some cp)) by eauto with mem. + assert (H: Mem.valid_access m chunk b ofs Writable cp) by eauto with mem. destruct (Mem.valid_access_store _ _ _ _ _ v H) as [m' STORE]. exists m'; split; auto. simpl. intuition auto. - eapply Mem.store_valid_access_1; eauto. @@ -504,16 +504,16 @@ Lemma range_contains: forall chunk b ofs cp P m, m |= range b ofs (ofs + size_chunk chunk) ** P -> (align_chunk chunk | ofs) -> - forall OWN : Mem.can_access_block m b (Some cp), + forall OWN : Mem.can_access_block m b cp, m |= contains chunk b ofs cp (fun v => True) ** P. Proof. intros. destruct H as (A & B & C). destruct A as (D & E & F). split; [|split]. -- assert (Mem.valid_access m chunk b ofs Freeable (Some cp)). +- assert (Mem.valid_access m chunk b ofs Freeable cp). { split; auto. red; auto. } split. generalize (size_chunk_pos chunk). unfold Ptrofs.max_unsigned. lia. split. auto. -+ destruct (Mem.valid_access_load m chunk b ofs (Some cp)) as [v LOAD]. ++ destruct (Mem.valid_access_load m chunk b ofs cp) as [v LOAD]. eauto with mem. exists v; auto. - auto. @@ -639,7 +639,8 @@ Next Obligation. destruct H. constructor. - destruct mi_inj. constructor; intros. + eapply Mem.perm_unchanged_on; eauto. -+ eapply (Mem.unchanged_on_own _ _ _ H0); eauto. ++ eapply (Mem.unchanged_on_own) with (b := b2) in H0. + eapply flowsto_trans; eauto. eapply mi_own; eauto. + eauto. + rewrite (Mem.unchanged_on_contents _ _ _ H0); eauto. - assumption. @@ -675,7 +676,7 @@ Proof. intros. destruct H as (A & B & C). simpl in A. exploit Mem.storev_mapped_inject; eauto. intros (m2' & STORE & INJ). inv H1; simpl in STORE; try discriminate. - assert (VALID: Mem.valid_access m1 chunk b1 (Ptrofs.unsigned ofs1) Writable (Some cp)) + assert (VALID: Mem.valid_access m1 chunk b1 (Ptrofs.unsigned ofs1) Writable cp) by eauto with mem. assert (EQ: Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) = Ptrofs.unsigned ofs1 + delta). { eapply Mem.address_inject'; eauto with mem. } @@ -717,7 +718,7 @@ Proof. - eapply Mem.alloc_right_inject; eauto. - eexact ALLOC1. - instantiate (1 := b2). eauto with mem. -- eapply Mem.owned_new_block; eauto. +- eapply Mem.owned_new_block in ALLOC2; subst; simpl; auto with comps. - instantiate (1 := delta). extlia. - intros. assert (0 <= ofs < sz2) by (eapply Mem.perm_alloc_3; eauto). lia. - intros. apply Mem.perm_implies with Freeable; auto with mem. @@ -885,7 +886,7 @@ Proof. destruct SEP as (A & B & C). simpl in A. exploit external_call_mem_inject; eauto. eapply globalenv_inject_preserves_globals. eapply sep_pick1; eauto. - intros (j' & vres2 & m2' & CALL' & RES & INJ' & UNCH1 & UNCH2 & INCR & ISEP & _). + intros (j' & vres2 & m2' & CALL' & RES & INJ' & UNCH1 & UNCH2 & INCR & ISEP). assert (MAXPERMS: forall b ofs p, Mem.valid_block m1 b -> Mem.perm m1' b ofs Max p -> Mem.perm m1 b ofs Max p). { intros. eapply external_call_max_perm; eauto. } diff --git a/riscV/Machregs.v b/riscV/Machregs.v index 28c8113066..89fa37b025 100644 --- a/riscV/Machregs.v +++ b/riscV/Machregs.v @@ -192,9 +192,9 @@ Fixpoint destroyed_by_clobber (cl: list string): list mreg := Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with - | EF_inline_asm cp txt sg clob => destroyed_by_clobber clob - | EF_memcpy cp sz al => R5 :: R6 :: R7 :: F0 :: nil - | EF_builtin cp name sg => + | EF_inline_asm txt sg clob => destroyed_by_clobber clob + | EF_memcpy sz al => R5 :: R6 :: R7 :: F0 :: nil + | EF_builtin name sg => if string_dec name "__builtin_clz" || string_dec name "__builtin_clzl" || string_dec name "__builtin_clzll" then @@ -221,7 +221,7 @@ Definition mregs_for_operation (op: operation): list (option mreg) * option mreg Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := match ef with - | EF_builtin cp name sg => + | EF_builtin name sg => if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then (Some R6 :: Some R5 :: nil, Some R5 :: Some R6 :: nil) else if string_dec name "__builtin_clz" @@ -268,11 +268,11 @@ Definition two_address_op (op: operation) : bool := Definition builtin_constraints (ef: external_function) : list builtin_arg_constraint := match ef with - | EF_builtin cp id sg => nil - | EF_vload cp _ => OK_addressing :: nil - | EF_vstore cp _ => OK_addressing :: OK_default :: nil - | EF_memcpy cp _ _ => OK_addrstack :: OK_addrstack :: nil - | EF_annot cp kind txt targs => map (fun _ => OK_all) targs - | EF_debug cp kind txt targs => map (fun _ => OK_all) targs + | EF_builtin id sg => nil + | EF_vload _ => OK_addressing :: nil + | EF_vstore _ => OK_addressing :: OK_default :: nil + | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil + | EF_annot kind txt targs => map (fun _ => OK_all) targs + | EF_debug kind txt targs => map (fun _ => OK_all) targs | _ => nil end. diff --git a/riscV/SelectLong.vp b/riscV/SelectLong.vp index 674032c320..b3e07bf558 100644 --- a/riscV/SelectLong.vp +++ b/riscV/SelectLong.vp @@ -29,7 +29,6 @@ Local Open Scope string_scope. Section SELECT. Context {hf: helper_functions}. -Context (cp: compartment). Definition longconst (n: int64) : expr := if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil. @@ -75,7 +74,7 @@ Nondetfunction addlimm (n: int64) (e: expr) := end. Nondetfunction addl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.addl cp e1 e2 else + if Archi.splitlong then SplitLong.addl e1 e2 else match e1, e2 with | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2 | t1, Eop (Olongconst n2) Enil => addlimm n2 t1 @@ -95,7 +94,7 @@ Nondetfunction addl (e1: expr) (e2: expr) := (** ** Integer and pointer subtraction *) Nondetfunction subl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.subl cp e1 e2 else + if Archi.splitlong then SplitLong.subl e1 e2 else match e1, e2 with | t1, Eop (Olongconst n2) Enil => addlimm (Int64.neg n2) t1 @@ -109,7 +108,7 @@ Nondetfunction subl (e1: expr) (e2: expr) := end. Definition negl (e: expr) := - if Archi.splitlong then SplitLong.negl cp e else + if Archi.splitlong then SplitLong.negl e else match is_longconst e with | Some n => longconst (Int64.neg n) | None => Eop Onegl (e ::: Enil) @@ -204,7 +203,7 @@ Definition mullimm_base (n1: int64) (e2: expr) := end. Nondetfunction mullimm (n1: int64) (e2: expr) := - if Archi.splitlong then SplitLong.mullimm cp n1 e2 + if Archi.splitlong then SplitLong.mullimm n1 e2 else if Int64.eq n1 Int64.zero then longconst Int64.zero else if Int64.eq n1 Int64.one then e2 else match e2 with @@ -214,7 +213,7 @@ Nondetfunction mullimm (n1: int64) (e2: expr) := end. Nondetfunction mull (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.mull cp e1 e2 else + if Archi.splitlong then SplitLong.mull e1 e2 else match e1, e2 with | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2 | t1, Eop (Olongconst n2) Enil => mullimm n2 t1 @@ -303,7 +302,7 @@ Definition modls_base (e1: expr) (e2: expr) := if Archi.splitlong then SplitLong.modls_base e1 e2 else Eop Omodl (e1:::e2:::Enil). Definition shrxlimm (e: expr) (n: int) := - if Archi.splitlong then SplitLong.shrxlimm cp e n else + if Archi.splitlong then SplitLong.shrxlimm e n else if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil). (** ** Comparisons *) diff --git a/riscV/SelectLongproof.v b/riscV/SelectLongproof.v index cf03e016d7..dcb696ff8e 100644 --- a/riscV/SelectLongproof.v +++ b/riscV/SelectLongproof.v @@ -33,11 +33,11 @@ Section CMCONSTR. Variable prog: program. Variable hf: helper_functions. +Hypothesis HELPERS: helper_functions_declared prog hf. Let ge := Genv.globalenv prog. Variable sp: val. Variable e: env. Variable cp: compartment. -Hypothesis HELPERS: helper_functions_declared prog hf cp. Variable m: mem. Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := @@ -109,9 +109,9 @@ Proof. - TrivialExists. Qed. -Theorem eval_negl: unary_constructor_sound (negl cp) Val.negl. +Theorem eval_negl: unary_constructor_sound negl Val.negl. Proof. - unfold negl. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_negl; eauto. + unfold negl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_negl; auto. red; intros. destruct (is_longconst a) as [n|] eqn:C. - exploit is_longconst_sound; eauto. intros EQ; subst x. econstructor; split. apply eval_longconst. auto. @@ -137,10 +137,10 @@ Proof. - TrivialExists. Qed. -Theorem eval_addl: binary_constructor_sound (addl cp) Val.addl. +Theorem eval_addl: binary_constructor_sound addl Val.addl. Proof. unfold addl. destruct Archi.splitlong eqn:SL. - eapply SplitLongproof.eval_addl; auto. eapply Archi.splitlong_ptr32; eauto. + apply SplitLongproof.eval_addl. apply Archi.splitlong_ptr32; auto. (* assert (SF: Archi.ptr64 = true). { Local Transparent Archi.splitlong. unfold Archi.splitlong in SL. @@ -192,10 +192,10 @@ Proof. - TrivialExists. Qed. -Theorem eval_subl: binary_constructor_sound (subl cp) Val.subl. +Theorem eval_subl: binary_constructor_sound subl Val.subl. Proof. unfold subl. destruct Archi.splitlong eqn:SL. - eapply SplitLongproof.eval_subl; auto. apply Archi.splitlong_ptr32; auto. + apply SplitLongproof.eval_subl. apply Archi.splitlong_ptr32; auto. red; intros; destruct (subl_match a b); InvEval. - rewrite Val.subl_addl_opp. apply eval_addlimm; auto. - subst. rewrite Val.subl_addl_l. rewrite Val.subl_addl_r. @@ -297,7 +297,7 @@ Proof. - TrivialExists. Qed. -Theorem eval_mullimm_base: forall n, unary_constructor_sound (mullimm_base cp n) (fun v => Val.mull v (Vlong n)). +Theorem eval_mullimm_base: forall n, unary_constructor_sound (mullimm_base n) (fun v => Val.mull v (Vlong n)). Proof. intros; unfold mullimm_base. red; intros. assert (DEFAULT: exists v, @@ -328,7 +328,7 @@ Proof. - apply DEFAULT. Qed. -Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm cp n) (fun v => Val.mull v (Vlong n)). +Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). Proof. unfold mullimm. intros; red; intros. destruct Archi.splitlong eqn:SL. @@ -351,7 +351,7 @@ Proof. - apply eval_mullimm_base; auto. Qed. -Theorem eval_mull: binary_constructor_sound (mull cp) Val.mull. +Theorem eval_mull: binary_constructor_sound mull Val.mull. Proof. unfold mull. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_mull; eauto. red; intros; destruct (mull_match a b); InvEval. @@ -482,7 +482,7 @@ Theorem eval_shrxlimm: forall le a n x z, eval_expr ge sp e cp m le a x -> Val.shrxl x (Vint n) = Some z -> - exists v, eval_expr ge sp e cp m le (shrxlimm cp a n) v /\ Val.lessdef z v. + exists v, eval_expr ge sp e cp m le (shrxlimm a n) v /\ Val.lessdef z v. Proof. unfold shrxlimm; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32. From 051e5c6ae2e25c6af1def905ee79cd5a6fa829b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Fri, 24 Nov 2023 13:48:16 +0100 Subject: [PATCH 06/83] [Compartments] Fix Selectionproof.v and modify RTL.v --- backend/RTL.v | 39 +++++++++++++++++++-------------------- backend/RTLgenproof.v | 4 +++- backend/Selectionproof.v | 22 +++++++++------------- common/AST.v | 8 ++++---- 4 files changed, 35 insertions(+), 38 deletions(-) diff --git a/backend/RTL.v b/backend/RTL.v index c33edaa409..f0ed32ca36 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -91,8 +91,7 @@ Record function: Type := mkfunction { fn_entrypoint: node }. -#[global] -Instance has_comp_function : has_comp function := fn_comp. +#[export] Instance has_comp_function : has_comp function := fn_comp. (** A function description comprises a control-flow graph (CFG) [fn_code] (a partial finite mapping from nodes to instructions). As in Cminor, @@ -176,7 +175,8 @@ Inductive state : Type := forall (stack: list stackframe) (**r call stack *) (f: fundef) (**r function to call *) (args: list val) (**r arguments to the call *) - (m: mem), (**r memory state *) + (m: mem) (**r memory state *) + (cp: compartment), (**r calling compartment (cf Cminor.v for why we dont use [call_comp]) *) state | Returnstate: forall (stack: list stackframe) (**r call stack *) @@ -185,10 +185,10 @@ Inductive state : Type := (cp: compartment), (**r compartment we're returning from *) state. -Definition call_comp (stack: list stackframe): option compartment := +Definition call_comp (stack: list stackframe): compartment := match stack with - | nil => None - | Stackframe _ _ f _ _ _ :: _ => Some (comp_of f) + | nil => top + | Stackframe _ _ f _ _ _ :: _ => comp_of f end. Section RELSEM. @@ -245,7 +245,7 @@ Inductive step: state -> trace -> state -> Prop := forall s f sp pc rs m chunk addr args dst pc' a v, (fn_code f)!pc = Some(Iload chunk addr args dst pc') -> eval_addressing ge sp addr rs##args = Some a -> - Mem.loadv chunk m a (Some (comp_of f)) = Some v -> + Mem.loadv chunk m a (comp_of f) = Some v -> step (State s f sp pc rs m) E0 (State s f sp pc' (rs#dst <- v) m) | exec_Istore: @@ -265,7 +265,7 @@ Inductive step: state -> trace -> state -> Prop := forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall -> Forall not_ptr (rs##args)), forall (EV: call_trace ge (comp_of f) (comp_of fd) vf (rs##args) (sig_args sig) t), step (State s f sp pc rs m) - t (Callstate (Stackframe res (sig_res sig) f sp pc' rs :: s) fd rs##args m) + t (Callstate (Stackframe res (sig_res sig) f sp pc' rs :: s) fd rs##args m (comp_of f)) | exec_Itailcall: forall s f stk pc rs m sig ros args fd m', (fn_code f)!pc = Some(Itailcall sig ros args) -> @@ -274,13 +274,12 @@ Inductive step: state -> trace -> state -> Prop := forall COMP: comp_of fd = (comp_of f), Mem.free m stk 0 f.(fn_stacksize) (comp_of f) = Some m' -> step (State s f (Vptr stk Ptrofs.zero) pc rs m) - E0 (Callstate s fd rs##args m') + E0 (Callstate s fd rs##args m' (comp_of f)) | exec_Ibuiltin: forall s f sp pc rs m ef args res pc' vargs t vres m', - forall ALLOWED: comp_of ef = comp_of f, (fn_code f)!pc = Some(Ibuiltin ef args res pc') -> eval_builtin_args ge (fun r => rs#r) sp m args vargs -> - external_call ef ge vargs m t vres m' -> + external_call ef ge (comp_of f) vargs m t vres m' -> step (State s f sp pc rs m) t (State s f sp pc' (regmap_setres res vres rs) m') | exec_Icond: @@ -304,9 +303,9 @@ Inductive step: state -> trace -> state -> Prop := step (State s f (Vptr stk Ptrofs.zero) pc rs m) E0 (Returnstate s (regmap_optget or Vundef rs) m' (comp_of f)) | exec_function_internal: - forall s f args m m' stk, + forall s f args m cp m' stk, Mem.alloc m (comp_of f) 0 f.(fn_stacksize) = (m', stk) -> - step (Callstate s (Internal f) args m) + step (Callstate s (Internal f) args m cp) E0 (State s f (Vptr stk Ptrofs.zero) @@ -314,10 +313,10 @@ Inductive step: state -> trace -> state -> Prop := (init_regs args f.(fn_params)) m') | exec_function_external: - forall s ef args res t m m', - external_call ef ge args m t res m' -> - step (Callstate s (External ef) args m) - t (Returnstate s res m' (comp_of ef)) + forall s ef args res t m m' cp, + external_call ef ge cp args m t res m' -> + step (Callstate s (External ef) args m cp) + t (Returnstate s res m' bottom) | exec_return: forall res f cp sp pc rs s vres m ty t, forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) cp = Genv.CrossCompartmentCall -> @@ -341,7 +340,7 @@ Lemma exec_Iload': forall s f sp pc rs m chunk addr args dst pc' rs' a v, (fn_code f)!pc = Some(Iload chunk addr args dst pc') -> eval_addressing ge sp addr rs##args = Some a -> - Mem.loadv chunk m a (Some (comp_of f)) = Some v -> + Mem.loadv chunk m a (comp_of f) = Some v -> rs' = (rs#dst <- v) -> step (State s f sp pc rs m) E0 (State s f sp pc' rs' m). @@ -363,7 +362,7 @@ Inductive initial_state (p: program): state -> Prop := Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = signature_main -> - initial_state p (Callstate nil f nil m0). + initial_state p (Callstate nil f nil m0 top). (** A final state is a [Returnstate] with an empty call stack. *) @@ -390,7 +389,7 @@ Proof. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. exists (State s0 f sp pc' (regmap_setres res vres2 rs) m2). eapply exec_Ibuiltin; eauto. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. - exists (Returnstate s0 vres2 m2 (comp_of ef)). econstructor; eauto. + exists (Returnstate s0 vres2 m2 bottom). econstructor; eauto. inv EV; inv H0; eauto. (* trace length *) red; intros; inv H; simpl; try lia. diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index f009454977..1705ff371f 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -350,7 +350,7 @@ Require Import Errors. Definition match_prog (p: CminorSel.program) (tp: RTL.program) := match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp. -#[global] +#[export] Instance comp_transl_function: has_comp_transl_partial transl_function. Proof. unfold transl_function. @@ -424,6 +424,8 @@ Lemma allowed_call_translated_same: Proof. intros cp vf H. eapply (Genv.match_genvs_allowed_calls TRANSL). eauto. + Unshelve. + eauto. eapply has_comp_transl_match. Qed. diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 6dd831fd93..b872a4a4b9 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -1214,7 +1214,7 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := match_states (Cminor.Callstate (External ef) args (Cminor.Kcall optid f sp e k) m (comp_of f)) (State f' (sel_builtin optid ef al) k' sp e' m') - | match_builtin_2: forall cunit hf v v' optid f sp e k m f' e' m' k' env ty + | match_builtin_2: forall cunit hf v v' optid f sp e k m f' e' m' k' env ty cp (LINK: linkorder cunit prog) (HF: helper_functions_declared cunit hf) (TF: sel_function (prog_defmap cunit) hf f = OK f') @@ -1223,9 +1223,10 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := (LDV: Val.lessdef v v') (LDE: env_lessdef (set_optvar optid v e) e') (ME: Mem.extends m m') - (CPT: comp_of f = comp_of f'), + (CPT: comp_of f = comp_of f') + (CPT_RET: cp ⊆ comp_of f), match_states - (Cminor.Returnstate v (Cminor.Kcall optid f sp e k) m ty (comp_of f)) + (Cminor.Returnstate v (Cminor.Kcall optid f sp e k) m ty cp) (State f' Sskip k' sp e' m'). Remark call_cont_commut: @@ -1618,8 +1619,7 @@ Proof. rewrite <- CPT; eauto. intros (e2' & m2' & P & Q & R). left; econstructor; split. eexact P. - replace bottom with (@comp_of _ (@has_comp_fundef function has_comp_function) (External ef)). - econstructor; eauto. + econstructor; eauto. apply bottom_flowsto. - (* return *) inv MC. left; econstructor; split. @@ -1634,7 +1634,7 @@ Proof. econstructor; eauto. destruct optid; simpl; auto. apply set_var_lessdef; auto. - (* return of an external call turned into a Sbuiltin *) right; left; split. simpl; lia. split. - { inv EV; auto. eapply Genv.type_of_call_same_cp in H; contradiction. } + { inv EV; auto. simpl in H. destruct (flowsto_dec cp (comp_of f)) eqn:?; now auto. } econstructor; eauto. Qed. @@ -1693,19 +1693,15 @@ Global Instance TransfSelectionLink : TransfLink match_prog. Proof. red; intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. - intros. elim H3. intros hf1 [hf_c1 [HF_C1 [A1 B1]]]. elim H4; intros hf2 [hf_c2 [HF_C2 [A2 B2]]]. + intros. elim H3. intros hf [A1 B1]. elim H4; intros hf' [A2 B2]. Local Transparent Linker_fundef. simpl in *. destruct f1, f2; simpl in *; monadInv B1; monadInv B2; simpl. - discriminate. - destruct e; try easy. - destruct eq_compartment; try easy. - subst cp. inv H2. - rewrite <- (comp_transl_partial _ EQ), dec_eq_true. + inv H2. econstructor; eauto. - destruct e; try easy. - destruct eq_compartment; try easy. - subst cp. inv H2. - rewrite <- (comp_transl_partial _ EQ), dec_eq_true. + inv H2. econstructor; eauto. - destruct (external_function_eq e e0); inv H2. econstructor; eauto. Qed. diff --git a/common/AST.v b/common/AST.v index 9b047f080c..d70d25b763 100644 --- a/common/AST.v +++ b/common/AST.v @@ -133,14 +133,14 @@ Class has_comp_match {C T S: Type} {CT: has_comp T} {CS: has_comp S} comp_match: forall c x y, R c x y -> comp_of x = comp_of y. -Instance has_comp_transl_match: +#[export] Instance has_comp_transl_match: forall {C T S: Type} {CT: has_comp T} {CS: has_comp S} (f: T -> S) {Cf: has_comp_transl f}, has_comp_match (fun (c : C) x y => y = f x). Proof. now intros C T S ???? c x y ->; rewrite comp_transl. Qed. -Instance has_comp_transl_partial_match: +#[export] Instance has_comp_transl_partial_match: forall {C T S: Type} {CT: has_comp T} {CS: has_comp S} (f: T -> res S) {Cf: has_comp_transl_partial f}, @@ -149,7 +149,7 @@ Proof. intros C T S ???? c. exact comp_transl_partial. Qed. -Instance has_comp_transl_match_contextual: +#[export] Instance has_comp_transl_match_contextual: forall {C D T S: Type} {CT: has_comp T} {CS: has_comp S} (f: D -> T -> S) {Cf: forall d, has_comp_transl (f d)} @@ -159,7 +159,7 @@ Proof. now intros C D T S CT CS f Cf g ??? ->; rewrite comp_transl. Qed. -Instance has_comp_transl_partial_match_contextual: +#[export] Instance has_comp_transl_partial_match_contextual: forall {C D T S: Type} {CT: has_comp T} {CS: has_comp S} (f: D -> T -> res S) {Cf: forall d, has_comp_transl_partial (f d)} From 769c0e25225dec893083ef89dece510d685293de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Sun, 26 Nov 2023 10:17:50 +0100 Subject: [PATCH 07/83] [Compartments] Restore two instances removed by mistake --- common/AST.v | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/common/AST.v b/common/AST.v index d70d25b763..63407e3271 100644 --- a/common/AST.v +++ b/common/AST.v @@ -917,6 +917,14 @@ Definition transf_fundef (fd: fundef A): fundef B := | External ef => External ef end. +#[export] Instance comp_transf_fundef: + forall {CA: has_comp A} {CB: has_comp B} + {CAB: has_comp_transl transf}, + has_comp_transl transf_fundef. +Proof. + intros CA CB CAB [f|ef]; simpl; eauto using comp_transl. +Qed. + End TRANSF_FUNDEF. Section TRANSF_PARTIAL_FUNDEF. @@ -930,6 +938,15 @@ Definition transf_partial_fundef (fd: fundef A): res (fundef B) := | External ef => OK (External ef) end. +#[export] Instance comp_transf_partial_fundef: + forall {CA: has_comp A} {CB: has_comp B} + {CAB: has_comp_transl_partial transf_partial}, + has_comp_transl_partial transf_partial_fundef. +Proof. + intros CA CB CAB [f|ef] tf H; simpl in *; monadInv H; trivial. + eauto using comp_transl_partial. +Qed. + End TRANSF_PARTIAL_FUNDEF. (** * Register pairs *) From 8edd816817e9eba0d5381944c2912b7a51a4befa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Sun, 26 Nov 2023 10:20:22 +0100 Subject: [PATCH 08/83] [Compartments] Fix RTLgenproof.v --- backend/Cminor.v | 6 ++-- backend/CminorSel.v | 6 ++-- backend/RTLgenproof.v | 67 +++++++++++++++++++++---------------------- 3 files changed, 39 insertions(+), 40 deletions(-) diff --git a/backend/Cminor.v b/backend/Cminor.v index 3b5909ebe3..329c4a22ab 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -414,10 +414,10 @@ Definition is_call_cont (k: cont) : Prop := | _ => False end. -Definition call_comp (k: cont) : option compartment := +Definition call_comp (k: cont) : compartment := match call_cont k with - | Kcall _ f _ _ _ => Some (comp_of f) - | _ => None + | Kcall _ f _ _ _ => comp_of f + | _ => top end. (** Find the statement and manufacture the continuation diff --git a/backend/CminorSel.v b/backend/CminorSel.v index 7f5eb8fea8..eefd334d6a 100644 --- a/backend/CminorSel.v +++ b/backend/CminorSel.v @@ -313,10 +313,10 @@ Definition is_call_cont (k: cont) : Prop := | _ => False end. -Definition call_comp (k: cont) : option compartment := +Definition call_comp (k: cont) : compartment := match call_cont k with - | Kcall _ f _ _ _ => Some (comp_of f) - | _ => None + | Kcall _ f _ _ _ => comp_of f + | _ => top end. (** Find the statement and manufacture the continuation diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index 1705ff371f..68e021b20f 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -424,12 +424,9 @@ Lemma allowed_call_translated_same: Proof. intros cp vf H. eapply (Genv.match_genvs_allowed_calls TRANSL). eauto. - Unshelve. - eauto. eapply has_comp_transl_match. Qed. - Lemma allowed_call_translated: forall cp vf vf' tf, Val.lessdef vf vf' -> @@ -447,21 +444,14 @@ Lemma find_comp_translated: forall vf vf' fd, Val.lessdef vf vf' -> Genv.find_funct ge vf = Some fd -> - Genv.find_comp ge vf = Genv.find_comp tge vf'. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf'. Proof. intros vf vf' fd LESSDEF FIND. inv LESSDEF. - - eapply (Genv.match_genvs_find_comp TRANSL). + - eapply (Genv.match_genvs_find_comp_in_genv TRANSL). - inv FIND. Qed. -Lemma type_of_call_translated: - forall cp cp', - Genv.type_of_call cp cp' = Genv.type_of_call cp cp'. -Proof. - eapply Genv.match_genvs_type_of_call. -Qed. - Lemma call_trace_translated: forall cp cp' vf vf' ls ls' tyargs t, Val.lessdef vf vf' -> @@ -661,7 +651,7 @@ Lemma transl_expr_Eload_correct: eval_exprlist ge sp e cp m le args vargs -> transl_exprlist_prop le args vargs -> Op.eval_addressing ge sp addr vargs = Some vaddr -> - Mem.loadv chunk m vaddr (Some cp) = Some v -> + Mem.loadv chunk m vaddr cp = Some v -> transl_expr_prop le (Eload chunk addr args) v. Proof. intros; red; intros. @@ -786,8 +776,7 @@ Lemma transl_expr_Ebuiltin_correct: forall le ef al vl v, eval_exprlist ge sp e cp m le al vl -> transl_exprlist_prop le al vl -> - external_call ef ge vl m E0 v m -> - comp_of ef = cp -> + external_call ef ge cp vl m E0 v m -> transl_expr_prop le (Ebuiltin ef al) v. Proof. intros; red; intros. inv TE. @@ -798,8 +787,9 @@ Proof. (* Exec *) split. eapply star_right. eexact EX1. change (rs1#rd <- v') with (regmap_setres (BR rd) v' rs1). - eapply exec_Ibuiltin; eauto. congruence. + eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_trivial. + rewrite <- COMP. eapply external_call_symbols_preserved; eauto. apply senv_preserved. traceEq. (* Match-env *) @@ -819,8 +809,8 @@ Lemma transl_expr_Eexternal_correct: ef_sig ef = sg -> eval_exprlist ge sp e cp m le al vl -> transl_exprlist_prop le al vl -> - external_call ef ge vl m E0 v m -> - forall (INTRA: Genv.type_of_call cp (comp_of ef) <> Genv.CrossCompartmentCall), + external_call ef ge cp vl m E0 v m -> + (* forall (INTRA: Genv.type_of_call cp (comp_of ef) <> Genv.CrossCompartmentCall), *) transl_expr_prop le (Eexternal id sg al) v. Proof. intros; red; intros. inv TE. @@ -830,29 +820,34 @@ Proof. exploit function_ptr_translated; eauto. simpl. intros [tf [P Q]]. inv Q. exists (rs1#rd <- v'); exists tm2. (* Exec *) - rewrite COMP in INTRA. - assert (comp_of f = comp_of ef) as e0. - { unfold Genv.type_of_call in INTRA. - destruct (Pos.eqb_spec (comp_of f) (comp_of ef)) as [e0|]; try congruence. } split. eapply star_trans. eexact EX1. eapply star_left. eapply exec_Icall; eauto. unfold find_function. simpl. rewrite symbols_preserved. rewrite H. eauto. auto. simpl. rewrite symbols_preserved. rewrite H. eauto. unfold Genv.allowed_call. - rewrite e0. + (* rewrite e0. *) rewrite <- (find_comp_translated (Vptr b Ptrofs.zero) (Vptr b Ptrofs.zero) _ (Val.lessdef_refl _) H0). - unfold Genv.find_comp. apply Genv.find_funct_ptr_iff in H0. + unfold Genv.find_comp_in_genv. apply Genv.find_funct_ptr_iff in H0. simpl. unfold Genv.find_comp_of_block. simpl in H0. simpl. - unfold CminorSel.fundef. rewrite H0. eauto. - intros contra. destruct (INTRA contra). + unfold CminorSel.fundef. rewrite H0. left; auto with comps. + intros contra. simpl in contra. + destruct (flowsto_dec bottom (comp_of f)); try congruence. + pose proof (bottom_flowsto (comp_of f)). contradiction. instantiate (1 := E0). - econstructor. assumption. + econstructor. + intros contra. simpl in contra. + destruct (flowsto_dec bottom (comp_of f)); try congruence. + pose proof (bottom_flowsto (comp_of f)). contradiction. eapply star_left. eapply exec_function_external. eapply external_call_symbols_preserved; eauto. apply senv_preserved. clear H3; subst cp. eauto. apply star_one. apply exec_return. - unfold Genv.type_of_call. now rewrite e0, Pos.eqb_refl. - econstructor. assumption. + unfold Genv.type_of_call. + destruct (flowsto_dec bottom (comp_of f)); try congruence. + pose proof (bottom_flowsto (comp_of f)). contradiction. + econstructor. simpl. + destruct (flowsto_dec bottom (comp_of f)); try congruence. + pose proof (bottom_flowsto (comp_of f)). contradiction. reflexivity. reflexivity. reflexivity. (* Match-env *) split. eauto with rtlg. @@ -1344,7 +1339,6 @@ Proof. | TF : tr_fun _ _ _ _ _ _ |- _ => inv TF; symmetry; eauto end. - now rewrite COMP. Qed. Inductive match_states: CminorSel.state -> RTL.state -> Prop := @@ -1359,13 +1353,13 @@ Inductive match_states: CminorSel.state -> RTL.state -> Prop := match_states (CminorSel.State f s k sp e m) (RTL.State cs tf sp ns rs tm) | match_callstate: - forall f args targs k m tm cs tf + forall f args targs k m tm cs tf cp (TF: transl_fundef f = OK tf) (MS: match_stacks (sig_res (CminorSel.funsig f)) k cs) (LD: Val.lessdef_list args targs) (MEXT: Mem.extends m tm), - match_states (CminorSel.Callstate f args k m) - (RTL.Callstate cs tf targs tm) + match_states (CminorSel.Callstate f args k m cp) + (RTL.Callstate cs tf targs tm cp) | match_returnstate: forall v tv k m tm cs ty cp (MS: match_stacks ty k cs) @@ -1512,6 +1506,7 @@ Proof. eapply call_trace_translated with (vf := vf); eauto. rewrite J; eauto. now left. } traceEq. + rewrite COMP. constructor; auto. econstructor; eauto. (* direct *) @@ -1532,6 +1527,7 @@ Proof. { rewrite <- COMP, <- (comp_transl_partial _ Q). eapply call_trace_translated with (vf := (Vptr b Ptrofs.zero)); eauto. } traceEq. + rewrite COMP. constructor; auto. econstructor; eauto. @@ -1554,6 +1550,7 @@ Proof. rewrite <- (comp_transl_partial fd Q), COMP. inv TF; congruence. rewrite H, <- COMP'; eauto. traceEq. + rewrite COMP'. constructor; auto. rewrite SIG in U. auto. (* direct *) exploit transl_exprlist_correct; eauto. @@ -1570,6 +1567,7 @@ Proof. rewrite <- (comp_transl_partial _ Q), COMP. inv TF; congruence. rewrite H, <- COMP'; eauto. traceEq. + rewrite COMP'. constructor; auto. rewrite SIG in U. auto. (* builtin *) @@ -1586,8 +1584,9 @@ Proof. edestruct external_call_mem_extends as [tv [tm'' [A [B [C D]]]]]; eauto. econstructor; split. left. eapply plus_right. eexact E. - eapply exec_Ibuiltin; eauto. congruence. + eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + rewrite <- COMP. eapply external_call_symbols_preserved. apply senv_preserved. eauto. traceEq. econstructor; eauto. constructor. From 30dbad3cf320bb5134ef92b0e4c25317dd804671 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Sun, 26 Nov 2023 13:30:32 +0100 Subject: [PATCH 09/83] [Compartments] Fix Tailcall pass --- backend/Tailcall.v | 7 ++- backend/Tailcallproof.v | 103 ++++++++++++++++++++++------------------ common/Events.v | 10 ++++ 3 files changed, 69 insertions(+), 51 deletions(-) diff --git a/backend/Tailcall.v b/backend/Tailcall.v index b14e1b9b7e..8e6a7d8676 100644 --- a/backend/Tailcall.v +++ b/backend/Tailcall.v @@ -78,8 +78,8 @@ Definition compenv := PTree.t compartment. Definition add_globdef (ce: compenv) (idg: ident * globdef fundef unit): compenv := match idg with - | (id, Gfun f) => PTree.set id (comp_of f) ce - | (id, Gvar _) => PTree.remove id ce + | (id, Gfun (Internal f)) => PTree.set id (comp_of f) ce + | (id, _) => PTree.remove id ce end. Definition compenv_program (p: program): compenv := @@ -89,7 +89,7 @@ Definition intra_compartment_call (ce: compenv) (ros: reg + ident) (cp: compartm match ros with | inr id => match ce!id with - | Some cp' => eq_compartment cp cp' + | Some cp' => cp_eq_dec cp' cp | None => false end | _ => false @@ -111,7 +111,6 @@ Definition transf_instr (ce: compenv) (f: function) (pc: node) (instr: instructi && tailcall_is_possible sig && rettype_eq sig.(sig_res) f.(fn_sig).(sig_res) && intra_compartment_call ce ros (comp_of f) - && negb (needs_calling_comp (comp_of f)) then Itailcall sig ros args else instr | _ => instr diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index 9bd3b71e2a..b95b3d8c06 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -147,7 +147,6 @@ Inductive transf_instr_spec (ce: compenv) (f: function): instruction -> instruct f.(fn_stacksize) = 0 -> is_return_spec f s res -> forall INTRA: intra_compartment_call ce ros (comp_of f) = true, - forall ALLOWED: needs_calling_comp (comp_of f) = false, forall SIGRES: sig_res sig = sig_res (fn_sig f), transf_instr_spec ce f (Icall sig ros args res s) (Itailcall sig ros args) | transf_instr_default: forall i, @@ -161,11 +160,10 @@ Proof. intros. unfold transf_instr. destruct instr; try constructor. destruct (is_return niter f n r && tailcall_is_possible s && rettype_eq (sig_res s) (sig_res (fn_sig f)) && - intra_compartment_call ce _ (comp_of f) && - negb (needs_calling_comp _)) eqn:B. + intra_compartment_call ce _ (comp_of f)) + eqn:B. - InvBooleans. eapply transf_instr_tailcall; eauto. -+ eapply is_return_charact; eauto. -+ destruct (needs_calling_comp _); easy. + eapply is_return_charact; eauto. - constructor. Qed. @@ -321,10 +319,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. intros vf. - eapply (Genv.match_genvs_find_comp TRANSL). + eapply (Genv.match_genvs_find_comp_in_genv TRANSL). Qed. Lemma call_trace_translated: @@ -361,7 +359,7 @@ generalized and unified. *) Definition cenv_compat (p: program) (ce: compenv) : Prop := forall id cp, ce!id = Some cp -> - exists f, (prog_defmap p)!id = Some (Gfun f) /\ cp = comp_of f. + exists f, (prog_defmap p)!id = Some (Gfun (Internal f)) /\ (cp = comp_of f). Lemma compenv_program_compat: forall p, cenv_compat p (compenv_program p). @@ -369,7 +367,7 @@ Proof. set (P := fun (dm: PTree.t (globdef fundef unit)) (cenv: compenv) => forall id cp, cenv!id = Some cp -> - exists f, dm!id = Some (Gfun f) /\ cp = comp_of f). + exists f, dm!id = Some (Gfun (Internal f)) /\ (cp = comp_of f)). assert (REMOVE: forall dm fenv id g, P dm fenv -> P (PTree.set id g dm) (PTree.remove id fenv)). @@ -381,9 +379,9 @@ Proof. P dm cenv -> P (PTree.set (fst idg) (snd idg) dm) (add_globdef cenv idg)). { intros dm fenv [id g]; simpl; intros. - destruct g as [f | v]; auto. + destruct g as [[f | ?] | v]; auto. red; intros. rewrite ! PTree.gsspec in *. - destruct (peq id0 id); auto. inv H0; eauto. + destruct (peq id0 id); auto. inv H0; eauto with comps. } assert (REC: forall l dm cenv, P dm cenv -> @@ -401,27 +399,30 @@ Lemma cenv_compat_linkorder: linkorder cunit prog -> cenv_compat cunit cenv -> cenv_compat prog cenv. Proof. intros; red; intros. apply H0 in H1. - destruct H1 as (f & GET & Ecp). subst cp. + destruct H1 as (f & GET & Ecp). destruct (prog_defmap_linkorder _ _ _ _ H GET) as (gd' & P & Q). - inv Q. inv H2; eauto. + inv Q. inv H2; eauto with comps. Qed. Lemma find_function_intra_compartment_call ce ros rs fd cp: cenv_compat prog ce -> find_function ge ros rs = Some fd -> intra_compartment_call ce ros cp = true -> - comp_of fd = cp. + cp = comp_of fd. Proof. unfold find_function. destruct ros as [?|id]; try easy. simpl. destruct (ce ! id) as [cp'|] eqn:GETce; try easy. intros COMPAT. specialize (COMPAT _ _ GETce). - destruct COMPAT as (f & GETprog & ?). subst cp'. + destruct COMPAT as (f & GETprog & ?). apply Genv.find_def_symbol in GETprog. destruct GETprog as (b & FIND1 & FIND2). - unfold ge. rewrite FIND1. - unfold Genv.find_funct, Genv.find_funct_ptr. rewrite FIND2. - intros ? EQ. apply proj_sumbool_true in EQ. destruct Ptrofs.eq_dec; congruence. + unfold ge. setoid_rewrite FIND1. + unfold Genv.find_funct, Genv.find_funct_ptr. + destruct Ptrofs.eq_dec; try congruence. + setoid_rewrite FIND2. + intros ? EQ. apply proj_sumbool_true in EQ. + inv H0; auto. Qed. (** Consider an execution of a call/move/nop/return sequence in the @@ -464,7 +465,7 @@ Inductive match_stackframes (m: mem) (cp: compartment) : list stackframe -> list | match_stackframes_normal: forall stk stk' res sp pc rs rs' ce f ty, match_stackframes m (comp_of f) stk stk' -> forall (COMPAT: cenv_compat prog ce), - forall (ACC: Mem.can_access_block m sp (Some (comp_of f))), + forall (ACC: Mem.can_access_block m sp (comp_of f)), regs_lessdef rs rs' -> match_stackframes m cp (Stackframe res ty f (Vptr sp Ptrofs.zero) pc rs :: stk) @@ -505,17 +506,17 @@ Inductive match_states: state -> state -> Prop := (RLD: regs_lessdef rs rs') (MLD: Mem.extends m m') (* (UPD: uptodate_caller (comp_of f) (call_comp s) (call_comp s')) *) - (ACC: Mem.can_access_block m' sp (Some (comp_of f))), + (ACC: Mem.can_access_block m' sp (comp_of f)), match_states (State s f (Vptr sp Ptrofs.zero) pc rs m) (State s' (transf_function ce f) (Vptr sp Ptrofs.zero) pc rs' m') | match_states_call: - forall s ce f args m s' args' m', + forall s ce f cp args m s' args' m', match_stackframes m' (comp_of f) s s' -> forall (COMPAT: cenv_compat prog ce), Val.lessdef_list args args' -> Mem.extends m m' -> - match_states (Callstate s f args m) - (Callstate s' (transf_fundef ce f) args' m') + match_states (Callstate s f args m cp) + (Callstate s' (transf_fundef ce f) args' m' cp) | match_states_return: forall s v m s' v' m' cp, match_stackframes m' cp s s' -> @@ -553,7 +554,7 @@ Inductive match_states: state -> state -> Prop := Definition measure (st: state) : nat := match st with | State s f sp pc rs m => (List.length s * (niter + 2) + return_measure f.(fn_code) pc + 1)%nat - | Callstate s f args m => 0%nat + | Callstate s f args m cp => 0%nat | Returnstate s v m cp => (List.length s * (niter + 2))%nat end. @@ -654,16 +655,18 @@ Proof. red; intros; extlia. eauto. destruct X as [m'' FREE]. - assert (Efd: comp_of fd = (comp_of f)). + assert (Efd: comp_of f = comp_of fd). { exploit find_function_intra_compartment_call; eauto. } left. - exists (Callstate s' (transf_fundef (compenv_program cu) fd) (rs'##args) m''); split. + exists (Callstate s' (transf_fundef (compenv_program cu) fd) (rs'##args) m'' (comp_of f)); split. assert (t = E0). { clear -EV FUNPTR H0 Efd. - unfold Genv.find_comp, find_function in *. rewrite FUNPTR in H0. - rewrite Efd in EV. - now eapply call_trace_same_cp; eauto. } + unfold Genv.find_comp_in_genv, find_function in *. rewrite FUNPTR in H0. + inv EV; auto. rewrite Efd in H. + now rewrite Genv.type_of_call_same_cp in H. } subst t. + (* rewrite <- Efd. *) + erewrite <- @comp_transl with (f := transf_function ce); eauto using comp_transf_function. eapply exec_Itailcall; eauto. { apply sig_preserved. } { now rewrite comp_transl, comp_transl. } @@ -674,7 +677,7 @@ Proof. constructor. eapply match_stackframes_tail; eauto. (* TODO: Should be a lemma? *) - { rewrite Efd. + { rewrite <- Efd. clear -FREE STACKS. revert STACKS. generalize (comp_of f). intros cp STACKS. @@ -687,8 +690,10 @@ Proof. eapply Mem.free_right_extends; eauto. rewrite stacksize_preserved. rewrite H7. intros. extlia. + (* call that remains a call *) - left. eexists (Callstate (Stackframe res _ (transf_function ce f) (Vptr sp0 Ptrofs.zero) pc' rs' :: s') - (transf_fundef (compenv_program cu) fd) (rs'##args) m'); split. + left. + eexists (Callstate (Stackframe res _ (transf_function ce f) (Vptr sp0 Ptrofs.zero) pc' rs' :: s') + (transf_fundef (compenv_program cu) fd) (rs'##args) m' (comp_of f)); split. + erewrite <- @comp_transl with (f := transf_function ce); eauto using comp_transf_function. eapply exec_Icall; eauto. apply sig_preserved. eapply find_function_ptr_translated; eauto. rewrite comp_transl. eapply allowed_call_translated; eauto. @@ -723,8 +728,9 @@ Proof. intros (cu & tf & FIND' & Etf & ORDER). subst tf. exploit Mem.free_parallel_extends; eauto. intros [m'1 [FREE EXT]]. TransfInstr. - assert (Ef: (comp_of f) = comp_of (transf_function ce f)) by now symmetry; apply comp_transl. - left. exists (Callstate s' (transf_fundef (compenv_program cu) fd) (rs'##args) m'1); split. + assert (Ef: comp_of f = comp_of (transf_function ce f)) by now symmetry; apply comp_transl. + left. exists (Callstate s' (transf_fundef (compenv_program cu) fd) (rs'##args) m'1 (comp_of f)); split. + rewrite Ef. eapply exec_Itailcall; eauto. apply sig_preserved. now rewrite comp_transl, COMP. rewrite stacksize_preserved; auto. @@ -742,15 +748,17 @@ Proof. intros [v' [m'1 [A [B [C D]]]]]. left. exists (State s' (transf_function ce f) (Vptr sp0 Ptrofs.zero) pc' (regmap_setres res v' rs') m'1); split. eapply exec_Ibuiltin; eauto. - rewrite comp_transf_function; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + rewrite comp_transf_function; eauto. econstructor; eauto. (* TODO: Should be a lemma! *) { clear -A STACKS. - induction STACKS. + revert STACKS. + generalize (comp_of f). + induction 1. - constructor. - - constructor; auto. eapply external_call_can_access_block; eauto. + - constructor; eauto. eapply external_call_can_access_block; eauto. - constructor; auto. } apply set_res_lessdef; auto. eapply external_call_can_access_block; eauto. @@ -810,27 +818,27 @@ Proof. simpl. eapply exec_function_internal; eauto. rewrite EQ1, EQ4; eauto. rewrite EQ2. rewrite EQ3. constructor; auto. (* TODO: Should be a lemma? *) - { clear -ALLOC H5. unfold comp_of in H5; simpl in H5. - revert H5. generalize (comp_of f). intros cp STACKS. + { clear -ALLOC H6. simpl in H6. + revert H6. generalize (comp_of f). intros cp STACKS. induction STACKS. - constructor. - constructor; auto. eapply Mem.alloc_can_access_block_other_inj_1; eauto. - constructor; auto. } apply regs_lessdef_init_regs. auto. - eapply Mem.owned_new_block; eauto. + simpl. erewrite Mem.owned_new_block; eauto. apply flowsto_refl. - (* external call *) exploit external_call_mem_extends; eauto. intros [res' [m2' [A [B [C D]]]]]. - left. exists (Returnstate s' res' m2' (comp_of ef)); split. + left. exists (Returnstate s' res' m2' bottom); split. simpl. econstructor; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. constructor; auto. (* TODO: Should be a lemma? *) - { clear -A H5. - remember (call_comp s) as cp. clear Heqcp. unfold comp_of in H5; simpl in H5. - induction H5. + { clear -A H6. + simpl in H6. + induction H6. - constructor. - constructor; auto. eapply external_call_can_access_block; eauto. - constructor; auto. } @@ -851,8 +859,9 @@ Proof. change (S (length s) * (niter + 2))%nat with ((niter + 2) + (length s) * (niter + 2))%nat. generalize (return_measure_bounds (fn_code f) pc). lia. - split. auto. - inv EV; auto. unfold Genv.type_of_call in H; rewrite Pos.eqb_refl in H; congruence. + split. + inv EV; auto. simpl in H; destruct (flowsto_dec (comp_of f) (comp_of f)); + pose proof (flowsto_refl (comp_of f)); congruence. econstructor; eauto. rewrite Regmap.gss. auto. Qed. @@ -864,7 +873,7 @@ Proof. intros. inv H. exploit funct_ptr_translated; eauto. intros (cu & tf & FIND & Etf & ORDER). subst tf. - exists (Callstate nil (transf_fundef (compenv_program cu) f) nil m0); split. + exists (Callstate nil (transf_fundef (compenv_program cu) f) nil m0 top); split. econstructor; eauto. eapply (Genv.init_mem_match TRANSL); eauto. replace (prog_main tprog) with (prog_main prog). diff --git a/common/Events.v b/common/Events.v index 08bf151e2e..f0ac614089 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2101,6 +2101,16 @@ Proof. now rewrite Genv.type_of_call_same_cp in H0. Qed. +Lemma call_trace_internal_call: + forall cp cp' vf vargs tyargs t, + Genv.type_of_call cp cp' = Genv.InternalCall -> + call_trace cp cp' vf vargs tyargs t -> + t = E0. +Proof. + intros. inv H0; auto. + congruence. +Qed. + Inductive return_trace: compartment -> compartment -> val -> rettype -> trace -> Prop := | return_trace_intra: forall cp cp' v ty, Genv.type_of_call cp cp' <> Genv.CrossCompartmentCall -> From d85d37e404316ec46e298b40af453175eacbb32a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Sun, 26 Nov 2023 13:39:43 +0100 Subject: [PATCH 10/83] [Compartments] Fix Inlining pass --- backend/Inlining.v | 4 +- backend/Inliningproof.v | 93 +++++++++++++++++++++++++---------------- backend/Inliningspec.v | 4 +- 3 files changed, 60 insertions(+), 41 deletions(-) diff --git a/backend/Inlining.v b/backend/Inlining.v index af6fb01dca..d4468701a3 100644 --- a/backend/Inlining.v +++ b/backend/Inlining.v @@ -291,7 +291,7 @@ Variable rec: forall fenv', (size_fenv fenv' < size_fenv fenv)%nat -> context -> Inductive inline_decision cp (ros: reg + ident) : Type := | Cannot_inline - | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f) (R: cp = (comp_of f)). + | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f) (R: cp = comp_of f). Arguments Cannot_inline {cp} {ros}. Arguments Can_inline {cp} {ros}. @@ -302,7 +302,7 @@ Program Definition can_inline (cp: compartment) (ros: reg + ident): inline_decis | inr id => match fenv!id with | Some f => - if eq_compartment cp (comp_of f) then + if cp_eq_dec cp (comp_of f) then Can_inline id f _ _ _ else Cannot_inline | None => Cannot_inline diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index 053c653464..8f2e580e30 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -77,10 +77,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. intros vf. - eapply (Genv.match_genvs_find_comp TRANSF). + eapply (Genv.match_genvs_find_comp_in_genv TRANSF). Qed. Lemma sig_function_translated: @@ -565,7 +565,7 @@ Inductive match_stacks (F: meminj) (m m': mem): (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)) (RES: Ple res ctx.(mreg)) (BELOW: Plt sp' bound) - (ACCESS: Mem.can_access_block m' sp' (Some (comp_of f'))), + (ACCESS: Mem.can_access_block m' sp' (comp_of f')), match_stacks F m m' cp (Stackframe res ty f (Vptr sp Ptrofs.zero) pc rs :: stk) (Stackframe (sreg ctx res) ty f' (Vptr sp' Ptrofs.zero) (spc ctx pc) rs' :: stk') @@ -578,7 +578,7 @@ Inductive match_stacks (F: meminj) (m m': mem): (RET: ctx.(retinfo) = Some (rpc, res)) (BELOW: Plt sp' bound) (COMP: cp = comp_of f') - (ACCESS: Mem.can_access_block m' sp' (Some (comp_of f'))), + (ACCESS: Mem.can_access_block m' sp' (comp_of f')), match_stacks F m m' cp stk (Stackframe res ty f' (Vptr sp' Ptrofs.zero) rpc rs' :: stk') @@ -603,7 +603,7 @@ with match_stacks_inside (F: meminj) (m m': mem): (RET: ctx.(retinfo) = Some (spc ctx' pc, sreg ctx' res)) (BELOW: context_below ctx' ctx) (SBELOW: context_stack_call ctx' ctx) - (ACCESS: Mem.can_access_block m' sp' (Some (comp_of f'))), + (ACCESS: Mem.can_access_block m' sp' (comp_of f')), match_stacks_inside F m m' (Stackframe res ty f (Vptr sp Ptrofs.zero) pc rs :: stk) stk' f' ctx sp' rs'. @@ -1022,23 +1022,23 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := (SP: F sp = Some(sp', ctx.(dstk))) (MINJ: Mem.inject F m m') (VB: Mem.valid_block m' sp') - (AC: Mem.can_access_block m' sp' (Some (comp_of f'))) + (AC: Mem.can_access_block m' sp' (comp_of f')) (PRIV: range_private F m m' sp' (ctx.(dstk) + ctx.(mstk)) f'.(fn_stacksize)) (SSZ1: 0 <= f'.(fn_stacksize) < Ptrofs.max_unsigned) (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)), match_states (State stk f (Vptr sp Ptrofs.zero) pc rs m) (State stk' f' (Vptr sp' Ptrofs.zero) (spc ctx pc) rs' m') - | match_call_states: forall stk fd args m stk' fd' args' m' cunit F + | match_call_states: forall stk fd args m stk' fd' args' m' cp cunit F (MS: match_stacks F m m' (comp_of fd) stk stk' (Mem.nextblock m')) (LINK: linkorder cunit prog) (FD: transf_fundef (funenv_program cunit) fd = OK fd') (VINJ: Val.inject_list F args args') (MINJ: Mem.inject F m m'), - match_states (Callstate stk fd args m) - (Callstate stk' fd' args' m') + match_states (Callstate stk fd args m cp) + (Callstate stk' fd' args' m' cp) | match_call_regular_states: forall stk f vargs m stk' f' sp' rs' m' F fenv ctx ctx' pc' pc1' rargs (MS: match_stacks_inside F m m' stk stk' f' ctx sp' rs') - (SAMECOMP: (comp_of f) = comp_of f') + (SAMECOMP: comp_of f' = comp_of f) (COMPAT: fenv_compat prog fenv) (FB: tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code)) (BELOW: context_below ctx' ctx) @@ -1047,11 +1047,11 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := (VINJ: list_forall2 (val_reg_charact F ctx' rs') vargs rargs) (MINJ: Mem.inject F m m') (VB: Mem.valid_block m' sp') - (AC: Mem.can_access_block m' sp' (Some (comp_of f'))) + (AC: Mem.can_access_block m' sp' (comp_of f')) (PRIV: range_private F m m' sp' ctx.(dstk) f'.(fn_stacksize)) (SSZ1: 0 <= f'.(fn_stacksize) < Ptrofs.max_unsigned) (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)), - match_states (Callstate stk (Internal f) vargs m) + match_states (Callstate stk (Internal f) vargs m (comp_of f')) (State stk' f' (Vptr sp' Ptrofs.zero) pc' rs' m') | match_return_states: forall stk v m stk' v' m' F cp (MS: match_stacks F m m' cp stk stk' (Mem.nextblock m')) @@ -1066,7 +1066,7 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := (VINJ: match or with None => v = Vundef | Some r => Val.inject F v rs'#(sreg ctx r) end) (MINJ: Mem.inject F m m') (VB: Mem.valid_block m' sp') - (AC: Mem.can_access_block m' sp' (Some (comp_of f'))) + (AC: Mem.can_access_block m' sp' (comp_of f')) (PRIV: range_private F m m' sp' ctx.(dstk) f'.(fn_stacksize)) (SSZ1: 0 <= f'.(fn_stacksize) < Ptrofs.max_unsigned) (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)), @@ -1078,7 +1078,7 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := Definition measure (S: RTL.state) : nat := match S with | State _ _ _ _ _ _ => 1%nat - | Callstate _ _ _ _ => 0%nat + | Callstate _ _ _ _ _ => 0%nat | Returnstate _ _ _ _ => 0%nat end. @@ -1198,6 +1198,7 @@ Proof. now rewrite (comp_transf_partial_fundef _ B). rewrite <- SAMECOMP, <- (comp_transf_partial_fundef _ B). eapply call_trace_translated; eauto. + rewrite SAMECOMP. econstructor; eauto. eapply match_stacks_cons; eauto. eapply agree_val_regs; eauto. @@ -1205,7 +1206,11 @@ Proof. assert (EQ: fd = Internal f0) by (eapply find_inlined_function; eauto). subst fd. right; split. simpl; lia. split. - eapply call_trace_same_cp; eauto. rewrite SAMECOMP0 in EV. exact EV. + eapply call_trace_internal_call; eauto. simpl. + rewrite SAMECOMP0. + destruct (flowsto_dec (comp_of f) (comp_of f)); pose proof (flowsto_refl (comp_of f)); + congruence. + rewrite SAMECOMP. econstructor; eauto. eapply match_stacks_inside_inlined; eauto. red; intros; apply PRIV. inv H14. destruct H17. lia. @@ -1233,6 +1238,7 @@ Proof. eapply plus_one. eapply exec_Itailcall; eauto. eapply sig_function_translated; eauto. now rewrite <- (comp_transl_partial _ B), COMP. + rewrite SAMECOMP. econstructor; eauto. eapply match_stacks_bound with (bound := sp'). rewrite COMP, SAMECOMP. @@ -1262,23 +1268,28 @@ Proof. - destruct (Genv.find_symbol ge i); try discriminate. inv Hvf. congruence. } (* TODO: Clean this up *) - assert (FINDCOMP: Genv.find_comp tge vf = Some (comp_of f)). + assert (FINDCOMP: Genv.find_comp_in_genv tge vf = comp_of f). { rewrite <- find_comp_translated, <- SAMECOMP'. unfold find_function in *. unfold find_function_ptr in *. destruct ros; simpl in *. - - inv Hvf. rewrite (Genv.find_funct_find_comp _ _ H0). congruence. + - inv Hvf. rewrite (Genv.find_funct_find_comp_in_genv _ _ H0). congruence. - destruct (Genv.find_symbol ge i); try discriminate. - inv Hvf. rewrite (Genv.find_funct_find_comp _ _ H0). congruence. } + inv Hvf. rewrite (Genv.find_funct_find_comp_in_genv _ _ H0). congruence. } left; econstructor; split. eapply plus_one. eapply exec_Icall; eauto. eapply sig_function_translated; eauto. - rewrite <- SAMECOMP. left; rewrite FINDCOMP; reflexivity. + rewrite <- SAMECOMP. left; rewrite FINDCOMP; apply flowsto_refl. (* This is a tailcall, so the type of call is InternalCall *) - rewrite <- SAMECOMP, <- (comp_transl_partial _ B), COMP. unfold Genv.type_of_call. now rewrite Pos.eqb_refl. + rewrite <- SAMECOMP, <- (comp_transl_partial _ B), COMP. + simpl; destruct (flowsto_dec (comp_of f) (comp_of f)); pose proof (flowsto_refl (comp_of f)); + now auto. econstructor; eauto. - rewrite <- SAMECOMP, <- (comp_transl_partial _ B), COMP. unfold Genv.type_of_call. now rewrite Pos.eqb_refl. + rewrite <- SAMECOMP, <- (comp_transl_partial _ B), COMP. + simpl; destruct (flowsto_dec (comp_of f) (comp_of f)); pose proof (flowsto_refl (comp_of f)); + now auto. + rewrite SAMECOMP. econstructor; eauto. eapply match_stacks_untailcall; eauto. eapply match_stacks_inside_invariant; eauto. @@ -1292,6 +1303,7 @@ Proof. assert (EQ: fd = Internal f0) by (eapply find_inlined_function; eauto). subst fd. right; split. simpl; lia. split. auto. + rewrite SAMECOMP. econstructor; eauto. eapply match_stacks_inside_inlined_tailcall; eauto. eapply match_stacks_inside_invariant; eauto. @@ -1310,9 +1322,10 @@ Proof. exploit tr_builtin_args; eauto. intros (vargs' & P & Q). exploit external_call_mem_inject; eauto. eapply match_stacks_inside_globals; eauto. - intros [F1 [v1 [m1' [A [B [C [D [E [J [K L]]]]]]]]]]. + intros [F1 [v1 [m1' [A [B [C [D [E [J K]]]]]]]]]. left; econstructor; split. - eapply plus_one. eapply exec_Ibuiltin; eauto. congruence. + eapply plus_one. eapply exec_Ibuiltin; eauto. + rewrite <- SAMECOMP. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor. eapply match_stacks_inside_set_res. @@ -1426,8 +1439,8 @@ Proof. eapply Mem.alloc_can_access_block_other_inj_1; eauto. } auto. auto. auto. eauto. auto. rewrite H6. apply agree_regs_init_regs. eauto. auto. inv H1; auto. congruence. auto. - eapply Mem.valid_new_block; eauto. - rewrite H4; eapply Mem.owned_new_block; eauto. + eapply Mem.valid_new_block; eauto. simpl. + rewrite H4; erewrite <- Mem.owned_new_block; eauto with comps. red; intros. split. eapply Mem.perm_alloc_2; eauto. inv H1; extlia. intros; red; intros. exploit Mem.perm_alloc_inv. eexact H. eauto. @@ -1444,7 +1457,7 @@ Proof. eauto. (* sp' is valid *) instantiate (1 := sp'). auto. - rewrite SAMECOMP. auto. + simpl. eapply flowsto_trans; eauto. rewrite SAMECOMP; apply flowsto_refl. (* offset is representable *) instantiate (1 := dstk ctx). generalize (Z.le_max_r (fn_stacksize f) 0). lia. (* size of target block is representable *) @@ -1479,7 +1492,7 @@ Proof. exploit match_stacks_globalenvs; eauto. intros [bound MG]. exploit external_call_mem_inject; eauto. eapply match_globalenvs_preserves_globals; eauto. - intros [F1 [v1 [m1' [A [B [C [D [E [J [K L]]]]]]]]]]. + intros [F1 [v1 [m1' [A [B [C [D [E [J K]]]]]]]]]. simpl in FD. inv FD. left; econstructor; split. eapply plus_one. eapply exec_function_external; eauto. @@ -1510,12 +1523,18 @@ Proof. rewrite RET in RET0; inv RET0. left; econstructor; split. eapply plus_one. eapply exec_return. - intros G. exfalso. eapply Genv.type_of_call_same_cp; eauto. + simpl. + destruct (flowsto_dec (comp_of f') (comp_of f')); pose proof (flowsto_refl (comp_of f')); + congruence. assert (t = E0). { clear -EV SAMECOMP. inv EV; auto. - exfalso. rewrite SAMECOMP in H. - eapply Genv.type_of_call_same_cp; eauto. } - subst; constructor; eauto using Genv.type_of_call_same_cp. + simpl in H. rewrite SAMECOMP in H. + destruct (flowsto_dec (comp_of f') (comp_of f')); pose proof (flowsto_refl (comp_of f')); + congruence. } + subst t. + subst; constructor; simpl; eauto using Genv.type_of_call_same_cp. + destruct (flowsto_dec (comp_of f') (comp_of f')); pose proof (flowsto_refl (comp_of f')); + congruence. eapply match_regular_states. eapply match_stacks_inside_set_reg; eauto. auto. eauto. auto. @@ -1529,11 +1548,11 @@ Proof. unfold inline_return in AT. assert (PRIV': range_private F m m' sp' (dstk ctx' + mstk ctx') f'.(fn_stacksize)). red; intros. destruct (zlt ofs (dstk ctx)). apply PAD. lia. apply PRIV. lia. - assert (t = E0). { rewrite SAMECOMP in EV. pose proof return_trace_intra as G. - assert (Genv.type_of_call (comp_of f') (comp_of f') <> Genv.CrossCompartmentCall) by - (unfold Genv.type_of_call; now rewrite Pos.eqb_refl). - specialize (G _ _ ge (comp_of f') (comp_of f') vres ty H). - now inv EV; inv G. } + assert (t = E0). + { clear -EV SAMECOMP. inv EV; auto. + simpl in H. rewrite SAMECOMP in H. + destruct (flowsto_dec (comp_of f') (comp_of f')); pose proof (flowsto_refl (comp_of f')); + congruence. } subst t. destruct or. + (* with a result *) @@ -1554,7 +1573,7 @@ Lemma transf_initial_states: Proof. intros. inv H. exploit function_ptr_translated; eauto. intros (cu & tf & FIND & TR & LINK). - exists (Callstate nil tf nil m0); split. + exists (Callstate nil tf nil m0 top); split. econstructor; eauto. eapply (Genv.init_mem_match TRANSF); eauto. rewrite symbols_preserved. replace (prog_main tprog) with (prog_main prog). auto. diff --git a/backend/Inliningspec.v b/backend/Inliningspec.v index b3fa637222..da5d235a2a 100644 --- a/backend/Inliningspec.v +++ b/backend/Inliningspec.v @@ -284,7 +284,7 @@ Inductive tr_instr: context -> compartment -> node -> instruction -> code -> Pro c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s)) -> tr_instr ctx cp pc (Icall sg ros args res s) c | tr_call_inlined:forall ctx cp pc sg id args res s c f pc1 ctx', - forall (SAMECOMP: cp = comp_of f), + forall (SAMECOMP: comp_of f = cp), Ple res ctx.(mreg) -> fenv!id = Some f -> c!(spc ctx pc) = Some(Inop pc1) -> @@ -303,7 +303,7 @@ Inductive tr_instr: context -> compartment -> node -> instruction -> code -> Pro ctx.(retinfo) = Some(s, res) -> tr_instr ctx cp pc (Itailcall sg ros args) c | tr_tailcall_inlined: forall ctx cp pc sg id args c f pc1 ctx', - forall (SAMECOMP: cp = comp_of f), + forall (SAMECOMP: comp_of f = cp), fenv!id = Some f -> c!(spc ctx pc) = Some(Inop pc1) -> tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) -> From 363a5af1f9451c5bd04a91c94a84f0d35bbb5503 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Sun, 26 Nov 2023 13:45:44 +0100 Subject: [PATCH 11/83] [Compartments] Fixers to RTLtyping, Renumber pass, and Cop/Ctypes --- backend/RTLtyping.v | 17 ++++++++--------- backend/Renumberproof.v | 10 +++++----- cfrontend/Cop.v | 8 ++------ cfrontend/Ctypes.v | 4 ++-- 4 files changed, 17 insertions(+), 22 deletions(-) diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index f24d85499f..f7a9484967 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -132,7 +132,7 @@ Inductive wt_instr : instruction -> Prop := | wt_Ibuiltin: forall ef args res s, match ef with - | EF_annot _ _ _ _ | EF_debug _ _ _ _ => True + | EF_annot _ _ _ | EF_debug _ _ _ => True | _ => map type_of_builtin_arg args = (ef_sig ef).(sig_args) end -> type_of_builtin_res res = proj_sig_res (ef_sig ef) -> @@ -309,7 +309,7 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv := do x <- check_successor s; do e1 <- match ef with - | EF_annot _ _ _ _ | EF_debug _ _ _ _ => OK e + | EF_annot _ _ _ | EF_debug _ _ _ => OK e | _ => type_builtin_args e args sig.(sig_args) end; type_builtin_res e1 res (proj_sig_res sig) @@ -705,7 +705,7 @@ Proof. exploit type_builtin_res_complete; eauto. instantiate (1 := res). intros [e2 [C D]]. exploit type_builtin_res_complete. eexact H. instantiate (1 := res). intros [e3 [E F]]. rewrite check_successor_complete by auto. simpl. - exists (match ef with EF_annot _ _ _ _ | EF_debug _ _ _ _ => e3 | _ => e2 end); split. + exists (match ef with EF_annot _ _ _ | EF_debug _ _ _ => e3 | _ => e2 end); split. rewrite H1 in C, E. destruct ef; try (rewrite <- H0; rewrite A); simpl; auto. destruct ef; auto. @@ -857,14 +857,13 @@ Qed. Lemma wt_exec_Ibuiltin: forall env f ef (ge: genv) args res s vargs m t vres m' rs, wt_instr f env (Ibuiltin ef args res s) -> - external_call ef ge vargs m t vres m' -> + external_call ef ge (comp_of f) vargs m t vres m' -> wt_regset env rs -> - comp_of ef = comp_of f -> wt_regset env (regmap_setres res vres rs). Proof. intros. inv H. eapply wt_regset_setres; eauto. - rewrite H8. eapply external_call_well_typed; eauto. + rewrite H7. eapply external_call_well_typed; eauto. Qed. Lemma wt_instr_at: @@ -894,11 +893,11 @@ Inductive wt_state: state -> Prop := (WT_RS: wt_regset env rs), wt_state (State s f sp pc rs m) | wt_state_call: - forall s f args m, + forall s f cp args m, wt_stackframes s (funsig f) -> wt_fundef f -> Val.has_type_list args (sig_args (funsig f)) -> - wt_state (Callstate s f args m) + wt_state (Callstate s f args m cp) | wt_state_return: forall s v m cp sg, wt_stackframes s sg -> @@ -979,7 +978,7 @@ Proof. econstructor; eauto. inv WTI; simpl. auto. rewrite <- H3. auto. (* internal function *) - simpl in *. inv H5. + simpl in *. inv H6. econstructor; eauto. inv H1. apply wt_init_regs; auto. rewrite wt_params0. auto. (* external function *) diff --git a/backend/Renumberproof.v b/backend/Renumberproof.v index dbc0f44108..c053ce89c3 100644 --- a/backend/Renumberproof.v +++ b/backend/Renumberproof.v @@ -104,10 +104,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. intros vf. - eapply (Genv.match_genvs_find_comp TRANSL). + eapply (Genv.match_genvs_find_comp_in_genv TRANSL). Qed. Lemma call_trace_translated: @@ -213,10 +213,10 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := (REACH: reach f pc), match_states (State stk f sp pc rs m) (State stk' (transf_function f) sp (renum_pc (pnum f) pc) rs m) - | match_callstates: forall stk f args m stk' + | match_callstates: forall stk f args m cp stk' (STACKS: list_forall2 match_frames stk stk'), - match_states (Callstate stk f args m) - (Callstate stk' (transf_fundef f) args m) + match_states (Callstate stk f args m cp) + (Callstate stk' (transf_fundef f) args m cp) | match_returnstates: forall stk v m cp stk' (STACKS: list_forall2 match_frames stk stk'), match_states (Returnstate stk v m cp) diff --git a/cfrontend/Cop.v b/cfrontend/Cop.v index 32a5f3ca2b..1570bcbf85 100644 --- a/cfrontend/Cop.v +++ b/cfrontend/Cop.v @@ -1120,7 +1120,7 @@ Definition bitfield_normalize (sz: intsize) (sg: signedness) (width: Z) (n: int) then Int.zero_ext width n else Int.sign_ext width n. -Inductive load_bitfield: type -> intsize -> signedness -> Z -> Z -> mem -> val -> val -> option compartment -> Prop := +Inductive load_bitfield: type -> intsize -> signedness -> Z -> Z -> mem -> val -> val -> compartment -> Prop := | load_bitfield_intro: forall sz sg1 attr sg pos width m addr c cp, 0 <= pos -> 0 < width <= bitsize_intsize sz -> pos + width <= bitsize_carrier sz -> sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> @@ -1132,7 +1132,7 @@ Inductive store_bitfield: type -> intsize -> signedness -> Z -> Z -> mem -> val | store_bitfield_intro: forall sz sg1 attr sg pos width m addr c n m' cp, 0 <= pos -> 0 < width <= bitsize_intsize sz -> pos + width <= bitsize_carrier sz -> sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> - Mem.loadv (chunk_for_carrier sz) m addr (Some cp) = Some (Vint c) -> + Mem.loadv (chunk_for_carrier sz) m addr cp = Some (Vint c) -> Mem.storev (chunk_for_carrier sz) m addr (Vint (Int.bitfield_insert (first_bit sz pos width) width c n)) cp = Some m' -> store_bitfield (Tint sz sg1 attr) sz sg pos width m addr (Vint n) @@ -1835,7 +1835,3 @@ Qed. End ArithConv. - - - - diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index 95935a4cdb..0a29656911 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -1507,11 +1507,11 @@ Inductive fundef : Type := | Internal: F -> fundef | External: external_function -> typelist -> type -> calling_convention -> fundef. -Global Instance has_comp_fundef {CF: has_comp F} : has_comp fundef := +#[export] Instance has_comp_fundef {CF: has_comp F} : has_comp fundef := fun fd => match fd with | Internal f => comp_of f - | External ef _ _ _ => comp_of ef + | External ef _ _ _ => bottom end. (** A program, or compilation unit, is composed of: From 4754b081d3d38e55a4bb6b7b6f78872191fc2c6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Sun, 26 Nov 2023 22:31:26 +0000 Subject: [PATCH 12/83] [Compartments] Various fixes in Allocation, Tunneling, Unusedglob, Csyntax, Events, and Memory --- backend/Allocation.v | 18 ++++++------- backend/Tunnelingproof.v | 14 +++++----- backend/Unusedglobproof.v | 49 ++++++++++++++++++----------------- backend/ValueAnalysis.v | 54 ++++++++++++++++++++------------------- backend/ValueDomain.v | 24 +++++------------ cfrontend/Csyntax.v | 2 +- common/Events.v | 22 +++++++++++++--- common/Memory.v | 15 +++++++++++ 8 files changed, 111 insertions(+), 87 deletions(-) diff --git a/backend/Allocation.v b/backend/Allocation.v index 0361335e76..e79d6c36fe 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -1008,13 +1008,13 @@ Definition kind_second_word := if Archi.big_endian then Low else High. equations that must hold "before" these instructions, or [None] if impossible. *) -(* FIXME A [Genv.type_of_call]-like function that closely mimics it but does not - take a global environment as a parameter and only distinguishes between - cross-compartment calls and everything else. Can be made cleaner. *) -Definition is_external_call (cp: compartment) (cp': compartment): bool := - if Pos.eqb cp cp' then false - else if Pos.eqb cp' default_compartment then false - else true. +(* (* FIXME A [Genv.type_of_call]-like function that closely mimics it but does not *) +(* take a global environment as a parameter and only distinguishes between *) +(* cross-compartment calls and everything else. Can be made cleaner. *) *) +(* Definition is_external_call (cp: compartment) (cp': compartment): bool := *) +(* if Pos.eqb cp cp' then false *) +(* else if Pos.eqb cp' default_compartment then false *) +(* else true. *) Definition transfer_aux (f: RTL.function) (env: regenv) (shape: block_shape) (e: eqs) : option eqs := @@ -1120,7 +1120,7 @@ Definition transfer_aux (f: RTL.function) (env: regenv) assertion (can_undef (destroyed_by_builtin ef) e2); do e3 <- match ef with - | EF_debug _ _ _ _ => add_equations_debug_args env args args' e2 + | EF_debug _ _ _ => add_equations_debug_args env args args' e2 | _ => add_equations_builtin_args env args args' e2 end; track_moves env mv1 e3 @@ -1365,7 +1365,7 @@ Definition check_function (rtl: RTL.function) (ltl: LTL.function) (env: regenv): match analyze rtl env bsh with | None => Error (msg "allocation analysis diverges") | Some a => - if eq_compartment rtl.(RTL.fn_comp) ltl.(LTL.fn_comp) then + if cp_eq_dec rtl.(RTL.fn_comp) ltl.(LTL.fn_comp) then check_entrypoints rtl ltl env bsh a else Error (msg "register allocation changed the function compartment") end. diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index d26a438227..ddf0ece79a 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -297,10 +297,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. intros vf. - eapply (Genv.match_genvs_find_comp TRANSL). + eapply (Genv.match_genvs_find_comp_in_genv TRANSL). Qed. Lemma senv_preserved: @@ -703,7 +703,7 @@ Proof. (fun p : rpair loc => Locmap.getpair p (undef_regs destroyed_at_function_entry - (* match Genv.type_of_call ge (comp_of f) (Genv.find_comp ge vf) with *) + (* match Genv.type_of_call ge (comp_of f) (Genv.find_comp_in_genv ge vf) with *) (* | Genv.CrossCompartmentCall => call_regs_ext rs (funsig fd) *) (* | _ => call_regs rs *) (* end *) @@ -713,7 +713,7 @@ Proof. (fun p : rpair loc => Locmap.getpair p (undef_regs destroyed_at_function_entry - (* match Genv.type_of_call tge (comp_of (tunnel_function f)) (Genv.find_comp ge vf) with *) + (* match Genv.type_of_call tge (comp_of (tunnel_function f)) (Genv.find_comp_in_genv ge vf) with *) (* | Genv.CrossCompartmentCall => call_regs_ext tls (funsig fd) *) (* | _ => call_regs tls *) (* end *) @@ -722,7 +722,7 @@ Proof. { apply locmap_getpairs_lessdef. apply locmap_undef_regs_lessdef. (* rewrite EQ. *) - (* destruct (Genv.type_of_call tge (comp_of (tunnel_function f)) (Genv.find_comp ge vf)). *) + (* destruct (Genv.type_of_call tge (comp_of (tunnel_function f)) (Genv.find_comp_in_genv ge vf)). *) (* apply call_regs_lessdef. auto. *) apply call_regs_ext_lessdef. auto. (* apply call_regs_lessdef. auto. *) @@ -812,8 +812,10 @@ Proof. intros (tvres & tm' & A & B & C & D). left; simpl; econstructor; split. eapply exec_function_external; eauto. + replace (call_comp ts) with (call_comp s) by (inv STK; auto; inv H; auto). eapply external_call_symbols_preserved; eauto. apply senv_preserved. - simpl. econstructor; eauto using locmap_setpair_lessdef, locmap_undef_caller_save_regs_lessdef. + replace (call_comp ts) with (call_comp s) by (inv STK; auto; inv H; auto). + econstructor; eauto using locmap_setpair_lessdef, locmap_undef_caller_save_regs_lessdef. - (* return *) inv STK. inv H1. left; econstructor; split. diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index 9aeab0e2e8..4cd1f52aa9 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -776,13 +776,13 @@ Inductive match_states: state -> state -> Prop := (MEMINJ: Mem.inject j m tm), match_states (State s f (Vptr sp Ptrofs.zero) pc rs m) (State ts f (Vptr tsp Ptrofs.zero) pc trs tm) - | match_states_call: forall s fd args m ts targs tm j + | match_states_call: forall s fd args m ts targs tm cp j (STACKS: match_stacks j s ts (Mem.nextblock m) (Mem.nextblock tm)) (KEPT: forall id, ref_fundef fd id -> kept id) (ARGINJ: Val.inject_list j args targs) (MEMINJ: Mem.inject j m tm), - match_states (Callstate s fd args m) - (Callstate ts fd targs tm) + match_states (Callstate s fd args m cp) + (Callstate ts fd targs tm cp) | match_states_return: forall s res m cp ts tres tm j (STACKS: match_stacks j s ts (Mem.nextblock m) (Mem.nextblock tm)) (RESINJ: Val.inject j res tres) @@ -791,23 +791,23 @@ Inductive match_states: state -> state -> Prop := (Returnstate ts tres tm cp). Lemma external_call_inject: - forall ef vargs m1 t vres m2 f m1' vargs', + forall ef cp vargs m1 t vres m2 f m1' vargs', meminj_preserves_globals f -> - external_call ef ge vargs m1 t vres m2 -> + external_call ef ge cp vargs m1 t vres m2 -> Mem.inject f m1 m1' -> Val.inject_list f vargs vargs' -> exists f', exists vres', exists m2', - external_call ef tge vargs' m1' t vres' m2' + external_call ef tge cp 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' - /\ (forall b : block, - ~ Mem.valid_block m1 b -> - Mem.valid_block m2 b -> - exists b' : block, f' b = Some (b', 0) /\ Mem.block_compartment m2 b = Some (comp_of ef)). + /\ inject_separated f f' m1 m1'. + (* /\ (forall b : block, *) + (* ~ Mem.valid_block m1 b -> *) + (* Mem.valid_block m2 b -> *) + (* exists b' : block, f' b = Some (b', 0) /\ Mem.block_compartment m2 b = Some (comp_of ef)). *) Proof. intros. eapply external_call_mem_inject_gen; eauto. apply globals_symbols_inject; auto. @@ -848,7 +848,7 @@ Lemma find_function_ptr_inject: exists tvf, find_function_ptr tge ros trs = Some tvf /\ Genv.allowed_call tge cp tvf /\ - Genv.find_comp ge vf = Genv.find_comp tge tvf /\ + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge tvf /\ Val.inject j vf tvf. Proof. unfold find_function. @@ -868,7 +868,7 @@ Proof. split; [| split; [| split]]; auto. { rewrite R in H2. destruct H2 as [H2 | H2]. - + left. now rewrite H2. + + left. simpl. setoid_rewrite <- D. now apply H2. + right. unfold Genv.allowed_cross_call in *. destruct H2 as [i [cp' [H21 [H22 [H23 H24]]]]]. @@ -880,7 +880,7 @@ 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. now rewrite D. + * rewrite <- H22. unfold Genv.find_comp_in_genv. now rewrite D. * apply match_prog_pol in TRANSF. unfold tge, Genv.globalenv. rewrite Genv.genv_pol_add_globals. simpl. @@ -891,7 +891,7 @@ Proof. rewrite Genv.genv_pol_add_globals. simpl. rewrite TRANSF. unfold ge, Genv.globalenv in H24. now rewrite Genv.genv_pol_add_globals in H24. } - { unfold Genv.type_of_call. unfold Genv.find_comp, Genv.find_funct. + { unfold Genv.type_of_call. unfold Genv.find_comp_in_genv, Genv.find_funct. now rewrite R. } { rewrite R. eapply Val.inject_ptr; eauto. } - destruct (Genv.find_symbol ge id) as [b|] eqn:FS; try discriminate. @@ -908,7 +908,7 @@ Proof. { rewrite <- Genv.find_funct_ptr_iff in H0. rewrite <- H0 in A. destruct H2 as [H2 | H2]. - + left. now rewrite H2. + + left. simpl. setoid_rewrite <- D. now apply H2. + right. unfold Genv.allowed_cross_call in *. destruct H2 as [i [cp' [H21 [H22 [H23 H24]]]]]. @@ -1004,7 +1004,7 @@ Lemma call_trace_translated: Val.inject j vf tvf -> meminj_preserves_globals j -> (Genv.type_of_call cp cp' = Genv.CrossCompartmentCall -> Forall not_ptr (rs##args)) -> - (Genv.find_comp ge vf = Genv.find_comp tge tvf) -> + (Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge tvf) -> call_trace ge cp cp' vf (rs##args) tyargs t -> call_trace tge cp cp' tvf (trs##args) tyargs t. Proof. @@ -1152,7 +1152,7 @@ eapply call_trace_translated; eauto. intros (vargs' & P & Q). exploit external_call_inject; eauto. eapply match_stacks_preserves_globals; eauto. - intros (j' & tv & tm' & A & B & C & D & E & F & G & I). + intros (j' & tv & tm' & A & B & C & D & E & F & G). econstructor; split. eapply exec_Ibuiltin; eauto. eapply match_states_regular with (j := j'); eauto. @@ -1207,7 +1207,7 @@ eapply call_trace_translated; eauto. - (* external function *) exploit external_call_inject; eauto. eapply match_stacks_preserves_globals; eauto. - intros (j' & tres & tm' & A & B & C & D & E & F & G & I). + intros (j' & tres & tm' & A & B & C & D & E & F & G). econstructor; split. eapply exec_function_external; eauto. (* { rewrite <- (match_stacks_call_comp _ _ _ _ _ STACKS); eauto. } *) @@ -1327,7 +1327,7 @@ Proof. apply P2. lia. - exploit init_meminj_invert; eauto. intros (A & id & B & C). subst delta. - destruct cp as [cp|]; simpl in *; trivial. + (* destruct cp as [cp|]; simpl in *; trivial. *) destruct (Genv.find_symbol_find_def_inversion _ _ B) as [g B']. assert ((prog_defmap p) ! id = Some g) as DEF1. { apply Genv.find_def_symbol. eauto. } @@ -1338,6 +1338,7 @@ Proof. destruct (IS.mem id used); try congruence. rewrite DEF1, DEF2 in DEF2'. injection DEF2' as ->. + simpl in *. rewrite (Genv.init_mem_find_def _ _ IM B') in *. now rewrite (Genv.init_mem_find_def _ _ TIM C') in *. - exploit init_meminj_invert; eauto. intros (A & id & B & C). @@ -1432,7 +1433,7 @@ Proof. exploit defs_inject. eauto. eexact Q. exact H2. intros (R & S & T). rewrite <- Genv.find_funct_ptr_iff in R. - exists (Callstate nil f nil tm); split. + exists (Callstate nil f nil tm top); split. econstructor; eauto. fold tge. erewrite match_prog_main by eauto. auto. econstructor; eauto. @@ -1480,10 +1481,10 @@ Local Transparent Linker_def Linker_fundef Linker_varinit Linker_vardef Linker_u simpl. destruct f1 as [f1|ef1], f2 as [f2|ef2]; simpl... + destruct ef2; try easy. - destruct eq_compartment; try easy. subst cp. + (* destruct eq_compartment; try easy. subst cp. *) intros H. inv H. auto. + destruct ef1; try easy. - destruct eq_compartment; try easy. subst cp. + (* destruct eq_compartment; try easy. subst cp. *) intros H. inv H. auto. + destruct (external_function_eq ef1 ef2); intuition congruence. - (* Two vardefs *) @@ -1491,7 +1492,7 @@ Local Transparent Linker_def Linker_fundef Linker_varinit Linker_vardef Linker_u unfold link_vardef. destruct v1 as [info1 c1 init1 ro1 vo1], v2 as [info2 c2 init2 ro2 vo2]; simpl. destruct (link_varinit init1 init2) as [init|] eqn:LI... - destruct eq_compartment... + destruct cp_eq_dec... destruct (eqb ro1 ro2) eqn:RO... destruct (eqb vo1 vo2) eqn:VO... simpl. diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index aca55e2f4d..b6a522cb85 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -91,31 +91,31 @@ Definition transfer_builtin (ae: aenv) (am: amem) (rm: romem) (ef: external_function) (args: list (builtin_arg reg)) (res: builtin_res reg) := match ef, args with - | EF_vload _ chunk, addr :: nil => + | EF_vload chunk, addr :: nil => let aaddr := abuiltin_arg ae am rm addr in let a := if va_strict tt then vlub (loadv chunk rm am aaddr) (vnormalize chunk (Ifptr Glob)) else vnormalize chunk Vtop in VA.State (set_builtin_res res a ae) am - | EF_vstore _ chunk, addr :: v :: nil => + | EF_vstore chunk, addr :: v :: nil => let aaddr := abuiltin_arg ae am rm addr in let av := abuiltin_arg ae am rm v in let am' := storev chunk am aaddr av in VA.State (set_builtin_res res ntop ae) (mlub am am') - | EF_memcpy _ sz al, dst :: src :: nil => + | EF_memcpy sz al, dst :: src :: nil => let adst := abuiltin_arg ae am rm dst in let asrc := abuiltin_arg ae am rm src in let p := loadbytes am rm (aptr_of_aval asrc) in let am' := storebytes am (aptr_of_aval adst) sz p in VA.State (set_builtin_res res ntop ae) am' - | (EF_annot _ _ _ _ | EF_debug _ _ _ _), _ => + | (EF_annot _ _ _ | EF_debug _ _ _), _ => VA.State (set_builtin_res res ntop ae) am - | EF_annot_val _ _ _ _, v :: nil => + | EF_annot_val _ _ _, v :: nil => let av := abuiltin_arg ae am rm v in VA.State (set_builtin_res res av ae) am - | EF_builtin cp name sg, _ => - match lookup_builtin_function name cp sg with + | EF_builtin name sg, _ => + match lookup_builtin_function name sg with | Some bf => match eval_static_builtin_function ae am rm bf args with | Some av => VA.State (set_builtin_res res av ae) am @@ -935,8 +935,8 @@ Qed. (** Construction 6: external call *) Theorem external_call_match: - forall ef (ge: genv) vargs m t vres m' bc rm am, - external_call ef ge vargs m t vres m' -> + forall ef (ge: genv) cp vargs m t vres m' bc rm am, + external_call ef ge cp vargs m t vres m' -> genv_match bc ge -> (forall v, In v vargs -> vmatch bc v Vtop) -> romatch bc m rm -> @@ -952,20 +952,20 @@ Theorem external_call_match: /\ bc_nostack bc' /\ (forall b ofs n cp, Mem.valid_block m b -> - (* forall OWN : Mem.can_access_block m b cp, *) + Mem.can_access_block m b cp -> bc b = BCinvalid -> Mem.loadbytes m' b ofs n cp = Mem.loadbytes m b ofs n cp). Proof. intros until am; intros EC GENV ARGS RO MM NOSTACK. (* Part 1: using ec_mem_inject *) - exploit (@external_call_mem_inject ef _ _ ge vargs m t vres m' (inj_of_bc bc) m vargs). + exploit (@external_call_mem_inject ef _ _ ge cp vargs m t vres m' (inj_of_bc bc) m vargs). apply inj_of_bc_preserves_globals; auto. exact EC. eapply mmatch_inj; eauto. eapply mmatch_below; eauto. revert ARGS. generalize vargs. induction vargs0; simpl; intros; constructor. eapply vmatch_inj; eauto. auto. - intros (j' & vres' & m'' & EC' & IRES & IMEM & UNCH1 & UNCH2 & IINCR & ISEP & _). + intros (j' & vres' & m'' & EC' & IRES & IMEM & UNCH1 & UNCH2 & IINCR & ISEP). assert (JBELOW: forall b, Plt b (Mem.nextblock m) -> j' b = inj_of_bc bc b). { intros. destruct (inj_of_bc bc b) as [[b' delta] | ] eqn:EQ. @@ -1065,14 +1065,16 @@ Proof. destruct (j' b); congruence. - (* unmapped blocks are invariant *) intros. - destruct (Mem.can_access_block_dec m b cp) eqn:e. + destruct (Mem.can_access_block_dec m b cp0) eqn:e. eapply Mem.loadbytes_unchanged_on_1; auto. - apply UNCH1; auto. intros; red. unfold inj_of_bc; rewrite H0; auto. - destruct (Mem.can_access_block_dec m' b cp) eqn:e'. - eapply Mem.unchanged_on_own in UNCH1; eauto. clear e'. eapply (proj2 UNCH1) in c. contradiction. - Local Transparent Mem.loadbytes. unfold Mem.loadbytes. - rewrite e, e'. simpl. rewrite 2!andb_false_r. reflexivity. - Local Opaque Mem.loadbytes. + apply UNCH1; auto. intros; red. unfold inj_of_bc; rewrite H1; auto. + contradiction. + (* destruct (Mem.can_access_block_dec m' b cp0) eqn:e'. *) + (* eapply Mem.unchanged_on_own in UNCH1; eauto. clear e'. *) + (* eapply (proj2 UNCH1) in c. contradiction. *) + (* Local Transparent Mem.loadbytes. unfold Mem.loadbytes. *) + (* rewrite e, e'. simpl. rewrite 2!andb_false_r. reflexivity. *) + (* Local Opaque Mem.loadbytes. *) Qed. (** ** Semantic invariant *) @@ -1098,7 +1100,7 @@ Inductive sound_stack: block_classification -> list stackframe -> mem -> block - (GE: genv_match bc' ge) (AN: VA.ge (analyze rm f)!!pc (VA.State (AE.set res Vtop ae) mafter_public_call)) (EM: ematch bc' e ae) - (ACC: Mem.can_access_block m sp (Some (comp_of f))), + (ACC: Mem.can_access_block m sp (comp_of f)), sound_stack bc (Stackframe res ty f (Vptr sp Ptrofs.zero) pc e :: stk) m bound | sound_stack_private_call: forall (bc: block_classification) res ty f sp pc e stk m bound bc' bound' ae am @@ -1111,7 +1113,7 @@ Inductive sound_stack: block_classification -> list stackframe -> mem -> block - (GE: genv_match bc' ge) (AN: VA.ge (analyze rm f)!!pc (VA.State (AE.set res (Ifptr Nonstack) ae) (mafter_private_call am))) (EM: ematch bc' e ae) - (ACC: Mem.can_access_block m sp (Some (comp_of f))) + (ACC: Mem.can_access_block m sp (comp_of f)) (CONTENTS: bmatch bc' m sp am.(am_stack)), sound_stack bc (Stackframe res ty f (Vptr sp Ptrofs.zero) pc e :: stk) m bound. @@ -1125,17 +1127,17 @@ Inductive sound_state_base: state -> Prop := (MM: mmatch bc m am) (GE: genv_match bc ge) (SP: bc sp = BCstack) - (ACC: Mem.can_access_block m sp (Some (comp_of f))), + (ACC: Mem.can_access_block m sp (comp_of f)), sound_state_base (State s f (Vptr sp Ptrofs.zero) pc e m) | sound_call_state: - forall s fd args m bc + forall s fd args m cp bc (STK: sound_stack bc s m (Mem.nextblock m)) (ARGS: forall v, In v args -> vmatch bc v Vtop) (RO: romatch bc m rm) (MM: mmatch bc m mtop) (GE: genv_match bc ge) (NOSTK: bc_nostack bc), - sound_state_base (Callstate s fd args m) + sound_state_base (Callstate s fd args m cp) | sound_return_state: forall s v m cp bc (STK: sound_stack bc s m (Mem.nextblock m)) @@ -1273,7 +1275,7 @@ Lemma sound_succ_state: genv_match bc ge -> bc sp = BCstack -> sound_stack bc s m' sp -> - Mem.can_access_block m' sp (Some (comp_of f)) -> + Mem.can_access_block m' sp (comp_of f) -> sound_state_base (State s f (Vptr sp Ptrofs.zero) pc' e' m'). Proof. intros. exploit analyze_succ; eauto. intros (ae'' & am'' & AN & EM & MM). @@ -1383,7 +1385,7 @@ Proof. rewrite K; auto. intros. rewrite K; auto. rewrite C; auto. apply bmatch_inv with m. eapply mmatch_stack; eauto. - intros. apply Q; auto. + intros. apply Q; eauto. eapply external_call_nextblock; eauto. intros (bc3 & U & V & W & X & Y & Z & AA). eapply sound_succ_state with (bc := bc3); eauto. simpl; auto. diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v index 152ab655b8..0a780b5cd2 100644 --- a/backend/ValueDomain.v +++ b/backend/ValueDomain.v @@ -3317,22 +3317,7 @@ Proof. - right. rewrite <- H0. symmetry. eapply Mem.loadbytes_storebytes_other; eauto. lia. - subst b'. left. eapply loadbytes_provenance; eauto. - destruct cp' as [cp' |]. - + assert (cp = cp'). - { Local Transparent Mem.storebytes Mem.loadbytes. - unfold Mem.storebytes, Mem.loadbytes in *. - destruct (Mem.range_perm_dec m b ofs (ofs + Z.of_nat (Datatypes.length bytes)) Cur Writable); - try discriminate. - destruct (Mem.can_access_block_dec m b (Some cp)) as [ACC | ACC]; try discriminate. - destruct (Mem.range_perm_dec m' b ofs' (ofs' + 1) Cur Readable); - try discriminate. - destruct (Mem.can_access_block_dec m' b (Some cp')) as [ACC' | ACC']; try discriminate. - simpl in *. inv H. unfold Mem.block_compartment in ACC'. simpl in ACC'. - unfold Mem.block_compartment in ACC. congruence. - Local Opaque Mem.storebytes Mem.loadbytes. } - subst. - eapply Mem.loadbytes_storebytes_same; eauto. - + eapply Mem.loadbytes_storebytes_same_None; eauto. + exploit Mem.loadbytes_change_comp; eauto. lia. Qed. Lemma store_provenance: @@ -4436,10 +4421,13 @@ Proof. intros. exploit inj_of_bc_inv; eauto. intros (A & B & C); subst. rewrite Z.add_0_r. set (mv := ZMap.get ofs (PMap.get b1 (Mem.mem_contents m))). - assert (Mem.loadbytes m b1 ofs 1 None = Some (mv :: nil)). + assert (Mem.loadbytes m b1 ofs 1 top = Some (mv :: nil)). { Local Transparent Mem.loadbytes. - unfold Mem.loadbytes. simpl. rewrite andb_true_r. + unfold Mem.loadbytes. simpl. + destruct (Mem.can_access_block_dec) as [E | NE]; simpl in *; + pose proof (flowsto_top (Mem.block_compartment m b1)); try congruence. + rewrite andb_true_r. destruct ((Mem.range_perm_dec m b1 ofs (ofs + 1) Cur Readable)); try reflexivity. exfalso; apply n. red; intros. replace ofs0 with ofs by lia. auto. diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index 7b20544234..d6ef78420e 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -108,7 +108,7 @@ Definition Epreincr (id: incr_or_decr) (l: expr) (ty: type) := Definition Eselection (cp: compartment) (r1 r2 r3: expr) (ty: type) := let t := typ_of_type ty in let sg := mksignature (AST.Tint :: t :: t :: nil) t cc_default in - Ebuiltin (EF_builtin cp "__builtin_sel"%string sg) + Ebuiltin (EF_builtin "__builtin_sel"%string sg) (Tcons type_bool (Tcons ty (Tcons ty Tnil))) (Econs r1 (Econs r2 (Econs r3 Enil))) ty. diff --git a/common/Events.v b/common/Events.v index f0ac614089..487f84c6bd 100644 --- a/common/Events.v +++ b/common/Events.v @@ -709,7 +709,7 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : forall ge vargs m1 t vres m2 b ofs n bytes ocp, sem ge cp vargs m1 t vres m2 -> Mem.valid_block m1 b -> - Mem.can_access_block m1 b ocp -> + (* Mem.can_access_block m1 b ocp -> *) Mem.loadbytes m2 b ofs n ocp = Some bytes -> (forall i, ofs <= i < ofs + n -> ~Mem.perm m1 b i Max Writable) -> Mem.loadbytes m1 b ofs n ocp = Some bytes; @@ -1062,6 +1062,10 @@ Proof. - inv H. inv H2. auto. eauto with mem. (* readonly *) - inv H. eapply unchanged_on_readonly; eauto. eapply volatile_store_readonly; eauto. + inv H3; eauto. + + eapply Mem.loadbytes_can_access_block_inj; eauto. + + simpl. erewrite <- Mem.store_block_compartment; eauto. + eapply Mem.loadbytes_can_access_block_inj; eauto. (* (* mem alloc *) *) (* - inv H. inv H2. congruence. *) @@ -1140,6 +1144,12 @@ Proof. apply Mem.valid_not_valid_diff with m1; eauto with mem. (* readonly *) - inv H. eapply unchanged_on_readonly; eauto. + assert (b <> b0). + { intros ?; subst b0. + exploit Mem.fresh_block_alloc; eauto. } + eapply Mem.alloc_can_access_block_other_inj_2; eauto. + simpl. erewrite <- Mem.store_block_compartment; eauto. + eapply Mem.loadbytes_can_access_block_inj; eauto. (* (* mem alloc *) *) (* - inv H. *) @@ -1239,10 +1249,14 @@ Proof. (* readonly *) - eapply unchanged_on_readonly; eauto. inv H. + eapply Mem.free_unchanged_on; eauto. - intros. red; intros. elim H7. + intros. red; intros. elim H6. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.free_range_perm; eauto. + apply Mem.unchanged_on_refl. ++ inv H. + * eapply Mem.free_can_access_block_inj_2; eauto. + eapply Mem.loadbytes_can_access_block_inj; eauto. + * eapply Mem.loadbytes_can_access_block_inj; eauto. (* (* mem alloc *) *) (* - inv H; try congruence. *) (* exploit Mem.valid_block_free_2; eauto. congruence. *) @@ -1366,8 +1380,10 @@ Proof. - (* readonly *) intros. inv H. eapply unchanged_on_readonly; eauto. eapply Mem.storebytes_unchanged_on; eauto. - intros; red; intros. elim H12. + intros; red; intros. elim H11. apply Mem.perm_cur_max. eapply Mem.storebytes_range_perm; eauto. + eapply Mem.storebytes_can_access_block_inj_2; eauto. + eapply Mem.loadbytes_can_access_block_inj; eauto. (* - (* new blocks *) *) (* intros. *) (* inv H. *) diff --git a/common/Memory.v b/common/Memory.v index fac31447a0..5a0f040891 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -1953,6 +1953,21 @@ Proof. apply storebytes_can_access_block_inj_1; eassumption. Qed. +Theorem loadbytes_change_comp: + forall ofs' z cp' v', + 0 < z -> + loadbytes m2 b ofs' z cp' = Some v' -> + loadbytes m2 b ofs (Z.of_nat (length bytes)) cp' = Some bytes. +Proof. + intros ofs' z cp' v' z0 H. + pose proof loadbytes_storebytes_same as G. + unfold loadbytes in *. + destruct andb eqn:E1; try congruence. apply andb_prop in E1 as [E1 E1']. + destruct andb eqn:E2; try congruence. apply andb_prop in E2 as [E2 E2']. + destruct andb eqn:E3; try congruence. apply andb_false_iff in E3 as [E3 | E3]; + congruence. +Qed. + Theorem loadbytes_storebytes_same_None: loadbytes m2 b ofs (Z.of_nat (length bytes)) top = Some bytes. Proof. From 7f7516f1d8975f5c59811397f3033c869ef62e86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 27 Nov 2023 11:53:22 +0000 Subject: [PATCH 13/83] [Compartments] Fix RTL optimizations passes (except ValueAnalysis) and Allocation pass --- backend/Allocproof.v | 39 ++++++++++++++++--------------- backend/CSE.v | 12 +++++----- backend/CSEproof.v | 38 +++++++++++++++--------------- backend/Constprop.v | 6 ++--- backend/Constpropproof.v | 22 +++++++++--------- backend/Deadcode.v | 12 +++++----- backend/Deadcodeproof.v | 50 ++++++++++++++++++++++------------------ backend/LTL.v | 23 +++++++++--------- backend/ValueAnalysis.v | 10 +++++--- 9 files changed, 112 insertions(+), 100 deletions(-) diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 3a359fc418..c44d367134 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -33,7 +33,7 @@ Proof. destruct type_function; try easy. destruct regalloc; try easy. destruct analyze; try easy. - destruct eq_compartment as [e|?]; try easy. + destruct cp_eq_dec as [e|?]; try easy. monadInv H. exact e. Qed. @@ -47,7 +47,7 @@ Proof. - destruct type_function; try easy. destruct regalloc; try easy. destruct analyze; try easy. - destruct eq_compartment as [e|?]; try easy. + destruct cp_eq_dec as [e|?]; try easy. monadInv H. monadInv EQ. exact e. - now inv H. @@ -2297,20 +2297,20 @@ Proof. Qed. Lemma add_equations_builtin_eval: - forall ef env args args' e1 e2 m1 m1' rs ls (ge: RTL.genv) sp vargs t vres m2, + forall ef cp env args args' e1 e2 m1 m1' rs ls (ge: RTL.genv) sp vargs t vres m2, wt_regset env rs -> match ef with - | EF_debug _ _ _ _ => add_equations_debug_args env args args' e1 + | EF_debug _ _ _ => add_equations_debug_args env args args' e1 | _ => add_equations_builtin_args env args args' e1 end = Some e2 -> Mem.extends m1 m1' -> satisf rs ls e2 -> eval_builtin_args ge (fun r => rs # r) sp m1 args vargs -> - external_call ef ge vargs m1 t vres m2 -> + external_call ef ge cp vargs m1 t vres m2 -> satisf rs ls e1 /\ exists vargs' vres' m2', eval_builtin_args ge ls sp m1' args' vargs' - /\ external_call ef ge vargs' m1' t vres' m2' + /\ external_call ef ge cp vargs' m1' t vres' m2' /\ Val.lessdef vres vres' /\ Mem.extends m2 m2'. Proof. @@ -2319,7 +2319,7 @@ Proof. satisf rs ls e1 /\ exists vargs' vres' m2', eval_builtin_args ge ls sp m1' args' vargs' - /\ external_call ef ge vargs' m1' t vres' m2' + /\ external_call ef ge cp vargs' m1' t vres' m2' /\ Val.lessdef vres vres' /\ Mem.extends m2 m2'). { @@ -2428,7 +2428,7 @@ Proof. destruct (check_function f f0 env) as [] eqn:?; inv H. unfold check_function in Heqr. destruct (analyze f env (pair_codes f tf)) as [an|] eqn:?; try discriminate. - destruct eq_compartment as [e|]; try discriminate. + destruct cp_eq_dec as [e|]; try discriminate. monadInv Heqr. destruct (check_entrypoints_aux f tf env x) as [y|] eqn:?; try discriminate. unfold check_entrypoints_aux, pair_entrypoints in Heqo0. MonadInv. @@ -2551,9 +2551,9 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. - eapply (Genv.match_genvs_find_comp TRANSF). + eapply (Genv.match_genvs_find_comp_in_genv TRANSF). Qed. Lemma exec_moves: @@ -2653,15 +2653,15 @@ Inductive match_states: RTL.state -> LTL.state -> Prop := match_states (RTL.State s f sp pc rs m) (LTL.State ts tf sp pc ls m') | match_states_call: - forall s f args m ts tf ls m' + forall s f args m ts tf ls m' cp (STACKS: match_stackframes s ts (funsig tf)) (FUN: transf_fundef f = OK tf) (ARGS: Val.lessdef_list args (map (fun p => Locmap.getpair p ls) (loc_arguments (funsig tf)))) (AG: agree_callee_save (parent_locset ts) ls) (MEM: Mem.extends m m') (WTARGS: Val.has_type_list args (sig_args (funsig tf))), - match_states (RTL.Callstate s f args m) - (LTL.Callstate ts tf (funsig tf) ls m') + match_states (RTL.Callstate s f args m cp) + (LTL.Callstate ts tf (funsig tf) ls m' cp) | match_states_return: forall s res m ts ls m' sg cp (STACKS: match_stackframes s ts sg) @@ -2864,7 +2864,7 @@ Proof. exploit eval_addressing_lessdef. eexact LD3. eapply eval_offset_addressing; eauto; apply Archi.splitlong_ptr32; auto. intros [a2' [F2 G2]]. - assert (LOADX: exists v2'', Mem.loadv Mint32 m' a2' (Some (comp_of f)) = Some v2'' /\ Val.lessdef v2' v2''). + assert (LOADX: exists v2'', Mem.loadv Mint32 m' a2' (comp_of f) = Some v2'' /\ Val.lessdef v2' v2''). { discriminate || (eapply Mem.loadv_extends; [eauto|eexact LOAD2|eexact G2]). } destruct LOADX as (v2'' & LOAD2' & LD4). set (ls4 := Locmap.set (R dst2') v2'' (undef_regs (destroyed_by_load Mint32 addr2) ls3)). @@ -2935,7 +2935,7 @@ Proof. exploit eval_addressing_lessdef. eexact LD1. eapply eval_offset_addressing; eauto; apply Archi.splitlong_ptr32; auto. intros [a1' [F1 G1]]. - assert (LOADX: exists v2'', Mem.loadv Mint32 m' a1' (Some (comp_of f)) = Some v2'' /\ Val.lessdef v2' v2''). + assert (LOADX: exists v2'', Mem.loadv Mint32 m' a1' (comp_of f) = Some v2'' /\ Val.lessdef v2' v2''). { discriminate || (eapply Mem.loadv_extends; [eauto|eexact LOAD2|eexact G1]). } destruct LOADX as (v2'' & LOAD2' & LD2). set (ls2 := Locmap.set (R dst') v2'' (undef_regs (destroyed_by_load Mint32 addr2) ls1)). @@ -3173,7 +3173,7 @@ Proof. } traceEq. traceEq. exploit analyze_successors; eauto. simpl. left; eauto. intros [enext [U V]]. - rewrite <- SIG. + rewrite <- SIG. rewrite comp_transf_function; eauto. econstructor; eauto. { econstructor; eauto. @@ -3210,7 +3210,7 @@ Proof. rewrite <- comp_transf_function; eauto. destruct (transf_function_inv _ _ FUN); auto. eauto. traceEq. - rewrite <- SIG'. + rewrite <- SIG'. rewrite comp_transf_function; eauto. econstructor; eauto. eapply match_stackframes_change_sig; eauto. rewrite SIG'. rewrite e0. decEq. destruct (transf_function_inv _ _ FUN); auto. @@ -3234,8 +3234,9 @@ Proof. eapply star_trans. eexact A1. eapply star_left. econstructor. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + rewrite <- comp_transf_function; eauto. eapply external_call_symbols_preserved. apply senv_preserved. eauto. - eauto. rewrite <- comp_transf_function; eauto. + eauto. eapply star_right. eexact A3. econstructor. reflexivity. reflexivity. reflexivity. traceEq. @@ -3395,7 +3396,7 @@ Proof. intros. inv H. exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. exploit sig_function_translated; eauto. intros SIG. - exists (LTL.Callstate nil tf signature_main (Locmap.init Vundef) m0); split. + exists (LTL.Callstate nil tf signature_main (Locmap.init Vundef) m0 top); split. econstructor; eauto. eapply (Genv.init_mem_transf_partial TRANSF); eauto. rewrite symbols_preserved. diff --git a/backend/CSE.v b/backend/CSE.v index b33fdb996f..dc772798c9 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -471,16 +471,16 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb empty_numbering | Ibuiltin ef args res s => match ef with - | EF_external _ _ _ | EF_runtime _ _ _ | EF_malloc _ | EF_free _ | EF_inline_asm _ _ _ _ => + | EF_external _ _ | EF_runtime _ _ | EF_malloc | EF_free | EF_inline_asm _ _ _ => empty_numbering - | EF_vstore _ _ => + | EF_vstore _ => set_res_unknown (kill_all_loads before) res - | EF_builtin cp name sg => - match lookup_builtin_function name cp sg with + | EF_builtin name sg => + match lookup_builtin_function name sg with | Some bf => set_res_unknown before res | None => set_res_unknown (kill_all_loads before) res end - | EF_memcpy _ sz al => + | EF_memcpy sz al => match args with | dst :: src :: nil => let app := approx!!pc in @@ -491,7 +491,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb | _ => empty_numbering end - | EF_vload _ _ | EF_annot _ _ _ _ | EF_annot_val _ _ _ _ | EF_debug _ _ _ _ => + | EF_vload _ | EF_annot _ _ _ | EF_annot_val _ _ _ | EF_debug _ _ _ => set_res_unknown before res end | Icond cond args ifso ifnot => diff --git a/backend/CSEproof.v b/backend/CSEproof.v index a56988ac78..ad6d4aa145 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -542,7 +542,7 @@ Proof. eapply Pos.lt_le_trans; eauto. red; simpl; intros. auto. + destruct H4; eauto with cse. subst eq. apply eq_holds_lessdef with (Val.load_result chunk rs#src). - apply load_eval_to with a (Some cp). rewrite <- Q; auto. + apply load_eval_to with a cp. rewrite <- Q; auto. destruct a; try discriminate. simpl. eapply Mem.load_store_same; eauto. rewrite B. rewrite R by auto. apply store_normalized_range_sound with bc. rewrite <- B. eapply vmatch_ge. apply vincl_ge; eauto. apply H2. @@ -587,7 +587,7 @@ Lemma load_memcpy: Mem.load chunk m b1 i cp1 = Some v -> ofs1 <= i -> i + size_chunk chunk <= ofs1 + sz -> (align_chunk chunk | ofs2 - ofs1) -> - Mem.load chunk m' b2 (i + (ofs2 - ofs1)) (Some cp2) = Some v. + Mem.load chunk m' b2 (i + (ofs2 - ofs1)) cp2 = Some v. Proof. intros. generalize (size_chunk_pos chunk); intros SPOS. @@ -618,9 +618,9 @@ Proof. assert (L2: Z.of_nat (length bytes2) = n2). { erewrite Mem.loadbytes_length by eauto. apply Z2Nat.id. unfold n2; lia. } rewrite L1 in *. rewrite L2 in *. - assert (LB': Mem.loadbytes m2 b2 (ofs2 + n1) n2 (Some cp2) = Some bytes2). + assert (LB': Mem.loadbytes m2 b2 (ofs2 + n1) n2 cp2 = Some bytes2). { rewrite <- L2. eapply Mem.loadbytes_storebytes_same; eauto. } - assert (LB'': Mem.loadbytes m' b2 (ofs2 + n1) n2 (Some cp2) = Some bytes2). + assert (LB'': Mem.loadbytes m' b2 (ofs2 + n1) n2 cp2 = Some bytes2). { rewrite <- LB'. eapply Mem.loadbytes_storebytes_other; eauto. unfold n2; lia. right; left; lia. } @@ -650,7 +650,7 @@ Qed. Lemma shift_memcpy_eq_holds: forall src dst sz cp e e' m sp bytes m' valu ge, shift_memcpy_eq src sz (dst - src) e = Some e' -> - Mem.loadbytes m sp src sz (Some cp) = Some bytes -> + Mem.loadbytes m sp src sz cp = Some bytes -> Mem.storebytes m sp dst bytes cp = Some m' -> equation_holds valu ge (Vptr sp Ptrofs.zero) m e -> equation_holds valu ge (Vptr sp Ptrofs.zero) m' e'. @@ -668,8 +668,8 @@ Proof with (try discriminate). destruct (zle j Ptrofs.max_unsigned)... simpl in H; inv H. assert (LD: forall v, - Mem.loadv chunk m (Vptr sp ofs) (Some cp) = Some v -> - Mem.loadv chunk m' (Vptr sp (Ptrofs.repr j)) (Some cp) = Some v). + Mem.loadv chunk m (Vptr sp ofs) cp = Some v -> + Mem.loadv chunk m' (Vptr sp (Ptrofs.repr j)) cp = Some v). { simpl; intros. rewrite Ptrofs.unsigned_repr by lia. unfold j, delta. eapply load_memcpy; eauto. @@ -685,7 +685,7 @@ Proof with (try discriminate). simpl. simpl in H7. Local Transparent Mem.load. Local Transparent Mem.loadbytes. unfold Mem.load. unfold Mem.load in H7. unfold Mem.loadbytes in H0. - destruct (Mem.valid_access_dec m chunk sp (Ptrofs.unsigned ofs) Readable (Some cp)). + destruct (Mem.valid_access_dec m chunk sp (Ptrofs.unsigned ofs) Readable cp). * destruct v as [v1 [v2 v3]]. destruct (Mem.valid_access_dec m chunk sp (Ptrofs.unsigned ofs) Readable cp0); try discriminate. @@ -696,7 +696,7 @@ Proof with (try discriminate). try discriminate. destruct v as [v1 [v2 v3]]; contradiction. -- apply Classical_Prop.not_and_or in n as [n | n]. - ++ destruct (Mem.can_access_block_dec m sp (Some cp)); try contradiction. + ++ destruct (Mem.can_access_block_dec m sp cp); try contradiction. simpl in H0. rewrite andb_false_r in H0. discriminate. ++ destruct (Mem.valid_access_dec m chunk sp (Ptrofs.unsigned ofs) Readable cp0); try discriminate. @@ -711,7 +711,7 @@ Proof with (try discriminate). simpl. simpl in H8. Local Transparent Mem.load. Local Transparent Mem.loadbytes. unfold Mem.load. unfold Mem.load in H8. unfold Mem.loadbytes in H0. - destruct (Mem.valid_access_dec m chunk sp (Ptrofs.unsigned ofs) Readable (Some cp)). + destruct (Mem.valid_access_dec m chunk sp (Ptrofs.unsigned ofs) Readable cp). * destruct v0 as [v1 [v2 v3]]. destruct (Mem.valid_access_dec m chunk sp (Ptrofs.unsigned ofs) Readable cp0); try discriminate. @@ -722,7 +722,7 @@ Proof with (try discriminate). try discriminate. destruct v0 as [v1 [v2 v3]]; contradiction. -- apply Classical_Prop.not_and_or in n as [n | n]. - ++ destruct (Mem.can_access_block_dec m sp (Some cp)); try contradiction. + ++ destruct (Mem.can_access_block_dec m sp cp); try contradiction. simpl in H0. rewrite andb_false_r in H0. discriminate. ++ destruct (Mem.valid_access_dec m chunk sp (Ptrofs.unsigned ofs) Readable cp0); try discriminate. @@ -745,7 +745,7 @@ Qed. Lemma add_memcpy_holds: forall m bsrc osrc sz cp bytes bdst odst (* cp' *) m' valu ge sp rs n1 n2 bc asrc adst, - Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz (Some cp) = Some bytes -> + Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz cp = Some bytes -> Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes cp = Some m' -> numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m n1 -> numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m' n2 -> @@ -983,10 +983,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. intros vf. - eapply (Genv.match_genvs_find_comp TRANSF). + eapply (Genv.match_genvs_find_comp_in_genv TRANSF). Qed. (** The proof of semantic preservation is a simulation argument using @@ -1042,14 +1042,14 @@ Inductive match_states: state -> state -> Prop := match_states (State s f sp pc rs m) (State s' (transf_function' f approx) sp pc rs' m') | match_states_call: - forall s f tf args m s' args' m' cu + forall s f tf args m cp s' args' m' cu (LINK: linkorder cu prog) (STACKS: match_stackframes s s') (TFD: transf_fundef (romem_for cu) f = OK tf) (ARGS: Val.lessdef_list args args') (MEXT: Mem.extends m m'), - match_states (Callstate s f args m) - (Callstate s' tf args' m') + match_states (Callstate s f args m cp) + (Callstate s' tf args' m' cp) | match_states_return: forall s s' v v' m m' cp (STACK: match_stackframes s s') @@ -1258,7 +1258,7 @@ Proof. { exists valu. apply set_res_unknown_holds. eapply kill_all_loads_hold; eauto. } destruct ef. + apply CASE1. - + destruct (lookup_builtin_function name cp sg) as [bf|] eqn:LK. + + destruct (lookup_builtin_function name sg) as [bf|] eqn:LK. ++ apply CASE2. simpl in H1; red in H1; rewrite LK in H1; inv H1. auto. ++ apply CASE3. + apply CASE1. @@ -1354,7 +1354,7 @@ Lemma transf_initial_states: Proof. intros. inversion H. exploit funct_ptr_translated; eauto. intros (cu & tf & A & B & C). - exists (Callstate nil tf nil m0); split. + exists (Callstate nil tf nil m0 top); split. econstructor; eauto. eapply (Genv.init_mem_match TRANSF); eauto. replace (prog_main tprog) with (prog_main prog). diff --git a/backend/Constprop.v b/backend/Constprop.v index fbeadd8635..c643f044ef 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -135,7 +135,7 @@ Fixpoint debug_strength_reduction (ae: AE.t) (al: list (builtin_arg reg)) := Definition builtin_strength_reduction (ae: AE.t) (ef: external_function) (al: list (builtin_arg reg)) := match ef with - | EF_debug _ _ _ _ => debug_strength_reduction ae al + | EF_debug _ _ _ => debug_strength_reduction ae al | _ => builtin_args_strength_reduction ae al (Machregs.builtin_constraints ef) end. @@ -202,8 +202,8 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem) | Ibuiltin ef args res s => let dfl := Ibuiltin ef (builtin_strength_reduction ae ef args) res s in match ef, res with - | EF_builtin cp name sg, BR rd => - match lookup_builtin_function name cp sg with + | EF_builtin name sg, BR rd => + match lookup_builtin_function name sg with | Some bf => match eval_static_builtin_function ae am rm bf args with | Some a => diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 48a3f81e56..75c67b45ca 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -97,10 +97,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. intros vf. - eapply (Genv.match_genvs_find_comp TRANSL). + eapply (Genv.match_genvs_find_comp_in_genv TRANSL). Qed. Lemma init_regs_lessdef: @@ -298,19 +298,19 @@ Proof. Qed. Lemma builtin_strength_reduction_correct: - forall sp bc ae rs ef args vargs m t vres m', + forall cp sp bc ae rs ef args vargs m t vres m', ematch bc rs ae -> eval_builtin_args ge (fun r => rs#r) sp m args vargs -> - external_call ef ge vargs m t vres m' -> + external_call ef ge cp vargs m t vres m' -> exists vargs', eval_builtin_args ge (fun r => rs#r) sp m (builtin_strength_reduction ae ef args) vargs' - /\ external_call ef ge vargs' m t vres m'. + /\ external_call ef ge cp vargs' m t vres m'. Proof. intros. assert (DEFAULT: forall cl, exists vargs', eval_builtin_args ge (fun r => rs#r) sp m (builtin_args_strength_reduction ae args cl) vargs' - /\ external_call ef ge vargs' m t vres m'). + /\ external_call ef ge cp vargs' m t vres m'). { exists vargs; split; auto. eapply builtin_args_strength_reduction_correct; eauto. } unfold builtin_strength_reduction. destruct ef; auto. @@ -365,13 +365,13 @@ Inductive match_states: nat -> state -> state -> Prop := match_states n (State s f sp pc rs m) (State s' (transf_function (romem_for cu) f) sp pc' rs' m') | match_states_call: - forall s f args m s' args' m' cu + forall s f args m cp s' args' m' cu (LINK: linkorder cu prog) (STACKS: list_forall2 match_stackframes s s') (ARGS: Val.lessdef_list args args') (MEM: Mem.extends m m'), - match_states O (Callstate s f args m) - (Callstate s' (transf_fundef (romem_for cu) f) args' m') + match_states O (Callstate s f args m cp) + (Callstate s' (transf_fundef (romem_for cu) f) args' m' cp) | match_states_return: forall s v m cp s' v' m' (STACKS: list_forall2 match_stackframes s s') @@ -603,7 +603,7 @@ Opaque builtin_strength_reduction. } destruct ef; auto. destruct res; auto. - destruct (lookup_builtin_function name cp sg) as [bf|] eqn:LK; auto. + destruct (lookup_builtin_function name sg) as [bf|] eqn:LK; auto. destruct (eval_static_builtin_function ae am rm bf args) as [a|] eqn:ES; auto. destruct (const_for_result a) as [cop|] eqn:CR; auto. clear DFL. simpl in H1; red in H1; rewrite LK in H1; inv H1. @@ -695,7 +695,7 @@ Lemma transf_initial_states: Proof. intros. inversion H. exploit function_ptr_translated; eauto. intros (cu & FIND & LINK). - exists O; exists (Callstate nil (transf_fundef (romem_for cu) f) nil m0); split. + exists O; exists (Callstate nil (transf_fundef (romem_for cu) f) nil m0 top); split. econstructor; eauto. apply (Genv.init_mem_match TRANSL); auto. replace (prog_main tprog) with (prog_main prog). diff --git a/backend/Deadcode.v b/backend/Deadcode.v index 2cc96d6983..9887b5096b 100644 --- a/backend/Deadcode.v +++ b/backend/Deadcode.v @@ -85,26 +85,26 @@ Function transfer_builtin (app: VA.t) (ef: external_function) (args: list (builtin_arg reg)) (res: builtin_res reg) (ne: NE.t) (nm: nmem) : NA.t := match ef, args with - | EF_vload _ chunk, a1::nil => + | EF_vload chunk, a1::nil => transfer_builtin_arg All (kill_builtin_res res ne, nmem_add nm (aaddr_arg app a1) (size_chunk chunk)) a1 - | EF_vstore _ chunk, a1::a2::nil => + | EF_vstore chunk, a1::a2::nil => transfer_builtin_arg All (transfer_builtin_arg (store_argument chunk) (kill_builtin_res res ne, nm) a2) a1 - | EF_memcpy _ sz al, dst::src::nil => + | EF_memcpy sz al, dst::src::nil => if nmem_contains nm (aaddr_arg app dst) sz then transfer_builtin_args (kill_builtin_res res ne, nmem_add (nmem_remove nm (aaddr_arg app dst) sz) (aaddr_arg app src) sz) args else (ne, nm) - | (EF_annot _ _ _ _ | EF_annot_val _ _ _ _), _ => + | (EF_annot _ _ _ | EF_annot_val _ _ _), _ => transfer_builtin_args (kill_builtin_res res ne, nm) args - | EF_debug _ _ _ _, _ => + | EF_debug _ _ _, _ => (kill_builtin_res res ne, nm) | _, _ => transfer_builtin_args (kill_builtin_res res ne, nmem_all) args @@ -188,7 +188,7 @@ Definition transf_instr (approx: PMap.t VA.t) (an: PMap.t NA.t) if nmem_contains (snd an!!pc) p (size_chunk chunk) then instr else Inop s - | Ibuiltin (EF_memcpy _ sz al) (dst :: src :: nil) res s => + | Ibuiltin (EF_memcpy sz al) (dst :: src :: nil) res s => if nmem_contains (snd an!!pc) (aaddr_arg approx!!pc dst) sz then instr else Inop s diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v index f5225cd9c0..4656e7ef1e 100644 --- a/backend/Deadcodeproof.v +++ b/backend/Deadcodeproof.v @@ -453,10 +453,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. intros vf. - eapply (Genv.match_genvs_find_comp TRANSF). + eapply (Genv.match_genvs_find_comp_in_genv TRANSF). Qed. Lemma sig_function_translated: @@ -615,14 +615,14 @@ Inductive match_states: state -> state -> Prop := match_states (State s f (Vptr sp Ptrofs.zero) pc e m) (State ts tf (Vptr sp Ptrofs.zero) pc te tm) | match_call_states: - forall s f args m ts tf targs tm cu + forall s f args m cp ts tf targs tm cu (STACKS: list_forall2 match_stackframes s ts) (LINK: linkorder cu prog) (FUN: transf_fundef (romem_for cu) f = OK tf) (ARGS: Val.lessdef_list args targs) (MEM: Mem.extends m tm), - match_states (Callstate s f args m) - (Callstate ts tf targs tm) + match_states (Callstate s f args m cp) + (Callstate ts tf targs tm cp) | match_return_states: forall s v m cp ts tv tm (STACKS: list_forall2 match_stackframes s ts) @@ -797,12 +797,12 @@ Qed. Lemma transf_volatile_store: forall cp v1 v2 v1' v2' m tm chunk sp nm t v m', - volatile_store_sem cp chunk ge (v1::v2::nil) m t v m' -> + volatile_store_sem chunk ge cp (v1::v2::nil) m t v m' -> Val.lessdef v1 v1' -> vagree v2 v2' (store_argument chunk) -> magree m tm (nlive ge sp nm) -> v = Vundef /\ - exists tm', volatile_store_sem cp chunk ge (v1'::v2'::nil) tm t Vundef tm' + exists tm', volatile_store_sem chunk ge cp (v1'::v2'::nil) tm t Vundef tm' /\ magree m' tm' (nlive ge sp nm). Proof. intros. inv H. split; auto. @@ -994,9 +994,10 @@ Ltac UseTransfer := + eapply add_need_all_eagree in AG. eauto. } eapply H1; eauto. eapply NO_CROSS_PTR. rewrite (comp_transl_partial _ B). - rewrite comp_transf_function; eauto. + erewrite comp_transf_function; eauto. rewrite <- (comp_transl_partial _ B), <- comp_transf_function; eauto. eapply call_trace_translated; eauto. + erewrite comp_transf_function; eauto. eapply match_call_states with (cu := cu'); eauto. constructor; auto. eapply match_stackframes_intro with (cu := cu); eauto. intros. @@ -1018,6 +1019,7 @@ Ltac UseTransfer := rewrite <- (comp_transl_partial _ B), COMP. now apply (comp_transl_partial _ FUN). erewrite stacksize_translated by eauto. rewrite <- comp_transf_function; eauto. + erewrite comp_transf_function; eauto. eapply match_call_states with (cu := cu'); eauto 2 with na. eapply magree_extends; eauto. apply nlive_all. @@ -1033,7 +1035,7 @@ Ltac UseTransfer := (size_chunk chunk)) a1) as (ne1, nm1) eqn: TR. InvSoundState. exploit transfer_builtin_arg_sound; eauto. intros (tv1 & A & B & C & D). - unfold comp_of in ALLOWED; simpl in ALLOWED; subst _x. + (* unfold comp_of in ALLOWED; simpl in ALLOWED; subst _x. *) inv H1. simpl in B. inv B. assert (X: exists tvres, volatile_load ge (comp_of f) chunk tm b ofs t tvres /\ Val.lessdef vres tvres). { @@ -1048,11 +1050,11 @@ Ltac UseTransfer := } destruct X as (tvres & P & Q). econstructor; split. - eapply exec_Ibuiltin; eauto. - unfold comp_of. simpl. rewrite comp_transf_function; eauto. + eapply exec_Ibuiltin; eauto. simpl. + (* rewrite comp_transf_function; eauto. *) apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. constructor. eauto. constructor. - rewrite comp_transf_function; eauto. + (* rewrite comp_transf_function; eauto. *) eapply external_call_symbols_preserved. apply senv_preserved. constructor. rewrite <- comp_transf_function; eauto. eapply match_succ_states; eauto. simpl; auto. @@ -1071,11 +1073,11 @@ Ltac UseTransfer := exploit transf_volatile_store; eauto. intros (EQ & tm' & P & Q). subst vres. econstructor; split. - eapply exec_Ibuiltin; eauto. rewrite <- comp_transf_function; eauto. + eapply exec_Ibuiltin; eauto. apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. constructor. eauto. constructor. eauto. constructor. eapply external_call_symbols_preserved. apply senv_preserved. - simpl; eauto. + rewrite <- comp_transf_function; eauto. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. + (* memcpy *) @@ -1111,10 +1113,11 @@ Ltac UseTransfer := eauto. intros (tm' & A & B). econstructor; split. - eapply exec_Ibuiltin; eauto. rewrite <- comp_transf_function; eauto. + eapply exec_Ibuiltin; eauto. + (* rewrite <- comp_transf_function; eauto. *) apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. constructor. eauto. constructor. eauto. constructor. - (* rewrite <- comp_transf_function; eauto. *) + rewrite <- comp_transf_function; eauto. eapply external_call_symbols_preserved. apply senv_preserved. simpl in B1; inv B1. simpl in B2; inv B2. econstructor; eauto. eapply match_succ_states; eauto. simpl; auto. @@ -1137,24 +1140,26 @@ Ltac UseTransfer := erewrite Mem.loadbytes_length in H0 by eauto. rewrite Z2Nat.id in H0 by lia. auto. + (* annot *) - destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x3) as (ne1, nm1) eqn:TR. + destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x2) as (ne1, nm1) eqn:TR. InvSoundState. exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D). inv H1. econstructor; split. - eapply exec_Ibuiltin; eauto. rewrite <- comp_transf_function; eauto. + eapply exec_Ibuiltin; eauto. + (* rewrite <- comp_transf_function; eauto. *) apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved. apply senv_preserved. constructor. eapply eventval_list_match_lessdef; eauto 2 with na. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. + (* annot val *) - destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x3) as (ne1, nm1) eqn:TR. + destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x2) as (ne1, nm1) eqn:TR. InvSoundState. exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D). inv H1. inv B. inv H6. econstructor; split. - eapply exec_Ibuiltin; eauto. rewrite <- comp_transf_function; eauto. + eapply exec_Ibuiltin; eauto. + (* rewrite <- comp_transf_function; eauto. *) apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved. apply senv_preserved. constructor. @@ -1183,8 +1188,9 @@ Ltac UseTransfer := eapply magree_extends; eauto. intros. apply nlive_all. intros (v' & tm' & P & Q & R & S). econstructor; split. - eapply exec_Ibuiltin; eauto. rewrite <- comp_transf_function; eauto. + eapply exec_Ibuiltin; eauto. apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + rewrite <- comp_transf_function; eauto. eapply external_call_symbols_preserved. apply senv_preserved. eauto. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. @@ -1262,7 +1268,7 @@ Lemma transf_initial_states: Proof. intros. inversion H. exploit function_ptr_translated; eauto. intros (cu & tf & A & B & C). - exists (Callstate nil tf nil m0); split. + exists (Callstate nil tf nil m0 top); split. econstructor; eauto. eapply (Genv.init_mem_match TRANSF); eauto. replace (prog_main tprog) with (prog_main prog). diff --git a/backend/LTL.v b/backend/LTL.v index 721a541e5d..2620a7dcfa 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -207,7 +207,8 @@ Inductive state : Type := (f: fundef) (**r function to call *) (sig: signature) (**r signature of function to call *) (ls: locset) (**r location state of caller *) - (m: mem), (**r memory state *) + (m: mem) (**r memory state *) + (cp: compartment), (**r calling compartment *) state | Returnstate: forall (stack: list stackframe) (**r call stack *) @@ -218,7 +219,7 @@ Inductive state : Type := Definition call_comp (stack: list stackframe) : compartment := match stack with - | nil => bottom + | nil => top | Stackframe f _ _ _ _ :: _ => comp_of f end. @@ -339,7 +340,7 @@ Inductive step: state -> trace -> state -> Prop := List.Forall not_ptr args), forall (EV: call_trace ge (comp_of f) (comp_of fd) vf args (sig_args sig) t), step (Block s f sp (Lcall sig ros :: bb) rs m) - t (Callstate (Stackframe f sig sp rs bb :: s) fd sig rs m) + t (Callstate (Stackframe f sig sp rs bb :: s) fd sig rs m (comp_of f)) | exec_Ltailcall: forall s f sp sig ros bb rs m fd rs' m', rs' = return_regs (parent_locset s) rs -> find_function ros rs' = Some fd -> @@ -348,7 +349,7 @@ Inductive step: state -> trace -> state -> Prop := forall (COMP: comp_of fd = (comp_of f)), Mem.free m sp 0 f.(fn_stacksize) (comp_of f) = Some m' -> step (Block s f (Vptr sp Ptrofs.zero) (Ltailcall sig ros :: bb) rs m) - E0 (Callstate s fd sig rs' m') + E0 (Callstate s fd sig rs' m' (comp_of f)) | exec_Lbuiltin: forall s f sp ef args res bb rs m vargs t vres rs' m', eval_builtin_args ge rs sp m args vargs -> external_call ef ge (comp_of f) vargs m t vres m' -> @@ -378,20 +379,20 @@ Inductive step: state -> trace -> state -> Prop := return_regs_ext (parent_locset s) rs (parent_signature s)), step (Block s f (Vptr sp Ptrofs.zero) (Lreturn :: bb) rs m) E0 (Returnstate s retrs m' (comp_of f)) - | exec_function_internal: forall s f rs m m' sp callrs sig rs', + | exec_function_internal: forall s f rs m m' cp sp callrs sig rs', Mem.alloc m (comp_of f) 0 f.(fn_stacksize) = (m', sp) -> forall (CALLREGS: callrs = call_regs_ext rs sig), rs' = undef_regs destroyed_at_function_entry callrs -> - step (Callstate s (Internal f) sig rs m) + step (Callstate s (Internal f) sig rs m cp) E0 (State s f (Vptr sp Ptrofs.zero) f.(fn_entrypoint) rs' m') - | exec_function_external: forall s ef t args res rs m rs' sig m', + | exec_function_external: forall s ef t args res rs m rs' sig m' cp, args = map (fun p => Locmap.getpair p rs) (loc_arguments (ef_sig ef)) -> - external_call ef ge (call_comp s) args m t res m' -> + external_call ef ge cp args m t res m' -> rs' = Locmap.setpair (loc_result (ef_sig ef)) res (undef_caller_save_regs rs) -> - step (Callstate s (External ef) sig rs m) - t (Returnstate s rs' m' (call_comp s)) + step (Callstate s (External ef) sig rs m cp) + t (Returnstate s rs' m' bottom) | exec_return: forall f sp rs1 bb s rs m cp sig t, forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) cp = Genv.CrossCompartmentCall -> @@ -414,7 +415,7 @@ Inductive initial_state (p: program): state -> Prop := Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = signature_main -> - initial_state p (Callstate nil f signature_main (Locmap.init Vundef) m0). + initial_state p (Callstate nil f signature_main (Locmap.init Vundef) m0 top). Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m retcode cp, diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index b6a522cb85..e88197cd02 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -1386,6 +1386,7 @@ Proof. intros. rewrite K; auto. rewrite C; auto. apply bmatch_inv with m. eapply mmatch_stack; eauto. intros. apply Q; eauto. + admit. eapply external_call_nextblock; eauto. intros (bc3 & U & V & W & X & Y & Z & AA). eapply sound_succ_state with (bc := bc3); eauto. simpl; auto. @@ -1393,6 +1394,7 @@ Proof. apply sound_stack_exten with bc. apply sound_stack_inv with m. auto. intros. apply Q. red. eapply Plt_trans; eauto. + admit. rewrite C; auto with ordered_type. intros. eapply external_call_can_access_block; eauto. exact AA. @@ -1414,6 +1416,7 @@ Proof. apply sound_stack_exten with bc. apply sound_stack_inv with m. auto. intros. apply Q. red. eapply Plt_trans; eauto. + admit. rewrite C; auto with ordered_type. intros. eapply external_call_can_access_block; eauto. exact AA. @@ -1422,7 +1425,7 @@ Proof. unfold transfer_builtin in TR. destruct ef; auto. + (* builtin function *) - destruct (lookup_builtin_function name cp sg) as [bf|] eqn:LK; auto. + destruct (lookup_builtin_function name sg) as [bf|] eqn:LK; auto. destruct (eval_static_builtin_function ae am rm bf args) as [av|] eqn:ES; auto. simpl in H1. red in H1. rewrite LK in H1. inv H1. eapply sound_succ_state; eauto. simpl; auto. @@ -1518,7 +1521,7 @@ Proof. intros. eapply Mem.loadbytes_alloc_unchanged; eauto. intros. eapply Mem.alloc_can_access_block_other_inj_1; eauto. intros. apply F. erewrite Mem.alloc_result by eauto. auto. - eapply Mem.owned_new_block; eauto. + simpl. erewrite Mem.owned_new_block; eauto. now apply flowsto_refl. - (* external function *) exploit external_call_match; eauto with va. @@ -1527,6 +1530,7 @@ Proof. apply sound_stack_new_bound with (Mem.nextblock m). apply sound_stack_exten with bc; auto. apply sound_stack_inv with m; auto. + intros. eapply K; eauto. admit. intros. eapply external_call_can_access_block; eauto. eapply external_call_nextblock; eauto. @@ -1548,7 +1552,7 @@ Proof. eapply sound_regular_state with (bc := bc1); eauto. apply sound_stack_exten with bc'; auto. eapply ematch_ge; eauto. apply ematch_update. auto. auto. -Qed. +Admitted. End SOUNDNESS. From 004144fb047e7cba2c0a9bd69b1d2e33f0fc2b64 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 27 Nov 2023 11:54:17 +0000 Subject: [PATCH 14/83] [Compartments] Fix Tunneling pass --- backend/Tunnelingproof.v | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index ddf0ece79a..76ce598d6b 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -412,12 +412,12 @@ Inductive match_states: state -> state -> Prop := match_states (Block s f sp (Lcond cond args pc1 pc2 :: bb) ls m) (State ts (tunnel_function f) sp (branch_target f pc1) tls tm) | match_states_call: - forall s f ls m ts tls tm sig + forall s f ls m ts tls tm sig cp (STK: list_forall2 match_stackframes s ts) (LS: locmap_lessdef ls tls) (MEM: Mem.extends m tm), - match_states (Callstate s f sig ls m) - (Callstate ts (tunnel_fundef f) sig tls tm) + match_states (Callstate s f sig ls m cp) + (Callstate ts (tunnel_fundef f) sig tls tm cp) | match_states_return: forall s ls m cp ts tls tm (STK: list_forall2 match_stackframes s ts) @@ -584,7 +584,7 @@ Definition measure (st: state) : nat := | Block s f sp (Lbranch pc :: _) ls m => (count_gotos f pc * 2 + 1)%nat | Block s f sp (Lcond _ _ pc1 pc2 :: _) ls m => (Nat.max (count_gotos f pc1) (count_gotos f pc2) * 2 + 1)%nat | Block s f sp bb ls m => 0%nat - | Callstate s f sig ls m => 0%nat + | Callstate s f sig ls m cp => 0%nat | Returnstate s ls m cp => 0%nat end. @@ -835,7 +835,7 @@ Lemma transf_initial_states: exists st2, initial_state tprog st2 /\ match_states st1 st2. Proof. intros. inversion H. - exists (Callstate nil (tunnel_fundef f) signature_main (Locmap.init Vundef) m0); split. + exists (Callstate nil (tunnel_fundef f) signature_main (Locmap.init Vundef) m0 top); split. econstructor; eauto. apply (Genv.init_mem_transf TRANSL); auto. rewrite (match_program_main TRANSL). From 5baf152db4ab21aee71dcc853729b840efc1a007 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 27 Nov 2023 12:06:02 +0000 Subject: [PATCH 15/83] [Compartments] Partially fix proofs for Linear level. Break for lunch --- backend/CleanupLabelsproof.v | 18 +++++++----- backend/Debugvar.v | 22 +++++++------- backend/Debugvarproof.v | 57 ++++++++++++++++++------------------ backend/Linear.v | 32 ++++++++++---------- backend/Linearizeproof.v | 22 +++++++------- backend/Lineartyping.v | 12 ++++---- 6 files changed, 83 insertions(+), 80 deletions(-) diff --git a/backend/CleanupLabelsproof.v b/backend/CleanupLabelsproof.v index 63bd777cb4..7b0b253d3c 100644 --- a/backend/CleanupLabelsproof.v +++ b/backend/CleanupLabelsproof.v @@ -109,10 +109,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. intros vf. - eapply (Genv.match_genvs_find_comp TRANSL). + eapply (Genv.match_genvs_find_comp_in_genv TRANSL). Qed. (** Correctness of [labels_branched_to]. *) @@ -243,10 +243,10 @@ Inductive match_states: state -> state -> Prop := match_states (State s f sp c ls m) (State ts (transf_function f) sp (remove_unused_labels (labels_branched_to f.(fn_code)) c) ls m) | match_states_call: - forall s f ls m ts sig, + forall s f ls m ts sig cp, list_forall2 match_stackframes s ts -> - match_states (Callstate s f sig ls m) - (Callstate ts (transf_fundef f) sig ls m) + match_states (Callstate s f sig ls m cp) + (Callstate ts (transf_fundef f) sig ls m cp) | match_states_return: forall s ls m ts cp, list_forall2 match_stackframes s ts -> @@ -342,8 +342,10 @@ Proof. left; econstructor; split. econstructor. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + rewrite comp_transl; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. rewrite comp_transl; eauto. + eauto. + (* rewrite comp_transl; eauto. *) econstructor; eauto with coqlib. (* Llabel *) case_eq (Labelset.mem lbl (labels_branched_to (fn_code f))); intros. @@ -386,10 +388,10 @@ Proof. left; econstructor; split. econstructor; simpl; eauto. assert (CALLER: call_comp s = call_comp ts). - { inv H7. reflexivity. + { inv H8. reflexivity. inv H0. reflexivity. } assert (SIG: parent_signature s = parent_signature ts). - { inv H7. reflexivity. + { inv H8. reflexivity. inv H0. reflexivity. } (* rewrite type_of_call_translated, CALLER, SIG. *) change (comp_of (transf_function f)) with (comp_of f). diff --git a/backend/Debugvar.v b/backend/Debugvar.v index 913bcc43d7..f75a998dbb 100644 --- a/backend/Debugvar.v +++ b/backend/Debugvar.v @@ -205,7 +205,7 @@ Fixpoint update_labels (lbls: list label) (s: avail) (lm: labelmap) : Definition is_debug_setvar (ef: external_function) := match ef with - | EF_debug _ 2%positive txt targs => Some txt + | EF_debug 2%positive txt targs => Some txt | _ => None end. @@ -316,17 +316,17 @@ Definition delta_state (before after: option avail) : avail * avail := (** Insert debug annotations at the beginning and end of live ranges of locations that correspond to source local variables. *) -Definition add_start_range (cp: compartment) (vi: ident * debuginfo) (c: code) : code := +Definition add_start_range (vi: ident * debuginfo) (c: code) : code := let (v, i) := vi in - Lbuiltin (EF_debug cp 3%positive v nil) (proj1_sig i :: nil) BR_none :: c. + Lbuiltin (EF_debug 3%positive v nil) (proj1_sig i :: nil) BR_none :: c. -Definition add_end_range (cp: compartment) (vi: ident * debuginfo) (c: code) : code := +Definition add_end_range (vi: ident * debuginfo) (c: code) : code := let (v, i) := vi in - Lbuiltin (EF_debug cp 4%positive v nil) nil BR_none :: c. + Lbuiltin (EF_debug 4%positive v nil) nil BR_none :: c. -Definition add_delta_ranges (cp: compartment) (before after: option avail) (c: code) : code := +Definition add_delta_ranges (before after: option avail) (c: code) : code := let (killed, born) := delta_state before after in - List.fold_right (add_end_range cp) (List.fold_right (add_start_range cp) c born) killed. + List.fold_right (add_end_range) (List.fold_right (add_start_range) c born) killed. Fixpoint skip_debug_setvar (lm: labelmap) (before: option avail) (c: code) := match c with @@ -338,17 +338,17 @@ Fixpoint skip_debug_setvar (lm: labelmap) (before: option avail) (c: code) := end end. -Fixpoint transf_code (cp: compartment) (lm: labelmap) (before: option avail) (c: code) : code := +Fixpoint transf_code (lm: labelmap) (before: option avail) (c: code) : code := match c with | nil => nil | Lgoto lbl1 :: Llabel lbl2 :: c' => (* This special case avoids some redundant start/end annotations *) let after := get_label lbl2 lm in Lgoto lbl1 :: Llabel lbl2 :: - add_delta_ranges cp before after (transf_code cp lm after c') + add_delta_ranges before after (transf_code lm after c') | i :: c' => let after := skip_debug_setvar lm (snd (transfer lm before i)) c' in - i :: add_delta_ranges cp before after (transf_code cp lm after c') + i :: add_delta_ranges before after (transf_code lm after c') end. Local Open Scope string_scope. @@ -358,7 +358,7 @@ Definition transf_function (f: function) : res function := | None => Error (msg "Debugvar: analysis diverges") | Some lm => OK (mkfunction f.(fn_comp) f.(fn_sig) f.(fn_stacksize) - (transf_code f.(fn_comp) lm (Some top) f.(fn_code))) + (transf_code lm (Some top) f.(fn_code))) end. Definition transf_fundef (fd: fundef) : res fundef := diff --git a/backend/Debugvarproof.v b/backend/Debugvarproof.v index b24bb6e9ef..904b719fbb 100644 --- a/backend/Debugvarproof.v +++ b/backend/Debugvarproof.v @@ -37,12 +37,12 @@ Proof. intros. eapply match_transform_partial_program; eauto. Qed. -Inductive match_code: compartment -> code -> code -> Prop := - | match_code_nil: forall cp, - match_code cp nil nil - | match_code_cons: forall cp i before after c c', - match_code cp c c' -> - match_code cp (i :: c) (i :: add_delta_ranges cp before after c'). +Inductive match_code: code -> code -> Prop := + | match_code_nil: + match_code nil nil + | match_code_cons: forall i before after c c', + match_code c c' -> + match_code (i :: c) (i :: add_delta_ranges before after c'). Remark diff_same: forall s, diff s s = nil. @@ -59,25 +59,25 @@ Proof. Qed. Lemma transf_code_match: - forall cp lm c before, match_code cp c (transf_code cp lm before c). + forall lm c before, match_code c (transf_code lm before c). Proof. - intros cp lm. fix REC 1. destruct c; intros before; simpl. + intros lm. fix REC 1. destruct c; intros before; simpl. - constructor. - assert (DEFAULT: forall before after, - match_code cp (i :: c) - (i :: add_delta_ranges cp before after (transf_code cp lm after c))). + match_code (i :: c) + (i :: add_delta_ranges before after (transf_code lm after c))). { intros. constructor. apply REC. } destruct i; auto. destruct c; auto. destruct i; auto. set (after := get_label l0 lm). - set (c1 := Llabel l0 :: add_delta_ranges cp before after (transf_code cp lm after c)). - replace c1 with (add_delta_ranges cp before before c1). + set (c1 := Llabel l0 :: add_delta_ranges before after (transf_code lm after c)). + replace c1 with (add_delta_ranges before before c1). constructor. constructor. apply REC. unfold add_delta_ranges. rewrite delta_state_same. auto. Qed. Inductive match_function: function -> function -> Prop := | match_function_intro: forall f c, - match_code f.(fn_comp) f.(fn_code) c -> + match_code f.(fn_code) c -> match_function f (mkfunction f.(fn_comp) f.(fn_sig) f.(fn_stacksize) c). Lemma transf_function_match: @@ -89,7 +89,7 @@ Proof. Qed. Remark find_label_add_delta_ranges: - forall cp lbl c before after, find_label lbl (add_delta_ranges cp before after c) = find_label lbl c. + forall lbl c before after, find_label lbl (add_delta_ranges before after c) = find_label lbl c. Proof. intros. unfold add_delta_ranges. destruct (delta_state before after) as [killed born]. @@ -98,10 +98,10 @@ Proof. Qed. Lemma find_label_match_rec: - forall cp lbl c' c tc, - match_code cp c tc -> + forall lbl c' c tc, + match_code c tc -> find_label lbl c = Some c' -> - exists before after tc', find_label lbl tc = Some (add_delta_ranges cp before after tc') /\ match_code cp c' tc'. + exists before after tc', find_label lbl tc = Some (add_delta_ranges before after tc') /\ match_code c' tc'. Proof. induction 1; simpl; intros. - discriminate. @@ -114,7 +114,7 @@ Lemma find_label_match: forall f tf lbl c, match_function f tf -> find_label lbl f.(fn_code) = Some c -> - exists before after tc, find_label lbl tf.(fn_code) = Some (add_delta_ranges f.(fn_comp) before after tc) /\ match_code f.(fn_comp) c tc. + exists before after tc, find_label lbl tf.(fn_code) = Some (add_delta_ranges before after tc) /\ match_code c tc. Proof. intros. inv H. eapply find_label_match_rec; eauto. Qed. @@ -370,10 +370,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. intros vf. - eapply (Genv.match_genvs_find_comp TRANSF). + eapply (Genv.match_genvs_find_comp_in_genv TRANSF). Qed. (** Evaluation of the debug annotations introduced by the transformation. *) @@ -391,7 +391,7 @@ Qed. Lemma eval_add_delta_ranges: forall s f sp c rs m before after, - star step tge (State s f sp (add_delta_ranges f.(fn_comp) before after c) rs m) + star step tge (State s f sp (add_delta_ranges before after c) rs m) E0 (State s f sp c rs m). Proof. intros. unfold add_delta_ranges. @@ -406,14 +406,12 @@ Proof. constructor. eexact E1. constructor. simpl; econstructor. simpl; auto. - auto. traceEq. - eapply star_step; eauto. econstructor. constructor. simpl; constructor. simpl; auto. - auto. traceEq. Qed. @@ -423,25 +421,25 @@ Inductive match_stackframes: Linear.stackframe -> Linear.stackframe -> Prop := | match_stackframe_intro: forall f sg sp rs c tf tc before after, match_function f tf -> - match_code f.(fn_comp) c tc -> + match_code c tc -> match_stackframes (Stackframe f sg sp rs c) - (Stackframe tf sg sp rs (add_delta_ranges f.(fn_comp) before after tc)). + (Stackframe tf sg sp rs (add_delta_ranges before after tc)). Inductive match_states: Linear.state -> Linear.state -> Prop := | match_states_instr: forall s f sp c rs m tf ts tc (STACKS: list_forall2 match_stackframes s ts) (TRF: match_function f tf) - (TRC: match_code f.(fn_comp) c tc), + (TRC: match_code c tc), match_states (State s f sp c rs m) (State ts tf sp tc rs m) | match_states_call: - forall s f rs m tf ts sig, + forall s f rs m tf ts sig cp, list_forall2 match_stackframes s ts -> transf_fundef f = OK tf -> - match_states (Callstate s f sig rs m) - (Callstate ts tf sig rs m) + match_states (Callstate s f sig rs m cp) + (Callstate ts tf sig rs m cp) | match_states_return: forall s rs m cp ts, list_forall2 match_stackframes s ts -> @@ -534,6 +532,7 @@ Proof. { rewrite <- (comp_transl_partial _ B). inv TRF; unfold comp_of; simpl. eapply call_trace_eq; eauto using senv_preserved, symbols_preserved. } + rewrite (comp_transl_partial _ B). constructor; auto. constructor; auto. replace (fn_comp tf) with (fn_comp f) by now inv TRF. constructor; auto. diff --git a/backend/Linear.v b/backend/Linear.v index 567003381c..7e036d2022 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -138,7 +138,8 @@ Inductive state: Type := (f: fundef) (**r function to call *) (sig: signature) (**r signature of function to call *) (rs: locset) (**r location state at point of call *) - (m: mem), (**r memory state *) + (m: mem) (**r memory state *) + (cp: compartment), (**r calling compartment *) state | Returnstate: forall (stack: list stackframe) (**r call stack *) @@ -147,10 +148,10 @@ Inductive state: Type := (cp: compartment), (**r compartment we're returning from *) state. -Definition call_comp (stack: list stackframe): option compartment := +Definition call_comp (stack: list stackframe): compartment := match stack with - | nil => None - | Stackframe f _ _ _ _ :: _ => Some (comp_of f) + | nil => top + | Stackframe f _ _ _ _ :: _ => comp_of f end. (** [parent_locset cs] returns the mapping of values for locations @@ -187,7 +188,7 @@ Inductive step: state -> trace -> state -> Prop := | exec_Lload: forall s f sp chunk addr args dst b rs m a v rs', eval_addressing ge sp addr (reglist rs args) = Some a -> - Mem.loadv chunk m a (Some (comp_of f)) = Some v -> + Mem.loadv chunk m a (comp_of f) = Some v -> rs' = Locmap.set (R dst) v (undef_regs (destroyed_by_load chunk addr) rs) -> step (State s f sp (Lload chunk addr args dst :: b) rs m) E0 (State s f sp b rs' m) @@ -213,7 +214,7 @@ Inductive step: state -> trace -> state -> Prop := List.Forall not_ptr args), forall (EV: call_trace ge (comp_of f) (comp_of f') vf args (sig_args sig) t), step (State s f sp (Lcall sig ros :: b) rs m) - t (Callstate (Stackframe f sig sp rs b:: s) f' sig rs m) + t (Callstate (Stackframe f sig sp rs b:: s) f' sig rs m (comp_of f)) | exec_Ltailcall: forall s f stk sig ros b rs m rs' f' m', rs' = return_regs (parent_locset s) rs -> @@ -222,13 +223,12 @@ Inductive step: state -> trace -> state -> Prop := forall COMP: comp_of f' = comp_of f, Mem.free m stk 0 f.(fn_stacksize) (comp_of f) = Some m' -> step (State s f (Vptr stk Ptrofs.zero) (Ltailcall sig ros :: b) rs m) - E0 (Callstate s f' sig rs' m') + E0 (Callstate s f' sig rs' m' (comp_of f)) | exec_Lbuiltin: forall s f sp rs m ef args res b vargs t vres rs' m', eval_builtin_args ge rs sp m args vargs -> - external_call ef ge vargs m t vres m' -> + external_call ef ge (comp_of f) vargs m t vres m' -> rs' = Locmap.setres res vres (undef_regs (destroyed_by_builtin ef) rs) -> - forall ALLOWED: comp_of ef = comp_of f, step (State s f sp (Lbuiltin ef args res :: b) rs m) t (State s f sp b rs' m') | exec_Llabel: @@ -270,21 +270,21 @@ Inductive step: state -> trace -> state -> Prop := step (State s f (Vptr stk Ptrofs.zero) (Lreturn :: b) rs m) E0 (Returnstate s retrs m' (comp_of f)) | exec_function_internal: - forall s f callrs rs m rs' m' stk sig, + forall s f callrs rs m cp rs' m' stk sig, Mem.alloc m (comp_of f) 0 f.(fn_stacksize) = (m', stk) -> forall (CALLREGS: callrs = call_regs_ext rs sig), rs' = undef_regs destroyed_at_function_entry callrs -> - step (Callstate s (Internal f) sig rs m) + step (Callstate s (Internal f) sig rs m cp) E0 (State s f (Vptr stk Ptrofs.zero) f.(fn_code) rs' m') | exec_function_external: - forall s ef args res rs1 rs2 m t m' sig, + forall s ef args res rs1 rs2 m cp t m' sig, args = map (fun p => Locmap.getpair p rs1) (loc_arguments (ef_sig ef)) -> - external_call ef ge args m t res m' -> + external_call ef ge cp args m t res m' -> rs2 = Locmap.setpair (loc_result (ef_sig ef)) res (undef_caller_save_regs rs1) -> - step (Callstate s (External ef) sig rs1 m) - t (Returnstate s rs2 m' (comp_of ef)) + step (Callstate s (External ef) sig rs1 m cp) + t (Returnstate s rs2 m' bottom) | exec_return: forall s f sp rs0 c rs m sg cp t, forall (NO_CROSS_PTR: @@ -303,7 +303,7 @@ Inductive initial_state (p: program): state -> Prop := Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = signature_main -> - initial_state p (Callstate nil f signature_main (Locmap.init Vundef) m0). + initial_state p (Callstate nil f signature_main (Locmap.init Vundef) m0 top). Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m retcode cp, diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index 307ca17301..466ab205be 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -132,9 +132,9 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. - eapply (Genv.match_genvs_find_comp TRANSF). + eapply (Genv.match_genvs_find_comp_in_genv TRANSF). Qed. (** * Correctness of reachability analysis *) @@ -572,11 +572,11 @@ Inductive match_states: LTL.state -> Linear.state -> Prop := match_states (LTL.Block s f sp bb ls m) (Linear.State ts tf sp (linearize_block bb c) ls m) | match_states_call: - forall s f ls m tf ts sig, + forall s f ls m tf ts sig cp, list_forall2 match_stackframes s ts -> transf_fundef f = OK tf -> - match_states (LTL.Callstate s f sig ls m) (* parent_signature ts *) - (Linear.Callstate ts tf sig ls m) + match_states (LTL.Callstate s f sig ls m cp) (* parent_signature ts *) + (Linear.Callstate ts tf sig ls m cp) | match_states_return: forall s ls m cp ts, list_forall2 match_stackframes s ts -> @@ -698,6 +698,7 @@ Proof. { rewrite <- (comp_transl_partial _ TRF). rewrite <- (comp_transl_partial _ B). eapply call_trace_eq; eauto using symbols_preserved, senv_preserved. } + rewrite <- comp_transf_fundef; eauto. econstructor; eauto. constructor; auto. econstructor; eauto. @@ -712,6 +713,7 @@ Proof. rewrite <- comp_transf_fundef; eauto. rewrite (stacksize_preserved _ _ TRF); eauto. rewrite (match_parent_locset _ _ STACKS). + rewrite <- comp_transf_fundef; eauto. econstructor; eauto. (* Lbuiltin *) @@ -775,17 +777,17 @@ Proof. (* internal functions *) assert (REACH: (reachable f)!!(LTL.fn_entrypoint f) = true). apply reachable_entrypoint. - monadInv H8. + monadInv H9. left; econstructor; split. apply plus_one. eapply exec_function_internal; eauto. rewrite (stacksize_preserved _ _ EQ). rewrite (comp_preserved _ _ EQ). eauto. generalize EQ; intro EQ'; monadInv EQ'. simpl. assert (CALLER: LTL.call_comp s = call_comp ts). - { inv H7. reflexivity. + { inv H8. reflexivity. inv H0. simpl. erewrite comp_preserved; eauto. } assert (SIG: LTL.parent_signature s = parent_signature ts). - { inv H7. reflexivity. + { inv H8. reflexivity. inv H0. reflexivity. } (* rewrite type_of_call_translated, CALLER, SIG. *) change (LTL.fn_comp f) with (comp_of f). @@ -799,7 +801,7 @@ Proof. econstructor; eauto. simpl. eapply is_tail_add_branch. constructor. (* external function *) - monadInv H9. left; econstructor; split. + monadInv H10. left; econstructor; split. apply plus_one. eapply exec_function_external; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. @@ -820,7 +822,7 @@ Lemma transf_initial_states: Proof. intros. inversion H. exploit function_ptr_translated; eauto. intros [tf [A B]]. - exists (Callstate nil tf signature_main (Locmap.init Vundef) m0); split. + exists (Callstate nil tf signature_main (Locmap.init Vundef) m0 top); split. econstructor; eauto. eapply (Genv.init_mem_transf_partial TRANSF); eauto. rewrite (match_program_main TRANSF). rewrite symbols_preserved. eauto. diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index e80943f630..001649a375 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -280,13 +280,13 @@ Inductive wt_state: state -> Prop := (WTC: wt_code f c = true) (WTRS: wt_locset rs), wt_state (State s f sp c rs m) - | wt_call_state: forall s fd sig rs m + | wt_call_state: forall s fd sig rs m cp (WTSTK: wt_callstack s) (WTFD: wt_fundef fd) (WTRS: wt_locset rs) (AGCS: agree_callee_save rs (parent_locset s)) (AGARGS: agree_outgoing_arguments (funsig fd) rs (parent_locset s)), - wt_state (Callstate s fd sig rs m) + wt_state (Callstate s fd sig rs m cp) | wt_return_state: forall s rs m cp (WTSTK: wt_callstack s) (WTRS: wt_locset rs) @@ -485,16 +485,16 @@ Proof. Qed. Lemma wt_callstate_wt_regs: - forall s f sig rs m, - wt_state (Callstate s f sig rs m) -> + forall s f sig rs m cp, + wt_state (Callstate s f sig rs m cp) -> forall r, Val.has_type (rs (R r)) (mreg_type r). Proof. intros. inv H. apply WTRS. Qed. Lemma wt_callstate_agree: - forall s f sig rs m, - wt_state (Callstate s f sig rs m) -> + forall s f sig rs m cp, + wt_state (Callstate s f sig rs m cp) -> (* agree_callee_save rs (parent_locset s) /\ agree_outgoing_arguments (funsig f) rs (parent_locset s). *) agree_callee_save rs (parent_locset s) /\ agree_outgoing_arguments (funsig f) rs (parent_locset s). Proof. From f094b52002d29d73ea62f8e8aa4f8d98445d77e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 27 Nov 2023 15:23:22 +0000 Subject: [PATCH 16/83] [Compartments] Fix Mach generation pass and fix Asm language --- backend/Debugvarproof.v | 19 ++++--- backend/Mach.v | 68 +++++++++++----------- backend/Stackingproof.v | 119 +++++++++++++++++++++------------------ riscV/Asm.v | 122 ++++++++++++++++++---------------------- 4 files changed, 166 insertions(+), 162 deletions(-) diff --git a/backend/Debugvarproof.v b/backend/Debugvarproof.v index 904b719fbb..e7fb075607 100644 --- a/backend/Debugvarproof.v +++ b/backend/Debugvarproof.v @@ -532,9 +532,8 @@ Proof. { rewrite <- (comp_transl_partial _ B). inv TRF; unfold comp_of; simpl. eapply call_trace_eq; eauto using senv_preserved, symbols_preserved. } - rewrite (comp_transl_partial _ B). + replace (comp_of tf) with (comp_of f) by now inv TRF. constructor; auto. constructor; auto. - replace (fn_comp tf) with (fn_comp f) by now inv TRF. constructor; auto. - (* tailcall *) exploit find_function_translated; eauto. intros (tf' & A & B). @@ -546,7 +545,9 @@ Proof. symmetry; apply sig_preserved; auto. now rewrite <- (comp_transl_partial _ B). eauto. - rewrite PLS. constructor; auto. + rewrite PLS. + replace (comp_of tf) with (comp_of f) by now inv TRF. + constructor; auto. - (* builtin *) econstructor; split. eapply plus_left. @@ -599,7 +600,7 @@ Proof. rewrite SIG. inv TRF; constructor; auto. - (* internal function *) - monadInv H8. rename x into tf. + monadInv H9. rename x into tf. assert (MF: match_function f tf) by (apply transf_function_match; auto). inversion MF; subst. econstructor; split. @@ -607,17 +608,17 @@ Proof. apply plus_one. eapply exec_function_internal. simpl; eauto. reflexivity. reflexivity. assert (CALLER: call_comp s = call_comp ts). - { inv H7. reflexivity. + { inv H8. reflexivity. inv H1. inv H3. reflexivity. } assert (SIG: parent_signature s = parent_signature ts). - { inv H7. reflexivity. + { inv H8. reflexivity. inv H1. reflexivity. } change (comp_of {| fn_comp := fn_comp f; fn_sig := fn_sig f; fn_stacksize := fn_stacksize f; fn_code := c |}) with (comp_of f). constructor; auto. - (* external function *) - monadInv H9. econstructor; split. + monadInv H10. econstructor; split. apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. constructor; auto. @@ -631,7 +632,7 @@ Proof. (fn_comp {| fn_comp := fn_comp f; fn_sig := fn_sig f; fn_stacksize := fn_stacksize f; fn_code := c0 |}) by reflexivity. apply eval_add_delta_ranges. traceEq. - constructor; auto. constructor; auto. + constructor; auto. simpl. constructor; auto. Qed. Lemma transf_initial_states: @@ -640,7 +641,7 @@ Lemma transf_initial_states: Proof. intros. inversion H. exploit function_ptr_translated; eauto. intros [tf [A B]]. - exists (Callstate nil tf signature_main (Locmap.init Vundef) m0); split. + exists (Callstate nil tf signature_main (Locmap.init Vundef) m0 AST.top); split. econstructor; eauto. eapply (Genv.init_mem_transf_partial TRANSF); eauto. rewrite (match_program_main TRANSF), symbols_preserved. auto. rewrite <- H3. apply sig_preserved. auto. diff --git a/backend/Mach.v b/backend/Mach.v index 8262c81e36..9bf4480033 100644 --- a/backend/Mach.v +++ b/backend/Mach.v @@ -338,7 +338,8 @@ Inductive state: Type := (f: block) (**r pointer to function to call *) (sig: signature) (**r signature of function to call *) (rs: regset) (**r register state *) - (m: mem), (**r memory state *) + (m: mem) (**r memory state *) + (cp: compartment), (**r calling compartment *) state | Returnstate: forall (stack: list stackframe) (**r call stack *) @@ -359,8 +360,11 @@ Definition parent_ra (s: list stackframe) : val := | Stackframe f _ sp ra c :: s' => Vptr f ra end. -Definition call_comp (s: list stackframe): option compartment := - Genv.find_comp ge (parent_ra s). +Definition call_comp (s: list stackframe): compartment := + match s with + | nil => top + | Stackframe f _ _ _ _ :: _ => Genv.find_comp_of_block ge f + end. (* TODO: Better name (also LTL)! *) Definition parent_signature (stack: list stackframe) : signature := @@ -376,23 +380,23 @@ Inductive step: state -> trace -> state -> Prop := E0 (State s f sp c rs m) | exec_Mgetstack: forall s f sp ofs ty dst c rs m v cp, - forall (CURCOMP: Genv.find_comp_of_block ge f = Some cp), - load_stack m sp ty ofs (Some cp) = Some v -> + forall (CURCOMP: Genv.find_comp_of_block ge f = cp), + load_stack m sp ty ofs cp = Some v -> step (State s f sp (Mgetstack ofs ty dst :: c) rs m) E0 (State s f sp c (rs#dst <- v) m) | exec_Msetstack: forall s f sp src ofs ty c rs m m' rs' cp, - forall (CURCOMP: Genv.find_comp_of_block ge f = Some cp), + forall (CURCOMP: Genv.find_comp_of_block ge f = cp), store_stack m sp ty ofs (rs src) cp = Some m' -> rs' = undef_regs (destroyed_by_setstack ty) rs -> step (State s f sp (Msetstack src ofs ty :: c) rs m) E0 (State s f sp c rs' m') | exec_Mgetparam: forall s fb f sp ofs ty dst c rs m v rs' cp, - forall (CURCOMP: Genv.find_comp_of_block ge fb = Some cp), + forall (CURCOMP: Genv.find_comp_of_block ge fb = cp), Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m sp Tptr f.(fn_link_ofs) (Some cp) = Some (parent_sp s) -> - load_stack m (parent_sp s) ty ofs None = Some v -> (* /!\ Privileged!! *) + load_stack m sp Tptr f.(fn_link_ofs) cp = Some (parent_sp s) -> + load_stack m (parent_sp s) ty ofs top = Some v -> (* /!\ Privileged!! *) rs' = (rs # temp_for_parent_frame <- Vundef # dst <- v) -> step (State s fb sp (Mgetparam ofs ty dst :: c) rs m) E0 (State s fb sp c rs' m) @@ -404,15 +408,15 @@ Inductive step: state -> trace -> state -> Prop := E0 (State s f sp c rs' m) | exec_Mload: forall s f sp chunk addr args dst c rs m a v rs' cp, - forall (CURCOMP: Genv.find_comp_of_block ge f = Some cp), + forall (CURCOMP: Genv.find_comp_of_block ge f = cp), eval_addressing ge sp addr rs##args = Some a -> - Mem.loadv chunk m a (Some cp) = Some v -> + Mem.loadv chunk m a cp = Some v -> rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) -> step (State s f sp (Mload chunk addr args dst :: c) rs m) E0 (State s f sp c rs' m) | exec_Mstore: forall s f sp chunk addr args src c rs m m' a rs' cp, - forall (CURCOMP: Genv.find_comp_of_block ge f = Some cp), + forall (CURCOMP: Genv.find_comp_of_block ge f = cp), eval_addressing ge sp addr rs##args = Some a -> Mem.storev chunk m a (rs src) cp = Some m' -> rs' = undef_regs (destroyed_by_store chunk addr) rs -> @@ -434,24 +438,24 @@ Inductive step: state -> trace -> state -> Prop := args (sig_args sig) t), step (State s fb sp (Mcall sig ros :: c) rs m) t (Callstate (Stackframe fb sig sp ra c :: s) - f' sig rs m) + f' sig rs m (comp_of f)) | exec_Mtailcall: forall s fb stk soff sig ros c rs m f f' m', - forall (NEXTCOMP: Genv.find_comp_of_block ge f' = Some (comp_of f)), + forall (NEXTCOMP: Genv.find_comp_of_block ge f' = comp_of f), find_function_ptr ge ros rs = Some f' -> Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) (Some (comp_of f)) + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) (comp_of f) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) (Some (comp_of f)) + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) (comp_of f) = Some (parent_ra s) -> Mem.free m stk 0 f.(fn_stacksize) (comp_of f) = Some m' -> step (State s fb (Vptr stk soff) (Mtailcall sig ros :: c) rs m) - E0 (Callstate s f' sig rs m') + E0 (Callstate s f' sig rs m' (comp_of f)) | exec_Mbuiltin: - forall s fb sp rs m ef args res b vargs t vres rs' m', - forall (CURCOMP: Genv.find_comp_of_block ge fb = Some (comp_of ef)), + forall s fb sp rs m ef cp args res b vargs t vres rs' m', + forall (CURCOMP: Genv.find_comp_of_block ge fb = cp), eval_builtin_args ge rs sp m args vargs -> - external_call ef ge vargs m t vres m' -> + external_call ef ge cp vargs m t vres m' -> rs' = set_res res vres (undef_regs (destroyed_by_builtin ef) rs) -> step (State s fb sp (Mbuiltin ef args res :: b) rs m) t (State s fb sp b rs' m') @@ -487,9 +491,9 @@ Inductive step: state -> trace -> state -> Prop := | exec_Mreturn: forall s fb stk soff c rs m f m' retrs, Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) (Some (comp_of f)) + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) (comp_of f) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) (Some (comp_of f)) + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) (comp_of f) = Some (parent_ra s) -> Mem.free m stk 0 f.(fn_stacksize) (comp_of f) = Some m' -> forall (RETREGS: @@ -498,7 +502,7 @@ Inductive step: state -> trace -> state -> Prop := step (State s fb (Vptr stk soff) (Mreturn :: c) rs m) E0 (Returnstate s retrs m' (comp_of f)) | exec_function_internal: - forall s fb rs m f m1 m2 m3 stk callrs rs' sig, + forall s fb rs m f m1 m2 m3 stk callrs rs' sig cp, Genv.find_funct_ptr ge fb = Some (Internal f) -> Mem.alloc m (comp_of f) 0 f.(fn_stacksize) = (m1, stk) -> let sp := Vptr stk Ptrofs.zero in @@ -510,19 +514,19 @@ Inductive step: state -> trace -> state -> Prop := callrs = undef_caller_save_regs_ext rs sig), rs' = undef_regs destroyed_at_function_entry callrs -> - step (Callstate s fb sig rs m) + step (Callstate s fb sig rs m cp) E0 (State s fb sp f.(fn_code) rs' m3) | exec_function_external: - forall s fb rs m t rs' ef args res m' sig, + forall s fb rs m t rs' ef args res m' sig cp, Genv.find_funct_ptr ge fb = Some (External ef) -> extcall_arguments rs m (parent_sp s) (ef_sig ef) args -> - external_call ef ge args m t res m' -> + external_call ef ge cp args m t res m' -> rs' = set_pair (loc_result (ef_sig ef)) res (undef_caller_save_regs rs) -> - step (Callstate s fb sig rs m) - t (Returnstate s rs' m' (comp_of ef)) + step (Callstate s fb sig rs m cp) + t (Returnstate s rs' m' bottom) | exec_return: forall s f sp ra c rs m sg cp t, - forall cp' (CURCOMP: Genv.find_comp_of_block ge f = Some cp'), + forall cp' (CURCOMP: Genv.find_comp_of_block ge f = cp'), forall (NO_CROSS_PTR: Genv.type_of_call cp' cp = Genv.CrossCompartmentCall -> not_ptr (return_value rs sg)), @@ -537,7 +541,7 @@ Inductive initial_state (p: program): state -> Prop := let ge := Genv.globalenv p in Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some fb -> - initial_state p (Callstate nil fb signature_main (Regmap.init Vundef) m0). + initial_state p (Callstate nil fb signature_main (Regmap.init Vundef) m0 top). Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r retcode cp, @@ -579,9 +583,9 @@ Inductive wf_state: state -> Prop := (CODE: Genv.find_funct_ptr ge fb = Some (Internal f)) (TAIL: is_tail c f.(fn_code)), wf_state (State s fb sp c rs m) - | wf_call_state: forall s fb sig rs m + | wf_call_state: forall s fb sig rs m cp (STACK: Forall wf_frame s), - wf_state (Callstate s fb sig rs m) + wf_state (Callstate s fb sig rs m cp) | wf_return_state: forall s rs m cp (STACK: Forall wf_frame s), wf_state (Returnstate s rs m cp). diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 4d9308399f..cca973ef18 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -156,7 +156,7 @@ Local Opaque Z.add Z.mul Z.divide. Lemma contains_get_stack: forall spec m ty sp ofs cp, m |= contains (chunk_of_type ty) sp ofs cp spec -> - exists v, load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr ofs) (Some cp) = Some v /\ spec v. + exists v, load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr ofs) cp = Some v /\ spec v. Proof. intros. unfold load_stack. replace (Val.offset_ptr (Vptr sp Ptrofs.zero) (Ptrofs.repr ofs)) with (Vptr sp (Ptrofs.repr ofs)). @@ -167,7 +167,7 @@ Qed. Lemma hasvalue_get_stack: forall ty m sp ofs cp v, m |= hasvalue (chunk_of_type ty) sp ofs cp v -> - load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr ofs) (Some cp) = Some v. + load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr ofs) cp = Some v. Proof. intros. exploit contains_get_stack; eauto. intros (v' & A & B). congruence. Qed. @@ -211,14 +211,13 @@ Qed. The documentation above (and for related assertions) needs to be amended. *) Program Definition contains_locations (j: meminj) (sp: block) (pos bound: Z) (sl: slot) (ls: locset) - (ocp: option compartment) (cp: compartment) : massert := {| + (cp: compartment) : massert := {| m_pred := fun m => (8 | pos) /\ 0 <= pos /\ pos + 4 * bound <= Ptrofs.modulus /\ Mem.range_perm m sp pos (pos + 4 * bound) Cur Freeable /\ - Mem.can_access_block m sp ocp /\ - ocp = Some cp /\ + Mem.can_access_block m sp cp /\ forall ofs ty, 0 <= ofs -> ofs + typesize ty <= bound -> (typealign ty | ofs) -> - exists v, Mem.load (chunk_of_type ty) m sp (pos + 4 * ofs) ocp = Some v + exists v, Mem.load (chunk_of_type ty) m sp (pos + 4 * ofs) cp = Some v /\ Val.inject j (ls (S sl ofs ty)) v; m_footprint := fun b ofs => b = sp /\ pos <= ofs < pos + 4 * bound @@ -231,10 +230,11 @@ Next Obligation. | Z.pos y' => Z.pos y'~0~0 | Z.neg y' => Z.neg y'~0~0 end) with (4 * bound) in *. - eapply Mem.unchanged_on_own with (b := sp) (cp := Some cp) in H0. - eapply H0. eauto. - eapply Mem.can_access_block_valid_block; eauto. - - exploit H6; eauto. intros (v & A & B). exists v; split; auto. + eapply Mem.unchanged_on_own with (b := sp) in H0. + eauto with comps. + (* eapply H0. eauto. *) + (* eapply Mem.can_access_block_valid_block; eauto. *) + - exploit H5; eauto. intros (v & A & B). exists v; split; auto. change (match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0 | Z.neg y' => Z.neg y'~0~0 @@ -279,13 +279,13 @@ Qed. Lemma get_location: forall m j sp pos bound sl ls cp ofs ty, - m |= contains_locations j sp pos bound sl ls (Some cp) cp -> + m |= contains_locations j sp pos bound sl ls cp -> 0 <= ofs -> ofs + typesize ty <= bound -> (typealign ty | ofs) -> exists v, - load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (pos + 4 * ofs)) (Some cp) = Some v + load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (pos + 4 * ofs)) cp = Some v /\ Val.inject j (ls (S sl ofs ty)) v. Proof. - intros. destruct H as (D & E & F & G & [H' [_ H]]). + intros. destruct H as (D & E & F & G & [H' H]). exploit H; eauto. intros (v & U & V). exists v; split; auto. unfold load_stack; simpl. rewrite Ptrofs.add_zero_l, Ptrofs.unsigned_repr; auto. unfold Ptrofs.max_unsigned. generalize (typesize_pos ty). lia. @@ -293,14 +293,14 @@ Qed. Lemma set_location: forall m j sp pos bound sl cp ls P ofs ty v v', - m |= contains_locations j sp pos bound sl ls (Some cp) cp ** P -> + m |= contains_locations j sp pos bound sl ls cp ** P -> 0 <= ofs -> ofs + typesize ty <= bound -> (typealign ty | ofs) -> Val.inject j v v' -> exists m', store_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (pos + 4 * ofs)) v' cp = Some m' - /\ m' |= contains_locations j sp pos bound sl (Locmap.set (S sl ofs ty) v ls) (Some cp) cp ** P. + /\ m' |= contains_locations j sp pos bound sl (Locmap.set (S sl ofs ty) v ls) cp ** P. Proof. - intros. destruct H as (A & B & C). destruct A as (D & E & F & G & [H' [_ H]]). + intros. destruct H as (A & B & C). destruct A as (D & E & F & G & [H' H]). edestruct Mem.valid_access_store as [m' STORE]. eapply valid_access_location; eauto. assert (PERM: Mem.range_perm m' sp pos (pos + 4 * bound) Cur Freeable). @@ -309,7 +309,7 @@ Proof. - unfold store_stack; simpl. rewrite Ptrofs.add_zero_l, Ptrofs.unsigned_repr; eauto. unfold Ptrofs.max_unsigned. generalize (typesize_pos ty). lia. - simpl. intuition auto. - + fold (Mem.can_access_block m' sp (Some cp)). + + fold (Mem.can_access_block m' sp cp). eapply Mem.store_can_access_block_inj in STORE. eapply STORE; eauto. + unfold Locmap.set. destruct (Loc.eq (S sl ofs ty) (S sl ofs0 ty0)); [|destruct (Loc.diff_dec (S sl ofs ty) (S sl ofs0 ty0))]. @@ -323,10 +323,10 @@ Proof. rewrite <- X; eapply Mem.load_store_other; eauto. destruct d. congruence. right. rewrite ! size_type_chunk, ! typesize_typesize. lia. * (* overlapping locations *) - destruct (Mem.valid_access_load m' (chunk_of_type ty0) sp (pos + 4 * ofs0) (Some cp)) as [v'' LOAD]. + destruct (Mem.valid_access_load m' (chunk_of_type ty0) sp (pos + 4 * ofs0) cp) as [v'' LOAD]. apply Mem.valid_access_implies with Writable; auto with mem. eapply valid_access_location; eauto. - fold (Mem.can_access_block m' sp (Some cp)). + fold (Mem.can_access_block m' sp cp). eapply Mem.store_can_access_block_inj in STORE. eapply STORE; eauto. exists v''; auto. + apply (m_invar P) with m; auto. @@ -338,14 +338,14 @@ Qed. Lemma initial_locations: forall j sp pos bound P sl ls cp m, m |= range sp pos (pos + 4 * bound) ** P -> - Mem.can_access_block m sp (Some cp) -> + Mem.can_access_block m sp cp -> (8 | pos) -> (forall ofs ty, ls (S sl ofs ty) = Vundef) -> - m |= contains_locations j sp pos bound sl ls (Some cp) cp ** P. + m |= contains_locations j sp pos bound sl ls cp ** P. Proof. intros. destruct H as (A & B & C). destruct A as (D & E & F). split. - simpl; intuition auto. red; intros; eauto with mem. - destruct (Mem.valid_access_load m (chunk_of_type ty) sp (pos + 4 * ofs) (Some cp)) as [v LOAD]. + destruct (Mem.valid_access_load m (chunk_of_type ty) sp (pos + 4 * ofs) cp) as [v LOAD]. eapply valid_access_location; eauto. red; intros; eauto with mem. exists v; split; auto. rewrite H2; auto. @@ -355,24 +355,24 @@ Qed. Lemma contains_locations_exten: forall ls ls' j sp pos bound sl cp, (forall ofs ty, Val.lessdef (ls' (S sl ofs ty)) (ls (S sl ofs ty))) -> - massert_imp (contains_locations j sp pos bound sl ls (Some cp) cp) - (contains_locations j sp pos bound sl ls' (Some cp) cp). + massert_imp (contains_locations j sp pos bound sl ls cp) + (contains_locations j sp pos bound sl ls' cp). Proof. intros; split; simpl; intros; auto. (* RB: NOTE: Try to avoid renumbering when using these definitions, also above. *) - intuition auto. exploit H7; eauto. intros (v & A & B). exists v; split; auto. + intuition auto. exploit H6; eauto. intros (v & A & B). exists v; split; auto. specialize (H ofs ty). inv H. congruence. auto. Qed. Lemma contains_locations_incr: forall j j' sp pos bound sl ls cp, inject_incr j j' -> - massert_imp (contains_locations j sp pos bound sl ls (Some cp) cp) - (contains_locations j' sp pos bound sl ls (Some cp) cp). + massert_imp (contains_locations j sp pos bound sl ls cp) + (contains_locations j' sp pos bound sl ls cp). Proof. intros; split; simpl; intros; auto. - intuition auto. exploit H7; eauto. intros (v & A & B). exists v; eauto. + intuition auto. exploit H6; eauto. intros (v & A & B). exists v; eauto. Qed. (** [contains_callee_saves j sp pos rl ls] is a memory assertion that holds @@ -429,8 +429,8 @@ we have full access rights on the stack frame, except the part that represents the Linear stack data. *) Definition frame_contents_1 (j: meminj) (sp: block) (ls ls0: locset) (parent retaddr: val) (cp: compartment) := - contains_locations j sp fe.(fe_ofs_local) b.(bound_local) Local ls (Some cp) cp - ** contains_locations j sp fe_ofs_arg b.(bound_outgoing) Outgoing ls (Some cp) cp + contains_locations j sp fe.(fe_ofs_local) b.(bound_local) Local ls cp + ** contains_locations j sp fe_ofs_arg b.(bound_outgoing) Outgoing ls cp ** hasvalue Mptr sp fe.(fe_ofs_link) cp parent ** hasvalue Mptr sp fe.(fe_ofs_retaddr) cp retaddr ** contains_callee_saves j sp fe.(fe_ofs_callee_save) b.(used_callee_save) ls0 cp. @@ -448,7 +448,7 @@ Lemma frame_get_local: m |= frame_contents j sp ls ls0 parent retaddr cp ** P -> slot_within_bounds b Local ofs ty -> slot_valid f Local ofs ty = true -> exists v, - load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (offset_local fe ofs)) (Some cp) = Some v + load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (offset_local fe ofs)) cp = Some v /\ Val.inject j (ls (S Local ofs ty)) v. Proof. unfold frame_contents, frame_contents_1; intros. unfold slot_valid in H1; InvBooleans. @@ -461,7 +461,7 @@ Lemma frame_get_outgoing: m |= frame_contents j sp ls ls0 parent retaddr cp ** P -> slot_within_bounds b Outgoing ofs ty -> slot_valid f Outgoing ofs ty = true -> exists v, - load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (offset_arg ofs)) (Some cp) = Some v + load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (offset_arg ofs)) cp = Some v /\ Val.inject j (ls (S Outgoing ofs ty)) v. Proof. unfold frame_contents, frame_contents_1; intros. unfold slot_valid in H1; InvBooleans. @@ -472,7 +472,7 @@ Qed. Lemma frame_get_parent: forall j sp ls ls0 parent retaddr cp m P, m |= frame_contents j sp ls ls0 parent retaddr cp ** P -> - load_stack m (Vptr sp Ptrofs.zero) Tptr (Ptrofs.repr fe.(fe_ofs_link)) (Some cp) = Some parent. + load_stack m (Vptr sp Ptrofs.zero) Tptr (Ptrofs.repr fe.(fe_ofs_link)) cp = Some parent. Proof. unfold frame_contents, frame_contents_1; intros. apply mconj_proj1 in H. apply sep_proj1 in H. apply sep_pick3 in H. rewrite <- chunk_of_Tptr in H. @@ -482,7 +482,7 @@ Qed. Lemma frame_get_retaddr: forall j sp ls ls0 parent retaddr cp m P, m |= frame_contents j sp ls ls0 parent retaddr cp ** P -> - load_stack m (Vptr sp Ptrofs.zero) Tptr (Ptrofs.repr fe.(fe_ofs_retaddr)) (Some cp) = Some retaddr. + load_stack m (Vptr sp Ptrofs.zero) Tptr (Ptrofs.repr fe.(fe_ofs_retaddr)) cp = Some retaddr. Proof. unfold frame_contents, frame_contents_1; intros. apply mconj_proj1 in H. apply sep_proj1 in H. apply sep_pick4 in H. rewrite <- chunk_of_Tptr in H. @@ -976,8 +976,8 @@ Lemma save_callee_save_rec_correct: forall k l pos cp rs m P, (forall r, In r l -> is_callee_save r = true) -> m |= range sp pos (size_callee_save_area_rec l pos) ** P -> - forall ACC : Mem.can_access_block m sp (Some cp), - forall COMP : Genv.find_comp_of_block tge fb = Some cp, + forall ACC : Mem.can_access_block m sp cp, + forall COMP : Genv.find_comp_of_block tge fb = cp, agree_regs j ls rs -> exists rs', exists m', star step tge @@ -1084,8 +1084,8 @@ Lemma save_callee_save_correct: forall j ls ls0 rs sp cs fb k sig cp m P, m |= range sp fe.(fe_ofs_callee_save) (size_callee_save_area b fe.(fe_ofs_callee_save)) ** P -> (forall r, Val.has_type (ls (R r)) (mreg_type r)) -> - forall ACC : Mem.can_access_block m sp (Some cp), - forall COMP : Genv.find_comp_of_block tge fb = Some cp, + forall ACC : Mem.can_access_block m sp cp, + forall COMP : Genv.find_comp_of_block tge fb = cp, agree_callee_save ls ls0 -> agree_regs j ls rs -> let ls1 := LTL.undef_regs destroyed_at_function_entry (LTL.call_regs_ext ls sig) in @@ -1191,8 +1191,8 @@ Local Opaque b fe. apply (frame_env_separated b) in SEP. replace (make_env b) with fe in SEP by auto. (* Store of parent *) rewrite sep_swap3 in SEP. - eapply (range_contains Mptr) in SEP; [|tauto - | eapply Mem.owned_new_block; eauto]. + eapply (range_contains Mptr) in SEP; + [| tauto | simpl; erewrite Mem.owned_new_block; eauto using flowsto_refl]. exploit (contains_set_stack (fun v' => v' = parent) parent (fun _ => True) m2' Tptr). rewrite chunk_of_Tptr; eexact SEP. apply Val.load_result_same; auto. clear SEP; intros (m3' & STORE_PARENT & SEP). @@ -1212,17 +1212,18 @@ Local Opaque b fe. { unfold store_stack in STORE_RETADDR. simpl in STORE_RETADDR. eapply Mem.store_can_access_block_2 in STORE_RETADDR. unfold comp_of in *; simpl in *. rewrite transf_function_comp in STORE_RETADDR. - eapply STORE_RETADDR. } - { unfold Genv.find_comp, Genv.find_comp_of_block. - apply Genv.find_funct_ptr_iff in FUNPTR. - unfold fundef. now rewrite FUNPTR. } + unfold Genv.find_comp_of_block; unfold Genv.find_funct_ptr in FUNPTR. + destruct (Genv.find_def tge fb) as [[]|] eqn:R; inv FUNPTR; try congruence. simpl; auto. } + (* { unfold Genv.find_comp, Genv.find_comp_of_block. *) + (* apply Genv.find_funct_ptr_iff in FUNPTR. *) + (* unfold fundef. now rewrite FUNPTR. } *) apply agree_regs_inject_incr with j; auto. replace (LTL.undef_regs destroyed_at_function_entry (call_regs_ext ls sig)) with ls1 by auto. replace (undef_regs destroyed_at_function_entry (undef_caller_save_regs_ext rs sig)) with rs1 by auto. clear SEP; intros (rs2 & m5' & SAVE_CS & SEP & PERMS & AGREGS'). rewrite sep_swap5 in SEP. (* Materializing the Local and Outgoing locations *) - assert (ACC: Mem.can_access_block m5' sp' (Some (Linear.fn_comp f))). + assert (ACC: Mem.can_access_block m5' sp' (Linear.fn_comp f)). { eapply sep_proj2 in SEP. eapply sep_proj2 in SEP. eapply sep_proj1 in SEP. apply contains_valid_access in SEP as [? [? ?]]. eassumption. } exploit (initial_locations j'). eexact SEP. eexact ACC. @@ -1244,7 +1245,10 @@ Local Opaque b fe. unfold frame_contents_1; rewrite ! sep_assoc. unfold comp_of in SEP; simpl in SEP. rewrite transf_function_comp in SEP. replace (comp_of tf) with (fn_comp tf) in SEP by reflexivity. + replace (Genv.find_comp_of_block tge fb) with (fn_comp tf) in SEP. exact SEP. + { unfold Genv.find_comp_of_block; unfold Genv.find_funct_ptr in FUNPTR. + destruct (Genv.find_def tge fb) as [[]|] eqn:R; inv FUNPTR; try congruence. simpl; auto. } assert (forall ofs k p, Mem.perm m2' sp' ofs k p -> Mem.perm m5' sp' ofs k p). { intros. apply PERMS. unfold store_stack in STORE_PARENT, STORE_RETADDR. @@ -1381,8 +1385,8 @@ Lemma function_epilogue_correct: j sp = Some(sp', fe.(fe_stack_data)) -> Mem.free m sp 0 f.(Linear.fn_stacksize) (comp_of f) = Some m1 -> exists rs1, exists m1', - load_stack m' (Vptr sp' Ptrofs.zero) Tptr tf.(fn_link_ofs) (Some (comp_of tf)) = Some pa - /\ load_stack m' (Vptr sp' Ptrofs.zero) Tptr tf.(fn_retaddr_ofs) (Some (comp_of tf)) = Some ra + load_stack m' (Vptr sp' Ptrofs.zero) Tptr tf.(fn_link_ofs) (comp_of tf) = Some pa + /\ load_stack m' (Vptr sp' Ptrofs.zero) Tptr tf.(fn_retaddr_ofs) (comp_of tf) = Some ra /\ Mem.free m' sp' 0 tf.(fn_stacksize) (comp_of tf) = Some m1' /\ star step tge (State cs fb (Vptr sp' Ptrofs.zero) (restore_callee_save fe k) rs m') @@ -1538,7 +1542,7 @@ Proof. intros j cs cs' sg H. destruct H; simpl. - unfold Vnullptr; destruct Archi.ptr64; reflexivity. -- unfold Genv.find_comp, Genv.find_funct. +- unfold Genv.find_comp_in_genv, Genv.find_funct. rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FINDF). symmetry. now rewrite (comp_transl_partial _ TRF). Qed. @@ -1705,10 +1709,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. intros vf. - eapply (Genv.match_genvs_find_comp TRANSF). + eapply (Genv.match_genvs_find_comp_in_genv TRANSF). Qed. Lemma find_function_translated': @@ -2074,7 +2078,7 @@ Inductive match_states: Linear.state -> Mach.state -> Prop := match_states (Linear.State cs f (Vptr sp Ptrofs.zero) c ls m) (Mach.State cs' fb (Vptr sp' Ptrofs.zero) (transl_code (make_env (function_bounds f)) c) rs m') | match_states_call: - forall cs f ls m cs' fb rs m' j tf sig + forall cs f ls m cs' fb rs m' j tf sig cp (STACKS: match_stacks j cs cs' (Linear.funsig f)) (TRANSL: transf_fundef f = OK tf) (FIND: Genv.find_funct_ptr tge fb = Some (tf)) @@ -2082,8 +2086,8 @@ Inductive match_states: Linear.state -> Mach.state -> Prop := (SEP: m' |= stack_contents j cs cs' ** minjection j m ** globalenv_inject ge j), - match_states (Linear.Callstate cs f sig ls m) - (Mach.Callstate cs' fb sig rs m') + match_states (Linear.Callstate cs f sig ls m cp) + (Mach.Callstate cs' fb sig rs m' cp) | match_states_return: forall cs ls m cs' rs m' j sg cp (STACKS: match_stacks j cs cs' sg) @@ -2302,6 +2306,7 @@ Proof. { intros; red. apply Z.le_trans with (size_arguments (Linear.funsig f')); auto. apply loc_arguments_bounded; auto. } + rewrite <- comp_transf_function; eauto. econstructor; eauto. econstructor; eauto with coqlib. apply Val.Vptr_has_type. @@ -2325,6 +2330,7 @@ Proof. destruct f'; auto. monadInv C. unfold comp_of; simpl. rewrite <- (comp_transf_function _ _ EQ); eauto. inv C. reflexivity. traceEq. + rewrite <- comp_transf_function; eauto. econstructor; eauto. apply match_stacks_change_sig with (Linear.fn_sig f); auto. apply zero_size_arguments_tailcall_possible. eapply wt_state_tailcall; eauto. @@ -2342,10 +2348,13 @@ Proof. rewrite <- sep_assoc, sep_comm, sep_assoc in SEP. econstructor; split. apply plus_one. econstructor; eauto. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND); eauto. + (* rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND); eauto. *) change (comp_of (Internal tf)) with (comp_of tf). - now erewrite ALLOWED, <- transf_function_comp; eauto. + (* now erewrite ALLOWED, <- transf_function_comp; eauto. *) eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND); eauto. + change (comp_of (Internal tf)) with (comp_of tf). + erewrite <- transf_function_comp; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. eapply match_states_intro with (j := j'); eauto with coqlib. eapply match_stacks_change_meminj; eauto. diff --git a/riscV/Asm.v b/riscV/Asm.v index e8b7bbf796..c06ffcb0e5 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -610,7 +610,7 @@ Definition eval_offset (ofs: offset) : ptrofs := Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem) (d: preg) (a: ireg) (ofs: offset) (cp: compartment) (priv: bool) := match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) - (if priv then None else Some cp) with + (if priv then top else cp) with | None => Stuck | Some v => Next (nextinstr (rs#d <- v)) m end. @@ -961,7 +961,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) (cp: | Some m2 => Next (nextinstr (rs #X30 <- (rs SP) #SP <- sp #X31 <- Vundef)) m2 end | Pfreeframe sz pos => - match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) (Some cp) with + match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) cp with | None => Stuck | Some v => match rs SP with @@ -1088,7 +1088,7 @@ Definition get_loc (rs: regset) (m: mem) (l: loc): option val := | R r => Some (rs (preg_of r)) | S Incoming ofs ty => let bofs := Stacklayout.fe_ofs_arg + 4 * ofs in - Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) None + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) top | _ => None end. @@ -1204,7 +1204,7 @@ Definition stack := list stackframe. Definition call_comp (s: stack) := match s with - | nil => None + | nil => top | Stackframe f _ _ _ :: _ => Genv.find_comp_of_block ge f end. @@ -1221,30 +1221,25 @@ Definition update_stack_call (s: stack) (sg: signature) (cp: compartment) rs' := let pc' := rs' # PC in let ra' := rs' # RA in let sp' := rs' # SP in - match Genv.find_comp ge pc' with - | Some cp' => - if Pos.eqb cp cp' then - (* If we are in the same compartment as previously recorded, we + let cp' := Genv.find_comp_in_genv ge pc' in + if flowsto_dec cp' cp then + (* If we are in the same compartment as previously recorded, we don't update the stack *) - Some s - else - (* Otherwise, we simply push a new frame on the stack *) - match ra' with - | Vptr f retaddr => - Some (Stackframe f sg sp' retaddr :: s) - | _ => None - end - | None => None - end. + Some s + else + (* Otherwise, we simply push a new frame on the stack *) + match ra' with + | Vptr f retaddr => + Some (Stackframe f sg sp' retaddr :: s) + | _ => None + end +. Definition update_stack_return (s: stack) (cp: compartment) rs' := let pc' := rs' # PC in - let cp' := match Genv.find_comp ge pc' with - | Some cp' => cp' - | None => default_compartment - end in - if Pos.eqb cp cp' then + let cp' := Genv.find_comp_in_genv ge pc' in + if flowsto_dec cp cp' then (* If we are in the same compartment as previously recorded, we don't update the stack *) Some s @@ -1254,7 +1249,7 @@ Definition update_stack_return (s: stack) (cp: compartment) rs' := | nil => Some nil | _ :: st' => Some st' end - . +. Inductive state: Type := | State: stack -> regset -> mem -> state @@ -1302,7 +1297,7 @@ Inductive step: state -> trace -> state -> Prop := sig_call i = None -> is_return i = false -> forall (NEXTPC: rs' PC = Vptr b' ofs'), - forall (ALLOWED: Some (comp_of f) = Genv.find_comp_of_block ge b'), + forall (ALLOWED: comp_of f = Genv.find_comp_of_block ge b'), step (State st rs m) E0 (State st rs' m') | exec_step_internal_call: forall b ofs f i sig rs m rs' m' b' ofs' st st' args t, @@ -1313,7 +1308,7 @@ Inductive step: state -> trace -> state -> Prop := 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 cp' (NEXTCOMP: Genv.find_comp_of_block ge b' = Some cp'), + forall cp' (NEXTCOMP: Genv.find_comp_of_block ge b' = cp'), (* Is a call, we update the stack *) forall (STUPD: update_stack_call st sig (comp_of f) rs' = Some st'), forall (ARGS: call_arguments rs' m' sig args), @@ -1336,7 +1331,7 @@ Inductive step: state -> trace -> state -> Prop := | exec_step_return: forall st st' rs m sg t rec_cp cp', rs PC <> Vnullptr -> - forall (NEXTCOMP: Genv.find_comp ge (rs PC) = Some cp'), + forall (NEXTCOMP: Genv.find_comp_in_genv 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), @@ -1357,8 +1352,7 @@ Inductive step: state -> trace -> state -> Prop := 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), + 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)) @@ -1368,10 +1362,10 @@ Inductive step: state -> trace -> state -> Prop := 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) -> - external_call ef ge args m t res m' -> + external_call ef ge (Genv.find_comp_in_genv ge (rs RA)) 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) -> - step (State st rs m) t (ReturnState st rs' m' (comp_of ef)). + step (State st rs m) t (ReturnState st rs' m' bottom). End RELSEM. @@ -1397,24 +1391,20 @@ Inductive final_state (p: program): state -> int -> Prop := Definition comp_of_main (p: program) := let ge := Genv.globalenv p in - match Genv.find_symbol ge (prog_main p) with - | Some fb => Genv.find_comp_of_block ge fb - | _ => None - end. - + Genv.find_comp_of_ident ge (prog_main p). Definition semantics (p: program) := Semantics step (initial_state p) (final_state p) (Genv.globalenv p). -(** [has_comp] instance for [Asm] states *) -#[export] Instance has_comp_state (p: program): has_comp state := - fun s => match s with - | State _ rs _ - | ReturnState _ rs _ _ => - match Genv.find_comp (Genv.globalenv p) (rs PC) with - | Some cp => cp - | None => default_compartment - end - end. +(** [has_comp] instan(* ce for [Asm] states *) *) +(* #[export] Instance has_comp_state (p: program): has_comp state := *) +(* fun s => match s with *) +(* | State _ rs _ *) +(* | ReturnState _ rs _ _ => *) +(* match Genv.find_comp_in_genv (Genv.globalenv p) (rs PC) with *) +(* | Some cp => cp *) +(* | None => default_compartment *) +(* end *) +(* end. *) (** Determinacy of the [Asm] semantics. *) @@ -1579,32 +1569,32 @@ Section ExecSem. Local Open Scope reducts_monad_scope. Variable do_external_function: - compartment -> string -> signature -> Senv.t -> world -> list val -> mem -> option (world * trace * val * mem). + string -> signature -> Senv.t -> compartment -> world -> list val -> mem -> option (world * trace * val * mem). Hypothesis do_external_function_sound: forall cp id sg ge vargs m t vres m' w w', - do_external_function cp id sg ge w vargs m = Some(w', t, vres, m') -> - external_functions_sem cp id sg ge vargs m t vres m' /\ possible_trace w t w'. + do_external_function id sg ge cp w vargs m = Some(w', t, vres, m') -> + external_functions_sem id sg ge cp vargs m t vres m' /\ possible_trace w t w'. Hypothesis do_external_function_complete: forall cp id sg ge vargs m t vres m' w w', - external_functions_sem cp id sg ge vargs m t vres m' -> + external_functions_sem id sg ge cp vargs m t vres m' -> possible_trace w t w' -> - do_external_function cp id sg ge w vargs m = Some(w', t, vres, m'). + do_external_function id sg ge cp w vargs m = Some(w', t, vres, m'). Variable do_inline_assembly: - compartment -> string -> signature -> Senv.t -> world -> list val -> mem -> option (world * trace * val * mem). + string -> signature -> Senv.t -> compartment -> world -> list val -> mem -> option (world * trace * val * mem). Hypothesis do_inline_assembly_sound: forall txt sg ge cp vargs m t vres m' w w', - do_inline_assembly cp txt sg ge w vargs m = Some(w', t, vres, m') -> - inline_assembly_sem cp txt sg ge vargs m t vres m' /\ possible_trace w t w'. + do_inline_assembly txt sg ge cp w vargs m = Some(w', t, vres, m') -> + inline_assembly_sem txt sg ge cp vargs m t vres m' /\ possible_trace w t w'. Hypothesis do_inline_assembly_complete: forall txt sg ge cp vargs m t vres m' w w', - inline_assembly_sem cp txt sg ge vargs m t vres m' -> + inline_assembly_sem txt sg ge cp vargs m t vres m' -> possible_trace w t w' -> - do_inline_assembly cp txt sg ge w vargs m = Some(w', t, vres, m'). + do_inline_assembly txt sg ge cp w vargs m = Some(w', t, vres, m'). Definition take_step (p: program) (ge: genv) (w: world) (s: state): option (trace * state) := let comp_of_main := comp_of_main p in @@ -1620,15 +1610,15 @@ Section ExecSem. match sig_call i, is_return i with | None, false => (* exec_step_internal *) do Vptr b' ofs' <- rs' PC; - do cp <- Genv.find_comp_of_block ge b'; - check (Pos.eqb (comp_of f) cp); + let cp := Genv.find_comp_of_block ge b' in + check (cp_eq_dec (comp_of f) cp); Some (E0, State st rs' m') | Some sig, false => (* exec_step_internal_call *) do Vptr b' ofs' <- rs' PC; check (Genv.allowed_call_b ge (comp_of f) (rs' PC)); do st' <- update_stack_call ge st sig (comp_of f) rs'; do vargs <- get_call_arguments rs' m' sig; - do cp <- Genv.find_comp ge (rs' PC); + let cp := Genv.find_comp_in_genv ge (rs' PC) in check (match Genv.type_of_call (comp_of f) cp with | Genv.CrossCompartmentCall => forallb not_ptr_b vargs | _ => true @@ -1644,21 +1634,21 @@ Section ExecSem. end | External ef => check (Ptrofs.eq ofs Ptrofs.zero); - let cp := Genv.find_comp ge (rs X1) in + let cp := Genv.find_comp_in_genv ge (rs X1) in do vargs <- get_extcall_arguments rs m (ef_sig ef); - do res_external <- do_external _ _ ge do_external_function do_inline_assembly ef w vargs m; + do res_external <- do_external _ _ ge do_external_function do_inline_assembly ef cp w vargs m; let '(w', t, res, m') := res_external in let rs' := (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) # PC <- (rs X1) in - do cp' <- Genv.find_comp ge (rs PC); + let cp' := Genv.find_comp_in_genv ge (rs PC) in Some (t, ReturnState st rs' m' cp') end | ReturnState st rs m rec_cp => check (negb (Val.eq (rs PC) Vnullptr)); let rec_cp' := call_comp ge st in - do cp' <- Genv.find_comp ge (rs PC); - check (match Pos.eqb rec_cp cp' with - | true => true - | false => andb (Val.eq (rs PC) (asm_parent_ra st)) (Val.eq (rs X2) (asm_parent_sp st)) + let cp' := Genv.find_comp_in_genv ge (rs PC) in + check (match cp_eq_dec rec_cp cp' with + | left _ => true + | right _ => andb (Val.eq (rs PC) (asm_parent_ra st)) (Val.eq (rs X2) (asm_parent_sp st)) end); do st' <- update_stack_return ge st rec_cp rs; let sg := sig_of_call st in From 5173743d72de6d314162ab3ce0954014b7af80f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Thu, 30 Nov 2023 10:25:07 +0000 Subject: [PATCH 17/83] [Compartments] Fix the compilation process from start to end --- Makefile | 2 +- backend/Allocproof.v | 6 +- backend/Asmexpandaux.ml | 18 +- backend/Asmgenproof0.v | 4 +- backend/Debugvarproof.v | 2 +- backend/LTL.v | 3 +- backend/Linear.v | 3 +- backend/Mach.v | 3 +- backend/PrintAsm.ml | 22 +- backend/RTL.v | 2 +- backend/RTLgenproof.v | 4 +- backend/Regalloc.ml | 2 +- backend/Selectionproof.v | 7 +- backend/XTL.ml | 1 + backend/XTL.mli | 1 + cfrontend/C2C.ml | 57 ++-- cfrontend/Cexec.v | 64 ++-- cfrontend/Clight.v | 31 +- cfrontend/ClightBigstep.v | 31 +- cfrontend/Cminorgenproof.v | 21 +- cfrontend/Csem.v | 30 +- cfrontend/Csharpminor.v | 15 +- cfrontend/Cshmgen.v | 10 +- cfrontend/Cshmgenproof.v | 32 +- cfrontend/Cstrategy.v | 39 +-- cfrontend/Ctyping.v | 23 +- cfrontend/Initializersproof.v | 42 +-- cfrontend/PrintClight.ml | 2 +- cfrontend/PrintCsyntax.ml | 20 +- cfrontend/SimplExpr.v | 4 +- cfrontend/SimplExprproof.v | 23 +- cfrontend/SimplLocals.v | 34 +- cfrontend/SimplLocalsproof.v | 73 ++-- common/AST.v | 138 ++++++++ common/Globalenvs.v | 12 +- common/Memory.v | 3 +- common/PrintAST.ml | 24 +- driver/Interp.ml | 36 +- riscV/Asm.v | 42 +-- riscV/Asmexpand.ml | 16 +- riscV/Asmgenproof.v | 611 +++++++++++++++++++++++----------- riscV/Asmgenproof1.v | 22 +- riscV/TargetPrinter.ml | 6 +- 43 files changed, 946 insertions(+), 595 deletions(-) diff --git a/Makefile b/Makefile index b9d5a38c14..723505d0b8 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 +SECURITY= #RSC.v Split.v Blame.v # Parser diff --git a/backend/Allocproof.v b/backend/Allocproof.v index c44d367134..41db59f105 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -25,8 +25,7 @@ Require Import Allocation. Definition match_prog (p: RTL.program) (tp: LTL.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. -#[global] -Instance comp_transf_function: has_comp_transl_partial transf_function. +#[global] Instance comp_transf_function: has_comp_transl_partial transf_function. Proof. unfold transf_function, check_function. intros f ? H. @@ -38,8 +37,7 @@ Proof. exact e. Qed. -#[global] -Instance comp_transf_fundef: has_comp_transl_partial transf_fundef. +#[global] Instance comp_transf_fundef: has_comp_transl_partial transf_fundef. Proof. unfold transf_fundef, transf_partial_fundef, transf_function, check_function. intros f ? H. diff --git a/backend/Asmexpandaux.ml b/backend/Asmexpandaux.ml index 9d3117fb09..893b317126 100644 --- a/backend/Asmexpandaux.ml +++ b/backend/Asmexpandaux.ml @@ -26,7 +26,7 @@ let emit i = current_code := i :: !current_code (* Generation of fresh labels *) -let dummy_function = { fn_comp = privileged_compartment; fn_code = []; fn_sig = signature_main } +let dummy_function = { fn_comp = COMP.top; fn_code = []; fn_sig = signature_main } let current_function = ref dummy_function let next_label = ref (None: label option) @@ -95,10 +95,10 @@ let translate_annot sp preg_to_dwarf annot = | [] -> None | a::_ -> aux a) -let builtin_nop cp = +let builtin_nop = let signature ={sig_args = []; sig_res = Tvoid; sig_cc = cc_default} in let name = coqstring_of_camlstring "__builtin_nop" in - Pbuiltin(EF_builtin(cp,name,signature),[],BR_none) + Pbuiltin(EF_builtin(name,signature),[],BR_none) let rec lbl_follows = function | Pbuiltin (EF_debug _, _, _):: rest -> @@ -115,7 +115,7 @@ let expand_debug id sp preg simple l = | Some lbl -> lbl in let rec aux lbl scopes = function | [] -> () - | (Pbuiltin(EF_debug (_cp,kind,txt,_x),args,_) as i)::rest -> + | (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i)::rest -> let kind = (P.to_int kind) in begin match kind with @@ -152,16 +152,16 @@ let expand_debug id sp preg simple l = | _ -> aux None scopes rest end - | (Pbuiltin(EF_annot (cp, kind, _, _),_,_) as annot)::rest -> + | (Pbuiltin(EF_annot (kind, _, _),_,_) as annot)::rest -> simple annot; if P.to_int kind = 2 && lbl_follows rest then - simple (builtin_nop cp); + simple (builtin_nop); aux None scopes rest | (Plabel lbl)::rest -> simple (Plabel lbl); aux (Some lbl) scopes rest | i::rest -> simple i; aux None scopes rest in (* We need to move all closing debug annotations before the last real statement *) let rec move_debug acc bcc = function - | (Pbuiltin(EF_debug (_cp,kind,_,_),_,_) as i)::rest -> + | (Pbuiltin(EF_debug (kind,_,_),_,_) as i)::rest -> let kind = (P.to_int kind) in if kind = 1 then move_debug acc (i::bcc) rest (* Do not move debug line *) @@ -173,10 +173,10 @@ let expand_debug id sp preg simple l = let expand_simple simple l = let rec aux = function - | (Pbuiltin(EF_annot (cp, kind, _, _),_,_) as annot)::rest -> + | (Pbuiltin(EF_annot (kind, _, _),_,_) as annot)::rest -> simple annot; if P.to_int kind = 2 && lbl_follows rest then - simple (builtin_nop cp); + simple (builtin_nop); aux rest | i::rest -> simple i; aux rest | [] -> () in diff --git a/backend/Asmgenproof0.v b/backend/Asmgenproof0.v index f66b23c38f..dd3bfca352 100644 --- a/backend/Asmgenproof0.v +++ b/backend/Asmgenproof0.v @@ -929,11 +929,11 @@ Lemma exec_straight_steps_1: forall s c rs m c' rs' m', exec_straight c rs m c' rs' m' -> list_length_z (fn_code fn) <= Ptrofs.max_unsigned -> - forall b ofs, + forall b ofs cp, rs#PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal fn) -> code_tail (Ptrofs.unsigned ofs) (fn_code fn) c -> - plus step ge (State s rs m) E0 (State s rs' m'). + plus step ge (State s rs m cp) E0 (State s rs' m' (comp_of fn)). Proof. induction 1; intros. apply plus_one. diff --git a/backend/Debugvarproof.v b/backend/Debugvarproof.v index e7fb075607..d6a0539f8c 100644 --- a/backend/Debugvarproof.v +++ b/backend/Debugvarproof.v @@ -641,7 +641,7 @@ Lemma transf_initial_states: Proof. intros. inversion H. exploit function_ptr_translated; eauto. intros [tf [A B]]. - exists (Callstate nil tf signature_main (Locmap.init Vundef) m0 AST.top); split. + exists (Callstate nil tf signature_main (Locmap.init Vundef) m0 AST.COMP.top); split. econstructor; eauto. eapply (Genv.init_mem_transf_partial TRANSF); eauto. rewrite (match_program_main TRANSF), symbols_preserved. auto. rewrite <- H3. apply sig_preserved. auto. diff --git a/backend/LTL.v b/backend/LTL.v index 2620a7dcfa..3765b24c38 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -53,8 +53,7 @@ Record function: Type := mkfunction { fn_entrypoint: node }. -#[global] -Instance has_comp_function : has_comp function := fn_comp. +#[global] Instance has_comp_function : has_comp function := fn_comp. Definition fundef := AST.fundef function. diff --git a/backend/Linear.v b/backend/Linear.v index 7e036d2022..aed09fbcb0 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -48,8 +48,7 @@ Record function: Type := mkfunction { fn_code: code }. -#[global] -Instance has_comp_function: has_comp function := fn_comp. +#[global] Instance has_comp_function: has_comp function := fn_comp. Definition fundef := AST.fundef function. diff --git a/backend/Mach.v b/backend/Mach.v index 9bf4480033..d202f57ae0 100644 --- a/backend/Mach.v +++ b/backend/Mach.v @@ -77,8 +77,7 @@ Record function: Type := mkfunction fn_link_ofs: ptrofs; fn_retaddr_ofs: ptrofs }. -#[global] -Instance has_comp_function: has_comp function := fn_comp. +#[global] Instance has_comp_function: has_comp function := fn_comp. Definition fundef := AST.fundef function. diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index 8a4bc7d837..55f5ef315d 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -266,6 +266,12 @@ let print_Z_asm p n = let print_ident_asm p id = Format.fprintf p "%ld" (P.to_int32 id) +let print_comp_asm p c = + match c with + | COMP.Coq_bottom' -> Format.fprintf p "CompBottom" + | COMP.Coq_top' -> Format.fprintf p "CompTop" + | COMP.Comp id -> Format.fprintf p "Comp%ld" (P.to_int32 id) + let print_string_asm p s = Format.fprintf p "\"%s\"%%string" (camlstring_of_coqstring s) @@ -406,7 +412,7 @@ let print_instruction_asm p = function let print_coq_function_asm p Asm.{ fn_comp; fn_sig; fn_code } = Format.fprintf p "{|@ fn_comp@ :=@ "; - print_ident_asm p fn_comp; + print_comp_asm p fn_comp; Format.fprintf p ";@ fn_sig@ :=@ "; print_signature_asm p fn_sig; Format.fprintf p ";@ fn_code@ :=@ "; @@ -415,28 +421,22 @@ let print_coq_function_asm p Asm.{ fn_comp; fn_sig; fn_code } = (* TODO cases *) let print_external_function_asm p = function - | EF_external (comp, str, fsig) -> + | EF_external (str, fsig) -> Format.fprintf p "EF_external@ ("; print_string_asm p str; Format.fprintf p ",@ "; - print_ident_asm p comp; - Format.fprintf p ",@ "; print_signature_asm p fsig; Format.fprintf p ")" - | EF_builtin (comp, str, fsig) -> + | EF_builtin (str, fsig) -> Format.fprintf p "EF_builtin@ ("; print_string_asm p str; Format.fprintf p ",@ "; - print_ident_asm p comp; - Format.fprintf p ",@ "; print_signature_asm p fsig; Format.fprintf p ")" - | EF_runtime (comp, str, fsig) -> + | EF_runtime (str, fsig) -> Format.fprintf p "EF_runtime@ ("; print_string_asm p str; Format.fprintf p ",@ "; - print_ident_asm p comp; - Format.fprintf p ",@ "; print_signature_asm p fsig; Format.fprintf p ")" | _ -> @@ -495,7 +495,7 @@ let print_globvar_asm (* TODO unit *) Format.fprintf p "{|@ gvar_info@ := tt;@ "; Format.fprintf p ";@ gvar_comp@ :=@ "; - print_ident_asm p gvar_comp; + print_comp_asm p gvar_comp; Format.fprintf p ";@ gvar_init@ :=@ "; print_list_asm p print_init_data_asm gvar_init; Format.fprintf p ";@ gvar_readonly@ :=@ "; diff --git a/backend/RTL.v b/backend/RTL.v index f0ed32ca36..e74e507e34 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -91,7 +91,7 @@ Record function: Type := mkfunction { fn_entrypoint: node }. -#[export] Instance has_comp_function : has_comp function := fn_comp. +#[global] Instance has_comp_function : has_comp function := fn_comp. (** A function description comprises a control-flow graph (CFG) [fn_code] (a partial finite mapping from nodes to instructions). As in Cminor, diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index 68e021b20f..e221970e40 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -350,8 +350,7 @@ Require Import Errors. Definition match_prog (p: CminorSel.program) (tp: RTL.program) := match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp. -#[export] -Instance comp_transl_function: has_comp_transl_partial transl_function. +#[global] Instance comp_transl_function: has_comp_transl_partial transl_function. Proof. unfold transl_function. intros f tf H; simpl in *. @@ -813,6 +812,7 @@ Lemma transl_expr_Eexternal_correct: (* forall (INTRA: Genv.type_of_call cp (comp_of ef) <> Genv.CrossCompartmentCall), *) transl_expr_prop le (Eexternal id sg al) v. Proof. + Local Opaque flowsto_dec. intros; red; intros. inv TE. exploit H3; eauto. intros [rs1 [tm1 [EX1 [ME1 [RR1 [RO1 EXT1]]]]]]. exploit external_call_mem_extends; eauto. diff --git a/backend/Regalloc.ml b/backend/Regalloc.ml index 7ab2c38b25..6f36923ec0 100644 --- a/backend/Regalloc.ml +++ b/backend/Regalloc.ml @@ -705,7 +705,7 @@ let add_interfs_instr g instr live = | EF_annot_val _, [BA arg], BR res -> (* like a move *) IRC.add_pref g arg res - | EF_inline_asm(cp, txt, sg, clob), _, _ -> + | EF_inline_asm(txt, sg, clob), _, _ -> let vargs = params_of_builtin_args args in (* clobbered regs interfere with res and args for GCC compatibility *) List.iter (fun c -> diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index b872a4a4b9..80f58fcae6 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -65,10 +65,6 @@ Proof. apply X. auto. Qed. -(* Lemma record_globdefs_sound: *) -(* forall dm cp id gd, (record_globdefs dm cp)!id = Some gd -> In (id, gd) dm.(prog_defs). *) -(* Admitted. *) - Lemma lookup_helper_correct_1: forall globs name sg id, lookup_helper globs name sg = OK id -> @@ -1330,6 +1326,7 @@ Remark find_label_commut: | _, _ => False end. Proof. + Local Opaque flowsto_dec. induction s; intros until k'; simpl; intros MC SE; try (monadInv SE); simpl; auto. (* store *) unfold store. destruct (addressing m (sel_expr e)); simpl; auto. @@ -1468,7 +1465,7 @@ Proof. destruct (Ptrofs.eq_dec ofs Ptrofs.zero); try congruence. (* rewrite <- EQ' in H2. *) destruct (flowsto_dec bottom (comp_of f)); try now auto. - pose proof (bottom_flowsto (comp_of f)); contradiction. + pose proof (bottom_flowsto (comp_of f)); try contradiction. econstructor; eauto. - (* Stailcall *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. diff --git a/backend/XTL.ml b/backend/XTL.ml index ceb512d636..a99db124c6 100644 --- a/backend/XTL.ml +++ b/backend/XTL.ml @@ -16,6 +16,7 @@ open Datatypes open Camlcoq open Maps open AST +open COMP open Registers open Op open Locations diff --git a/backend/XTL.mli b/backend/XTL.mli index f2c87994de..39d7292a25 100644 --- a/backend/XTL.mli +++ b/backend/XTL.mli @@ -16,6 +16,7 @@ open Datatypes open Camlcoq open Maps open AST +open COMP open Registers open Machregs open Locations diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 6419520612..d1deb4ca47 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -16,6 +16,7 @@ open C +open AST.COMP open Camlcoq open! Floats open Values @@ -311,7 +312,7 @@ let make_builtin_memcpy cp args = if not (Z.eq (Z.modulo sz1 al1) Z.zero) then error "alignment argument of '__builtin_memcpy_aligned' must be a divisor of the size"; (* Issue #28: must decay array types to pointer types *) - Ebuiltin( AST.EF_memcpy(cp, sz1, al1), + Ebuiltin( AST.EF_memcpy( sz1, al1), Tcons(typeconv(typeof dst), Tcons(typeconv(typeof src), Tnil)), Econs(dst, Econs(src, Enil)), Tvoid) @@ -605,8 +606,8 @@ let global_for_string s id = init := AST.Init_int8(Z.of_uint(Char.code c)) :: !init in add_char '\000'; for i = String.length s - 1 downto 0 do add_char s.[i] done; - AST.(id, Gvar { gvar_comp = privileged_compartment; - (* FIXME: this is incorrect *) + AST.(id, Gvar { gvar_comp = bottom; + (* FIXME: this is very likely incorrect *) gvar_info = typeStringLiteral s; gvar_init = !init; gvar_readonly = true; gvar_volatile = false}) @@ -647,7 +648,7 @@ let global_for_wide_string (s, ik) id = init := init_of_char(Z.of_uint64 c) :: !init in List.iter add_char s; add_char 0L; - AST.(id, Gvar { gvar_comp = privileged_compartment; (* FIXME: incorrect *) + AST.(id, Gvar { gvar_comp = bottom; (* FIXME: incorrect *) gvar_info = typeWideStringLiteral s ik; gvar_init = List.rev !init; gvar_readonly = true; gvar_volatile = false}) @@ -874,7 +875,7 @@ let rec convertExpr cp env e = | [] -> assert false (* catched earlier *) in let targs2 = convertTypAnnotArgs env args2 in Ebuiltin( - AST.EF_debug(cp, P.of_int64 kind, intern_string text, + AST.EF_debug(P.of_int64 kind, intern_string text, typlist_of_typelist targs2), targs2, convertExprList cp env args2, convertTyp env e.etyp) @@ -883,7 +884,7 @@ let rec convertExpr cp env e = | {edesc = C.EConst(CStr txt)} :: args1 -> let targs1 = convertTypAnnotArgs env args1 in Ebuiltin( - AST.EF_annot(cp, P.of_int 1,coqstring_of_camlstring txt, typlist_of_typelist targs1), + AST.EF_annot(P.of_int 1,coqstring_of_camlstring txt, typlist_of_typelist targs1), targs1, convertExprList cp env args1, convertTyp env e.etyp) | _ -> error "argument 1 of '__builtin_annot' must be a string literal"; @@ -895,7 +896,7 @@ let rec convertExpr cp env e = | [ {edesc = C.EConst(CStr txt)}; arg ] -> let targ = convertTyp env (Cutil.default_argument_conversion env arg.etyp) in - Ebuiltin(AST.EF_annot_val(cp, P.of_int 1,coqstring_of_camlstring txt, typ_of_type targ), + Ebuiltin(AST.EF_annot_val(P.of_int 1,coqstring_of_camlstring txt, typ_of_type targ), Tcons(targ, Tnil), convertExprList cp env [arg], convertTyp env e.etyp) | _ -> @@ -912,7 +913,7 @@ let rec convertExpr cp env e = let targs1 = convertTypAnnotArgs env args1 in AisAnnot.validate_ais_annot env !currentLocation txt args1; Ebuiltin( - AST.EF_annot(cp, P.of_int 2,coqstring_of_camlstring (loc_string ^ txt), typlist_of_typelist targs1), + AST.EF_annot(P.of_int 2,coqstring_of_camlstring (loc_string ^ txt), typlist_of_typelist targs1), targs1, convertExprList cp env args1, convertTyp env e.etyp) | _ -> error "argument 1 of '__builtin_ais_annot' must be a string literal"; @@ -939,7 +940,7 @@ let rec convertExpr cp env e = | C.ECall({edesc = C.EVar {name = "__builtin_va_copy"}}, [arg1; arg2]) -> let dst = convertExpr cp env arg1 in let src = convertExpr cp env arg2 in - Ebuiltin( AST.EF_memcpy(cp, Z.of_uint CBuiltins.size_va_list, Z.of_uint 4), + Ebuiltin( AST.EF_memcpy(Z.of_uint CBuiltins.size_va_list, Z.of_uint 4), Tcons(Tpointer(Tvoid, noattr), Tcons(Tpointer(Tvoid, noattr), Tnil)), Econs(va_list_ptr dst, Econs(va_list_ptr src, Enil)), @@ -959,7 +960,7 @@ let rec convertExpr cp env e = let sg = signature_of_type targs tres { AST.cc_vararg = Some (coqint_of_camlint 1l); cc_unproto = false; cc_structret = false} in - Ebuiltin( AST.EF_external(cp, coqstring_of_camlstring "printf", sg), (* NOTE old: privileged_compartment *) + Ebuiltin( AST.EF_external(coqstring_of_camlstring "printf", sg), (* NOTE old: privileged_compartment *) targs, convertExprList cp env args, tres) | C.ECall(fn, args) -> @@ -1020,7 +1021,7 @@ let convertAsm cp loc env txt outputs inputs clobber = let e = let tinputs = convertTypAnnotArgs env inputs' in let toutput = convertTyp env ty_res in - Ebuiltin( AST.EF_inline_asm(cp, coqstring_of_camlstring txt', + Ebuiltin( AST.EF_inline_asm(coqstring_of_camlstring txt', signature_of_type tinputs toutput AST.cc_default, clobber'), tinputs, @@ -1140,7 +1141,7 @@ let convertFundef loc env fd = Debug.atom_local_variable id id'; (id', convertTyp env ty)) fd.fd_locals in - let body' = convertStmt (intern_string fd.fd_comp) env fd.fd_body in + let body' = convertStmt (Comp (intern_string fd.fd_comp)) env fd.fd_body in let id' = intern_string fd.fd_name.name in let noinline = Cutil.find_custom_attributes ["noinline";"__noinline__"] fd.fd_attrib <> [] in let inline = if noinline || fd.fd_vararg then (* PR#15 *) @@ -1150,7 +1151,7 @@ let convertFundef loc env fd = else No_specifier in let cp = - intern_string fd.fd_comp in + Comp (intern_string fd.fd_comp) in Debug.atom_global fd.fd_name id'; Hashtbl.add decl_atom id' { a_storage = fd.fd_storage; @@ -1183,14 +1184,13 @@ let convertFundecl env (sto, id, ty, optinit, comp) = let sg = signature_of_type args res cconv in (* TODO: should we check that the [comp] we have is indeed the compartment of the predefined *) (* functions such as [EF_malloc] or [EF_free]? *) - let cp = intern_string comp in let ef = - if id.name = "malloc" then AST.EF_malloc cp else - if id.name = "free" then AST.EF_free cp else + if id.name = "malloc" then AST.EF_malloc else + if id.name = "free" then AST.EF_free else if Str.string_match re_builtin id.name 0 && List.mem_assoc id.name builtins.builtin_functions - then AST.EF_builtin(cp, id'', sg) - else AST.EF_external(cp, id'', sg) in + then AST.EF_builtin(id'', sg) + else AST.EF_external(id'', sg) in (id', AST.Gfun(Ctypes.External(ef, args, res, cconv))) (** Initializers *) @@ -1224,7 +1224,7 @@ let convertInitializer cp env ty i = let convertGlobvar loc env (sto, id, ty, optinit, comp) = let id' = intern_string id.name in - let cp = intern_string comp in + let cp = Comp (intern_string comp) in Debug.atom_global id id'; let ty' = convertTyp env ty in let sz = Ctypes.sizeof !comp_env ty' in @@ -1378,7 +1378,7 @@ let helper_function_declaration cp (name, tyres, tyargs) = List.fold_right (fun t tl -> Tcons(t, tl)) tyargs Tnil in let ef = (* AST.EF_runtime(cp, coqstring_of_camlstring name, *) - AST.EF_runtime(cp, Builtins0.standard_builtin_name (coqstring_of_camlstring name) cp, + AST.EF_runtime((coqstring_of_camlstring name), signature_of_type tyargs tyres AST.cc_default) in (intern_string name, AST.Gfun (Ctypes.External(ef, tyargs, tyres, AST.cc_default))) @@ -1475,21 +1475,22 @@ let public_globals gl = (* List.fold_left f l (T.empty _). *) let add_to_tree = fun m k_v -> - match Maps.PTree.get (fst k_v) m with - | None -> Maps.PTree.set (fst k_v) [snd k_v] m - | Some s -> Maps.PTree.set (fst k_v) (snd k_v :: s) m + match CompTree.get (fst k_v) m with + | None -> CompTree.set (fst k_v) [snd k_v] m + | Some s -> CompTree.set (fst k_v) (snd k_v :: s) m let of_list' l = - List.fold_left add_to_tree Maps.PTree.empty l + List.fold_left add_to_tree CompTree.empty l (* FIXME: this is very ad-hoc. I'm worried that by generating new names using "intern_string", we might be doing something bad. Ideally, we should inspect *) (* the rest of the file and figure out how the translation between C.ident and AST.ident works. *) let build_policy (imports: C.import list) (exports: C.export list): AST.Policy.t = let open AST.Policy in - let exports' = List.map (function Export(id1, id2) -> (intern_string id1.name, intern_string id2.name)) exports in - let exports'': AST.ident list Maps.PTree.t = of_list' exports' in - let imports' = List.map (function Import(id1, id2, id3) -> (intern_string id1.name, (intern_string id2.name, intern_string id3.name))) imports in - let imports'': (AST.compartment * AST.ident) list Maps.PTree.t = of_list' imports' in + let exports' = List.map (function Export(id1, id2) -> (Comp (intern_string id1.name), intern_string id2.name)) exports in + let exports'': AST.ident list CompTree.t = of_list' exports' in + let imports' = List.map (function Import(id1, id2, id3) -> + (Comp (intern_string id1.name), (Comp (intern_string id2.name), intern_string id3.name))) imports in + let imports'': (compartment * AST.ident) list Maps.PTree.t = of_list' imports' in (* let imports'': (AST.compartment * AST.ident) list Maps.PTree.t = Maps.PTree_Properties.of_list [] in *) let p = { policy_export = exports''; policy_import = imports'' } in diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index ebe64533a4..ae9700f9b5 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -108,7 +108,7 @@ Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) match access_mode ty with | By_value chunk => match type_is_volatile ty with - | false => do v <- Mem.loadv chunk m (Vptr b ofs) (Some cp); Some(w, E0, v) + | false => do v <- Mem.loadv chunk m (Vptr b ofs) cp; Some(w, E0, v) | true => do_volatile_load _ _ ge w chunk cp m b ofs end | By_reference => Some(w, E0, Vptr b ofs) @@ -121,7 +121,7 @@ Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) check (intsize_eq sz1 sz && signedness_eq sg1 (if zlt width (bitsize_intsize sz) then Signed else sg) && zle 0 pos && zlt 0 width && zle width (bitsize_intsize sz) && zle (pos + width) (bitsize_carrier sz)); - match Mem.loadv (chunk_for_carrier sz) m (Vptr b ofs) (Some cp) with + match Mem.loadv (chunk_for_carrier sz) m (Vptr b ofs) cp with | Some (Vint c) => Some (w, E0, Vint (bitfield_extract sz sg pos width c)) | _ => None end @@ -171,7 +171,7 @@ Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) match v with | Vptr b' ofs' => if check_assign_copy ty b ofs b' ofs' then - do bytes <- Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ge ty) (Some cp); + do bytes <- Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ge ty) cp; do m' <- Mem.storebytes m b (Ptrofs.unsigned ofs) bytes cp; Some(w, E0, m', v) else None @@ -181,7 +181,7 @@ Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) end | Bits sz sg pos width => check (zle 0 pos && zlt 0 width && zle width (bitsize_intsize sz) && zle (pos + width) (bitsize_carrier sz)); - match ty, v, Mem.loadv (chunk_for_carrier sz) m (Vptr b ofs) (Some cp) with + match ty, v, Mem.loadv (chunk_for_carrier sz) m (Vptr b ofs) cp with | Tint sz1 sg1 _, Vint n, Some (Vint c) => check (intsize_eq sz1 sz && signedness_eq sg1 (if zlt width (bitsize_intsize sz) then Signed else sg)); @@ -268,32 +268,32 @@ Proof. Qed. Variable do_external_function: - compartment -> string -> signature -> Senv.t -> world -> list val -> mem -> option (world * trace * val * mem). + string -> signature -> Senv.t -> compartment -> world -> list val -> mem -> option (world * trace * val * mem). Hypothesis do_external_function_sound: forall cp id sg ge vargs m t vres m' w w', - do_external_function cp id sg ge w vargs m = Some(w', t, vres, m') -> - external_functions_sem cp id sg ge vargs m t vres m' /\ possible_trace w t w'. + do_external_function id sg ge cp w vargs m = Some(w', t, vres, m') -> + external_functions_sem id sg ge cp vargs m t vres m' /\ possible_trace w t w'. Hypothesis do_external_function_complete: forall cp id sg ge vargs m t vres m' w w', - external_functions_sem cp id sg ge vargs m t vres m' -> + external_functions_sem id sg ge cp vargs m t vres m' -> possible_trace w t w' -> - do_external_function cp id sg ge w vargs m = Some(w', t, vres, m'). + do_external_function id sg ge cp w vargs m = Some(w', t, vres, m'). Variable do_inline_assembly: - compartment -> string -> signature -> Senv.t -> world -> list val -> mem -> option (world * trace * val * mem). + string -> signature -> Senv.t -> compartment -> world -> list val -> mem -> option (world * trace * val * mem). Hypothesis do_inline_assembly_sound: forall txt sg ge cp vargs m t vres m' w w', - do_inline_assembly cp txt sg ge w vargs m = Some(w', t, vres, m') -> - inline_assembly_sem cp txt sg ge vargs m t vres m' /\ possible_trace w t w'. + do_inline_assembly txt sg ge cp w vargs m = Some(w', t, vres, m') -> + inline_assembly_sem txt sg ge cp vargs m t vres m' /\ possible_trace w t w'. Hypothesis do_inline_assembly_complete: forall txt sg ge cp vargs m t vres m' w w', - inline_assembly_sem cp txt sg ge vargs m t vres m' -> + inline_assembly_sem txt sg ge cp vargs m t vres m' -> possible_trace w t w' -> - do_inline_assembly cp txt sg ge w vargs m = Some(w', t, vres, m'). + do_inline_assembly txt sg ge cp w vargs m = Some(w', t, vres, m'). (** * Reduction of expressions *) @@ -561,8 +561,8 @@ Fixpoint step_expr (cp: compartment) (k: kind) (a: expr) (m: mem): reducts expr match is_val_list rargs with | Some vtl => do vargs <- sem_cast_arguments vtl tyargs m; - check (Pos.eqb (comp_of ef) cp); - match do_external _ _ ge do_external_function do_inline_assembly ef w vargs m with + (* check (Pos.eqb (comp_of ef) cp); *) + match do_external _ _ ge do_external_function do_inline_assembly ef cp w vargs m with | None => stuck | Some(w',t,v,m') => topred (Rred "red_builtin" (Eval v ty) m' t) end @@ -680,8 +680,7 @@ Definition invert_expr_prop (cp: compartment) (a: expr) (m: mem) : Prop := exprlist_all_values rargs -> exists vargs t vres m' w', cast_arguments m rargs tyargs vargs - /\ external_call ef ge vargs m t vres m' - /\ comp_of ef = cp + /\ external_call ef ge cp vargs m t vres m' /\ possible_trace w t w' | _ => True end. @@ -1178,12 +1177,12 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; destruct (Genv.allowed_call_b ge cp vf) eqn:ALLOWED... destruct (sem_cast_arguments vtl tyargs m) as [vargs|] eqn:?... destruct (type_eq (type_of_fundef fd) (Tfunction tyargs tyres cconv))... - destruct (Genv.type_of_call cp (comp_of fd)) eqn:?... + destruct (flowsto_dec (comp_of fd) cp) eqn:?... destruct (get_call_trace _ _ ge cp (comp_of fd) vf vargs (typlist_of_typelist tyargs)) eqn:?... apply topred_ok; auto. red. split; auto. eapply red_call; eauto. eapply sem_cast_arguments_sound; eauto. (* Use Heqb *) - eapply Genv.allowed_call_reflect; eauto. congruence. + eapply Genv.allowed_call_reflect; eauto. simpl. rewrite Heqs. congruence. eapply get_call_trace_eq; eauto. apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. eapply get_call_trace_eq in H5. @@ -1200,14 +1199,14 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; eapply get_call_trace_eq; eauto. apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. (* apply Genv.cross_call_reflect in Heqb. *) - assert (x2 = fd) as -> by congruence. specialize (H4 Heqc0). + assert (x2 = fd) as -> by congruence. rewrite Heqs in H4. specialize (H4 eq_refl). rewrite Heqc in H; inv H. rewrite Heqo1 in H0; inv H0. exploit sem_cast_arguments_complete; eauto. intros [vtl' [P Q]]. rewrite Heqo0 in P. inv P. rewrite Heqo2 in Q; inv Q. eapply get_call_trace_eq in H5; congruence. apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. (* apply Genv.cross_call_reflect in Heqb. *) - assert (x2 = fd) as -> by congruence. specialize (H4 Heqc0). + assert (x2 = fd) as -> by congruence. rewrite Heqs in H4. specialize (H4 eq_refl). rewrite Heqc in H; inv H. rewrite Heqo1 in H0; inv H0. exploit sem_cast_arguments_complete; eauto. intros [vtl' [P Q]]. rewrite Heqo0 in P. inv P. @@ -1246,18 +1245,19 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; exploit is_val_list_all_values; eauto. intros ALLVAL. (* top *) destruct (sem_cast_arguments vtl tyargs m) as [vargs|] eqn:?... - destruct (Pos.eqb (comp_of ef) cp) eqn:?... - destruct (do_external _ _ ge do_external_function do_inline_assembly ef w vargs m) as [[[[? ?] v] m'] | ] eqn:?... + (* destruct (Pos.eqb (comp_of ef) cp) eqn:?... *) + destruct (do_external _ _ ge do_external_function do_inline_assembly ef cp w vargs m) as [[[[? ?] v] m'] | ] eqn:?... exploit do_ef_external_sound; eauto. intros [EC PT]. apply topred_ok; auto. red. split; auto. eapply red_builtin; eauto. - eapply sem_cast_arguments_sound; eauto. now apply Peqb_true_eq. + eapply sem_cast_arguments_sound; eauto. exists w0; auto. apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. assert (x = vargs). exploit sem_cast_arguments_complete; eauto. intros [vtl' [A B]]. congruence. subst x. exploit do_ef_external_complete; eauto. congruence. - apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. subst. now rewrite Pos.eqb_refl in Heqb. apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. + (* subst. now rewrite Pos.eqb_refl in Heqb. *) + (* apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. *) exploit sem_cast_arguments_complete; eauto. intros [vtl' [A B]]. congruence. (* depth *) eapply incontext_list_ok; eauto. @@ -1357,9 +1357,8 @@ Proof. inv H0. rewrite H; econstructor; eauto. (* builtin *) exploit sem_cast_arguments_complete; eauto. intros [vtl [A B]]. - subst cp. exploit do_ef_external_complete; eauto. intros C. - rewrite A. rewrite B. rewrite Pos.eqb_refl. rewrite C. econstructor; eauto. + rewrite A. rewrite B. rewrite C. econstructor; eauto. Qed. Lemma callred_topred: @@ -1373,8 +1372,9 @@ Proof. eapply Genv.allowed_call_reflect in ALLOWED. rewrite ALLOWED. econstructor; eauto. - destruct (Genv.type_of_call cp (comp_of fd)) eqn:?; try reflexivity. + destruct (flowsto_dec (comp_of fd) cp) eqn:?; try reflexivity. eapply get_call_trace_eq in EV; rewrite EV; eauto. + simpl in NO_CROSS_PTR; rewrite Heqs in NO_CROSS_PTR. specialize (NO_CROSS_PTR eq_refl). pose proof (proj1 (Forall_forall _ _) NO_CROSS_PTR) as G. assert (forallb not_ptr_b vargs = true) as G'. @@ -1815,9 +1815,9 @@ Definition do_step (w: world) (s: state) : list transition := do m2 <- sem_bind_parameters w e m1 f.(fn_params) vargs (fn_comp f); ret "step_internal_function" (State f f.(fn_body) k e m2) | Callstate (External ef _ tres _) vargs k m => - match do_external _ _ ge do_external_function do_inline_assembly ef w vargs m with + match do_external _ _ ge do_external_function do_inline_assembly ef (call_comp k) w vargs m with | None => nil - | Some(w',t,v,m') => TR "step_external_function" t (Returnstate v k m' (rettype_of_type tres) (comp_of ef)) :: nil + | Some(w',t,v,m') => TR "step_external_function" t (Returnstate v k m' (rettype_of_type tres) bottom) :: nil end | Returnstate v (Kcall f e C ty k) m ty' cp => @@ -1897,6 +1897,7 @@ Proof with try (left; right; econstructor; eauto; fail). eapply do_ef_external_sound; eauto. (* returnstate *) destruct k; myinv... left; right; constructor. + simpl. intros REWR; rewrite REWR in Heqb. now apply not_ptr_reflect. now apply get_return_trace_eq in Heqo. (* stuckstate *) @@ -2003,6 +2004,7 @@ Proof with (unfold ret; eauto with coqlib). { destruct (Genv.type_of_call (comp_of f) cp) eqn:eq_type_of_call; [reflexivity | ]. apply not_ptr_reflect; auto. } + simpl in H. rewrite H. apply get_return_trace_eq in EV; rewrite EV. simpl. left; reflexivity. Qed. diff --git a/cfrontend/Clight.v b/cfrontend/Clight.v index 278758c648..4f6ba4169f 100644 --- a/cfrontend/Clight.v +++ b/cfrontend/Clight.v @@ -215,7 +215,7 @@ Inductive deref_loc (cp: compartment) (ty: type) (m: mem) (b: block) (ofs: ptrof bitfield -> val -> Prop := | deref_loc_value: forall chunk v, access_mode ty = By_value chunk -> - Mem.loadv chunk m (Vptr b ofs) (Some cp) = Some v -> + Mem.loadv chunk m (Vptr b ofs) cp = Some v -> deref_loc cp ty m b ofs Full v | deref_loc_reference: access_mode ty = By_reference -> @@ -224,7 +224,7 @@ Inductive deref_loc (cp: compartment) (ty: type) (m: mem) (b: block) (ofs: ptrof access_mode ty = By_copy -> deref_loc cp ty m b ofs Full (Vptr b ofs) | deref_loc_bitfield: forall sz sg pos width v, - load_bitfield ty sz sg pos width m (Vptr b ofs) v (Some cp) -> + load_bitfield ty sz sg pos width m (Vptr b ofs) v cp -> deref_loc cp ty m b ofs (Bits sz sg pos width) v. (** Symmetrically, [assign_loc ty m b ofs bf v m'] returns the @@ -247,7 +247,7 @@ Inductive assign_loc (ce: composite_env) (cp: compartment) (ty: type) (m: mem) ( b' <> b \/ Ptrofs.unsigned ofs' = Ptrofs.unsigned ofs \/ Ptrofs.unsigned ofs' + sizeof ce ty <= Ptrofs.unsigned ofs \/ Ptrofs.unsigned ofs + sizeof ce ty <= Ptrofs.unsigned ofs' -> - Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ce ty) (Some cp) = Some bytes -> + Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ce ty) cp = Some bytes -> Mem.storebytes m b (Ptrofs.unsigned ofs) bytes cp = Some m' -> assign_loc ce cp ty m b ofs Full (Vptr b' ofs') m' | assign_loc_bitfield: forall sz sg pos width v m' v', @@ -494,10 +494,10 @@ Definition is_call_cont (k: cont) : Prop := | _ => False end. -Definition call_comp (k: cont) : option compartment := +Definition call_comp (k: cont) : compartment := match call_cont k with - | Kcall _ f _ _ _ => Some (comp_of f) - | _ => None + | Kcall _ f _ _ _ => comp_of f + | _ => top end. (** States *) @@ -602,8 +602,7 @@ Inductive step: state -> trace -> state -> Prop := | step_builtin: forall f optid ef tyargs al k e le m vargs t vres m', eval_exprlist e (comp_of f) le m al tyargs vargs -> - forall ALLOWED: comp_of ef = comp_of f, - external_call ef ge vargs m t vres m' -> + external_call ef ge (comp_of f) vargs m t vres m' -> step (State f (Sbuiltin optid ef tyargs al) k e le m) t (State f Sskip k e (set_opttemp optid vres le) m') @@ -687,9 +686,9 @@ Inductive step: state -> trace -> state -> Prop := E0 (State f f.(fn_body) k e le m1) | step_external_function: forall ef targs tres cconv vargs k m vres t m', - external_call ef ge vargs m t vres m' -> + external_call ef ge (call_comp k) vargs m t vres m' -> step (Callstate (External ef targs tres cconv) vargs k m) - t (Returnstate vres k m' (rettype_of_type tres) (comp_of ef)) + t (Returnstate vres k m' (rettype_of_type tres) bottom) | step_returnstate: forall v optid f e le ty cp k m t, forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) cp = Genv.CrossCompartmentCall -> @@ -1061,7 +1060,7 @@ Proof. parallel_find_funct. reflexivity. - parallel_eval_exprlist. - destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ H0 H13) as (_ & EQ). + destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ _ H0 H13) as (_ & EQ). specialize (EQ eq_refl) as [<- <-]. reflexivity. - parallel_eval_expr. @@ -1082,7 +1081,7 @@ Proof. reflexivity. - parallel_function_entry1. reflexivity. - - destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ H H9) as (_ & EQ). + - destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ _ H H9) as (_ & EQ). specialize (EQ eq_refl) as [<- <-]. reflexivity. Qed. @@ -1101,10 +1100,10 @@ Proof. destruct (eval_exprlist_determ H1 H16). reflexivity. - destruct (eval_exprlist_determ H H12). - destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ H0 H13) as [_ EQ]. + destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ _ H0 H13) as [_ EQ]. specialize (EQ eq_refl) as [<- <-]. reflexivity. - - destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ H H9) as [_ EQ]. + - destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ _ H H9) as [_ EQ]. specialize (EQ eq_refl) as [<- <-]. reflexivity. - reflexivity. @@ -1138,9 +1137,9 @@ Proof. rewrite H2 in H17. injection H17 as <-. parallel_call_trace. - parallel_eval_exprlist. - destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ H0 H13) as (? & ?). + destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ _ H0 H13) as (? & ?). inv H1. - - destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ H H9) as (? & ?). + - destruct (external_call_determ _ _ _ _ _ _ _ _ _ _ _ H H9) as (? & ?). inv H0. - pose proof return_trace_determ EV EV0; discriminate. Qed. diff --git a/cfrontend/ClightBigstep.v b/cfrontend/ClightBigstep.v index 6b77f6cd45..01d969c3dd 100644 --- a/cfrontend/ClightBigstep.v +++ b/cfrontend/ClightBigstep.v @@ -97,7 +97,7 @@ Inductive exec_stmt: env -> compartment -> temp_env -> eval_exprlist ge e c le m al tyargs vargs -> Genv.find_funct ge vf = Some fd -> type_of_fundef fd = Tfunction tyargs tyres cconv -> - eval_funcall m fd vargs t m' vres -> + eval_funcall c m fd vargs t m' vres -> forall (ALLOWED: Genv.allowed_call ge c vf), forall (NO_CROSS_PTR_CALL: Genv.type_of_call c (comp_of fd) = Genv.CrossCompartmentCall -> Forall not_ptr vargs), forall (NO_CROSS_PTR_RETURN: Genv.type_of_call c (comp_of fd) = Genv.CrossCompartmentCall -> not_ptr vres), @@ -107,8 +107,7 @@ Inductive exec_stmt: env -> compartment -> temp_env -> (t' ** t ** t'') (set_opttemp optid vres le) m' Out_normal | exec_Sbuiltin: forall e c le m optid ef al tyargs vargs t m' vres, eval_exprlist ge e c le m al tyargs vargs -> - external_call ef ge vargs m t vres m' -> - forall ALLOWED: comp_of ef = c, + external_call ef ge c vargs m t vres m' -> exec_stmt e c le m (Sbuiltin optid ef tyargs al) t (set_opttemp optid vres le) m' Out_normal | exec_Sseq_1: forall e c le m s1 s2 t1 le1 m1 t2 le2 m2 out, @@ -169,18 +168,18 @@ Inductive exec_stmt: env -> compartment -> temp_env -> (** [eval_funcall m1 fd args t m2 res] describes the invocation of function [fd] with arguments [args]. [res] is the value returned by the call. *) -with eval_funcall: mem -> fundef -> list val -> trace -> mem -> val -> Prop := - | eval_funcall_internal: forall le m f vargs t e m1 m2 m3 out vres m4, +with eval_funcall: compartment -> mem -> fundef -> list val -> trace -> mem -> val -> Prop := + | eval_funcall_internal: forall cp le m f vargs t e m1 m2 m3 out vres m4, alloc_variables ge (comp_of f) empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) -> bind_parameters ge (comp_of f) e m1 f.(fn_params) vargs m2 -> exec_stmt e (comp_of f) (create_undef_temps f.(fn_temps)) m2 f.(fn_body) t le m3 out -> outcome_result_value out f.(fn_return) vres m3 -> Mem.free_list m3 (blocks_of_env ge e) (comp_of f) = Some m4 -> - eval_funcall m (Internal f) vargs t m4 vres - | eval_funcall_external: forall m ef targs tres cconv vargs t vres m', - external_call ef ge vargs m t vres m' -> - eval_funcall m (External ef targs tres cconv) vargs t m' vres. + eval_funcall cp m (Internal f) vargs t m4 vres + | eval_funcall_external: forall cp m ef targs tres cconv vargs t vres m', + external_call ef ge cp vargs m t vres m' -> + eval_funcall cp m (External ef targs tres cconv) vargs t m' vres. Scheme exec_stmt_ind2 := Minimality for exec_stmt Sort Prop with eval_funcall_ind2 := Minimality for eval_funcall Sort Prop. @@ -259,7 +258,7 @@ Inductive bigstep_program_terminates (p: program): trace -> int -> Prop := 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 -> - eval_funcall ge m0 f nil t m1 (Vint r) -> + eval_funcall ge top m0 f nil t m1 (Vint r) -> bigstep_program_terminates p t r. Inductive bigstep_program_diverges (p: program): traceinf -> Prop := @@ -315,11 +314,12 @@ Lemma exec_stmt_eval_funcall_steps: star step1 ge (State f s k e le m) t S /\ outcome_state_match e le' m' f k out S) /\ - (forall m fd args t m' res, - eval_funcall ge m fd args t m' res -> + (forall c m fd args t m' res, + eval_funcall ge c m fd args t m' res -> forall k tyargs tyres cconv, forall RETTYPE: type_of_fundef fd = Tfunction tyargs tyres cconv, is_call_cont k -> + forall COMP: c = call_comp k, star step1 ge (Callstate fd args k m) t (Returnstate res k m' (rettype_of_type tyres) (comp_of fd))). Proof. apply exec_stmt_funcall_ind; intros; try subst c. @@ -343,7 +343,6 @@ Proof. constructor. (* builtin *) - rewrite H1 in *. econstructor; split. apply star_one; econstructor; eauto. econstructor. @@ -508,11 +507,12 @@ Proof. Qed. Lemma eval_funcall_steps: - forall m fd args t m' res, - eval_funcall ge m fd args t m' res -> + forall c m fd args t m' res, + eval_funcall ge c m fd args t m' res -> forall k tyargs tyres cconv, forall RETTYPE: type_of_fundef fd = Tfunction tyargs tyres cconv, is_call_cont k -> + forall COMP: c = call_comp k, star step1 ge (Callstate fd args k m) t (Returnstate res k m' (rettype_of_type tyres) (comp_of fd)). Proof. apply (proj2 exec_stmt_eval_funcall_steps). Qed. @@ -600,6 +600,7 @@ Proof. inv H. econstructor; econstructor. split. econstructor; eauto. split. eapply eval_funcall_steps. eauto. eauto. eauto. red; auto. + reflexivity. econstructor. (* divergence *) inv H. econstructor. diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index 18e9857835..d83762ebee 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -525,7 +525,7 @@ Inductive match_callstack (f: meminj) (m: mem) (tm: mem): (MTMP: match_temps f le te) (MENV: match_env f cenv e sp lo hi) (BOUND: match_bounds e m) - (COMP: Mem.can_access_block tm sp (Some (comp_of tf))) + (COMP: Mem.can_access_block tm sp (comp_of tf)) (* (COMP: Mem.block_compartment tm sp = Some (comp_of tf)) *) (PERM: padding_freeable f e tm sp tf.(fn_stackspace)) (MCS: match_callstack f m tm cs lo sp), @@ -745,7 +745,7 @@ Proof. eelim Mem.fresh_block_alloc; eauto. eapply Mem.valid_block_inject_2; eauto. rewrite RES. change (Mem.valid_block tm tb). eapply Mem.valid_block_inject_2; eauto. red; intros. rewrite PTree.gempty in H4. discriminate. - subst. eapply Mem.owned_new_block. eauto. + subst. simpl. erewrite Mem.owned_new_block; eauto. apply flowsto_refl. red; intros. left. eapply Mem.perm_alloc_2; eauto. eapply match_callstack_invariant with (tm1 := tm); eauto. rewrite RES; auto. @@ -1674,7 +1674,7 @@ Inductive match_states: Csharpminor.state -> Cminor.state -> Prop := (ISCC: Csharpminor.is_call_cont k) (ARGSINJ: Val.inject_list f args targs), match_states (Csharpminor.Callstate fd args k m) - (Callstate tfd targs tk tm) + (Callstate tfd targs tk tm (Csharpminor.call_comp k)) | match_returnstate: forall v k m tv tk tm cp f cs cenv sg (MINJ: Mem.inject f m tm) @@ -2023,7 +2023,7 @@ Proof. Qed. Lemma find_comp_transl: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. apply (Genv.find_comp_transf_partial TRANSL). Qed. @@ -2034,7 +2034,7 @@ Lemma type_of_call_transl: forall cenv f cp sz tfn, Proof. intros cenv f vf sz tfn TRF. erewrite <- (comp_transl_partial _ TRF). - eapply (Genv.type_of_call_transf_partial). + reflexivity. Qed. (** The simulation diagram. *) @@ -2138,9 +2138,12 @@ Proof. now rewrite (comp_of_fun_transl TRANS). rewrite <- (comp_of_fun_transl TRANS). monadInv TRF; unfold comp_of; simpl. eapply call_trace_translated; eauto. + replace (comp_of tfn) with (Csharpminor.call_comp (Csharpminor.Kcall optid f e le k)). econstructor; eauto. eapply match_Kcall with (cenv' := cenv); eauto. red; auto. + unfold Csharpminor.call_comp. simpl. + rewrite comp_transl_funbody; eauto. (* builtin *) monadInv TR. @@ -2149,12 +2152,12 @@ Proof. exploit match_callstack_match_globalenvs; eauto. intros [hi' MG]. exploit external_call_mem_inject; eauto. eapply inj_preserves_globals; eauto. - intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR [SEPARATED COMPNEW]]]]]]]]]]. + intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR SEPARATED]]]]]]]]]. left; econstructor; split. apply plus_one. econstructor. eauto. - (* rewrite <- (comp_transl_partial _ TRF). *) + rewrite <- (comp_transl_partial _ TRF). eapply external_call_symbols_preserved; eauto. apply senv_preserved. - monadInv TRF; auto. + (* monadInv TRF; auto. *) assert (MCS': match_callstack f' m' tm' (Frame cenv tfn e le te sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm')). @@ -2316,7 +2319,7 @@ Opaque PTree.set. exploit match_callstack_match_globalenvs; eauto. intros [hi MG]. exploit external_call_mem_inject; eauto. eapply inj_preserves_globals; eauto. - intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR [SEPARATED COMPNEW]]]]]]]]]]. + intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR SEPARATED]]]]]]]]]. left; econstructor; split. apply plus_one. econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index cab6022aae..c09ff9caac 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -60,7 +60,7 @@ Inductive deref_loc (cp: compartment) (ty: type) (m: mem) (b: block) (ofs: ptrof | deref_loc_value: forall chunk v, access_mode ty = By_value chunk -> type_is_volatile ty = false -> - Mem.loadv chunk m (Vptr b ofs) (Some cp) = Some v -> + Mem.loadv chunk m (Vptr b ofs) cp = Some v -> deref_loc cp ty m b ofs Full E0 v | deref_loc_volatile: forall chunk t v, access_mode ty = By_value chunk -> type_is_volatile ty = true -> @@ -73,7 +73,7 @@ Inductive deref_loc (cp: compartment) (ty: type) (m: mem) (b: block) (ofs: ptrof access_mode ty = By_copy -> deref_loc cp ty m b ofs Full E0 (Vptr b ofs) | deref_loc_bitfield: forall sz sg pos width v, - load_bitfield ty sz sg pos width m (Vptr b ofs) v (Some cp) -> + load_bitfield ty sz sg pos width m (Vptr b ofs) v cp -> deref_loc cp ty m b ofs (Bits sz sg pos width) E0 v. (** Symmetrically, [assign_loc ty m b ofs bf v t m' v'] returns the @@ -106,7 +106,7 @@ Inductive assign_loc (cp: compartment) (ty: type) (m: mem) (b: block) (ofs: ptro b' <> b \/ Ptrofs.unsigned ofs' = Ptrofs.unsigned ofs \/ Ptrofs.unsigned ofs' + sizeof ge ty <= Ptrofs.unsigned ofs \/ Ptrofs.unsigned ofs + sizeof ge ty <= Ptrofs.unsigned ofs' -> - Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ge ty) (Some cp) = Some bytes -> + Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ge ty) cp = Some bytes -> Mem.storebytes m b (Ptrofs.unsigned ofs) bytes cp = Some m' -> assign_loc cp ty m b ofs Full (Vptr b' ofs') E0 m' (Vptr b' ofs') | assign_loc_bitfield: forall sz sg pos width v m' v', @@ -315,8 +315,7 @@ Inductive rred: expr -> mem -> trace -> expr -> mem -> Prop := E0 (Eval v ty) m | red_builtin: forall ef tyargs el ty m vargs t vres m', cast_arguments m el tyargs vargs -> - comp_of ef = cp -> - external_call ef ge vargs m t vres m' -> + external_call ef ge cp vargs m t vres m' -> rred (Ebuiltin ef tyargs el ty) m t (Eval vres ty) m'. @@ -467,10 +466,9 @@ Proof. intros. unfold Eselection. set (t := typ_of_type ty). set (sg := mksignature (AST.Tint :: t :: t :: nil) t cc_default). - assert (LK: lookup_builtin_function "__builtin_sel"%string cp sg = Some (BI_standard (BI_select t))). - (* { unfold sg, t; destruct ty as [ | ? ? ? | ? | [] ? | ? ? | ? ? ? | ? ? ? | ? ? | ? ? ]; *) - (* simpl; unfold Tptr; destruct Archi.ptr64; reflexivity. } *) - { admit. } + assert (LK: lookup_builtin_function "__builtin_sel"%string sg = Some (BI_standard (BI_select t))). + { unfold sg, t; destruct ty as [ | ? ? ? | ? | [] ? | ? ? | ? ? ? | ? ? ? | ? ? | ? ? ]; + simpl; unfold Tptr; destruct Archi.ptr64; reflexivity. } set (v' := if b then v2' else v3'). assert (C: val_casted v' ty). { unfold v'; destruct b; eapply cast_val_is_casted; eauto. } @@ -481,11 +479,9 @@ Proof. constructor. eauto. constructor. eauto. constructor. -- reflexivity. - red. red. rewrite LK. constructor. simpl. rewrite <- EQ. destruct b; auto. -(* Qed. *) -Admitted. +Qed. Lemma ctx_selection_1: forall k C r2 r3 ty, context k RV C -> context k RV (fun x => Eselection cp (C x) r2 r3 ty). @@ -562,10 +558,10 @@ Definition is_call_cont (k: cont) : Prop := | _ => False end. -Definition call_comp (k: cont) : option compartment := +Definition call_comp (k: cont) : compartment := match call_cont k with - | Kcall f _ _ _ _ => Some (comp_of f) - | _ => None + | Kcall f _ _ _ _ => comp_of f + | _ => top end. (** Execution states of the program are grouped in 4 classes corresponding @@ -824,9 +820,9 @@ Inductive sstep: state -> trace -> state -> Prop := E0 (State f f.(fn_body) k e m2) | step_external_function: forall ef targs tres cc vargs k m vres t m', - external_call ef ge vargs m t vres m' -> + external_call ef ge (call_comp k) vargs m t vres m' -> sstep (Callstate (External ef targs tres cc) vargs k m) - t (Returnstate vres k m' (rettype_of_type tres) (comp_of ef)) + t (Returnstate vres k m' (rettype_of_type tres) bottom) (* sig_res (ef_sig ef) *) | step_returnstate: forall v f e C ty ty' k m cp t, diff --git a/cfrontend/Csharpminor.v b/cfrontend/Csharpminor.v index 3a2ad1a281..47098ede86 100644 --- a/cfrontend/Csharpminor.v +++ b/cfrontend/Csharpminor.v @@ -189,10 +189,10 @@ Definition is_call_cont (k: cont) : Prop := | _ => False end. -Definition call_comp (k: cont) : option compartment := +Definition call_comp (k: cont) : compartment := match call_cont k with - | Kcall _ f _ _ _ => Some f.(fn_comp) - | _ => None + | Kcall _ f _ _ _ => comp_of f + | _ => top end. (** Resolve [switch] statements. *) @@ -349,7 +349,7 @@ Inductive eval_expr: expr -> val -> Prop := eval_expr (Ebinop op a1 a2) v | eval_Eload: forall chunk a v1 v, eval_expr a v1 -> - Mem.loadv chunk m v1 (Some cp) = Some v -> + Mem.loadv chunk m v1 cp = Some v -> eval_expr (Eload chunk a) v. (** Evaluation of a list of expressions: @@ -408,8 +408,7 @@ Inductive step: state -> trace -> state -> Prop := | step_builtin: forall f optid ef bl k e le m vargs t vres m', eval_exprlist e (comp_of f) le m bl vargs -> - forall ALLOWED: comp_of ef = comp_of f, - external_call ef ge vargs m t vres m' -> + external_call ef ge (comp_of f) vargs m t vres m' -> step (State f (Sbuiltin optid ef bl) k e le m) t (State f Sskip k e (Cminor.set_optvar optid vres le) m') @@ -475,9 +474,9 @@ Inductive step: state -> trace -> state -> Prop := E0 (State f f.(fn_body) k e le m1) | step_external_function: forall ef vargs k m t vres m', - external_call ef ge vargs m t vres m' -> + external_call ef ge (call_comp k) vargs m t vres m' -> step (Callstate (External ef) vargs k m) - t (Returnstate vres k m' (sig_res (ef_sig ef)) (comp_of ef)) + t (Returnstate vres k m' (sig_res (ef_sig ef)) bottom) | step_return: forall v optid f e le cp k m ty t, forall (NO_CROSS_PTR: Genv.type_of_call (comp_of f) cp = Genv.CrossCompartmentCall -> not_ptr v), diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index 3db59a8898..ea952bcb15 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -426,9 +426,9 @@ Definition make_store_bitfield (sz: intsize) (sg: signedness) (pos width: Z) (** [make_memcpy dst src ty] returns a [memcpy] builtin appropriate for by-copy assignment of a value of Clight type [ty]. *) -Definition make_memcpy (ce: composite_env) (cp: compartment) (dst src: expr) (ty: type) := +Definition make_memcpy (ce: composite_env) (dst src: expr) (ty: type) := do sz <- sizeof ce ty; - OK (Sbuiltin None (EF_memcpy cp sz (Ctypes.alignof_blockcopy ce ty)) + OK (Sbuiltin None (EF_memcpy sz (Ctypes.alignof_blockcopy ce ty)) (dst :: src :: nil)). (** [make_store addr ty bf rhs] stores the value of the @@ -436,12 +436,12 @@ Definition make_memcpy (ce: composite_env) (cp: compartment) (dst src: expr) (ty Csharpminor expression [addr]. [ty] is the type of the memory location and [bf] a bitfield designator. *) -Definition make_store (ce: composite_env) (cp: compartment) (addr: expr) (ty: type) (bf: bitfield) (rhs: expr) := +Definition make_store (ce: composite_env) (addr: expr) (ty: type) (bf: bitfield) (rhs: expr) := match bf with | Full => match access_mode ty with | By_value chunk => OK (Sstore chunk addr rhs) - | By_copy => make_memcpy ce cp addr rhs ty + | By_copy => make_memcpy ce addr rhs ty | _ => Error (msg "Cshmgen.make_store") end | Bits sz sg pos width => @@ -672,7 +672,7 @@ Fixpoint transl_statement (ce: composite_env) (cp: compartment) (tyret: type) (n do (tb, bf) <- transl_lvalue ce b; do tc <- transl_expr ce c; do tc' <- make_cast (typeof c) (typeof b) tc; - make_store ce cp tb (typeof b) bf tc' + make_store ce tb (typeof b) bf tc' | Clight.Sset x b => do tb <- transl_expr ce b; OK(Sset x tb) diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 801c1ad7a4..c5d9bdf030 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -1024,7 +1024,7 @@ Lemma make_memcpy_correct: eval_expr ge e (comp_of f) le m src v -> assign_loc prog.(prog_comp_env) (comp_of f) ty m b ofs Full v m' -> access_mode ty = By_copy -> - make_memcpy cunit.(prog_comp_env) (comp_of f) dst src ty = OK s -> + make_memcpy cunit.(prog_comp_env) dst src ty = OK s -> step ge (State f s k e le m) E0 (State f Sskip k e le m'). Proof. intros. inv H1; try congruence. @@ -1033,7 +1033,7 @@ Proof. change le with (set_optvar None Vundef le) at 2. econstructor. econstructor. - eauto. econstructor. eauto. constructor. reflexivity. + eauto. econstructor. eauto. constructor. econstructor; eauto. apply alignof_blockcopy_1248. apply sizeof_pos. @@ -1042,7 +1042,7 @@ Qed. Lemma make_store_correct: forall addr ty bf rhs code e le m b ofs v m' f k, - make_store cunit.(prog_comp_env) (comp_of f) addr ty bf rhs = OK code -> + make_store cunit.(prog_comp_env) addr ty bf rhs = OK code -> eval_expr ge e (comp_of f) le m addr (Vptr b ofs) -> eval_expr ge e (comp_of f) le m rhs v -> assign_loc prog.(prog_comp_env) (comp_of f) ty m b ofs bf v m' -> @@ -1126,9 +1126,9 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. - eapply (Genv.match_genvs_find_comp TRANSL). + eapply (Genv.match_genvs_find_comp_in_genv TRANSL). Qed. Lemma type_of_call_translated: @@ -1139,7 +1139,7 @@ Lemma type_of_call_translated: Proof. intros cp f ce tf TRF. erewrite <- (comp_transl_partial _ TRF). - eapply Genv.match_genvs_type_of_call. + reflexivity. Qed. Lemma call_trace_translated: @@ -1757,8 +1757,6 @@ Proof. econstructor; split. apply plus_one. eapply make_store_correct; eauto. rewrite <- (comp_transl_function _ _ _ TRF); eauto. - eapply transl_lvalue_correct; eauto. - rewrite <- (comp_transl_function _ _ _ TRF); eauto. eapply make_cast_correct; eauto. eapply transl_expr_correct; eauto. rewrite <- (comp_transl_function _ _ _ TRF); eauto. @@ -2034,6 +2032,7 @@ Proof. exploit match_cont_is_call_cont; eauto. intros [A B]. econstructor; split. apply plus_one. constructor. + exploit match_cont_call_comp; eauto. intros <-. eapply external_call_symbols_preserved; eauto. apply senv_preserved. replace (rettype_of_type tres) with (sig_res (ef_sig ef)) by now rewrite H5. eapply match_returnstate with (ce := ce); eauto. @@ -2118,17 +2117,14 @@ Local Transparent Linker_fundef Linking.Linker_fundef. inv H3; inv H4; simpl in H2. + discriminate. + destruct ef; try easy. - destruct eq_compartment; try easy. - subst cp. inv H2. - econstructor; split. -* simpl. rewrite (comp_transl_partial _ H5), dec_eq_true; eauto. -* left; constructor; auto. + (* destruct eq_compartment; try easy. *) + inv H2. + econstructor; split; simpl; auto. + left; constructor; auto. + destruct ef; try easy. - destruct eq_compartment; try easy. - subst cp. inv H2. - econstructor; split. -* simpl. rewrite (comp_transl_partial _ H3), dec_eq_true; eauto. -* right; constructor; auto. + inv H2. + econstructor; split; simpl; auto. + right; constructor; auto. + destruct (external_function_eq ef ef0 && typelist_eq args args0 && type_eq res res0 && calling_convention_eq cc cc0) eqn:E'; inv H2. InvBooleans. subst ef0. econstructor; split. diff --git a/cfrontend/Cstrategy.v b/cfrontend/Cstrategy.v index 21ee307288..85af3f1ca8 100644 --- a/cfrontend/Cstrategy.v +++ b/cfrontend/Cstrategy.v @@ -382,8 +382,7 @@ Inductive estep: state -> trace -> state -> Prop := | step_builtin: forall f C ef tyargs rargs ty k e m vargs t vres m', leftcontext RV RV C -> eval_simple_list e (comp_of f) m rargs tyargs vargs -> - external_call ef ge vargs m t vres m' -> - forall ALLOWED: comp_of ef = comp_of f, + external_call ef ge (comp_of f) vargs m t vres m' -> estep (ExprState f (C (Ebuiltin ef tyargs rargs ty)) k e m) t (ExprState f (C (Eval vres ty)) k e m'). @@ -592,8 +591,7 @@ Definition invert_expr_prop (cp: compartment) (a: expr) (m: mem) : Prop := exprlist_all_values rargs -> exists vargs, exists t, exists vres, exists m', cast_arguments m rargs tyargs vargs - /\ external_call ef ge vargs m t vres m' - /\ comp_of ef = cp + /\ external_call ef ge cp vargs m t vres m' | _ => True end. @@ -1404,7 +1402,7 @@ Proof. eapply safe_steps. eexact H. apply (eval_simple_list_steps f k e m rargs vl E C'); auto. simpl. intros X. exploit X. eapply rval_list_all_values. - intros [vargs [t [vres [m' [U [V W]]]]]]. + intros [vargs [t [vres [m' [U V]]]]]. econstructor; econstructor; eapply step_builtin; eauto. eapply can_eval_simple_list; eauto. + (* paren *) @@ -1583,7 +1581,7 @@ Proof. inv H1. exploit external_call_trace_length; eauto. destruct t1; simpl; intros. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. - exists (Returnstate vres2 k m2 (rettype_of_type tres) (comp_of ef)); exists E0; right; econstructor; eauto. + exists (Returnstate vres2 k m2 (rettype_of_type tres) bottom); exists E0; right; econstructor; eauto. extlia. inv EV; inv H0. eexists; eexists; right; econstructor; eauto. econstructor; eauto. @@ -1795,7 +1793,7 @@ with eval_expr: compartment -> env -> mem -> kind -> expr -> trace -> mem -> exp classify_fun (typeof rf) = fun_case_f targs tres cconv -> Genv.find_funct ge vf = Some fd -> type_of_fundef fd = Tfunction targs tres cconv -> - eval_funcall m2 fd vargs t3 m3 vres ty -> + eval_funcall c m2 fd vargs t3 m3 vres ty -> forall (ALLOWED: Genv.allowed_call ge c vf), forall (NO_CROSS_PTR_CALL: Genv.type_of_call c (comp_of fd) = Genv.CrossCompartmentCall -> Forall not_ptr vargs), @@ -1932,18 +1930,18 @@ with exec_stmt: compartment -> env -> mem -> statement -> trace -> mem -> outcom function [fd] with arguments [args]. [res] is the value returned by the call and [ty] its type. *) -with eval_funcall: mem -> fundef -> list val -> trace -> mem -> val -> type -> Prop := - | eval_funcall_internal: forall m f vargs t e m1 m2 m3 out vres m4, +with eval_funcall: compartment -> mem -> fundef -> list val -> trace -> mem -> val -> type -> Prop := + | eval_funcall_internal: forall cp m f vargs t e m1 m2 m3 out vres m4, list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) -> alloc_variables ge (comp_of f) empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> bind_parameters ge (comp_of f) e m1 f.(fn_params) vargs m2 -> exec_stmt (comp_of f) e m2 f.(fn_body) t m3 out -> outcome_result_value out f.(fn_return) vres m3 -> Mem.free_list m3 (blocks_of_env ge e) (comp_of f) = Some m4 -> - eval_funcall m (Internal f) vargs t m4 vres f.(fn_return) - | eval_funcall_external: forall m ef targs tres cconv vargs t vres m', - external_call ef ge vargs m t vres m' -> - eval_funcall m (External ef targs tres cconv) vargs t m' vres tres. + eval_funcall cp m (Internal f) vargs t m4 vres f.(fn_return) + | eval_funcall_external: forall cp m ef targs tres cconv vargs t vres m', + external_call ef ge cp vargs m t vres m' -> + eval_funcall cp m (External ef targs tres cconv) vargs t m' vres tres. Scheme eval_expression_ind5 := Minimality for eval_expression Sort Prop with eval_expr_ind5 := Minimality for eval_expr Sort Prop @@ -2245,10 +2243,11 @@ Lemma bigstep_to_steps: forall (COMP: c = comp_of f), exists S, star step ge (State f s k e m) t S /\ outcome_state_match e m' f k out S) -/\(forall m fd args t m' res ty, - eval_funcall m fd args t m' res ty -> +/\(forall c m fd args t m' res ty, + eval_funcall c m fd args t m' res ty -> forall k, is_call_cont k -> + forall (COMP: c = call_comp k), star step ge (Callstate fd args k m) t (Returnstate res k m' (rettype_of_type ty) (comp_of fd))). Proof. apply bigstep_induction; intros; try subst c. @@ -2658,6 +2657,7 @@ Proof. (* call external *) apply star_one. right; apply step_external_function; auto. + subst; auto. (* congruence. *) Qed. @@ -2694,10 +2694,11 @@ Lemma exec_stmt_to_steps: Proof. exact (proj1 (proj2 (proj2 (proj2 bigstep_to_steps)))). Qed. Lemma eval_funcall_to_steps: - forall m fd args t m' res ty, - eval_funcall m fd args t m' res ty -> + forall c m fd args t m' res ty, + eval_funcall c m fd args t m' res ty -> forall k, is_call_cont k -> + forall (COMP: c = call_comp k), star step ge (Callstate fd args k m) t (Returnstate res k m' (rettype_of_type ty) (comp_of fd)). Proof (proj2 (proj2 (proj2 (proj2 bigstep_to_steps)))). @@ -3079,7 +3080,7 @@ Inductive bigstep_program_terminates (p: program): trace -> int -> Prop := 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 -> - eval_funcall ge m0 f nil t m1 (Vint r) ty -> + eval_funcall ge top m0 f nil t m1 (Vint r) ty -> bigstep_program_terminates p t r. Inductive bigstep_program_diverges (p: program): traceinf -> Prop := @@ -3102,7 +3103,7 @@ Proof. (* termination *) inv H. econstructor; econstructor. split. econstructor; eauto. - split. apply (eval_funcall_to_steps _); simpl; eauto. + split. apply (eval_funcall_to_steps _ top); simpl; eauto. econstructor. (* divergence *) inv H. econstructor. diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v index c658abf5c4..31a2433591 100644 --- a/cfrontend/Ctyping.v +++ b/cfrontend/Ctyping.v @@ -393,7 +393,7 @@ Inductive wt_rvalue : expr -> Prop := classify_fun (typeof r1) = fun_case_f tyargs tyres cconv -> wt_arguments rargs tyargs -> wt_rvalue (Ecall r1 rargs tyres) - | wt_Ebuiltin: forall ef cp tyargs rargs ty, + | wt_Ebuiltin: forall ef tyargs rargs ty, wt_exprlist rargs -> wt_arguments rargs tyargs -> (* This typing rule is specialized to the builtin invocations generated @@ -402,7 +402,7 @@ Inductive wt_rvalue : expr -> Prop := \/ (tyargs = Tcons type_bool (Tcons ty (Tcons ty Tnil)) /\ let t := typ_of_type ty in let sg := mksignature (AST.Tint :: t :: t :: nil) t cc_default in - ef = EF_builtin cp "__builtin_sel"%string sg) -> + ef = EF_builtin "__builtin_sel"%string sg) -> wt_rvalue (Ebuiltin ef tyargs rargs ty) | wt_Eparen: forall r tycast ty, wt_rvalue r -> @@ -1258,7 +1258,6 @@ Proof. destruct (type_eq tyres Tvoid); simpl in EQ2; try discriminate. destruct (rettype_eq (sig_res (ef_sig ef)) AST.Tvoid); inv EQ2. econstructor; eauto. eapply check_arguments_sound; eauto. - Unshelve. exact default_compartment. Qed. Lemma eselection_sound: @@ -1826,30 +1825,28 @@ Proof. constructor; auto. - (* comma *) auto. - (* paren *) inv H3. constructor. apply H5. eapply pres_sem_cast; eauto. -- (* builtin *) subst. destruct H8 as [(A & B) | (A & B)]. +- (* builtin *) subst. destruct H7 as [(A & B) | (A & B)]. + subst ty. auto with ty. + simpl in B. set (T := typ_of_type ty) in *. set (sg := mksignature (AST.Tint :: T :: T :: nil) T cc_default) in *. - assert (LK: lookup_builtin_function "__builtin_sel"%string cp0 sg = Some (BI_standard (BI_select T))). - (* { unfold sg, T; destruct ty as [ | ? ? ? | ? | [] ? | ? ? | ? ? ? | ? ? ? | ? ? | ? ? ]; *) - (* simpl; unfold Tptr; destruct Archi.ptr64; reflexivity. } *) - { admit. } - subst ef. red in H1. red in H1. rewrite LK in H1. inv H1. - inv H. inv H8. inv H9. inv H10. simpl in H0. + assert (LK: lookup_builtin_function "__builtin_sel"%string sg = Some (BI_standard (BI_select T))). + { unfold sg, T; destruct ty as [ | ? ? ? | ? | [] ? | ? ? | ? ? ? | ? ? ? | ? ? | ? ? ]; + simpl; unfold Tptr; destruct Archi.ptr64; reflexivity. } + subst ef. red in H0. red in H0. rewrite LK in H0. inv H0. + inv H. inv H8. inv H9. inv H10. simpl in H1. assert (A: val_casted v1 type_bool) by (eapply cast_val_is_casted; eauto). inv A. set (v' := if Int.eq n Int.zero then v4 else v2) in *. constructor. destruct (type_eq ty Tvoid). subst. constructor. - inv H0. + inv H1. assert (C: val_casted v' ty). { unfold v'; destruct (Int.eq n Int.zero); eapply cast_val_is_casted; eauto. } assert (EQ: Val.normalize v' T = v'). { apply Val.normalize_idem. apply val_casted_has_type; auto. } rewrite EQ. apply wt_val_casted; auto. -(* Qed. *) -Admitted. +Qed. Lemma wt_lred: forall tenv ge e cp a m a' m', diff --git a/cfrontend/Initializersproof.v b/cfrontend/Initializersproof.v index f82b4fee15..f5cbf0097f 100644 --- a/cfrontend/Initializersproof.v +++ b/cfrontend/Initializersproof.v @@ -664,7 +664,7 @@ Lemma store_init_data_loadbytes: forall m b p i cp m', Genv.store_init_data ge m b p i cp = Some m' -> match i with Init_space _ => False | _ => True end -> - Mem.loadbytes m' b p (init_data_size i) (Some cp) = Some (boid i). + Mem.loadbytes m' b p (init_data_size i) cp = Some (boid i). Proof. intros; destruct i; simpl in H; try apply (Mem.loadbytes_store_same _ _ _ _ _ _ H). - change (init_data_size (Init_int8 i)) with (size_chunk Mint8unsigned). @@ -786,7 +786,7 @@ Qed. (** ** Memory areas that are initialized to zeros *) Definition reads_as_zeros (m: mem) (b: block) (from to: Z) (cp: compartment) : Prop := - forall i, from <= i < to -> Mem.loadbytes m b i 1 (Some cp) = Some (Byte Byte.zero :: nil). + forall i, from <= i < to -> Mem.loadbytes m b i 1 cp = Some (Byte Byte.zero :: nil). Lemma reads_as_zeros_mono: forall m b from1 from2 to1 to2 cp, reads_as_zeros m b from1 to1 cp -> from1 <= from2 -> to2 <= to1 -> @@ -809,8 +809,8 @@ Qed. Lemma reads_as_zeros_loadbytes: forall m cp b from to, reads_as_zeros m b from to cp -> forall len pos, from <= pos -> pos + len <= to -> 0 <= len -> - forall (OWN: Mem.can_access_block m b (Some cp)), - Mem.loadbytes m b pos len (Some cp) = Some (repeat (Byte Byte.zero) (Z.to_nat len)). + forall (OWN: Mem.can_access_block m b cp), + Mem.loadbytes m b pos len cp = Some (repeat (Byte Byte.zero) (Z.to_nat len)). Proof. intros until to; intros RZ. induction len using (well_founded_induction (Zwf_well_founded 0)). @@ -827,8 +827,8 @@ Proof. Qed. Lemma reads_as_zeros_equiv: forall m b from to cp, - forall (OWN: Mem.can_access_block m b (Some cp)), - reads_as_zeros m b from to cp <-> Genv.readbytes_as_zero m b from (to - from) (Some cp). + forall (OWN: Mem.can_access_block m b cp), + reads_as_zeros m b from to cp <-> Genv.readbytes_as_zero m b from (to - from) cp. Proof. intros; split; intros. - red; intros. set (len := Z.of_nat n). @@ -845,13 +845,13 @@ Record match_state (s: state) (m: mem) (b: block) (cp: compartment) : Prop := { match_range: 0 <= s.(curr) <= s.(total_size); match_contents: - Mem.loadbytes m b 0 s.(curr) (Some cp) = Some (boidl (rev s.(init))); + Mem.loadbytes m b 0 s.(curr) cp = Some (boidl (rev s.(init))); match_valid: idlvalid 0 (rev s.(init)); match_uninitialized: reads_as_zeros m b s.(curr) s.(total_size) cp; match_own: - Mem.can_access_block m b (Some cp) + Mem.can_access_block m b cp }. Lemma match_size: forall s m b cp, @@ -896,9 +896,9 @@ Lemma trisection_correct: forall s m b cp pos sz bytes1 bytes2 il, match_state s m b cp -> trisection s.(init) (s.(curr) - (pos + sz)) sz = OK (bytes1, bytes2, il) -> 0 <= pos -> pos + sz <= s.(curr) -> 0 <= sz -> - Mem.loadbytes m b 0 pos (Some cp) = Some (boidl (rev il)) - /\ Mem.loadbytes m b pos sz (Some cp) = Some (inj_bytes bytes2) - /\ Mem.loadbytes m b (pos + sz) (s.(curr) - (pos + sz)) (Some cp) = Some (inj_bytes bytes1). + Mem.loadbytes m b 0 pos cp = Some (boidl (rev il)) + /\ Mem.loadbytes m b pos sz cp = Some (inj_bytes bytes2) + /\ Mem.loadbytes m b (pos + sz) (s.(curr) - (pos + sz)) cp = Some (inj_bytes bytes1). Proof. intros. apply trisection_boidl in H0. destruct H0 as (A & B & C). set (depth := curr s - (pos + sz)) in *. @@ -939,7 +939,7 @@ Qed. Theorem load_int_correct: forall s m b cp pos isz i v, match_state s m b cp -> load_int s pos isz = OK i -> - Mem.load (chunk_for_carrier isz) m b pos (Some cp) = Some v -> + Mem.load (chunk_for_carrier isz) m b pos cp = Some v -> v = Vint i. Proof. intros until v; intros MS RI LD. @@ -1031,7 +1031,7 @@ Proof. + eapply reads_as_zeros_unchanged; eauto. eapply reads_as_zeros_mono. eapply match_uninitialized; eauto. lia. lia. intros. simpl. lia. - + apply Mem.loadbytes_can_access_block_inj in D. congruence. + + apply Mem.loadbytes_can_access_block_inj in D. simpl in *. congruence. - monadInv ST. destruct x as [[bytes1 bytes2] il]. inv EQ0. assert (pos + sz <= curr s1) by (apply curr_pad_to). assert (MS': match_state s1 m b cp) by (apply pad_to_correct; auto). @@ -1055,7 +1055,7 @@ Proof. rewrite Z2Nat.id by lia. simpl. tauto. + eapply reads_as_zeros_unchanged; eauto. eapply match_uninitialized; eauto. intros. simpl. lia. - + apply Mem.loadbytes_can_access_block_inj in D. congruence. + + apply Mem.loadbytes_can_access_block_inj in D. simpl in *. congruence. Qed. Corollary store_int_correct: forall s m b cp pos isz n s' m', @@ -1073,11 +1073,11 @@ Theorem init_data_list_of_state_correct: forall s m b cp il b' m1, match_state s m b cp -> init_data_list_of_state s = OK il -> Mem.range_perm m1 b' 0 s.(total_size) Cur Writable -> - forall (OWN: Mem.can_access_block m1 b' (Some cp)), + forall (OWN: Mem.can_access_block m1 b' cp), reads_as_zeros m1 b' 0 s.(total_size) cp -> exists m2, Genv.store_init_data_list ge m1 b' 0 il cp = Some m2 - /\ Mem.loadbytes m2 b' 0 (init_data_list_size il) (Some cp) = Mem.loadbytes m b 0 s.(total_size) (Some cp). + /\ Mem.loadbytes m2 b' 0 (init_data_list_size il) cp = Mem.loadbytes m b 0 s.(total_size) cp. Proof. intros. unfold init_data_list_of_state in H0; monadInv H0. rename l into LE. set (s1 := pad_to s s.(total_size)) in *. @@ -1163,7 +1163,7 @@ Inductive exec_assign: mem -> block -> Z -> bitfield -> type -> val -> compartme type_is_volatile ty = false -> 0 <= pos -> 0 < width -> pos + width <= bitsize_intsize sz -> sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> - Mem.load (chunk_for_carrier sz) m b ofs (Some cp) = Some (Vint c) -> + Mem.load (chunk_for_carrier sz) m b ofs cp = Some (Vint c) -> Mem.store (chunk_for_carrier sz) m b ofs (Vint (Int.bitfield_insert (first_bit sz pos width) width c n)) cp = Some m' -> exec_assign m b ofs (Bits sz sg pos width) (Tint sz sg1 attr) (Vint n) cp m'. @@ -1219,7 +1219,7 @@ Qed. (** A semantics for general initializers *) -Definition dummy_function := mkfunction default_compartment Tvoid cc_default nil nil Sskip. +Definition dummy_function := mkfunction bottom Tvoid cc_default nil nil Sskip. Fixpoint initialized_fields_of_struct (ms: members) (pos: Z) : res (list (Z * bitfield * type)) := match ms with @@ -1354,12 +1354,12 @@ Theorem transl_init_sound: let sz := sizeof (prog_comp_env p) ty in Mem.range_perm m b 0 sz Cur Writable -> reads_as_zeros m b 0 sz cp -> - forall (OWN: Mem.can_access_block m b (Some cp)), + forall (OWN: Mem.can_access_block m b cp), exec_init (globalenv p) m b 0 Full ty i cp m1 -> transl_init (prog_comp_env p) ty i = OK data -> exists m2, Genv.store_init_data_list (globalenv p) m b 0 data cp = Some m2 - /\ Mem.loadbytes m2 b 0 (init_data_list_size data) (Some cp) = Mem.loadbytes m1 b 0 sz (Some cp). + /\ Mem.loadbytes m2 b 0 (init_data_list_size data) cp = Mem.loadbytes m1 b 0 sz cp. Proof. intros. set (ge := globalenv p) in *. @@ -1373,7 +1373,7 @@ Proof. assumption. - auto. - assumption. - - rewrite OWN. reflexivity. + - simpl in OWN. apply OWN. } assert (match_state ge x m1 b cp). { eapply (proj1 (transl_init_rec_sound ge)); eauto. } diff --git a/cfrontend/PrintClight.ml b/cfrontend/PrintClight.ml index 697c7e9e99..a9ecb342cd 100644 --- a/cfrontend/PrintClight.ml +++ b/cfrontend/PrintClight.ml @@ -282,7 +282,7 @@ let print_fundef ver p id fd = let print_fundecl p id fd = match fd with - | Ctypes.External((AST.EF_external _ | AST.EF_runtime _ | AST.EF_malloc _ | AST.EF_free _), args, res, cconv) -> + | Ctypes.External((AST.EF_external _ | AST.EF_runtime _ | AST.EF_malloc | AST.EF_free), args, res, cconv) -> fprintf p "extern %s;@ " (name_cdecl (extern_atom id) (Tfunction(args, res, cconv))) | Ctypes.External(_, _, _, _) -> diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml index 4e2f157923..16cdfc4161 100644 --- a/cfrontend/PrintCsyntax.ml +++ b/cfrontend/PrintCsyntax.ml @@ -234,7 +234,7 @@ let rec expr p (prec, e) = expr (prec1, a1) (name_binop op) expr (prec2, a2) | Ecast(a1, ty) -> fprintf p "(%s) %a" (name_type ty) expr (prec', a1) - | Eassign(res, Ebuiltin(EF_inline_asm(_cp, txt, sg, clob), _, args, _), _) -> + | Eassign(res, Ebuiltin(EF_inline_asm(txt, sg, clob), _, args, _), _) -> extended_asm p txt (Some res) args clob | Eassign(a1, a2, _) -> fprintf p "%a =@ %a" expr (prec1, a1) expr (prec2, a2) @@ -250,26 +250,26 @@ let rec expr p (prec, e) = fprintf p "%a,@ %a" expr (prec1, a1) expr (prec2, a2) | Ecall(a1, al, _) -> fprintf p "%a@[(%a)@]" expr (prec', a1) exprlist (true, al) - | Ebuiltin(EF_memcpy(_cp, sz, al), _, args, _) -> + | Ebuiltin(EF_memcpy(sz, al), _, args, _) -> fprintf p "__builtin_memcpy_aligned@[(%ld,@ %ld,@ %a)@]" (camlint_of_coqint sz) (camlint_of_coqint al) exprlist (true, args) - | Ebuiltin(EF_annot(_cp,_,txt, _), _, args, _) -> + | Ebuiltin(EF_annot(_,txt, _), _, args, _) -> fprintf p "__builtin_annot@[(%S%a)@]" (camlstring_of_coqstring txt) exprlist (false, args) - | Ebuiltin(EF_annot_val(_cp,_,txt, _), _, args, _) -> + | Ebuiltin(EF_annot_val(_,txt, _), _, args, _) -> fprintf p "__builtin_annot_intval@[(%S%a)@]" (camlstring_of_coqstring txt) exprlist (false, args) - | Ebuiltin(EF_external(_cp, id, sg), _, args, _) -> + | Ebuiltin(EF_external(id, sg), _, args, _) -> fprintf p "%s@[(%a)@]" (camlstring_of_coqstring id) exprlist (true, args) - | Ebuiltin(EF_runtime(_cp, id, sg), _, args, _) -> + | Ebuiltin(EF_runtime(id, sg), _, args, _) -> fprintf p "%s@[(%a)@]" (camlstring_of_coqstring id) exprlist (true, args) - | Ebuiltin(EF_inline_asm(_cp, txt, sg, clob), _, args, _) -> + | Ebuiltin(EF_inline_asm(txt, sg, clob), _, args, _) -> extended_asm p txt None args clob - | Ebuiltin(EF_debug(_cp,kind,txt,_),_,args,_) -> + | Ebuiltin(EF_debug(kind,txt,_),_,args,_) -> fprintf p "__builtin_debug@[(%d,%S%a)@]" (P.to_int kind) (extern_atom txt) exprlist (false,args) - | Ebuiltin(EF_builtin(_cp,name, _), _, args, _) -> + | Ebuiltin(EF_builtin(name, _), _, args, _) -> fprintf p "%s@[(%a)@]" (camlstring_of_coqstring name) exprlist (true, args) | Ebuiltin(_, _, args, _) -> @@ -430,7 +430,7 @@ let print_function p id f = let print_fundef p id fd = match fd with - | Ctypes.External((EF_external _ | EF_runtime _| EF_malloc _ | EF_free _), args, res, cconv) -> + | Ctypes.External((EF_external _ | EF_runtime _| EF_malloc | EF_free), args, res, cconv) -> fprintf p "extern %s;@ @ " (name_cdecl (extern_atom id) (Tfunction(args, res, cconv))) | Ctypes.External(_, _, _, _) -> diff --git a/cfrontend/SimplExpr.v b/cfrontend/SimplExpr.v index 110b89f10f..91e080589f 100644 --- a/cfrontend/SimplExpr.v +++ b/cfrontend/SimplExpr.v @@ -201,7 +201,7 @@ Definition make_set (cp: compartment) (bf: bitfield) (id: ident) (l: expr) : sta | None => Sset id l | Some chunk => let typtr := Tpointer (typeof l) noattr in - Sbuiltin (Some id) (EF_vload cp chunk) (Tcons typtr Tnil) ((Eaddrof l typtr):: nil) + Sbuiltin (Some id) (EF_vload chunk) (Tcons typtr Tnil) ((Eaddrof l typtr):: nil) end. (** Translation of a "valof" operation. @@ -223,7 +223,7 @@ Definition make_assign (cp: compartment) (bf: bitfield) (l r: expr) : statement | Some chunk => let ty := typeof l in let typtr := Tpointer ty noattr in - Sbuiltin None (EF_vstore cp chunk) (Tcons typtr (Tcons ty Tnil)) + Sbuiltin None (EF_vstore chunk) (Tcons typtr (Tcons ty Tnil)) (Eaddrof l typtr :: r :: nil) end. diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index 14ec04d5d4..a0e8574229 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -123,10 +123,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. destruct TRANSL. - eapply (Genv.match_genvs_find_comp H). + eapply (Genv.match_genvs_find_comp_in_genv H). Qed. Lemma call_trace_translated: @@ -2199,7 +2199,8 @@ Ltac NOTIN := econstructor; split. left. eapply plus_left. constructor. apply star_one. econstructor; eauto. - rewrite CO; eauto. congruence. + rewrite CO; eauto. + rewrite CO; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. traceEq. econstructor; eauto. @@ -2210,7 +2211,8 @@ Ltac NOTIN := econstructor; split. left. eapply plus_left. constructor. apply star_one. econstructor; eauto. - rewrite CO; eauto. congruence. + rewrite CO; eauto. + rewrite CO; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. traceEq. econstructor; eauto. @@ -2534,6 +2536,8 @@ Proof. inv TR. econstructor; split. left; apply plus_one. econstructor; eauto. + specialize (MK (prog_comp_env cu)). + exploit match_cont_call_comp; eauto. intros <-. eapply external_call_symbols_preserved; eauto. apply senv_preserved. apply match_returnstates. auto. @@ -2545,7 +2549,6 @@ Proof. now rewrite CO. rewrite CO. eapply return_trace_eq; eauto using senv_preserved. econstructor; eauto. - Qed. (** Semantic preservation *) @@ -2610,19 +2613,13 @@ Proof. Local Transparent Linker_fundef. simpl in *; unfold link_fundef in *. inv H3; inv H4; try discriminate. destruct ef; inv H2. - destruct (eq_compartment cp (comp_of f0)); [| discriminate]. - injection H4 as ?; subst f cp. exists (Internal tf); split. - inv H5. rewrite H2. - destruct (eq_compartment (comp_of f0) (comp_of f0)); [| contradiction]. + inv H5. reflexivity. left; constructor; auto. destruct ef; inv H2. - destruct (eq_compartment cp (comp_of f0)); [| discriminate]. - injection H5 as ?; subst f cp. exists (Internal tf); split. - inv H3. rewrite H2. - destruct (eq_compartment (comp_of f0) (comp_of f0)); [| contradiction]. + inv H3. reflexivity. right; constructor; auto. destruct (external_function_eq ef ef0 && typelist_eq targs targs0 && diff --git a/cfrontend/SimplLocals.v b/cfrontend/SimplLocals.v index a3713fd4a7..143597d370 100644 --- a/cfrontend/SimplLocals.v +++ b/cfrontend/SimplLocals.v @@ -54,19 +54,19 @@ Definition make_cast (a: expr) (tto: type) : expr := (** Insertion of debug annotations *) -Definition Sdebug_temp (cp: compartment) (id: ident) (ty: type) := - Sbuiltin None (EF_debug cp 2%positive id (typ_of_type ty :: nil)) +Definition Sdebug_temp (id: ident) (ty: type) := + Sbuiltin None (EF_debug 2%positive id (typ_of_type ty :: nil)) (Tcons (typeconv ty) Tnil) (Etempvar id ty :: nil). -Definition Sdebug_var (cp: compartment) (id: ident) (ty: type) := - Sbuiltin None (EF_debug cp 5%positive id (AST.Tptr :: nil)) +Definition Sdebug_var (id: ident) (ty: type) := + Sbuiltin None (EF_debug 5%positive id (AST.Tptr :: nil)) (Tcons (Tpointer ty noattr) Tnil) (Eaddrof (Evar id ty) (Tpointer ty noattr) :: nil). -Definition Sset_debug (cp: compartment) (id: ident) (ty: type) (a: expr) := +Definition Sset_debug (id: ident) (ty: type) (a: expr) := if Compopts.debug tt - then Ssequence (Sset id (make_cast a ty)) (Sdebug_temp cp id ty) + then Ssequence (Sset id (make_cast a ty)) (Sdebug_temp id ty) else Sset id (make_cast a ty). (** Rewriting of expressions and statements. *) @@ -109,7 +109,7 @@ Fixpoint simpl_stmt (cenv: compilenv) (cp: compartment) (s: statement) : res sta | Sassign a1 a2 => match is_liftable_var cenv a1 with | Some id => - OK (Sset_debug cp id (typeof a1) (simpl_expr cenv a2)) + OK (Sset_debug id (typeof a1) (simpl_expr cenv a2)) | None => OK (Sassign (simpl_expr cenv a1) (simpl_expr cenv a2)) end @@ -245,20 +245,20 @@ Definition cenv_for (f: function) : compilenv := (** Transform a function *) -Definition add_debug_var (cp: compartment) (id_ty: ident * type) (s: statement) := - let (id, ty) := id_ty in Ssequence (Sdebug_var cp id ty) s. +Definition add_debug_var (id_ty: ident * type) (s: statement) := + let (id, ty) := id_ty in Ssequence (Sdebug_var id ty) s. -Definition add_debug_vars (cp: compartment) (vars: list (ident * type)) (s: statement) := +Definition add_debug_vars (vars: list (ident * type)) (s: statement) := if Compopts.debug tt - then List.fold_right (add_debug_var cp) s vars + then List.fold_right add_debug_var s vars else s. -Definition add_debug_param (cp: compartment) (id_ty: ident * type) (s: statement) := - let (id, ty) := id_ty in Ssequence (Sdebug_temp cp id ty) s. +Definition add_debug_param (id_ty: ident * type) (s: statement) := + let (id, ty) := id_ty in Ssequence (Sdebug_temp id ty) s. -Definition add_debug_params (cp: compartment) (params: list (ident * type)) (s: statement) := +Definition add_debug_params (params: list (ident * type)) (s: statement) := if Compopts.debug tt - then List.fold_right (add_debug_param cp) s params + then List.fold_right add_debug_param s params else s. Definition remove_lifted (cenv: compilenv) (vars: list (ident * type)) := @@ -279,9 +279,9 @@ Definition transf_function (f: function) : res function := fn_params := f.(fn_params); fn_vars := vars'; fn_temps := temps'; - fn_body := add_debug_params f.(fn_comp) f.(fn_params) + fn_body := add_debug_params f.(fn_params) (store_params cenv f.(fn_params) - (add_debug_vars f.(fn_comp) vars' body')) |}. + (add_debug_vars vars' body')) |}. (** Whole-program transformation *) diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index 316e784e19..344f94a338 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -114,10 +114,10 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. destruct TRANSF. - eapply (Genv.match_genvs_find_comp H). + eapply (Genv.match_genvs_find_comp_in_genv H). Qed. Lemma type_of_call_translated: @@ -128,7 +128,7 @@ Lemma type_of_call_translated: Proof. intros f tf cp TRF. erewrite <- (comp_transl_partial _ TRF). - eapply (Genv.match_genvs_type_of_call). + reflexivity. Qed. Lemma call_trace_translated: @@ -164,7 +164,7 @@ Inductive match_var (f: meminj) (cenv: compilenv) (e: env) (m: mem) (te: env) (t (LIFTED: VSet.mem id cenv = true) (MAPPED: f b = None) (MODE: access_mode ty = By_value chunk) - (LOAD: Mem.load chunk m b 0 (Some c) = Some v) + (LOAD: Mem.load chunk m b 0 c = Some v) (TLENV: tle!(id) = Some tv) (VINJ: Val.inject f v tv), match_var f cenv e m te tle id @@ -371,7 +371,7 @@ Lemma step_Sdebug_temp: forall f id ty k e le m v, le!id = Some v -> val_casted v ty -> - step2 tge (State f (Sdebug_temp (comp_of f) id ty) k e le m) + step2 tge (State f (Sdebug_temp id ty) k e le m) E0 (State f Sskip k e le m). Proof. intros. unfold Sdebug_temp. eapply step_builtin with (optid := None); eauto. @@ -382,7 +382,7 @@ Qed. Lemma step_Sdebug_var: forall f id ty k e le m b, e!id = Some(b, ty) -> - step2 tge (State f (Sdebug_var (comp_of f) id ty) k e le m) + step2 tge (State f (Sdebug_var id ty) k e le m) E0 (State f Sskip k e le m). Proof. intros. unfold Sdebug_var. eapply step_builtin with (optid := None); eauto. @@ -395,7 +395,7 @@ Lemma step_Sset_debug: forall f id ty a k e le m v v', eval_expr tge e (comp_of f) le m a v -> sem_cast v (typeof a) ty m = Some v' -> - plus step2 tge (State f (Sset_debug (comp_of f) id ty a) k e le m) + plus step2 tge (State f (Sset_debug id ty a) k e le m) E0 (State f Sskip k e (PTree.set id v' le) m). Proof. intros; unfold Sset_debug. @@ -415,7 +415,7 @@ Qed. Lemma step_add_debug_vars: forall f s e le m vars k, (forall id ty, In (id, ty) vars -> exists b, e!id = Some (b, ty)) -> - star step2 tge (State f (add_debug_vars (comp_of f) vars s) k e le m) + star step2 tge (State f (add_debug_vars vars s) k e le m) E0 (State f s k e le m). Proof. unfold add_debug_vars. destruct (Compopts.debug tt). @@ -449,7 +449,7 @@ Lemma step_add_debug_params: list_norepet (var_names params) -> list_forall2 val_casted vl (map snd params) -> bind_parameter_temps params vl le1 = Some le -> - star step2 tge (State f (add_debug_params (comp_of f) params s) k e le m) + star step2 tge (State f (add_debug_params params s) k e le m) E0 (State f s k e le m). Proof. unfold add_debug_params. destruct (Compopts.debug tt). @@ -846,7 +846,7 @@ Qed. Definition env_initial_value (c: compartment) (e: env) (m: mem) := forall id b ty chunk, - e!id = Some(b, ty) -> access_mode ty = By_value chunk -> Mem.load chunk m b 0 (Some c) = Some Vundef. + e!id = Some(b, ty) -> access_mode ty = By_value chunk -> Mem.load chunk m b 0 c = Some Vundef. Lemma alloc_variables_initial_value: forall c e m vars e' m', @@ -860,7 +860,7 @@ Proof. destruct (peq id0 id). inv H2. eapply Mem.load_alloc_same'; eauto. lia. rewrite Z.add_0_l. eapply sizeof_by_value; eauto. - eapply Mem.owned_new_block; eauto. + simpl. erewrite Mem.owned_new_block; eauto. apply flowsto_refl. apply Z.divide_0_r. eapply Mem.load_alloc_other; eauto. Qed. @@ -1344,7 +1344,7 @@ Fixpoint freelist_no_overlap (l: list (block * Z * Z)) : Prop := Lemma can_free_list: forall l m c, (forall b lo hi, In (b, lo, hi) l -> Mem.range_perm m b lo hi Cur Freeable) -> - forall (OWN_BLOCKS: (forall b lo hi, In (b, lo, hi) l -> Mem.can_access_block m b (Some c))), + forall (OWN_BLOCKS: (forall b lo hi, In (b, lo, hi) l -> Mem.can_access_block m b c)), freelist_no_overlap l -> exists m', Mem.free_list m l c = Some m'. Proof. @@ -1605,18 +1605,16 @@ Proof. rewrite ENV in H7; inv H7. inv H0; try congruence. assert (chunk0 = chunk). simpl in H. congruence. subst chunk0. - assert (v0 = v). unfold Mem.loadv in H2. rewrite Ptrofs.unsigned_zero in H2. - (* JT: TODO: clean this proof! also make sure it's the right way to do things back - in the [match_envs] definition *) - assert (c = c0). - { clear -LOAD H2. + assert (v0 = v). + { unfold Mem.loadv in H2. rewrite Ptrofs.unsigned_zero in H2. + clear -LOAD H2. Local Transparent Mem.load. unfold Mem.load in *. - destruct (Mem.valid_access_dec m chunk loc 0 Readable (Some c0)) eqn:?; - destruct (Mem.valid_access_dec m chunk loc 0 Readable (Some c)) eqn:?; + destruct (Mem.valid_access_dec m chunk loc 0 Readable c0) eqn:?; + destruct (Mem.valid_access_dec m chunk loc 0 Readable c) eqn:?; try discriminate. destruct v1 as [? [? ?]]. destruct v2 as [? [? ?]]. - simpl in *. eapply Mem.can_access_block_component; eauto. } - congruence. subst v0. + simpl in *. congruence. } + subst v0. exists tv; split; auto. constructor; auto. simpl in H; congruence. simpl in H; congruence. @@ -2172,14 +2170,14 @@ Proof. Qed. Lemma find_label_add_debug_vars: - forall s k vars, find_label lbl (add_debug_vars cp vars s) k = find_label lbl s k. + forall s k vars, find_label lbl (add_debug_vars vars s) k = find_label lbl s k. Proof. unfold add_debug_vars. destruct (Compopts.debug tt); auto. induction vars; simpl; auto. destruct a as [id ty]; simpl. auto. Qed. Lemma find_label_add_debug_params: - forall s k vars, find_label lbl (add_debug_params cp vars s) k = find_label lbl s k. + forall s k vars, find_label lbl (add_debug_params vars s) k = find_label lbl s k. Proof. unfold add_debug_params. destruct (Compopts.debug tt); auto. induction vars; simpl; auto. destruct a as [id ty]; simpl. auto. @@ -2204,7 +2202,7 @@ Proof. inv H. (* local variable *) econstructor; split. - rewrite (comp_transl_partial _ TRF). + (* rewrite (comp_transl_partial _ TRF). *) eapply step_Sset_debug. rewrite <- (comp_transl_partial _ TRF). eauto. rewrite typeof_simpl_expr. eauto. econstructor; eauto with compat. @@ -2257,9 +2255,9 @@ Proof. eauto. erewrite type_of_fundef_preserved; eauto. eapply allowed_call_translated; eauto. - erewrite <- type_of_call_translated; eauto. + erewrite <- type_of_call_translated; eauto. simpl. intros. eapply Val.inject_list_not_ptr; eauto. eapply NO_CROSS_PTR. - rewrite comp_transf_fundef; eauto. + erewrite comp_transf_fundef; eauto. rewrite <- comp_transf_fundef; eauto. eapply call_trace_translated; eauto. rewrite <- comp_transf_function; eauto. @@ -2271,7 +2269,7 @@ Proof. (* builtin *) exploit eval_simpl_exprlist; eauto with compat. intros [CASTED [tvargs [C D]]]. exploit external_call_mem_inject; eauto. apply match_globalenvs_preserves_globals; eauto with compat. - intros [j' [tvres [tm' [P [Q [R [S [T [U [V W]]]]]]]]]]. + intros [j' [tvres [tm' [P [Q [R [S [T [U V]]]]]]]]]. econstructor; split. apply plus_one. econstructor; eauto. rewrite <- (comp_transl_partial _ TRF). eauto. @@ -2435,9 +2433,9 @@ Proof. fn_vars := remove_lifted (cenv_for f) (fn_params f ++ fn_vars f); fn_temps := add_lifted (cenv_for f) (fn_vars f) (fn_temps f); fn_body := - add_debug_params (fn_comp f) (fn_params f) + add_debug_params (fn_params f) (store_params (cenv_for f) (fn_params f) - (add_debug_vars (fn_comp f) (remove_lifted (cenv_for f) (fn_params f ++ fn_vars f)) x0)) + (add_debug_vars (remove_lifted (cenv_for f) (fn_params f ++ fn_vars f)) x0)) |}) by reflexivity. eapply step_add_debug_params. auto. eapply forall2_val_casted_inject; eauto. eexact Q. eapply star_trans. eexact P. @@ -2460,10 +2458,13 @@ Proof. (* external function *) monadInv TRFD. inv FUNTY. exploit external_call_mem_inject; eauto. apply match_globalenvs_preserves_globals. - eapply match_cont_globalenv. eexact (MCONT VSet.empty (comp_of ef)). - intros [j' [tvres [tm' [P [Q [R [S [T [U [V W]]]]]]]]]]. + eapply match_cont_globalenv. eexact (MCONT VSet.empty top). + intros [j' [tvres [tm' [P [Q [R [S [T [U V]]]]]]]]]. econstructor; split. - apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + (* NOTE: strange specialize here *) + specialize (MCONT (VSet.empty) top). + exploit match_cont_call_comp; eauto. intros G. + apply plus_one. econstructor; eauto. rewrite <- G. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. intros. apply match_cont_incr_bounds with (Mem.nextblock m) (Mem.nextblock tm). eapply match_cont_extcall; eauto. extlia. extlia. @@ -2544,15 +2545,11 @@ Local Transparent Linker_fundef. simpl in *; unfold link_fundef in *. destruct f1; monadInv H3; destruct f2; monadInv H4; try discriminate. - destruct e; inv H2. - destruct eq_compartment; try easy. subst cp. inv H4. exists (Internal x); split; auto. -* now rewrite <- (comp_transl_partial _ EQ), dec_eq_true. -* simpl; rewrite EQ; auto. + simpl; rewrite EQ; auto. - destruct e; inv H2. - destruct eq_compartment; try easy. subst cp. inv H4. exists (Internal x); split; auto. -* now rewrite <- (comp_transl_partial _ EQ), dec_eq_true. -* simpl; rewrite EQ; auto. + simpl; rewrite EQ; auto. - destruct (external_function_eq e e0 && typelist_eq t t1 && type_eq t0 t2 && calling_convention_eq c c0); inv H2. econstructor; split; eauto. diff --git a/common/AST.v b/common/AST.v index 63407e3271..7e4951a4b1 100644 --- a/common/AST.v +++ b/common/AST.v @@ -40,6 +40,7 @@ Definition ident_eq := peq. (* Notation default_compartment := privileged_compartment. (* TODO: fix this *) *) (* Definition eq_compartment (c1 c2: compartment) := *) (* peq c1 c2. *) +Module Type COMPTYPE. Parameter compartment: Type. Parameters top bottom: compartment. @@ -102,11 +103,148 @@ Axiom flowsto_join2: forall cp cp', cp' ⊆ cp ∪ cp'. Axiom meet_flowsto1: forall cp cp', cp ∩ cp' ⊆ cp. Axiom meet_flowsto2: forall cp cp', cp ∩ cp' ⊆ cp'. +End COMPTYPE. + +Module COMP <: COMPTYPE. + + Variant compartment' := + | bottom': compartment' + | top': compartment' + | Comp: ident -> compartment' + . + + Definition compartment := compartment'. + Definition bottom := bottom'. + Definition top := top'. + (* Parameters top bottom: compartment. *) + Variant flowsto': compartment -> compartment -> Prop := + | bottom_flowsto': forall cp, flowsto' bottom cp + | flowsto_top': forall cp, flowsto' cp top + | flowsto_refl': forall cp, flowsto' cp cp. + + Definition flowsto := flowsto'. + + Lemma bottom_flowsto: forall cp, flowsto bottom cp. + Proof. exact bottom_flowsto'. Qed. + + Lemma flowsto_top: forall cp, flowsto cp top. + Proof. exact flowsto_top'. Qed. + Lemma flowsto_refl: forall cp, flowsto cp cp. + Proof. exact flowsto_refl'. Qed. + +Notation "c '⊆' c'" := (flowsto c c') (no associativity, at level 95). +Notation "c '⊈' c'" := (not (flowsto c c')) (no associativity, at level 95). + + +Lemma flowsto_dec: forall cp cp', {cp ⊆ cp'} + {cp ⊈ cp'}. +Proof. + destruct cp as [] eqn:?, cp' as [] eqn:?; try (now left; constructor). + now right; intros H; inv H. + now right; intros H; inv H. + now right; intros H; inv H. + subst. destruct (Pos.eq_dec i i0); subst. + - left; constructor. + - now right; intros H; inv H. +Defined. + +Lemma flowsto_antisym: forall cp cp', cp ⊆ cp' -> cp' ⊆ cp -> cp = cp'. +Proof. + intros ? ? H1 H2; + inv H1; inv H2; auto. +Qed. + +Lemma flowsto_trans: forall cp cp' cp'', cp ⊆ cp' -> cp' ⊆ cp'' -> cp ⊆ cp''. +Proof. + intros ? ? ? H1 H2. + inv H1; inv H2; try now constructor. +Qed. + +Lemma cp_eq_dec: forall (cp cp': compartment), {cp = cp'} + {cp <> cp'}. + intros cp cp'. + destruct (flowsto_dec cp cp') as [f1 | n1]; destruct (flowsto_dec cp' cp) as [f2 | n2]. + - left; eapply flowsto_antisym; eauto. + - right; intros ?; subst cp'; contradiction. + - right; intros ?; subst cp'; contradiction. + - right; intros ?; subst cp'; apply n1; now eapply flowsto_refl. +Qed. + +Definition comp_to_pos: compartment -> positive := + fun c => match c with + | bottom' => Z.to_pos 0 + | top' => Z.to_pos 1 + | Comp i => (Z.to_pos 2 + i)%positive + end. + +Axiom comp_to_pos_inj: forall x y: compartment, comp_to_pos x = comp_to_pos y -> x = y. + +Module COMPARTMENT_INDEXED_TYPE <: INDEXED_TYPE. + Definition t := compartment. + Definition index := comp_to_pos. + Definition index_inj := comp_to_pos_inj. + Definition eq := cp_eq_dec. +End COMPARTMENT_INDEXED_TYPE. + +Module CompTree := ITree (COMPARTMENT_INDEXED_TYPE). + +(* Axiom bottom_flowsto: forall cp, bottom ⊆ cp. *) +(* Axiom flowsto_top: forall cp, cp ⊆ top. *) + + +Definition join (c1 c2: compartment): compartment := + match c1, c2 with + | bottom', c2 => c2 + | c1, bottom' => c1 + | Comp i1, Comp i2 => if (Pos.eq_dec i1 i2) then Comp i1 else top + | _, _ => top + end. + +Definition meet (c1 c2: compartment): compartment := + match c1, c2 with + | top', c2 => c2 + | c1, top' => c1 + | Comp i1, Comp i2 => if (Pos.eq_dec i1 i2) then Comp i1 else bottom + | _, _ => bottom + end. + +Notation "c '∪' c'" := (join c c') (left associativity, at level 40). +Notation "c '∩' c'" := (meet c c') (left associativity, at level 40). +Axiom join_comm: forall cp cp', cp ∪ cp' = cp' ∪ cp. +Axiom meet_comm: forall cp cp', cp ∩ cp' = cp' ∩ cp. +Axiom join_assoc: forall cp cp' cp'', cp ∪ (cp' ∪ cp'') = (cp ∪ cp') ∪ cp''. +Axiom meet_assoc: forall cp cp' cp'', cp ∩ (cp' ∩ cp'') = (cp ∩ cp') ∩ cp''. +Axiom join_absorbs_meet: forall cp cp', cp ∪ (cp ∩ cp') = cp. +Axiom meet_absorbs_join: forall cp cp', cp ∩ (cp ∪ cp') = cp. + +Lemma join_idempotent: forall cp, cp ∪ cp = cp. +Proof. + intros cp. + rewrite <- (meet_absorbs_join cp cp) at 2; rewrite join_absorbs_meet; reflexivity. +Qed. + +Lemma meet_idempotent: forall cp, cp ∩ cp = cp. +Proof. + intros cp. + rewrite <- (join_absorbs_meet cp cp) at 2; rewrite meet_absorbs_join; reflexivity. +Qed. + +Axiom flowsto_join1: forall cp cp', cp ⊆ cp ∪ cp'. +Axiom flowsto_join2: forall cp cp', cp' ⊆ cp ∪ cp'. +Axiom meet_flowsto1: forall cp cp', cp ∩ cp' ⊆ cp. +Axiom meet_flowsto2: forall cp cp', cp ∩ cp' ⊆ cp'. + +End COMP. +Export COMP. +Global Opaque flowsto_dec. + + Create HintDb comps. #[export] Hint Resolve flowsto_refl flowsto_antisym flowsto_trans bottom_flowsto flowsto_top join_comm meet_comm join_assoc meet_assoc flowsto_join1 flowsto_join2 meet_flowsto1 meet_flowsto2: comps. #[export] Hint Rewrite join_idempotent meet_idempotent join_absorbs_meet meet_absorbs_join: comps. +Print HintDb comps. + + Set Typeclasses Strict Resolution. (** An instance of [has_comp] represents a syntactic entity that belongs to a compartment. We turn on strict resolution to prevent typeclass inference from diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 17dd23a331..868b9508e0 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -2035,14 +2035,6 @@ Definition type_of_call (cp: compartment) (cp': compartment): call_type := #[global] Arguments type_of_call /. -(* Lemma type_of_call_cp_default: *) -(* forall ge cp, type_of_call ge cp default_compartment <> CrossCompartmentCall. *) -(* Proof. *) -(* intros ge cp; unfold type_of_call. *) -(* destruct (cp =? default_compartment)%positive; [congruence |]. *) -(* rewrite Pos.eqb_refl; congruence. *) -(* Qed. *) - Lemma type_of_call_same_cp: forall cp, type_of_call cp cp = InternalCall. Proof. @@ -2097,8 +2089,9 @@ Lemma allowed_call_reflect: forall ge cp vf, Proof. intros ge cp vf. unfold allowed_call, allowed_call_b, allowed_cross_call. + Local Opaque flowsto_dec. destruct vf as [|?|?|?|?|b ofs]; simpl; - try now split; intuition; destruct (flowsto_dec); auto. + try (now split; intuition; edestruct (flowsto_dec); auto with comps). split. - intros [e | (i' & cp'' & A & B & C & D)]. + destruct flowsto_dec; auto. @@ -2121,6 +2114,7 @@ Proof. rewrite C. apply proj_sumbool_true in D. apply proj_sumbool_true in E. auto. + Local Transparent flowsto_dec. Qed. Lemma allowed_cross_call_public_symbol: forall ge cp vf, diff --git a/common/Memory.v b/common/Memory.v index 5a0f040891..40df75e14d 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -454,7 +454,8 @@ Theorem valid_block_can_access_block_priv: valid_block m b -> can_access_block m b top. Proof. - unfold can_access_block. simpl; trivial with comps. + unfold can_access_block. intros. simpl; auto with comps. + Print HintDb comps. Qed. (* Theorem can_access_block_valid_block: *) diff --git a/common/PrintAST.ml b/common/PrintAST.ml index 01d892c7b3..6b76cce742 100644 --- a/common/PrintAST.ml +++ b/common/PrintAST.ml @@ -49,19 +49,19 @@ let name_of_chunk = function | Many64 -> "any64" let name_of_external = function - | EF_external(_, name, sg) -> sprintf "extern %S" (camlstring_of_coqstring name) - | EF_builtin(_, name, sg) -> sprintf "builtin %S" (camlstring_of_coqstring name) - | EF_runtime(_, name, sg) -> sprintf "runtime %S" (camlstring_of_coqstring name) - | EF_vload(_, chunk) -> sprintf "volatile load %s" (name_of_chunk chunk) - | EF_vstore(_, chunk) -> sprintf "volatile store %s" (name_of_chunk chunk) - | EF_malloc _ -> "malloc" - | EF_free _ -> "free" - | EF_memcpy(_, sz, al) -> + | EF_external(name, sg) -> sprintf "extern %S" (camlstring_of_coqstring name) + | EF_builtin(name, sg) -> sprintf "builtin %S" (camlstring_of_coqstring name) + | EF_runtime(name, sg) -> sprintf "runtime %S" (camlstring_of_coqstring name) + | EF_vload(chunk) -> sprintf "volatile load %s" (name_of_chunk chunk) + | EF_vstore(chunk) -> sprintf "volatile store %s" (name_of_chunk chunk) + | EF_malloc -> "malloc" + | EF_free -> "free" + | EF_memcpy(sz, al) -> sprintf "memcpy size %s align %s " (Z.to_string sz) (Z.to_string al) - | EF_annot(_, kind,text, targs) -> sprintf "annot %S" (camlstring_of_coqstring text) - | EF_annot_val(_, kind,text, targ) -> sprintf "annot_val %S" (camlstring_of_coqstring text) - | EF_inline_asm(_, text, sg, clob) -> sprintf "inline_asm %S" (camlstring_of_coqstring text) - | EF_debug(_, kind, text, targs) -> + | EF_annot(kind,text, targs) -> sprintf "annot %S" (camlstring_of_coqstring text) + | EF_annot_val(kind,text, targ) -> sprintf "annot_val %S" (camlstring_of_coqstring text) + | EF_inline_asm(text, sg, clob) -> sprintf "inline_asm %S" (camlstring_of_coqstring text) + | EF_debug(kind, text, targs) -> sprintf "debug%d %S" (P.to_int kind) (extern_atom text) let rec print_builtin_arg px oc = function diff --git a/driver/Interp.ml b/driver/Interp.ml index 989b2091a0..d1875ab7dd 100644 --- a/driver/Interp.ml +++ b/driver/Interp.ml @@ -57,6 +57,12 @@ let print_eventval_list p = function print_eventval p v1; List.iter (fun v -> fprintf p ",@ %a" print_eventval v) vl +let string_of_comp c = + match c with + | COMP.Coq_bottom' -> Format.sprintf "CompBottom" + | COMP.Coq_top' -> Format.sprintf "CompTop" + | COMP.Comp id -> Format.sprintf "Comp%ld" (P.to_int32 id) + let print_event p = function | Event_syscall(id, args, res) -> fprintf p "extcall %s(%a) -> %a" @@ -78,16 +84,16 @@ let print_event p = function (camlstring_of_coqstring text) print_eventval_list args | Event_call(caller, callee, f, args) -> - fprintf p "Call %ld -[%a]-> %ld.%ld" - (P.to_int32 caller) + fprintf p "Call %s -[%a]-> %s.%ld" + (string_of_comp caller) print_eventval_list args - (P.to_int32 callee) + (string_of_comp callee) (P.to_int32 f) | Event_return(caller, callee, ret) -> - fprintf p "Return %ld <-[%a]- %ld" - (P.to_int32 caller) + fprintf p "Return %s <-[%a]- %s" + (string_of_comp caller) print_eventval ret - (P.to_int32 callee) + (string_of_comp callee) (* Printing states *) @@ -279,7 +285,7 @@ module StateMap = let extract_string m blk ofs = let b = Buffer.create 80 in let rec extract blk ofs = - match Mem.load Mint8unsigned m blk ofs None with + match Mem.load Mint8unsigned m blk ofs COMP.top with | Some(Vint n) -> let c = Char.chr (Z.to_int n) in if c = '\000' then begin @@ -398,7 +404,7 @@ let rec convert_external_args ge vl tl = convert_external_args ge vl tl >>= fun el -> Some (e1 :: el) | _, _ -> None -let do_external_function cp id sg ge w (* cp <- NOTE *) args m = +let do_external_function id sg ge cp w args m = match camlstring_of_coqstring id, args with | "printf", Vptr(b, ofs) :: args' -> extract_string m b ofs >>= fun fmt -> @@ -423,15 +429,14 @@ and world_io ge m id args = and world_vload ge m chunk id ofs = Genv.find_symbol ge.genv_genv id >>= fun b -> - Mem.load chunk m b ofs None >>= fun v -> + Mem.load chunk m b ofs COMP.top >>= fun v -> Exec.eventval_of_val ge.genv_genv v (type_of_chunk chunk) >>= fun ev -> Some(ev, world ge m) and world_vstore ge m chunk id ofs ev = Genv.find_symbol ge.genv_genv id >>= fun b -> Exec.val_of_eventval ge.genv_genv ev (type_of_chunk chunk) >>= fun v -> - Mem.block_compartment m b >>= fun cp -> - Mem.store chunk m b ofs v cp >>= fun m' -> + Mem.store chunk m b ofs v (Mem.block_compartment m b) >>= fun m' -> Some(world ge m') let do_event p ge time w ev = @@ -619,7 +624,7 @@ let call_main3_function main_id main_ty = let body = Sreturn(Some(Ecall(main_var, Econs(arg1, Econs(arg2, Enil)), type_int32s))) in - { fn_comp = AST.privileged_compartment; + { fn_comp = COMP.top; fn_return = type_int32s; fn_callconv = cc_default; fn_params = []; fn_vars = []; fn_body = body } @@ -629,7 +634,7 @@ let call_other_main_function main_id main_ty main_ty_res = Ssequence(Sdo(Ecall(main_var, Enil, main_ty_res)), Sreturn(Some(Eval(Vint(coqint_of_camlint 0l), type_int32s)))) in { fn_return = type_int32s; fn_callconv = cc_default; - fn_comp = AST.privileged_compartment; + fn_comp = COMP.top; fn_params = []; fn_vars = []; fn_body = body } (* FIXME? *) @@ -700,15 +705,14 @@ and world_io_asm ge m id args = and world_vload_asm ge m chunk id ofs = Genv.find_symbol ge id >>= fun b -> - Mem.load chunk m b ofs None >>= fun v -> + Mem.load chunk m b ofs COMP.top >>= fun v -> Exec.eventval_of_val ge v (type_of_chunk chunk) >>= fun ev -> Some(ev, world_asm ge m) and world_vstore_asm ge m chunk id ofs ev = Genv.find_symbol ge id >>= fun b -> Exec.val_of_eventval ge ev (type_of_chunk chunk) >>= fun v -> - Mem.block_compartment m b >>= fun cp -> - Mem.store chunk m b ofs v cp >>= fun m' -> + Mem.store chunk m b ofs v (Mem.block_compartment m b) >>= fun m' -> Some(world_asm ge m') let do_step_asm p prog ge time s w = diff --git a/riscV/Asm.v b/riscV/Asm.v index c06ffcb0e5..831174a4f8 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1222,7 +1222,7 @@ Definition update_stack_call (s: stack) (sg: signature) (cp: compartment) rs' := let ra' := rs' # RA in let sp' := rs' # SP in let cp' := Genv.find_comp_in_genv ge pc' in - if flowsto_dec cp' cp then + if cp_eq_dec cp' cp then (* If we are in the same compartment as previously recorded, we don't update the stack *) Some s @@ -1239,7 +1239,7 @@ Definition update_stack_call (s: stack) (sg: signature) (cp: compartment) rs' := Definition update_stack_return (s: stack) (cp: compartment) rs' := let pc' := rs' # PC in let cp' := Genv.find_comp_in_genv ge pc' in - if flowsto_dec cp cp' then + if cp_eq_dec cp cp' then (* If we are in the same compartment as previously recorded, we don't update the stack *) Some s @@ -1252,7 +1252,7 @@ Definition update_stack_return (s: stack) (cp: compartment) rs' := . Inductive state: Type := - | State: stack -> regset -> mem -> state + | State: stack -> regset -> mem -> compartment -> state | ReturnState: stack -> regset -> mem -> compartment -> state. Definition sig_call i := @@ -1289,7 +1289,7 @@ Definition sig_of_call s := Inductive step: state -> trace -> state -> Prop := | exec_step_internal: - forall b ofs f i rs m rs' m' b' ofs' st, + 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 -> @@ -1298,7 +1298,7 @@ Inductive step: state -> trace -> state -> Prop := is_return i = false -> forall (NEXTPC: rs' PC = Vptr b' ofs'), forall (ALLOWED: comp_of f = Genv.find_comp_of_block ge b'), - step (State st rs m) E0 (State st rs' m') + step (State st rs m cp) E0 (State st rs' m' (comp_of f)) | exec_step_internal_call: forall b ofs f i sig rs m rs' m' b' ofs' st st' args t, rs PC = Vptr b ofs -> @@ -1318,16 +1318,16 @@ Inductive step: state -> trace -> state -> Prop := List.Forall not_ptr args), forall (EV: call_trace ge (comp_of f) cp' (Vptr b' ofs') args (sig_args sig) t), - step (State st rs m) t (State st' rs' m') + step (State st rs m (comp_of f)) t (State st' rs' m' (comp_of f)) | exec_step_internal_return: - forall b ofs f i rs m rs' m' st, + forall b ofs f i rs m rs' m' 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 -> exec_instr f i rs m (comp_of f) = Next rs' m' -> is_return i = true -> (* We attempt a return, so we go to a ReturnState*) - step (State st rs m) E0 (ReturnState st rs' m' (comp_of f)) + step (State st rs m cp) E0 (ReturnState st rs' m' (comp_of f)) | exec_step_return: forall st st' rs m sg t rec_cp cp', rs PC <> Vnullptr -> @@ -1345,7 +1345,7 @@ Inductive step: state -> trace -> state -> Prop := (Genv.type_of_call 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 (ReturnState st rs m rec_cp) t (State st' rs m) + step (ReturnState st rs m rec_cp) t (State st' rs m cp') | exec_step_builtin: forall b ofs f ef args res rs m vargs t vres rs' m' st, rs PC = Vptr b ofs -> @@ -1357,15 +1357,15 @@ Inductive step: state -> trace -> state -> Prop := (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs #X1 <- Vundef #X31 <- Vundef))) -> - step (State st rs m) t (State st rs' m') + step (State st rs m (comp_of f)) t (State st rs' m' (comp_of f)) | exec_step_external: - forall b ef args res rs m t rs' m' st, + forall b ef args res rs m t rs' m' st cp, rs PC = Vptr b Ptrofs.zero -> Genv.find_funct_ptr ge b = Some (External ef) -> - external_call ef ge (Genv.find_comp_in_genv ge (rs RA)) args m t res m' -> + 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) -> - step (State st rs m) t (ReturnState st rs' m' bottom). + step (State st rs m cp) t (ReturnState st rs' m' bottom). End RELSEM. @@ -1380,7 +1380,7 @@ Inductive initial_state (p: program): state -> Prop := # SP <- Vnullptr # RA <- Vnullptr in Genv.init_mem p = Some m0 -> - initial_state p (State initial_stack rs0 m0). + initial_state p (State initial_stack rs0 m0 top). Inductive final_state (p: program): state -> int -> Prop := | final_state_intro: forall rs m r cp, @@ -1504,10 +1504,10 @@ intros; constructor; simpl; intros. + discriminate. + discriminate. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H5. eexact H14. intros [A B]. + exploit external_call_determ. eexact H5. eexact H15. intros [A B]. split. auto. intros. destruct B; auto. subst. auto. + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. - exploit external_call_determ. eexact H3. eexact H9. intros [A B]. + exploit external_call_determ. eexact H3. eexact H12. intros [A B]. split. auto. intros. destruct B; auto. subst. congruence. - (* trace length *) red; intros. inv H; simpl. @@ -1599,7 +1599,7 @@ Section ExecSem. Definition take_step (p: program) (ge: genv) (w: world) (s: state): option (trace * state) := let comp_of_main := comp_of_main p in match s with - | State st rs m => + | State st rs m _ => do Vptr b ofs <- rs PC; do fd <- Genv.find_funct_ptr ge b; match fd with @@ -1612,7 +1612,7 @@ Section ExecSem. do Vptr b' ofs' <- rs' PC; let cp := Genv.find_comp_of_block ge b' in check (cp_eq_dec (comp_of f) cp); - Some (E0, State st rs' m') + Some (E0, State st rs' m' (comp_of f)) | Some sig, false => (* exec_step_internal_call *) do Vptr b' ofs' <- rs' PC; check (Genv.allowed_call_b ge (comp_of f) (rs' PC)); @@ -1624,7 +1624,7 @@ Section ExecSem. | _ => true end); do t <- get_call_trace _ _ ge (comp_of f) cp (rs' PC) vargs (sig_args sig); - Some (t, State st' rs' m') + Some (t, State st' rs' m' (comp_of f)) | None, true => (* exec_step_internal_return *) check (Genv.allowed_call_b ge (comp_of f) (rs' PC)); Some (E0, ReturnState st rs' m' (comp_of f)) @@ -1656,7 +1656,7 @@ Section ExecSem. | Genv.CrossCompartmentCall => not_ptr_b (return_value rs sg) | _ => true end); do t <- get_return_trace _ _ ge cp' rec_cp (return_value rs sg) (sig_res sg); - Some (t, State st' rs m) + Some (t, State st' rs m bottom) end. Definition build_initial_state (p: program): option state := @@ -1667,7 +1667,7 @@ Definition build_initial_state (p: program): option state := # SP <- Vnullptr # RA <- Vnullptr in do m0 <- Genv.init_mem p; - Some (State initial_stack rs0 m0). + Some (State initial_stack rs0 m0 top). End ExecSem. diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index e221519875..a8cd941bfc 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -140,8 +140,8 @@ let fixup_function_entry sg = (* Handling of annotations *) -let expand_annot_val cp kind txt targ args res = - emit (Pbuiltin (EF_annot(cp,kind,txt,[targ]), args, BR_none)); +let expand_annot_val kind txt targ args res = + emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); match args, res with | [BA(IR src)], BR(IR dst) -> if dst <> src then emit (Pmv (dst, src)) @@ -734,15 +734,15 @@ let expand_instruction instr = | Pbuiltin (ef,args,res) -> begin match ef with - | EF_builtin (_cp,name,sg) -> + | EF_builtin (name,sg) -> expand_builtin_inline (camlstring_of_coqstring name) args res - | EF_vload (_cp,chunk) -> + | EF_vload (chunk) -> expand_builtin_vload chunk args res - | EF_vstore (_cp,chunk) -> + | EF_vstore (chunk) -> expand_builtin_vstore chunk args - | EF_annot_val (cp,kind,txt,targ) -> - expand_annot_val cp kind txt targ args res - | EF_memcpy(_cp,sz, al) -> + | EF_annot_val (kind,txt,targ) -> + expand_annot_val kind txt targ args res + | EF_memcpy(sz, al) -> expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args | EF_annot _ | EF_debug _ | EF_inline_asm _ -> emit instr diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 4a6af0ac98..978ac78f1a 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -71,7 +71,7 @@ Qed. Lemma find_comp_translated: forall vf, - Genv.find_comp ge vf = Genv.find_comp tge vf. + Genv.find_comp_in_genv ge vf = Genv.find_comp_in_genv tge vf. Proof. eapply (Genv.find_comp_transf_partial TRANSF). Qed. @@ -107,12 +107,15 @@ Proof. Qed. Lemma exec_straight_exec: - forall fb f c ep tf tc c' rs m rs' m' st, + forall fb f c ep tf tc c' rs m rs' m' st cp, transl_code_at_pc ge (rs PC) fb f c ep tf tc -> exec_straight tge tf tc rs m c' rs' m' -> - plus step tge (State st rs m) E0 (State st rs' m'). + cp = Genv.find_comp_in_genv ge (rs PC) -> + plus step tge (State st rs m cp) E0 (State st rs' m' cp). Proof. intros. inv H. + rewrite <- H2; simpl; erewrite Genv.find_funct_ptr_find_comp_of_block; eauto; simpl; + rewrite comp_transf_function; eauto. eapply exec_straight_steps_1; eauto. eapply transf_function_no_overflow; eauto. eapply functions_transl; eauto. @@ -525,15 +528,15 @@ Inductive match_stacks cp : list Mach.stackframe -> stack -> Prop := (* Intra-compartment calls create a new frame in the source, but not the target *) forall s s' f, match_stacks cp s s' -> - Mach.call_comp ge (f :: s) = Some cp -> (* meaning, we are staying in the same + Mach.call_comp ge (f :: s) = cp -> (* meaning, we are staying in the same compartment *) match_stacks cp (f :: s) s' | match_stacks_cross_compartment: (* Cross-compartment calls create a new frame in both the source and the target *) forall cp' s s' f f', match_stacks cp' s s' -> - Mach.call_comp ge (f :: s) = Some cp' -> - call_comp tge (f' :: s') = Some cp' -> + Mach.call_comp ge (f :: s) = cp' -> + call_comp tge (f' :: s') = cp' -> cp <> cp' -> match_stackframe f f' -> match_stacks cp (f :: s) (f' :: s') @@ -550,18 +553,18 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (AG: agree ms sp rs) (DXP: ep = true -> rs#X30 = parent_sp s), match_states (Mach.State s fb sp c ms m) - (Asm.State s' rs m') + (Asm.State s' rs m' (comp_of f)) | match_states_call: - forall s s' fb ms m m' rs sig cp + forall s s' fb ms m m' rs sig cp cp' (STACKS: match_stack ge s) - (STACKS_COMP: Genv.find_comp_of_block ge fb = Some cp) + (STACKS_COMP: Genv.find_comp_of_block ge fb = cp) (STACKS': match_stacks cp s s') (MEXT: Mem.extends m m') (AG: agree ms (parent_sp s) rs) (ATPC: rs PC = Vptr fb Ptrofs.zero) (ATLR: rs RA = parent_ra s), - match_states (Mach.Callstate s fb sig ms m) - (Asm.State s' rs m') + match_states (Mach.Callstate s fb sig ms m cp') + (Asm.State s' rs m' cp') | match_states_return: forall s s' ms m m' rs cp (STACKS: match_stack ge s) @@ -585,13 +588,14 @@ Lemma exec_straight_steps: /\ agree ms2 sp rs2 /\ (it1_is_parent ep i = true -> rs2#X30 = parent_sp s)) -> exists st', - plus step tge (State s' rs1 m1') E0 st' /\ + plus step tge (State s' rs1 m1' (comp_of f)) E0 st' /\ match_states (Mach.State s fb sp c ms2 m2) st'. Proof. intros. inversion H2. subst. monadInv H7. exploit H3; eauto. intros [rs2 [A [B C]]]. - exists (State s' rs2 m2'); split. + exists (State s' rs2 m2' (comp_of f)); split. eapply exec_straight_exec; eauto. + now rewrite <- H4; simpl; erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. econstructor; eauto. eapply exec_straight_at; eauto. Qed. @@ -613,7 +617,7 @@ Lemma exec_straight_steps_goto: /\ sig_call jmp = None /\ is_return jmp = false) -> exists st', - plus step tge (State s' rs1 m1') E0 st' /\ + plus step tge (State s' rs1 m1' (comp_of f)) E0 st' /\ match_states (Mach.State s fb sp c' ms2 m2) st'. Proof. intros. inversion H3. subst. monadInv H9. @@ -625,16 +629,17 @@ Proof. exploit find_label_goto_label; eauto. intros [tc' [rs3 [GOTO [AT' OTH]]]]. inversion AT'; subst. - exists (State s' rs3 m2'); split. + exists (State s' rs3 m2' (comp_of f)); split. eapply plus_right'. - eapply exec_straight_steps_1; eauto. unfold Genv.find_comp. - { econstructor. eauto. eauto. + rewrite comp_transf_function; eauto. + eapply exec_straight_steps_1; eauto. + { rewrite comp_transf_function; eauto. + econstructor. eauto. eauto. eapply find_instr_tail. eauto. rewrite <- comp_transf_function; eauto. rewrite C. eexact GOTO. auto. auto. eauto. - simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FN). - } + simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FN). } traceEq. econstructor; eauto. apply agree_exten with rs2; auto with asmgen. @@ -658,7 +663,7 @@ Lemma exec_straight_opt_steps_goto: /\ sig_call jmp = None /\ is_return jmp = false) -> exists st', - plus step tge (State s' rs1 m1') E0 st' /\ + plus step tge (State s' rs1 m1' (comp_of f)) E0 st' /\ match_states (Mach.State s fb sp c' ms2 m2) st'. Proof. intros. inversion H3. subst. monadInv H9. @@ -669,9 +674,10 @@ Proof. - exploit find_label_goto_label; eauto. intros [tc' [rs3 [GOTO [AT' OTH]]]]. inversion AT'; subst. - exists (State s' rs3 m2'); split. + exists (State s' rs3 m2' (comp_of f)); split. apply plus_one. - { econstructor. eauto. eauto. + { rewrite comp_transf_function; eauto. + econstructor. eauto. eauto. eapply find_instr_tail. eauto. rewrite C. eexact GOTO. auto. auto. eauto. simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FN). @@ -684,10 +690,12 @@ Proof. exploit find_label_goto_label; eauto. intros [tc' [rs3 [GOTO [AT' OTH]]]]. inversion AT'; subst. - exists (State s' rs3 m2'); split. + exists (State s' rs3 m2' (comp_of f)); split. eapply plus_right'. + rewrite comp_transf_function; eauto. eapply exec_straight_steps_1; eauto. - { econstructor. eauto. eauto. + { rewrite comp_transf_function; eauto. + econstructor. eauto. eauto. eapply find_instr_tail. eauto. rewrite C. eexact GOTO. auto. auto. eauto. simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FN). @@ -709,7 +717,7 @@ Qed. Definition measure (s: Mach.state) : nat := match s with | Mach.State _ _ _ _ _ _ => 0%nat - | Mach.Callstate _ _ _ _ _ => 2%nat + | Mach.Callstate _ _ _ _ _ _ => 2%nat | Mach.Returnstate _ _ _ _ => 1%nat end. @@ -719,7 +727,7 @@ Proof. exploit preg_of_injective; eauto. intros; subst r; discriminate. Qed. -Ltac unfold_find_comp A R := +Ltac unfold_find_comp_in_genv A R := rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ R) in A; injection A as A. @@ -744,8 +752,10 @@ Proof. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto. intros. simpl in TR. inv AT. - unfold_find_comp CURCOMP FIND. - rewrite <- CURCOMP in A. setoid_rewrite (comp_transf_function) in A; eauto. + (* unfold_find_comp_in_genv CURCOMP FIND. *) + unfold Genv.find_comp_of_block in A; unfold Genv.find_funct_ptr in FIND. + destruct (Genv.find_def ge f) as [[] |] eqn:?; try congruence. inv FIND. simpl in A. + setoid_rewrite (comp_transf_function) in A; eauto. exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. exists rs'; split. eauto. split. eapply agree_set_mreg; eauto with asmgen. congruence. @@ -758,8 +768,9 @@ Proof. left; eapply exec_straight_steps; eauto. rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. inv AT. - unfold_find_comp CURCOMP FIND. - setoid_rewrite <- CURCOMP in A. setoid_rewrite (comp_transf_function) in A; eauto. + unfold Genv.find_comp_of_block in A; unfold Genv.find_funct_ptr in FIND. + destruct (Genv.find_def ge f) as [[] |] eqn:?; try congruence. inv FIND. simpl in A. + setoid_rewrite (comp_transf_function) in A; eauto. exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. exists rs'; split. eauto. split. eapply agree_undef_regs; eauto with asmgen. @@ -788,8 +799,9 @@ Opaque loadind. (* GPR11 does not contain parent *) rewrite chunk_of_Tptr in A. inv AT. - unfold_find_comp CURCOMP FIND. - setoid_rewrite <- CURCOMP in A. setoid_rewrite (comp_transf_function) in A; eauto. + unfold Genv.find_comp_of_block in A; unfold Genv.find_funct_ptr in FIND. + destruct (Genv.find_def ge fb) as [[] |] eqn:?; try congruence. inv FIND. simpl in A. + setoid_rewrite (comp_transf_function) in A; eauto. exploit loadind_ptr_correct. eexact A. congruence. intros [rs1 [P [Q R]]]. exploit loadind_priv_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. congruence. intros [rs2 [S [T U]]]. @@ -825,8 +837,9 @@ Local Transparent destroyed_by_op. exploit Mem.loadv_extends; eauto. intros [v' [C D]]. left; eapply exec_straight_steps; eauto; intros. simpl in TR. inv AT. - unfold_find_comp CURCOMP FIND. - setoid_rewrite <- CURCOMP in C. setoid_rewrite (comp_transf_function) in C; eauto. + unfold Genv.find_comp_of_block in C; unfold Genv.find_funct_ptr in FIND. + destruct (Genv.find_def ge f) as [[] |] eqn:?; try congruence. inv FIND. simpl in C. + setoid_rewrite (comp_transf_function) in C; eauto. exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]]. exists rs2; split. eauto. split. eapply agree_set_undef_mreg; eauto. congruence. @@ -842,8 +855,9 @@ Local Transparent destroyed_by_op. exploit Mem.storev_extends; eauto. intros [m2' [C D]]. left; eapply exec_straight_steps; eauto. inv AT. - unfold_find_comp CURCOMP FIND. - setoid_rewrite <- CURCOMP in C. setoid_rewrite (comp_transf_function) in C; eauto. + unfold Genv.find_comp_of_block in C; unfold Genv.find_funct_ptr in FIND. + destruct (Genv.find_def ge f) as [[] |] eqn:?; try congruence. inv FIND. simpl in C. + setoid_rewrite (comp_transf_function) in C; eauto. intros. simpl in TR. exploit transl_store_correct; eauto. intros [rs2 [P Q]]. exists rs2; split. eauto. split. eapply agree_undef_regs; eauto with asmgen. @@ -870,9 +884,11 @@ Local Transparent destroyed_by_op. instantiate (1 := (rs0 # PC <- (rs0 x0)) # X1 <- (Val.offset_ptr (rs0 PC) Ptrofs.one)). simpl. eapply agree_exten. eapply agree_undef_regs; eauto. intros. Simpl. intros [args' [ARGS' LDARGS]]. - destruct ((comp_of (Internal tf) =? comp_of tf')%positive) eqn:Heq. + destruct (cp_eq_dec (comp_of tf') (comp_of tf)) eqn:Heq. * left; econstructor; split. - apply plus_one. eapply exec_step_internal_call with (args := args'). + apply plus_one. + rewrite comp_transf_function. + eapply exec_step_internal_call with (args := args'). rewrite <- H2; simpl; eauto. eapply functions_transl; eauto. eapply find_instr_tail; eauto. @@ -886,77 +902,177 @@ Local Transparent destroyed_by_op. rewrite H7; simpl. unfold tge. rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - unfold comp_of in *; simpl in *; unfold comp_of in *; now rewrite Heq. + rewrite e; destruct (cp_eq_dec (comp_of tf) (comp_of tf)); try now auto. auto. + rewrite e, Genv.type_of_call_same_cp; now auto. (* Not a cross-compartment call *) - { unfold Genv.type_of_call; simpl in *. - unfold comp_of. unfold comp_of in Heq. now setoid_rewrite Heq. } + (* { destruct (cp_eq_dec (comp_of tf) (comp_of tf)); try now auto. } *) + (* pose proof (flowsto_refl (comp_of tf)); try now auto. } *) { rewrite <- comp_transf_function; eauto. rewrite <- (comp_transl_partial _ TTRANSF); eauto. eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } + eauto. + (* replace (comp_of f) with (comp_of tf'). *) + (* replace (comp_of f) with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) + rewrite comp_transf_function; eauto. econstructor; eauto. econstructor; eauto. eapply agree_sp_def; eauto. - { rewrite find_comp_of_block_translated. unfold tge. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). } + (* { rewrite find_comp_translated. unfold tge. *) + (* unfold Genv.find_comp_in_genv. simpl. *) + (* exploit functions_transl; eauto. intros G. *) + (* rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ G). *) + (* rewrite comp_transf_function; simpl; eauto. } *) { Simpl. change (comp_of (Internal tf)) with (comp_of tf) in Heq. - apply Peqb_true_eq in Heq. rewrite <- Heq. - rewrite <- (comp_transf_function _ _ H4). + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). apply match_stacks_intra_compartment; trivial. + replace (comp_of fd) with (comp_of f). auto. + { rewrite comp_transf_function; eauto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + - monadInv TTRANSF. simpl in *. + rewrite comp_transf_function. rewrite e; eauto. + eauto. + - inv TTRANSF. simpl in *. auto. } unfold Mach.call_comp. simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). } - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. - * left; econstructor; split. - apply plus_one. eapply exec_step_internal_call. - rewrite <- H2; simpl; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - simpl; eauto. - Simpl; eauto. - rewrite <- (comp_transl_partial _ H4). - eapply allowed_call_translated; eauto. - simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - unfold update_stack_call. Simpl. - rewrite H7; simpl. - simpl. - unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - rewrite <- H2. simpl. - replace (comp_of tf =? comp_of tf')%positive with false. - reflexivity. - eauto. - { simpl. - intros. - rewrite <- (comp_transl_partial _ H4) in H8. - rewrite <- (comp_transl_partial _ TTRANSF) in H8. - specialize (NO_CROSS_PTR H8). - now eapply Val.lessdef_list_not_ptr; eauto. } - { simpl. rewrite <- comp_transf_function; eauto. - rewrite <- (comp_transl_partial _ TTRANSF). - eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - { Simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). } - (* TODO: clean *) - { eapply match_stacks_cross_compartment. exact STACKS'. - - unfold Mach.call_comp. simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). - - simpl. - rewrite <- find_comp_of_block_translated. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). - - rewrite (comp_transl_partial _ TTRANSF). - rewrite (comp_transl_partial _ H4). - intros contra. now rewrite contra, Pos.eqb_refl in Heq. - - erewrite agree_sp; eauto. - constructor. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). + { simpl. + rewrite comp_transf_function; eauto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + - monadInv TTRANSF. simpl in *. + rewrite comp_transf_function. rewrite e; eauto. + eauto. + - inv TTRANSF. simpl in *. auto. } } simpl. eapply agree_exten; eauto. intros. Simpl. Simpl. rewrite <- H2. auto. + (* simpl. *) + (* now rewrite e, comp_transf_function. *) + * destruct (flowsto_dec (comp_of tf') (comp_of tf)) eqn:?. + -- left; econstructor; split. + rewrite comp_transf_function. + apply plus_one. eapply exec_step_internal_call. + rewrite <- H2; simpl; eauto. + eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; eauto. + simpl; eauto. + Simpl; eauto. + rewrite <- (comp_transl_partial _ H4). + eapply allowed_call_translated; eauto. + simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + unfold update_stack_call. Simpl. + rewrite H7; simpl. + simpl. + unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + rewrite <- H2. simpl. rewrite Heq. + reflexivity. + eauto. + { simpl. + intros. + rewrite <- (comp_transl_partial _ H4) in H8. + rewrite <- (comp_transl_partial _ TTRANSF) in H8. + specialize (NO_CROSS_PTR H8). + now eapply Val.lessdef_list_not_ptr; eauto. } + { simpl. rewrite <- comp_transf_function; eauto. + rewrite <- (comp_transl_partial _ TTRANSF). + eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } + eauto. + (* replace (comp_of f) *) + (* with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) + rewrite comp_transf_function; eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + (* TODO: clean *) + { eapply match_stacks_cross_compartment. exact STACKS'. + - unfold Mach.call_comp. simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). + - simpl. + rewrite <- find_comp_of_block_translated. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). + - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). + simpl. + rewrite comp_transf_function; eauto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + + monadInv TTRANSF. simpl in *. + rewrite comp_transf_function; eauto. + + inv TTRANSF. simpl in *. auto. + - erewrite agree_sp; eauto. + constructor. + } + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. + (* simpl. *) + (* now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). *) + -- left; econstructor; split. + rewrite comp_transf_function; eauto. + apply plus_one. eapply exec_step_internal_call. + rewrite <- H2; simpl; eauto. + eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; eauto. + simpl; eauto. + Simpl; eauto. + rewrite <- (comp_transl_partial _ H4). + eapply allowed_call_translated; eauto. + simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + unfold update_stack_call. Simpl. + rewrite H7; simpl. + simpl. + unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + rewrite <- H2. simpl. rewrite Heq. + reflexivity. + eauto. + { simpl. + intros. + rewrite <- (comp_transl_partial _ H4) in H8. + rewrite <- (comp_transl_partial _ TTRANSF) in H8. + specialize (NO_CROSS_PTR H8). + now eapply Val.lessdef_list_not_ptr; eauto. } + { simpl. rewrite <- comp_transf_function; eauto. + rewrite <- (comp_transl_partial _ TTRANSF). + eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } + (* replace (comp_of f) *) + (* with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) + rewrite comp_transf_function; eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + (* { rewrite find_comp_translated. unfold tge. *) + (* unfold Genv.find_comp_in_genv. simpl. *) + (* exploit functions_transl; eauto. intros G. *) + (* rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ G). *) + (* rewrite comp_transf_function; simpl; eauto. } *) + (* TODO: clean *) + { eapply match_stacks_cross_compartment. exact STACKS'. + - unfold Mach.call_comp. simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). + - simpl. + rewrite <- find_comp_of_block_translated. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). + (* - rewrite (comp_transl_partial _ TTRANSF). *) + (* rewrite (comp_transl_partial _ H4). *) + (* intros contra. now rewrite contra, Pos.eqb_refl in Heq. *) + - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). + simpl. + rewrite comp_transf_function; eauto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + + monadInv TTRANSF. simpl in *. + rewrite comp_transf_function; eauto. + + inv TTRANSF. simpl in *. auto. + - erewrite agree_sp; eauto. + constructor. + } + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. + (* simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). *) + (* Direct call *) generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). @@ -966,8 +1082,9 @@ Local Transparent destroyed_by_op. instantiate (1 := (rs0 # PC <- (Genv.symbol_address tge fid Ptrofs.zero)) # X1 <- (Val.offset_ptr (rs0 PC) Ptrofs.one)). simpl. eapply agree_exten. eapply agree_undef_regs; eauto. intros. Simpl. intros [args' [ARGS' LDARGS]]. - destruct (comp_of (Internal tf) =? comp_of tf')%positive eqn:Heq. + destruct (cp_eq_dec (comp_of tf') (comp_of tf)) eqn:Heq. * left; econstructor; split. + rewrite comp_transf_function; eauto. apply plus_one. eapply exec_step_internal_call. rewrite <- H2; simpl; eauto. eapply functions_transl; eauto. @@ -987,72 +1104,175 @@ Local Transparent destroyed_by_op. unfold comp_of in *; simpl in *. unfold comp_of in *. now rewrite Heq. eauto. (* Not a cross-compartment call *) - { unfold Genv.type_of_call; simpl in *. - unfold comp_of. unfold comp_of in Heq. now setoid_rewrite Heq. } + rewrite e, Genv.type_of_call_same_cp; now auto. + (* { unfold Genv.type_of_call; simpl in *. *) + (* unfold comp_of. unfold comp_of in Heq. now setoid_rewrite Heq. } *) { simpl. rewrite <- comp_transf_function; eauto. rewrite <- (comp_transl_partial _ TTRANSF). eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } + (* replace (comp_of f) with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) + rewrite comp_transf_function; eauto. econstructor; eauto. econstructor; eauto. eapply agree_sp_def; eauto. + (* { rewrite find_comp_translated. unfold tge. *) + (* unfold Genv.find_comp_in_genv. simpl. *) + (* exploit functions_transl; eauto. intros G. *) + (* rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ G). *) + (* rewrite comp_transf_function; simpl; eauto. } *) { Simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). } - { Simpl. - rewrite (comp_transl_partial _ TTRANSF). - apply Pos.eqb_eq in Heq. rewrite <- Heq. - change (comp_of (Internal tf)) with (comp_of tf). - rewrite <- (comp_transl_partial _ H4). - apply match_stacks_intra_compartment. exact STACKS'. - unfold Mach.call_comp. simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). } - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. - Simpl. rewrite <- H2. auto. - * left; econstructor; split. - apply plus_one. eapply exec_step_internal_call. - rewrite <- H2; simpl; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - simpl; eauto. - Simpl; eauto. - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. - rewrite <- (comp_transl_partial _ H4). - eapply allowed_call_translated; eauto. - rewrite <- find_comp_of_block_translated. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). - unfold update_stack_call. Simpl. - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. - simpl; unfold tge. rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - replace (comp_of tf =? comp_of tf')%positive with false. - rewrite <- H2. simpl. eauto. eauto. - { simpl. intros. - rewrite <- (comp_transl_partial _ H4) in H5. - specialize (NO_CROSS_PTR H5). - now eapply Val.lessdef_list_not_ptr; eauto. } - { simpl. rewrite <- comp_transf_function; eauto. - eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - (* TODO: clean *) - { Simpl. + change (comp_of (Internal tf)) with (comp_of tf) in Heq. rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). - rewrite (comp_transl_partial _ TTRANSF). reflexivity. } - { change (comp_of (Internal tf)) with (comp_of tf) in *. - eapply match_stacks_cross_compartment. exact STACKS'. - - unfold Mach.call_comp. simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). - - simpl. - rewrite <- find_comp_of_block_translated. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). - - rewrite (comp_transl_partial _ H4). - intros contra. now rewrite contra, Pos.eqb_refl in Heq. - - erewrite agree_sp; eauto. - constructor. } + apply match_stacks_intra_compartment; trivial. + replace (comp_of fd) with (comp_of f). auto. + { rewrite comp_transf_function; eauto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + - monadInv TTRANSF. simpl in *. + rewrite comp_transf_function. rewrite e; eauto. + eauto. + - inv TTRANSF. simpl in *. auto. } + unfold Mach.call_comp. simpl. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). + { simpl. + rewrite comp_transf_function; eauto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + - monadInv TTRANSF. simpl in *. + rewrite comp_transf_function. rewrite e; eauto. + eauto. + - inv TTRANSF. simpl in *. auto. } + } simpl. eapply agree_exten; eauto. intros. Simpl. Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. Simpl. rewrite <- H2. auto. + (* simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). *) + * destruct (flowsto_dec (comp_of tf') (comp_of tf)) eqn:?. + -- left; econstructor; split. + rewrite comp_transf_function; eauto. + apply plus_one. eapply exec_step_internal_call. + rewrite <- H2; simpl; eauto. + eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; eauto. + simpl; eauto. + Simpl; eauto. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. + rewrite <- (comp_transl_partial _ H4). + eapply allowed_call_translated; eauto. + simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + unfold update_stack_call. Simpl. + (* rewrite H7; simpl. *) + (* simpl. *) + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. simpl. + unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + rewrite <- H2. simpl. rewrite Heq. + reflexivity. + eauto. + { simpl. + intros. + rewrite <- (comp_transl_partial _ H4) in H5. + rewrite <- (comp_transl_partial _ TTRANSF) in H5. + specialize (NO_CROSS_PTR H5). + now eapply Val.lessdef_list_not_ptr; eauto. } + { simpl. rewrite <- comp_transf_function; eauto. + rewrite <- (comp_transl_partial _ TTRANSF). + eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } + (* replace (comp_of f) *) + (* with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) + rewrite comp_transf_function; eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + (* TODO: clean *) + { eapply match_stacks_cross_compartment. exact STACKS'. + - unfold Mach.call_comp. simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). + - simpl. + rewrite <- find_comp_of_block_translated. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). + - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). + simpl. + rewrite comp_transf_function; eauto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + + monadInv TTRANSF. simpl in *. + rewrite comp_transf_function; eauto. + + inv TTRANSF. simpl in *. auto. + - erewrite agree_sp; eauto. + constructor. + } + simpl. eapply agree_exten; eauto. intros. Simpl. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. simpl. + Simpl. rewrite <- H2. auto. + (* simpl. *) + (* now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). *) + -- left; econstructor; split. + rewrite comp_transf_function; eauto. + apply plus_one. eapply exec_step_internal_call. + rewrite <- H2; simpl; eauto. + eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; eauto. + simpl; eauto. + Simpl; eauto. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. + rewrite <- (comp_transl_partial _ H4). + eapply allowed_call_translated; eauto. + simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + unfold update_stack_call. Simpl. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. simpl. + unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + rewrite <- H2. simpl. rewrite Heq. + reflexivity. + eauto. + { simpl. + intros. + rewrite <- (comp_transl_partial _ H4) in H5. + rewrite <- (comp_transl_partial _ TTRANSF) in H5. + specialize (NO_CROSS_PTR H5). + now eapply Val.lessdef_list_not_ptr; eauto. } + { simpl. rewrite <- comp_transf_function; eauto. + rewrite <- (comp_transl_partial _ TTRANSF). + eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } + (* replace (comp_of f) *) + (* with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) + rewrite comp_transf_function; eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + (* { rewrite find_comp_translated. unfold tge. *) + (* unfold Genv.find_comp_in_genv. simpl. *) + (* exploit functions_transl; eauto. intros G. *) + (* rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ G). *) + (* rewrite comp_transf_function; simpl; eauto. } *) + (* TODO: clean *) + { eapply match_stacks_cross_compartment. exact STACKS'. + - unfold Mach.call_comp. simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). + - simpl. + rewrite <- find_comp_of_block_translated. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). + (* - rewrite (comp_transl_partial _ TTRANSF). *) + (* rewrite (comp_transl_partial _ H4). *) + (* intros contra. now rewrite contra, Pos.eqb_refl in Heq. *) + - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). + simpl. + rewrite comp_transf_function; eauto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + + monadInv TTRANSF. simpl in *. + rewrite comp_transf_function; eauto. + + inv TTRANSF. simpl in *. auto. + - erewrite agree_sp; eauto. + constructor. + } + simpl. eapply agree_exten; eauto. intros. Simpl. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. simpl. + Simpl. rewrite <- H2. auto. + (* simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). *) - (* Mtailcall *) assert (f0 = f) by congruence. subst f0. @@ -1075,6 +1295,8 @@ Local Transparent destroyed_by_op. left; econstructor; split. (* execution *) eapply plus_right'. eapply exec_straight_exec; eauto. + now rewrite <- H4; simpl; erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. + rewrite comp_transf_function; eauto. econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. reflexivity. simpl. reflexivity. eauto. eauto. @@ -1084,6 +1306,7 @@ Local Transparent destroyed_by_op. now rewrite <- find_comp_of_block_translated, NEXTCOMP. traceEq. (* match states *) + rewrite comp_transf_function; eauto. econstructor; eauto. apply agree_set_other; auto with asmgen. Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. @@ -1094,7 +1317,10 @@ Local Transparent destroyed_by_op. intros (ofs' & P & Q). left; econstructor; split. (* execution *) + rewrite comp_transf_function; eauto. eapply plus_right'. eapply exec_straight_exec; eauto. + rewrite <- comp_transf_function; eauto. + now rewrite <- H4; simpl; erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. reflexivity. simpl. reflexivity. eauto. eauto. @@ -1104,6 +1330,7 @@ Local Transparent destroyed_by_op. simpl. now rewrite <- find_comp_of_block_translated. traceEq. (* match states *) + rewrite comp_transf_function; eauto. econstructor; eauto. apply agree_set_other; auto with asmgen. apply agree_set_other; auto with asmgen. @@ -1117,14 +1344,18 @@ Local Transparent destroyed_by_op. exploit external_call_mem_extends; eauto. intros [vres' [m2' [A [B [C D]]]]]. left. econstructor; split. apply plus_one. + rewrite comp_transf_function; eauto. eapply exec_step_builtin. eauto. eauto. eapply find_instr_tail; eauto. erewrite <- sp_val by eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. rewrite <- (comp_transl_partial _ H3). - unfold_find_comp CURCOMP FIND. rewrite <- CURCOMP. reflexivity. + erewrite Genv.find_funct_ptr_find_comp_of_block in A; eauto. simpl in A. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + (* rewrite <- (comp_transl_partial _ H3). *) + (* unfold_find_comp_in_genv CURCOMP FIND. rewrite <- CURCOMP. reflexivity. *) eauto. + rewrite <- comp_transf_function; eauto. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). unfold nextinstr. rewrite Pregmap.gss. @@ -1144,11 +1375,12 @@ Local Transparent destroyed_by_op. inv AT. monadInv H4. exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. exploit functions_transl; eauto. intro FN. - left. inversion AT2; subst. exists (State s' rs' m'); split. + left. inversion AT2; subst. + exists (State s' rs' m' (comp_of f)); split. + rewrite comp_transf_function; eauto. apply plus_one. econstructor; eauto. eapply find_instr_tail; eauto. simpl; eauto. eauto. eauto. - simpl; unfold Genv.find_comp; simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FN). econstructor; eauto. eapply agree_exten; eauto with asmgen. @@ -1195,13 +1427,14 @@ Local Transparent destroyed_by_op. simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. eauto. eauto. eauto. simpl. - simpl; unfold Genv.find_comp; simpl. + (* simpl; unfold Genv.find_comp; simpl. *) now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FN). assert (exists ofs, rs' PC = Vptr fb ofs) as [ofs' Hptr]. { destruct (rs' PC); inversion B. eauto. } + rewrite <- comp_transf_function; eauto. econstructor; eauto. eapply agree_undef_regs; eauto. simpl. intros. rewrite C; auto with asmgen. Simpl. @@ -1220,6 +1453,7 @@ Local Transparent destroyed_by_op. left; econstructor; split. eapply plus_star_trans. eapply exec_straight_exec; eauto. + now rewrite <- H3; simpl; erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. eapply star_step. eapply exec_step_internal_return; eauto. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. simpl. reflexivity. eauto. @@ -1277,7 +1511,8 @@ Local Transparent destroyed_by_op. left; eexists; split. eapply exec_straight_steps_1; eauto. lia. simpl. constructor. econstructor; eauto. - unfold_find_comp STACKS_COMP H. now subst cp. + erewrite Genv.find_funct_ptr_find_comp_of_block in STACKS'; eauto. now simpl in STACKS'. + (* unfold_find_comp_in_genv STACKS_COMP H. now subst cp. *) rewrite X; econstructor; eauto. apply agree_exten with rs2; eauto with asmgen. unfold rs2. @@ -1305,9 +1540,10 @@ Local Transparent destroyed_at_function_entry. left; econstructor; split. apply plus_one. eapply exec_step_external; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. - unfold_find_comp STACKS_COMP H. subst cp. + (* unfold_find_comp_in_genv STACKS_COMP H. subst cp. *) econstructor; eauto. - Simpl. rewrite ATLR. eauto. + erewrite Genv.find_funct_ptr_find_comp_of_block in STACKS'; eauto. simpl in STACKS'. auto. + (* Simpl. rewrite ATLR. eauto. *) eapply agree_set_other; eauto. eapply agree_set_pair; eauto. eapply agree_undef_caller_save_regs; eauto. @@ -1319,25 +1555,25 @@ Local Transparent destroyed_at_function_entry. rewrite <- find_comp_of_block_translated. rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). change (comp_of (Internal f0)) with (comp_of f0). - destruct (cp =? comp_of f0)%positive eqn:e. - - apply Pos.eqb_eq in e. subst cp. + destruct (cp_eq_dec cp (comp_of f0)) eqn:e. + - subst cp. + (* apply Pos.eqb_eq in e. subst cp. *) eexists; split; auto. inv STACKS'; auto. unfold Mach.call_comp in *; simpl in *. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in H2. - change (comp_of (Internal f0)) with (comp_of f0) in *. - congruence. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in H4. + simpl in *. + inv H10. + rewrite find_comp_of_block_translated in H5. congruence. - inv STACKS'; auto. + unfold Mach.call_comp in *. simpl in *. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in H4. - injection H4 as E. subst cp. - now rewrite Pos.eqb_refl in e. + clear e. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in n. simpl in n. + congruence. + unfold Mach.call_comp in *. simpl in *. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in H2. - injection H2 as E. subst cp'0. eauto. - } + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in H1. eauto. } - left. eexists (State s'' rs0 m'). split. + left. eexists (State s'' rs0 m' (comp_of f0)). split. assert (LD: Val.lessdef (Mach.return_value rs sg) (return_value rs0 sg)). { unfold Mach.return_value, return_value. destruct (loc_result sg). @@ -1349,40 +1585,35 @@ Local Transparent destroyed_at_function_entry. econstructor; eauto. rewrite ATPC. unfold Vnullptr. now destruct Archi.ptr64. { rewrite ATPC. simpl. rewrite <- find_comp_of_block_translated. - eauto. } + now erewrite (Genv.find_funct_ptr_find_comp_of_block); eauto. } { rewrite ATPC. simpl. intros diff. inv STACKS'; auto. - - simpl in *. subst. unfold Mach.call_comp in *. simpl in *. congruence. + - simpl in diff. erewrite Genv.find_funct_ptr_find_comp_of_block in diff; eauto. now simpl in diff. - inv H10. reflexivity. } { intros diff. inv STACKS'; auto. - - simpl in *. subst. unfold Mach.call_comp in *. simpl in *. - congruence. + - simpl in diff. erewrite Genv.find_funct_ptr_find_comp_of_block in diff; eauto. now simpl in diff. - inv H10. eapply agree_sp; eauto. } { intros TYPE. inv STACKS'; auto. - - simpl in *. subst. unfold Mach.call_comp in *. simpl in *. - assert (cp' = cp) by congruence. subst cp'. - now eapply Genv.type_of_call_same_cp in TYPE. - - simpl in *. subst. unfold Mach.call_comp in *. simpl in *. - inv H10. + - simpl in *. erewrite Genv.find_funct_ptr_find_comp_of_block in TYPE; eauto. simpl in TYPE. + pose proof (flowsto_refl (comp_of f0)); now destruct (flowsto_dec (comp_of f0) (comp_of f0)). + - simpl in *. erewrite Genv.find_funct_ptr_find_comp_of_block in NO_CROSS_PTR; eauto. simpl in *. specialize (NO_CROSS_PTR TYPE). + inv H10. (* TODO: factorize into a lemma Val.lessdef_not_ptr *) inv LD; auto. now rewrite <- H0 in NO_CROSS_PTR. } { inv STACKS'; auto. - - simpl in *. subst. unfold Mach.call_comp in *. simpl in *. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in H4. - change (comp_of (Internal f0)) with (comp_of f0) in *. - injection H4 as <-. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in CURCOMP. - injection CURCOMP as <-. + - simpl in *. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in *. simpl in *. assert (t = E0). - { inv EV; auto. - exfalso. eapply Genv.type_of_call_same_cp. eauto. } - subst. constructor. now apply Genv.type_of_call_same_cp. - - simpl in *. unfold Mach.call_comp in *. simpl in *. - inv H10. + { inv EV; auto. rewrite Genv.type_of_call_same_cp in H; now auto. } + subst. + constructor. + rewrite Genv.type_of_call_same_cp; now auto. + - simpl in *. inv H10. + erewrite Genv.find_funct_ptr_find_comp_of_block in EV; eauto. eapply return_trace_lessdef with (ge := ge) (v := Mach.return_value rs sg); eauto using senv_preserved. } diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 84d617112f..afce8c47a9 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -1205,7 +1205,7 @@ Lemma indexed_load_priv_access_correct: exec_load ge chunk rs m rd base ofs (comp_of fn) true) -> (forall base ofs, sig_call (mk_instr base ofs) = None /\ is_return (mk_instr base ofs) = false) -> forall (base: ireg) ofs k (rs: regset) v, - Mem.loadv chunk m (Val.offset_ptr rs#base ofs) None = Some v -> + Mem.loadv chunk m (Val.offset_ptr rs#base ofs) top = Some v -> base <> X31 -> rd <> PC -> exists rs', exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m @@ -1229,7 +1229,7 @@ Lemma indexed_load_access_correct: exec_instr ge fn (mk_instr base ofs) rs m (comp_of fn) = exec_load ge chunk rs m rd base ofs (comp_of fn) b) -> (forall base ofs, sig_call (mk_instr base ofs) = None /\ is_return (mk_instr base ofs) = false) -> forall (base: ireg) ofs k (rs: regset) v, - Mem.loadv chunk m (Val.offset_ptr rs#base ofs) (Some (comp_of fn)) = Some v -> + Mem.loadv chunk m (Val.offset_ptr rs#base ofs) (comp_of fn) = Some v -> base <> X31 -> rd <> PC -> exists rs', exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m @@ -1242,7 +1242,7 @@ Proof. econstructor; split. eapply exec_straight_opt_right. eexact A. eapply exec_straight_one. rewrite EXEC. unfold exec_load. - assert (LOAD': Mem.loadv chunk m (Val.offset_ptr (rs base) ofs) None = Some v). + assert (LOAD': Mem.loadv chunk m (Val.offset_ptr (rs base) ofs) top = Some v). { destruct (Val.offset_ptr (rs base) ofs); try discriminate; simpl in *; eapply Mem.load_Some_None; eauto. } destruct b; rewrite B; [rewrite LOAD' | rewrite LOAD]; eauto. @@ -1275,7 +1275,7 @@ Qed. Lemma loadind_priv_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v, loadind base ofs ty dst k true = OK c -> - Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) None = Some v -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) top = Some v -> base <> X31 -> exists rs', exec_straight ge fn c rs m k rs' m @@ -1298,7 +1298,7 @@ Qed. Lemma loadind_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v b, loadind base ofs ty dst k b = OK c -> - Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) (Some (comp_of fn)) = Some v -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) (comp_of fn) = Some v -> base <> X31 -> exists rs', exec_straight ge fn c rs m k rs' m @@ -1342,7 +1342,7 @@ Qed. Lemma loadind_priv_ptr_correct: forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, - Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) None = Some v -> + Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) top = Some v -> base <> X31 -> exists rs', exec_straight ge fn (loadind_ptr base ofs dst k true) rs m k rs' m @@ -1356,7 +1356,7 @@ Qed. Lemma loadind_ptr_correct: forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v b, - Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) (Some (comp_of fn)) = Some v -> + Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) (comp_of fn) = Some v -> base <> X31 -> exists rs', exec_straight ge fn (loadind_ptr base ofs dst k b) rs m k rs' m @@ -1409,7 +1409,7 @@ Lemma transl_load_access_correct: (forall base ofs, sig_call (mk_instr base ofs) = None /\ is_return (mk_instr base ofs) = false) -> transl_memory_access mk_instr addr args k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - Mem.loadv chunk m v (Some (comp_of fn)) = Some v' -> + Mem.loadv chunk m v (comp_of fn) = Some v' -> rd <> PC -> exists rs', exec_straight ge fn c rs m k rs' m @@ -1451,7 +1451,7 @@ Lemma transl_load_correct: forall chunk addr args dst k c (rs: regset) m a v, transl_load chunk addr args dst k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a (Some (comp_of fn)) = Some v -> + Mem.loadv chunk m a (comp_of fn) = Some v -> exists rs', exec_straight ge fn c rs m k rs' m /\ rs'#(preg_of dst) = v @@ -1498,8 +1498,8 @@ Qed. Lemma make_epilogue_correct: forall ge0 f m stk soff cs m' ms rs k tm, - load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) (Some (comp_of f)) = Some (parent_sp cs) -> - load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) (Some (comp_of f)) = Some (parent_ra cs) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) (comp_of f) = Some (parent_sp cs) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) (comp_of f) = Some (parent_ra cs) -> Mem.free m stk 0 f.(fn_stacksize) (comp_of f) = Some m' -> agree ms (Vptr stk soff) rs -> Mem.extends m tm -> diff --git a/riscV/TargetPrinter.ml b/riscV/TargetPrinter.ml index 860860552c..55c8825e11 100644 --- a/riscV/TargetPrinter.ml +++ b/riscV/TargetPrinter.ml @@ -556,7 +556,7 @@ module Target : TARGET = fprintf oc " nop\n" | Pbuiltin(ef, args, res) -> begin match ef with - | EF_annot(_cp, kind,txt, targs) -> + | EF_annot(kind,txt, targs) -> begin match (P.to_int kind) with | 1 -> let annot = annot_text preg_annot "x2" (camlstring_of_coqstring txt) args in fprintf oc "%s annotation: %S\n" comment annot @@ -565,10 +565,10 @@ module Target : TARGET = add_ais_annot lbl preg_annot "x2" (camlstring_of_coqstring txt) args | _ -> assert false end - | EF_debug(_cp, kind, txt, targs) -> + | EF_debug(kind, txt, targs) -> print_debug_info comment print_file_line preg_annot "sp" oc (P.to_int kind) (extern_atom txt) args - | EF_inline_asm(_cp, txt, sg, clob) -> + | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment From e28fdea750f61fba659d810b085ca51710386f3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 4 Dec 2023 13:07:17 +0000 Subject: [PATCH 18/83] [Compartments] Little fixes --- Makefile | 2 +- security/Split.v | 3 --- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 723505d0b8..83375b38a4 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 +SECURITY= Split.v # Blame.v # Parser diff --git a/security/Split.v b/security/Split.v index 4a7698c1ac..3b70a173ff 100644 --- a/security/Split.v +++ b/security/Split.v @@ -1,5 +1,4 @@ Require Import String. -Require Import Coqlib Maps Errors. Require Import AST. Require Import Values. @@ -28,5 +27,3 @@ Class has_side {ctx: Type} (A: Type) := { in_side s := fun a δ => s (comp_of a) = δ }. Notation "s '|=' a '∈' δ " := (in_side s a δ) (no associativity, at level 75). - - From 24d938f627926c27ed116ebcbd18846be9c3db67 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Wed, 6 Dec 2023 12:54:40 +0000 Subject: [PATCH 19/83] [Compartments] Integrate a functional, not-verified version of the back-translation after removal of compartments --- Makefile | 2 +- security/Backtranslation.v | 786 +++++++--- security/BacktranslationAux.v | 2022 +++++++++++++++++++++++++ security/BacktranslationProof.v | 2229 +++++++++++++++++++++++++++ security/BacktranslationProof2.v | 1454 ++++++++++++++++++ security/Blame.v | 1697 +++------------------ security/BtBasics.v | 260 ++++ security/BtInfoAsm.v | 2416 ++++++++++++++++++++++++++++++ security/BtInfoAsmBound.v | 82 + security/MemoryDelta.v | 1165 ++++++++++++++ security/MemoryWeak.v | 1768 ++++++++++++++++++++++ security/Recomposition.v | 247 ++- security/Split.v | 3 + security/Tactics.v | 959 ++++++++++++ 14 files changed, 13292 insertions(+), 1798 deletions(-) create mode 100644 security/BacktranslationAux.v create mode 100644 security/BacktranslationProof.v create mode 100644 security/BacktranslationProof2.v create mode 100644 security/BtBasics.v create mode 100644 security/BtInfoAsm.v create mode 100644 security/BtInfoAsmBound.v create mode 100644 security/MemoryDelta.v create mode 100644 security/MemoryWeak.v create mode 100644 security/Tactics.v diff --git a/Makefile b/Makefile index 83375b38a4..95c37275a3 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= Split.v # Blame.v +SECURITY= Split.v Tactics.v MemoryWeak.v MemoryDelta.v BtBasics.v BtInfoAsm.v BtInfoAsmBound.v Backtranslation.v BacktranslationAux.v BacktranslationProof.v # Parser diff --git a/security/Backtranslation.v b/security/Backtranslation.v index f87495e928..b7328b95c5 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -4,216 +4,636 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. +Require Import Tactics. +Require Import riscV.Asm. +Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. Require Import Ctypes Clight. -Record backtranslation_environment := - { local_counter: compartment -> ident }. -Section Backtranslation. - Variable bt_env: backtranslation_environment. +Ltac simpl_expr := + repeat (match goal with + | |- eval_expr _ _ _ _ _ _ _ => econstructor + | |- eval_lvalue _ _ _ _ _ _ _ _ _ => econstructor 2 + (* | |- eval_lvalue _ _ _ _ _ _ _ _ _ => econstructor *) + | |- deref_loc _ _ _ _ _ _ _ => econstructor + | |- assign_loc _ _ _ _ _ _ _ _ _ => econstructor + | |- Cop.sem_cmp _ _ _ _ _ _ = Some _ => unfold Cop.sem_cmp + | |- Cop.sem_add _ _ _ _ _ _ = Some _ => unfold Cop.sem_add + | |- Cop.sem_binarith _ _ _ _ _ _ _ _ _ = Some _ => unfold Cop.sem_binarith + | |- match Cop.sem_cast _ ?x ?x _ with | _ => _ end = Some _ => rewrite Cop.cast_val_casted + | |- Cop.sem_cast _ ?y ?y _ = Some _ => rewrite Cop.cast_val_casted + | |- Cop.val_casted _ _ => constructor + | H: ?x = _ |- Cop.bool_val (_ ?x) _ _ = Some _ => rewrite H; try reflexivity + end; simpl; eauto). - Definition ptr_of_id_ofs (id: ident) (ofs: ptrofs): expr := - Ebinop Cop.Oadd - (Eaddrof (Evar id Tvoid) (Tpointer Tvoid noattr)) - (Econst_int (Ptrofs.to_int ofs) (Tint I32 Signed noattr)) - (Tpointer Tvoid noattr). +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))) -> *) + (* 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 Tvoid (list_eventval_to_typelist vs') - end. (* TODO: currently this is just a list of Tvoid of the right size. Fix? *) + | 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 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. + (* Lemma typeof_eventval_to_expr_type *) + (* v *) + (* : *) + (* typeof (eventval_to_expr v) = eventval_to_type v. *) + (* Proof. destruct v; simpl; auto. apply ptr_of_id_ofs_typeof. Qed. *) + + (* Definition wf_eventval_pub (v: eventval): Prop := *) + (* match v with *) + (* | EVptr_global id _ => (Senv.public_symbol ge id = true) *) + (* | _ => True *) + (* end. *) + +End CONV. + + +Section CODEAUX. + + (* We extract function data: argument types, fn_return, rn_callconv from signature *) + (* Correctness should follow from eventval_match *) + Definition typ_to_type: typ -> type := + fun t: typ => + match t with + | AST.Tint => Tint I32 Signed noattr + | AST.Tfloat => Tfloat F64 noattr + | AST.Tlong => Tlong Signed noattr + | AST.Tsingle => Tfloat F32 noattr + (* do not appear in eventval_match *) + | AST.Tany32 => Tint I32 Signed noattr + | AST.Tany64 => Tlong Signed noattr + end. + + Fixpoint list_typ_to_typelist (ts: list typ): typelist := + match ts with + | nil => Tnil + | cons t ts' => Tcons (typ_to_type t) (list_typ_to_typelist ts') + end. + + Definition rettype_to_type: rettype -> type := + fun rt: rettype => + match rt with + | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => Tint I32 Signed noattr + | AST.Tvoid => Tint I32 Signed noattr + | Tret t => typ_to_type t + end. + + (* Lemma proj_rettype_to_type_rettype_of_type_eq *) + (* ge evres rt res *) + (* (EVM: eventval_match ge evres (proj_rettype rt) res) *) + (* : *) + (* proj_rettype (rettype_of_type (rettype_to_type rt)) = proj_rettype rt. *) + (* Proof. *) + (* inv EVM; destruct rt; simpl; auto. *) + (* destruct t; simpl in *; auto; try congruence. *) + (* destruct t; simpl in *; auto; try congruence. *) + (* destruct t; simpl in *; auto; try congruence. *) + (* destruct t; simpl in *; auto; try congruence. *) + (* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. *) + (* destruct t; simpl in *; auto; try congruence. *) + (* destruct t; simpl in *; auto; try congruence. *) + (* Qed. *) + + (* Wanted internal function data from signature *) + Record fun_data : Type := mkfundata { dargs: typelist; dret: type; dcc: calling_convention }. + Definition funs_data : Type := (PTree.tree fun_data). + + Definition from_sig_fun_data (sig: signature): fun_data := + mkfundata (list_typ_to_typelist sig.(sig_args)) (rettype_to_type sig.(sig_res)) (sig.(sig_cc)). + + (* Extract from Asm *) + Definition from_asmfun_fun_data (af: Asm.function): fun_data := from_sig_fun_data af.(fn_sig). + Definition from_extfun_fun_data (ef: external_function): fun_data := from_sig_fun_data (ef_sig ef). + Definition from_asmfd_fun_data (fd: Asm.fundef): fun_data := + match fd with | AST.Internal af => from_asmfun_fun_data af | AST.External ef => from_extfun_fun_data ef end. + Definition from_asmgd_fun_data (gd: globdef Asm.fundef unit): option fun_data := + match gd with | Gfun fd => Some (from_asmfd_fun_data fd) | Gvar _ => None end. + + Definition from_asm_funs_data (asm: Asm.program): funs_data := + let defs := Genv.genv_defs (Genv.globalenv asm) in + PTree.map_filter1 from_asmgd_fun_data defs. + + (* Extract from Clight *) + Definition from_clfun_fun_data (cf: Clight.function): fun_data := mkfundata (type_of_params cf.(fn_params)) cf.(fn_return) cf.(fn_callconv). + Definition from_clfd_fun_data (fd: Clight.fundef): fun_data := + match fd with | Ctypes.Internal cf => from_clfun_fun_data cf | Ctypes.External ef _ _ _ => from_extfun_fun_data ef end. + Definition from_clgd_fun_data (gd: globdef Clight.fundef type): option fun_data := + match gd with | Gfun fd => Some (from_clfd_fun_data fd) | Gvar _ => None end. + + Definition from_cl_funs_data (cl: Clight.program): funs_data := + let defs := Genv.genv_defs (genv_genv (globalenv cl)) in + PTree.map_filter1 from_clgd_fun_data defs. + +End CODEAUX. + + +Section CONV. + + Variable ge: Senv.t. + + (* Type: Tvoid has size 1, which is what we want *) + Definition expr_of_addr (id: ident) (ofs: ptrofs): expr := + ptr_of_id_ofs id ofs. + + Definition chunk_to_type (ch: memory_chunk): option type := + match ch with + | Mint8signed => Some (Tint I8 Signed noattr) + | Mint8unsigned => Some (Tint I8 Unsigned noattr) + | Mint16signed => Some (Tint I16 Signed noattr) + | Mint16unsigned => Some (Tint I16 Unsigned noattr) + | Mint32 => Some (Tint I32 Signed noattr) + | Mint64 => Some (Tlong Signed noattr) + | Mfloat32 => Some (Tfloat F32 noattr) + | Mfloat64 => Some (Tfloat F64 noattr) + | Many32 => None + | Many64 => None + end. + + (* Lemma access_mode_chunk_to_type_wf *) + (* ch ty *) + (* (CT: chunk_to_type ch = Some ty) *) + (* : *) + (* access_mode ty = By_value ch. *) + (* Proof. destruct ch; inv CT; ss. Qed. *) + + Definition chunk_val_to_expr (ch: memory_chunk) (v: val) : option expr := + match chunk_to_type ch with + | Some ty => + match v with + | Vint i => Some (Econst_int i ty) + | Vlong i => Some (Econst_long i ty) + | Vfloat f => Some (Econst_float f ty) + | Vsingle f => Some (Econst_single f ty) + | Vptr b ofs => + match Senv.invert_symbol ge b with + | Some id => Some (ptr_of_id_ofs id ofs) + | None => None + end + | Vundef => None + end + | None => None + end. + +End CONV. + + +Section CODE. + (** converting *informative* trace to code **) + + Variable ge: Senv.t. + + Definition code_mem_delta_storev cp0 (d: mem_delta_storev): statement := + let '(ch, ptr, v, cp) := d in + match ptr with + | Vptr b ofs => + match Senv.invert_symbol ge b with + | Some id => + match chunk_to_type ch, chunk_val_to_expr ge ch v with + | Some ty, Some ve => + if ((Senv.public_symbol ge id) && (flowsto_dec cp cp0)) (* TODO: check direction *) + then Sassign (Ederef (expr_of_addr id ofs) ty) ve + else Sskip + | _, _ => Sskip + end + | None => Sskip + end + | _ => Sskip + end. - 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_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_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_mem_delta cp (d: mem_delta) (snext: statement): statement := + fold_right Ssequence snext (map (code_mem_delta_kind cp) d). - 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_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_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_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) := - Sreturn (Some (eventval_to_expr v)). + 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_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 + 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 type_counter: type := Tint I32 Unsigned noattr. - Definition type_bool: type := Tint IBool Signed noattr. + Definition one_expr: expr := Econst_int Int.one (Tint I32 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 - Sifthenelse (Ebinop Cop.Oeq - (Evar (bt_env.(local_counter) cp) type_counter) - (Econst_int (Int.repr n) (Tint I32 Unsigned noattr)) 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. + Definition switch_bundle_events cnt cp (tr: bundle_trace) := + switch cnt (map (fun ib => code_bundle_event cp (snd ib)) tr) (Sreturn None). - Ltac simpl_expr := - unfold type_counter; unfold type_bool; simpl; - repeat (match goal with - | |- eval_expr _ _ _ _ _ _ _ => econstructor - | |- eval_lvalue _ _ _ _ _ _ _ _ _ => econstructor - | |- deref_loc _ _ _ _ _ _ _ => econstructor - | |- assign_loc _ _ _ _ _ _ _ _ _ => econstructor - | |- Cop.sem_cmp _ _ _ _ _ _ = Some _ => unfold Cop.sem_cmp - | |- Cop.sem_add _ _ _ _ _ _ = Some _ => unfold Cop.sem_add - | |- Cop.sem_binarith _ _ _ _ _ _ _ _ _ = Some _ => unfold Cop.sem_binarith - | |- match Cop.sem_cast _ ?x ?x _ with | _ => _ end = Some _ => rewrite Cop.cast_val_casted - | |- Cop.sem_cast _ ?y ?y _ = Some _ => rewrite Cop.cast_val_casted - | |- Cop.val_casted _ _ => constructor - | H: ?x = _ |- Cop.bool_val (_ ?x) _ _ = Some _ => rewrite H; try reflexivity - end; simpl; eauto). - - Ltac take_step := econstructor; [econstructor; simpl_expr | | traceEq]; simpl. - - Lemma switch_clause_spec p (cp: compartment) f (e: env) le m b (n: int) (n': Z) s_then s_else: - cp = comp_of f -> - e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> - Mem.valid_access m Mint32 b 0 Writable (Some cp) -> - Mem.loadv Mint32 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vint n) -> - if Int.eq n (Int.repr n') then - 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') - else - Star (Clight.semantics1 p) (State f (switch_clause cp n' s_then s_else) Kstop e le m) E0 (State f s_else Kstop e le m). - Proof. - intros; subst cp. - destruct (Int.eq n (Int.repr n')) eqn:eq_n_n'. - - simpl. - destruct (Mem.valid_access_store m Mint32 b 0%Z (comp_of f) (Vint (Int.add n Int.one))) as [m' m_m']; try assumption. - exists m'. split; eauto. - do 4 take_step. - now apply star_refl. - - (* take_steps. *) - take_step. rewrite Int.eq_true; simpl. - now apply star_refl. - Qed. - - Definition switch_add_statement cp s res := - (Z.pred (fst res), switch_clause cp (Z.pred (fst res)) s (snd res)). - - Definition switch (cp: compartment) (ss: list statement) (s_else: statement): statement := - snd (fold_right (switch_add_statement cp) (Z.of_nat (length ss), s_else) ss). - - Lemma fst_switch (cp: compartment) n (s_else: statement) (ss : list statement) : - fst (fold_right (switch_add_statement cp) (n, s_else) ss) = (n - Z.of_nat (length ss))%Z. - Proof. - induction ss as [|s' ss IH]; try now rewrite Z.sub_0_r. - simpl; lia. - Qed. - - Lemma switch_spec_else p (cp: compartment) f Kstop (e: env) le m b (n: Z) ss s_else: - n >= 0 -> - cp = comp_of f -> - e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> - Mem.valid_access m Mint32 b 0 Writable (Some cp) -> - Mem.loadv Mint32 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vint (Int.repr n)) -> - (Z.of_nat (length ss) <= n)%Z -> - Star (Clight.semantics1 p) - (State f (switch cp ss s_else) Kstop e le m) - E0 - (State f s_else Kstop e le m). - Proof. - intros; subst cp. unfold switch. - assert (G: forall n', - 0 <= n' -> - n' <= n -> - Z.of_nat (length ss) <= n -> - Star (Clight.semantics1 p) - (State f (snd (fold_right (switch_add_statement (comp_of f)) (n', s_else) ss)) Kstop e le m) - E0 - (State f s_else Kstop e le m)). - { clear H4. - intros n' zero_le_n' n'_le_n' ss_le_n. - induction ss as [|s ss IH]; try apply star_refl. - simpl. simpl in ss_le_n. rewrite fst_switch, <- Z.sub_succ_r. - take_step. - { rewrite Int.eq_false. reflexivity. - 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. } - rewrite Int.eq_true; simpl. - eapply IH. lia. } - now apply G; lia. - Admitted. - - - 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 -> Csyntax.program * Csyntax.program. *) - (* Axiom backtranslation_correct: *) - (* forall pol s t p C, *) - (* backtranslation pol s t = (p, C) -> *) - (* c_compatible s p C /\ *) - (* exists W, link p C = Some W /\ *) - (* c_program_has_initial_trace W t. *) - - (* 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. *) - - (* 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. *) + (* 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 top [] false false. + + Definition gen_globdef ge cnt params tr (a_gd: globdef Asm.fundef unit): globdef Clight.fundef type := + match a_gd with + | Gfun a_fd => Gfun (gen_fundef ge cnt params tr a_fd) + | Gvar a_gv => Gvar (gen_globvar a_gv) + end. + + Definition gen_counter cp: globdef Clight.fundef type := + Gvar (mkglobvar type_counter cp [(Init_int64 Int64.zero)] false false). + + (* Generate the max + 1 of the keys *) + Definition next_id {A} (l: list (ident * A)): ident := + Pos.succ (fold_left (fun x '(i, _) => if (x (id, (Pos.add id m, gen_counter (comp_of gd)))) gds in + PTree_Properties.of_list gds'. + + Definition params_of := PTree.t (list (ident * type)). + + Fixpoint numbering {A} (i: ident) (l: list A): list (ident * A) := + match l with + | [] => [] + | hd :: tl => (i, hd) :: (numbering (Pos.succ i) tl) + end. + + Definition funsig (fd: Asm.fundef) := + match fd with + | AST.Internal f => fn_sig f + | AST.External ef => ef_sig ef + end. + + Definition gen_params_one (m: ident) (gd: globdef Asm.fundef unit): option (list (ident * type)) := + match gd with + | Gvar _ => None + | Gfun fd => + let types := map typ_to_type (sig_args (funsig fd)) in + Some (numbering m types) + end. + + (* Generate fresh parameter ids for each function --- parameter ids for different functions are allowed to be duplicated *) + Definition gen_params (m: ident) (gds: list (ident * globdef Asm.fundef unit)): params_of := + let params' := map (fun '(id, gd) => match gen_params_one m gd with + | Some ps => (id, ps) + | None => (id, []) + end) gds + in + PTree_Properties.of_list params'. + + + Definition gen_progdef (ge: Senv.t) (tr: bundle_trace) a_gd (ocnt: option (ident * globdef Clight.fundef type)) (oparams: option (list (ident * type))): globdef Clight.fundef type := + match ocnt, oparams with + | Some (cnt, _), Some params => gen_globdef ge cnt params tr a_gd + | _, _ => Gvar default_globvar + end. + + Definition get_id_tr (tr: bundle_trace) (id0: ident): bundle_trace := filter (fun '(id, _) => Pos.eqb id0 id) tr. + + Definition gen_prog_defs (a_ge: Senv.t) tr (gds: list (ident * globdef Asm.fundef unit)): list (ident * globdef Clight.fundef type) := + let m0 := next_id gds in + let cnts := gen_counter_defs m0 gds in + let cnt_defs := map snd (PTree.elements cnts) in + let m1 := next_id cnt_defs in + let params := gen_params m1 gds in + (map (fun '(id, gd) => (id, gen_progdef a_ge (get_id_tr tr id) gd (cnts ! id) (params ! id))) gds) ++ cnt_defs. + + Program Definition gen_program tr (a_p: Asm.program): Clight.program := + let a_ge := Genv.globalenv a_p in + @Build_program _ + (gen_prog_defs a_ge tr a_p.(AST.prog_defs)) + (AST.prog_public a_p) + (AST.prog_main a_p) + (AST.prog_pol a_p) + [] + (@PTree.empty composite) + _ + _. + Next Obligation. + Admitted. + +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 new file mode 100644 index 0000000000..c61fccd59b --- /dev/null +++ b/security/BacktranslationAux.v @@ -0,0 +1,2022 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Require Import Tactics. +Require Import riscV.Asm. +Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. +Require Import Ctypes Clight. +Require Import Backtranslation. + + + +(* Section CODEPROOFS. *) + +(* Lemma ptr_of_id_ofs_eval *) +(* (ge: genv) id ofs e b cp le m *) +(* (GE1: wf_env ge e) *) +(* (GE2: Senv.find_symbol ge id = Some b) *) +(* : *) +(* eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). *) +(* Proof. *) +(* specialize (GE1 id). rewrite GE2 in GE1. *) +(* unfold ptr_of_id_ofs. destruct (Archi.ptr64) eqn:ARCH. *) +(* - eapply eval_Ebinop. eapply eval_Eaddrof. eapply eval_Evar_global; eauto. *) +(* simpl_expr. *) +(* simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. *) +(* rewrite Ptrofs.of_int64_to_int64; auto. *) +(* - eapply eval_Ebinop. eapply eval_Eaddrof. eapply eval_Evar_global; eauto. *) +(* simpl_expr. *) +(* simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. *) +(* erewrite Ptrofs.agree32_of_ints_eq; auto. apply Ptrofs.agree32_to_int; auto. *) +(* Qed. *) + +(* Lemma code_mem_delta_cons *) +(* (ge: Senv.t) cp k d sn *) +(* : *) +(* code_mem_delta ge cp (k :: d) sn = *) +(* Ssequence (code_mem_delta_kind ge cp k) (code_mem_delta ge cp d sn). *) +(* Proof. unfold code_mem_delta. ss. Qed. *) + +(* Lemma code_mem_delta_app *) +(* (ge: Senv.t) cp d1 d2 sn *) +(* : *) +(* code_mem_delta ge cp (d1 ++ d2) sn = (code_mem_delta ge cp d1 (code_mem_delta ge cp d2 sn)). *) +(* Proof. *) +(* revert sn d2. induction d1; intros; ss. *) +(* rewrite ! code_mem_delta_cons. erewrite IHd1. auto. *) +(* Qed. *) + +(* Lemma type_of_chunk_val_to_expr *) +(* (ge: Senv.t) ch ty v e *) +(* (WF: wf_chunk_val_b ch v) *) +(* (CT: chunk_to_type ch = Some ty) *) +(* (CVE: chunk_val_to_expr ge ch v = Some e) *) +(* : *) +(* typeof e = ty. *) +(* Proof. unfold chunk_val_to_expr in CVE. rewrite CT in CVE. des_ifs. Qed. *) + +(* Definition val_is_int (v: val) := (match v with | Vint _ => True | _ => False end). *) +(* Definition val_is_not_int (v: val) := (match v with | Vint _ => False | _ => True end). *) + +(* Lemma val_cases v: (val_is_int v) \/ (val_is_not_int v). *) +(* Proof. destruct v; ss; auto. Qed. *) + +(* Lemma sem_cast_chunk_val *) +(* (ge: Senv.t) m ch ty v e *) +(* (WF: wf_chunk_val_b ch v) *) +(* (CT: chunk_to_type ch = Some ty) *) +(* (CVE: chunk_val_to_expr ge ch v = Some e) *) +(* (NINT: val_is_not_int v) *) +(* : *) +(* Cop.sem_cast v (typeof e) ty m = Some v. *) +(* Proof. *) +(* erewrite type_of_chunk_val_to_expr; eauto. apply Cop.cast_val_casted. clear - WF CT NINT. *) +(* unfold wf_chunk_val_b, wf_chunk_val_b in WF. des_ifs; ss; inv CT; econs. *) +(* Qed. *) + +(* Definition cast_chunk_int (ch: memory_chunk) (i: int): val := *) +(* match ch with *) +(* | Mint8signed => Vint (Int.sign_ext 8 i) *) +(* | Mint8unsigned => Vint (Int.zero_ext 8 i) *) +(* | Mint16signed => Vint (Int.sign_ext 16 i) *) +(* | Mint16unsigned => Vint (Int.zero_ext 16 i) *) +(* | Mint32 => Vint i *) +(* | _ => Vundef *) +(* end. *) + +(* Lemma chunk_val_to_expr_eval *) +(* (ge: genv) ch v exp e cp le m *) +(* (EXP: chunk_val_to_expr ge ch v = Some exp) *) +(* (WF: wf_chunk_val_b ch v) *) +(* : *) +(* eval_expr ge e cp le m exp v. *) +(* Proof. unfold chunk_val_to_expr in EXP. des_ifs; ss; econs. Qed. *) + +(* Lemma wf_chunk_val_chunk_to_type *) +(* ch v *) +(* (WF: wf_chunk_val_b ch v) *) +(* : *) +(* exists ty, chunk_to_type ch = Some ty. *) +(* Proof. unfold wf_chunk_val_b in WF. des_ifs; ss; eauto. Qed. *) + +(* Lemma wf_chunk_val_chunk_val_to_expr *) +(* (ge: Senv.t) ch v *) +(* (WF: wf_chunk_val_b ch v) *) +(* : *) +(* exists ve, chunk_val_to_expr ge ch v = Some ve. *) +(* Proof. *) +(* unfold chunk_val_to_expr. exploit wf_chunk_val_chunk_to_type; eauto. *) +(* intros (ty & TY). rewrite TY. unfold wf_chunk_val_b in WF. des_ifs; ss; eauto. *) +(* Qed. *) + +(* Lemma code_mem_delta_storev_correct *) +(* (ge: genv) f k e le m m' *) +(* d *) +(* (WFE: wf_env ge e) *) +(* (STORE: mem_delta_apply_storev (Some m) d = Some m') *) +(* (WF: wf_mem_delta_storev_b ge (comp_of f) d) *) +(* : *) +(* step1 ge (State f (code_mem_delta_storev ge (comp_of f) d) k e le m) *) +(* E0 (State f Sskip k e le m'). *) +(* Proof. *) +(* unfold wf_mem_delta_storev_b in WF. des_ifs. rename m0 into ch, i into ofs. ss. *) +(* exploit wf_chunk_val_chunk_to_type; eauto. intros (ty & TY). *) +(* exploit wf_chunk_val_chunk_val_to_expr; eauto. intros (ve & EXPR). *) +(* rewrite H, Heq, TY, EXPR. *) +(* destruct (val_cases v) as [INT | NINT]. *) +(* { unfold val_is_int in INT. des_ifs. clear INT. eapply step_assign. *) +(* - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval; auto. *) +(* eapply Genv.invert_find_symbol; eauto. *) +(* - instantiate (1:=Vint i). eapply chunk_val_to_expr_eval; eauto. *) +(* - instantiate (1:=cast_chunk_int ch i). erewrite type_of_chunk_val_to_expr; eauto. *) +(* unfold chunk_to_type in TY. destruct ch; ss; inv TY. *) +(* + unfold Cop.sem_cast. ss. des_ifs. *) +(* + unfold Cop.sem_cast. ss. des_ifs. *) +(* + unfold Cop.sem_cast. ss. des_ifs. *) +(* + unfold Cop.sem_cast. ss. des_ifs. *) +(* + unfold Cop.sem_cast. ss. des_ifs. *) +(* - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. *) +(* rewrite <- STORE. apply Pos.eqb_eq in WF. subst c. destruct ch; ss. *) +(* + rewrite Mem.store_int8_sign_ext. auto. *) +(* + rewrite Mem.store_int8_zero_ext. auto. *) +(* + rewrite Mem.store_int16_sign_ext. auto. *) +(* + rewrite Mem.store_int16_zero_ext. auto. *) +(* } *) +(* { rewrite WF, H0. ss. eapply step_assign. *) +(* - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval; auto. *) +(* eapply Genv.invert_find_symbol; eauto. *) +(* - instantiate (1:=v). eapply chunk_val_to_expr_eval; eauto. *) +(* - ss. eapply sem_cast_chunk_val; eauto. *) +(* - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. *) +(* apply Pos.eqb_eq in WF. clarify. *) +(* } *) +(* Qed. *) + +(* Lemma wf_mem_delta_storev_false_is_skip *) +(* (ge: Senv.t) cp d *) +(* (NWF: wf_mem_delta_storev_b ge cp d = false) *) +(* : *) +(* code_mem_delta_storev ge cp d = Sskip. *) +(* Proof. destruct d as [[[ch ptr] v] cp0]. ss. des_ifs. Qed. *) + +(* Lemma code_mem_delta_correct *) +(* (ge: genv) *) +(* f k e le m m' *) +(* d snext *) +(* (WFE: wf_env ge e) *) +(* (APPD: mem_delta_apply_wf ge (comp_of f) d (Some m) = Some m') *) +(* : *) +(* (star step1 ge (State f (code_mem_delta ge (comp_of f) d snext) k e le m) *) +(* E0 (State f snext k e le m')). *) +(* Proof. *) +(* revert m m' snext APPD. induction d; intros. *) +(* { unfold mem_delta_apply_wf in APPD. ss. inv APPD. unfold code_mem_delta. ss. econs 1. } *) +(* rewrite mem_delta_apply_wf_cons in APPD. rewrite code_mem_delta_cons. *) +(* des_ifs. *) +(* - exploit mem_delta_apply_wf_some; eauto. intros (mi & APPD0). rewrite APPD0 in APPD. *) +(* destruct a; ss. econs 2. *) +(* { eapply step_seq. } *) +(* econs 2. *) +(* { eapply code_mem_delta_storev_correct; eauto. } *) +(* take_step. eapply IHd; eauto. eauto. auto. *) +(* - destruct a; ss. *) +(* rewrite wf_mem_delta_storev_false_is_skip; auto. *) +(* all: take_step; take_step; eapply IHd; eauto. *) +(* Qed. *) + +(* Lemma code_bundle_trace_spec *) +(* (ge: genv) cp cnt tr *) +(* f e le m k *) +(* : *) +(* star step1 ge *) +(* (State f (code_bundle_trace ge cp cnt tr) k e le m) *) +(* E0 *) +(* (State f (switch_bundle_events ge cnt cp tr) *) +(* (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge cnt cp tr)) Sskip k) *) +(* e le m). *) +(* Proof. *) +(* econs 2. *) +(* { unfold code_bundle_trace, Swhile. eapply step_loop. } *) +(* econs 2. *) +(* { eapply step_seq. } *) +(* econs 2. *) +(* { eapply step_ifthenelse. simpl_expr. ss. } *) +(* rewrite Int.eq_false; ss. econs 2. *) +(* { eapply step_skip_seq. } *) +(* econs 1. all: eauto. *) +(* Qed. *) + +(* End CODEPROOFS. *) + + +(* Section GENV. *) + +(* Definition symbs_public (ge1 ge2: Senv.t) := (forall id : ident, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id). *) +(* Definition symbs_find (ge1 ge2: Senv.t) := forall id b, Senv.find_symbol ge1 id = Some b -> Senv.find_symbol ge2 id = Some b. *) +(* Definition symbs_volatile (ge1 ge2: Senv.t) := forall b, Senv.block_is_volatile ge2 b = Senv.block_is_volatile ge1 b. *) + +(* Definition match_symbs (ge1 ge2: Senv.t) := symbs_public ge1 ge2 /\ symbs_find ge1 ge2 /\ symbs_volatile ge1 ge2. *) + +(* Lemma match_symbs_meminj_public *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* : *) +(* meminj_public ge1 = meminj_public ge2. *) +(* Proof. *) +(* destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). unfold meminj_public. extensionalities b. des_ifs. *) +(* - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. *) +(* apply Senv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. *) +(* - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. *) +(* apply Senv.find_invert_symbol in x0. clarify. *) +(* - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. *) +(* apply Senv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. *) +(* - exfalso. rewrite MSYMB1 in Heq1. apply Senv.public_symbol_exists in Heq1. des. *) +(* exploit MSYMB2; eauto. intros. apply Senv.invert_find_symbol in Heq0. clarify. *) +(* apply Senv.find_invert_symbol in Heq1. clarify. *) +(* Qed. *) + +(* Lemma match_symbs_wf_mem_delta_storev *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp0 d *) +(* : *) +(* wf_mem_delta_storev_b ge1 cp0 d = wf_mem_delta_storev_b ge2 cp0 d. *) +(* Proof. *) +(* destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). *) +(* destruct d as [[[ch ptr] v] cp]. ss. des_ifs. *) +(* - do 2 f_equal. apply Senv.invert_find_symbol, MSYMB2, Senv.find_invert_symbol in Heq. clarify. *) +(* - exfalso. apply Senv.invert_find_symbol, MSYMB2, Senv.find_invert_symbol in Heq. clarify. *) +(* - destruct (Senv.public_symbol ge2 i0) eqn:PUB; ss. *) +(* exfalso. rewrite MSYMB1 in PUB. apply Senv.public_symbol_exists in PUB. des. *) +(* exploit MSYMB2; eauto. intros. apply Senv.invert_find_symbol in Heq0. clarify. *) +(* apply Senv.find_invert_symbol in PUB. clarify. *) +(* Qed. *) + +(* Lemma match_symbs_wf_mem_delta_kind *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp *) +(* : *) +(* wf_mem_delta_kind_b ge1 cp = wf_mem_delta_kind_b ge2 cp. *) +(* Proof. unfold wf_mem_delta_kind_b. extensionalities d. des_ifs. apply match_symbs_wf_mem_delta_storev; auto. Qed. *) + +(* Lemma match_symbs_get_wf_mem_delta *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp d *) +(* : *) +(* get_wf_mem_delta ge1 cp d = get_wf_mem_delta ge2 cp d. *) +(* Proof. unfold get_wf_mem_delta. erewrite match_symbs_wf_mem_delta_kind; eauto. Qed. *) + +(* Lemma match_symbs_mem_delta_apply_wf *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp d m *) +(* : *) +(* mem_delta_apply_wf ge1 cp d m = mem_delta_apply_wf ge2 cp d m. *) +(* Proof. unfold mem_delta_apply_wf. erewrite match_symbs_get_wf_mem_delta; eauto. Qed. *) + +(* Lemma match_symbs_code_mem_delta_kind *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp *) +(* : *) +(* code_mem_delta_kind ge1 cp = code_mem_delta_kind ge2 cp. *) +(* Proof. *) +(* extensionalities k. unfold code_mem_delta_kind. des_ifs. *) +(* destruct d as [[[ch ptr] v] cp0]. ss. destruct ptr; ss. *) +(* destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). *) +(* destruct (Senv.invert_symbol ge1 b) eqn:INV1. *) +(* { exploit Senv.invert_find_symbol; eauto. intros FIND1. *) +(* exploit MSYMB2; eauto. intros FIND2. exploit Senv.find_invert_symbol; eauto. intros INV2. *) +(* rewrite INV2. destruct (chunk_to_type ch) eqn:CHTY; auto. *) +(* des_ifs. *) +(* - apply andb_prop in Heq0, Heq2. des. apply andb_prop in Heq0, Heq2. des. *) +(* assert (chunk_val_to_expr ge2 ch v = chunk_val_to_expr ge1 ch v). *) +(* { unfold chunk_val_to_expr. rewrite CHTY. clear - Heq6. *) +(* unfold wf_chunk_val_b in Heq6. des_ifs. *) +(* } *) +(* rewrite Heq, Heq1 in H. clarify. *) +(* - exfalso. apply andb_prop in Heq0. des. apply andb_prop in Heq0. des. *) +(* clarify. rewrite ! andb_true_r in Heq2. rewrite MSYMB1 in Heq2. clarify. *) +(* - exfalso. apply andb_prop in Heq0. des. apply andb_prop in Heq0. des. *) +(* apply (wf_chunk_val_chunk_val_to_expr (ge2)) in Heq3; eauto. des; clarify. *) +(* - exfalso. apply andb_prop in Heq2. des. apply andb_prop in Heq2. des. *) +(* clarify. rewrite ! andb_true_r in Heq0. rewrite MSYMB1 in Heq2; clarify. *) +(* - exfalso. apply andb_prop in Heq1. des. apply andb_prop in Heq1. des. *) +(* apply (wf_chunk_val_chunk_val_to_expr (ge1)) in Heq3; eauto. des; clarify. *) +(* } *) +(* { des_ifs. *) +(* exfalso. apply andb_prop in Heq2. des. apply andb_prop in Heq2. des. *) +(* rewrite MSYMB1 in Heq2. eapply Senv.public_symbol_exists in Heq2. des. *) +(* exploit MSYMB2. eapply Heq2. intros FIND4. eapply Senv.invert_find_symbol in Heq. clarify. *) +(* exploit Senv.find_invert_symbol. apply Heq2. intros INV3. clarify. *) +(* } *) +(* Qed. *) + +(* Lemma match_symbs_code_mem_delta *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp d s *) +(* : *) +(* code_mem_delta ge1 cp d s = code_mem_delta ge2 cp d s. *) +(* Proof. unfold code_mem_delta. erewrite match_symbs_code_mem_delta_kind; eauto. Qed. *) + +(* Lemma match_symbs_code_bundle_call *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp tr id evargs sg d *) +(* : *) +(* code_bundle_call ge1 cp tr id evargs sg d = code_bundle_call ge2 cp tr id evargs sg d. *) +(* Proof. unfold code_bundle_call. erewrite match_symbs_code_mem_delta; eauto. Qed. *) + +(* Lemma match_symbs_code_bundle_return *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp tr evr d *) +(* : *) +(* code_bundle_return ge1 cp tr evr d = code_bundle_return ge2 cp tr evr d. *) +(* Proof. unfold code_bundle_return. erewrite match_symbs_code_mem_delta; eauto. Qed. *) + +(* Lemma match_symbs_code_bundle_builtin *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp tr ef evargs d *) +(* : *) +(* code_bundle_builtin ge1 cp tr ef evargs d = code_bundle_builtin ge2 cp tr ef evargs d. *) +(* Proof. unfold code_bundle_builtin. erewrite match_symbs_code_mem_delta; eauto. Qed. *) + +(* Lemma match_symbs_code_bundle_events *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp *) +(* : *) +(* code_bundle_event ge1 cp = code_bundle_event ge2 cp. *) +(* Proof. *) +(* extensionalities be. unfold code_bundle_event. des_ifs. *) +(* eapply match_symbs_code_bundle_call; auto. eapply match_symbs_code_bundle_return; auto. eapply match_symbs_code_bundle_builtin; auto. *) +(* Qed. *) + +(* Lemma match_symbs_switch_bundle_events *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp cnt tr *) +(* : *) +(* switch_bundle_events ge1 cnt cp tr = switch_bundle_events ge2 cnt cp tr. *) +(* Proof. unfold switch_bundle_events. erewrite match_symbs_code_bundle_events; eauto. Qed. *) + +(* Lemma match_symbs_code_bundle_trace *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp cnt tr *) +(* : *) +(* code_bundle_trace ge1 cp cnt tr = code_bundle_trace ge2 cp cnt tr. *) +(* Proof. unfold code_bundle_trace. erewrite match_symbs_switch_bundle_events; eauto. Qed. *) + + +(* Lemma match_symbs_symbols_inject *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* : *) +(* symbols_inject (meminj_public ge1) ge1 ge2. *) +(* Proof. *) +(* destruct MSYMB as (MS0 & MS1 & MS2). unfold symbols_inject. splits; auto. *) +(* - i. unfold meminj_public in H. des_ifs. split; auto. *) +(* - i. exists b1. split; auto. unfold meminj_public. apply Senv.find_invert_symbol in H0. *) +(* rewrite H0. rewrite H. auto. *) +(* - i. unfold meminj_public in H. des_ifs. *) +(* Qed. *) + +(* End GENV. *) + + +(* Section PROOF. *) + +(* Lemma filter_filter *) +(* A (l: list A) (p q: A -> bool) *) +(* : *) +(* filter q (filter p l) = filter (fun a => (p a) && (q a)) l. *) +(* Proof. *) +(* induction l; ss. des_ifs; ss; clarify. *) +(* f_equal. auto. *) +(* Qed. *) + +(* Lemma get_wf_mem_delta_idem *) +(* ge cp d *) +(* : *) +(* get_wf_mem_delta ge cp (get_wf_mem_delta ge cp d) = get_wf_mem_delta ge cp d. *) +(* Proof. unfold get_wf_mem_delta. rewrite filter_filter. f_equal. extensionalities k. apply andb_diag. Qed. *) + +(* Lemma mem_delta_apply_wf_get_wf_mem_delta *) +(* ge cp d m *) +(* : *) +(* mem_delta_apply_wf ge cp d m = mem_delta_apply_wf ge cp (get_wf_mem_delta ge cp d) m. *) +(* Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_idem. auto. Qed. *) + +(* Lemma wf_mem_delta_kind_is_wf *) +(* ge cp k *) +(* (WF: wf_mem_delta_kind_b ge cp k) *) +(* : *) +(* mem_delta_kind_inj_wf cp (meminj_public ge) k. *) +(* Proof. unfold wf_mem_delta_kind_b in WF. des_ifs. unfold wf_mem_delta_storev_b in WF. ss. des_ifs. apply Pos.eqb_eq in WF. auto. Qed. *) + +(* Lemma get_wf_mem_delta_is_wf *) +(* cp ge d *) +(* : *) +(* mem_delta_inj_wf cp (meminj_public ge) (get_wf_mem_delta ge cp d). *) +(* Proof. induction d; ss. des_ifs. econs; auto. apply wf_mem_delta_kind_is_wf; auto. Qed. *) + +(* Lemma mem_delta_apply_establish_inject2 *) +(* (ge: Senv.t) k m0 m0' *) +(* (INJ: Mem.inject k m0 m0') *) +(* (INCR: inject_incr (meminj_public ge) k) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) +(* d cp m1 *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) *) +(* (FO: public_first_order ge m1) *) +(* : *) +(* exists m1', mem_delta_apply_wf ge cp d (Some m0') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. *) +(* Proof. *) +(* unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. eapply mem_delta_apply_establish_inject; eauto. *) +(* apply get_wf_mem_delta_is_wf. *) +(* unfold public_first_order in FO. ii. unfold meminj_public in H. des_ifs. apply Senv.invert_find_symbol in Heq. *) +(* eapply FO; eauto. *) +(* Qed. *) + +(* Lemma mem_delta_apply_establish_inject_preprocess_gen *) +(* (ge: Senv.t) (k: meminj) m0 m0' *) +(* (INJ: Mem.inject k m0 m0') *) +(* pch pb pofs pv pcp m0'' *) +(* (PRE: Mem.store pch m0' pb pofs pv pcp = Some m0'') *) +(* (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) *) +(* (INCR: inject_incr (meminj_public ge) k) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) +(* d cp m1 *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) *) +(* : *) +(* exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ *) +(* (meminj_first_order (meminj_public ge) m1 -> Mem.inject (meminj_public ge) m1 m1'). *) +(* Proof. *) +(* unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. *) +(* eapply mem_delta_apply_establish_inject_preprocess_gen; eauto. *) +(* apply get_wf_mem_delta_is_wf. *) +(* Qed. *) + +(* Lemma mem_delta_apply_establish_inject_preprocess2 *) +(* (ge: Senv.t) (k: meminj) m0 m0' *) +(* (INJ: Mem.inject k m0 m0') *) +(* pch pb pofs pv pcp m0'' *) +(* (PRE: Mem.store pch m0' pb pofs pv pcp = Some m0'') *) +(* (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) *) +(* (INCR: inject_incr (meminj_public ge) k) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) +(* d cp m1 *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) *) +(* (FO: public_first_order ge m1) *) +(* : *) +(* exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. *) +(* Proof. *) +(* hexploit mem_delta_apply_establish_inject_preprocess_gen; eauto. i. des. *) +(* esplits; eauto. apply H0. ii. unfold meminj_public in H1. des_ifs. *) +(* eapply FO; eauto. apply Senv.invert_find_symbol; auto. *) +(* Qed. *) + +(* End PROOF. *) + + + +(* Section DEFINITIONS. *) + +(* Definition meminj_same_block (j : meminj) := *) +(* forall b1 b2 del, j b1 = Some (b2, del) -> b1 = b2. *) + +(* Definition not_global_blks (ge: Senv.t) (ebs: list block) := *) +(* Forall (fun b => Senv.invert_symbol ge b = None) ebs. *) + +(* Definition blocks_of_env2 ge e : list block := (map (fun x => fst (fst x)) (blocks_of_env ge e)). *) + +(* Definition not_inj_blks (j: meminj) (ebs: list block) := *) +(* Forall (fun b => j b = None) ebs. *) + +(* Lemma not_global_is_not_inj_bloks *) +(* ge l *) +(* (NGB: not_global_blks ge l) *) +(* : *) +(* not_inj_blks (meminj_public ge) l. *) +(* Proof. induction NGB. ss. econs; eauto. unfold meminj_public. des_ifs. Qed. *) + +(* Definition eq_policy (ge1: Asm.genv) (ge2: genv) := *) +(* Genv.genv_policy ge1 = Genv.genv_policy ge2. *) + +(* End DEFINITIONS. *) + + + +(* Section PROOF. *) + +(* (* Properties *) *) +(* Lemma eventval_match_transl *) +(* (ge: Senv.t) *) +(* ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* eventval_match ge ev (typ_of_type (typ_to_type ty)) (eventval_to_val ge ev). *) +(* Proof. *) +(* inversion EM; subst; simpl; try constructor. *) +(* setoid_rewrite H0. unfold Tptr in *. destruct Archi.ptr64; auto. *) +(* Qed. *) + +(* Lemma eventval_match_eventval_to_val *) +(* (ge: Senv.t) *) +(* ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* eventval_to_val ge ev = v. *) +(* Proof. inversion EM; subst; simpl; auto. setoid_rewrite H0. auto. Qed. *) + +(* Lemma eventval_list_match_transl *) +(* (ge: Senv.t) *) +(* evs tys vs *) +(* (EM: eventval_list_match ge evs tys vs) *) +(* : *) +(* eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs). *) +(* Proof. induction EM; simpl. constructor. constructor; auto. eapply eventval_match_transl; eauto. Qed. *) + +(* Lemma eventval_list_match_transl_val *) +(* (ge: Senv.t) *) +(* evs tys vs *) +(* (EM: eventval_list_match ge evs tys vs) *) +(* : *) +(* eventval_list_match ge evs tys (list_eventval_to_list_val ge evs). *) +(* Proof. induction EM; simpl. constructor. constructor; auto. erewrite eventval_match_eventval_to_val; eauto. Qed. *) + +(* Lemma typ_type_typ *) +(* (ge: Senv.t) *) +(* ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* typ_of_type (typ_to_type ty) = ty. *) +(* Proof. inversion EM; simpl; auto. subst. unfold Tptr. destruct Archi.ptr64; simpl; auto. Qed. *) + +(* Lemma eventval_to_expr_val_eval *) +(* (ge: genv) en cp temp m ev ty v *) +(* (WFENV: wf_env ge en) *) +(* (EM: eventval_match ge ev ty v) *) +(* (* (WFGE: wf_eventval_ge ge ev) *) *) +(* : *) +(* eval_expr ge en cp temp m (eventval_to_expr ev) (eventval_to_val ge ev). *) +(* Proof. destruct ev; simpl in *; try constructor. inv EM. setoid_rewrite H4. eapply ptr_of_id_ofs_eval; auto. Qed. *) + +(* Lemma sem_cast_eventval_match *) +(* (ge: Senv.t) v ty vv m *) +(* (EM: eventval_match ge v (typ_of_type (typ_to_type ty)) vv) *) +(* : *) +(* Cop.sem_cast vv (typeof (eventval_to_expr v)) (typ_to_type ty) m = Some vv. *) +(* Proof. *) +(* destruct ty; simpl in *; inversion EM; subst; simpl in *; simpl_expr. *) +(* all: try rewrite ptr_of_id_ofs_typeof; simpl. *) +(* all: try (cbn; auto). *) +(* all: unfold Tptr in *; destruct Archi.ptr64 eqn:ARCH; try congruence. *) +(* { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } *) +(* { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } *) +(* { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } *) +(* { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } *) +(* Qed. *) + +(* Lemma list_eventval_to_expr_val_eval *) +(* (ge: genv) en cp temp m evs tys *) +(* (* (WFENV: Forall (wf_eventval_env en) evs) *) *) +(* (WFENV: wf_env ge en) *) +(* (EMS: eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs)) *) +(* : *) +(* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) (list_eventval_to_list_val ge evs). *) +(* Proof. *) +(* revert en cp temp m WFENV. *) +(* match goal with | [H: eventval_list_match _ _ ?t ?v |- _] => remember t as tys2; remember v as vs2 end. *) +(* revert tys Heqtys2 Heqvs2. induction EMS; intros; subst; simpl in *. *) +(* { destruct tys; simpl in *. constructor. congruence. } *) +(* inversion Heqvs2; clear Heqvs2; subst; simpl in *. *) +(* destruct tys; simpl in Heqtys2. congruence with Heqtys2. *) +(* inversion Heqtys2; clear Heqtys2; subst; simpl in *. *) +(* econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. *) +(* (* eapply eventval_match_wf_eventval_ge; eauto. *) *) +(* eapply sem_cast_eventval_match; eauto. *) +(* Qed. *) + +(* Lemma eventval_match_eventval_to_type *) +(* (ge: Senv.t) *) +(* ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* eventval_match ge ev (typ_of_type (eventval_to_type ev)) v. *) +(* Proof. inversion EM; subst; simpl; auto. Qed. *) + +(* Lemma list_eventval_match_eventval_to_type *) +(* (ge: Senv.t) *) +(* evs tys vs *) +(* (ESM: eventval_list_match ge evs tys vs) *) +(* : *) +(* eventval_list_match ge evs (typlist_of_typelist (list_eventval_to_typelist evs)) vs. *) +(* Proof. induction ESM; simpl. constructor. constructor; auto. eapply eventval_match_eventval_to_type; eauto. Qed. *) + +(* Lemma val_load_result_idem *) +(* ch v *) +(* : *) +(* Val.load_result ch (Val.load_result ch v) = Val.load_result ch v. *) +(* Proof. *) +(* destruct ch, v; simpl; auto. *) +(* 5,6,7: destruct Archi.ptr64; simpl; auto. *) +(* 1,3: rewrite Int.sign_ext_idem; auto. *) +(* 3,4: rewrite Int.zero_ext_idem; auto. *) +(* all: lia. *) +(* Qed. *) + +(* Lemma val_load_result_aux *) +(* F V (ge: Genv.t F V) *) +(* ev ch v *) +(* (EM: eventval_match ge ev (type_of_chunk ch) (Val.load_result ch v)) *) +(* : *) +(* eventval_match ge ev (type_of_chunk ch) (Val.load_result ch (eventval_to_val ge ev)). *) +(* Proof. *) +(* inversion EM; subst; simpl in *; auto. *) +(* 1,2,3,4: rewrite H1, H2; rewrite val_load_result_idem; auto. *) +(* rewrite H3, H. rewrite H0. rewrite val_load_result_idem. auto. *) +(* Qed. *) + +(* Lemma eventval_match_proj_rettype *) +(* (ge: Senv.t) *) +(* ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* eventval_match ge ev (proj_rettype (rettype_of_type (typ_to_type ty))) v. *) +(* Proof. *) +(* inversion EM; subst; simpl; try constructor. *) +(* unfold Tptr in *. destruct Archi.ptr64; simpl; auto. *) +(* Qed. *) + +(* (* Lemma sem_cast_eventval *) *) +(* (* (ge: cgenv) v m *) *) +(* (* (WFEV: wf_eventval_ge ge v) *) *) +(* (* : *) *) +(* (* Cop.sem_cast (eventval_to_val ge v) (typeof (eventval_to_expr v)) (eventval_to_type v) m = Some (eventval_to_val ge v). *) *) +(* (* Proof. rewrite typeof_eventval_to_expr_type. destruct v; simpl in *; simpl_expr. destruct WFEV. rewrite H. simpl_expr. Qed. *) *) + +(* (* Lemma list_eventval_to_expr_val_eval2 *) *) +(* (* (ge: genv) en cp temp m evs *) *) +(* (* (WFENV: Forall (wf_eventval_env en) evs) *) *) +(* (* (WFGE: Forall (wf_eventval_ge ge) evs) *) *) +(* (* : *) *) +(* (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_eventval_to_typelist evs) (list_eventval_to_list_val ge evs). *) *) +(* (* Proof. *) *) +(* (* move evs at top. revert ge en cp temp m WFENV WFGE. induction evs; intros; simpl in *. *) *) +(* (* constructor. *) *) +(* (* inversion WFENV; clear WFENV; subst. inversion WFGE; clear WFGE; subst. *) *) +(* (* econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. *) *) +(* (* apply sem_cast_eventval; auto. *) *) +(* (* Qed. *) *) + +(* Lemma eventval_match_sem_cast *) +(* (* F V (ge: Genv.t F V) *) *) +(* (ge: genv) *) +(* m ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* (* Cop.sem_cast (eventval_to_val ge ev) (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some (eventval_to_val ge ev). *) *) +(* Cop.sem_cast v (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some v. *) +(* Proof. *) +(* inversion EM; subst; simpl; try constructor. all: simpl_expr. *) +(* rewrite ptr_of_id_ofs_typeof. unfold Tptr. unfold Cop.sem_cast. destruct Archi.ptr64 eqn:ARCH; simpl. *) +(* - rewrite ARCH; auto. *) +(* - rewrite ARCH; auto. *) +(* Qed. *) + +(* (* Lemma list_eventval_to_expr_val_eval_typs *) *) +(* (* (ge: genv) en cp temp m evs tys vs *) *) +(* (* (WFENV: Forall (wf_eventval_env en) evs) *) *) +(* (* (EMS: eventval_list_match ge evs tys vs) *) *) +(* (* : *) *) +(* (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) vs. *) *) +(* (* Proof. *) *) +(* (* revert en cp temp m WFENV. *) *) +(* (* induction EMS; intros; subst; simpl in *. constructor. *) *) +(* (* inversion WFENV; clear WFENV; subst. *) *) +(* (* econstructor; eauto. 2: eapply eventval_match_sem_cast; eauto. *) *) +(* (* exploit eventval_match_eventval_to_val. eauto. intros. rewrite <- H0. eapply eventval_to_expr_val_eval; auto. *) *) +(* (* eapply eventval_match_wf_eventval_ge; eauto. *) *) +(* (* Qed. *) *) + +(* Lemma sem_cast_ptr *) +(* b ofs m *) +(* : *) +(* Cop.sem_cast (Vptr b ofs) (Tpointer Tvoid noattr) (typ_to_type Tptr) m = Some (Vptr b ofs). *) +(* Proof. *) +(* unfold Tptr. destruct Archi.ptr64 eqn:ARCH; unfold Cop.sem_cast; simpl; rewrite ARCH; auto. *) +(* Qed. *) + +(* Lemma sem_cast_proj_rettype *) +(* (ge: genv) evres rty res m *) +(* (EVM: eventval_match ge evres (proj_rettype rty) res) *) +(* : *) +(* Cop.sem_cast (eventval_to_val ge evres) *) +(* (typeof (eventval_to_expr evres)) *) +(* (rettype_to_type rty) m *) +(* = Some (eventval_to_val ge evres). *) +(* Proof. *) +(* destruct rty; simpl in *. *) +(* { eapply eventval_match_sem_cast. eauto. erewrite eventval_match_eventval_to_val; eauto. } *) +(* { inv EVM; simpl; simpl_expr. *) +(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) +(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) +(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) +(* } *) +(* { inv EVM; simpl; simpl_expr. *) +(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) +(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) +(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) +(* } *) +(* { inv EVM; simpl; simpl_expr. *) +(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) +(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) +(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) +(* } *) +(* { inv EVM; simpl; simpl_expr. *) +(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) +(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) +(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) +(* } *) +(* { inv EVM; simpl; simpl_expr. *) +(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) +(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) +(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) +(* } *) +(* Qed. *) + +(* Lemma type_of_params_eq *) +(* params ts *) +(* (PARSIGS : list_typ_to_list_type ts = map snd params) *) +(* : *) +(* type_of_params params = list_typ_to_typelist ts. *) +(* Proof. *) +(* revert params PARSIGS. induction ts; ii; ss. *) +(* { destruct params; ss. } *) +(* destruct params; ss. destruct p; ss. clarify. f_equal. auto. *) +(* Qed. *) + +(* Lemma match_senv_eventval_match *) +(* (ge0 ge1: Senv.t) *) +(* (MS: match_symbs ge0 ge1) *) +(* ev ty v *) +(* (EM: eventval_match ge0 ev ty v) *) +(* : *) +(* eventval_match ge1 ev ty v. *) +(* Proof. destruct MS as (MS0 & MS1 & MS2). inv EM; try econs; auto. rewrite MS0. auto. Qed. *) + +(* Lemma match_senv_eventval_list_match *) +(* (ge0 ge1: Senv.t) *) +(* (MS: match_symbs ge0 ge1) *) +(* evs tys vs *) +(* (EM: eventval_list_match ge0 evs tys vs) *) +(* : *) +(* eventval_list_match ge1 evs tys vs. *) +(* Proof. induction EM; ss. econs; auto. econs; auto. eapply match_senv_eventval_match; eauto. Qed. *) + +(* Lemma unbundle_trace_app *) +(* tr1 tr2 *) +(* : *) +(* unbundle_trace (tr1 ++ tr2) = (unbundle_trace tr1) ++ (unbundle_trace tr2). *) +(* Proof. induction tr1; ss. rewrite <- app_assoc. f_equal. auto. Qed. *) + +(* Lemma allowed_call_gen_function *) +(* cp (ge_i: Asm.genv) (ge_c: genv) next cnt params tr f_i f_c *) +(* (GE: symbs_find ge_i ge_c) *) +(* (GEPOL: eq_policy ge_i ge_c) *) +(* (GEN: f_c = gen_function ge_i cnt params tr f_i) *) +(* (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) *) +(* (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.Internal f_i)) *) +(* (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = Some (Internal f_c)) *) +(* : *) +(* Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). *) +(* Proof. *) +(* unfold Genv.allowed_call in *. des; [left | right]. *) +(* - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. *) +(* - subst. unfold Genv.allowed_cross_call in *. des. *) +(* unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. *) +(* specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. *) +(* { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. *) +(* apply GE. auto. *) +(* } *) +(* { i. rewrite FINDF_C in H. clarify. } *) +(* { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. *) +(* rewrite <- ALLOW1. ss. *) +(* } *) +(* Qed. *) + +(* Lemma allowed_call_gen_function_external *) +(* cp (ge_i: Asm.genv) (ge_c: genv) next ef *) +(* (GE: symbs_find ge_i ge_c) *) +(* (GEPOL: eq_policy ge_i ge_c) *) +(* (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) *) +(* (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.External ef)) *) +(* (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = *) +(* Some (External ef *) +(* (list_typ_to_typelist (sig_args (ef_sig ef))) *) +(* (rettype_to_type (sig_res (ef_sig ef))) *) +(* (sig_cc (ef_sig ef)))) *) +(* : *) +(* Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). *) +(* Proof. *) +(* unfold Genv.allowed_call in *. des; [left | right]. *) +(* - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. *) +(* - unfold Genv.allowed_cross_call in *. des. *) +(* unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. *) +(* specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. *) +(* { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. *) +(* apply GE. auto. *) +(* } *) +(* { i. rewrite FINDF_C in H. clarify. } *) +(* { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. *) +(* rewrite <- ALLOW1. ss. *) +(* } *) +(* Qed. *) + +(* Lemma eventval_list_match_list_eventval_to_list_val *) +(* (ge: Senv.t) evargs tys vargs *) +(* (EVMS: eventval_list_match ge evargs tys vargs) *) +(* : *) +(* list_eventval_to_list_val ge evargs = vargs. *) +(* Proof. *) +(* induction EVMS; ss. f_equal; auto. *) +(* eapply eventval_match_eventval_to_val. eauto. *) +(* Qed. *) + +(* Lemma match_symbs_eventval_match *) +(* ge0 ge1 ev ty v *) +(* (MS: match_symbs ge0 ge1) *) +(* (EVM: eventval_match ge0 ev ty v) *) +(* : *) +(* eventval_match ge1 ev ty v. *) +(* Proof. *) +(* destruct MS as (MS0 & MS1 & MS2). inv EVM; econs; auto. rewrite MS0; auto. *) +(* Qed. *) + +(* Lemma match_symbs_eventval_list_match *) +(* ge0 ge1 ev ty v *) +(* (MS: match_symbs ge0 ge1) *) +(* (EVM: eventval_list_match ge0 ev ty v) *) +(* : *) +(* eventval_list_match ge1 ev ty v. *) +(* Proof. *) +(* induction EVM. econs. econs; auto. eapply match_symbs_eventval_match; eauto. *) +(* Qed. *) + +(* Lemma alloc_variables_exists *) +(* ge cp e m l *) +(* : *) +(* exists e' m', alloc_variables ge cp e m l e' m'. *) +(* Proof. *) +(* revert ge cp e m. induction l; ii. *) +(* { do 2 eexists. econs 1. } *) +(* destruct a as (id & ty). *) +(* destruct (Mem.alloc m cp 0 (sizeof ge ty)) as (m0 & b0) eqn:ALLOC. *) +(* specialize (IHl ge cp (PTree.set id (b0, ty) e) m0). des. *) +(* do 2 eexists. econs 2. eapply ALLOC. eapply IHl. *) +(* Qed. *) + +(* Lemma access_mode_typ_to_type *) +(* s *) +(* : *) +(* exists ch, access_mode (typ_to_type s) = By_value ch. *) +(* Proof. destruct s; ss; eauto. Qed. *) + +(* Lemma bind_parameters_exists *) +(* (ge: genv) cp (e: env) m params vargs *) +(* (INENV: Forall (fun '(id, ty) => *) +(* exists b, (e ! id = Some (b, ty)) /\ *) +(* (forall ch, access_mode ty = By_value ch -> *) +(* Mem.valid_access m ch b 0 Writable (Some cp))) *) +(* params) *) +(* sg *) +(* (PARSIGS: list_typ_to_list_type sg = map snd params) *) +(* evargs *) +(* (EMS: eventval_list_match ge evargs sg vargs) *) +(* : *) +(* exists m', bind_parameters ge cp e m params vargs m'. *) +(* Proof. *) +(* revert e m vargs INENV sg PARSIGS evargs EMS. induction params; ii. *) +(* { ss. inv EMS; ss. eexists. econs. } *) +(* destruct a as (id & ty). inv INENV. des. ss. *) +(* destruct sg; ss. rename t into s. clarify. inv EMS. *) +(* destruct (access_mode_typ_to_type s) as (ch & ACCM). *) +(* specialize (H0 _ ACCM). hexploit Mem.valid_access_store. apply H0. instantiate (1:=v1). *) +(* intros (m0 & STORE). *) +(* assert *) +(* (FA: Forall *) +(* (fun '(id, ty) => *) +(* exists b : block, *) +(* e ! id = Some (b, ty) /\ *) +(* (forall ch : memory_chunk, access_mode ty = By_value ch -> *) +(* Mem.valid_access m0 ch b 0 Writable (Some cp))) params). *) +(* { clear - H2 STORE. move H2 before cp. revert_until H2. induction H2; ii; ss. *) +(* econs; eauto. des_ifs. des. esplits; eauto. i. eapply Mem.store_valid_access_1; eauto. *) +(* } *) +(* hexploit IHparams. apply FA. 1,2: eauto. intros. des. exists m'. *) +(* econs; eauto. econs; eauto. *) +(* Qed. *) + +(* Lemma alloc_variables_wf_id *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* (WF: list_norepet (var_names params)) *) +(* : *) +(* forall id bt, (~ In id (var_names params)) -> (e ! id = Some bt) -> (e' ! id = Some bt). *) +(* Proof. *) +(* revert WF. induction EA; ii; ss. *) +(* apply Classical_Prop.not_or_and in H0. des. inv WF. *) +(* apply IHEA; auto. rewrite PTree.gso; auto. *) +(* Qed. *) + +(* Lemma alloc_variables_valid_access *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* : *) +(* forall b' ch' ofs' p' cp', Mem.valid_access m ch' b' ofs' p' cp' -> *) +(* Mem.valid_access m' ch' b' ofs' p' cp'. *) +(* Proof. *) +(* i. assert (WF: (b' < Mem.nextblock m)%positive). *) +(* { unfold Mem.valid_access in H. des. destruct (Unusedglob.IS.MSet.Raw.MX.lt_dec b' (Mem.nextblock m)); auto. *) +(* exfalso. unfold Mem.range_perm in H. specialize (H ofs'). *) +(* eapply (Mem.nextblock_noaccess _ _ ofs' Cur) in n. *) +(* exploit H. *) +(* { pose proof (size_chunk_pos ch'). lia. } *) +(* i. unfold Mem.perm in x0. rewrite n in x0. ss. *) +(* } *) +(* revert_until EA. induction EA; ii; ss. *) +(* apply IHEA. *) +(* { eapply Mem.valid_access_alloc_other; eauto. } *) +(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) +(* Qed. *) + +(* Lemma alloc_variables_forall *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* (WF: list_norepet (var_names params)) *) +(* : *) +(* Forall (fun '(id, ty) => *) +(* exists b, (e' ! id = Some (b, ty)) /\ *) +(* (forall ch, access_mode ty = By_value ch -> *) +(* Mem.valid_access m' ch b 0 Writable (Some cp))) params. *) +(* Proof. *) +(* revert WF. induction EA; ii; ss. *) +(* inv WF. econs; eauto. *) +(* hexploit alloc_variables_wf_id. apply EA. auto. apply H2. apply PTree.gss. *) +(* i. esplits; eauto. *) +(* i. eapply alloc_variables_valid_access. apply EA. *) +(* apply Mem.valid_access_freeable_any. eapply Mem.valid_access_alloc_same; eauto. lia. *) +(* { ss. clear - H1. destruct ty; ss; clarify. des_ifs; clarify; ss. des_ifs; clarify; ss. unfold Mptr. des_ifs. } *) +(* exists 0. ss. *) +(* Qed. *) + +(* Lemma assign_loc_valid_access *) +(* ge cp ty m b ofs bit v m' *) +(* (AL: assign_loc ge cp ty m b ofs bit v m') *) +(* ch' b' ofs' perm' cp' *) +(* (VA: Mem.valid_access m ch' b' ofs' perm' (Some cp')) *) +(* : *) +(* Mem.valid_access m' ch' b' ofs' perm' (Some cp'). *) +(* Proof. *) +(* inv AL. *) +(* - eapply Mem.store_valid_access_1; eauto. *) +(* - eapply Mem.storebytes_valid_access_1; eauto. *) +(* - inv H. eapply Mem.store_valid_access_1; eauto. *) +(* Qed. *) + +(* Lemma bind_parameters_valid_access *) +(* (ge: genv) cp (e: env) m params vargs m' *) +(* (BIND: bind_parameters ge cp e m params vargs m') *) +(* ch b ofs perm cp' *) +(* (VA: Mem.valid_access m ch b ofs perm (Some cp')) *) +(* : *) +(* Mem.valid_access m' ch b ofs perm (Some cp'). *) +(* Proof. *) +(* revert_until BIND. induction BIND; ii; ss. *) +(* apply IHBIND. eapply assign_loc_valid_access; eauto. *) +(* Qed. *) + +(* Lemma mem_delta_apply_wf_valid_access *) +(* ge cp d m m' *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) +(* ch b ofs perm cp' *) +(* (VA: Mem.valid_access m ch b ofs perm cp') *) +(* : *) +(* Mem.valid_access m' ch b ofs perm cp'. *) +(* Proof. *) +(* move d before ge. revert_until d. induction d; ii. *) +(* { unfold mem_delta_apply_wf in APPD. ss; clarify. } *) +(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs. *) +(* - destruct a; ss. hexploit mem_delta_apply_wf_some; eauto. *) +(* intros (m0 & STOREV). rewrite STOREV in APPD. *) +(* eapply IHd. apply APPD. *) +(* unfold mem_delta_apply_storev in STOREV. des_ifs. *) +(* unfold Mem.storev in STOREV. des_ifs. *) +(* eapply Mem.store_valid_access_1; eauto. *) +(* - eapply IHd; eauto. *) +(* Qed. *) + +(* Lemma bind_parameters_mem_load *) +(* ge cp e m0 params vargs m1 *) +(* (BIND: bind_parameters ge cp e m0 params vargs m1) *) +(* : *) +(* forall ch b ofs cp', *) +(* (forall id b_e ty, (e ! id = Some (b_e, ty) -> b <> b_e)) -> *) +(* (Mem.load ch m1 b ofs cp' = Mem.load ch m0 b ofs cp'). *) +(* Proof. *) +(* induction BIND; ii; ss. *) +(* rewrite IHBIND; auto. *) +(* inv H0. *) +(* - eapply Mem.load_store_other. eapply H3. left. ii. clarify. specialize (H1 _ _ _ H). clarify. *) +(* - eapply Mem.load_storebytes_other. eapply H7. left. ii. clarify. specialize (H1 _ _ _ H). clarify. *) +(* Qed. *) + +(* Lemma alloc_variables_mem_load *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* : *) +(* forall ch b ofs cp', *) +(* (b < Mem.nextblock m)%positive -> *) +(* (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). *) +(* Proof. *) +(* induction EA; ii; ss. *) +(* rewrite IHEA. *) +(* { eapply Mem.load_alloc_unchanged; eauto. } *) +(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) +(* Qed. *) + +(* Lemma alloc_variables_old_blocks *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* : *) +(* forall b, (b < Mem.nextblock m)%positive -> *) +(* (forall id b' ty, e ! id = Some (b', ty) -> b <> b') -> *) +(* (forall id b' ty, e' ! id = Some (b', ty) -> b <> b'). *) +(* Proof. *) +(* induction EA; i. *) +(* { ii; clarify. specialize (H0 _ _ _ H1). clarify. } *) +(* hexploit Mem.alloc_result; eauto. intros; clarify. *) +(* eapply IHEA. 3: eapply H2. *) +(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) +(* { i. destruct (Pos.eq_dec id id1). *) +(* - clarify. rewrite PTree.gss in H3. clarify. lia. *) +(* - rewrite PTree.gso in H3; auto. eapply H1; eauto. *) +(* } *) +(* Qed. *) + +(* Lemma mem_delta_apply_wf_mem_load *) +(* ge cp d m m' *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) +(* : *) +(* forall id ch b ofs cp', *) +(* Senv.invert_symbol ge b = Some id -> *) +(* Senv.public_symbol ge id = false -> *) +(* (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). *) +(* Proof. *) +(* move d before ge. revert_until d. induction d; ii. *) +(* { unfold mem_delta_apply_wf in APPD. ss. clarify. } *) +(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs. *) +(* { destruct a; ss. unfold wf_mem_delta_storev_b in Heq. des_ifs. ss. *) +(* hexploit mem_delta_apply_wf_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. *) +(* erewrite IHd. 2: eauto. 2: eauto. all: auto. *) +(* destruct (Pos.eq_dec b b0). *) +(* - clarify. *) +(* - erewrite Mem.load_store_other. 2: eauto. all: auto. *) +(* } *) +(* { eapply IHd; eauto. } *) +(* Qed. *) + +(* Lemma nat64_int64_add_one *) +(* n *) +(* (BOUND: Z.of_nat n < Int64.modulus) *) +(* : *) +(* Int64.add (nat64 n) Int64.one = nat64 (n + 1). *) +(* Proof. *) +(* unfold nat64. rewrite Nat2Z.inj_add. ss. *) +(* assert (N: Z.of_nat n = Int64.unsigned (Int64.repr (Z.of_nat n))). *) +(* { symmetry. apply Int64.unsigned_repr. split. apply Zle_0_nat. *) +(* unfold Int64.max_unsigned. lia. *) +(* } *) +(* assert (ONE: 1 = (Int64.unsigned (Int64.repr 1))). *) +(* { ss. } *) +(* rewrite N at 2. rewrite ONE. rewrite <- Int64.add_unsigned. ss. *) +(* Qed. *) + +(* Lemma mem_free_list_impl1 *) +(* blks m cp m_f *) +(* (FREE: Mem.free_list m blks cp = Some m_f) *) +(* : *) +(* Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks. *) +(* Proof. *) +(* Local Opaque Mem.can_access_block. *) +(* revert_until blks. induction blks; ii; ss. des_ifs. ss. econs. *) +(* 2:{ cut (Forall (fun '(b0, lo, hi) => Mem.range_perm m0 b0 lo hi Cur Freeable /\ Mem.can_access_block m0 b0 (Some cp)) blks); cycle 1. *) +(* { eapply IHblks; eauto. } *) +(* clear - Heq. intros FA. revert_until blks. induction blks; ii; ss. *) +(* destruct a as ((ba & loa) & hia). ss. inv FA. des; clarify. econs. *) +(* { *) +(* clear IHblks. split. *) +(* - unfold Mem.range_perm in *. ii. eapply Mem.perm_free_3. eauto. eauto. *) +(* - eapply Mem.free_can_access_block_inj_2; eauto. *) +(* } *) +(* eapply IHblks; eauto. *) +(* } *) +(* split. *) +(* - eapply Mem.free_range_perm; eauto. *) +(* - eapply Mem.free_can_access_block_1; eauto. *) +(* Local Transparent Mem.can_access_block. *) +(* Qed. *) + +(* Lemma mem_free_list_impl2 *) +(* blks m cp *) +(* (NR: list_norepet (map (fun x => fst (fst x)) blks)) *) +(* (FA: Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks) *) +(* : *) +(* exists m_f, (Mem.free_list m blks cp = Some m_f). *) +(* Proof. *) +(* Local Opaque Mem.can_access_block. *) +(* revert_until blks. induction blks; ii; ss; eauto. *) +(* inv FA. inv NR. des_ifs; des. *) +(* 2:{ exfalso. destruct (Mem.range_perm_free _ _ _ _ _ H1 H0) as (m0 & FREE). clarify. } *) +(* eapply IHblks; clear IHblks; eauto. ss. clear - H2 H3 Heq. *) +(* revert_until blks. induction blks; ii; ss. inv H2. des_ifs; ss. des. econs; eauto. *) +(* clear IHblks H4. apply Classical_Prop.not_or_and in H3. des. split. *) +(* - unfold Mem.range_perm in *. ii. hexploit Mem.perm_free_inv; eauto. ii. des; clarify. *) +(* - eapply Mem.free_can_access_block_inj_1; eauto. *) +(* Local Transparent Mem.can_access_block. *) +(* Qed. *) + +(* Lemma list_map_norepet_rev *) +(* A (l: list A) B (f: A -> B) *) +(* (NR: list_norepet (map f l)) *) +(* : *) +(* list_norepet l. *) +(* Proof. *) +(* revert NR. induction l; ii; ss. econs. inv NR. econs; eauto. *) +(* ii. apply H1; clear H1. apply in_map; auto. *) +(* Qed. *) + +(* Lemma alloc_variables_wunchanged_on *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* : *) +(* wunchanged_on (fun b _ => Mem.valid_block m b) m m'. *) +(* Proof. *) +(* induction EA. apply wunchanged_on_refl. *) +(* eapply wunchanged_on_implies in IHEA. *) +(* { eapply wunchanged_on_trans. 2: eauto. eapply alloc_wunchanged_on. eauto. } *) +(* { ii. ss. } *) +(* Qed. *) + +(* Lemma alloc_variables_exists_free_list *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* (ENV1: forall id1 id2 b1 b2 t1 t2, (id1 <> id2) -> (e ! id1 = Some (b1, t1)) -> (e ! id2 = Some (b2, t2)) -> (b1 <> b2)) *) +(* (ENV2: forall id b t, (e ! id = Some (b, t)) -> (Mem.valid_block m b)) *) +(* m_f0 *) +(* (FREE: Mem.free_list m' (blocks_of_env ge e) cp = Some m_f0) *) +(* : *) +(* exists m_f, Mem.free_list m' (blocks_of_env ge e') cp = Some m_f. *) +(* Proof. *) +(* revert_until EA. induction EA; ii; ss; eauto. *) +(* assert (exists m_f0, Mem.free_list m2 (blocks_of_env ge (PTree.set id (b1, ty) e)) cp = Some m_f0); cycle 1. *) +(* { des. eapply IHEA; clear IHEA; eauto. *) +(* - i. destruct (Pos.eqb_spec id id1); clarify. *) +(* + rewrite PTree.gss in H2. rewrite PTree.gso in H3; auto. clarify. specialize (ENV2 _ _ _ H3). *) +(* ii. clarify. apply Mem.fresh_block_alloc in H. clarify. *) +(* + destruct (Pos.eqb_spec id id2); clarify. *) +(* * rewrite PTree.gso in H2; auto. rewrite PTree.gss in H3; auto. clarify. specialize (ENV2 _ _ _ H2). *) +(* ii. clarify. apply Mem.fresh_block_alloc in H. clarify. *) +(* * rewrite PTree.gso in H2, H3; auto. hexploit ENV1. 2: eapply H2. 2: eapply H3. all: auto. *) +(* - i. destruct (Pos.eqb_spec id id0); clarify. *) +(* + rewrite PTree.gss in H1. clarify. eapply Mem.valid_new_block; eauto. *) +(* + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). eapply Mem.valid_block_alloc; eauto. *) +(* } *) +(* clear IHEA. eapply mem_free_list_impl2. *) +(* { unfold blocks_of_env. rewrite map_map. apply list_map_norepet. *) +(* { eapply list_map_norepet_rev. apply PTree.elements_keys_norepet. } *) +(* { i. unfold block_of_binding. des_ifs. ss. apply PTree.elements_complete in H0, H1. *) +(* destruct (Pos.eqb_spec id i); clarify. *) +(* - rewrite PTree.gss in H0. clarify. destruct (Pos.eqb_spec i i0); clarify. *) +(* + rewrite PTree.gss in H1; clarify. *) +(* + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). ii; clarify. *) +(* apply Mem.fresh_block_alloc in H. clarify. *) +(* - rewrite PTree.gso in H0; auto. destruct (Pos.eqb_spec id i0); clarify. *) +(* + rewrite PTree.gss in H1. clarify. specialize (ENV2 _ _ _ H0). ii; clarify. *) +(* apply Mem.fresh_block_alloc in H. clarify. *) +(* + rewrite PTree.gso in H1; auto. eapply ENV1. 2: apply H0. 2: apply H1. ii; clarify. *) +(* } *) +(* } *) +(* { apply mem_free_list_impl1 in FREE. rewrite Forall_forall in *. i. *) +(* assert ((x = (b1, 0%Z, sizeof ge ty)) \/ (In x (blocks_of_env ge e))). *) +(* { clear - H0. unfold blocks_of_env in *. apply list_in_map_inv in H0. des. *) +(* destruct x0 as (xid & xb & xt). apply PTree.elements_complete in H1. clarify. *) +(* destruct (Pos.eqb_spec id xid); clarify. *) +(* - rewrite PTree.gss in H1. clarify. left; auto. *) +(* - rewrite PTree.gso in H1; auto. right. apply in_map. apply PTree.elements_correct. auto. *) +(* } *) +(* des. *) +(* - clarify. split. *) +(* + ii. eapply perm_wunchanged_on. eapply alloc_variables_wunchanged_on; eauto. *) +(* { ss. eapply Mem.valid_new_block; eauto. } *) +(* { eapply Mem.perm_alloc_2; eauto. } *) +(* + rewrite <- wunchanged_on_own. 2: eapply alloc_variables_wunchanged_on; eauto. *) +(* eapply Mem.owned_new_block; eauto. eapply Mem.valid_new_block; eauto. *) +(* - eapply FREE. eauto. *) +(* } *) +(* Qed. *) + +(* Lemma assign_loc_wunchanged_on *) +(* ge cp ty m b ofs bit v m' *) +(* (AL: assign_loc ge cp ty m b ofs bit v m') *) +(* : *) +(* wunchanged_on (fun _ _ => True) m m'. *) +(* Proof. *) +(* inv AL. *) +(* - eapply store_wunchanged_on; eauto. *) +(* - eapply storebytes_wunchanged_on; eauto. *) +(* - inv H. eapply store_wunchanged_on; eauto. *) +(* Qed. *) + +(* Lemma bind_parameters_wunchanged_on *) +(* (ge: genv) cp (e: env) m params vargs m' *) +(* (BIND: bind_parameters ge cp e m params vargs m') *) +(* : *) +(* wunchanged_on (fun _ _ => True) m m'. *) +(* Proof. *) +(* induction BIND. apply wunchanged_on_refl. eapply wunchanged_on_trans. 2: apply IHBIND. *) +(* eapply assign_loc_wunchanged_on; eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_exists_free *) +(* m m' *) +(* (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') *) +(* b lo hi cp m_f *) +(* (FREE: Mem.free m b lo hi cp = Some m_f) *) +(* : *) +(* exists m_f', Mem.free m' b lo hi cp = Some m_f'. *) +(* Proof. *) +(* hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. *) +(* hexploit Mem.range_perm_free. *) +(* 3:{ intros (m0 & F). eexists; eapply F. } *) +(* - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. eapply Mem.perm_valid_block; eauto. *) +(* - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. *) +(* Qed. *) + +(* Lemma assign_loc_perm *) +(* ge cp ty m b ofs bit v m' *) +(* (AL: assign_loc ge cp ty m b ofs bit v m') *) +(* b' o' C P *) +(* (PERM: Mem.perm m b' o' C P) *) +(* : *) +(* Mem.perm m' b' o' C P. *) +(* Proof. *) +(* inv AL. *) +(* - eapply Mem.perm_store_1; eauto. *) +(* - eapply Mem.perm_storebytes_1; eauto. *) +(* - inv H. eapply Mem.perm_store_1; eauto. *) +(* Qed. *) + +(* Lemma assign_loc_own *) +(* ge cp ty m b ofs bit v m' *) +(* (AL: assign_loc ge cp ty m b ofs bit v m') *) +(* b' cp' *) +(* (OWN: Mem.can_access_block m b' cp') *) +(* : *) +(* Mem.can_access_block m' b' cp'. *) +(* Proof. *) +(* inv AL. *) +(* - rewrite <- Mem.store_can_access_block_inj; eauto. *) +(* - eapply Mem.storebytes_can_access_block_inj_1; eauto. *) +(* - inv H. rewrite <- Mem.store_can_access_block_inj; eauto. *) +(* Qed. *) + +(* Lemma assign_loc_exists_free *) +(* ge cp ty m b ofs bit v m' *) +(* (AL: assign_loc ge cp ty m b ofs bit v m') *) +(* b' lo hi cp' m_f *) +(* (FREE: Mem.free m b' lo hi cp' = Some m_f) *) +(* : *) +(* exists m_f, Mem.free m' b' lo hi cp' = Some m_f. *) +(* Proof. *) +(* hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. *) +(* hexploit Mem.range_perm_free. *) +(* 3:{ intros (m0 & F). eexists; eapply F. } *) +(* - unfold Mem.range_perm in *. i. eapply assign_loc_perm; eauto. *) +(* - eapply assign_loc_own; eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_free_preserves *) +(* m m' *) +(* (WU : wunchanged_on (fun (b : block) (_ : Z) => Mem.valid_block m b) m m') *) +(* b lo hi cp m1 m1' *) +(* (FREE: Mem.free m b lo hi cp = Some m1) *) +(* (FREE': Mem.free m' b lo hi cp = Some m1') *) +(* : *) +(* wunchanged_on (fun (b0 : block) (_ : Z) => Mem.valid_block m1 b0) m1 m1'. *) +(* Proof. *) +(* inv WU. econs. *) +(* - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. *) +(* - i. assert (VB: Mem.valid_block m b0). *) +(* { eapply Mem.valid_block_free_2; eauto. } *) +(* split; i. *) +(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. *) +(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) +(* hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. *) +(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. *) +(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) +(* hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. *) +(* - i. assert (VB: Mem.valid_block m b0). *) +(* { eapply Mem.valid_block_free_2; eauto. } *) +(* split; i. *) +(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) +(* eapply Mem.free_can_access_block_inj_2; eauto. *) +(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) +(* eapply Mem.free_can_access_block_inj_2; eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_exists_mem_free_list *) +(* m m' *) +(* (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') *) +(* l cp m_f *) +(* (FREE: Mem.free_list m l cp = Some m_f) *) +(* : *) +(* exists m_f', Mem.free_list m' l cp = Some m_f'. *) +(* Proof. *) +(* move l after m. revert_until l. induction l; ii; ss; eauto. des_ifs. *) +(* 2:{ exfalso. hexploit wunchanged_on_exists_free. 2: eapply Heq0. 2: auto. *) +(* 2:{ intros. des. rewrite H in Heq; clarify. } *) +(* auto. *) +(* } *) +(* hexploit IHl. 2: eapply FREE. *) +(* { instantiate (1:=m0). eapply wunchanged_on_free_preserves; eauto. } *) +(* eauto. *) +(* Qed. *) + +(* Lemma mem_free_list_wunchanged_on *) +(* x m l cp m' *) +(* (FL: Mem.free_list m l cp = Some m') *) +(* (WF: Forall (fun '(b, lo, hi) => (x <= b)%positive) l) *) +(* : *) +(* wunchanged_on (fun b _ => (b < x)%positive) m m'. *) +(* Proof. *) +(* move WF before x. revert_until WF. induction WF; i; ss. clarify. apply wunchanged_on_refl. des_ifs. *) +(* hexploit IHWF; eauto. i. eapply wunchanged_on_trans. 2: eauto. *) +(* eapply free_wunchanged_on; eauto. *) +(* i. lia. *) +(* Qed. *) + +(* Lemma wunchanged_on_free_list_preserves *) +(* m m' *) +(* (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') *) +(* l cp m_f m_f' *) +(* (FREE: Mem.free_list m l cp = Some m_f) *) +(* (FREE': Mem.free_list m' l cp = Some m_f') *) +(* : *) +(* wunchanged_on (fun b _ => Mem.valid_block m_f b) m_f m_f'. *) +(* Proof. *) +(* move l after m. revert_until l. induction l; ii; ss. clarify. *) +(* des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves; eauto. *) +(* Qed. *) + +(* Lemma mem_delta_apply_wf_wunchanged_on *) +(* ge cp d m m' *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) +(* P *) +(* : *) +(* wunchanged_on P m m'. *) +(* Proof. *) +(* revert_until d. induction d; ii; ss. *) +(* { cbn in APPD. clarify. apply wunchanged_on_refl. } *) +(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs. *) +(* - hexploit mem_delta_apply_wf_some; eauto. intros (m0 & ST). rewrite ST in APPD. *) +(* specialize (IHd _ _ APPD). unfold mem_delta_apply_kind in ST. unfold mem_delta_apply_storev in ST. des_ifs. *) +(* ss. des_ifs. ss. eapply wunchanged_on_trans. eapply store_wunchanged_on. eapply ST. *) +(* eapply wunchanged_on_implies. eapply IHd. ss. *) +(* - eauto. *) +(* Unshelve. all: exact 0%nat. *) +(* Qed. *) + +(* Lemma alloc_variables_fresh_blocks *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* x *) +(* (X: (x <= Mem.nextblock m)%positive) *) +(* (FA: Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e)) *) +(* : *) +(* Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e'). *) +(* Proof. *) +(* revert_until EA. induction EA; ii; ss. specialize (IHEA x). *) +(* eapply IHEA; clear IHEA. *) +(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) +(* apply Forall_forall. rewrite Forall_forall in FA. ii. specialize (FA x0). des_ifs. *) +(* unfold blocks_of_env in H0. apply list_in_map_inv in H0. des. destruct x0 as (xid & xb & xt). *) +(* apply PTree.elements_complete in H1. destruct (Pos.eqb_spec id xid); clarify. *) +(* - rewrite PTree.gss in H1. ss. clarify. erewrite Mem.alloc_result. 2: eauto. auto. *) +(* - rewrite PTree.gso in H1; auto. apply FA. rewrite H0. unfold blocks_of_env. apply in_map. *) +(* apply PTree.elements_correct; auto. *) +(* Qed. *) + +(* Lemma alloc_variables_one_fresh_block *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* (NR: list_norepet (var_names params)) *) +(* xid xb xt *) +(* (NOT: e ! xid = None) *) +(* (GET: e' ! xid = Some (xb, xt)) *) +(* : *) +(* ~ (Mem.valid_block m xb). *) +(* Proof. *) +(* revert_until EA. induction EA; i. clarify. *) +(* inv NR. destruct (Pos.eqb_spec xid id). *) +(* { subst id. hexploit alloc_variables_wf_id. eauto. auto. eauto. apply PTree.gss. *) +(* i. rewrite GET in H0. clarify. eapply Mem.fresh_block_alloc; eauto. } *) +(* hexploit IHEA. auto. rewrite PTree.gso. eapply NOT. auto. eapply GET. i. *) +(* ii. apply H0. unfold Mem.valid_block in *. erewrite Mem.nextblock_alloc; eauto. *) +(* etransitivity. eapply H1. apply Plt_succ. *) +(* Qed. *) + +(* Lemma assign_loc_outside_mem_inject *) +(* ge cp ty m b ofs bf v m' *) +(* (AL: assign_loc ge cp ty m b ofs bf v m') *) +(* k m0 *) +(* (INJ: Mem.inject k m0 m) *) +(* (NIB: k b = None) *) +(* (MS: meminj_same_block k) *) +(* : *) +(* Mem.inject k m0 m'. *) +(* Proof. *) +(* inv AL. *) +(* - eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H1). clarify. *) +(* - eapply Mem.storebytes_outside_inject; eauto. i. specialize (MS _ _ _ H5). clarify. *) +(* - inv H. eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H). clarify. *) +(* Qed. *) + +(* Lemma bind_parameters_outside_mem_inject *) +(* ge cp e m_cur params vargs m_next *) +(* (BIND: bind_parameters ge cp e m_cur params vargs m_next) *) +(* k m *) +(* (INJ: Mem.inject k m m_cur) *) +(* (NIB: forall id b t, e ! id = Some (b, t) -> k b = None) *) +(* (MS: meminj_same_block k) *) +(* (* (NIB: not_inj_blks k (blocks_of_env2 ge e)) *) *) +(* : *) +(* Mem.inject k m m_next. *) +(* Proof. *) +(* revert_until BIND. induction BIND; ii. *) +(* { auto. } *) +(* apply IHBIND; auto. clear IHBIND. specialize (NIB _ _ _ H). *) +(* eapply assign_loc_outside_mem_inject; eauto. *) +(* Qed. *) + +(* Lemma not_inj_blks_get_env *) +(* k ge e *) +(* (NIB: not_inj_blks k (blocks_of_env2 ge e)) *) +(* : *) +(* forall id b t, e ! id = Some (b, t) -> k b = None. *) +(* Proof. *) +(* rr in NIB. unfold blocks_of_env2, blocks_of_env in NIB. rewrite map_map in NIB. *) +(* rewrite Forall_forall in NIB. i. apply PTree.elements_correct in H. *) +(* apply NIB. eapply (in_map (fun x : ident * (block * type) => fst (fst (block_of_binding ge x)))) in H. ss. *) +(* Qed. *) + +(* Lemma not_global_blks_get_env *) +(* (ge: genv) e *) +(* (NIB: not_global_blks ge (blocks_of_env2 ge e)) *) +(* : *) +(* forall id b t, e ! id = Some (b, t) -> (meminj_public ge) b = None. *) +(* Proof. eapply not_inj_blks_get_env. eapply not_global_is_not_inj_bloks. eauto. Qed. *) + +(* Lemma meminj_public_same_block *) +(* ge *) +(* : *) +(* meminj_same_block (meminj_public ge). *) +(* Proof. rr. unfold meminj_public. i. des_ifs. Qed. *) + +(* Lemma alloc_variables_mem_inject *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* k m0 *) +(* (INJ: Mem.inject k m0 m) *) +(* : *) +(* Mem.inject k m0 m'. *) +(* Proof. *) +(* revert_until EA. induction EA; ii. auto. *) +(* apply IHEA. clear IHEA. eapply Mem.alloc_right_inject; eauto. *) +(* Qed. *) + +(* Lemma mem_valid_access_wunchanged_on *) +(* m ch b ofs p cp *) +(* (MV: Mem.valid_access m ch b ofs p cp) *) +(* P m' *) +(* (WU: wunchanged_on P m m') *) +(* (SAT: forall ofs', P b ofs') *) +(* : *) +(* Mem.valid_access m' ch b ofs p cp. *) +(* Proof. *) +(* unfold Mem.valid_access in *. des. splits; auto. *) +(* - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on; eauto. *) +(* - destruct cp. 2: ss. erewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block; eauto. *) +(* Qed. *) + +(* Lemma mem_free_list_wunchanged_on_2 *) +(* l m cp m' *) +(* (FREE: Mem.free_list m l cp = Some m') *) +(* : *) +(* wunchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. *) +(* Proof. *) +(* revert_until l. induction l; ii. *) +(* { ss. clarify. apply wunchanged_on_refl. } *) +(* ss. des_ifs. eapply wunchanged_on_trans; cycle 1. *) +(* { eapply wunchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } *) +(* ss. eapply free_wunchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. *) +(* Qed. *) + +(* Lemma not_global_blks_global_not_in *) +(* (ge: genv) id b *) +(* (FIND: Genv.find_symbol ge id = Some b) *) +(* e *) +(* (NGB: not_global_blks ge (blocks_of_env2 ge e)) *) +(* : *) +(* ~ In b (map (fun x : block * Z * Z => fst (fst x)) (blocks_of_env ge e)). *) +(* Proof. *) +(* intros CONTRA. unfold not_global_blks in NGB. unfold blocks_of_env2, blocks_of_env in *. *) +(* rewrite map_map in NGB, CONTRA. rewrite Forall_forall in NGB. specialize (NGB _ CONTRA). *) +(* apply Genv.find_invert_symbol in FIND. setoid_rewrite FIND in NGB. inv NGB. *) +(* Qed. *) + +(* Lemma mem_free_list_unchanged_on *) +(* l m cp m' *) +(* (FREE: Mem.free_list m l cp = Some m') *) +(* : *) +(* Mem.unchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. *) +(* Proof. *) +(* revert_until l. induction l; ii. *) +(* { ss. clarify. apply Mem.unchanged_on_refl. } *) +(* ss. des_ifs. eapply Mem.unchanged_on_trans; cycle 1. *) +(* { eapply Mem.unchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } *) +(* ss. eapply Mem.free_unchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. *) +(* Qed. *) + +(* Lemma exists_vargs_vres *) +(* (ge1: Senv.t) (ge2: genv) *) +(* (MS: match_symbs ge1 ge2) *) +(* ef m1 vargs tr vretv m2 *) +(* (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) *) +(* e cp le m_c *) +(* (WFE: wf_env ge2 e) *) +(* : *) +(* (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) +(* (list_typ_to_typelist (sig_args (ef_sig ef))) vargs) /\ *) +(* (external_call ef ge2 vargs m_c tr vretv m_c). *) +(* Proof. *) +(* pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. *) +(* unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). *) +(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) +(* esplits. *) +(* + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. *) +(* + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. *) +(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) +(* esplits. *) +(* + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. *) +(* econs. 3: econs. *) +(* { instantiate (1:=v). destruct v; ss; try (econs; fail). *) +(* - destruct chunk; ss; inv H2; ss. *) +(* - destruct Archi.ptr64 eqn:ARCH. *) +(* + destruct chunk; ss; inv H2; ss; des_ifs. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* + destruct chunk; ss; inv H2; ss; des_ifs. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* } *) +(* { rewrite EK1 in H2. *) +(* destruct v; ss. *) +(* - destruct chunk; ss; inv H2; ss. *) +(* - destruct chunk; ss. all: simpl_expr. inv H2. *) +(* - destruct chunk; ss. all: simpl_expr. *) +(* - destruct chunk; ss. inv H2. *) +(* - destruct chunk; ss. all: inv H2. *) +(* - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. *) +(* rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss; simpl_expr. *) +(* + unfold Cop.sem_cast. ss. rewrite Heq. auto. *) +(* + unfold Cop.sem_cast. ss. rewrite Heq. auto. *) +(* } *) +(* + econs. econs; auto. rewrite MS3; auto. rewrite EK1. *) +(* rewrite EK1 in H2. eapply match_symbs_eventval_match; eauto. *) +(* - esplits. *) +(* + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. *) +(* erewrite <- eventval_list_match_list_eventval_to_list_val. *) +(* 2:{ eapply match_senv_eventval_list_match in H; eauto. } *) +(* eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. *) +(* eapply match_senv_eventval_list_match; eauto. *) +(* + econs. eapply match_senv_eventval_list_match; eauto. *) +(* - esplits. *) +(* + econs. 3: econs. *) +(* * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. *) +(* eapply match_senv_eventval_match; eauto. *) +(* * erewrite eventval_match_val_to_eventval. 2: eapply H. *) +(* erewrite eventval_match_eventval_to_val. *) +(* 2:{ eapply match_senv_eventval_match; eauto. } *) +(* eapply eventval_match_sem_cast. eapply match_senv_eventval_match; eauto. *) +(* + econs. eapply match_senv_eventval_match; eauto. *) +(* Qed. *) + +(* Lemma eventval_list_match_eval_exprlist *) +(* (ge: genv) args targs vargs *) +(* (EMS: eventval_list_match ge args targs vargs) *) +(* e cp le m *) +(* (WF: wf_env ge e) *) +(* : *) +(* eval_exprlist ge e cp le m (list_eventval_to_list_expr args) *) +(* (list_eventval_to_typelist args) vargs. *) +(* Proof. *) +(* revert_until EMS. induction EMS; i; ss. econs. *) +(* econs; auto. *) +(* { clear dependent evl. clear tyl vl. inv H; try (simpl_expr; fail). *) +(* ss. eapply ptr_of_id_ofs_eval; auto. *) +(* } *) +(* { clear dependent evl. clear tyl vl. inv H; ss; try (simpl_expr; fail). *) +(* rewrite ptr_of_id_ofs_typeof. ss. *) +(* } *) +(* Qed. *) + +(* Lemma exists_vargs_vres_2 *) +(* (ge1: Senv.t) (ge2: genv) *) +(* (MS: match_symbs ge1 ge2) *) +(* ef m1 vargs tr vretv m2 *) +(* (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) *) +(* e cp le m_c *) +(* (WFE: wf_env ge2 e) *) +(* : *) +(* exists vargs2 vretv2, *) +(* (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) +(* (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs2) /\ *) +(* (external_call ef ge2 vargs2 m_c tr vretv2 m_c). *) +(* Proof. *) +(* pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. *) +(* unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). *) +(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) +(* esplits. *) +(* + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. *) +(* + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. *) +(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) +(* esplits. *) +(* + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. *) +(* econs. 3: econs. *) +(* { instantiate (1:=v). destruct v; ss; try (econs; fail). *) +(* - destruct chunk; ss; inv H2; ss. *) +(* - destruct Archi.ptr64 eqn:ARCH. *) +(* + destruct chunk; ss; inv H2; ss; des_ifs. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* + destruct chunk; ss; inv H2; ss; des_ifs. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* } *) +(* { instantiate (1:=Val.load_result chunk v). rewrite EK1 in H2. rewrite EK1. *) +(* destruct v; ss. *) +(* - destruct chunk; ss; inv H2; ss. *) +(* - destruct chunk; ss. all: simpl_expr. *) +(* - destruct chunk; ss. all: simpl_expr. *) +(* - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. *) +(* rewrite ptr_of_id_ofs_typeof. simpl_expr. *) +(* } *) +(* + econs. econs; auto. rewrite MS3; auto. rewrite EK1. eapply match_symbs_eventval_match; eauto. *) +(* - esplits. *) +(* + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. *) +(* eapply eventval_list_match_eval_exprlist; eauto. *) +(* eapply match_senv_eventval_list_match; eauto. *) +(* + econs. eapply match_senv_eventval_list_match; eauto. *) +(* - esplits. *) +(* + econs. 3: econs. *) +(* * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. *) +(* eapply match_senv_eventval_match; eauto. *) +(* * inv H; ss; try (simpl_expr; fail). apply MS2 in H1. setoid_rewrite H1. *) +(* rewrite ptr_of_id_ofs_typeof. ss. *) +(* + econs. eapply match_senv_eventval_match; eauto. *) +(* Qed. *) + +(* Lemma known_obs_preserves_mem *) +(* ef ge m vargs tr vretv m' *) +(* (EK: external_call_known_observables ef ge m vargs tr vretv m') *) +(* : *) +(* m' = m. *) +(* Proof. *) +(* unfold external_call_known_observables in EK. des_ifs; des; inv EK; clarify. inv H; clarify. *) +(* Qed. *) + +(* Lemma meminj_first_order_public_first_order *) +(* ge m *) +(* (MFO: meminj_first_order (meminj_public ge) m) *) +(* : *) +(* public_first_order ge m. *) +(* Proof. *) +(* ii. apply MFO; auto. unfold meminj_public. apply Senv.find_invert_symbol in FIND. *) +(* rewrite FIND. rewrite PUBLIC. ss. *) +(* Qed. *) + +(* Lemma vals_public_eval_to_vargs *) +(* (ge: genv) ef vargs *) +(* (VP: vals_public ge (sig_args (ef_sig ef)) vargs) *) +(* e cp le m *) +(* (WFE: wf_env ge e) *) +(* : *) +(* eval_exprlist ge e cp le m *) +(* (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) *) +(* (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. *) +(* Proof. *) +(* induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. *) +(* - clear dependent l. clear dependent l'. *) +(* inv H; ss; try (simpl_expr; fail). *) +(* destruct H0 as (id & BP1 & BP2). *) +(* unfold senv_invert_symbol_total. rewrite BP1. *) +(* apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. *) +(* - clear dependent l. clear dependent l'. *) +(* inv H; ss; try (simpl_expr; fail). *) +(* destruct H0 as (id & BP1 & BP2). *) +(* unfold senv_invert_symbol_total. rewrite BP1. *) +(* rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss. *) +(* + unfold Cop.sem_cast. ss. rewrite Heq. ss. *) +(* + unfold Cop.sem_cast. ss. rewrite Heq. ss. *) +(* Qed. *) + +(* Lemma vals_public_eval_to_vargs_2 *) +(* (ge: genv) ef vargs *) +(* (VP: vals_public ge (sig_args (ef_sig ef)) vargs) *) +(* e cp le m *) +(* (WFE: wf_env ge e) *) +(* : *) +(* eval_exprlist ge e cp le m *) +(* (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) *) +(* (list_eventval_to_typelist (vals_to_eventvals ge vargs)) vargs. *) +(* Proof. *) +(* induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. *) +(* - clear dependent l. clear dependent l'. *) +(* inv H; ss; try (simpl_expr; fail). *) +(* destruct H0 as (id & BP1 & BP2). *) +(* unfold senv_invert_symbol_total. rewrite BP1. *) +(* apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. *) +(* - clear dependent l. clear dependent l'. *) +(* inv H; ss; try (simpl_expr; fail). *) +(* destruct H0 as (id & BP1 & BP2). *) +(* unfold senv_invert_symbol_total. rewrite BP1. *) +(* rewrite ptr_of_id_ofs_typeof. ss. *) +(* Qed. *) + +(* Lemma match_symbs_block_public *) +(* ge1 ge2 *) +(* (MS: match_symbs ge1 ge2) *) +(* b *) +(* (BP: block_public ge1 b) *) +(* : *) +(* block_public ge2 b. *) +(* Proof. *) +(* destruct MS as (MS1 & MS2 & MS3). destruct BP as (id & BP1 & BP2). *) +(* apply Senv.invert_find_symbol in BP1. apply MS2 in BP1. rewrite <- MS1 in BP2. *) +(* unfold block_public. esplits; eauto. apply Senv.find_invert_symbol; auto. *) +(* Qed. *) + +(* Lemma match_symbs_vals_public *) +(* ge1 ge2 *) +(* (MS: match_symbs ge1 ge2) *) +(* tys vargs *) +(* (VP: vals_public ge1 tys vargs) *) +(* : *) +(* vals_public ge2 tys vargs. *) +(* Proof. *) +(* induction VP; ss. econs; auto. clear VP IHVP. inv H; econs; auto. *) +(* eapply match_symbs_block_public; eauto. *) +(* Qed. *) + +(* Lemma match_symbs_vals_public_vals_to_eventvals *) +(* ge1 ge2 *) +(* (MS: match_symbs ge1 ge2) *) +(* tys vargs *) +(* (VP: vals_public ge1 tys vargs) *) +(* : *) +(* vals_to_eventvals ge1 vargs = vals_to_eventvals ge2 vargs. *) +(* Proof. *) +(* induction VP; ss. f_equal; auto. clear dependent l. clear dependent l'. *) +(* inv H; ss. destruct H0 as (id & BP1 & BP2). *) +(* unfold senv_invert_symbol_total at 1. des_ifs. *) +(* destruct MS as (MS0 & MS1 & MS2). *) +(* apply Senv.invert_find_symbol in Heq. apply MS1 in Heq. *) +(* unfold senv_invert_symbol_total at 1. apply Senv.find_invert_symbol in Heq. *) +(* rewrite Heq. auto. *) +(* Qed. *) + +(* Lemma match_symbs_vals_public_eval_to_vargs *) +(* ge1 (ge2: genv) *) +(* (MS: match_symbs ge1 ge2) *) +(* ef vargs *) +(* (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) *) +(* e cp le m *) +(* (WFE: wf_env ge2 e) *) +(* : *) +(* eval_exprlist ge2 e cp le m *) +(* (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) +(* (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. *) +(* Proof. *) +(* erewrite match_symbs_vals_public_vals_to_eventvals; eauto. *) +(* eapply vals_public_eval_to_vargs; auto. eapply match_symbs_vals_public; eauto. *) +(* Qed. *) + +(* Lemma match_symbs_vals_public_eval_to_vargs_2 *) +(* ge1 (ge2: genv) *) +(* (MS: match_symbs ge1 ge2) *) +(* ef vargs *) +(* (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) *) +(* e cp le m *) +(* (WFE: wf_env ge2 e) *) +(* : *) +(* eval_exprlist ge2 e cp le m *) +(* (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) +(* (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs. *) +(* Proof. *) +(* erewrite match_symbs_vals_public_vals_to_eventvals; eauto. *) +(* eapply vals_public_eval_to_vargs_2; auto. eapply match_symbs_vals_public; eauto. *) +(* Qed. *) + +(* Lemma extcall_unkowns_vals_public *) +(* ef ge m vargs *) +(* (EC: external_call_unknowns ef ge m vargs) *) +(* : *) +(* vals_public ge (sig_args (ef_sig ef)) vargs. *) +(* Proof. *) +(* unfold external_call_unknowns in EC. des_ifs; ss; auto. *) +(* all: destruct EC as (EC1 & EC2); auto. *) +(* Qed. *) + + +(* Lemma mem_unchanged_wunchanged *) +(* P m m' *) +(* (UCH: Mem.unchanged_on P m m') *) +(* : *) +(* wunchanged_on P m m'. *) +(* Proof. inv UCH. econs; eauto. Qed. *) + +(* Lemma meminj_public_not_public_not_mapped *) +(* ge cnt_cur *) +(* (NP: Senv.public_symbol ge cnt_cur = false) *) +(* cnt_cur_b *) +(* (FIND: Senv.find_symbol ge cnt_cur = Some cnt_cur_b) *) +(* : *) +(* forall b ofs, meminj_public ge b <> Some (cnt_cur_b, ofs). *) +(* Proof. *) +(* ii. unfold meminj_public in H. des_ifs. *) +(* assert (i = cnt_cur). *) +(* { eapply Senv.find_symbol_injective; eauto. apply Senv.invert_find_symbol; auto. } *) +(* subst i. rewrite NP in Heq0. ss. *) +(* Qed. *) + + +(* Lemma wunchanged_on_exists_mem_free_gen *) +(* m1 b lo hi cp m2 *) +(* (FREE: Mem.free m1 b lo hi cp = Some m2) *) +(* (P: block -> Prop) m_c *) +(* (WCH: wunchanged_on (fun b _ => P b) m1 m_c) *) +(* (NGB: P b) *) +(* : *) +(* exists m_c', Mem.free m_c b lo hi cp = Some m_c'. *) +(* Proof. *) +(* hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. *) +(* hexploit Mem.range_perm_free. *) +(* 3:{ intros (m0 & F). eexists; eapply F. } *) +(* - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. *) +(* - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_exists_mem_free_2 *) +(* m1 b lo hi cp m2 *) +(* (FREE: Mem.free m1 b lo hi cp = Some m2) *) +(* ge m_c *) +(* (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) *) +(* (NGB: Senv.invert_symbol ge b = None) *) +(* : *) +(* exists m_c', Mem.free m_c b lo hi cp = Some m_c'. *) +(* Proof. eapply wunchanged_on_exists_mem_free_gen; eauto. eapply WCH. ss. Qed. *) + +(* Lemma wunchanged_on_free_preserves_gen *) +(* P m m' *) +(* (WU : wunchanged_on P m m') *) +(* b lo hi cp m1 m1' *) +(* (FREE: Mem.free m b lo hi cp = Some m1) *) +(* (FREE': Mem.free m' b lo hi cp = Some m1') *) +(* : *) +(* wunchanged_on P m1 m1'. *) +(* Proof. *) +(* inv WU. econs. *) +(* - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. *) +(* - i. assert (VB: Mem.valid_block m b0). *) +(* { eapply Mem.valid_block_free_2; eauto. } *) +(* split; i. *) +(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. *) +(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) +(* hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. *) +(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. *) +(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) +(* hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. *) +(* - i. assert (VB: Mem.valid_block m b0). *) +(* { eapply Mem.valid_block_free_2; eauto. } *) +(* split; i. *) +(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) +(* eapply Mem.free_can_access_block_inj_2; eauto. *) +(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) +(* eapply Mem.free_can_access_block_inj_2; eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_exists_mem_free_list_gen *) +(* l m1 cp m2 *) +(* (FREE: Mem.free_list m1 l cp = Some m2) *) +(* (P: block -> Prop) m_c *) +(* (WCH: wunchanged_on (fun b _ => P b) m1 m_c) *) +(* (NGB: Forall P (map (fun x => fst (fst x)) l)) *) +(* : *) +(* exists m_c', Mem.free_list m_c l cp = Some m_c'. *) +(* Proof. *) +(* revert_until l. induction l; i; ss. eauto. *) +(* destruct a as ((b & lo) & hi). ss. inv NGB. des_ifs; ss. *) +(* 2:{ exfalso. hexploit wunchanged_on_exists_mem_free_gen. 2: eapply WCH. all: eauto. *) +(* intros. des. rewrite H in Heq; clarify. *) +(* } *) +(* hexploit IHl. eapply FREE. 2: eapply H2. *) +(* { instantiate (1:=m). eapply wunchanged_on_free_preserves_gen; eauto. } *) +(* eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_exists_mem_free_list_2 *) +(* l m1 cp m2 *) +(* (FREE: Mem.free_list m1 l cp = Some m2) *) +(* ge m_c *) +(* (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) *) +(* (NGB: not_global_blks ge (map (fun x => fst (fst x)) l)) *) +(* : *) +(* exists m_c', Mem.free_list m_c l cp = Some m_c'. *) +(* Proof. eapply wunchanged_on_exists_mem_free_list_gen; eauto. ss. Qed. *) + +(* Lemma wunchanged_on_free_list_preserves_gen *) +(* P m m' *) +(* (WU: wunchanged_on P m m') *) +(* l cp m_f m_f' *) +(* (FREE: Mem.free_list m l cp = Some m_f) *) +(* (FREE': Mem.free_list m' l cp = Some m_f') *) +(* : *) +(* wunchanged_on P m_f m_f'. *) +(* Proof. *) +(* move l after m. revert_until l. induction l; ii; ss. clarify. *) +(* des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves_gen; eauto. *) +(* Qed. *) + +(* Lemma meminj_not_alloc_external_call *) +(* j m1 *) +(* (NA: meminj_not_alloc j m1) *) +(* ef ge vargs tr vretv m2 *) +(* (EC: external_call ef ge vargs m1 tr vretv m2) *) +(* : *) +(* meminj_not_alloc j m2. *) +(* Proof. *) +(* unfold meminj_not_alloc in *. i. apply NA. clear NA. *) +(* eapply external_call_nextblock in EC. etransitivity. 2: eapply H. auto. *) +(* Qed. *) + +(* Lemma public_first_order_meminj_first_order *) +(* (ge: Senv.t) m *) +(* (FO: public_first_order ge m) *) +(* : *) +(* meminj_first_order (meminj_public ge) m. *) +(* Proof. *) +(* ii. unfold meminj_public in H. des_ifs. eapply FO; eauto. *) +(* apply Senv.invert_find_symbol; auto. *) +(* Qed. *) + +(* Lemma list_length_filter_le *) +(* A P (l: list A) *) +(* : *) +(* (Datatypes.length (filter P l) <= Datatypes.length l)%nat. *) +(* Proof. *) +(* induction l; ss. des_ifs; ss; auto. rewrite <- Nat.succ_le_mono. auto. *) +(* Qed. *) + +(* End PROOF. *) diff --git a/security/BacktranslationProof.v b/security/BacktranslationProof.v new file mode 100644 index 0000000000..56302dd62a --- /dev/null +++ b/security/BacktranslationProof.v @@ -0,0 +1,2229 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Require Import Tactics. +Require Import riscV.Asm. +Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. +Require Import Ctypes Clight. +Require Import Backtranslation BacktranslationAux. + + + +(* Section INVS. *) + +(* Definition cnt_ids := PTree.t ident. *) + +(* Definition wf_counter (ge: Senv.t) (m: mem) cp (n: nat) (cnt: ident): Prop := *) +(* (Senv.public_symbol ge cnt = false) /\ *) +(* exists b, (Senv.find_symbol ge cnt = Some b) /\ *) +(* (Mem.valid_access m Mint64 b 0 Writable (Some cp)) /\ *) +(* (Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (nat64 n))). *) + +(* Definition wf_counters (ge_a: Asm.genv) (ge: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := *) +(* (forall id0 id1 cnt, (cnts ! id0 = Some cnt) -> (cnts ! id1 = Some cnt) -> (id0 = id1)) /\ *) +(* (forall id b gd, *) +(* (Genv.find_symbol ge_a id = Some b) -> *) +(* (Genv.find_def ge_a b = Some gd) -> *) +(* (exists cnt, (cnts ! id = Some cnt) /\ *) +(* (wf_counter ge m (comp_of gd) (length (get_id_tr tr id)) cnt))). *) + +(* Inductive wf_c_cont (ge: Clight.genv) : mem -> cont -> Prop := *) +(* | wf_c_cont_nil *) +(* m *) +(* : *) +(* wf_c_cont ge m Kstop *) +(* | wf_c_cont_cons *) +(* m ck *) +(* f e le s1 s2 m' ck' *) +(* (WFENV: wf_env ge e) *) +(* (NINJ: not_global_blks (ge) (blocks_of_env2 ge e)) *) +(* (CK: ck = Kcall None f e le (Kloop1 s1 s2 ck')) *) +(* (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') *) +(* (IND: wf_c_cont ge m' ck') *) +(* : *) +(* wf_c_cont ge m ck. *) + +(* Definition wf_c_stmt (ge: Senv.t) cp cnts id tr stmt := *) +(* forall cnt, (cnts ! id = Some cnt) -> stmt = code_bundle_trace ge cp cnt (get_id_tr tr id). *) + +(* Definition wf_c_nb (ge: Clight.genv) (m: mem) := *) +(* (Genv.genv_next ge <= Mem.nextblock m)%positive. *) + +(* Definition wf_c_state ge_a (ge: Clight.genv) (tr ttr: bundle_trace) (cnts: cnt_ids) id (cst: Clight.state) := *) +(* match cst with *) +(* | State f stmt k_c e le m_c => *) +(* wf_counters ge_a ge m_c tr cnts /\ *) +(* (exists m_c', Mem.free_list m_c (blocks_of_env ge e) (comp_of f) = Some m_c' /\ wf_c_cont ge m_c' k_c) /\ *) +(* wf_c_stmt ge (comp_of f) cnts id ttr stmt /\ *) +(* (wf_env ge e /\ (not_global_blks (ge) (blocks_of_env2 ge e)) /\ (wf_c_nb ge m_c)) *) +(* | _ => False *) +(* end. *) + +(* Definition match_genv (ge: Asm.genv) (ge': genv) := *) +(* (match_symbs ge ge') /\ (eq_policy ge ge'). *) + +(* Definition match_mem (ge: Senv.t) (k: meminj) (m_i m_c: mem): Prop := *) +(* let j := meminj_public ge in *) +(* (Mem.inject k m_i m_c) /\ (inject_incr j k) /\ (meminj_not_alloc j m_i). *) + +(* Definition match_cur_fun (ge_i: Asm.genv) (ge_c: genv) (cur: block) f (id: ident): Prop := *) +(* (Genv.find_funct_ptr ge_c cur = Some (Internal f)) /\ *) +(* (exists f_i, Genv.find_funct_ptr ge_i cur = Some (AST.Internal f_i)) /\ *) +(* (Genv.invert_symbol ge_i cur = Some id). *) + +(* Definition match_find_def (ge_i: Asm.genv) (ge_c: Clight.genv) (cnts: cnt_ids) (pars: params_of) tr := *) +(* forall b gd_i id, *) +(* Genv.find_def ge_i b = Some gd_i -> *) +(* Senv.invert_symbol ge_i b = Some id -> *) +(* match (cnts ! id), (pars ! id) with *) +(* | Some cnt, Some params => *) +(* Genv.find_def ge_c b = Some (gen_globdef ge_i cnt params (get_id_tr tr id) gd_i) *) +(* | _, _ => False *) +(* end. *) + +(* Inductive match_cont (ge: Clight.genv) (tr: bundle_trace) (cnts: cnt_ids) : (cont) -> (ir_conts) -> Prop := *) +(* | match_cont_nil *) +(* ck ik *) +(* (CK: ck = Kstop) *) +(* (IK: ik = nil) *) +(* : *) +(* match_cont ge tr cnts ck ik *) +(* | match_cont_cons *) +(* ck ik *) +(* f e le cnt id ck' *) +(* b ik' *) +(* (FUN: Genv.find_funct_ptr ge b = Some (Internal f)) *) +(* (ID: Genv.invert_symbol ge b = Some id) *) +(* (CNT: cnts ! id = Some cnt) *) +(* (CK: ck = Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge cnt (comp_of f) (get_id_tr tr id))) Sskip ck')) *) +(* (IK: ik = (ir_cont b) :: ik') *) +(* (IND: match_cont ge tr cnts ck' ik') *) +(* : *) +(* match_cont ge tr cnts ck ik. *) + +(* Definition match_params pars (ge_c: genv) (ge_i: Asm.genv) := *) +(* (wf_params_of pars) /\ (wf_params_of_sig pars ge_i) /\ (wf_params_of_symb pars ge_c). *) + +(* Definition match_cnts cnts (ge_c: genv) (k: meminj) := *) +(* forall id cnt cnt_b, (cnts ! id = Some cnt) -> (Genv.find_symbol ge_c cnt = Some cnt_b) -> *) +(* (forall b ofs, k b <> Some (cnt_b, ofs)). *) + +(* Definition match_state (ge_i: Asm.genv) (ge_c: Clight.genv) (k: meminj) tr cnts pars id (ist: ir_state) (cst: Clight.state) := *) +(* match ist, cst with *) +(* | Some (cur, m_i, k_i), State f _ k_c e le m_c => *) +(* (match_genv ge_i ge_c) /\ (match_mem ge_i k m_i m_c) /\ *) +(* (match_cur_fun ge_i ge_c cur f id) /\ (match_find_def ge_i ge_c cnts pars tr) /\ *) +(* (match_cont ge_c tr cnts k_c k_i) /\ *) +(* (match_params pars ge_c ge_i) /\ *) +(* (match_cnts cnts ge_c k) *) +(* | _, _ => False *) +(* end. *) + +(* End INVS. *) + + + +(* Section PROOF. *) + +(* Lemma cur_fun_def *) +(* ge_i (ge_c: genv) cur f (f_i_cur : Asm.function) id_cur cnts pars ttr *) +(* (FINDF_C_CUR : Genv.find_funct_ptr ge_c cur = Some (Internal f)) *) +(* (FINDF_I_CUR : Genv.find_funct_ptr ge_i cur = Some (AST.Internal f_i_cur)) *) +(* (INV_CUR : Genv.invert_symbol ge_i cur = Some id_cur) *) +(* (MS3 : match_find_def ge_i ge_c cnts pars ttr) *) +(* : *) +(* exists cnt_cur params_cur, *) +(* (cnts ! id_cur = Some cnt_cur) /\ (pars ! id_cur = Some params_cur) /\ *) +(* (f = gen_function ge_i cnt_cur params_cur (get_id_tr ttr id_cur) f_i_cur). *) +(* Proof. *) +(* exploit MS3. eapply Genv.find_funct_ptr_iff. eauto. eapply INV_CUR. intros. des_ifs. *) +(* esplits; eauto. apply Genv.find_funct_ptr_iff in FINDF_C_CUR. *) +(* setoid_rewrite FINDF_C_CUR in x0. unfold gen_globdef in x0. clarify. *) +(* Qed. *) + +(* Lemma wf_c_cont_wunchanged_on *) +(* ge m k *) +(* (WFC: wf_c_cont ge m k) *) +(* m' *) +(* (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') *) +(* : *) +(* wf_c_cont ge m' k. *) +(* Proof. *) +(* revert_until WFC. induction WFC; ii. econs. *) +(* clarify. *) +(* hexploit wunchanged_on_exists_mem_free_list. eapply WU. eapply FREE. intros (m_f & FREE2). *) +(* econs. 1,2,3: eauto. eapply FREE2. eapply IHWFC. *) +(* eapply wunchanged_on_free_list_preserves. eapply WU. all: eauto. *) +(* Qed. *) + +(* Lemma star_cut_middle *) +(* stepk ge_a ge_c cst1 ev pretr ttr cnts ge_i pars ist2 *) +(* (CUT: exists tr1 cst', *) +(* (star stepk ge_c cst1 tr1 cst') /\ *) +(* exists tr2 cst2, *) +(* (star stepk ge_c cst' tr2 cst2) /\ *) +(* ((exists id', (wf_c_state ge_a ge_c (pretr ++ [ev]) ttr cnts id' cst2) /\ *) +(* exists k, (match_state ge_i ge_c k ttr cnts pars id' ist2 cst2)) *) +(* \/ (ist2 = None)) /\ *) +(* (unbundle ev = tr1 ++ tr2)) *) +(* : *) +(* exists cst2, (star stepk ge_c cst1 (unbundle ev) cst2) /\ *) +(* ((exists id', (wf_c_state ge_a ge_c (pretr ++ [ev]) ttr cnts id' cst2) /\ *) +(* exists k, (match_state ge_i ge_c k ttr cnts pars id' ist2 cst2)) *) +(* \/ (ist2 = None)). *) +(* Proof. *) +(* destruct CUT as (tr1 & cts' & STAR1 & tr2 & cst2 & STAR2 & PROP & TR). *) +(* exists cst2. split; auto. eapply star_trans. eapply STAR1. eapply STAR2. auto. *) +(* Qed. *) + +(* Lemma mem_inject_incr_match_cnts_rev *) +(* k1 k2 *) +(* (INCR: inject_incr k1 k2) *) +(* cnts ge *) +(* (MC: match_cnts cnts ge k2) *) +(* : *) +(* match_cnts cnts ge k1. *) +(* Proof. *) +(* unfold match_cnts in *. i. specialize (MC _ _ _ H H0 b ofs). ii. apply MC; clear MC. apply INCR. auto. *) +(* Qed. *) + +(* Lemma wf_c_cont_wunchanged_on_2 *) +(* ge m k *) +(* (WF: wf_c_cont ge m k) *) +(* m' *) +(* (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m m') *) +(* : *) +(* wf_c_cont ge m' k. *) +(* Proof. *) +(* revert_until WF. induction WF; i; ss. econs. *) +(* clarify. hexploit wunchanged_on_exists_mem_free_list_2. *) +(* eapply FREE. instantiate (2:=ge). eapply WCH. auto. *) +(* intros (m_c' & FREE2). *) +(* econs. eauto. auto. eauto. eapply FREE2. eapply IHWF. *) +(* eapply wunchanged_on_free_list_preserves_gen. 2,3: eauto. auto. *) +(* Qed. *) + +(* Lemma wf_c_nb_wunchanged_on *) +(* P m1 m2 *) +(* (WCH: wunchanged_on P m1 m2) *) +(* ge *) +(* (WFNB: wf_c_nb ge m1) *) +(* : *) +(* wf_c_nb ge m2. *) +(* Proof. *) +(* unfold wf_c_nb in *. hexploit wunchanged_on_nextblock. eapply WCH. *) +(* intros. etransitivity. eapply WFNB. auto. *) +(* Qed. *) + + + +(* Lemma ir_to_clight_step_cce_1 *) +(* (ge_i: Asm.genv) (ge_c: genv) *) +(* (WFGE : wf_ge ge_i) *) +(* cnts pars k_i cur m_i pretr btr (tr tr' : trace) id0 evargs ef id_cur d *) +(* (BOUND : Z.of_nat *) +(* (Datatypes.length *) +(* (pretr ++ (id_cur, Bundle_call tr' id0 evargs (ef_sig ef) d) :: btr)) < *) +(* Int64.modulus) *) +(* k_c id f stmt k0 e le m_c *) +(* (MS0 : match_genv ge_i ge_c) *) +(* (MS1 : match_mem ge_i k_c m_i m_c) *) +(* (MS2 : match_cur_fun ge_i ge_c cur f id) *) +(* (MS4 : match_cont ge_c (pretr ++ (id_cur, Bundle_call tr' id0 evargs (ef_sig ef) d) :: btr) cnts *) +(* k0 k_i) *) +(* (MS3 : match_find_def ge_i ge_c cnts pars *) +(* (pretr ++ (id_cur, Bundle_call tr' id0 evargs (ef_sig ef) d) :: btr)) *) +(* (MS5 : match_params pars ge_c ge_i) *) +(* (MCNTS : match_cnts cnts ge_c k_c) *) +(* (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), *) +(* cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) *) +(* (WFC0 : forall (id : ident) (b : block) gd, *) +(* Genv.find_symbol ge_i id = Some b -> *) +(* Genv.find_def ge_i b = Some gd -> *) +(* exists cnt : ident, *) +(* cnts ! id = Some cnt /\ *) +(* wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) *) +(* m_freeenv *) +(* (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) *) +(* (WFC1 : wf_c_cont ge_c m_freeenv k0) *) +(* (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id *) +(* (pretr ++ (id_cur, Bundle_call tr' id0 evargs (ef_sig ef) d) :: btr) stmt) *) +(* (WFC3 : wf_env ge_c e) *) +(* (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) *) +(* (WFNB : wf_c_nb ge_c m_c) *) +(* vargs b *) +(* (FINDB : Genv.find_symbol ge_i id0 = Some b) *) +(* (FINDF : Genv.find_funct ge_i (Vptr b Ptrofs.zero) = Some (AST.External ef)) *) +(* (NPTR : crossing_comp ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (comp_of ef) -> *) +(* Forall not_ptr vargs) *) +(* (ALLOW : Genv.allowed_call ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) *) +(* (Vptr b Ptrofs.zero)) *) +(* (TR : call_trace_cross ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) *) +(* (comp_of ef) b vargs (sig_args (ef_sig ef)) tr id0 evargs) *) +(* (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) *) +(* m2 *) +(* (DELTA: mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = Some m2) *) +(* (DELTA_CASES: (public_first_order ge_i m2) \/ (d = [])) *) +(* (TR_APP: exists tr0, tr' = tr ++ tr0) *) +(* : *) +(* exists cnt_cur cnt_cur_b, *) +(* (cnts ! id_cur = Some cnt_cur /\ Senv.find_symbol ge_c cnt_cur = Some cnt_cur_b /\ Senv.public_symbol ge_c cnt_cur = false) /\ *) +(* let dsg := from_sig_fun_data (ef_sig ef) in *) +(* let fd_next := (External ef (dargs dsg) (dret dsg) (dcc dsg)) in *) +(* exists m_c', *) +(* (star step1 ge_c (State f stmt k0 e le m_c) *) +(* (tr) *) +(* (Callstate fd_next vargs *) +(* (Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr (pretr ++ (id_cur, Bundle_call tr' id0 evargs (ef_sig ef) d) :: btr) id_cur))) Sskip k0)) m_c')) *) +(* /\ *) +(* (exists m_cu, *) +(* (Mem.storev Mint64 m_c (Vptr cnt_cur_b Ptrofs.zero) (Vlong (Int64.add (nat64 (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr pretr id_cur)))) Int64.one)) (comp_of f) = Some m_cu) /\ *) +(* (d = [] -> m_c' = m_cu) /\ *) +(* ((public_first_order ge_i m2) -> *) +(* (mem_delta_apply_wf ge_i (comp_of f) d (Some m_cu) = Some m_c') /\ *) +(* (Mem.inject (meminj_public ge_i) m2 m_c'))) *) +(* . *) +(* Proof. *) +(* assert (id = id_cur). *) +(* { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } *) +(* subst id. *) +(* destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). *) + +(* exploit MS3. *) +(* { eapply Genv.find_funct_ptr_iff. erewrite <- Genv.find_funct_find_funct_ptr. eapply FINDF. } *) +(* { eapply Genv.find_invert_symbol; eauto. } *) +(* intros FINDF_C. des_ifs. rename id0 into id_next, i into cnt_next, Heq into CNTS_NEXT, l into params_next, Heq0 into PARS_NEXT. simpl in FINDF_C. *) +(* set (pretr ++ (id_cur, Bundle_call tr' id_next evargs (ef_sig ef) d) :: btr) as ttr in *. *) +(* assert (FIND_CUR_I: Genv.find_symbol ge_i id_cur = Some cur). *) +(* { apply Genv.invert_find_symbol in IDCUR. auto. } *) +(* assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1 in FIND_CUR_I. auto. } *) +(* assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). *) +(* { auto. } *) + +(* exploit WFC0. eapply FIND_CUR_I. rewrite <- Genv.find_funct_ptr_iff; eapply FINDF_I_CUR. *) +(* intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). *) +(* destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). *) +(* exists cnt_cur, cnt_cur_b. split. auto. *) +(* set (Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)) as kc_next. *) +(* assert (CUR_TR: get_id_tr ttr id_cur = (get_id_tr pretr id_cur) ++ (id_cur, Bundle_call tr' id_next evargs (ef_sig ef) d) :: (get_id_tr btr id_cur)). *) +(* { subst ttr. clear. rewrite get_id_tr_app. rewrite get_id_tr_cons. ss. rewrite Pos.eqb_refl. auto. } *) +(* assert (BOUND2: Z.of_nat (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr ttr id_cur))) < Int64.modulus). *) +(* { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. *) +(* apply inj_le. apply list_length_filter_le. *) +(* } *) + +(* hexploit cur_fun_def. eapply FINDF_C_CUR. eapply FINDF_I_CUR. eapply IDCUR. eauto. *) +(* intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). *) +(* rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. *) +(* assert (CP_CUR: (comp_of f) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). *) +(* { unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. subst f. ss. } *) +(* assert (COMP_CUR_EQ: comp_of (@Gfun _ unit (AST.Internal f_i_cur)) = comp_of f). *) +(* { subst f. ss. } *) +(* setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_VA. setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_LOAD. *) + +(* hexploit switch_spec. *) +(* { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } *) +(* { unfold wf_env in WFC3. specialize (WFC3 cnt_cur). des_ifs. eapply WFC3. } *) +(* eapply FIND_CNT_CUR. eapply CNT_CUR_MEM_VA. *) +(* { rewrite CNT_CUR_MEM_LOAD. rewrite map_length. auto. } *) +(* instantiate (1:=le). *) +(* instantiate (1:=(Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)). *) +(* instantiate (1:=Sreturn None). *) +(* intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). *) + +(* assert (DELTA_C: exists m_c', *) +(* (mem_delta_apply_wf ge_i (comp_of f) d (Some m_cu) = Some m_c') /\ *) +(* (((public_first_order ge_i m2) -> (Mem.inject (meminj_public ge_i) m2 m_c')))). *) +(* { move MS1 after CUR_SWITCH_STAR. destruct MS1 as (MINJ & INJINCR & NALLOC). *) +(* move DELTA after NALLOC. *) +(* hexploit mem_delta_apply_establish_inject_preprocess_gen. *) +(* apply MINJ. eapply CNT_CUR_STORE. *) +(* { instantiate (1:=ge_i). erewrite match_symbs_meminj_public. 2: destruct MS0 as (MS & _); apply MS. *) +(* ii. eapply meminj_public_not_public_not_mapped. 3: apply H. 2: eauto. auto. *) +(* } *) +(* apply INJINCR. apply NALLOC. apply DELTA. *) +(* intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. *) +(* rewrite CP_CUR. auto. i. apply INJ'. apply public_first_order_meminj_first_order; auto. *) +(* } *) +(* desH DELTA_C. rename DELTA_C0 into MEMINJ_CNT. *) + +(* exists m_c'. split; cycle 1. *) +(* { exists m_cu. split; auto. split. *) +(* - i. subst d. unfold mem_delta_apply_wf in DELTA_C. ss. clarify. *) +(* - i. split; auto. *) +(* } *) + +(* unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. *) +(* eapply star_trans. eapply code_bundle_trace_spec. 2: ss. *) +(* unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. *) +(* rewrite ! (match_symbs_code_bundle_call ge_i ge_c) in CUR_SWITCH_STAR. *) +(* rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. *) +(* eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: apply MS0. *) +(* clear BOUND2 CUR_SWITCH_STAR. *) +(* unfold code_bundle_call. eapply star_trans. eapply code_mem_delta_correct. auto. *) +(* { erewrite <- match_symbs_mem_delta_apply_wf. eapply DELTA_C. apply MS0. } *) +(* 2: ss. *) +(* unfold unbundle. simpl. rename b into next. *) + +(* assert (CP_NEXT: (Genv.find_comp ge_c (Vptr next Ptrofs.zero)) = (comp_of ef)). *) +(* { unfold Genv.find_comp. apply Genv.find_funct_ptr_iff in FINDF_C. setoid_rewrite FINDF_C. ss. } *) +(* assert (EVARGS: list_eventval_to_list_val ge_c evargs = vargs). *) +(* { destruct MS0 as (MSENV & MGENV). inv TR. *) +(* eapply eventval_list_match_list_eventval_to_list_val. eapply match_symbs_eventval_list_match; eauto. *) +(* } *) + +(* econs 2. *) +(* { eapply step_call. ss. *) +(* { econs. assert (FSN_C: Senv.find_symbol ge_c id_next = Some next). *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1. auto. } *) +(* eapply eval_Evar_global. *) +(* - unfold wf_env in WFC3. specialize (WFC3 id_next). rewrite FSN_C in WFC3. apply WFC3. *) +(* - eapply FSN_C. *) +(* - econs 2. ss. *) +(* } *) +(* { eapply list_eventval_to_expr_val_eval. auto. inv TR. eapply eventval_list_match_transl. eapply match_senv_eventval_list_match; eauto. destruct MS0 as (MSENV & _); auto. } *) +(* { unfold match_find_def in MS3. hexploit MS3. *) +(* unfold Genv.find_funct in FINDF. rewrite pred_dec_true in FINDF; auto. unfold Genv.find_funct_ptr in FINDF. des_ifs. eapply Heq. *) +(* eapply Senv.find_invert_symbol; eapply FINDB. *) +(* rewrite CNTS_NEXT, PARS_NEXT. intros. unfold Genv.find_funct. rewrite pred_dec_true. unfold Genv.find_funct_ptr. rewrite H. ss. ss. *) +(* } *) +(* { ss. } *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). *) +(* subst f. setoid_rewrite CP_CUR. move ALLOW after EVARGS. *) +(* eapply allowed_call_gen_function_external; eauto. *) +(* setoid_rewrite Genv.find_funct_ptr_iff. auto. *) +(* } *) +(* { move NPTR after EVARGS. move TR after NPTR. i. *) +(* rewrite EVARGS. apply NPTR. unfold crossing_comp. rewrite <- H. *) +(* setoid_rewrite CP_CUR. rewrite CP_NEXT. auto. *) +(* } *) +(* { move TR after EVARGS. instantiate (1:=tr). inv TR. *) +(* setoid_rewrite CP_CUR. rewrite CP_NEXT. *) +(* econs 2. *) +(* { rewrite <- H. ss. } *) +(* eauto. *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply Genv.find_invert_symbol. apply MSENV1. auto. } *) +(* { eapply eventval_list_match_transl. eapply match_senv_eventval_list_match; eauto. destruct MS0 as (MSENV & _); auto. } *) +(* } *) +(* } *) +(* { rewrite EVARGS. subst kc_next. econs 1. } *) +(* traceEq. *) +(* Qed. *) + +(* Lemma ir_to_clight_step_cce_2 *) +(* (ge_i: Asm.genv) (ge_c: genv) *) +(* (WFGE : wf_ge ge_i) *) +(* cnts pars k_i cur m_i pretr btr (tr1 tr2 tr' : trace) id0 vargs ef id_cur d *) +(* (BOUND : Z.of_nat *) +(* (Datatypes.length *) +(* (pretr ++ (id_cur, Bundle_call tr' id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr)) < *) +(* Int64.modulus) *) +(* k_c id f stmt k0 e le m_c *) +(* (MS0 : match_genv ge_i ge_c) *) +(* (MS1 : match_mem ge_i k_c m_i m_c) *) +(* (MS2 : match_cur_fun ge_i ge_c cur f id) *) +(* (MS4 : match_cont ge_c (pretr ++ (id_cur, Bundle_call tr' id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) cnts k0 k_i) *) +(* (MS3 : match_find_def ge_i ge_c cnts pars (pretr ++ (id_cur, Bundle_call tr' id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr)) *) +(* (MS5 : match_params pars ge_c ge_i) *) +(* (MCNTS : match_cnts cnts ge_c k_c) *) +(* (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), *) +(* cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) *) +(* (WFC0 : forall (id : ident) (b : block) gd, *) +(* Genv.find_symbol ge_i id = Some b -> *) +(* Genv.find_def ge_i b = Some gd -> *) +(* exists cnt : ident, *) +(* cnts ! id = Some cnt /\ *) +(* wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) *) +(* m_freeenv *) +(* (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) *) +(* (WFC1 : wf_c_cont ge_c m_freeenv k0) *) +(* (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id *) +(* (pretr ++ (id_cur, Bundle_call tr' id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) stmt) *) +(* (WFC3 : wf_env ge_c e) *) +(* (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) *) +(* (WFNB : wf_c_nb ge_c m_c) *) +(* b *) +(* (FINDB : Genv.find_symbol ge_i id0 = Some b) *) +(* (FINDF : Genv.find_funct ge_i (Vptr b Ptrofs.zero) = Some (AST.External ef)) *) +(* (NPTR : crossing_comp ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (comp_of ef) -> *) +(* Forall not_ptr vargs) *) +(* (ALLOW : Genv.allowed_call ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) *) +(* (Vptr b Ptrofs.zero)) *) +(* (m1' m2 : mem) *) +(* (vretv : val) *) +(* (DELTA : mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = Some m1') *) +(* (TR1 : call_trace_cross ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) *) +(* (comp_of ef) b vargs (sig_args (ef_sig ef)) tr1 id0 (vals_to_eventvals ge_i vargs)) *) +(* (TR2 : external_call ef ge_i vargs m1' tr2 vretv m2) *) +(* (ECCASES : external_call_unknowns ef ge_i m1' vargs \/ *) +(* external_call_known_observables ef ge_i m1' vargs tr2 vretv m2 /\ d = []) *) +(* (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) *) +(* (TR_APP: exists tr0, tr' = tr1 ++ tr2 ++ tr0) *) +(* : *) +(* exists cnt_cur cnt_cur_b, *) +(* (cnts ! id_cur = Some cnt_cur /\ Senv.find_symbol ge_c cnt_cur = Some cnt_cur_b /\ Senv.public_symbol ge_c cnt_cur = false) /\ *) +(* let dsg := from_sig_fun_data (ef_sig ef) in *) +(* exists m_c', *) +(* (exists vres m_next, *) +(* (star step1 ge_c (State f stmt k0 e le m_c) *) +(* (tr1 ++ tr2) *) +(* (Returnstate vres (Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr (pretr ++ (id_cur, Bundle_call tr' id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) id_cur))) Sskip k0)) m_next (rettype_of_type (dret dsg)) (comp_of ef))) /\ *) +(* (external_call ef ge_c vargs m_c' tr2 vres m_next)) *) +(* /\ *) +(* (exists m_cu, *) +(* (Mem.storev Mint64 m_c (Vptr cnt_cur_b Ptrofs.zero) (Vlong (Int64.add (nat64 (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr pretr id_cur)))) Int64.one)) (comp_of f) = Some m_cu) /\ *) +(* (d = [] -> m_c' = m_cu) /\ *) +(* ((public_first_order ge_i m1') -> *) +(* (mem_delta_apply_wf ge_i (comp_of f) d (Some m_cu) = Some m_c') /\ *) +(* (Mem.inject (meminj_public ge_i) m1' m_c'))) *) +(* . *) +(* Proof. *) +(* hexploit ir_to_clight_step_cce_1; eauto. *) +(* { desH ECCASES; [left | right; auto]. apply external_call_unknowns_fo in ECCASES. *) +(* apply meminj_first_order_public_first_order; auto. *) +(* } *) +(* { desH TR_APP. eauto. } *) +(* instantiate (1:=le). *) +(* intros (cnt_cur & cnt_cur_b & (CNT_CUR & FIND_CNT & CNT_CUR_NP) & m_c' & STAR & MEM). *) +(* destruct MEM as (m_cu & CNT_CUR_STORE & DELTA_NIL & DELTA_PUB). *) +(* exists cnt_cur, cnt_cur_b. split; auto. ss. exists m_c'. split. *) +(* 2:{ exists m_cu. splits; auto. } *) +(* desH ECCASES; cycle 1. *) + +(* (* Case 1: observable defined external calls *) *) +(* { clear DELTA_PUB. subst d. specialize (DELTA_NIL eq_refl). subst m_c'. *) +(* unfold mem_delta_apply_wf in DELTA. simpl in DELTA. inversion DELTA; clear DELTA. subst m1'. *) +(* hexploit exists_vargs_vres. eapply MS0. eapply ECCASES. eauto. intros (EVALS & EXT2). *) +(* esplits. 2: eapply EXT2. *) +(* eapply star_trans. eapply STAR. *) +(* { econs 2. eapply step_external_function. eapply EXT2. econs 1. ss. } *) +(* { traceEq. } *) +(* } *) + +(* (* Case 2: observable defined external calls *) *) +(* { clear DELTA_NIL. *) +(* hexploit external_call_unknowns_fo. eapply ECCASES. intros FO_I. *) +(* hexploit external_call_unknowns_val_inject_list. eapply ECCASES. intros ARGS_INJ. *) +(* hexploit meminj_first_order_public_first_order. apply FO_I. intros PFO. *) +(* specialize (DELTA_PUB PFO). desH DELTA_PUB. *) +(* move MS1 after ARGS_INJ. destruct MS1 as (MM0 & MM1 & MM2). *) +(* hexploit external_call_mem_inject_gen. *) +(* { eapply match_symbs_symbols_inject. apply MS0. } *) +(* apply TR2. apply DELTA_PUB0. apply ARGS_INJ. *) +(* intros (j2 & vres2 & m_next & EC2 & RET_INJ & INJ2 & UCH0 & UCH1 & INCR2 & INJ_SEP). *) +(* exists vres2, m_next. split; [|auto]. eapply star_trans. eapply STAR. *) +(* { econs 2. eapply step_external_function. eapply EC2. econs 1. ss. } *) +(* traceEq. *) +(* Unshelve. exact 1%positive. exact le. *) +(* } *) +(* Qed. *) + +(* Lemma val_inject_not_ptr *) +(* k v1 v2 *) +(* (VI: Val.inject k v1 v2) *) +(* (NPTR: not_ptr v1) *) +(* : *) +(* not_ptr v2. *) +(* Proof. inv VI; auto. ss. Qed. *) + +(* Lemma not_ptr_val_inject_eq *) +(* j v1 v2 *) +(* (VI: Val.inject j v1 v2) *) +(* (NPTR: not_ptr v1) *) +(* : *) +(* v1 = v2. *) +(* Proof. inv VI; ss. Qed. *) + +(* Lemma ir_to_clight_step_1 *) +(* ge_i ge_c *) +(* (WFGE : wf_ge ge_i) *) +(* cnts pars k_i cur m_i *) +(* pretr btr *) +(* tr id0 evargs f_next d id_cur *) +(* (BOUND : Z.of_nat *) +(* (Datatypes.length *) +(* (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr)) < *) +(* Int64.modulus) *) +(* k_c id f stmt k0 e le m_c *) +(* (MS0 : match_genv ge_i ge_c) *) +(* (MS1 : match_mem ge_i k_c m_i m_c) *) +(* (MS2 : match_cur_fun ge_i ge_c cur f id) *) +(* (MS4 : match_cont ge_c (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr) *) +(* cnts k0 k_i) *) +(* (MS3 : match_find_def ge_i ge_c cnts pars *) +(* (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr)) *) +(* (MS5 : match_params pars ge_c ge_i) *) +(* (MCNTS : match_cnts cnts ge_c k_c) *) +(* (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), *) +(* cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) *) +(* (WFC0 : forall (id : ident) (b : block) gd, *) +(* Genv.find_symbol ge_i id = Some b -> *) +(* Genv.find_def ge_i b = Some gd -> *) +(* exists cnt : ident, *) +(* cnts ! id = Some cnt /\ *) +(* wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) *) +(* m_freeenv *) +(* (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) *) +(* (WFC1 : wf_c_cont ge_c m_freeenv k0) *) +(* (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id *) +(* (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr) stmt) *) +(* (WFC3 : wf_env ge_c e) *) +(* (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) *) +(* (WFNB : wf_c_nb ge_c m_c) *) +(* vargs b m2 *) +(* (FINDB : Genv.find_symbol ge_i id0 = Some b) *) +(* (FINDF : Genv.find_funct ge_i (Vptr b Ptrofs.zero) = Some (AST.Internal f_next)) *) +(* (NPTR : crossing_comp ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (comp_of f_next) -> *) +(* Forall not_ptr vargs) *) +(* (ALLOW : Genv.allowed_call ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) *) +(* (Vptr b Ptrofs.zero)) *) +(* (DELTA : mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = *) +(* Some m2) *) +(* (TR : call_trace_cross ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) *) +(* (comp_of f_next) b vargs (sig_args (fn_sig f_next)) tr id0 evargs) *) +(* (PUB : public_first_order ge_i m2) *) +(* (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) *) +(* : *) +(* exists cst2 : state, *) +(* star step1 ge_c (State f stmt k0 e le m_c) *) +(* (unbundle (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d)) cst2 /\ *) +(* ((exists id' : positive, *) +(* wf_c_state ge_i ge_c (pretr ++ [(id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d)]) *) +(* (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr) cnts id' cst2 /\ *) +(* (exists k : meminj, *) +(* match_state ge_i ge_c k *) +(* (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr) cnts pars *) +(* id' (Some (b, m2, ir_cont cur :: k_i)) cst2)) \/ *) +(* Some (b, m2, ir_cont cur :: k_i) = None). *) +(* Proof. *) +(* assert (id = id_cur). *) +(* { unfold match_cur_fun in MS2. des. rewrite MS7 in IDCUR. clarify. } *) +(* subst id. *) +(* rename f_next into fi_next. *) + +(* exploit MS3. *) +(* { eapply Genv.find_funct_ptr_iff. erewrite <- Genv.find_funct_find_funct_ptr. eapply FINDF. } *) +(* { eapply Genv.find_invert_symbol; eauto. } *) +(* intros FINDF_C. des_ifs. rename id0 into id_next, i into cnt_next, Heq into CNTS_NEXT, l into params_next, Heq0 into PARS_NEXT. simpl in FINDF_C. *) +(* set (pretr ++ (id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d) :: btr) as ttr in *. *) +(* set (gen_function ge_i cnt_next params_next (get_id_tr ttr id_next) fi_next) as f_next in *. *) +(* set (fn_body f_next) as stmt_next. *) +(* hexploit Genv.invert_find_symbol. eapply IDCUR. intros FIND_CUR_I. *) +(* destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). *) +(* assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1 in FIND_CUR_I. auto. } *) +(* assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). *) +(* { auto. } *) + +(* exploit WFC0. apply FIND_CUR_I. rewrite <- Genv.find_funct_ptr_iff. apply FINDF_I_CUR. *) +(* intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). *) +(* set (Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)) as kc_next. *) +(* assert (CUR_TR: get_id_tr ttr id_cur = (get_id_tr pretr id_cur) ++ (id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d) :: (get_id_tr btr id_cur)). *) +(* { subst ttr. clear. rewrite get_id_tr_app. rewrite get_id_tr_cons. ss. rewrite Pos.eqb_refl. auto. } *) +(* assert (BOUND2: Z.of_nat (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr ttr id_cur))) < Int64.modulus). *) +(* { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. *) +(* apply inj_le. apply list_length_filter_le. *) +(* } *) +(* destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). *) +(* assert (PARSIGS: list_typ_to_list_type (sig_args (fn_sig fi_next)) = map snd params_next). *) +(* { destruct MS5 as (_ & WFP1 & _). exploit WFP1. apply FINDF. apply FINDB. apply PARS_NEXT. ss. } *) + +(* hexploit cur_fun_def. eapply FINDF_C_CUR. eapply FINDF_I_CUR. eapply INV_CUR. eauto. *) +(* intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). *) +(* rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. *) +(* assert (CP_CUR: (comp_of f) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). *) +(* { unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. subst f. ss. } *) +(* assert (COMP_CUR_EQ: comp_of (@Gfun _ unit (AST.Internal f_i_cur)) = comp_of f). *) +(* { subst f. ss. } *) +(* setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_VA. setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_LOAD. *) + +(* hexploit switch_spec. *) +(* { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } *) +(* { unfold wf_env in WFC3. specialize (WFC3 cnt_cur). des_ifs. eapply WFC3. } *) +(* eapply FIND_CNT_CUR. eapply CNT_CUR_MEM_VA. *) +(* { rewrite CNT_CUR_MEM_LOAD. rewrite map_length. auto. } *) +(* instantiate (1:=le). *) +(* instantiate (1:=(Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)). *) +(* instantiate (1:=Sreturn None). *) +(* intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). *) + +(* assert (DELTA_C: exists m_c', (mem_delta_apply_wf ge_i (comp_of f) d (Some m_cu) = Some m_c') /\ *) +(* (Mem.inject (meminj_public ge_i) m2 m_c')). *) +(* { move MS1 after CUR_SWITCH_STAR. destruct MS1 as (MINJ & INJINCR & NALLOC). *) +(* move DELTA after NALLOC. move PUB after NALLOC. *) +(* hexploit mem_delta_apply_establish_inject_preprocess2. *) +(* apply MINJ. eapply CNT_CUR_STORE. *) +(* { instantiate (1:=ge_i). erewrite match_symbs_meminj_public. 2: destruct MS0 as (MS & _); apply MS. *) +(* ii. unfold meminj_public in H. des_ifs. apply Senv.find_invert_symbol in FIND_CNT_CUR. *) +(* rewrite FIND_CNT_CUR in Heq. clarify. *) +(* } *) +(* apply INJINCR. apply NALLOC. apply DELTA. apply PUB. *) +(* intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. *) +(* rewrite CP_CUR. auto. *) +(* } *) +(* des. rename DELTA_C0 into MEMINJ_CNT. *) +(* assert (ENV_ALLOC: exists e_next m_c_next0, alloc_variables ge_c (comp_of f_next) empty_env m_c' (fn_params f_next ++ fn_vars f_next) e_next m_c_next0). *) +(* { eapply alloc_variables_exists. } *) +(* des. *) +(* assert (ENV_BIND: exists m_c_next, bind_parameters ge_c (comp_of f_next) e_next m_c_next0 (fn_params f_next) vargs m_c_next). *) +(* { move PARSIGS after ENV_ALLOC. inv TR; ss. *) +(* eapply bind_parameters_exists. 2: apply PARSIGS. *) +(* 2:{ eapply match_senv_eventval_list_match. 2: apply H1. destruct MS0 as (MS0 & _); auto. } *) +(* rewrite app_nil_r in ENV_ALLOC. eapply alloc_variables_forall. apply ENV_ALLOC. *) +(* { move MS5 after H1. destruct MS5. specialize (H2 _ _ PARS_NEXT). auto. } *) +(* } *) +(* des. *) +(* set (create_undef_temps (fn_temps f_next)) as le_next. *) +(* set (State f_next (fn_body f_next) *) +(* (Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)) *) +(* e_next le_next m_c_next) as cst2. *) + +(* assert (ENV_NGLOB: not_global_blks (ge_c) (blocks_of_env2 ge_c e_next)). *) +(* { clear CUR_SWITCH_STAR. move MS5 after le_next. destruct MS5 as (MP1 & MP2 & MP3). *) +(* apply Forall_forall. i. *) +(* unfold blocks_of_env2, blocks_of_env in H. rewrite map_map in H. *) +(* apply list_in_map_inv in H. des. destruct x0 as (xid & xb & xt). *) +(* apply PTree.elements_complete in H0. move WFNB after H0. *) +(* destruct (Senv.invert_symbol ge_c x) eqn:CASES; auto. exfalso. *) +(* unfold wf_c_nb in WFNB. apply Senv.invert_find_symbol in CASES. apply Senv.find_symbol_below in CASES. *) +(* hexploit alloc_variables_one_fresh_block. eapply ENV_ALLOC. *) +(* { ss. rewrite app_nil_r. eapply MP1. eauto. } *) +(* { ss. } *) +(* eapply H0. intros. apply H1; clear H1. ss. clarify. unfold Mem.valid_block. *) +(* eapply mem_delta_apply_wf_wunchanged_on in DELTA_C. eapply store_wunchanged_on in CNT_CUR_STORE. *) +(* eapply wunchanged_on_nextblock in CNT_CUR_STORE, DELTA_C. revert_until H0. clear; i. *) +(* eapply Plt_Ple_trans. eapply CASES. etransitivity. eapply WFNB. etransitivity; eauto. *) +(* Unshelve. all: exact (fun _ _ => True). *) +(* } *) +(* assert (ENV_NINJ: not_inj_blks (meminj_public ge_c) (blocks_of_env2 ge_c e_next)). *) +(* { eapply not_global_is_not_inj_bloks. auto. } *) + +(* assert (WFC_NEXT: wf_c_state ge_i ge_c (pretr ++ [(id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d)]) ttr cnts id_next cst2). *) +(* { subst cst2; ss. splits; auto. *) +(* - unfold wf_counters. splits; auto. *) +(* clear CUR_SWITCH_STAR. move WFC0 after le_next. *) +(* ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. *) +(* unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. *) +(* exists b1. splits; auto. *) +(* + eapply bind_parameters_valid_access. eapply ENV_BIND. *) +(* eapply alloc_variables_valid_access. eapply ENV_ALLOC. *) +(* eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. *) +(* eapply Mem.store_valid_access_1. eapply CNT_CUR_STORE. *) +(* auto. *) +(* + assert (MNB: (b1 < Mem.nextblock m_c')%positive). *) +(* { eapply Mem.valid_access_implies in WFC7. *) +(* apply Mem.valid_access_valid_block in WFC7. 2: apply perm_any_N. *) +(* unfold Mem.valid_block in WFC7. *) +(* hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros UCH1. *) +(* hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros UCH2. *) +(* apply wunchanged_on_nextblock in UCH1, UCH2. *) +(* eapply Pos.lt_le_trans; eauto. etransitivity; eauto. *) +(* } *) +(* destruct (Pos.eq_dec id id_cur). *) +(* * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. clarify. *) +(* replace (comp_of gd) with *) +(* (comp_of *) +(* (gen_function ge_i cnt_cur params_cur (get_id_tr ttr id_cur) f_i_cur)). *) +(* 2:{ rewrite Genv.find_funct_ptr_iff in FINDF_I_CUR. rewrite FINDF_I_CUR in H0. *) +(* clarify. *) +(* } *) +(* erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. *) +(* 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. auto. } *) +(* erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. *) +(* 2:{ auto. } *) +(* erewrite mem_delta_apply_wf_mem_load. *) +(* 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. apply DELTA_C. destruct MS0 as (MS & _). eauto. } *) +(* 2:{ eapply Genv.find_invert_symbol. eapply FIND_CNT_CUR. } *) +(* 2:{ auto. } *) +(* erewrite Mem.load_store_same. 2: eapply CNT_CUR_STORE. *) +(* ss. rewrite map_length. rewrite get_id_tr_app. ss. *) +(* rewrite Pos.eqb_refl. rewrite app_length. ss. *) +(* do 2 f_equal. apply nat64_int64_add_one. *) +(* subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. *) +(* eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. *) +(* apply Nat.le_add_r. *) +(* * ss. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. *) +(* 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. auto. } *) +(* erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. *) +(* 2:{ auto. } *) +(* erewrite mem_delta_apply_wf_mem_load. *) +(* 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. apply DELTA_C. destruct MS0 as (MS & _). eauto. } *) +(* 2:{ eapply Genv.find_invert_symbol. eapply WFC6. } *) +(* 2:{ auto. } *) +(* erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. *) +(* 2:{ left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC6. *) +(* rewrite FIND_CNT_CUR in WFC6. clarify. rename cnt into cnt_cur. *) +(* specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. *) +(* } *) +(* rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. *) +(* rewrite WFC8. auto. *) + +(* - clear CUR_SWITCH_STAR. move WFC1 after le_next. move WFC4 after WFC1. move FREEENV after WFC4. *) +(* hexploit alloc_variables_exists_free_list. eapply ENV_ALLOC. ss. ss. ss. intros; des. *) +(* hexploit wunchanged_on_exists_mem_free_list. 2: eapply H. *) +(* { eapply wunchanged_on_implies. eapply bind_parameters_wunchanged_on. apply ENV_BIND. ss. } *) +(* intros (m_f' & FREE). *) +(* assert (WU: wunchanged_on (fun b _ => Mem.valid_block m_c b) m_c m_f'). *) +(* { eapply wunchanged_on_trans. eapply store_wunchanged_on. eapply CNT_CUR_STORE. *) +(* eapply wunchanged_on_trans. eapply wunchanged_on_implies. eapply mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. ss. *) +(* eapply wunchanged_on_trans. eapply wunchanged_on_implies. eapply alloc_variables_wunchanged_on. eapply ENV_ALLOC. ss. *) +(* eapply wunchanged_on_trans. eapply wunchanged_on_implies. eapply bind_parameters_wunchanged_on. eapply ENV_BIND. ss. *) +(* eapply mem_free_list_wunchanged_on. eapply FREE. *) +(* eapply alloc_variables_fresh_blocks. eapply ENV_ALLOC. *) +(* 2:{ unfold blocks_of_env, empty_env. ss. } *) +(* hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. i. eapply wunchanged_on_nextblock in H0. *) +(* etransitivity. 2: eapply H0. erewrite <- Mem.nextblock_store. 2: eapply CNT_CUR_STORE. lia. *) +(* } *) +(* hexploit wunchanged_on_exists_mem_free_list. eapply WU. eapply FREEENV. intros (m_freeenv' & FREEENV'). *) +(* exists m_f'. splits; auto. econs. 1,2,3: eauto. eapply FREEENV'. *) +(* hexploit wunchanged_on_free_list_preserves. eapply WU. eapply FREEENV. eapply FREEENV'. intros WUFREE. *) +(* move WFC1 after FREEENV'. *) +(* eapply wf_c_cont_wunchanged_on. eapply WFC1. apply WUFREE. *) + +(* - move WFC2 after le_next. unfold wf_c_stmt in *. clear CUR_SWITCH_STAR. *) +(* i. rewrite CNTS_NEXT in H. inv H. rename cnt into cnt_next. *) +(* subst f_next. unfold comp_of. ss. apply match_symbs_code_bundle_trace. *) +(* destruct MS0 as (MS0 & _); auto. *) + +(* - clear CUR_SWITCH_STAR. move MS5 after le_next. destruct MS5 as (MP1 & MP2 & MP3). *) +(* eapply alloc_variables_wf_params_of_symb. eapply ENV_ALLOC. eapply MP3. *) +(* rewrite app_nil_r. apply PARS_NEXT. *) + +(* - clear CUR_SWITCH_STAR. move WFNB after ENV_NINJ. unfold wf_c_nb in *. *) +(* eapply bind_parameters_wunchanged_on in ENV_BIND. eapply alloc_variables_wunchanged_on in ENV_ALLOC. *) +(* eapply mem_delta_apply_wf_wunchanged_on in DELTA_C. eapply store_wunchanged_on in CNT_CUR_STORE. *) +(* eapply wunchanged_on_nextblock in CNT_CUR_STORE, DELTA_C, ENV_ALLOC, ENV_BIND. *) +(* clear - CNT_CUR_STORE DELTA_C ENV_ALLOC ENV_BIND WFNB. *) +(* do 5 (etransitivity; eauto). *) +(* } *) + +(* assert (MS_NEXT: match_state ge_i ge_c (meminj_public ge_i) ttr cnts pars id_next (Some (b, m2, ir_cont cur :: k_i)) cst2). *) +(* { clear CUR_SWITCH_STAR WFC_NEXT. subst cst2. ss. *) +(* rewrite app_nil_r in ENV_ALLOC. splits; auto. *) +(* - unfold match_mem. splits; auto. *) +(* + eapply bind_parameters_outside_mem_inject. eapply ENV_BIND. *) +(* 2:{ eapply not_inj_blks_get_env. erewrite match_symbs_meminj_public. eapply ENV_NINJ. destruct MS0 as (MS0 & _). apply MS0. *) +(* } *) +(* 2: apply meminj_public_same_block. *) +(* eapply alloc_variables_mem_inject. eapply ENV_ALLOC. auto. *) +(* + move MS1 after ENV_NINJ. destruct MS1 as (MM1 & MM2 & MM3). *) +(* move DELTA after ENV_NINJ. eapply meminj_not_alloc_delta. eapply MM3. eapply DELTA. *) +(* - unfold match_cur_fun. splits; auto. *) +(* + rewrite Genv.find_funct_ptr_iff. eapply FINDF_C. *) +(* + eexists. eapply FINDF. *) +(* + apply Genv.find_invert_symbol. apply FINDB. *) +(* - move MS4 after ENV_NINJ. econs 2. 4,5,6: eauto. all: auto. *) +(* apply Genv.find_invert_symbol. apply FIND_CUR_C. *) +(* - move MS1 after ENV_NINJ. move MCNTS after MS1. destruct MS1 as (MM1 & MM2 & MM3). *) +(* eapply mem_inject_incr_match_cnts_rev. eapply MM2. auto. *) +(* } *) + +(* exists cst2. split. *) +(* 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } *) +(* unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. *) +(* eapply star_trans. eapply code_bundle_trace_spec. 2: ss. *) +(* unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. *) +(* rewrite ! (match_symbs_code_bundle_call ge_i ge_c) in CUR_SWITCH_STAR. rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. *) +(* eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: auto. *) +(* clear BOUND2 CUR_SWITCH_STAR. *) +(* unfold code_bundle_call. eapply star_trans. eapply code_mem_delta_correct. auto. *) +(* { erewrite <- match_symbs_mem_delta_apply_wf. eapply DELTA_C. *) +(* destruct MS0 as (MSYMB & _). auto. } *) +(* 2: ss. 2,3: destruct MS0 as (MSENV & _); apply MSENV. *) +(* unfold unbundle. simpl. rename b into next. *) + +(* assert (CP_NEXT: *) +(* (Genv.find_comp ge_c (Vptr next Ptrofs.zero)) = *) +(* (comp_of fi_next)). *) +(* { unfold Genv.find_comp. apply Genv.find_funct_ptr_iff in FINDF_C. setoid_rewrite FINDF_C. subst f_next. ss. } *) +(* assert (EVARGS: list_eventval_to_list_val ge_c evargs = vargs). *) +(* { destruct MS0 as (MSENV & MGENV). inv TR. *) +(* eapply eventval_list_match_list_eventval_to_list_val. eapply match_symbs_eventval_list_match; eauto. *) +(* } *) + +(* econs 2. *) +(* { eapply step_call. ss. *) +(* { econs. assert (FSN_C: Senv.find_symbol ge_c id_next = Some next). *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1. auto. } *) +(* eapply eval_Evar_global. *) +(* - unfold wf_env in WFC3. specialize (WFC3 id_next). rewrite FSN_C in WFC3. apply WFC3. *) +(* - eapply FSN_C. *) +(* - econs 2. ss. *) +(* } *) +(* { eapply list_eventval_to_expr_val_eval. auto. inv TR. eapply eventval_list_match_transl. eapply match_senv_eventval_list_match; eauto. destruct MS0 as (MSENV & _); auto. } *) +(* { unfold match_find_def in MS3. hexploit MS3. *) +(* unfold Genv.find_funct in FINDF. rewrite pred_dec_true in FINDF; auto. unfold Genv.find_funct_ptr in FINDF. des_ifs. eapply Heq. *) +(* eapply Senv.find_invert_symbol; eapply FINDB. *) +(* rewrite CNTS_NEXT, PARS_NEXT. intros. unfold Genv.find_funct. rewrite pred_dec_true. unfold Genv.find_funct_ptr. rewrite H. ss. ss. *) +(* } *) +(* { ss. unfold type_of_function, gen_function. ss. f_equal. apply type_of_params_eq. apply PARSIGS. } *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). *) +(* subst f. setoid_rewrite CP_CUR. *) +(* eapply allowed_call_gen_function; eauto. *) +(* { setoid_rewrite Genv.find_funct_ptr_iff. rewrite FINDF_C. subst f_next. eauto. } *) +(* } *) +(* { move NPTR after MS_NEXT. move TR after NPTR. i. *) +(* rewrite EVARGS. apply NPTR. unfold crossing_comp. rewrite <- H. *) +(* setoid_rewrite CP_CUR. rewrite CP_NEXT. auto. *) +(* } *) +(* { move TR after MS_NEXT. instantiate (1:=tr). inv TR. *) +(* setoid_rewrite CP_CUR. rewrite CP_NEXT. *) +(* econs 2. *) +(* { rewrite <- H. ss. } *) +(* eauto. *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply Genv.find_invert_symbol. apply MSENV1. auto. } *) +(* { eapply eventval_list_match_transl. eapply match_senv_eventval_list_match; eauto. destruct MS0 as (MSENV & _); auto. } *) +(* } *) +(* } *) +(* { econs 2. 2: econs 1. eapply step_internal_function. 2: ss. *) +(* econs; eauto. *) +(* { destruct MS5 as (MPARS & _). specialize (MPARS _ _ PARS_NEXT). subst f_next. ss. rewrite app_nil_r. auto. } *) +(* { rewrite EVARGS. auto. } *) +(* } *) +(* traceEq. *) + +(* Unshelve. all: try exact 0%nat. all: exact (fun _ _ => True). *) +(* Qed. *) + +(* Lemma ir_to_clight_step_2 *) +(* ge_i ge_c *) +(* (WFGE : wf_ge ge_i) *) +(* cnts pars cur m_i pretr btr tr evretv d id_cur *) +(* (BOUND : Z.of_nat (Datatypes.length (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr)) < *) +(* Int64.modulus) *) +(* k_c id f stmt k0 e le m_c *) +(* (MS0 : match_genv ge_i ge_c) *) +(* (MS1 : match_mem ge_i k_c m_i m_c) *) +(* (MS2 : match_cur_fun ge_i ge_c cur f id) *) +(* (MS3 : match_find_def ge_i ge_c cnts pars (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr)) *) +(* next ik_tl *) +(* (MS4 : match_cont ge_c (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr) cnts k0 *) +(* (ir_cont next :: ik_tl)) *) +(* (MS5 : match_params pars ge_c ge_i) *) +(* (MCNTS : match_cnts cnts ge_c k_c) *) +(* (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), *) +(* cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) *) +(* (WFC0 : forall (id : ident) (b : block) gd, *) +(* Genv.find_symbol ge_i id = Some b -> *) +(* Genv.find_def ge_i b = Some gd -> *) +(* exists cnt : ident, *) +(* cnts ! id = Some cnt /\ *) +(* wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) *) +(* m_freeenv *) +(* (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) *) +(* (WFC1 : wf_c_cont ge_c m_freeenv k0) *) +(* (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr) *) +(* stmt) *) +(* (WFC3 : wf_env ge_c e) *) +(* (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) *) +(* (WFNB : wf_c_nb ge_c m_c) *) +(* vretv fd_cur f_next m2 *) +(* (FINDFD : Genv.find_funct_ptr ge_i cur = Some fd_cur) *) +(* (NPTR : crossing_comp ge_i (Genv.find_comp ge_i (Vptr next Ptrofs.zero)) *) +(* (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) -> not_ptr vretv) *) +(* (INTERNAL : Genv.find_funct_ptr ge_i next = Some (AST.Internal f_next)) *) +(* (TR : return_trace_cross ge_i (Genv.find_comp ge_i (Vptr next Ptrofs.zero)) *) +(* (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) vretv (sig_res (funsig fd_cur)) tr evretv) *) +(* (DELTA : mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = *) +(* Some m2) *) +(* (PUB : public_first_order ge_i m2) *) +(* (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) *) +(* : *) +(* exists cst2 : state, *) +(* star step1 ge_c (State f stmt k0 e le m_c) (unbundle (id_cur, Bundle_return tr evretv d)) *) +(* cst2 /\ *) +(* ((exists id' : positive, *) +(* wf_c_state ge_i ge_c (pretr ++ [(id_cur, Bundle_return tr evretv d)]) *) +(* (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr) cnts id' cst2 /\ *) +(* (exists k : meminj, *) +(* match_state ge_i ge_c k (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr) cnts *) +(* pars id' (Some (next, m2, ik_tl)) cst2)) \/ Some (next, m2, ik_tl) = None). *) +(* Proof. *) +(* assert (id = id_cur). *) +(* { unfold match_cur_fun in MS2. des. rewrite MS7 in IDCUR. clarify. } *) +(* subst id. rename f_next into fi_next. *) +(* assert (INV_ID_NEXT: exists id_next, Genv.invert_symbol ge_i next = Some id_next). *) +(* { rewrite Genv.find_funct_ptr_iff in INTERNAL. eapply wf_ge_block_to_id. auto. eauto. } *) +(* des. *) +(* destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). *) +(* assert (FIND_CUR_I: Genv.find_symbol ge_i id_cur = Some cur). *) +(* { apply Genv.invert_find_symbol; auto. } *) + +(* exploit MS3. *) +(* { eapply Genv.find_funct_ptr_iff. eapply INTERNAL. } *) +(* { eapply INV_ID_NEXT. } *) +(* intros FINDF_C. des_ifs. rename i into cnt_next, Heq into CNTS_NEXT, l into params_next, Heq0 into PARS_NEXT. simpl in FINDF_C. *) +(* set (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr) as ttr in *. *) +(* set (gen_function ge_i cnt_next params_next (get_id_tr ttr id_next) fi_next) as f_next in *. *) +(* set (fn_body f_next) as stmt_next. *) +(* assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. auto. } *) +(* assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). *) +(* { auto. } *) + +(* exploit WFC0. eapply FIND_CUR_I. rewrite <- Genv.find_funct_ptr_iff; eauto. *) +(* intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). *) +(* inv WFC1. *) +(* { inv MS4. inv IK. inv CK. } *) +(* assert (CUR_TR: get_id_tr ttr id_cur = (get_id_tr pretr id_cur) ++ (id_cur, Bundle_return tr evretv d) :: (get_id_tr btr id_cur)). *) +(* { subst ttr. clear. rewrite get_id_tr_app. rewrite get_id_tr_cons. ss. rewrite Pos.eqb_refl. auto. } *) +(* assert (BOUND2: Z.of_nat (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr ttr id_cur))) < Int64.modulus). *) +(* { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. *) +(* apply inj_le. apply list_length_filter_le. *) +(* } *) +(* destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). *) +(* assert (PARSIGS: list_typ_to_list_type (sig_args (fn_sig fi_next)) = map snd params_next). *) +(* { destruct MS5 as (_ & WFP1 & _). exploit WFP1. apply INTERNAL. apply Genv.invert_find_symbol. apply INV_ID_NEXT. apply PARS_NEXT. ss. } *) + +(* inv MS4. *) +(* { inv IK. } *) +(* clarify. *) + +(* hexploit cur_fun_def. eapply FIND_FUN_C. eapply FINDFD. eapply IDCUR. eauto. *) +(* intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). *) +(* rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. *) +(* assert (CP_CUR: (comp_of f) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). *) +(* { unfold Genv.find_comp. setoid_rewrite FINDFD. subst f. ss. } *) +(* assert (COMP_CUR_EQ: comp_of (@Gfun _ unit (AST.Internal f_i_cur)) = comp_of f). *) +(* { subst f. ss. } *) +(* setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_VA. setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_LOAD. *) + +(* rename ck'0 into ck_next. rename e1 into e_next. rename le1 into le_next. *) +(* hexploit switch_spec. *) +(* { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } *) +(* { unfold wf_env in WFC3. specialize (WFC3 cnt_cur). des_ifs. eapply WFC3. } *) +(* eapply FIND_CNT_CUR. eapply CNT_CUR_MEM_VA. *) +(* { rewrite CNT_CUR_MEM_LOAD. rewrite map_length. auto. } *) +(* instantiate (1:=le). *) +(* instantiate (1:= (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) *) +(* Sskip *) +(* (Kcall None f_next e_next le_next (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_next (comp_of f_next) (get_id_tr ttr id_next))) Sskip ck_next)))). *) +(* instantiate (1:=Sreturn None). *) +(* intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). *) + +(* assert (DELTA_C: exists m_c', (mem_delta_apply_wf ge_i (comp_of f) d (Some m_cu) = Some m_c') /\ *) +(* (Mem.inject (meminj_public ge_i) m2 m_c')). *) +(* { move MS1 after CUR_SWITCH_STAR. destruct MS1 as (MINJ & INJINCR & NALLOC). *) +(* move DELTA after NALLOC. move PUB after NALLOC. *) +(* hexploit mem_delta_apply_establish_inject_preprocess2. *) +(* apply MINJ. eapply CNT_CUR_STORE. *) +(* { instantiate (1:=ge_i). erewrite match_symbs_meminj_public. 2: destruct MS0 as (MS & _); apply MS. *) +(* ii. unfold meminj_public in H. des_ifs. apply Senv.find_invert_symbol in FIND_CNT_CUR. *) +(* rewrite FIND_CNT_CUR in Heq. clarify. *) +(* } *) +(* apply INJINCR. apply NALLOC. apply DELTA. apply PUB. *) +(* intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. *) +(* rewrite CP_CUR. auto. *) +(* } *) +(* des. rename DELTA_C0 into MEMINJ_CNT. *) + +(* assert (f1 = f_next). *) +(* { rewrite <- Genv.find_funct_ptr_iff in FINDF_C. rewrite FINDF_C in FUN. clarify. } *) +(* subst f1. clear INV_CUR. *) +(* assert (id = id_next). *) +(* { apply Genv.invert_find_symbol in INV_ID_NEXT. destruct MS0 as ((_ & MS & _) & _). apply MS in INV_ID_NEXT. *) +(* apply Senv.find_invert_symbol in INV_ID_NEXT. setoid_rewrite INV_ID_NEXT in ID. clarify. *) +(* } *) +(* subst id. *) +(* assert (cnt = cnt_next). *) +(* { rewrite CNTS_NEXT in CNT. clarify. } *) +(* subst cnt. clear ID CNT. *) + +(* assert (WCHG1: wunchanged_on (fun b _ => Mem.valid_block m_c b) m_c m_c'). *) +(* { eapply wunchanged_on_trans. eapply store_wunchanged_on. eapply CNT_CUR_STORE. *) +(* eapply wunchanged_on_implies. eapply mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. ss. *) +(* } *) +(* assert (FREENEXT: exists m_c_next, Mem.free_list m_c' (blocks_of_env ge_c e) (comp_of f) = Some m_c_next). *) +(* { eapply wunchanged_on_exists_mem_free_list. eapply WCHG1. eapply FREEENV. } *) +(* des. *) + +(* set (State f_next (fn_body f_next) ck_next e_next le_next m_c_next) as cst2. *) + +(* assert (WFC_NEXT: wf_c_state ge_i ge_c (pretr ++ [(id_cur, Bundle_return tr evretv d)]) ttr cnts id_next cst2). *) +(* { clear CUR_SWITCH_STAR. ss. splits; auto. *) +(* - unfold wf_counters. split. auto. *) +(* move WFC0 after cst2. *) +(* ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. *) +(* unfold wf_counter in WFC1. des. unfold wf_counter. splits; auto. *) +(* exists b1. splits; auto. *) +(* + eapply mem_valid_access_wunchanged_on. eapply WFC6. *) +(* eapply wunchanged_on_trans; cycle 1. eapply mem_free_list_wunchanged_on_2. eapply FREENEXT. *) +(* eapply wunchanged_on_trans; cycle 1. eapply mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. *) +(* eapply store_wunchanged_on. eapply CNT_CUR_STORE. ss. i. *) +(* move MS5 after H0. destruct MS5 as (MP0 & MP1 & MP). specialize (MP _ _ WFC5). move WFC4 after MP. *) +(* eapply not_global_blks_global_not_in; eauto. *) +(* + move WFNB after CP_CUR. move WFC4 after WFNB. *) +(* eapply Mem.load_unchanged_on. eapply mem_free_list_unchanged_on. eapply FREENEXT. *) +(* { ss. i. eapply not_global_blks_global_not_in; eauto. } *) +(* erewrite mem_delta_apply_wf_mem_load; cycle 1. *) +(* { erewrite match_symbs_mem_delta_apply_wf in DELTA_C. apply DELTA_C. destruct MS0 as (MS & _). eauto. } *) +(* { eapply Genv.find_invert_symbol. apply WFC5. } *) +(* { auto. } *) +(* destruct (Pos.eq_dec id id_cur). *) +(* * subst id. assert (cnt_cur = cnt). *) +(* { rewrite WFC0 in CNTS_CUR. clarify. } *) +(* subst cnt. assert (b1 = cnt_cur_b). *) +(* { setoid_rewrite WFC5 in FIND_CNT_CUR. clarify. } *) +(* subst b1. assert (b0 = cur). *) +(* { rewrite FIND_CUR_I in H. clarify. } *) +(* subst b0. assert (gd = Gfun (AST.Internal f_i_cur)). *) +(* { apply Genv.find_funct_ptr_iff in FINDFD. rewrite FINDFD in H0. clarify. } *) +(* subst gd. erewrite Mem.load_store_same. *) +(* 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. *) +(* ss. rewrite map_length. rewrite get_id_tr_app. ss. *) +(* rewrite Pos.eqb_refl. rewrite app_length. ss. *) +(* do 2 f_equal. apply nat64_int64_add_one. *) +(* subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. *) +(* eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. *) +(* apply Nat.le_add_r. *) +(* * ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. *) +(* 2:{ left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC5. *) +(* rewrite FIND_CNT_CUR in WFC5. clarify. rename cnt into cnt_cur. *) +(* specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. *) +(* } *) +(* rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. rewrite WFC7. auto. *) + +(* - move IND after cst2. move FREE after cst2. move FREEENV after cst2. *) +(* hexploit wunchanged_on_free_list_preserves. eapply WCHG1. all: eauto. intros WCHG2. *) +(* hexploit wunchanged_on_exists_mem_free_list. eapply WCHG2. eapply FREE. intros (m_c_next2 & FREE2). *) +(* exists m_c_next2. splits; auto. *) +(* hexploit wunchanged_on_free_list_preserves. eapply WCHG2. all: eauto. intros WCHG3. *) +(* eapply wf_c_cont_wunchanged_on. eapply IND. auto. *) + +(* - move WFC2 after cst2. unfold wf_c_stmt in *. i. rewrite CNTS_NEXT in H. inv H. rename cnt into cnt_next. *) +(* subst f_next. unfold comp_of. ss. apply match_symbs_code_bundle_trace. destruct MS0 as (MS0 & _); auto. *) + +(* - move WFNB after cst2. unfold wf_c_nb in *. *) +(* apply SimplLocalsproof.free_list_nextblock in FREENEXT. rewrite FREENEXT. *) +(* eapply mem_delta_apply_wf_wunchanged_on in DELTA_C. eapply store_wunchanged_on in CNT_CUR_STORE. *) +(* eapply wunchanged_on_nextblock in CNT_CUR_STORE, DELTA_C. *) +(* clear - WFNB CNT_CUR_STORE DELTA_C. *) +(* do 5 (etransitivity; eauto). *) +(* Unshelve. all: try (exact 0%nat). all: try (exact (fun _ _ => True)). *) +(* } *) + +(* assert (MS_NEXT: match_state ge_i ge_c (meminj_public ge_i) ttr cnts pars id_next (Some (b, m2, ik')) cst2). *) +(* { clear CUR_SWITCH_STAR WFC_NEXT. ss. splits; auto. *) +(* - unfold match_mem. splits; auto. *) +(* + eapply SimplLocalsproof.free_list_right_inject. eapply MEMINJ_CNT. eapply FREENEXT. *) +(* i. move WFC4 after cst2. apply not_global_is_not_inj_bloks in WFC4. setoid_rewrite Forall_forall in WFC4. *) +(* assert (b2 = b1). *) +(* { clear - H. unfold meminj_public in H. des_ifs. } *) +(* subst b2. hexploit (WFC4 b1). *) +(* { unfold blocks_of_env2, blocks_of_env in *. rewrite map_map. *) +(* eapply (in_map (fun x => fst (fst x))) in H0. ss. rewrite map_map in H0. ss. *) +(* } *) +(* intros. erewrite <- match_symbs_meminj_public in H3. rewrite H in H3. clarify. *) +(* destruct MS0 as (MS & _). apply MS. *) +(* + move MS1 after cst2. destruct MS1 as (MM1 & MM2 & MM3). *) +(* move DELTA after cst2. eapply meminj_not_alloc_delta. eapply MM3. eapply DELTA. *) +(* - unfold match_cur_fun. splits; auto. eauto. *) +(* - destruct MS1 as (MM1 & MM2 & MM3). eapply mem_inject_incr_match_cnts_rev; eauto. *) +(* } *) +(* exists cst2. split. *) +(* 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } *) + +(* unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. *) +(* eapply star_trans. eapply code_bundle_trace_spec. 2: ss. *) +(* unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. *) +(* rewrite ! (match_symbs_code_bundle_return ge_i ge_c) in CUR_SWITCH_STAR. rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. *) +(* eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: destruct MS0 as (MS & _); auto. *) +(* clear BOUND2 CUR_SWITCH_STAR. *) +(* unfold code_bundle_return. eapply star_trans. eapply code_mem_delta_correct. auto. *) +(* { erewrite <- match_symbs_mem_delta_apply_wf. eapply DELTA_C. destruct MS0 as (MSYMB & _). auto. } *) +(* 2: ss. *) +(* unfold unbundle. simpl. rename b into next. *) + +(* assert (CP_NEXT: (Genv.find_comp ge_c (Vptr next Ptrofs.zero)) = (comp_of fi_next)). *) +(* { unfold Genv.find_comp. apply Genv.find_funct_ptr_iff in FINDF_C. setoid_rewrite FINDF_C. subst f_next. ss. } *) +(* assert (EVRETV: eventval_to_val ge_c evretv = vretv). *) +(* { destruct MS0 as (MSENV & MGENV). inv TR. *) +(* eapply eventval_match_eventval_to_val. eapply match_symbs_eventval_match; eauto. *) +(* } *) + +(* econs 2. *) +(* { inv TR. eapply match_senv_eventval_match in H0. 2: destruct MS0 as (MS0 & _); apply MS0. *) +(* eapply step_return_1. *) +(* - eapply eventval_to_expr_val_eval. auto. eapply H0. *) +(* - ss. *) +(* eapply sem_cast_proj_rettype. eapply H0. *) +(* - eapply FREENEXT. *) +(* } *) +(* ss. econs 2. *) +(* { assert (CPEQ1: comp_of f_next = (Genv.find_comp ge_i (Vptr next Ptrofs.zero))). *) +(* { subst f_next. unfold comp_of, gen_function. ss. unfold Genv.find_comp. setoid_rewrite INTERNAL. ss. } *) +(* assert (CPEQ2: (comp_of (gen_function ge_i cnt_cur params_cur (get_id_tr ttr id_cur) f_i_cur)) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). *) +(* { unfold comp_of, gen_function. ss. unfold Genv.find_comp. setoid_rewrite FINDFD. ss. } *) +(* eapply step_returnstate. *) +(* - move NPTR after EVRETV. i. rewrite EVRETV. apply NPTR. rr. rewrite CPEQ1 in H. setoid_rewrite CPEQ2 in H. apply H. *) +(* - move TR after EVRETV. instantiate (1:=tr). inv TR. setoid_rewrite CPEQ2. rewrite CPEQ1. econs; auto. *) +(* erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. *) +(* eapply match_senv_eventval_match. 2: eapply H0. apply MS0. *) +(* } *) +(* ss. econs 2. *) +(* { eapply step_skip_or_continue_loop1. auto. } *) +(* econs 2. *) +(* { eapply step_skip_loop2. } *) +(* { subst cst2. unfold code_bundle_trace. unfold Swhile. destruct MS0 as (MS0 & _). *) +(* erewrite (match_symbs_switch_bundle_events _ _ MS0). *) +(* setoid_rewrite <- CP_NEXT. unfold Genv.find_comp. setoid_rewrite FUN. *) +(* replace (comp_of (Internal f_next)) with (comp_of f_next). econs 1. ss. *) +(* } *) +(* all: traceEq. traceEq. *) +(* Qed. *) + +(* Lemma ir_to_clight_step_3 *) +(* ge_i ge_c *) +(* (WFGE : wf_ge ge_i) *) +(* cnts pars k_i cur m_i pretr btr tr id0 ef d vargs id_cur *) +(* (BOUND : Z.of_nat *) +(* (Datatypes.length *) +(* (pretr ++ *) +(* (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr)) < *) +(* Int64.modulus) *) +(* k_c id f stmt k0 e le m_c *) +(* (MS0 : match_genv ge_i ge_c) *) +(* (MS1 : match_mem ge_i k_c m_i m_c) *) +(* (MS2 : match_cur_fun ge_i ge_c cur f id) *) +(* (MS4 : match_cont ge_c *) +(* (pretr ++ *) +(* (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) cnts *) +(* k0 k_i) *) +(* (MS3 : match_find_def ge_i ge_c cnts pars *) +(* (pretr ++ *) +(* (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr)) *) +(* (MS5 : match_params pars ge_c ge_i) *) +(* (MCNTS : match_cnts cnts ge_c k_c) *) +(* (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), *) +(* cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) *) +(* (WFC0 : forall (id : ident) (b : block) gd, *) +(* Genv.find_symbol ge_i id = Some b -> *) +(* Genv.find_def ge_i b = Some gd -> *) +(* exists cnt : ident, *) +(* cnts ! id = Some cnt /\ *) +(* wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) *) +(* m_freeenv *) +(* (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) *) +(* (WFC1 : wf_c_cont ge_c m_freeenv k0) *) +(* (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id *) +(* (pretr ++ *) +(* (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) *) +(* stmt) *) +(* (WFC3 : wf_env ge_c e) *) +(* (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) *) +(* (WFNB : wf_c_nb ge_c m_c) *) +(* m2 b_ext m1' vretv *) +(* (FINDB : Genv.find_symbol ge_i id0 = Some b_ext) *) +(* (FINDF : Genv.find_funct ge_i (Vptr b_ext Ptrofs.zero) = Some (AST.External ef)) *) +(* (INTRA : Genv.type_of_call ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (comp_of ef) = *) +(* Genv.InternalCall) *) +(* (MEM : mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = *) +(* Some m1') *) +(* (EC : external_call ef ge_i vargs m1' tr vretv m2) *) +(* (ECCASES : external_call_unknowns ef ge_i m1' vargs \/ *) +(* external_call_known_observables ef ge_i m1' vargs tr vretv m2 /\ d = []) *) +(* (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) *) +(* : *) +(* exists cst2 : state, *) +(* star step1 ge_c (State f stmt k0 e le m_c) *) +(* (unbundle (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d)) cst2 /\ *) +(* ((exists id' : positive, *) +(* wf_c_state ge_i ge_c *) +(* (pretr ++ [(id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d)]) *) +(* (pretr ++ *) +(* (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) cnts *) +(* id' cst2 /\ *) +(* (exists k : meminj, *) +(* match_state ge_i ge_c k *) +(* (pretr ++ *) +(* (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) *) +(* cnts pars id' (Some (cur, m2, k_i)) cst2)) \/ Some (cur, m2, k_i) = None). *) +(* Proof. *) +(* assert (id = id_cur). *) +(* { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } *) +(* subst id. rename id0 into id_next. *) +(* destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). *) + +(* set (pretr ++ (id_cur, Bundle_call tr id_next (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) as ttr in *. *) +(* assert (FIND_CUR_I: Genv.find_symbol ge_i id_cur = Some cur). *) +(* { apply Genv.invert_find_symbol in IDCUR. auto. } *) +(* assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1 in FIND_CUR_I. auto. } *) +(* assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). *) +(* { auto. } *) + +(* exploit WFC0. eapply FIND_CUR_I. rewrite <- Genv.find_funct_ptr_iff; eapply FINDF_I_CUR. *) +(* intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). *) +(* assert (CUR_TR: get_id_tr ttr id_cur = (get_id_tr pretr id_cur) ++ (id_cur, Bundle_call tr id_next (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: (get_id_tr btr id_cur)). *) +(* { subst ttr. clear. rewrite get_id_tr_app. rewrite get_id_tr_cons. ss. rewrite Pos.eqb_refl. auto. } *) +(* assert (BOUND2: Z.of_nat (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr ttr id_cur))) < Int64.modulus). *) +(* { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. *) +(* apply inj_le. apply list_length_filter_le. *) +(* } *) +(* destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). *) + +(* hexploit cur_fun_def. eapply FINDF_C_CUR. eapply FINDF_I_CUR. eapply INV_CUR. eauto. *) +(* intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). *) +(* rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. *) +(* assert (CP_CUR: (comp_of f) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). *) +(* { unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. subst f. ss. } *) + +(* assert (COMP_CUR_EQ: comp_of (@Gfun _ unit (AST.Internal f_i_cur)) = comp_of f). *) +(* { subst f. ss. } *) +(* setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_VA. setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_LOAD. *) + +(* hexploit switch_spec. *) +(* { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } *) +(* { unfold wf_env in WFC3. specialize (WFC3 cnt_cur). des_ifs. eapply WFC3. } *) +(* eapply FIND_CNT_CUR. eapply CNT_CUR_MEM_VA. *) +(* { rewrite CNT_CUR_MEM_LOAD. rewrite map_length. auto. } *) +(* instantiate (1:=le). *) +(* instantiate (1:= (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)). *) +(* instantiate (1:=Sreturn None). *) +(* intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). *) +(* rename MEM into DELTA. move ECCASES after CUR_SWITCH_STAR. *) + +(* assert (FIND_F_C: Genv.find_funct ge_c (Vptr b_ext Ptrofs.zero) = *) +(* Some (External ef (list_typ_to_typelist (sig_args (ef_sig ef))) (rettype_to_type (sig_res (ef_sig ef))) (sig_cc (ef_sig ef)))). *) +(* { unfold match_find_def in MS3. hexploit MS3. *) +(* unfold Genv.find_funct in FINDF. rewrite pred_dec_true in FINDF; auto. unfold Genv.find_funct_ptr in FINDF. des_ifs. eapply Heq. *) +(* eapply Senv.find_invert_symbol; eapply FINDB. *) +(* intros. des_ifs. ss. rewrite pred_dec_true; auto. rewrite Genv.find_funct_ptr_iff. auto. *) +(* } *) +(* assert (COMP_F_C: comp_of f = Genv.find_comp ge_c (Vptr b_ext Ptrofs.zero)). *) +(* { unfold Genv.type_of_call in INTRA. des_ifs. *) +(* setoid_rewrite CP_CUR. apply Peqb_true_eq in Heq. rewrite Heq. *) +(* unfold Genv.find_comp. setoid_rewrite FIND_F_C. ss. *) +(* } *) + +(* desH ECCASES; cycle 1. *) + +(* (* Case 3-1: observable defined external calls *) *) +(* { subst d. unfold mem_delta_apply_wf in DELTA. simpl in DELTA. inversion DELTA; clear DELTA. subst m1'. *) +(* hexploit exists_vargs_vres. eapply MS0. eapply ECCASES. eauto. intros (EVALS & EXT2). *) +(* eapply star_cut_middle. exists E0. *) +(* eexists. split. *) +(* { unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. *) +(* eapply star_trans. eapply code_bundle_trace_spec. 2: ss. *) +(* unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. *) +(* rewrite ! (match_symbs_code_bundle_call ge_i ge_c) in CUR_SWITCH_STAR. *) +(* rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. *) +(* eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: destruct MS0 as (MS & _); auto. *) +(* clear BOUND2 CUR_SWITCH_STAR. *) +(* unfold code_bundle_call. eapply star_trans. eapply code_mem_delta_correct. auto. *) +(* { unfold mem_delta_apply_wf. simpl. reflexivity. } *) +(* 2: ss. econs 2. 2: econs 1. 2: traceEq. *) +(* eapply step_call. ss. *) +(* { econs. assert (FSN_C: Senv.find_symbol ge_c id_next = Some b_ext). *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1. auto. } *) +(* eapply eval_Evar_global. *) +(* - unfold wf_env in WFC3. specialize (WFC3 id_next). rewrite FSN_C in WFC3. apply WFC3. *) +(* - eapply FSN_C. *) +(* - econs 2. ss. *) +(* } *) +(* { eapply EVALS. } *) +(* { eapply FIND_F_C. } *) +(* { ss. } *) +(* { left. apply COMP_F_C. } *) +(* { i. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_F_C. rewrite COMP_F_C in H. inv H. } *) +(* { econs 1. ii. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_F_C. rewrite COMP_F_C in H. inv H. } *) +(* } *) +(* clear BOUND2 CUR_SWITCH_STAR. *) +(* assert (COMP_SAME: comp_of f = comp_of ef). *) +(* { rewrite COMP_F_C. unfold Genv.find_comp. rewrite FIND_F_C. ss. } *) +(* do 2 eexists. split. *) +(* { econs 2. eapply step_external_function. eapply EXT2. *) +(* econs 2. eapply step_returnstate. *) +(* { i. exfalso. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_SAME. rewrite COMP_SAME in H. ss. } *) +(* { econs 1. rewrite COMP_SAME. unfold Genv.type_of_call. rewrite Pos.eqb_refl. ss. } *) +(* econs 2. eapply step_skip_or_continue_loop1. left; auto. econs 2. eapply step_skip_loop2. *) +(* econs 1. all: ss. *) +(* } *) +(* splits. *) +(* 2:{ unfold unbundle. ss. traceEq. } *) + +(* left. exists id_cur. split. *) +(* { ss. splits; auto. *) +(* - unfold wf_counters. split; auto. *) +(* move WFC0 after COMP_SAME. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. *) +(* unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. *) +(* exists b0. splits; auto. *) +(* + eapply mem_valid_access_wunchanged_on. eapply WFC7. *) +(* eapply store_wunchanged_on. eapply CNT_CUR_STORE. instantiate (1:= fun _ _ => True). ss. *) +(* + destruct (Pos.eq_dec id id_cur). *) +(* * subst id. assert (cnt_cur = cnt). *) +(* { rewrite WFC0 in CNTS_CUR. clarify. } *) +(* subst cnt. assert (b0 = cnt_cur_b). *) +(* { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } *) +(* subst b0. assert (b = cur). *) +(* { rewrite FIND_CUR_I in H. clarify. } *) +(* subst b. assert (gd = Gfun (AST.Internal f_i_cur)). *) +(* { apply Genv.find_funct_ptr_iff in FINDF_I_CUR. setoid_rewrite FINDF_I_CUR in H0. clarify. } *) +(* subst gd. *) +(* ss. erewrite Mem.load_store_same. *) +(* 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. *) +(* ss. rewrite map_length. rewrite get_id_tr_app. ss. *) +(* rewrite Pos.eqb_refl. rewrite app_length. ss. *) +(* do 2 f_equal. apply nat64_int64_add_one. *) +(* subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. *) +(* eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. *) +(* apply Nat.le_add_r. *) +(* * ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. *) +(* 2:{ left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC6. *) +(* rewrite FIND_CNT_CUR in WFC6. clarify. rename cnt into cnt_cur. *) +(* specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. *) +(* } *) +(* rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. rewrite WFC8. auto. *) +(* - hexploit wunchanged_on_exists_mem_free_list. *) +(* { eapply store_wunchanged_on. eapply CNT_CUR_STORE. } *) +(* eapply FREEENV. intros (m_f & FREE2). esplits. eapply FREE2. *) +(* eapply wf_c_cont_wunchanged_on. eapply WFC1. *) +(* hexploit wunchanged_on_free_list_preserves. 2: eapply FREEENV. 2: eapply FREE2. 2: auto. *) +(* eapply store_wunchanged_on. eapply CNT_CUR_STORE. *) +(* - move WFC2 after COMP_SAME. unfold wf_c_stmt in *. i. rewrite CNTS_CUR in H. inv H. rename cnt into cnt_cur. ss. *) +(* - move WFNB after COMP_SAME. unfold wf_c_nb in *. erewrite Mem.nextblock_store. eapply WFNB. eapply CNT_CUR_STORE. *) +(* } *) +(* { ss. exists k_c. splits; auto. *) +(* 2:{ unfold match_cur_fun. splits; eauto. } *) +(* move MS1 after COMP_SAME. move MCNTS after COMP_SAME. destruct MS1 as (MM0 & MM1 & MM2). *) +(* assert (m2 = m_i). *) +(* { eapply known_obs_preserves_mem. eapply ECCASES. } *) +(* subst m2. unfold match_mem. splits; auto. *) +(* { eapply Mem.store_outside_inject. eapply MM0. 2: eapply CNT_CUR_STORE. ss. i. *) +(* unfold match_cnts in MCNTS. eapply MCNTS. 3: eapply H. all: eauto. *) +(* } *) +(* } *) +(* } *) + +(* (* Case 3-2: observables unknown external calls *) *) +(* { hexploit external_call_unknowns_fo. eapply ECCASES. intros FO_I. *) +(* hexploit external_call_unknowns_val_inject_list. eapply ECCASES. intros ARGS_INJ. *) +(* move MS1 after ARGS_INJ. destruct MS1 as (MM0 & MM1 & MM2). *) +(* hexploit mem_delta_apply_establish_inject_preprocess2. *) +(* eapply MM0. eapply CNT_CUR_STORE. 2: eapply MM1. 2: eapply MM2. *) +(* 2: eapply DELTA. *) +(* 2:{ apply meminj_first_order_public_first_order. auto. } *) +(* { clear CUR_SWITCH_STAR CNT_CUR_STORE. ii. erewrite match_symbs_meminj_public in H. *) +(* 2:{ destruct MS0 as (MS & _). apply MS. } *) +(* unfold meminj_public in H. des_ifs. *) +(* eapply Senv.find_invert_symbol in FIND_CNT_CUR. rewrite FIND_CNT_CUR in Heq. clarify. *) +(* } *) +(* intros (m_next0 & DELTA_C & INJ0). *) +(* hexploit external_call_mem_inject_gen. *) +(* { eapply match_symbs_symbols_inject. destruct MS0 as (MS & _). apply MS. } *) +(* apply EC. apply INJ0. apply ARGS_INJ. *) +(* intros (j2 & vres2 & m_next & EC2 & RET_INJ & INJ2 & UCH0 & UCH1 & INCR2 & INJ_SEP). *) +(* assert (COMP_SAME: comp_of f = comp_of ef). *) +(* { rewrite COMP_F_C. unfold Genv.find_comp. rewrite FIND_F_C. ss. } *) + +(* exists (State f stmt k0 e le m_next). split. *) +(* { unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. *) +(* eapply star_trans. eapply code_bundle_trace_spec. 2: ss. *) +(* unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. *) +(* rewrite ! (match_symbs_code_bundle_call ge_i ge_c) in CUR_SWITCH_STAR. *) +(* rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. *) +(* eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: destruct MS0 as (MS & _); auto. *) +(* clear BOUND2 CUR_SWITCH_STAR CNT_CUR_STORE. *) +(* unfold code_bundle_call. eapply star_trans. eapply code_mem_delta_correct. auto. *) +(* { erewrite <- match_symbs_mem_delta_apply_wf. rewrite CP_CUR. eapply DELTA_C. *) +(* destruct MS0 as (MSYMB & _). auto. *) +(* } *) +(* 2: ss. unfold unbundle. simpl. *) +(* econs 2. eapply step_call. ss. *) +(* { econs. assert (FSN_C: Senv.find_symbol ge_c id_next = Some b_ext). *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1. auto. } *) +(* eapply eval_Evar_global. *) +(* - unfold wf_env in WFC3. specialize (WFC3 id_next). rewrite FSN_C in WFC3. apply WFC3. *) +(* - eapply FSN_C. *) +(* - econs 2. ss. *) +(* } *) +(* { eapply match_symbs_vals_public_eval_to_vargs; auto. *) +(* destruct MS0 as (MS0 & _). auto. *) +(* eapply extcall_unkowns_vals_public; eauto. *) +(* } *) +(* { eapply FIND_F_C. } *) +(* { ss. } *) +(* { left. apply COMP_F_C. } *) +(* { i. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_F_C. rewrite COMP_F_C in H. inv H. } *) +(* { econs 1. ii. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_F_C. rewrite COMP_F_C in H. inv H. } *) + +(* econs 2. eapply step_external_function. eapply EC2. *) +(* econs 2. eapply step_returnstate. *) +(* { i. exfalso. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_SAME. rewrite COMP_SAME in H. ss. } *) +(* { econs 1. rewrite COMP_SAME. unfold Genv.type_of_call. rewrite Pos.eqb_refl. ss. } *) +(* econs 2. eapply step_skip_or_continue_loop1. left; auto. econs 2. eapply step_skip_loop2. *) +(* econs 1. all: ss. traceEq. *) +(* } *) + +(* clear CUR_SWITCH_STAR BOUND2. *) +(* assert (UCH2: Mem.unchanged_on (fun b _ => forall b0 ofs0, (meminj_public ge_i) b0 <> Some (b, ofs0)) m_next0 m_next). *) +(* { eapply Mem.unchanged_on_implies. eapply UCH1. ii. eapply H; eauto. } *) +(* assert (UCH3: Mem.unchanged_on (fun b _ => Senv.invert_symbol ge_c b = None) m_next0 m_next). *) +(* { eapply Mem.unchanged_on_implies. eapply UCH2. ss. i. unfold meminj_public. des_ifs. ii. clarify. *) +(* apply Senv.invert_find_symbol in Heq. destruct MS0 as ((MSE1 & MSE2 & MSE3) & _). apply MSE2 in Heq. *) +(* apply Senv.find_invert_symbol in Heq. setoid_rewrite H in Heq. ss. *) +(* } *) +(* eapply mem_unchanged_wunchanged in UCH3. *) +(* hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros UCH4. *) +(* hexploit wunchanged_on_trans. eapply UCH4. eapply UCH3. intros UCH5. *) +(* hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros UCH6. *) +(* hexploit wunchanged_on_trans. eapply UCH6. eapply UCH5. intros UCH7. *) +(* clear UCH3 UCH4 UCH5 UCH6. *) +(* left. exists id_cur. split. *) +(* { ss. splits; auto. *) +(* - unfold wf_counters. split; auto. *) +(* move WFC0 after COMP_SAME. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. *) +(* unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. *) +(* exists b0. splits; auto. *) +(* + move MCNTS after COMP_SAME. *) +(* eapply mem_valid_access_wunchanged_on. 2: eapply mem_unchanged_wunchanged; eapply UCH2. *) +(* eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. *) +(* eapply mem_valid_access_wunchanged_on. 2: eapply store_wunchanged_on; eapply CNT_CUR_STORE. *) +(* auto. instantiate (1:= fun _ _ => True). ss. *) +(* ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. *) +(* + destruct (Pos.eq_dec id id_cur). *) +(* * subst id. assert (cnt_cur = cnt). *) +(* { rewrite WFC0 in CNTS_CUR. clarify. } *) +(* subst cnt. assert (b0 = cnt_cur_b). *) +(* { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } *) +(* subst b0. assert (b = cur). *) +(* { rewrite FIND_CUR_I in H. clarify. } *) +(* subst b. assert (gd = Gfun (AST.Internal f_i_cur)). *) +(* { apply Genv.find_funct_ptr_iff in FINDF_I_CUR. setoid_rewrite FINDF_I_CUR in H0. clarify. } *) +(* subst gd. *) +(* ss. eapply Mem.load_unchanged_on. eapply UCH2. *) +(* { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } *) +(* erewrite mem_delta_apply_wf_mem_load. *) +(* 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } *) +(* 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } *) +(* 2:{ auto. } *) +(* erewrite Mem.load_store_same. *) +(* 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. *) +(* { ss. rewrite map_length. rewrite get_id_tr_app. ss. rewrite Pos.eqb_refl. rewrite app_length. ss. *) +(* do 2 f_equal. apply nat64_int64_add_one. *) +(* subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. *) +(* eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. *) +(* apply Nat.le_add_r. *) +(* } *) +(* * eapply Mem.load_unchanged_on. eapply UCH2. *) +(* { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } *) +(* erewrite mem_delta_apply_wf_mem_load. *) +(* 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } *) +(* 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } *) +(* 2:{ auto. } *) +(* ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. *) +(* { rewrite WFC8. rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. auto. } *) +(* { left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC6. *) +(* rewrite FIND_CNT_CUR in WFC6. clarify. rename cnt into cnt_cur. *) +(* specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. *) +(* } *) + +(* - move FREEENV after COMP_SAME. move WFC1 after FREEENV. move WFC4 after FREEENV. *) +(* hexploit wunchanged_on_exists_mem_free_list_2. eapply FREEENV. *) +(* instantiate (2:=ge_c). eapply UCH7. ss. *) +(* intros (m_c' & FREE2). esplits. eapply FREE2. *) +(* eapply wf_c_cont_wunchanged_on_2. eapply WFC1. *) +(* eapply wunchanged_on_free_list_preserves_gen. 2,3: eauto. auto. *) +(* - move WFNB after UCH7. eapply wf_c_nb_wunchanged_on; eauto. *) +(* } *) +(* { ss. exists j2. splits; auto. *) +(* 2:{ unfold match_cur_fun. splits; eauto. } *) +(* { unfold match_mem. splits; auto. move DELTA after UCH7. move EC after UCH7. *) +(* eapply meminj_not_alloc_delta in MM2. 2: eapply DELTA. *) +(* eapply meminj_not_alloc_external_call. eapply MM2. eauto. *) +(* } *) +(* { ii. assert (NINJP: (meminj_public ge_i) b = None). *) +(* { move MCNTS after UCH7. specialize (MCNTS _ _ _ H H0 b ofs). *) +(* destruct (meminj_public ge_i b) eqn:CASES; ss. exfalso. *) +(* destruct p. move MM1 after UCH7. move INCR2 after UCH7. *) +(* unfold inject_incr in *. hexploit MM1. apply CASES. hexploit INCR2. apply CASES. *) +(* i. rewrite H1 in H2. clarify. *) +(* } *) +(* specialize (INJ_SEP _ _ _ NINJP H1). des. apply INJ_SEP0. *) +(* hexploit Genv.genv_symb_range. eapply H0. intros RANGE. *) +(* move WFNB before RANGE. *) +(* hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros T1. *) +(* hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros T2. *) +(* eapply wunchanged_on_nextblock in T1, T2. revert_until NINJP. clear. i. *) +(* unfold wf_c_nb in WFNB. unfold Mem.valid_block. eapply Plt_Ple_trans. eauto. *) +(* etransitivity. eapply WFNB. etransitivity; eauto. *) +(* } *) +(* } *) +(* } *) + +(* Unshelve. all: exact (fun _ _ => True). *) +(* Qed. *) + +(* Lemma ir_to_clight_step_4 *) +(* ge_i ge_c *) +(* (WFGE : wf_ge ge_i) *) +(* cnts pars k_i cur m_i pretr btr tr ef d vargs id_cur *) +(* (BOUND : Z.of_nat *) +(* (Datatypes.length *) +(* (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr)) < *) +(* Int64.modulus) *) +(* k_c id f stmt k0 e le m_c *) +(* (MS0 : match_genv ge_i ge_c) *) +(* (MS1 : match_mem ge_i k_c m_i m_c) *) +(* (MS2 : match_cur_fun ge_i ge_c cur f id) *) +(* (MS4 : match_cont ge_c *) +(* (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) cnts *) +(* k0 k_i) *) +(* (MS3 : match_find_def ge_i ge_c cnts pars *) +(* (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr)) *) +(* (MS5 : match_params pars ge_c ge_i) *) +(* (MCNTS : match_cnts cnts ge_c k_c) *) +(* (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), *) +(* cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) *) +(* (WFC0 : forall (id : ident) (b : block) gd, *) +(* Genv.find_symbol ge_i id = Some b -> *) +(* Genv.find_def ge_i b = Some gd -> *) +(* exists cnt : ident, *) +(* cnts ! id = Some cnt /\ *) +(* wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) *) +(* m_freeenv *) +(* (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) *) +(* (WFC1 : wf_c_cont ge_c m_freeenv k0) *) +(* (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id *) +(* (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) stmt) *) +(* (WFC3 : wf_env ge_c e) *) +(* (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) *) +(* (WFNB : wf_c_nb ge_c m_c) *) +(* m2 m1' vretv *) +(* (MEM : mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = *) +(* Some m1') *) +(* (ALLOWED : comp_of ef = Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) *) +(* (EC : external_call ef ge_i vargs m1' tr vretv m2) *) +(* (ECCASES : external_call_unknowns ef ge_i m1' vargs \/ *) +(* external_call_known_observables ef ge_i m1' vargs tr vretv m2 /\ d = []) *) +(* (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) *) +(* : *) +(* exists cst2 : state, *) +(* star step1 ge_c (State f stmt k0 e le m_c) *) +(* (unbundle (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d)) cst2 /\ *) +(* ((exists id' : positive, *) +(* wf_c_state ge_i ge_c *) +(* (pretr ++ [(id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d)]) *) +(* (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) cnts *) +(* id' cst2 /\ *) +(* (exists k : meminj, *) +(* match_state ge_i ge_c k *) +(* (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) *) +(* cnts pars id' (Some (cur, m2, k_i)) cst2)) \/ Some (cur, m2, k_i) = None). *) +(* Proof. *) +(* assert (id = id_cur). *) +(* { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } *) +(* subst id. *) +(* destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). *) + +(* set (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) as ttr in *. *) +(* assert (FIND_CUR_I: Genv.find_symbol ge_i id_cur = Some cur). *) +(* { apply Genv.invert_find_symbol in IDCUR. auto. } *) +(* assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1 in FIND_CUR_I. auto. } *) +(* assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). *) +(* { auto. } *) + +(* exploit WFC0. eapply FIND_CUR_I. rewrite <- Genv.find_funct_ptr_iff; eapply FINDF_I_CUR. *) +(* intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). *) +(* assert (CUR_TR: get_id_tr ttr id_cur = (get_id_tr pretr id_cur) ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: (get_id_tr btr id_cur)). *) +(* { subst ttr. clear. rewrite get_id_tr_app. rewrite get_id_tr_cons. ss. rewrite Pos.eqb_refl. auto. } *) +(* assert (BOUND2: Z.of_nat (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr ttr id_cur))) < Int64.modulus). *) +(* { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. *) +(* apply inj_le. apply list_length_filter_le. *) +(* } *) +(* destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). *) + +(* hexploit cur_fun_def. eapply FINDF_C_CUR. eapply FINDF_I_CUR. eapply INV_CUR. eauto. *) +(* intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). *) +(* rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. *) +(* assert (CP_CUR: (comp_of f) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). *) +(* { unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. subst f. ss. } *) +(* assert (COMP_CUR_EQ: comp_of (@Gfun _ unit (AST.Internal f_i_cur)) = comp_of f). *) +(* { subst f. ss. } *) +(* setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_VA. setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_LOAD. *) + +(* hexploit switch_spec. *) +(* { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } *) +(* { unfold wf_env in WFC3. specialize (WFC3 cnt_cur). des_ifs. eapply WFC3. } *) +(* eapply FIND_CNT_CUR. eapply CNT_CUR_MEM_VA. *) +(* { rewrite CNT_CUR_MEM_LOAD. rewrite map_length. auto. } *) +(* instantiate (1:=le). *) +(* instantiate (1:= (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)). *) +(* instantiate (1:=Sreturn None). *) +(* intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). *) +(* assert (COMP_SAME: comp_of f = comp_of ef). *) +(* { rewrite ALLOWED. apply CP_CUR. } *) +(* rename MEM into DELTA. move ECCASES after CUR_SWITCH_STAR. *) + +(* desH ECCASES; cycle 1. *) + +(* (* Case 4-1: observable defined external calls *) *) +(* { subst d. unfold mem_delta_apply_wf in DELTA. simpl in DELTA. inversion DELTA; clear DELTA. subst m1'. *) +(* hexploit exists_vargs_vres_2. eapply MS0. eapply ECCASES. eauto. intros (vargs2 & vretv2 & EVALS & EXT2). *) +(* eapply star_cut_middle. exists E0. *) +(* eexists. split. *) +(* { unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. *) +(* eapply star_trans. eapply code_bundle_trace_spec. 2: ss. *) +(* unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. *) +(* rewrite ! (match_symbs_code_bundle_builtin ge_i ge_c) in CUR_SWITCH_STAR. *) +(* rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. *) +(* eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: destruct MS0 as (MS & _); auto. *) +(* clear BOUND2 CUR_SWITCH_STAR. *) +(* unfold code_bundle_builtin. eapply star_trans. eapply code_mem_delta_correct. auto. *) +(* { unfold mem_delta_apply_wf. simpl. reflexivity. } *) +(* econs 1. ss. *) +(* } *) +(* clear BOUND2 CUR_SWITCH_STAR. *) +(* do 2 eexists. split. econs 2. *) +(* { eapply step_builtin. ss. *) +(* { eapply EVALS. } *) +(* { auto. } *) +(* { eapply EXT2. } *) +(* } *) +(* econs 2. eapply step_skip_or_continue_loop1. left; auto. *) +(* econs 2. eapply step_skip_loop2. *) +(* econs 1. all: ss. *) +(* splits. *) +(* 2:{ unfold unbundle. ss. traceEq. } *) + +(* left. exists id_cur. split. *) +(* { splits; auto. *) +(* - unfold wf_counters. split; auto. *) +(* move WFC0 after COMP_SAME. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. *) +(* unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. *) +(* exists b0. splits; auto. *) +(* + eapply mem_valid_access_wunchanged_on. eapply WFC7. *) +(* eapply store_wunchanged_on. eapply CNT_CUR_STORE. instantiate (1:= fun _ _ => True). ss. *) +(* + destruct (Pos.eq_dec id id_cur). *) +(* * subst id. assert (cnt_cur = cnt). *) +(* { rewrite WFC0 in CNTS_CUR. clarify. } *) +(* subst cnt. assert (b0 = cnt_cur_b). *) +(* { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } *) +(* subst b0. assert (b = cur). *) +(* { rewrite FIND_CUR_I in H. clarify. } *) +(* subst b. assert (gd = Gfun (AST.Internal f_i_cur)). *) +(* { apply Genv.find_funct_ptr_iff in FINDF_I_CUR. setoid_rewrite FINDF_I_CUR in H0. clarify. } *) +(* subst gd. *) +(* ss. erewrite Mem.load_store_same. *) +(* 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. *) +(* ss. rewrite map_length. rewrite get_id_tr_app. ss. *) +(* rewrite Pos.eqb_refl. rewrite app_length. ss. *) +(* do 2 f_equal. apply nat64_int64_add_one. *) +(* subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. *) +(* eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. *) +(* apply Nat.le_add_r. *) +(* * ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. *) +(* 2:{ left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC6. *) +(* rewrite FIND_CNT_CUR in WFC6. clarify. rename cnt into cnt_cur. *) +(* specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. *) +(* } *) +(* rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. rewrite WFC8. auto. *) +(* - hexploit wunchanged_on_exists_mem_free_list. *) +(* { eapply store_wunchanged_on. eapply CNT_CUR_STORE. } *) +(* eapply FREEENV. intros (m_f & FREE2). esplits. eapply FREE2. *) +(* eapply wf_c_cont_wunchanged_on. eapply WFC1. *) +(* hexploit wunchanged_on_free_list_preserves. 2: eapply FREEENV. 2: eapply FREE2. 2: auto. *) +(* eapply store_wunchanged_on. eapply CNT_CUR_STORE. *) +(* - move WFC2 after COMP_SAME. unfold wf_c_stmt in *. i. rewrite CNTS_CUR in H. inv H. rename cnt into cnt_cur. ss. *) +(* - move WFNB after COMP_SAME. unfold wf_c_nb in *. erewrite Mem.nextblock_store. eapply WFNB. eapply CNT_CUR_STORE. *) +(* } *) +(* { ss. exists k_c. splits; auto. *) +(* 2:{ unfold match_cur_fun. splits; eauto. } *) +(* move MS1 after COMP_SAME. move MCNTS after COMP_SAME. destruct MS1 as (MM0 & MM1 & MM2). *) +(* assert (m2 = m_i). *) +(* { eapply known_obs_preserves_mem. eapply ECCASES. } *) +(* subst m2. unfold match_mem. splits; auto. *) +(* { eapply Mem.store_outside_inject. eapply MM0. 2: eapply CNT_CUR_STORE. ss. i. *) +(* unfold match_cnts in MCNTS. eapply MCNTS. 3: eapply H. all: eauto. *) +(* } *) +(* } *) +(* } *) + +(* (* Case 4-2: observables unknown external calls *) *) +(* { hexploit external_call_unknowns_fo. eapply ECCASES. intros FO_I. *) +(* hexploit external_call_unknowns_val_inject_list. eapply ECCASES. intros ARGS_INJ. *) +(* move MS1 after ARGS_INJ. destruct MS1 as (MM0 & MM1 & MM2). *) +(* hexploit mem_delta_apply_establish_inject_preprocess2. *) +(* eapply MM0. eapply CNT_CUR_STORE. 2: eapply MM1. 2: eapply MM2. *) +(* 2: eapply DELTA. *) +(* 2:{ apply meminj_first_order_public_first_order. auto. } *) +(* { clear CUR_SWITCH_STAR CNT_CUR_STORE. ii. erewrite match_symbs_meminj_public in H. *) +(* 2:{ destruct MS0 as (MS & _). apply MS. } *) +(* unfold meminj_public in H. des_ifs. *) +(* eapply Senv.find_invert_symbol in FIND_CNT_CUR. rewrite FIND_CNT_CUR in Heq. clarify. *) +(* } *) +(* intros (m_next0 & DELTA_C & INJ0). *) +(* hexploit external_call_mem_inject_gen. *) +(* { eapply match_symbs_symbols_inject. destruct MS0 as (MS & _). apply MS. } *) +(* apply EC. apply INJ0. apply ARGS_INJ. *) +(* intros (j2 & vres2 & m_next & EC2 & RET_INJ & INJ2 & UCH0 & UCH1 & INCR2 & INJ_SEP). *) + +(* exists (State f stmt k0 e le m_next). split. *) +(* { unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. *) +(* eapply star_trans. eapply code_bundle_trace_spec. 2: ss. *) +(* unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. *) +(* rewrite ! (match_symbs_code_bundle_builtin ge_i ge_c) in CUR_SWITCH_STAR. *) +(* rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. *) +(* eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: destruct MS0 as (MS & _); auto. *) +(* clear BOUND2 CUR_SWITCH_STAR CNT_CUR_STORE. *) +(* unfold code_bundle_builtin. eapply star_trans. eapply code_mem_delta_correct. auto. *) +(* { erewrite <- match_symbs_mem_delta_apply_wf. rewrite CP_CUR. eapply DELTA_C. *) +(* destruct MS0 as (MSYMB & _). auto. *) +(* } *) +(* 2: ss. unfold unbundle. simpl. *) +(* econs 2. eapply step_builtin. *) +(* { eapply match_symbs_vals_public_eval_to_vargs_2; auto. *) +(* destruct MS0 as (MS0 & _). auto. eapply extcall_unkowns_vals_public; eauto. *) +(* } *) +(* { auto. } *) +(* { eapply EC2. } *) +(* econs 2. eapply step_skip_or_continue_loop1. left; auto. *) +(* econs 2. eapply step_skip_loop2. econs 1. all: ss. traceEq. *) +(* } *) + +(* clear CUR_SWITCH_STAR BOUND2. *) +(* assert (UCH2: Mem.unchanged_on (fun b _ => forall b0 ofs0, (meminj_public ge_i) b0 <> Some (b, ofs0)) m_next0 m_next). *) +(* { eapply Mem.unchanged_on_implies. eapply UCH1. ii. eapply H; eauto. } *) +(* assert (UCH3: Mem.unchanged_on (fun b _ => Senv.invert_symbol ge_c b = None) m_next0 m_next). *) +(* { eapply Mem.unchanged_on_implies. eapply UCH2. ss. i. unfold meminj_public. des_ifs. ii. clarify. *) +(* apply Senv.invert_find_symbol in Heq. destruct MS0 as ((MSE1 & MSE2 & MSE3) & _). apply MSE2 in Heq. *) +(* apply Senv.find_invert_symbol in Heq. setoid_rewrite H in Heq. ss. *) +(* } *) +(* eapply mem_unchanged_wunchanged in UCH3. *) +(* hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros UCH4. *) +(* hexploit wunchanged_on_trans. eapply UCH4. eapply UCH3. intros UCH5. *) +(* hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros UCH6. *) +(* hexploit wunchanged_on_trans. eapply UCH6. eapply UCH5. intros UCH7. *) +(* clear UCH3 UCH4 UCH5 UCH6. *) +(* left. exists id_cur. split. *) +(* { ss. splits; auto. *) +(* - unfold wf_counters. split; auto. *) +(* move WFC0 after COMP_SAME. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. *) +(* unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. *) +(* exists b0. splits; auto. *) +(* + move MCNTS after COMP_SAME. *) +(* eapply mem_valid_access_wunchanged_on. 2: eapply mem_unchanged_wunchanged; eapply UCH2. *) +(* eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. *) +(* eapply mem_valid_access_wunchanged_on. 2: eapply store_wunchanged_on; eapply CNT_CUR_STORE. *) +(* auto. instantiate (1:= fun _ _ => True). ss. *) +(* ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. *) +(* + destruct (Pos.eq_dec id id_cur). *) +(* * subst id. assert (cnt_cur = cnt). *) +(* { rewrite WFC0 in CNTS_CUR. clarify. } *) +(* subst cnt. assert (b0 = cnt_cur_b). *) +(* { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } *) +(* subst b0. assert (b = cur). *) +(* { rewrite FIND_CUR_I in H. clarify. } *) +(* subst b. assert (gd = Gfun (AST.Internal f_i_cur)). *) +(* { apply Genv.find_funct_ptr_iff in FINDF_I_CUR. setoid_rewrite FINDF_I_CUR in H0. clarify. } *) +(* subst gd. *) +(* ss. eapply Mem.load_unchanged_on. eapply UCH2. *) +(* { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } *) +(* erewrite mem_delta_apply_wf_mem_load. *) +(* 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } *) +(* 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } *) +(* 2:{ auto. } *) +(* erewrite Mem.load_store_same. *) +(* 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. *) +(* { ss. rewrite map_length. rewrite get_id_tr_app. ss. rewrite Pos.eqb_refl. rewrite app_length. ss. *) +(* do 2 f_equal. apply nat64_int64_add_one. *) +(* subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. *) +(* eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. *) +(* apply Nat.le_add_r. *) +(* } *) +(* * eapply Mem.load_unchanged_on. eapply UCH2. *) +(* { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } *) +(* erewrite mem_delta_apply_wf_mem_load. *) +(* 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } *) +(* 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } *) +(* 2:{ auto. } *) +(* ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. *) +(* { rewrite WFC8. rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. auto. } *) +(* { left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC6. *) +(* rewrite FIND_CNT_CUR in WFC6. clarify. rename cnt into cnt_cur. *) +(* specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. *) +(* } *) + +(* - move FREEENV after COMP_SAME. move WFC1 after FREEENV. move WFC4 after FREEENV. *) +(* hexploit wunchanged_on_exists_mem_free_list_2. eapply FREEENV. *) +(* instantiate (2:=ge_c). eapply UCH7. ss. *) +(* intros (m_c' & FREE2). esplits. eapply FREE2. *) +(* eapply wf_c_cont_wunchanged_on_2. eapply WFC1. *) +(* eapply wunchanged_on_free_list_preserves_gen. 2,3: eauto. auto. *) +(* - move WFNB after UCH7. eapply wf_c_nb_wunchanged_on; eauto. *) +(* } *) +(* { ss. exists j2. splits; auto. *) +(* 2:{ unfold match_cur_fun. splits; eauto. } *) +(* { unfold match_mem. splits; auto. move DELTA after UCH7. move EC after UCH7. *) +(* eapply meminj_not_alloc_delta in MM2. 2: eapply DELTA. *) +(* eapply meminj_not_alloc_external_call. eapply MM2. eauto. *) +(* } *) +(* { ii. assert (NINJP: (meminj_public ge_i) b = None). *) +(* { move MCNTS after UCH7. specialize (MCNTS _ _ _ H H0 b ofs). *) +(* destruct (meminj_public ge_i b) eqn:CASES; ss. exfalso. *) +(* destruct p. move MM1 after UCH7. move INCR2 after UCH7. *) +(* unfold inject_incr in *. hexploit MM1. apply CASES. hexploit INCR2. apply CASES. *) +(* i. rewrite H1 in H2. clarify. *) +(* } *) +(* specialize (INJ_SEP _ _ _ NINJP H1). des. apply INJ_SEP0. *) +(* hexploit Genv.genv_symb_range. eapply H0. intros RANGE. *) +(* move WFNB before RANGE. *) +(* hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros T1. *) +(* hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros T2. *) +(* eapply wunchanged_on_nextblock in T1, T2. revert_until NINJP. clear. i. *) +(* unfold wf_c_nb in WFNB. unfold Mem.valid_block. eapply Plt_Ple_trans. eauto. *) +(* etransitivity. eapply WFNB. etransitivity; eauto. *) +(* } *) +(* } *) +(* } *) + +(* Unshelve. all: exact (fun _ _ => True). *) +(* Qed. *) + +(* Lemma ir_to_clight_step *) +(* (ge_i: Asm.genv) (ge_c: Clight.genv) *) +(* (WFGE: wf_ge ge_i) *) +(* cnts pars ist1 ev ist2 *) +(* (STEP: ir_step ge_i ist1 ev ist2) *) +(* ttr pretr btr *) +(* (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) *) +(* (TOTAL: ttr = pretr ++ ev :: btr) *) +(* cst1 k id *) +(* (WFC: wf_c_state ge_i ge_c pretr ttr cnts id cst1) *) +(* (MS: match_state ge_i ge_c k ttr cnts pars id ist1 cst1) *) +(* : *) +(* exists cst2, (star step1 ge_c cst1 (unbundle ev) cst2) /\ *) +(* ((exists id', (wf_c_state ge_i ge_c (pretr ++ [ev]) ttr cnts id' cst2) /\ *) +(* exists k, (match_state ge_i ge_c k ttr cnts pars id' ist2 cst2)) *) +(* \/ (ist2 = None)). *) +(* Proof. *) +(* unfold wf_c_state in WFC. des_ifs. rename s into stmt, k into k_c, m into m_c. *) +(* destruct WFC as ((CNT_INJ & WFC0) & (m_freeenv & FREEENV & WFC1) & WFC2 & WFC3 & WFC4 & WFNB). *) +(* unfold match_state in MS. des_ifs. rename i into k_i, b into cur, m into m_i. *) +(* destruct MS as (MS0 & MS1 & MS2 & MS3 & MS4 & MS5 & MCNTS). *) +(* move STEP after WFC4. inv STEP. *) + +(* (** Case 1: Cross Call *) *) +(* - eapply ir_to_clight_step_1; eauto. *) + +(* (** Case 2: Cross Return *) *) +(* - eapply ir_to_clight_step_2; eauto. *) + +(* (** Case 3: Internal-External Call *) *) +(* - eapply ir_to_clight_step_3; eauto. *) + +(* (** Case 4: Builtins *) *) +(* - eapply ir_to_clight_step_4; eauto. *) + +(* (** Case 5: Cross Call External 1 *) *) +(* - hexploit ir_to_clight_step_cce_1; eauto. *) +(* { unfold mem_delta_apply_wf. ss. } *) +(* { exists []. rewrite app_nil_r. auto. } *) +(* intros (cnt_cur & cnt_cur_b & (CNT_CUR & FIND_CNT & CNT_CUR_NP) & m_c' & STAR & MEM). *) +(* destruct MEM as (m_cu & CNT_CUR_STORE & DELTA_NIL & DELTA_PUB). *) +(* eapply star_cut_middle. esplits. *) +(* { eapply STAR. } *) +(* { econs 1. } *) +(* { ss. right; auto. } *) +(* { unfold unbundle. ss. traceEq. } *) + +(* (** Case 6: Cross Call External 2 *) *) +(* - hexploit ir_to_clight_step_cce_2; eauto. *) +(* { exists []. rewrite app_nil_r. auto. } *) +(* rename MEM into DELTA. *) +(* intros (cnt_cur & cnt_cur_b & (CNT_CUR & FIND_CNT & CNT_CUR_NP) & m_c' & STAR & MEM). *) +(* destruct STAR as (vres & m_next & STAR & EC2). *) +(* destruct MEM as (m_cu & CNT_CUR_STORE & DELTA_NIL & DELTA_PUB). *) +(* eapply star_cut_middle. esplits. *) +(* { eapply STAR. } *) +(* { econs 1. } *) +(* { ss. right; auto. } *) +(* { unfold unbundle. ss. traceEq. } *) + +(* (** Case 7: Cross Call External 3 *) *) +(* - hexploit ir_to_clight_step_cce_2; eauto. *) +(* rename MEM into DELTA. *) +(* intros (cnt_cur & cnt_cur_b & (CNT_CUR & FIND_CNT & CNT_CUR_NP) & m_c' & STAR & MEM). *) +(* destruct STAR as (vres & m_next & STAR & EC2). *) +(* destruct MEM as (m_cu & CNT_CUR_STORE & DELTA_NIL & DELTA_PUB). *) + +(* assert (id = id_cur). *) +(* { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } *) +(* subst id. *) +(* assert (COMP_CUR_F: (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) = comp_of f). *) +(* { destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). *) +(* hexploit cur_fun_def. eapply FINDF_C_CUR. eapply FINDF_I_CUR. eapply INV_CUR. eauto. *) +(* intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). *) +(* unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. subst f. ss. *) +(* } *) +(* assert (FIND_CUR_I: Genv.find_symbol ge_i id_cur = Some cur). *) +(* { apply Genv.invert_find_symbol in IDCUR. auto. } *) +(* assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). *) +(* { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1 in FIND_CUR_I. auto. } *) +(* assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). *) +(* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) +(* assert (COMP_CUR_EQ: (comp_of (@Gfun _ unit (AST.Internal f_cur))) = comp_of f). *) +(* { rewrite <- COMP_CUR_F. unfold Genv.find_comp. setoid_rewrite INTERNAL. ss. } *) +(* desH ECCASES; cycle 1. *) + +(* (* Case 3-1: observable defined external calls *) *) +(* { clear DELTA_PUB. subst d. specialize (DELTA_NIL eq_refl). subst m_c'. *) +(* hexploit exists_vargs_vres. apply MS0. apply ECCASES. eauto. intros (_ & EC2'). *) +(* hexploit external_call_deterministic. eapply EC2. eapply EC2'. intros (EQ1 & EQ2). *) +(* subst vres m_cu. clear EC2'. *) +(* eapply star_cut_middle. esplits. eapply STAR. *) +(* econs 2. *) +(* { eapply step_returnstate. *) +(* - i. apply NPTR0. rewrite COMP_CUR_F. apply H. *) +(* - move TR3 after COMP_CUR_F. rewrite COMP_CUR_F in TR3. instantiate (1:=tr3). *) +(* inv TR3. econs; [auto |]. ss. *) +(* erewrite proj_rettype_to_type_rettype_of_type_eq. 2: apply H0. *) +(* eapply match_symbs_eventval_match. apply MS0. auto. *) +(* } *) +(* ss. econs 2. *) +(* { eapply step_skip_or_continue_loop1. auto. } *) +(* econs 2. *) +(* { eapply step_skip_loop2. } *) +(* econs 1. all: ss. *) +(* 2:{ unfold unbundle. ss. traceEq. } *) +(* left. exists id_cur. clear STAR. split. *) + +(* - splits; auto. *) +(* { unfold wf_counters. split; auto. *) +(* move WFC0 after COMP_CUR_F. i. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. *) +(* unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. *) +(* exists b1. splits; auto. *) +(* + eapply mem_valid_access_wunchanged_on. eapply WFC7. *) +(* eapply store_wunchanged_on. eapply CNT_CUR_STORE. instantiate (1:= fun _ _ => True). ss. *) +(* + destruct (Pos.eq_dec id id_cur). *) +(* * subst id. assert (cnt_cur = cnt). *) +(* { rewrite WFC0 in CNT_CUR. clarify. } *) +(* subst cnt. assert (b1 = cnt_cur_b). *) +(* { setoid_rewrite WFC6 in FIND_CNT. clarify. } *) +(* subst b1. assert (b0 = cur). *) +(* { rewrite FIND_CUR_I in H. clarify. } *) +(* subst b0. assert (gd = Gfun (AST.Internal f_cur)). *) +(* { apply Genv.find_funct_ptr_iff in INTERNAL. setoid_rewrite INTERNAL in H0. clarify. } *) +(* subst gd. *) +(* ss. erewrite Mem.load_store_same. *) +(* 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. *) +(* ss. rewrite map_length. rewrite get_id_tr_app. ss. *) +(* rewrite Pos.eqb_refl. rewrite app_length. ss. *) +(* do 2 f_equal. apply nat64_int64_add_one. *) +(* clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. *) +(* eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. *) +(* apply Nat.le_add_r. *) +(* * ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. *) +(* 2:{ left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT, WFC6. *) +(* rewrite FIND_CNT in WFC6. clarify. rename cnt into cnt_cur. *) +(* specialize (CNT_INJ _ _ _ CNT_CUR WFC0). clarify. *) +(* } *) +(* rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. *) +(* rewrite app_nil_r. rewrite WFC8. auto. *) +(* } *) +(* { hexploit wunchanged_on_exists_mem_free_list. *) +(* { eapply store_wunchanged_on. eapply CNT_CUR_STORE. } *) +(* eapply FREEENV. intros (m_f & FREE2). esplits. eapply FREE2. *) +(* eapply wf_c_cont_wunchanged_on. eapply WFC1. *) +(* hexploit wunchanged_on_free_list_preserves. 2: eapply FREEENV. 2: eapply FREE2. 2: auto. *) +(* eapply store_wunchanged_on. eapply CNT_CUR_STORE. *) +(* } *) +(* { ii. rewrite CNT_CUR in H. inv H. ss. } *) +(* { move WFNB after FIND_FUN_C. unfold wf_c_nb in *. erewrite Mem.nextblock_store. eapply WFNB. eapply CNT_CUR_STORE. *) +(* } *) +(* - exists k_c. splits; auto. *) +(* move MS1 after FIND_FUN_C. move MCNTS after MS1. destruct MS1 as (MM0 & MM1 & MM2). *) +(* unfold mem_delta_apply_wf in DELTA. ss. inv DELTA. *) +(* assert (m2 = m1'). *) +(* { eapply known_obs_preserves_mem. eapply ECCASES. } *) +(* subst m1'. unfold match_mem. splits; auto. *) +(* eapply Mem.store_outside_inject. eapply MM0. 2: eapply CNT_CUR_STORE. ss. i. *) +(* unfold match_cnts in MCNTS. eapply MCNTS. 3: eapply H. all: eauto. *) +(* } *) + +(* (* Case 3-2: observables unknown external calls *) *) +(* { hexploit external_call_unknowns_fo. eapply ECCASES. intros FO_I. *) +(* hexploit external_call_unknowns_val_inject_list. eapply ECCASES. intros ARGS_INJ. *) +(* hexploit meminj_first_order_public_first_order. apply FO_I. intros PFO. *) +(* clear DELTA_NIL. specialize (DELTA_PUB PFO). desH DELTA_PUB. rename DELTA_PUB0 into INJ0. *) +(* move MS1 after ARGS_INJ. destruct MS1 as (MM0 & MM1 & MM2). *) +(* hexploit external_call_mem_inject_gen. *) +(* { eapply match_symbs_symbols_inject. destruct MS0 as (MS & _). apply MS. } *) +(* apply TR2. apply INJ0. apply ARGS_INJ. *) +(* intros (j2 & vres2 & m_next' & EC2' & RET_INJ & INJ2 & UCH0 & UCH1 & INCR2 & INJ_SEP). *) +(* hexploit external_call_deterministic. eapply EC2. eapply EC2'. intros (EQ1 & EQ2). *) +(* subst vres m_next'. clear EC2'. *) +(* eapply star_cut_middle. esplits. eapply STAR. *) +(* econs 2. *) +(* { assert (CROSS_I: crossing_comp ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (comp_of ef)). *) +(* { move TR1 after INJ_SEP. inv TR1. apply H. } *) +(* assert (NPTR': not_ptr vretv). *) +(* { apply NPTR0. auto. } *) +(* eapply step_returnstate. *) +(* - i. eapply val_inject_not_ptr; eauto. *) +(* - move TR3 after COMP_CUR_F. rewrite COMP_CUR_F in TR3. instantiate (1:=tr3). *) +(* inv TR3. econs; [auto |]. ss. *) +(* erewrite proj_rettype_to_type_rettype_of_type_eq. 2: apply H0. *) + +(* hexploit not_ptr_val_inject_eq; eauto. i; subst vres2. *) +(* eapply match_symbs_eventval_match. apply MS0. auto. *) +(* } *) +(* econs 2. eapply step_skip_or_continue_loop1. left; auto. econs 2. eapply step_skip_loop2. *) +(* econs 1. all: ss. *) +(* 2:{ unfold unbundle. ss. traceEq. } *) + +(* rename m_c' into m_next0. rename DELTA_PUB into DELTA_C. *) +(* assert (UCH2: Mem.unchanged_on (fun b _ => forall b0 ofs0, (meminj_public ge_i) b0 <> Some (b, ofs0)) m_next0 m_next). *) +(* { eapply Mem.unchanged_on_implies. eapply UCH1. ii. eapply H; eauto. } *) +(* assert (UCH3: Mem.unchanged_on (fun b _ => Senv.invert_symbol ge_c b = None) m_next0 m_next). *) +(* { eapply Mem.unchanged_on_implies. eapply UCH2. ss. i. unfold meminj_public. des_ifs. ii. clarify. *) +(* apply Senv.invert_find_symbol in Heq. destruct MS0 as ((MSE1 & MSE2 & MSE3) & _). apply MSE2 in Heq. *) +(* apply Senv.find_invert_symbol in Heq. setoid_rewrite H in Heq. ss. *) +(* } *) +(* eapply mem_unchanged_wunchanged in UCH3. *) +(* hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros UCH4. *) +(* hexploit wunchanged_on_trans. eapply UCH4. eapply UCH3. intros UCH5. *) +(* hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros UCH6. *) +(* hexploit wunchanged_on_trans. eapply UCH6. eapply UCH5. intros UCH7. *) +(* clear UCH3 UCH4 UCH5 UCH6. *) + +(* left. exists id_cur. clear STAR. split. *) +(* { ss. splits; auto. *) +(* - unfold wf_counters. split; auto. *) +(* move WFC0 after INJ_SEP. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. *) +(* unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. *) +(* exists b1. splits; auto. *) +(* + move MCNTS after INJ_SEP. *) +(* eapply mem_valid_access_wunchanged_on. *) +(* 2: eapply mem_unchanged_wunchanged; eapply UCH2. *) +(* eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. *) +(* eapply mem_valid_access_wunchanged_on. 2: eapply store_wunchanged_on; eapply CNT_CUR_STORE. *) +(* auto. instantiate (1:= fun _ _ => True). ss. *) +(* ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. *) +(* + destruct (Pos.eq_dec id id_cur). *) +(* * subst id. assert (cnt_cur = cnt). *) +(* { rewrite WFC0 in CNT_CUR. clarify. } *) +(* subst cnt. assert (b1 = cnt_cur_b). *) +(* { setoid_rewrite WFC6 in FIND_CNT. clarify. } *) +(* subst b1. assert (b0 = cur). *) +(* { rewrite FIND_CUR_I in H. clarify. } *) +(* subst b0. assert (gd = Gfun (AST.Internal f_cur)). *) +(* { apply Genv.find_funct_ptr_iff in INTERNAL. setoid_rewrite INTERNAL in H0. clarify. } *) +(* subst gd. *) +(* ss. eapply Mem.load_unchanged_on. eapply UCH2. *) +(* { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } *) +(* erewrite mem_delta_apply_wf_mem_load. *) +(* 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } *) +(* 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } *) +(* 2:{ auto. } *) +(* erewrite Mem.load_store_same. *) +(* 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. *) +(* { ss. rewrite map_length. rewrite get_id_tr_app. ss. rewrite Pos.eqb_refl. rewrite app_length. ss. *) +(* do 2 f_equal. apply nat64_int64_add_one. *) +(* clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. *) +(* eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. *) +(* apply Nat.le_add_r. *) +(* } *) +(* * eapply Mem.load_unchanged_on. eapply UCH2. *) +(* { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } *) +(* erewrite mem_delta_apply_wf_mem_load. *) +(* 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } *) +(* 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } *) +(* 2:{ auto. } *) +(* ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. *) +(* { rewrite WFC8. rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. auto. } *) +(* { left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT, WFC6. *) +(* rewrite FIND_CNT in WFC6. clarify. rename cnt into cnt_cur. *) +(* specialize (CNT_INJ _ _ _ CNT_CUR WFC0). clarify. *) +(* } *) + +(* - move FREEENV after INJ_SEP. move WFC1 after FREEENV. move WFC4 after FREEENV. *) +(* hexploit wunchanged_on_exists_mem_free_list_2. eapply FREEENV. *) +(* instantiate (2:=ge_c). eapply UCH7. ss. *) +(* intros (m_c' & FREE2). esplits. eapply FREE2. *) +(* eapply wf_c_cont_wunchanged_on_2. eapply WFC1. *) +(* eapply wunchanged_on_free_list_preserves_gen. 2,3: eauto. auto. *) +(* - ii. rewrite CNT_CUR in H. inv H. ss. *) +(* - move WFNB after UCH7. eapply wf_c_nb_wunchanged_on; eauto. *) +(* } *) +(* { exists j2. splits; auto. *) +(* { unfold match_mem. splits; auto. move DELTA after UCH7. move TR2 after UCH7. *) +(* eapply meminj_not_alloc_delta in MM2. 2: eapply DELTA. *) +(* eapply meminj_not_alloc_external_call. eapply MM2. eauto. *) +(* } *) +(* { ii. assert (NINJP: (meminj_public ge_i) b0 = None). *) +(* { move MCNTS after UCH7. specialize (MCNTS _ _ _ H H0 b0 ofs). *) +(* destruct (meminj_public ge_i b0) eqn:CASES; ss. exfalso. *) +(* destruct p. move MM1 after UCH7. move INCR2 after UCH7. *) +(* unfold inject_incr in *. hexploit MM1. apply CASES. hexploit INCR2. apply CASES. *) +(* i. rewrite H1 in H2. clarify. *) +(* } *) +(* specialize (INJ_SEP _ _ _ NINJP H1). des. apply INJ_SEP0. *) +(* hexploit Genv.genv_symb_range. eapply H0. intros RANGE. *) +(* move WFNB before RANGE. *) +(* hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros T1. *) +(* hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros T2. *) +(* eapply wunchanged_on_nextblock in T1, T2. revert_until NINJP. clear. i. *) +(* unfold wf_c_nb in WFNB. unfold Mem.valid_block. eapply Plt_Ple_trans. eauto. *) +(* etransitivity. eapply WFNB. etransitivity; eauto. *) +(* } *) +(* } *) +(* } *) + +(* Unshelve. all: try exact (fun _ _ => True). exact 1%positive. exact le. *) +(* Qed. *) + +(* Lemma ir_to_clight_aux *) +(* (ge_i: Asm.genv) (ge_c: Clight.genv) *) +(* (WFGE: wf_ge ge_i) *) +(* (pretr: bundle_trace) *) +(* pist ist *) +(* (PREIR: istar (ir_step) ge_i pist pretr ist) *) +(* pcst cst *) +(* (PREC: star step1 ge_c pcst (unbundle_trace pretr) cst) *) +(* ttr cnts pars k id *) +(* (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) *) +(* (WFC: wf_c_state ge_i ge_c pretr ttr cnts id cst) *) +(* (MS: match_state ge_i ge_c k ttr cnts pars id ist cst) *) +(* btr ist' *) +(* (TOTAL: ttr = pretr ++ btr) *) +(* (STAR: istar (ir_step) ge_i ist btr ist') *) +(* : *) +(* exists cst', star step1 ge_c cst (unbundle_trace btr) cst'. *) +(* Proof. *) +(* revert pretr PREIR cst PREC k id WFC MS TOTAL. induction STAR; intros. *) +(* { ss. eexists. econs 1. } *) +(* rename H into STEP. subst t. ss. *) +(* hexploit ir_to_clight_step; eauto. intros; des. *) +(* - hexploit IHSTAR. *) +(* { eapply istar_trans. eapply PREIR. econs 2. eapply STEP. econs 1. all: ss. } *) +(* { rewrite unbundle_trace_app. eapply star_trans. eapply PREC. eapply H. ss. rewrite app_nil_r. ss. } *) +(* eauto. eauto. *) +(* { rewrite <- app_assoc. ss. } *) +(* intros (cst' & INDSTAR). *) +(* exists cst'. eapply star_trans. eapply H. eapply INDSTAR. ss. *) +(* - subst s2. inv STAR. *) +(* + ss. rewrite app_nil_r. eauto. *) +(* + inv H0. *) +(* Qed. *) + +(* Theorem ir_to_clight *) +(* (ge_i: Asm.genv) (ge_c: Clight.genv) *) +(* (WFGE: wf_ge ge_i) *) +(* ist cst *) +(* ttr cnts pars k id *) +(* (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) *) +(* (WFC: wf_c_state ge_i ge_c [] ttr cnts id cst) *) +(* (MS: match_state ge_i ge_c k ttr cnts pars id ist cst) *) +(* ist' *) +(* (STAR: istar (ir_step) ge_i ist ttr ist') *) +(* : *) +(* exists cst', star step1 ge_c cst (unbundle_trace ttr) cst'. *) +(* Proof. eapply ir_to_clight_aux. eauto. 4,5,6,7: eauto. all: eauto. econs 1. econs 1. Qed. *) + +(* End PROOF. *) diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v new file mode 100644 index 0000000000..c6a7a13dbd --- /dev/null +++ b/security/BacktranslationProof2.v @@ -0,0 +1,1454 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Require Import Tactics. +Require Import riscV.Asm. +Require Import BtBasics BtInfoAsm BtInfoAsmBound MemoryDelta MemoryWeak. +Require Import Ctypes Clight. +Require Import Backtranslation BacktranslationAux BacktranslationProof. +Require Import RSC. + + +Section GENPROOFS. + + Definition next_id0 {A} (l: list (ident * A)) x: ident := + Pos.succ (fold_left (fun x '(i, _) => if (x + (cnt = (id + x0)%positive) /\ (exists gd_a, (In (id, gd_a) gds) /\ (gd_c = gen_counter (comp_of gd_a)))) + (PTree.elements cnts). + Proof. + subst. rewrite Forall_forall. i. destruct x as (id & (cnt & gd_c)). unfold gen_counter_defs in H. + apply PTree.elements_complete in H. apply PTree_Properties.in_of_list in H. + apply list_in_map_inv in H. des. des_ifs. splits; auto. esplits; eauto. + Qed. + + Lemma gen_counter_defs_lt + m agds + id cnt cd + (GET: (gen_counter_defs m agds) ! id = Some (cnt, cd)) + : + (Pos.lt m cnt). + Proof. + hexploit gen_counter_defs_props; eauto. intros FA. rewrite Forall_forall in FA. + apply PTree.elements_correct in GET. specialize (FA _ GET). ss. des. clarify. lia. + Qed. + + Lemma Forall_numbering0 + A (l: list A) + : + forall x1 x2, (x1 <= x2)%positive -> Forall (fun '(id, _) => (x1 <= id)%positive) (numbering x2 l). + Proof. induction l; i; ss. econs. auto. eapply IHl. lia. Qed. + + Lemma Forall_numbering + A (l: list A) + : + forall x, Forall (fun '(id, _) => (x <= id)%positive) (numbering x l). + Proof. i. eapply Forall_numbering0. lia. Qed. + + Lemma map_snd_numbering + A (l: list A) + : + forall x, l = map snd (numbering x l). + Proof. induction l; i; ss. f_equal. eauto. Qed. + + Lemma in_gds_exists_params + gds id gd_i + (FD: (PTree_Properties.of_list gds) ! id = Some gd_i) + (NR: list_norepet (map fst gds)) + x + : + exists ps, (gen_params x gds) ! id = Some ps /\ + Forall (fun '(id, _) => (x <= id)%positive) ps /\ + (match gd_i with + | Gfun fd => map typ_to_type (sig_args (funsig fd)) = map snd ps + | Gvar _ => ps = [] + end). + Proof. + unfold gen_params. + assert (IN: In id (map fst (map (fun '(id0, gd) => + match gen_params_one x gd with + | Some ps0 => (id0, ps0) + | None => (id0, []) + end) gds))). + { apply PTree_Properties.in_of_list in FD. rewrite map_map. + apply (in_map (fun x0 : PTree.elt * globdef Asm.fundef unit => + fst (let '(id0, gd) := x0 in + match gen_params_one x gd with + | Some ps0 => (id0, ps0) + | None => (id0, []) + end))) in FD. des_ifs. + } + apply PTree_Properties.of_list_dom in IN. des. rename v into ps. + setoid_rewrite IN. exists ps. split; auto. + apply PTree_Properties.in_of_list in IN. apply list_in_map_inv in IN. des. des_ifs; ss. + - unfold gen_params_one in Heq. des_ifs. split. + apply Forall_numbering; eauto. + hexploit PTree_Properties.of_list_norepet. eauto. apply IN0. intros GET. + rewrite FD in GET; clarify. eapply map_snd_numbering. + - unfold gen_params_one in Heq. des_ifs. + hexploit PTree_Properties.of_list_norepet. eauto. apply IN0. intros GET. + rewrite FD in GET; clarify. + - unfold gen_params_one in Heq. des_ifs. + hexploit PTree_Properties.of_list_norepet. eauto. apply IN0. intros GET. + rewrite FD in GET; clarify. + Qed. + + Lemma gen_params_props + (gds: list (ident * globdef Asm.fundef unit)) + pars x0 + (CNTS: pars = gen_params x0 gds) + : + Forall (fun '(id, ps) => + exists gd, (In (id, gd) gds) /\ + ((gen_params_one x0 gd = Some ps) \/ (gen_params_one x0 gd = None /\ ps = [])) + ) + (PTree.elements pars). + Proof. + subst. rewrite Forall_forall. i. destruct x as (id & ps). unfold gen_params in H. + apply PTree.elements_complete in H. apply PTree_Properties.in_of_list in H. + apply list_in_map_inv in H. des. des_ifs; esplits; eauto. + Qed. + + Lemma gen_params_one_le + m p t ps + (IN: In (p, t) ps) + gd + (GEN: gen_params_one m gd = Some ps) + : + (m <= p)%positive. + Proof. + unfold gen_params_one in GEN. des_ifs. + hexploit (Forall_numbering _ (map typ_to_type (sig_args (funsig f))) m). intros FA. + rewrite Forall_forall in FA. specialize (FA _ IN). des_ifs. + Qed. + + Lemma gen_params_le + m agds + id ps + (GET: (gen_params m agds) ! id = Some ps) + p t + (IN: In (p, t) ps) + : + Pos.le m p. + Proof. + hexploit gen_params_props; eauto. intros FA. rewrite Forall_forall in FA. + apply PTree.elements_correct in GET. specialize (FA _ GET). ss. des; clarify. + eapply gen_params_one_le; eauto. + Qed. + + Lemma numbering_norepet + A (l: list A) m + : + list_norepet (map fst (numbering m l)). + Proof. + revert_until l. induction l; i; ss. econs. + econs; eauto. ii. apply list_in_map_inv in H. des. destruct x; ss. + hexploit Forall_numbering. i. rewrite Forall_forall in H1. specialize (H1 _ H0). des_ifs. + lia. + Qed. + + Lemma gen_params_one_wf + m gd ps + (FA: gen_params_one m gd = Some ps) + : + list_norepet (var_names ps). + Proof. + unfold gen_params_one in FA. des_ifs. unfold var_names. eapply numbering_norepet. + Qed. + + Lemma gen_params_wf + m agds + : + wf_params_of (gen_params m agds). + Proof. + ii. hexploit gen_params_props; eauto. intros FA. rewrite Forall_forall in FA. + apply PTree.elements_correct in H. specialize (FA _ H). ss. des; clarify; ss. 2: econs. + eapply gen_params_one_wf; eauto. + Qed. + +End GENPROOFS. + +Definition wf_program_public {F V} (p: AST.program F V) := + forall id, In id (AST.prog_public p) -> In id (map fst (AST.prog_defs p)). + + + +Section PROOFGENV. + + Lemma gen_prog_defs_props_1 + (a_ge: Senv.t) tr (gds: list (ident * globdef Asm.fundef unit)) + (gen_gds1: list (ident * globdef Clight.fundef type)) + cnts params + (GEN: gen_gds1 = (map (fun '(id, gd) => (id, gen_progdef a_ge (get_id_tr tr id) gd (cnts ! id) (params ! id))) gds)) + : + Forall (fun '(id, gd_c) => + exists gd_a, (In (id, gd_a) gds) /\ (gd_c = gen_progdef a_ge (get_id_tr tr id) gd_a (cnts ! id) (params ! id))) + gen_gds1. + Proof. + subst gen_gds1. rewrite Forall_map. apply Forall_forall. i. des_ifs. esplits; eauto. + Qed. + + Lemma gen_prog_defs_inv_1 + (a_ge: Senv.t) tr (gds: list (ident * globdef Asm.fundef unit)) + (gen_gds1: list (ident * globdef Clight.fundef type)) + cnts params + (GEN: gen_gds1 = (map (fun '(id, gd) => (id, gen_progdef a_ge (get_id_tr tr id) gd (cnts ! id) (params ! id))) gds)) + id gd + (IN: In (id, gd) gds) + : + In (id, gen_progdef a_ge (get_id_tr tr id) gd (cnts ! id) (params ! id)) gen_gds1. + Proof. + eapply (in_map (fun '(id0, gd0) => (id0, gen_progdef a_ge (get_id_tr tr id0) gd0 cnts ! id0 params ! id0))) in IN. clarify. + Qed. + + Lemma gen_counter_defs_inv + (gds: list (ident * globdef Asm.fundef unit)) + (NR: list_norepet (map fst gds)) + cnts x0 + (CNTS: cnts = gen_counter_defs x0 gds) + id gd + (IN: In (id, gd) gds) + : + cnts ! id = Some ((id + x0)%positive, gen_counter (comp_of gd)). + Proof. + subst. unfold gen_counter_defs. apply PTree_Properties.of_list_norepet. + { rewrite map_map. + match goal with + | [|- list_norepet (map ?f gds)] => assert (f = fst) + end. + { extensionalities s. des_ifs. } + rewrite H. auto. + } + { eapply (in_map (fun '(id0, gd0) => (id0, ((id0 + x0)%positive, gen_counter (comp_of gd0))))) in IN. auto. } + Qed. + + Lemma gen_counter_defs_inj + (gds: list (ident * globdef Asm.fundef unit)) + (NR: list_norepet (map fst gds)) + cnts x0 + (CNTS: cnts = gen_counter_defs x0 gds) + : + forall (id0 id1 : positive) (cnt : ident) gd0 gd1, + cnts ! id0 = Some (cnt, gd0) -> cnts ! id1 = Some (cnt, gd1) -> (id0 = id1 /\ gd0 = gd1). + Proof. + i. hexploit gen_counter_defs_props. eauto. i. rewrite Forall_forall in H1. + pose proof (PTree.elements_correct _ _ H) as IN1. pose proof (PTree.elements_correct _ _ H0) as IN2. + hexploit (H1 _ IN1). hexploit (H1 _ IN2). clear H1. i. des. clarify. apply Pos.add_reg_r in H2. subst id1. clarify. + rewrite H. split; auto. + Qed. + + Definition get_cnt_ids (cnts0: PTree.t (ident * globdef fundef type)): cnt_ids := + PTree.map (fun id '(cnt, _) => cnt) cnts0. + + Lemma gen_counter_defs_cnt_ids_inj + (gds: list (ident * globdef Asm.fundef unit)) + (NR: list_norepet (map fst gds)) + cnts0 x0 + (CNTS0: cnts0 = gen_counter_defs x0 gds) + (cnts: cnt_ids) + (CNTS: cnts = get_cnt_ids cnts0) + : + forall (id0 id1 : positive) (cnt : ident), + cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1. + Proof. + i. subst. unfold get_cnt_ids in *. rewrite PTree.gmap in H0, H. unfold option_map in *. des_ifs. + hexploit gen_counter_defs_inj. eauto. eauto. apply Heq0. apply Heq. intros (EQ & _). auto. + Qed. + + Lemma in_prog_defs_gen_program + p_a btr gds + (GDS: gds = AST.prog_defs p_a) + id gd_a + (IN: In (id, gd_a) gds) + : + exists gd_c, + (In (id, gd_c) (prog_defs (gen_program btr p_a))) /\ + (let m0 := next_id gds in + let cnts := gen_counter_defs m0 gds in + let cnt_defs := map snd (PTree.elements cnts) in + let m1 := next_id cnt_defs in + let params := gen_params m1 gds in + gd_c = gen_progdef (Genv.globalenv p_a) (get_id_tr btr id) gd_a (cnts ! id) (params ! id)). + Proof. + ss. esplits. 2: eauto. unfold gen_prog_defs. apply in_or_app. left. subst. + eapply (in_map (fun '(id0, gd) => + (id0, gen_progdef (Genv.globalenv p_a) (get_id_tr btr id0) gd + (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a)) ! id0 + (gen_params (next_id (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a))))) + (AST.prog_defs p_a)) ! id0))) in IN. ss. + Qed. + + Lemma genv_find_symbol_add_global_other + F V (ge0: Genv.t F V) + (gd: (ident * globdef F V)) + id + (NEQ: fst gd <> id) + : + Genv.find_symbol (Genv.add_global ge0 gd) id = Genv.find_symbol ge0 id. + Proof. unfold Genv.add_global, Genv.find_symbol. ss. rewrite PTree.gso; auto. Qed. + + Lemma genv_find_symbol_add_globals_other + F V (ge0: Genv.t F V) + (gds: list (ident * globdef F V)) + id + (NEQ: Forall (fun '(id0, _) => id0 <> id) gds) + : + Genv.find_symbol (Genv.add_globals ge0 gds) id = Genv.find_symbol ge0 id. + Proof. + move NEQ after ge0. revert_until NEQ. induction NEQ; i; ss. rewrite IHNEQ. + des_ifs. eapply genv_find_symbol_add_global_other. ss. + Qed. + + Lemma genv_find_def_add_globals + F V + (gds: list (ident * globdef F V)) + ge0 b + (BLK: (b < Genv.genv_next ge0)%positive) + : + Genv.find_def (Genv.add_globals ge0 gds) b = Genv.find_def ge0 b. + Proof. + revert_until gds. induction gds; ii; ss. + destruct a as (idx & gdx). rewrite IHgds. + 2:{ ss. lia. } + unfold Genv.find_def, Genv.add_global. ss. rewrite PTree.gso; auto. + { ii. lia. } + Qed. + + Lemma genv_find_def_add_globals_2 + F V + (gds: list (ident * globdef F V)) + ge0 id gda + : + Genv.find_def (Genv.add_globals (Genv.add_global ge0 (id, gda)) gds) (Genv.genv_next ge0) = Some gda. + Proof. + rewrite genv_find_def_add_globals. + { unfold Genv.find_def, Genv.add_global. ss. rewrite PTree.gss. auto. } + { ss. lia. } + Qed. + + Lemma genv_find_symbol_add_globals_some + F V + (gds: list (ident * globdef F V)) + id + (IN: In id (map (fun x => fst x) gds)) + (ge0: Genv.t F V) b + (FIND: Genv.find_symbol (Genv.add_globals ge0 gds) id = Some b) + : + exists gd id0, (Genv.find_def (Genv.add_globals ge0 gds) b = Some gd) /\ (In (id0, gd) gds). + Proof. + revert_until gds. induction gds; i; ss. + destruct a as (ida & gda). ss. des; clarify. + - destruct (in_dec Pos.eq_dec id (map fst gds)). + + specialize (IHgds _ i _ _ FIND). des. esplits; eauto. + + clear IHgds. rewrite genv_find_symbol_add_globals_other in FIND. + * unfold Genv.find_symbol, Genv.add_global in FIND. ss. rewrite PTree.gss in FIND. clarify. + exists gda, id. split; auto. apply genv_find_def_add_globals_2. + * apply Forall_forall. i. destruct x as (idx & gdx). ii. subst. apply n. apply (in_map fst) in H. ss. + - specialize (IHgds _ IN _ _ FIND). des. esplits; eauto. + Qed. + + Lemma genv_find_symbol_add_globals_map + F0 V0 F1 V1 + id b l + (ge0: Genv.t F0 V0) (ge1: Genv.t F1 V1) + (NB: (Genv.genv_next ge0) = (Genv.genv_next ge1)) + (FIND: Genv.find_symbol (Genv.add_globals ge0 l) id = Some b) + gd + (IN: In (id, gd) l) + f f' + (FUN: f' = fun '(id, x) => (id, f (id, x))) + : + Genv.find_symbol (Genv.add_globals ge1 (map f' l)) id = Some b. + Proof. + subst f'. revert_until l. induction l; i; ss. + destruct a as (id0 & gd0); ss. des. + { clarify. destruct (in_dec Pos.eq_dec id (map fst l)). + { eapply list_in_map_inv in i. des. destruct x as (id' & gd'). ss. subst id'. eapply IHl; eauto. + unfold Genv.genv_next, Genv.add_global. rewrite NB. auto. + } + { clear IHl. rewrite genv_find_symbol_add_globals_other. + - rewrite genv_find_symbol_add_globals_other in FIND. + + unfold Genv.find_symbol, Genv.add_global in *. ss. rewrite PTree.gss in *. rewrite <- NB. auto. + + apply Forall_forall. i. des_ifs. ii. subst i. apply n. apply (in_map fst) in H. ss. + - rewrite Forall_map. apply Forall_forall. i. des_ifs. ii. subst i. apply n. apply (in_map fst) in H. ss. + } + } + { eapply IHl; eauto. unfold Genv.genv_next, Genv.add_global. rewrite NB. auto. } + Qed. + + Lemma gen_program_symbs_find + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + : + symbs_find ge_a ge_c. + Proof. + subst p_c ge_a ge_c. ii. ss. hexploit Genv.find_symbol_inversion. eapply H. intros IN_A. + unfold prog_defs_names in IN_A. apply list_in_map_inv in IN_A. des. destruct x as (id0 & gd_a). ss. subst id0. + unfold Genv.globalenv. ss. unfold gen_prog_defs. rewrite Genv.add_globals_app. rewrite genv_find_symbol_add_globals_other. + { eapply genv_find_symbol_add_globals_map; eauto. ss. extensionalities. des_ifs. f_equal. + instantiate (1:= fun '(i, g) => + gen_progdef (Genv.globalenv p_a) (get_id_tr btr i) g (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a)) ! i + (gen_params (next_id (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a))))) + (AST.prog_defs p_a)) ! i). ss. + } + { hexploit gen_counter_defs_props. eauto. intros FA. + eapply Forall_map. eapply Forall_impl. 2: eapply FA. clear FA. ss. i. des_ifs. des; ss; clarify. + assert (BIG: (id < next_id (AST.prog_defs p_a))%positive). + { eapply next_id_lt; eauto. } + lia. + } + Qed. + + Lemma gen_program_symbs_public + p_a btr + p_c ge_a ge_c + (WFPP: wf_program_public p_a) + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + : + symbs_public ge_a ge_c. + Proof. + subst p_c ge_a ge_c. ss. unfold symbs_public. i. ss. unfold Genv.public_symbol. + rewrite ! Genv.globalenv_public. destruct (Genv.find_symbol (Genv.globalenv p_a) id) eqn:FIND_A. + { eapply gen_program_symbs_find in FIND_A; auto. ss. rewrite FIND_A. ss. } + des_ifs. destruct (in_dec ident_eq id (AST.prog_public (gen_program btr p_a))); ss. exfalso. + apply WFPP in i. apply list_in_map_inv in i. des. destruct x; clarify. + apply Genv.find_symbol_exists in i0. des. ss. clarify. + Qed. + + Lemma pos_neq_dec (id: positive): forall id0, {id0 <> id} + {~ id0 <> id}. + Proof. i. destruct (Pos.eq_dec id0 id); clarify; auto. Qed. + + Lemma genv_find_symbol_gen_cases + (p_a: Asm.program) btr + id b + (FIND: Genv.find_symbol (Genv.globalenv (gen_program btr p_a)) id = Some b) + : + (Genv.find_symbol (Genv.globalenv p_a) id = Some b) \/ + (Genv.find_symbol (Genv.globalenv p_a) id = None /\ + exists cp, Genv.find_def (Genv.globalenv (gen_program btr p_a)) b = Some (gen_counter cp)). + Proof. + destruct (Genv.find_symbol (Genv.globalenv p_a) id) eqn:FIND_A. + { left. eapply gen_program_symbs_find in FIND_A; eauto. ss. setoid_rewrite FIND in FIND_A. clarify. } + { right. split; auto. + unfold Genv.globalenv in *. ss. unfold gen_prog_defs in *. rewrite Genv.add_globals_app in FIND. + destruct (Forall_Exists_dec _ (pos_neq_dec id) (map fst (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a)))))). + - exfalso. + rewrite genv_find_symbol_add_globals_other in FIND. + 2:{ rewrite Forall_map in f. eapply Forall_impl. 2: apply f. ss. i. des_ifs. } + set ({| + prog_defs := (map + (fun '(id, gd) => + (id, + gen_progdef (Genv.globalenv p_a) (get_id_tr btr id) gd + (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a)) ! id + (gen_params + (next_id (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a))))) + (AST.prog_defs p_a)) ! id)) (AST.prog_defs p_a)); + prog_public := AST.prog_public p_a; + prog_main := AST.prog_main p_a; + prog_pol := AST.prog_pol p_a; + prog_types := []; + prog_comp_env := PTree.empty composite; + prog_comp_env_eq := (fun (_ : bundle_trace) (_ : Asm.program) => Backtranslation.gen_program_obligation_1) btr p_a + |}) as p_t. + hexploit Genv.find_symbol_find_def_inversion. + { instantiate (3:=p_t). unfold Genv.globalenv. subst p_t. ss. eapply FIND. } + intros (g & FIND_C_DEF). + assert (PDM: (prog_defmap p_t) ! id = Some g). + { rewrite Genv.find_def_symbol. esplits; eauto. } + unfold prog_defmap in PDM. apply PTree_Properties.in_of_list in PDM. subst p_t; ss. + apply list_in_map_inv in PDM. des. destruct x as (idx & gdx). clarify. + apply Genv.find_symbol_exists in PDM0. des. unfold Genv.globalenv in PDM0. rewrite FIND_A in PDM0. clarify. + - rewrite map_map in e. rewrite Exists_exists in e. des. apply Classical_Prop.NNPP in e0. subst x. + hexploit genv_find_symbol_add_globals_some. + 2:{ eapply FIND. } + { rewrite map_map. auto. } + intros. des. hexploit gen_counter_defs_props. + { instantiate (1:=(AST.prog_defs p_a)). instantiate (1:=(next_id (AST.prog_defs p_a))). auto. } + intros FA. rewrite Forall_forall in FA. apply list_in_map_inv in H0. des. specialize (FA x H1). des_ifs. des; clarify. + ss. clarify. rewrite Genv.add_globals_app. eauto. + } + Qed. + + Lemma in_gds_exists_cnt + gds id gd_i + (FD: (PTree_Properties.of_list gds) ! id = Some gd_i) + x + : + exists cnt, (get_cnt_ids (gen_counter_defs x gds)) ! id = Some cnt /\ (x < cnt)%positive. + Proof. + unfold get_cnt_ids, gen_counter_defs. + assert (IN: In id (map fst (map (fun '(id0, gd) => (id0, ((id0 + x)%positive, gen_counter (comp_of gd)))) gds))). + { apply PTree_Properties.in_of_list in FD. rewrite map_map. + apply (in_map (fun x0 : positive * globdef Asm.fundef unit => fst (let '(id0, gd) := x0 in (id0, ((id0 + x)%positive, gen_counter (comp_of gd)))))) in FD. ss. + } + apply PTree_Properties.of_list_dom in IN. des. destruct v. + rewrite PTree.gmap. setoid_rewrite IN. ss. esplits; eauto. + apply PTree_Properties.in_of_list in IN. apply list_in_map_inv in IN. des. des_ifs. lia. + Qed. + + Lemma in_asm_in_gen + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + id gd_a + (FD: (prog_defmap p_a) ! id = Some gd_a) + gds + (GDS: gds = AST.prog_defs p_a) + x0 cnt + (X0: x0 = next_id gds) + (IN_CNT : (get_cnt_ids (gen_counter_defs x0 gds)) ! id = Some cnt) + x1 ps + (X1: x1 = next_id (map snd (PTree.elements (gen_counter_defs x0 gds)))) + (IN_PS : (gen_params x1 gds) ! id = Some ps) + (NR_GEN: list_norepet (prog_defs_names p_c)) + : + (prog_defmap p_c) ! id = + Some (gen_globdef ge_a cnt ps (get_id_tr btr id) gd_a). + Proof. + subst. apply in_prog_defmap in FD. eapply in_prog_defs_gen_program in FD; eauto. + des. assert (FD': In (id, gd_c) (AST.prog_defs (gen_program btr p_a))). + { eapply FD. } + hexploit prog_defmap_norepet. 2: eapply FD'. auto. + intros EQ. rewrite EQ. clear EQ FD'. ss. subst gd_c. + unfold gen_progdef. + rewrite IN_PS. unfold get_cnt_ids in IN_CNT. rewrite PTree.gmap in IN_CNT. + destruct ((gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a)) ! id) eqn:CNT; ss. + destruct p. clarify. + Qed. + + Lemma gen_counter_defs_list_norepet + x gds + (NR: list_norepet (map fst gds)) + : + list_norepet (map (fun x => fst (snd x)) (PTree.elements (gen_counter_defs x gds))). + Proof. + eapply list_map_norepet. + { hexploit PTree.elements_keys_norepet. intros A. apply list_map_norepet_rev in A. eauto. } + i. destruct x0 as (idx & (cntx & gdx)). destruct y as (idy & (cnty & gdy)). + apply PTree.elements_complete in H, H0. ss. + destruct (Pos.eqb_spec idx idy). + { subst. rewrite H0 in H. clarify. } + { destruct (Pos.eqb_spec cntx cnty); auto. + subst. hexploit gen_counter_defs_inj. eauto. 2: apply H. 2: apply H0. eauto. + i. des; clarify. + } + Qed. + + Lemma gen_counter_defs_list_disjoint + gds x + (BOUND: ((next_id gds) <= x)%positive) + : + list_disjoint (map fst gds) + (map (fun x => fst (snd x)) (PTree.elements (gen_counter_defs x gds))). + Proof. + ii. subst. apply list_in_map_inv in H, H0. des. destruct x1, x0. ss. clarify. + destruct p0 as (cnt & g_cnt). ss. rename p into id. + apply PTree.elements_complete in H1. apply gen_counter_defs_lt in H1. + hexploit next_id_lt. apply H2. i. lia. + Qed. + + Lemma gen_program_list_norepet + p_a btr + (NR: list_norepet (prog_defs_names p_a)) + : + list_norepet (prog_defs_names (gen_program btr p_a)). + Proof. + unfold prog_defs_names, gen_program in *. ss. unfold gen_prog_defs. + rewrite map_app. rewrite ! map_map. + match goal with + | [|- list_norepet (?l ++ _)] => assert (EQ: l = map fst (AST.prog_defs p_a)) + end. + { f_equal. extensionalities x. destruct x; ss. } + rewrite EQ. clear EQ. rewrite list_norepet_app. splits; auto. + apply gen_counter_defs_list_norepet; auto. + apply gen_counter_defs_list_disjoint; auto. lia. + Qed. + + Lemma gen_program_match_find_def + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + gds + (GDS: gds = AST.prog_defs p_a) + x0 cnts + (X0: x0 = next_id gds) + (CNTS: cnts = get_cnt_ids (gen_counter_defs x0 gds)) + x1 pars + (X1: x1 = next_id (map snd (PTree.elements (gen_counter_defs x0 gds)))) + (PARS: pars = gen_params x1 gds) + (NR: list_norepet (prog_defs_names p_a)) + : + match_find_def ge_a ge_c cnts pars btr. + Proof. + subst. ii. assert (FD: (prog_defmap p_a) ! id = Some gd_i). + { rewrite Genv.find_def_symbol. apply Senv.invert_find_symbol in H0. ss. esplits; eauto. } + unfold prog_defmap in FD. set (AST.prog_defs p_a) as gds in *. + hexploit in_gds_exists_cnt. eapply FD. intros (cnt & IN_CNT). + hexploit in_gds_exists_params. eapply FD. apply NR. intros (ps & IN_PS). + des. rewrite IN_CNT, IN_PS. + hexploit in_asm_in_gen. 4: apply FD. 6: apply IN_CNT. 7: apply IN_PS. all: eauto. + { apply gen_program_list_norepet. auto. } + instantiate (1:=btr). intros FD_C. rewrite Genv.find_def_symbol in FD_C. des. + apply Senv.invert_find_symbol in H0. ss. eapply gen_program_symbs_find in H0; eauto. + ss. setoid_rewrite FD_C in H0. clarify. + Qed. + + Lemma gen_program_symbs_volatile + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + (NR: list_norepet (prog_defs_names p_a)) + : + symbs_volatile ge_a ge_c. + Proof. + unfold symbs_volatile. i. unfold Senv.block_is_volatile. ss. + unfold Genv.block_is_volatile. destruct (Genv.find_var_info ge_a b) eqn:VAR_A. + { rewrite Genv.find_var_info_iff in VAR_A. hexploit wf_ge_block_to_id. 2: eapply VAR_A. + { subst ge_a. apply wf_program_wf_ge. ss. } + intros (id & INV_A). + hexploit gen_program_match_find_def; eauto. intros MFD. + unfold match_find_def in MFD. specialize (MFD _ _ _ VAR_A INV_A). des_ifs. + 2:{ ss. rewrite <- Genv.find_var_info_iff in MFD. rewrite MFD in Heq. ss. } + ss. rewrite Genv.find_var_info_iff in Heq. rewrite MFD in Heq. clarify. + } + { des_ifs. rewrite Genv.find_var_info_iff in Heq. + hexploit @genv_def_to_ident. 3: eapply Heq. eapply gen_program_list_norepet; eauto. ss. + intros (id & INV). apply Genv.invert_find_symbol in INV. + hexploit genv_find_symbol_gen_cases. apply INV. intros CASES. des. + { exfalso. unfold Genv.find_var_info in VAR_A. des_ifs. + 2:{ apply Genv.find_symbol_find_def_inversion in CASES. des. clarify. } + apply Genv.find_invert_symbol in CASES. hexploit gen_program_match_find_def; eauto. + intros MFD. unfold match_find_def in MFD. specialize (MFD _ _ _ Heq0 CASES). + des_ifs. rewrite Heq in MFD. ss. + } + setoid_rewrite Heq in CASES0. clarify. + } + Qed. + + Lemma gen_program_eq_policy + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + : + eq_policy ge_a ge_c. + Proof. + subst. unfold eq_policy. ss. unfold Genv.globalenv. ss. + rewrite ! Genv.genv_pol_add_globals. ss. + Qed. + + Lemma gen_program_match_symbs + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + (WFPP: wf_program_public p_a) + (NR: list_norepet (prog_defs_names p_a)) + : + match_symbs ge_a ge_c. + Proof. + unfold match_symbs. splits. + eapply gen_program_symbs_public; eauto. + eapply gen_program_symbs_find; eauto. + eapply gen_program_symbs_volatile; eauto. + Qed. + + Lemma gen_program_match_genv + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + (WFPP: wf_program_public p_a) + (NR: list_norepet (prog_defs_names p_a)) + : + match_genv ge_a ge_c. + Proof. + unfold match_genv. splits. eapply gen_program_match_symbs; eauto. + eapply gen_program_eq_policy; eauto. + Qed. + +End PROOFGENV. + + +Section PROOFINIT. + + Lemma gen_counter_defs_alloc + x0 gds cnts + (CNTS: cnts = gen_counter_defs x0 gds) + F V (ge: Genv.t F V) + : + Forall (fun (idg: ident * (globdef fundef type)) => + let (_, y) := idg in + match y with + | Gfun _ => False + | Gvar v => + Genv.init_data_list_aligned 0 (gvar_init v) /\ + (forall (i : ident) (o : ptrofs), In (Init_addrof i o) (gvar_init v) -> exists b : block, Genv.find_symbol ge i = Some b) + end) (map snd (PTree.elements cnts)). + Proof. + apply Forall_forall. intros (idx & gdx) IN. hexploit (gen_counter_defs_props _ _ _ CNTS). + intros FA. rewrite Forall_forall in FA. apply list_in_map_inv in IN. des. + destruct x as (id & (cnt & gd)). ss. clarify. specialize (FA _ IN0). ss. des. + subst. ss. splits; auto. apply Z.divide_0_r. i. des; ss. + Qed. + + Lemma genv_store_init_data_eq + (ge_a: Asm.genv) (ge_c: Clight.genv) + (SF: symbs_find ge_a ge_c) + a m b z cp m' + (SOME: Genv.store_init_data ge_a m b z a cp = Some m') + : + Genv.store_init_data ge_c m b z a cp = Some m'. + Proof. + destruct a; ss. destruct (Genv.find_symbol ge_a i) eqn:FIND; ss. + apply SF in FIND. setoid_rewrite FIND. ss. + Qed. + + Lemma genv_store_init_data_list_eq + (ge_a: Asm.genv) (ge_c: Clight.genv) + (SF: symbs_find ge_a ge_c) + l m b z cp m' + (SOME: Genv.store_init_data_list ge_a m b z l cp = Some m') + : + Genv.store_init_data_list ge_c m b z l cp = Some m'. + Proof. + revert_until l. induction l; i; ss. + destruct (Genv.store_init_data ge_a m b z a cp) eqn:MEM; ss. + eapply genv_store_init_data_eq in MEM; eauto. rewrite MEM. eauto. + Qed. + + Lemma gen_progdef_exists_alloc_global + (ge_a: Asm.genv) (ge_c: Clight.genv) + (SF: symbs_find ge_a ge_c) + m0 id gd m1 + (AG: Genv.alloc_global ge_a m0 (id, gd) = Some m1) + btr cnt ps + : + Genv.alloc_global ge_c m0 (id, gen_progdef ge_a btr gd (Some cnt) (Some ps)) = Some m1. + Proof. + ss. destruct cnt as (cnt & cnt_def). destruct gd; ss. + { replace (comp_of (gen_fundef ge_a cnt ps btr f)) with (comp_of f). + 2:{ unfold gen_fundef. des_ifs. } + ss. + } + { replace (Genv.perm_globvar (gen_globvar v)) with (Genv.perm_globvar v). + 2:{ ss. } + destruct (Mem.alloc m0 (gvar_comp v) 0 (init_data_list_size (gvar_init v))) as (ma & b). + destruct (store_zeros ma b 0 (init_data_list_size (gvar_init v)) (gvar_comp v)); ss. + destruct (Genv.store_init_data_list ge_a m b 0 (gvar_init v) (gvar_comp v)) eqn:MEM; ss. + hexploit genv_store_init_data_list_eq; eauto. intros EQ. rewrite EQ. ss. + } + Qed. + + Lemma gen_program_exists_init_mem_1_aux + (ge_a: Asm.genv) (ge_c: Clight.genv) + (SF: symbs_find ge_a ge_c) + (gds: list (ident * globdef Asm.fundef unit)) + m0 m_a + (MEMA : Genv.alloc_globals ge_a m0 gds = Some m_a) + btr cnts pars + (CNTS: forall id, In id (map fst gds) -> exists cnt, cnts ! id = Some cnt) + (PARS: forall id, In id (map fst gds) -> exists ps, pars ! id = Some ps) + : + Genv.alloc_globals ge_c m0 + (map (fun '(id, gd) => (id, gen_progdef ge_a (get_id_tr btr id) gd cnts ! id pars ! id)) gds) = Some m_a. + Proof. + revert_until gds. induction gds; i; ss. eauto. + destruct (Genv.alloc_global ge_a m0 a) eqn:ALLOC; ss. + destruct a as (id & gd). + hexploit CNTS. left; ss. intros (cnt & GET_CNT). + hexploit PARS. left; ss. intros (ps & GET_PS). + rewrite GET_CNT, GET_PS. + hexploit gen_progdef_exists_alloc_global. 2: eapply ALLOC. eauto. + intros ALLOC2. rewrite ALLOC2. + eapply IHgds; eauto. + Qed. + + Lemma gen_program_exists_init_mem_1 + p btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p) + (GE_A: ge_a = Genv.globalenv p) + (GE_C: ge_c = globalenv p_c) + (NR: list_norepet (map fst (AST.prog_defs p))) + m0 m_a + (MEMA : Genv.alloc_globals ge_a m0 (AST.prog_defs p) = Some m_a) + : + Genv.alloc_globals ge_c m0 + (map + (fun '(id, gd) => + (id, + gen_progdef ge_a (get_id_tr btr id) gd + (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)) ! id + (gen_params + (next_id + (map snd + (PTree.elements + (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p))))) + (AST.prog_defs p)) ! id)) (AST.prog_defs p)) = Some m_a. + Proof. + eapply gen_program_exists_init_mem_1_aux; auto. + { subst. eapply gen_program_symbs_find; auto. } + eauto. + { i. apply PTree_Properties.of_list_dom in H. des. + eapply in_gds_exists_cnt in H. des. unfold get_cnt_ids in H. rewrite PTree.gmap in H. + unfold option_map in H. des_ifs. eauto. + } + { i. apply PTree_Properties.of_list_dom in H. des. + eapply in_gds_exists_params in H; auto. des. eauto. + } + Qed. + + Lemma genv_alloc_globals_exists + ge + gds + (FA: Forall (fun (idg: ident * (globdef fundef type)) => + let (_, y) := idg in + match y with + | Gfun _ => True + | Gvar v => + Genv.init_data_list_aligned 0 (gvar_init v) /\ + (forall (i : ident) (o : ptrofs), In (Init_addrof i o) (gvar_init v) -> exists b : block, Genv.find_symbol ge i = Some b) + end) gds) + m + : + exists m', Genv.alloc_globals ge m gds = Some m'. + Proof. + revert_until FA. induction FA; i; ss. eauto. + hexploit Genv.alloc_global_exists. eapply H. intros (m' & ALLOC). + rewrite ALLOC. eauto. + Qed. + + Lemma gen_program_exists_init_mem + btr (p: Asm.program) + m_a + (MEMA: Genv.init_mem p = Some m_a) + (NR: list_norepet (map fst (AST.prog_defs p))) + : + exists m_c, Genv.init_mem (gen_program btr p) = Some m_c. + Proof. + unfold Genv.init_mem in *. ss. unfold gen_prog_defs. + hexploit gen_program_exists_init_mem_1; auto. eauto. apply MEMA. + intros ALLOC1. erewrite <- Genv.alloc_globals_app. + 2:{ apply ALLOC1. } + eapply genv_alloc_globals_exists. eapply Forall_impl. 2: eapply gen_counter_defs_alloc; eauto. + i. destruct a as (ida & gda). des_ifs. des. splits; eauto. + Qed. + + Lemma gen_program_split_init_mem + btr (p: Asm.program) + m_a + (MEMA: Genv.init_mem p = Some m_a) + (NR: list_norepet (map fst (AST.prog_defs p))) + m_c + (MEMC: Genv.init_mem (gen_program btr p) = Some m_c) + : + Genv.alloc_globals (Genv.globalenv (gen_program btr p)) m_a (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)))) = Some m_c. + Proof. + unfold Genv.init_mem in *. ss. unfold gen_prog_defs in *. + hexploit gen_program_exists_init_mem_1; auto. eauto. apply MEMA. + intros ALLOC1. erewrite Genv.alloc_globals_app. apply MEMC. apply ALLOC1. + Qed. + + Lemma gen_program_prog_main_eq + p btr + : + prog_main (gen_program btr p) = AST.prog_main p. + Proof. ss. Qed. + + Lemma exists_initial_state + p ist + (INIT: ir_initial_state p ist) + (WFMAINSIG: wf_main_sig p) + (NR: list_norepet (map fst (AST.prog_defs p))) + btr + : + exists f m_c, initial_state (gen_program btr p) (Callstate (Internal f) [] Kstop m_c) + /\ + ((fn_params f = []) /\ (fn_vars f = []) /\ (fn_temps f = [])). + Proof. + inv INIT. des. hexploit gen_program_exists_init_mem; eauto. intros (m_c & INIT_MC). + hexploit gen_program_match_find_def; eauto. intros MFD. unfold match_find_def in MFD. + ss. hexploit Genv.find_invert_symbol. eapply H. intros INV_A. + specialize (WFMAINSIG _ _ H H0). + rewrite Genv.find_funct_ptr_iff in H0. specialize (MFD _ _ _ H0 INV_A). + des_ifs. ss. rewrite <- Genv.find_funct_ptr_iff in MFD. + assert (l = []). + { hexploit in_gds_exists_params. + { eapply PTree_Properties.of_list_norepet. eauto. apply in_prog_defmap. + rewrite Genv.find_def_symbol. exists cur. splits; eauto. + } + auto. + intros. des. rewrite Heq0 in H2. clarify. ss. rewrite WFMAINSIG in *. ss. + symmetry in H4. apply map_eq_nil in H4. subst. ss. + } + subst. do 2 eexists. split. + - econs; eauto. + { rewrite gen_program_prog_main_eq. eapply gen_program_symbs_find in H; ss; eauto. apply H. } + { ss. unfold gen_function, type_of_function. ss. rewrite WFMAINSIG in *. ss. } + - ss. + Qed. + + Lemma mem_unchanged_on_inject + j m m1 + (INJ: Mem.inject j m m1) + P m2 + (UCH: Mem.unchanged_on P m1 m2) + : + (forall b1 b2 ofs delta, j b1 = Some (b2, delta) -> P b2 (ofs + delta)) -> + Mem.inject j m m2. + Proof. + i. inv INJ. inv UCH. econs; eauto. + - inv mi_inj. econs; eauto. + + i. rewrite <- unchanged_on_perm. all: eauto. + + i. rewrite <- unchanged_on_own. all: eauto. + + i. rewrite unchanged_on_contents. all: eauto. + - i. eapply mi_mappedblocks in H0. clear - H0 unchanged_on_nextblock. + unfold Mem.valid_block in *. eapply Plt_Ple_trans; eauto. + - i. eapply mi_perm_inv; eauto. rewrite unchanged_on_perm; eauto. + Qed. + + Lemma genv_alloc_global_flat_inj + F V (CF: has_comp F) + (ge: Genv.t F V) + m + (INJ: Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m) + ida gda m_c + (ALLOC1 : Genv.alloc_global ge m (ida, gda) = Some m_c) + : + Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m_c. + Proof. + eapply mem_unchanged_on_inject. eauto. eapply Genv.alloc_global_unchanged; eauto. + instantiate (1:= fun b _ => Plt b (Mem.nextblock m)). i. + unfold Mem.flat_inj in H. des_ifs. + Qed. + + Lemma genv_alloc_globals_flat_inj + F V (CF: has_comp F) + (ge: Genv.t F V) (gds: list (ident * globdef F V)) + m + (INJ: Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m) + m_c + (ALLOC: Genv.alloc_globals ge m gds = Some m_c) + : + Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m_c. + Proof. + eapply mem_unchanged_on_inject. eauto. eapply Genv.alloc_globals_unchanged; eauto. + instantiate (1:= fun b _ => Plt b (Mem.nextblock m)). i. + unfold Mem.flat_inj in H. des_ifs. + Qed. + + Lemma genv_init_mem_inj + p_a btr p_c + (NR: list_norepet (map fst (AST.prog_defs p_a))) + (P_C: p_c = gen_program btr p_a) + m_a + (MEM_A: Genv.init_mem p_a = Some m_a) + m_c + (MEM_C: Genv.init_mem p_c = Some m_c) + : + let k := (Mem.flat_inj (Mem.nextblock m_a)) in + Mem.inject k m_a m_c. + Proof. + subst. hexploit gen_program_split_init_mem; eauto. intros ALLOC. + ss. hexploit Genv.initmem_inject. eapply MEM_A. intros INJ1. + eapply genv_alloc_globals_flat_inj; eauto. + Qed. + + Lemma genv_find_symbol_add_globals_map_inv + F0 V0 F1 V1 + id b l + (ge0: Genv.t F0 V0) (ge1: Genv.t F1 V1) + (NB: (Genv.genv_next ge0) = (Genv.genv_next ge1)) + f f' + (FUN: f' = fun '(id, x) => (id, f (id, x))) + (FIND: Genv.find_symbol (Genv.add_globals ge1 (map f' l)) id = Some b) + gd + (IN: In (id, gd) (map f' l)) + : + (Genv.find_symbol (Genv.add_globals ge0 l) id = Some b). + Proof. + subst f'. revert_until l. induction l; i; ss. + destruct a as (id0 & gd0); ss. des. + { clarify. destruct (in_dec Pos.eq_dec id (map fst l)). + { eapply list_in_map_inv in i. des. destruct x as (id' & gd'). ss. subst id'. eapply IHl; eauto. + - unfold Genv.genv_next, Genv.add_global. rewrite NB. auto. + - eapply (in_map (fun '(id0, x) => (id0, f (id0, x)))) in i0. eapply i0. + } + { clear IHl. rewrite genv_find_symbol_add_globals_other. + - rewrite genv_find_symbol_add_globals_other in FIND. + + unfold Genv.find_symbol, Genv.add_global in *. ss. rewrite PTree.gss in *. rewrite NB. auto. + + apply Forall_forall. i. des_ifs. ii. subst i. apply n. + apply (in_map fst) in H. ss. rewrite map_map in H. + assert ((fun x : ident * globdef F0 V0 => fst (let '(id, x0) := x in (id, f (id, x0)))) = fst). + { extensionalities. des_ifs. } + rewrite H0 in H. auto. + - apply Forall_forall. i. des_ifs. ii. subst i. apply n. apply (in_map fst) in H. ss. + } + } + { eapply IHl; eauto. unfold Genv.genv_next, Genv.add_global. rewrite NB. auto. } + Qed. + + Lemma genv_find_symbol_add_globals_gt_block + F V gds (ge: Genv.t F V) id b + (FIND: Genv.find_symbol (Genv.add_globals ge gds) id = Some b) + (IN: In id (map fst gds)) + : + (Genv.genv_next ge <= b)%positive. + Proof. + revert_until gds. induction gds; i; ss. destruct a as (ida & gda); ss; des; clarify. + - destruct (in_dec Pos.eq_dec id (map fst gds)). + + specialize (IHgds _ id _ FIND i). ss. lia. + + clear IHgds. rewrite genv_find_symbol_add_globals_other in FIND. + * unfold Genv.find_symbol, Genv.add_global in FIND. ss. rewrite PTree.gss in FIND. clarify. lia. + * apply Forall_forall. i. destruct x as (idx & gdx). ii. subst. apply n. apply (in_map fst) in H. ss. + - specialize (IHgds _ id _ FIND IN). ss. lia. + Qed. + + Lemma genv_advance_next_eq_len + F1 V1 F2 V2 + (gds1: list (ident * globdef F1 V1)) + (gds2: list (ident * globdef F2 V2)) + (LEN: length gds1 = length gds2) + x + : + Genv.advance_next gds1 x = Genv.advance_next gds2 x. + Proof. + revert_until gds1. induction gds1; i; ss. + { destruct gds2; ss. } + destruct gds2; ss. apply IHgds1; eauto. + Qed. + + Lemma genv_find_symbol_gen_program_cases + p btr + (WFP: wf_program p) + id b + (FIND: Genv.find_symbol (Genv.globalenv (gen_program btr p)) id = Some b) + : + ((forall i, (In i (map fst (AST.prog_defs p))) -> (i < id)%positive) /\ + (Genv.genv_next (Genv.globalenv p) <= b)%positive) \/ + (In id (map fst (AST.prog_defs p)) /\ (b < Genv.genv_next (Genv.globalenv p))%positive). + Proof. + unfold gen_program, Genv.globalenv in *. ss. + set (Genv.add_globals (Genv.empty_genv Asm.fundef unit (AST.prog_public p) (AST.prog_pol p)) (AST.prog_defs p)) as ge_a in *. + unfold gen_prog_defs in FIND. rewrite Genv.add_globals_app in FIND. + set (AST.prog_defs p) as gds in *. + destruct (Forall_Exists_dec _ (pos_neq_dec id) (map fst (map snd (PTree.elements (gen_counter_defs (next_id gds) gds))))). + - right. rewrite genv_find_symbol_add_globals_other in FIND. + 2:{ rewrite Forall_map in f. eapply Forall_impl; eauto. ss. i. des_ifs. } + set ({| + prog_defs := (map + (fun '(id, gd) => + (id, + gen_progdef ge_a (get_id_tr btr id) gd + (gen_counter_defs (next_id gds) gds) ! id + (gen_params + (next_id (map snd (PTree.elements (gen_counter_defs (next_id gds) gds)))) + gds) ! id)) gds); + prog_public := AST.prog_public p; + prog_main := AST.prog_main p; + prog_pol := AST.prog_pol p; + prog_types := []; + prog_comp_env := PTree.empty composite; + prog_comp_env_eq := (fun (_ : bundle_trace) (_ : Asm.program) => Backtranslation.gen_program_obligation_1) btr p + |}) as p_t. + (* hexploit Genv.find_symbol_find_def_inversion. *) + (* { instantiate (3:=p_t). unfold Genv.globalenv. subst p_t. ss. eapply FIND. } *) + hexploit Genv.find_symbol_inversion. + { instantiate (3:=p_t). unfold Genv.globalenv. subst p_t. ss. eapply FIND. } + intros IN. subst p_t. unfold prog_defs_names in IN. ss. apply list_in_map_inv in IN. + des. destruct x. ss; clarify. rename i into id, g into gd. + hexploit genv_find_symbol_add_globals_map_inv. 3: eapply FIND. + { instantiate (1:=(Genv.empty_genv Asm.fundef unit (AST.prog_public p) (AST.prog_pol p))). + ss. + } + { instantiate (1:= fun '(id0, gd) => + gen_progdef ge_a (get_id_tr btr id0) gd (gen_counter_defs (next_id gds) gds) ! id0 + (gen_params (next_id (map snd (PTree.elements (gen_counter_defs (next_id gds) gds)))) gds) + ! id0). ss. + } + { eauto. } + intros FIND2. split. + { apply (in_map fst) in IN0; ss. rewrite map_map in IN0. ss. + assert (EQ: ((fun x : ident * globdef Asm.fundef unit => + fst + (let + '(id, gd) := x in + (id, + gen_progdef ge_a (get_id_tr btr id) gd + (gen_counter_defs (next_id gds) gds) ! id + (gen_params + (next_id (map snd (PTree.elements (gen_counter_defs (next_id gds) gds)))) + gds) ! id)))) = fst). + { extensionalities. des_ifs. } + setoid_rewrite EQ in IN0. auto. + } + { hexploit Genv.genv_symb_range. eapply FIND2. ss. } + - left. apply Exists_exists in e. des. apply Classical_Prop.NNPP in e0. subst x. + hexploit list_in_map_inv. eapply e. intros. des. destruct x. ss; subst. + rename i into id, g into gd. + hexploit list_in_map_inv. eapply H0. intros. des. destruct x, p1. ss; clarify. + rename i into cnt, p0 into id, g into gd. + apply PTree.elements_complete in H1. apply gen_counter_defs_lt in H1. split. + + i. apply list_in_map_inv in H. des. destruct x; ss; clarify. apply next_id_lt in H2. lia. + + etransitivity; cycle 1. + { eapply genv_find_symbol_add_globals_gt_block. eapply FIND. ss. } + { subst ge_a. rewrite ! Genv.genv_next_add_globals. ss. + apply Pos.le_partorder. apply genv_advance_next_eq_len. + apply map_length. + } + Qed. + + Definition max_id0 {A} (l: list (ident * A)) i: ident := + (fold_left (fun x '(i, _) => if (x exists i2, In i2 (map fst l2) /\ (i1 < i2)%positive) + a b + (AB: (a <= b)%positive) + : + (max_id0 (l1 ++ l2) a <= max_id0 l2 b)%positive. + Proof. + revert_until l1. induction l1; i; ss. + { apply max_id0_ge; auto. } + destruct a as (id & a); ss. des_ifs; auto. + destruct (Pos.ltb_spec a0 id); ss. clear Heq. hexploit GT. left; auto. i; des. + destruct (Pos.ltb_spec i2 b); ss. + { apply IHl1. 2: lia. i. eapply GT. auto. } + rewrite (max_id0_base _ _ _ _ H0); auto. apply IHl1; auto. lia. + Qed. + + Lemma star_state_behaves_cut + p s0 tr + (CUT: exists s1, star step1 (globalenv p) s0 E0 s1 /\ + (exists s2 beh, star step1 (globalenv p) s1 tr s2 /\ + state_behaves (semantics1 p) s2 beh)) + : + exists s2 beh, star step1 (globalenv p) s0 tr s2 /\ state_behaves (semantics1 p) s2 beh. + Proof. + des. exists s2, beh. split; auto. eapply star_trans. 2: eauto. eauto. ss. + Qed. + +End PROOFINIT. + + + +Definition asm_program_does_prefix (p: Asm.program) (t: trace) := + semantics_has_initial_trace_prefix (Asm.semantics p) t. +Definition clight_program_does_prefix (p: Clight.program) (t: trace) := + semantics_has_initial_trace_prefix (Clight.semantics1 p) t. + +Definition asm_program_is_wf (p: Asm.program) := + (wf_program p) /\ + (wf_program_public p) /\ + (exists b, Genv.find_symbol (Genv.globalenv p) (AST.prog_main p) = Some b /\ + (exists f, Genv.find_funct_ptr (Genv.globalenv p) b = Some (AST.Internal f) /\ + (fn_sig f = signature_main))) /\ + (exists m0, Genv.init_mem p = Some m0). + + + +Section PROOF. + + Lemma step_fix_fix + p s tr s' + : + star (Asm.step (comp_of_main p)) (Genv.globalenv p) s tr s' + -> star (step_fix (comp_of_main p)) (Genv.globalenv p) s tr s'. + Proof. + (* TODO: FIXME *) + Admitted. + + Hypothesis EFO: external_functions_observable. + Hypothesis IAO: inline_assembly_observable. + + Lemma asm_to_clight + (p: Asm.program) + (WFP: wf_program p) + (WFPP: wf_program_public p) + (WFMAIN: wf_main p) + (WFMAINSIG: wf_main_sig p) + (WFINIT: exists (s : Asm.state), Asm.initial_state p s) + : + forall tr, + (Z.of_nat (length tr) < Int64.modulus) -> + asm_program_does_prefix p tr -> + exists btr, + clight_program_does_prefix (gen_program btr p) tr /\ + unbundle_trace btr = tr. + Proof. + i. rename H into BOUND, H0 into H. + eapply semantics_has_initial_trace_prefix_implies_cut in H. + 2:{ apply sd_traces. apply semantics_determinate. } + inv H; cycle 1. + { exfalso. ss. des. eapply H0. eapply WFINIT. } + clear WFINIT. ss. des. hexploit ir_has_initial_state; eauto. intros (ist & IR_INIT). + hexploit match_state_initial_state; eauto. intros (m0 & j & INIT_MEM_A & MS_I). + hexploit asm_to_ir. + { eapply wf_program_wf_ge; eauto. } + { eapply wf_asm_initial_state; eauto. } + { eapply step_fix_fix. eauto. } + { eapply MS_I. } + intros (btr & ist' & UTR & ISTAR). esplits. 2: eauto. + eapply semantics_has_initial_trace_cut_implies_prefix. + hexploit exists_initial_state; eauto. instantiate (1:=btr). + intros (f_cur & m_c & INIT_C & F_MAIN). + econs 1; ss. eapply INIT_C. eapply star_state_behaves_cut. + eexists. split. + { econs 2. 2: econs 1. 2: traceEq. eapply step_internal_function. + instantiate (3:=empty_env). instantiate (2:=@PTree.empty _). instantiate (1:=m_c). + des. econs; ss. all: try rewrite F_MAIN; try rewrite F_MAIN0; try rewrite F_MAIN1; ss. + econs. econs. econs. + } + clear dependent s. clear dependent s'. clear dependent m0. clear beh' j. + inv IR_INIT. clarify. des. inv INIT_C. rewrite gen_program_prog_main_eq in *. + remember (AST.prog_main p) as id_cur. clear Heqid_cur. + hexploit gen_program_match_find_def; eauto. intros MFD. + hexploit Genv.find_invert_symbol. eapply H. intros INV_A. + dup H0. rewrite Genv.find_funct_ptr_iff in H2. specialize (MFD _ _ _ H2 INV_A). + des_ifs. rename Heq into CNT_CUR. rename Heq0 into PAR_CUR. + assert (b = cur). + { eapply gen_program_symbs_find in H; eauto. ss. + subst ge0. setoid_rewrite H5 in H. clarify. ss. + } + subst b. ss. rewrite <- Genv.find_funct_ptr_iff in MFD. + assert (f_cur = (gen_function (Genv.globalenv p) i l (get_id_tr btr id_cur) f)). + { subst ge0. setoid_rewrite H6 in MFD. clarify. } + clear MFD. + hexploit gen_program_match_genv; eauto. instantiate (1:=btr). intros MGENV. + + hexploit ir_to_clight. + { eapply wf_program_wf_ge; eauto. } + 4: eapply ISTAR. + { hexploit bundle_trace_bounded; auto. apply ISTAR. clear - BOUND. i. lia. } + { instantiate (1:=State f_cur (fn_body f_cur) Kstop empty_env (PTree.empty val) m_c). + instantiate (1:=id_cur). + instantiate (1:=(get_cnt_ids (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)))). + instantiate (1:= globalenv (gen_program btr p)). ss. splits. + - unfold wf_counters. split. + { eapply gen_counter_defs_cnt_ids_inj; eauto. } + i. assert (PDM: (prog_defmap p) ! id = Some gd). + { rewrite Genv.find_def_symbol. esplits; eauto. } + hexploit gen_counter_defs_inv; eauto. eapply in_prog_defmap; eauto. intros GETCNT. + esplits. + { unfold get_cnt_ids. rewrite PTree.gmap. rewrite GETCNT. ss. } + set (id + next_id (AST.prog_defs p))%positive as id_cnt. + unfold wf_counter. splits. + { ss. assert (NIN: ~ In id_cnt (Genv.genv_public (Genv.globalenv (gen_program btr p)))). + { ii. destruct MGENV as ((MS0 & MS1 & MS2) & EQP). + replace (Genv.genv_public (Genv.globalenv (gen_program btr p))) with + (AST.prog_public p) in H10. + 2:{ rewrite Genv.globalenv_public. ss. } + apply WFPP in H10. apply list_in_map_inv in H10. des. destruct x; ss; clarify. + apply next_id_lt in H11. lia. + } + unfold Genv.public_symbol. des_ifs. + eapply (pred_dec_false (in_dec ident_eq _ _) true false) in NIN. des_ifs. + } + ss. assert (PDM_C: (prog_defmap (gen_program btr p)) ! id_cnt = Some (gen_counter (comp_of gd))). + { apply prog_defmap_norepet. apply gen_program_list_norepet; auto. + unfold gen_program. ss. unfold gen_prog_defs. apply in_or_app. right. + apply PTree.elements_correct in GETCNT. apply (in_map snd) in GETCNT. ss. + } + apply Genv.find_def_symbol in PDM_C. des. + hexploit Genv.init_mem_characterization_gen. eapply H4. + intros GI. specialize (GI _ _ PDM_C0). ss. des. + specialize (GI1 eq_refl). specialize (GI2 eq_refl). des. + esplits; eauto. + unfold Mem.valid_access. splits; auto. 2: apply Z.divide_0_r. + eapply Mem.loadbytes_can_access_block_inj; eauto. + - esplits; eauto. econs. + - unfold wf_c_stmt. i. subst f_cur. ss. rewrite CNT_CUR in H8. clarify. + replace (comp_of (gen_function (Genv.globalenv p) cnt [] (get_id_tr btr id_cur) f)) with + (Asm.fn_comp f). + 2:{ ss. } + apply match_symbs_code_bundle_trace. apply MGENV. + - ii. des_ifs. + - unfold not_global_blks. unfold empty_env. ss. unfold blocks_of_env2, blocks_of_env. ss. + - unfold wf_c_nb. ss. erewrite Genv.init_mem_genv_next. reflexivity. auto. + } + { instantiate (1:= gen_params (next_id (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p))))) (AST.prog_defs p)). + ss. splits. + - auto. + - assert (INCR: inject_incr (meminj_public (Genv.globalenv p)) (Mem.flat_inj (Mem.nextblock m0))). + { clear - H1. ii. unfold meminj_public in H. des_ifs. ss. + apply Genv.invert_find_symbol in Heq. unfold Genv.find_symbol in Heq. + apply Genv.genv_symb_range in Heq. apply Genv.init_mem_genv_next in H1. + unfold Mem.flat_inj. rewrite H1 in Heq. des_ifs. + } + unfold match_mem. splits; eauto. + + eapply genv_init_mem_inj; eauto. + + clear - INCR. ii. unfold inject_incr in INCR. + destruct (meminj_public (Genv.globalenv p) b) eqn:CASES; auto. + exfalso. destruct p0. specialize (INCR _ _ _ CASES). unfold Mem.flat_inj in INCR. + des_ifs. unfold Plt in *. lia. + - unfold match_cur_fun. ss. splits; ss. eauto. + - eapply gen_program_match_find_def; eauto. + - econs; auto. + - unfold match_params. splits. + + apply gen_params_wf. + + ii. hexploit in_gds_exists_params. 2: eauto. + { setoid_rewrite Genv.find_def_symbol. esplits; eauto. + rewrite <- Genv.find_funct_ptr_iff. eauto. + } + i. des. rewrite H10 in H11. clarify. + + ii. ss. hexploit Genv.find_symbol_inversion. apply H8. intros INDEF. + apply list_in_map_inv in H10. des. destruct x; ss; clarify. + hexploit gen_params_le. apply H9. apply H11. intros GT. + clear - WFP INDEF GT. unfold gen_program, prog_defs_names in INDEF. ss. + apply list_in_map_inv in INDEF. des. destruct x; ss; clarify. + apply next_id_lt in INDEF0. unfold gen_prog_defs in INDEF0. + assert (MAX: (max_id + (map + (fun '(id, gd) => + (id, + gen_progdef (Genv.globalenv p) (get_id_tr btr id) gd + (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)) ! id + (gen_params + (next_id + (map snd + (PTree.elements + (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p))))) + (AST.prog_defs p)) ! id)) (AST.prog_defs p) ++ + map snd + (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)))) <= + max_id (map snd + (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)))))%positive). + { apply max_id0_app. 2: lia. clear - WFP. i. rewrite map_map in H. + apply list_in_map_inv in H. des. destruct x; ss; clarify. + rewrite map_map. + hexploit gen_counter_defs_inv; eauto. intros. + apply PTree.elements_correct in H. + apply (in_map (fun x : positive * (ident * globdef fundef type) => fst (snd x))) in H. + ss. eexists. split. apply H. lia. + } + rewrite next_id_is_succ_max_id in INDEF0, GT. lia. + - ii. setoid_rewrite PTree.gmap in H8. unfold option_map in H8. des_ifs. + hexploit gen_counter_defs_lt; eauto. intros LT. + unfold Mem.flat_inj in H10. des_ifs. erewrite <- Genv.init_mem_genv_next in p0; eauto. + hexploit Genv.find_symbol_inversion. apply H9. intros INDEFS. + ss. hexploit genv_find_symbol_gen_program_cases. eauto. eapply H9. i. des. + + unfold Plt in p0. lia. + + clear - LT H3. apply list_in_map_inv in H3. des. destruct x; ss; clarify. + hexploit next_id_lt; eauto. i. lia. + } + intros (cst' & STAR_C). hexploit state_behaves_exists. intros (beh2 & BEH2). + esplits; eauto. + Qed. + +End PROOF. + +Section BT. + + Hypothesis EFO: external_functions_observable. + Hypothesis IAO: inline_assembly_observable. + + Theorem backtranslation_proof + (p: Asm.program) + (WF: asm_program_is_wf p) + : + forall tr, + (Z.of_nat (length tr) < Int64.modulus) -> + asm_program_does_prefix p tr -> + exists p_c, + clight_program_does_prefix p_c tr. + Proof. + unfold asm_program_is_wf in WF. des. i. + hexploit asm_to_clight; eauto. + { rr. esplits; eauto. } + { rr. i. rewrite WF1 in H1. clarify. } + { eexists. econs; eauto. } + i. des. eauto. + Qed. + +End BT. diff --git a/security/Blame.v b/security/Blame.v index 08e457d4f8..eb97f92254 100644 --- a/security/Blame.v +++ b/security/Blame.v @@ -5,90 +5,65 @@ Require Import AST Globalenvs Linking Smallstep Events Behaviors Memory Values. Require Import Ctypes Cop Clight. Require Import Split. -Definition gdef := globdef fundef type. - -Variant match_fundef : unit -> fundef -> fundef -> Prop := +Variant match_fundef (s: split): unit -> fundef -> fundef -> Prop := | match_function_left: forall cp ty cc params vars vars' temps temps' body body', - match_fundef tt - (Internal {| fn_comp := cp; fn_return := ty; fn_callconv := cc; - fn_params := params; fn_vars := vars; fn_temps := temps; - fn_body := body |}) - (Internal {| fn_comp := cp; fn_return := ty; fn_callconv := cc; - fn_params := params; fn_vars := vars'; fn_temps := temps'; - fn_body := body' |}) + s |= cp ∈ Left -> + match_fundef s tt (Internal {| fn_comp := cp; fn_return := ty; fn_callconv := cc; + fn_params := params; fn_vars := vars; fn_temps := temps; + fn_body := body |}) + (Internal {| fn_comp := cp; fn_return := ty; fn_callconv := cc; + fn_params := params; fn_vars := vars'; fn_temps := temps'; + fn_body := body' |}) | match_external_left: forall ef tys ty cc, - match_fundef tt (External ef tys ty cc) - (External ef tys ty cc) + s |= ef ∈ Left -> + match_fundef s tt (External ef tys ty cc) + (External ef tys ty cc) + | match_right: forall fd, + s |= fd ∈ Right -> + match_fundef s tt fd fd . -#[local] Instance has_comp_match_fundef : has_comp_match match_fundef. +#[local] Instance has_comp_match_fundef (s: split): has_comp_match (match_fundef s). intros ? x y H. inv H; auto. Qed. -Lemma match_fundef_refl u f : match_fundef u f f. -Proof. -destruct u. destruct f as [[]|]; constructor. -Qed. Definition match_varinfo (ty1 ty2: type): Prop := ty1 = ty2. -Definition kept_genv (s: split) (ge: genv) (δ: side) (id: ident): bool := - match Genv.find_symbol ge id with - | Some b => - match (Genv.genv_defs ge)!b with - | None => false - | Some gd => side_eq (s (comp_of gd)) δ - end - | None => false - end. - -Variant match_globdef : gdef -> gdef -> Prop := -| match_gfun f1 f2 : - match_fundef tt f1 f2 -> match_globdef (Gfun f1) (Gfun f2) -| match_gvar v1 v2 : - match_globvar match_varinfo v1 v2 -> - match_globdef (Gvar v1) (Gvar v2). - -Definition match_opt_globdefs sd d1 d2 := - match sd with - | Left => option_rel match_globdef d1 d2 - | Right => d1 = d2 - end. - -Definition match_globdefs (s: split) (ge1 ge2: genv) := - forall id cp, - (Genv.find_comp_of_ident ge1 id = Some cp \/ - Genv.find_comp_of_ident ge2 id = Some cp) -> - (s cp = Right \/ Genv.public_symbol ge1 id = true \/ - Genv.public_symbol ge2 id = true) -> - exists b1 b2, - Genv.find_symbol ge1 id = Some b1 /\ - Genv.find_symbol ge2 id = Some b2 /\ - match_opt_globdefs (s cp) (Genv.find_def ge1 b1) (Genv.find_def ge2 b2). - -Record match_prog (s: split) (p p': program) : Prop := { - match_prog_main: - p'.(prog_main) = p.(prog_main); - match_prog_public: - p'.(prog_public) = p.(prog_public); - match_prog_types: - p'.(prog_types) = p.(prog_types); - match_prog_pol: - p'.(prog_pol) = p.(prog_pol); - match_prog_globdefs: - match_globdefs s (globalenv p) (globalenv p'); - match_prog_unique1: - list_norepet (prog_defs_names p); - match_prog_unique2: - list_norepet (prog_defs_names p') -}. +Definition match_prog (s: split) := match_program_gen (match_fundef s) match_varinfo. Section Equivalence. Variable s: split. Variable j: meminj. - Definition same_domain (ge1: genv) (m1: mem) := + Definition same_symbols (ge1 : genv) m1 := + let H := Mem.has_side_block in + forall id loc, + Genv.find_symbol ge1 id = Some loc -> + (* AAA: This condition is not present in Genv.same_symbols. This is + problematic for the invariant below because, together with same_dom, it + means that the global environment can only have identifiers defined on + the right. Cf. problem lemma below. *) + (s, m1) |= loc ∈ Right -> + j loc = Some (loc, 0). + (* AAA: Consider using symbols_inject instead of this condition. *) + + + Lemma problem (ge1 : genv) m1 id (b : block) : + let H := Mem.has_side_block in + Mem.same_domain s j Right m1 -> + Genv.same_symbols j ge1 -> + Genv.find_symbol ge1 id = Some b -> + (s, m1) |= b ∈ Right. + Proof. + simpl. intros same_dom same_sym find. + specialize (same_sym _ _ find). + assert (def : j b <> None) by congruence. + now rewrite (same_dom b) in def. + Qed. + + Definition same_domain (ge1 ge2: genv) (m1 m2: mem) := let H := Mem.has_side_block in forall b, match Genv.invert_symbol ge1 b with @@ -96,113 +71,17 @@ Section Equivalence. if Senv.public_symbol ge1 id then j b <> None else - j b <> None <-> (s, m1) |= b ∈ Right + j b <> None -> (s, m1) |= b ∈ Right | None => - j b <> None <-> (s, m1) |= b ∈ Right + j b <> None -> (s, m1) |= b ∈ Right end. - Lemma same_domain_free m b lo hi cp m' ge - (FREE : Mem.free m b lo hi cp = Some m') - (BLOCKS : same_domain ge m) : - same_domain ge m'. - Proof. - intros b'. specialize (BLOCKS b'). - destruct Genv.invert_symbol as [id |] eqn:INVSYM. - - destruct Senv.public_symbol eqn:PUBSYM; - [assumption |]. - split. - + intros j_b'. destruct BLOCKS as [BLOCKS _]. specialize (BLOCKS j_b'). - simpl in *. destruct (Mem.block_compartment m b') as [cp' |] eqn:COMP; - [| contradiction]. - rewrite (Mem.free_can_access_block_inj_1 _ _ _ _ _ _ FREE _ (Some _) COMP). - assumption. - + intros RIGHT. destruct BLOCKS as [_ BLOCKS]. simpl in *. - destruct (Mem.block_compartment m' b') as [cp' |] eqn:COMP'; - [| contradiction]. - rewrite (Mem.free_can_access_block_inj_2 _ _ _ _ _ _ FREE _ (Some _) COMP') - in BLOCKS. - exact (BLOCKS RIGHT). - - split. (* Same proof as above *) - + intros j_b'. destruct BLOCKS as [BLOCKS _]. specialize (BLOCKS j_b'). - simpl in *. destruct (Mem.block_compartment m b') as [cp' |] eqn:COMP; - [| contradiction]. - rewrite (Mem.free_can_access_block_inj_1 _ _ _ _ _ _ FREE _ (Some _) COMP). - assumption. - + intros RIGHT. destruct BLOCKS as [_ BLOCKS]. simpl in *. - destruct (Mem.block_compartment m' b') as [cp' |] eqn:COMP'; - [| contradiction]. - rewrite (Mem.free_can_access_block_inj_2 _ _ _ _ _ _ FREE _ (Some _) COMP') - in BLOCKS. - exact (BLOCKS RIGHT). - Qed. - - Lemma same_domain_free_list m bs cp m' ge - (FREE : Mem.free_list m bs cp = Some m') - (BLOCKS : same_domain ge m) : - same_domain ge m'. - Proof. - revert m cp m' ge FREE BLOCKS. - induction bs as [| [[b lo] hi] ? IH]; intros. - - now inv FREE. - - simpl in FREE. - destruct (Mem.free m b lo hi cp) as [m1 |] eqn:FREE1; [| discriminate]. - eapply same_domain_free in FREE1; [| exact BLOCKS]. - now eapply IH; eauto. - Qed. - - Definition same_blocks (ge: genv) (m: mem) := - forall b cp, Genv.find_comp_of_block ge b = Some cp -> - Mem.block_compartment m b = Some cp. - - Lemma same_blocks_store chunk m b ofs sz cp m' ge - (STORE : Mem.store chunk m b ofs sz cp = Some m') - (BLOCKS : same_blocks ge m) : - same_blocks ge m'. - Proof. - intros. intros b' cp' FIND. specialize (BLOCKS b' cp' FIND). - erewrite Mem.store_block_compartment; eauto. - Qed. - - Lemma same_blocks_storebytes m b ofs sz ocp m' ge - (STORE : Mem.storebytes m b ofs sz ocp = Some m') - (BLOCKS : same_blocks ge m) : - same_blocks ge m'. - Proof. - intros. intros b' cp FIND. specialize (BLOCKS b' cp FIND). - erewrite Mem.storebytes_block_compartment; eauto. - Qed. - - Lemma same_blocks_free m b lo hi cp m' ge - (FREE : Mem.free m b lo hi cp = Some m') - (BLOCKS : same_blocks ge m) : - same_blocks ge m'. - Proof. - intros b' cp' FIND. specialize (BLOCKS b' cp' FIND). - exact (Mem.free_can_access_block_inj_1 _ _ _ _ _ _ FREE _ (Some _) BLOCKS). - Qed. - - Lemma same_blocks_free_list m bs cp m' ge - (FREE : Mem.free_list m bs cp = Some m') - (BLOCKS : same_blocks ge m) : - same_blocks ge m'. - Proof. - revert m cp m' ge FREE BLOCKS. - induction bs as [| [[b lo] hi] ? IH]; intros. - - now inv FREE. - - simpl in FREE. - destruct (Mem.free m b lo hi cp) as [m1 |] eqn:FREE1; [| discriminate]. - eapply same_blocks_free in FREE1; [| exact BLOCKS]. - now eapply IH; eauto. - Qed. - - Record right_mem_injection (ge1 ge2: genv) (m1 m2: mem) : Prop := - { same_dom: same_domain ge1 m1; + Record right_mem_injection (ge1 ge2: genv) (m1 m2: mem) := + { same_dom: same_domain ge1 ge2 m1 m2; partial_mem_inject: Mem.inject j m1 m2; j_delta_zero: Mem.delta_zero j; same_symb: symbols_inject j ge1 ge2; - jinjective: Mem.meminj_injective j; - same_blks1: same_blocks ge1 m1; - same_blks2: same_blocks ge2 m2; + jinjective: Mem.meminj_injective j }. Fixpoint remove_until_right (k: cont) := @@ -233,12 +112,16 @@ Inductive right_cont_injection: cont -> cont -> Prop := | right_cont_injection_kcall_left: forall id1 id2 f1 f2 en1 en2 le1 le2 k1 k2, s |= f1 ∈ Left -> s |= f2 ∈ Left -> + (* s (comp_of f1) = Left -> *) + (* s (comp_of f2) = Left -> *) right_cont_injection (remove_until_right k1) (remove_until_right k2) -> right_cont_injection (Kcall id1 f1 en1 le1 k1) (Kcall id2 f2 en2 le2 k2) (* TODO: is it correct to add [right_cont_injection_kcall_right]? *) | right_cont_injection_kcall_right: forall id1 id2 f1 f2 en1 en2 le1 le2 k1 k2, s |= f1 ∈ Right -> s |= f2 ∈ Right -> + (* s (comp_of f1) = Right -> *) + (* s (comp_of f2) = Right -> *) right_cont_injection k1 k2 -> right_cont_injection (Kcall id1 f1 en1 le1 k1) (Kcall id2 f2 en2 le2 k2) . @@ -274,39 +157,39 @@ Definition right_tenv_injection (le1 le2: temp_env): Prop := Variant right_executing_injection (ge1 ge2: genv): state -> state -> Prop := | inject_states: forall f s k1 k2 e1 e2 le1 le2 m1 m2, (* we forget about program memories but require injection of context memories *) - forall RMEMINJ : right_mem_injection ge1 ge2 m1 m2, + right_mem_injection ge1 ge2 m1 m2 -> (* we forget about program parts of the continuation but require injection of context continuation *) - forall RCONTINJ : right_cont_injection k1 k2, + right_cont_injection k1 k2 -> (* the environments satisfy the injection *) - forall RENVINJ : right_env_injection e1 e2, - forall RTENVINJ : right_tenv_injection le1 le2, + right_env_injection e1 e2 -> + right_tenv_injection le1 le2 -> right_executing_injection ge1 ge2 (State f s k1 e1 le1 m1) (State f s k2 e2 le2 m2) | inject_callstates: forall f vs vs' k1 k2 m1 m2, (* we forget about program memories but require injection of context memories *) - forall RMEMINJ : right_mem_injection ge1 ge2 m1 m2, + right_mem_injection ge1 ge2 m1 m2 -> (* we forget about program parts of the continuation but require injection of context continuation *) - forall RCONTINJ : right_cont_injection k1 k2, + right_cont_injection k1 k2 -> (* the parameters are related by the memory injection *) - forall ARGINJ : Val.inject_list j vs vs', + Val.inject_list j vs vs' -> right_executing_injection ge1 ge2 (Callstate f vs k1 m1) (Callstate f vs' k2 m2) | inject_returnstates: forall v v' k1 k2 m1 m2 ty cp, (* we forget about program memories but require injection of context memories *) - forall RMEMINJ : right_mem_injection ge1 ge2 m1 m2, + right_mem_injection ge1 ge2 m1 m2 -> (* we forget about program parts of the continuation but require injection of context continuation *) - forall RCONTINJ : right_cont_injection k1 k2, + right_cont_injection k1 k2 -> (* The return values are related by the injection *) - forall RVALINJ : Val.inject j v v', + Val.inject j v v' -> right_executing_injection ge1 ge2 (Returnstate v k1 m1 ty cp) (Returnstate v' k2 m2 ty cp) . @@ -364,182 +247,20 @@ Section Simulation. Hypothesis c_p1: link p1 c = Some W1. Hypothesis c_p2: link p2 c = Some W2. - Hypothesis match_W1_W2: match_prog s W1 W2. - - Hypothesis W1_ini: exists s, Smallstep.initial_state (semantics1 W1) s. - Hypothesis W2_ini: exists s, Smallstep.initial_state (semantics1 W2) s. + Hypothesis match_W1_W2: match_prog s tt W1 W2. (* Context (ge1 ge2: genv). *) - Notation ge1 := (globalenv W1). - Notation ge2 := (globalenv W2). -(* - Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. - Proof (Genv.find_symbol_match match_W1_W2). -*) - -(** New helpers *) - -Lemma state_split_decidable: - forall st, s |= st ∈ Left \/ s |= st ∈ Right. -Proof. - intros []. - - simpl. destruct (s (comp_of f)); auto. - - simpl. destruct (s (comp_of fd)); auto. - - simpl. destruct (s cp); auto. -Qed. + Let ge1 := globalenv W1. + Let ge2 := globalenv W2. + (* Is this hypothesis realistic? *) + Hypothesis same_cenv: genv_cenv ge1 = genv_cenv ge2. -Lemma state_split_contra: - forall st, s |= st ∈ Left -> s |= st ∈ Right -> False. -Proof. - intros []. - - simpl. destruct (s (comp_of f)); discriminate. - - simpl. destruct (s (comp_of fd)); discriminate. - - simpl. destruct (s cp); discriminate. -Qed. - -Lemma step_E0_same_side: forall {p s1 s2 sd}, - Step (semantics1 p) s1 E0 s2 -> - s |= s1 ∈ sd <-> s |= s2 ∈ sd. -Proof. - intros p s1 s2 sd STEP. - inv STEP; try easy. - - inv EV. unfold Genv.type_of_call in H4. - destruct (_ =? _)%positive eqn:EQ; [| contradiction]. - simpl. apply Pos.eqb_eq in EQ. rewrite EQ. - easy. - - inv EV. unfold Genv.type_of_call in H. - destruct (_ =? _)%positive eqn:EQ; [| contradiction]. - simpl. apply Pos.eqb_eq in EQ. rewrite EQ. easy. -Qed. - -Lemma star_E0_same_side: forall {p s1 s2 sd}, - Star (semantics1 p) s1 E0 s2 -> - s |= s1 ∈ sd <-> s |= s2 ∈ sd. -Proof. - intros p s1 s2 sd STAR. - elim STAR using star_E0_ind; clear s1 s2 STAR. - - easy. - - intros s1 s2 s3 STEP12 IH. - rewrite (step_E0_same_side STEP12). - auto. -Qed. -Lemma right_state_injection_same_side_left: forall {j ge1 ge2 s1 s2 sd}, - right_state_injection s j ge1 ge2 s1 s2 -> - s |= s2 ∈ sd -> - s |= s1 ∈ sd. -Proof. - intros j ge1 ge2 s1 s2 sd RINJ SIDE. - destruct sd; inv RINJ. - - assumption. - - exfalso. eapply state_split_contra; eauto. - - exfalso. eapply state_split_contra; eauto. - - assumption. -Qed. - - (** More invariant helpers *) - - Lemma same_blocks_step1 s1 s1' - (BLKS : same_blocks ge1 (memory_of s1)) - (STEP : step1 ge1 s1 E0 s1'): - same_blocks ge1 (memory_of s1'). - Proof. - inv STEP; auto. - - admit. - - intros b cp FIND. - specialize (BLKS b cp FIND). - simpl in *. - change (Mem.block_compartment m b = Some cp) - with (Mem.can_access_block m b (Some cp)) in BLKS. - exploit external_call_can_access_block; eauto. - - eapply same_blocks_free_list; eauto. - - eapply same_blocks_free_list; eauto. - - eapply same_blocks_free_list; eauto. - - admit. - - intros b cp FIND. - specialize (BLKS b cp FIND). - simpl in *. - change (Mem.block_compartment m b = Some cp) - with (Mem.can_access_block m b (Some cp)) in BLKS. - exploit external_call_can_access_block; eauto. - Admitted. - - (** *) - - Lemma public_symbol_preserved: - forall id, Genv.public_symbol ge2 id = Genv.public_symbol ge1 id. - Proof. - intros id. - assert (in_dec ident_eq id (Genv.genv_public ge2) = - in_dec ident_eq id (Genv.genv_public ge1) :> bool) - as public_eq. - { simpl. rewrite !Genv.globalenv_public. simpl. - now rewrite (match_prog_public _ _ _ match_W1_W2). } - destruct (Genv.public_symbol ge1 id) eqn:public1. - - destruct (Genv.public_symbol_exists _ _ public1) as [b1 ge1_id_b1]. - assert (exists cp, Genv.find_comp_of_ident ge1 id = Some cp) - as [cp ge1_id_cp]. - { apply Genv.find_symbol_find_comp. - unfold ge1, fundef in *. simpl in *. congruence. } - assert (exists b2, Genv.find_symbol ge2 id = Some b2) - as [b2 ge2_id_b2]. - { exploit match_prog_globdefs; eauto. - intros (? & b2 & _ & H & _). eauto. } - unfold Genv.public_symbol in *. - rewrite ge1_id_b1 in public1. - rewrite ge2_id_b2. congruence. - - unfold Genv.public_symbol in public1. - destruct (Genv.find_symbol ge1 id) as [b1|] eqn:ge1_id. - + assert (exists cp, Genv.find_comp_of_ident ge1 id = Some cp) - as [cp ge1_id_cp]. - { apply Genv.find_symbol_find_comp. - unfold ge1, fundef in *. simpl in *. congruence. } - unfold Genv.public_symbol. - destruct (Genv.find_symbol ge2 id) as [b2|] eqn:ge2_id; trivial. - congruence. - + destruct (Genv.public_symbol ge2 id) eqn:public2; trivial. - destruct (Genv.public_symbol_exists _ _ public2) as [b2 ge2_id_b2]. - assert (exists cp, Genv.find_comp_of_ident ge2 id = Some cp) - as [cp ge2_id_cp]. - { apply Genv.find_symbol_find_comp. - unfold ge1, fundef in *. simpl in *. congruence. } - exploit match_prog_globdefs; eauto. - intros (? & _ & ? & _). congruence. - Qed. - - Lemma allowed_addrof_translated: - forall cp id, - s cp = Right -> - Genv.allowed_addrof ge1 cp id -> - Genv.allowed_addrof ge2 cp id. - Proof. - intros cp id RIGHT [H|H]. - - left. - exploit match_prog_globdefs; eauto. rewrite RIGHT. simpl. - intros (b1 & b2 & ge1_id & ge2_id & MATCH). - unfold Genv.find_comp_of_ident in *. - simpl in H. rewrite ge1_id in H. - rewrite ge2_id. - unfold Genv.find_comp_of_block in *. now rewrite <- MATCH. - - right. now rewrite public_symbol_preserved. - Qed. - - Lemma genv_cenv_preserved : ge2 = ge1 :> composite_env. - Proof. - simpl. - pose proof (prog_comp_env_eq W1) as H1. - pose proof (prog_comp_env_eq W2) as H2. - rewrite (match_prog_types _ _ _ match_W1_W2) in H2. - congruence. - Qed. - - (* AAA: [2023-08-08: This next part is not true anymore because left symbols - can be covered by a memory injection] Right now, this statement is forcing - every global identifier id that occurs in an expression to refer to a - function or variable that is defined on the right. This is because, when - you evaluate an lvalue, you get something that is defined in the memory - injection j. Here are possible solutions: + (* AAA: Right now, this statement is forcing every global identifier id that + occurs in an expression to refer to a function or variable that is defined + on the right. This is because, when you evaluate an lvalue, you get + something that is defined in the memory injection j. Here are possible + solutions: 1. Modify the second implication so that, if we evaluate an lvalue that is not defined in the memory injection j (and, therefore, is on the Left), @@ -552,47 +273,26 @@ Qed. 2. Change the second implication so that we do not care if we get a non-global-function-or-variable pointer that is on the left. - [2023-08-23] We realized that, if we allow programs to take the address of - arbitrary variables, we run into issues when a program running on the right - attempts to take the address of a private variable on the left. The issue - is that, according to our current matching definitions, this private - variable must not have a corresponding address in the memory injection - relating the two executions. Therefore, it would not be possible to produce - a matching evaluation on the other execution. - - One solution would be to dynamically disallow taking the address of a - non-public variable that lives in a different compartment. But at lower - levels it might not be possible to impose this check, because there - probably isn't a difference between variables and their addresses (NB we - should double-check this!). But this might not be an issue, because we are - always free to omit checks at the target level. - - Moreover, it sounds like this check might be necessary for blame to - hold. Consider a context C that is linked against two programs p1 and p2. - If C tries to access a private variable of p1 that is not defined by p2, - and the check is not performed, the execution with p1 might succeed, - whereas the one with p2 will definitely fail. - *) Lemma eval_expr_lvalue_injection: - forall j m1 m2 e1 e2 le1 le2 cp, + forall s j m1 m2 e1 e2 le1 le2 cp, forall inj: right_mem_injection s j ge1 ge2 m1 m2, forall env_inj: right_env_injection j e1 e2, forall lenv_inj: right_tenv_injection j le1 le2, - forall cp_right: s cp = Right, (forall a v, eval_expr ge1 e1 cp le1 m1 a v -> + (* forall loc ofs (EQv: v = Vptr loc ofs), *) exists v', Val.inject j v v' /\ eval_expr ge2 e2 cp le2 m2 a v') /\ (forall a loc ofs bf, eval_lvalue ge1 e1 cp le1 m1 a loc ofs bf -> exists loc' ofs', - (j loc = Some (loc', ofs')) /\ + j loc = Some (loc', ofs') /\ eval_lvalue ge2 e2 cp le2 m2 a loc' (Ptrofs.add ofs (Ptrofs.repr ofs')) bf). Proof. - intros. - destruct inj as [inj_dom inj_inject j_delta_zero same_symb jinj SAMEBLKS]. + intros. subst ge1 ge2. + destruct inj as [inj_dom inj_inject j_delta_zero same_symb]. apply eval_expr_lvalue_ind; intros; try now match goal with | |- exists _, Val.inject _ (Vint _) _ /\ _ => eexists; split; [eapply Val.inject_int | econstructor; eauto] @@ -600,44 +300,36 @@ Qed. | |- exists _, Val.inject _ (Vsingle _) _ /\ _ => eexists; split; [eapply Val.inject_single | econstructor; eauto] | |- exists _, Val.inject _ (Vlong _) _ /\ _ => eexists; split; [eapply Val.inject_long | econstructor; eauto] end. - - (* eval_Etempvar *) - exploit lenv_inj; eauto. intros [loc' [? ?]]. + - exploit lenv_inj; eauto. intros [loc' [? ?]]. eexists; split; eauto. constructor; auto. - - (* eval_Eaddrof *) - destruct H0 as [loc' [ofs' [? ?]]]. + - destruct H0 as [loc' [ofs' [? ?]]]. eexists; split; eauto. econstructor; eauto. - - (* eval_Eunop *) - destruct H0 as [v' [? ?]]. + - destruct H0 as [v' [? ?]]. exploit sem_unary_operation_inject; eauto. intros [? [? ?]]. eexists; split; eauto. econstructor; eauto. - - (* eval_Ebinop *) - destruct H0 as [v1' [? ?]]. + - destruct H0 as [v1' [? ?]]. destruct H2 as [v2' [? ?]]. exploit sem_binary_operation_inject; eauto. - rewrite <- genv_cenv_preserved. + rewrite same_cenv. intros [? [? ?]]. eexists; split; eauto. econstructor; eauto. - - (* eval_Ecast *) - destruct H0 as [v' [? ?]]. + - destruct H0 as [v' [? ?]]. exploit sem_cast_inject; eauto. intros [v1' [? ?]]. eexists; split; eauto. econstructor; eauto. - - (* eval_Esizeof *) - rewrite <- genv_cenv_preserved. + - rewrite same_cenv. eexists; split; eauto. econstructor; eauto. - - (* eval_Ealignof *) - rewrite <- genv_cenv_preserved. + - rewrite same_cenv. eexists; split; eauto. econstructor; eauto. - - (* eval_Elvalue *) - destruct H0 as [loc' [ofs' [? ?]]]. + - destruct H0 as [loc' [ofs' [? ?]]]. (* This assert heavily relies on the assumption that the injection always gives a delta = 0. *) assert (G: exists v', Val.inject j v v' /\ deref_loc cp (typeof a) m2 loc' (Ptrofs.add ofs (Ptrofs.repr ofs')) bf v'). @@ -661,82 +353,46 @@ Qed. destruct G as [v' [? ?]]. eexists; split; eauto. econstructor; eauto. - - (* eval_Evar_local *) - destruct env_inj as [env_inj _]. + - destruct env_inj as [env_inj _]. exploit env_inj; eauto. intros [b' [? ?]]. eexists; eexists; split; eauto. econstructor; eauto. - - (* eval_Evar_global *) - destruct env_inj as [_ env_inj]. + - destruct env_inj as [_ env_inj]. rename l into b. rename H into e1_id. rename H0 into W1_id. - rename H1 into ALLOWED. exploit env_inj; eauto. intros e2_id. exploit Genv.find_invert_symbol; eauto. - intros W1_b. + intros W1_l. pose proof (idP := inj_dom b). - rewrite W1_b in idP. + rewrite W1_l in idP. destruct (Senv.public_symbol _ id) eqn: public_id. - + (* public symbol *) - assert (exists b', j b = Some (b', 0) /\ - Senv.find_symbol (globalenv W2) id = Some b') - as (b' & j_b & W2_id). - { destruct same_symb as (_ & _ & H & _). now apply H. } - exists b', 0; split; trivial. - rewrite Ptrofs.add_zero_l. - eapply eval_Evar_global; eauto. - now apply allowed_addrof_translated. - + (* private symbol *) - assert (id_cp : Genv.find_comp_of_ident ge1 id = Some cp). - { destruct ALLOWED; trivial. - unfold Genv.to_senv in public_id. simpl in public_id. - unfold globalenv in H. simpl in H. - congruence. } - assert (b_right : (s, m1) |= b ∈ Right). - { unfold Mem.has_side_block. simpl. - unfold Genv.find_comp_of_ident in id_cp. - rewrite W1_id in id_cp. - apply SAMEBLKS in id_cp. now rewrite id_cp. } - apply idP in b_right. - destruct (j b) as [[loc' ofs']|] eqn:j_b; try easy. - clear b_right idP. - exists loc', ofs'. split; trivial. - assert (ofs' = 0 /\ Genv.find_symbol (globalenv W2) id = Some loc') - as [? W2_id]. - { destruct same_symb as (_ & same_symb & _). - eapply same_symb; eauto. } - subst ofs'. - rewrite Ptrofs.add_zero_l. - apply eval_Evar_global; eauto. - now apply allowed_addrof_translated. - - (* eval_Ederef *) - destruct H0 as [v' [? ?]]. +(* eapply Genv.find_symbol_match in match_W1_W2. rewrite <- match_W1_W2 in H0. + eexists; eexists; split; eauto. + eapply eval_Evar_global; eauto.*) admit. + - destruct H0 as [v' [? ?]]. inv H0. eexists; eexists; split; eauto. econstructor; eauto. - - (* eval_Efield_struct *) - destruct H0 as [v' [? ?]]. + - destruct H0 as [v' [? ?]]. inv H0. eexists; eexists; split; eauto. rewrite Ptrofs.add_assoc, (Ptrofs.add_commut (Ptrofs.repr delta)), <- Ptrofs.add_assoc. - eapply eval_Efield_struct; try rewrite genv_cenv_preserved; eauto. - - (* eval_Efield_union *) - destruct H0 as [v' [? ?]]. + eapply eval_Efield_struct; try rewrite <- same_cenv; eauto. + - destruct H0 as [v' [? ?]]. inv H0. eexists; eexists; split; eauto. rewrite Ptrofs.add_assoc, (Ptrofs.add_commut (Ptrofs.repr delta)), <- Ptrofs.add_assoc. - eapply eval_Efield_union; try rewrite genv_cenv_preserved; eauto. + eapply eval_Efield_union; try rewrite <- same_cenv; eauto. Qed. Lemma eval_expr_injection: - forall j m1 m2 e1 e2 le1 le2 cp, + forall s j m1 m2 e1 e2 le1 le2 cp, forall inj: right_mem_injection s j ge1 ge2 m1 m2, forall env_inj: right_env_injection j e1 e2, forall lenv_inj: right_tenv_injection j le1 le2, - forall s_right: s cp = Right, forall a v, eval_expr ge1 e1 cp le1 m1 a v -> exists v', Val.inject j v v' /\ @@ -748,11 +404,10 @@ Qed. Qed. Lemma eval_exprlist_injection: - forall j m1 m2 e1 e2 le1 le2 cp, + forall s j m1 m2 e1 e2 le1 le2 cp, forall inj: right_mem_injection s j ge1 ge2 m1 m2, forall env_inj: right_env_injection j e1 e2, forall lenv_inj: right_tenv_injection j le1 le2, - forall s_right: s cp = Right, forall al tys vs, eval_exprlist ge1 e1 cp le1 m1 al tys vs -> exists vs', Val.inject_list j vs vs' /\ @@ -772,11 +427,10 @@ Qed. Qed. Lemma eval_lvalue_injection: - forall j m1 m2 e1 e2 le1 le2 cp, + forall s j m1 m2 e1 e2 le1 le2 cp, forall inj: right_mem_injection s j ge1 ge2 m1 m2, forall env_inj: right_env_injection j e1 e2, forall lenv_inj: right_tenv_injection j le1 le2, - forall s_right: s cp = Right, forall a loc ofs bf, eval_lvalue ge1 e1 cp le1 m1 a loc ofs bf -> exists loc' ofs', j loc = Some (loc', ofs') /\ @@ -789,353 +443,91 @@ Qed. Ltac destruct_mem_inj := match goal with - | H: right_mem_injection _ _ _ _ _ _ |- _ => - destruct H as [same_dom mem_inject delta_zero same_symb injective SAMEBLKS] + | H: right_mem_injection _ _ _ _ _ _ |- _ => destruct H as [same_dom mem_inject delta_zero same_symb injective] end. - Lemma find_funct_preserved j f v v' : - s (comp_of f) = Right -> - Val.inject j v v' -> - symbols_inject j ge1 ge2 -> - Genv.find_funct ge1 v = Some f -> - Genv.find_funct ge2 v' = Some f. - Proof. - unfold Genv.find_funct. intros s_cp v_inj symbs_inj. - case v_inj; try congruence. clear v_inj. - intros b ofs b' _ delta j_b ->. - destruct Ptrofs.eq_dec as [?|_]; try congruence. subst ofs. - intros ge1_b. - apply Genv.find_funct_ptr_iff in ge1_b. - assert (exists id, Genv.find_symbol ge1 id = Some b) as [id ge1_id]. - { apply (Genv.find_def_find_symbol_inversion _ _ ge1_b). - apply (match_prog_unique1 _ _ _ match_W1_W2). } - assert (delta = 0 /\ Genv.find_symbol ge2 id = Some b') as [? ge2_id]. - { destruct symbs_inj as (_ & inj & _); eapply inj; eauto. } - subst delta. - rewrite Ptrofs.add_zero_l. unfold Ptrofs.zero. - destruct Ptrofs.eq_dec as [_|?]; try congruence. - assert (Genv.find_comp_of_ident ge1 id = Some (comp_of f)) as ge1_id_comp. - { unfold Genv.find_comp_of_ident. rewrite ge1_id. - unfold Genv.find_comp_of_block. now rewrite ge1_b. } - exploit match_prog_globdefs; eauto. - intros (b1 & b2 & ge1_id_alt & ge2_id_alt & MATCH). - assert (b1 = b) by congruence. subst b1. - assert (b2 = b') by congruence. subst b2. - rewrite ge1_b, s_cp in MATCH. simpl in MATCH. - unfold Genv.find_funct_ptr, ge2. simpl. - rewrite <- MATCH. split; trivial. - Qed. - - Lemma allowed_call_preserved : forall j cp m1 m2 vf1 vf2, - right_mem_injection s j ge1 ge2 m1 m2 -> - Val.inject j vf1 vf2 -> - Genv.allowed_call ge1 cp vf1 -> - Genv.allowed_call ge2 cp vf2. - Proof. - intros j cp m1 m2 vf1 vf2 inj vf12 allowed. - destruct allowed as [same_comp|cross]; [left|right]. - - unfold Genv.find_comp in *. - revert same_comp. case vf12; try easy. - intros b1 _ b2 ofs2 delta j_b1 _ ge1_b1. - assert (exists id, Genv.find_symbol ge1 id = Some b1) as (id & ge1_id). - { unfold Genv.find_comp_of_block in ge1_b1. - destruct (Genv.find_def ge1 b1) as [d1|] eqn:ge1_b1'; try easy. - eapply Genv.find_def_find_symbol_inversion; eauto. - exploit match_prog_unique1; eauto. } - assert (ge1_id_cp : Genv.find_comp_of_ident ge1 id = Some cp). - { unfold Genv.find_comp_of_ident. now rewrite ge1_id, ge1_b1. } - exploit same_symb; eauto. - intros (H1 & H2 & H3 & H4). - exploit H2; eauto. intros (-> & ge2_id). simpl in ge2_id. - unfold Genv.find_comp_of_block. - exploit Genv.find_symbol_find_def_inversion; eauto. - intros (d2 & ge2_b2). unfold ge2. simpl. unfold fundef in *. rewrite ge2_b2. - exploit partial_mem_inject; eauto. intros INJ. - exploit Mem.mi_inj; eauto. intros INJ'. - assert (access : Mem.can_access_block m1 b1 (Some cp)). - { simpl. exploit same_blks1; eauto. } - assert (ge2_b2' : Genv.find_comp_of_block ge2 b2 = Some (comp_of d2)). - { unfold Genv.find_comp_of_block, ge2. simpl. unfold fundef in *. - now rewrite ge2_b2. } - exploit same_blks2; eauto. intros m2_b2. - exploit Mem.mi_own; eauto. simpl. intros ?. - congruence. - - unfold Genv.allowed_cross_call in *. - revert cross. case vf12; try easy. - simpl. intros b1 _ b2 ofs2 delta j_b1 _. - intros (id & cp' & ge1_b1 & ge1_b1' & imp & exp). - exists id, cp'. - exploit same_symb; eauto. intros (H1 & H2 & H3 & H4). simpl in *. - exploit Genv.invert_find_symbol; eauto. intros ge1_id. - exploit H2; eauto. intros (-> & ge2_id). - split; [now apply Genv.find_invert_symbol|]. - - - Admitted. - - (** Sub-invariant lemmas, mostly on injections *) - - Lemma right_mem_injection_left_step_E0_1: forall j s1 s2 s1', - right_mem_injection s j ge1 ge2 (memory_of s1) (memory_of s2) -> - s |= s1 ∈ Left -> - step1 ge1 s1 E0 s1' -> - exists j', - right_mem_injection s j' ge1 ge2 (memory_of s1') (memory_of s2). - Proof. - intros j s1 s2 s1' MEMINJ LEFT STEP. - exists j. (* FIXME: this falls back to the old form of the lemma *) - destruct MEMINJ as [DOM MEMINJ ZERO SYMB INJ BLKS]. - constructor; try assumption; - [| | eapply same_blocks_step1; eassumption]. - { (* NOTE: Essentially identical sub-cases *) - clear MEMINJ ZERO SYMB INJ BLKS. - inv STEP; try assumption. - - intros b. specialize (DOM b). - destruct Genv.invert_symbol as [id |] eqn:INVSYM. - + destruct Senv.public_symbol eqn:PUBSYM; [assumption |]. - simpl. simpl in DOM. split. - * intros j_b. destruct DOM as [DOM _]. specialize (DOM j_b). - destruct (Mem.block_compartment m b) as [cp |] eqn:COMP; - [| contradiction]. - admit. (* Easy *) - * intros RIGHT. destruct DOM as [_ DOM]. - destruct (Mem.block_compartment m' b) as [cp' |] eqn:COMP'; - [| contradiction]. - destruct (Mem.block_compartment m b) as [cp |] eqn:COMP. - -- assert (cp = cp') as <- by admit. (* Easy *) - exact (DOM RIGHT). - -- admit. (* Easy, contra on COMP and COMP' with [assign_loc] *) - + simpl. simpl in DOM. split. - * intros j_b. destruct DOM as [DOM _]. specialize (DOM j_b). - destruct (Mem.block_compartment m b) as [cp |] eqn:COMP; - [| contradiction]. - admit. (* Easy *) - * simpl. simpl in DOM. intros RIGHT. destruct DOM as [_ DOM]. - destruct (Mem.block_compartment m' b) as [cp' |] eqn:COMP'; - [| contradiction]. - destruct (Mem.block_compartment m b) as [cp |] eqn:COMP. - -- assert (cp = cp') as <- by admit. (* Easy *) - exact (DOM RIGHT). - -- admit. (* Easy, contra on COMP and COMP' with [assign_loc] *) - - intros b; specialize (DOM b). - destruct Genv.invert_symbol as [id |] eqn:INVSYM. - + admit. - + simpl. simpl in DOM. split. - * intros j_b. destruct DOM as [DOM _]. specialize (DOM j_b). - destruct (Mem.block_compartment m b) as [cp |] eqn:COMP; - [| contradiction]. - admit. (* Easy *) - * intros RIGHT. destruct DOM as [_ DOM]. - destruct (Mem.block_compartment m' b) as [cp' |] eqn:COMP'; - [| contradiction]. - destruct (Mem.block_compartment m b) as [cp |] eqn:COMP. - -- assert (cp = cp') as <- by admit. (* Easy *) - exact (DOM RIGHT). - -- admit. (* If any newly allocated [b] belongs to [comp_of ef] = [comp_of f] - (which is on the left), and since [b] belongs to [cp'] (which is - on the right), this is a contradiction. *) - - eapply same_domain_free_list; eauto. - - eapply same_domain_free_list; eauto. - - eapply same_domain_free_list; eauto. - - inv H. - intros b. specialize (DOM b). - destruct Genv.invert_symbol as [id |] eqn:INVSYM. - + destruct Senv.public_symbol eqn:PUBSYM; [assumption |]. - simpl. simpl in DOM. split. - * intros j_b. destruct DOM as [DOM _]. specialize (DOM j_b). - destruct (Mem.block_compartment m b) as [cp |] eqn:COMP; - [| contradiction]. - admit. (* Easy *) - * intros RIGHT. destruct DOM as [_ DOM]. - destruct (Mem.block_compartment m1 b) as [cp' |] eqn:COMP'; - [| contradiction]. - destruct (Mem.block_compartment m b) as [cp |] eqn:COMP. - -- assert (cp = cp') as <- by admit. (* Easy *) - exact (DOM RIGHT). - -- admit. (* Easy, contra on LEFT and RIGHT with H1 and H2 *) - + simpl. simpl in DOM. split. - * intros j_b. destruct DOM as [DOM _]. specialize (DOM j_b). - destruct (Mem.block_compartment m b) as [cp |] eqn:COMP; - [| contradiction]. - admit. (* Easy *) - * intros RIGHT. destruct DOM as [_ DOM]. - destruct (Mem.block_compartment m1 b) as [cp' |] eqn:COMP'; - [| contradiction]. - destruct (Mem.block_compartment m b) as [cp |] eqn:COMP. - -- assert (cp = cp') as <- by admit. (* Easy *) - exact (DOM RIGHT). - -- admit. (* Same as above sub-case *) - - admit. (* See [external_call] above *) - } - { clear DOM ZERO SYMB INJ BLKS. - inv STEP; try assumption. - { - inv MEMINJ. - constructor; auto. - admit. (* assign_loc *) - { intros b NOTVALID. specialize (mi_freeblocks b). simpl in *. - Search Mem.valid_block Mem.free_list. admit. - } - { intros b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 b1_b2 j_b1 j_b2 PERM1 PERM2. - specialize (mi_no_overlap b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 b1_b2 j_b1 j_b2). - simpl in *. admit. - } - admit. admit. - } - { (* New injection *) - admit. - } - eapply Mem.free_list_left_inject; eauto. - eapply Mem.free_list_left_inject; eauto. - eapply Mem.free_list_left_inject; eauto. - { admit. (* injection probably OK *) } - { (* New injection *) - admit. - } - } - Admitted. - - Lemma right_cont_injection_left_step_E0_1: forall s1 s2 s1', - right_cont_injection s (cont_of s1) (cont_of s2) -> - s |= s1 ∈ Left -> - step1 ge1 s1 E0 s1' -> - right_cont_injection s (cont_of s1') (cont_of s2). - Admitted. - - Lemma right_cont_injection_left_step_E0_2: forall s1 s2 s1', - right_cont_injection s (cont_of s1) (cont_of s2) -> - s |= s1 ∈ Left -> - step1 ge1 s1 E0 s1' -> - right_cont_injection s (cont_of s1') (cont_of s2). - Admitted. (* Symmetric *) - - (* WIP *) - Definition abstract_step_inj (j: meminj): meminj := - j. - - (** Step diagram lemmas *) - Lemma parallel_concrete: forall j s1 s2 s1' t, right_state_injection s j ge1 ge2 s1 s2 -> s |= s1 ∈ Right -> - step1 ge1 s1 t s1' -> + Clight.step1 ge1 s1 t s1' -> exists j' s2', - step1 ge2 s2 t s2' /\ + Clight.step1 ge2 s2 t s2' /\ right_state_injection s j' ge1 ge2 s1' s2'. Proof. - intros j s1 s2 s1' t rs_inj is_r1 step1. - destruct rs_inj as [? | st1 st2 _ is_r2 right_exec_inj]. + intros j s1 s2 s1' t rs_inj is_r step1. + destruct rs_inj as [? | st1 st2 is_r1 is_r2 right_exec_inj]. { (* contradiction *) destruct st1; simpl in *; congruence. } inv step1; inv right_exec_inj. + (* step_assign *) - rename m into m1. rename m' into m1'. - rename k into k1. rename e into e1. - rename le into le1. - rename a1 into lhs. rename a2 into rhs. - rename v2 into v1. rename v into v1'. - rename loc into loc1. rename ofs into ofs1. - rename H into eval_lhs1. - rename H0 into eval_rhs1. - rename H1 into cast_v1. - rename H2 into ASSIGN. - assert (f_right : s (comp_of f) = Right) by exact is_r2. exploit eval_lvalue_injection; eauto. exploit eval_expr_injection; eauto. - intros [v2 [v1_v2 eval_rhs2]] [loc2 [loc1_ofs [j_loc1 eval_lhs2]]]. + intros [v' [? ?]] [loc' [ofs' [? ?]]]. destruct_mem_inj. exploit sem_cast_inject; eauto. - intros [v2' [cast_v2 v1'_v2']]. - exploit delta_zero; eauto. intros ?; subst loc1_ofs. - rewrite Ptrofs.add_zero in *. - inv ASSIGN. - * rename H into ACCESS. - rename H0 into store_v1'. - exploit Mem.store_mapped_inject; eauto. - rewrite Z.add_0_r. - intros [m2' [store_v2' mem_inject']]. + intros [tv [? ?]]. + inv H2. + * exploit Mem.store_mapped_inject; eauto. + intros [? [? ?]]. + exploit delta_zero; eauto. intros ?; subst. + rewrite Z.add_0_r in *. exists j; eexists; split. - econstructor; eauto. econstructor; eauto. + rewrite Ptrofs.add_zero; eauto. - apply RightControl; eauto. constructor; eauto. split; eauto. - ++ unfold same_domain in *. - intros b. specialize same_dom with b. - enough (((s, m1') |= b ∈ Right) = ((s, m1) |= b ∈ Right)) - as -> by easy. - unfold Mem.has_side_block. simpl. - erewrite Mem.store_block_compartment; eauto. - ++ unfold same_blocks in *. - intros b cp b_cp. - specialize (SAMEBLKS b cp b_cp). - erewrite Mem.store_block_compartment; eauto. - ++ unfold same_blocks in *. - intros b cp b_cp. - specialize (same_blks3 b cp b_cp). - erewrite Mem.store_block_compartment; eauto. - * rename b' into b1'. rename ofs' into ofs1'. - rename H into ACCESS. - rename H0 into align_lhs1'. - rename H1 into align_lhs1. - rename H2 into sizes1. - rename H3 into load_b1'. - rename H4 into store_loc1. - inv v1'_v2'. - rename b2 into b2'. rename H1 into j_b1'. - rename bytes into bytes1. - exploit delta_zero; try exact j_b1'; eauto. intros ?; subst delta. + clear -same_dom H10. + unfold Mem.same_domain in *. + intros. + unfold in_side in *; simpl in *. + erewrite Mem.store_block_compartment; eauto. + * inv H8. exploit Mem.loadbytes_inj; eauto using Mem.mi_inj. - rewrite Z.add_0_r. - intros [bytes2 [load_b2' MVALINJ]]. + intros [? [? ?]]. exploit Mem.storebytes_mapped_inject; eauto using Mem.mi_inj. - rewrite Z.add_0_r. - intros [m2' [store_loc2 mem_inject']]. + intros [? [? ?]]. + exploit delta_zero; eauto; intros; subst. + exploit (delta_zero loc); eauto; intros; subst. exists j; eexists; split. - econstructor; eauto. - rewrite genv_cenv_preserved in *. - eapply assign_loc_copy; try rewrite Ptrofs.add_zero; eauto. - { destruct sizes1. + rewrite <- same_cenv, !Z.add_0_r, !Ptrofs.add_zero in *; eauto. + eapply assign_loc_copy; eauto. + { destruct H15. - exploit injective; eauto. intros []; [now left| contradiction]. - auto. } - apply RightControl; eauto. constructor; eauto. split; eauto. - ++ clear -same_dom store_loc1. - unfold same_domain in *. - intros b. - unfold in_side in *; simpl in *. - erewrite Mem.storebytes_block_compartment; eauto. - exact (same_dom b). - ++ eapply same_blocks_storebytes; eauto. - ++ eapply same_blocks_storebytes; eauto. - * inv H. + clear -same_dom H17. + unfold Mem.same_domain in *. + intros. + unfold in_side in *; simpl in *. + erewrite Mem.storebytes_block_compartment; eauto. + * inv H9. exploit Mem.load_inject; eauto using Mem.mi_inj. intros [? [? ?]]. exploit Mem.store_mapped_inject; eauto. intros [? [? ?]]. - inv H8. + inv H16. exploit delta_zero; eauto; intros; subst. rewrite Z.add_0_r in *. exists j; eexists; split. - econstructor; eauto. - eapply assign_loc_bitfield. rewrite <- H0. inv H4. inv v1'_v2'. + rewrite Ptrofs.add_zero. + eapply assign_loc_bitfield. rewrite <- H2. inv H8. econstructor; eauto. - apply RightControl; eauto. constructor; eauto. split; eauto. - ++ clear -same_dom H6. - unfold same_domain in *. - intros b. - unfold in_side in *; simpl in *. - erewrite Mem.store_block_compartment; eauto. - exact (same_dom b). - ++ now constructor. - ++ eapply same_blocks_store; eauto. - ++ eapply same_blocks_store; eauto. + clear -same_dom H18. + unfold Mem.same_domain in *. + intros. + unfold in_side in *; simpl in *. + erewrite Mem.store_block_compartment; eauto. + (* step_set *) exploit eval_expr_injection; eauto. - auto. intros [v' [? ?]]. exists j; eexists; split. * econstructor; eauto. @@ -1146,145 +538,36 @@ Qed. destruct (peq i id); eauto. inv H2; subst. eexists; split; eauto. + (* step_call *) - rename m into m1. - rename k into k1. - rename e into e1. - rename le into le1. - rename vf into vf1. rename fd into fd1. - rename vargs into vargs1. - rename H into a_type. - rename H0 into eval_a1. - rename H1 into eval_vargs1. - rename H2 into find_vf1. - rename H3 into type_fd1. - rename ALLOWED into ALLOWED1. - rename NO_CROSS_PTR into NO_CROSS_PTR1. - rename EV into EV1. - assert (Genv.find_comp ge1 vf1 = Some (comp_of fd1)) as comp_vf1. - { now apply Genv.find_funct_find_comp. } - exploit eval_expr_injection; eauto; eauto. - intros [vf2 [vf1_vf2 eval_a2]]. - exploit eval_exprlist_injection; eauto; eauto. - intros [vargs2 [vargs1_vargs2 eval_vargs2]]. - destruct (s (comp_of fd1)) eqn:s_fd1. - * (* Next function is on the left *) - assert (CROSS1 : Genv.allowed_cross_call ge1 (comp_of f) vf1). - { destruct ALLOWED1 as [CONTRA|CROSS1]; trivial. - rewrite (Genv.find_funct_find_comp _ _ find_vf1) in CONTRA. - congruence. } - destruct (Genv.allowed_cross_call_public_symbol - _ _ _ CROSS1) - as (id & b1 & off1 & evf1 & ge1_id & pub_id1). - assert (off1 = Ptrofs.zero /\ Genv.find_def ge1 b1 = Some (Gfun fd1)) - as [-> find_vf1']. - { rewrite evf1 in find_vf1. simpl in find_vf1. - destruct Ptrofs.eq_dec as [->|_]; try easy. - split; trivial. - unfold Genv.find_funct_ptr in find_vf1. - unfold ge1. simpl. - destruct (Genv.find_def _ b1) as [def1|]; try easy. - destruct def1 as [fd1'|?]; try easy. - now injection find_vf1 as ->. } - exploit (@match_prog_globdefs _ _ _ match_W1_W2 id (comp_of fd1)); eauto. - { left. - unfold Genv.find_comp_of_ident. - rewrite ge1_id. - unfold Genv.find_comp_of_block. now rewrite find_vf1'. } - intros (b1' & b2 & ge1_id' & ge2_id & match_fd). - assert (b1' = b1) as -> by congruence. clear ge1_id'. - rewrite find_vf1', s_fd1 in match_fd. - simpl in match_fd. - assert (exists def2, - Genv.find_def ge2 b2 = Some def2 /\ - match_globdef (Gfun fd1) def2) - as (def2 & ge2_b2 & match_fd'). - { inv match_fd. eauto. } - assert (exists fd2, - def2 = Gfun fd2 /\ - match_fundef tt fd1 fd2) - as (fd2 & -> & match_fd''). - { inv match_fd'. eauto. } - assert (vf2 = Vptr b2 Ptrofs.zero) as evf2. - { exploit same_symb; eauto. intros (_ & _ & INJ & _). - destruct (INJ _ _ pub_id1 ge1_id) as (b2' & j_b1 & ge2_id'). - assert (b2' = b2) as -> by (simpl in *; congruence). - inv vf1_vf2; try congruence. - match goal with - | [ _ : j b1 = Some (b2, 0), - H1 : j ?b1' = Some (?b2', ?delta), - H2 : Vptr _ ?ofs1 = Vptr b1 _ |- _ ] - => assert (b1' = b1) as -> by congruence; - assert (ofs1 = Ptrofs.zero) as -> by congruence; - assert (b2' = b2) as -> by congruence; - assert (delta = 0) as -> by congruence; - clear H1 H2 - end. - now rewrite Ptrofs.add_zero. } - assert (Genv.find_funct ge2 vf2 = Some fd2) as find_vf2'. - { unfold Genv.find_funct, Genv.find_funct_ptr. rewrite evf2. - destruct Ptrofs.eq_dec as [_|?]; try congruence. - now rewrite ge2_b2. } - assert (type_of_fundef fd2 = Tfunction tyargs tyres cconv) - as type_fd2. - { inv match_fd''; eauto. } - assert (Genv.allowed_call ge2 (comp_of f) vf2) as ALLOWED2. - { right. rewrite evf2. simpl. exists id, (comp_of fd2). - split. - { now apply Genv.find_invert_symbol. } - (* unfold Genv.find_comp. rewrite <- evf2. unfold ge2 in find_vf2'. *) - (* simpl in find_vf2'. rewrite find_vf2'. split; trivial. *) - admit. - } - - exists j, (Callstate fd2 vargs2 (Kcall optid f e2 le2 k2) m2). - (* split. *) - (* econstructor; eauto. *) - admit. - * rename fd1 into fd. - rename type_fd1 into type_fd. - (* rewrite comp_vf1 in *. *) - exploit find_funct_preserved; eauto. - { eapply same_symb; eauto. } - intros find_vf2. - (* assert (Genv.find_comp ge2 vf2 = comp_of fd) as comp_vf2. *) - (* { unfold Genv.find_comp. now rewrite find_vf2. } *) - assert (Genv.allowed_call ge2 (comp_of f) vf2) as ALLOWED2. - { admit. } - exists j. - exists (Callstate fd vargs2 (Kcall optid f e2 le2 k2) m2). - split. - { econstructor; eauto. - - admit. - - admit. } - apply RightControl; trivial. - constructor; trivial. - now apply right_cont_injection_kcall_right. - (* Stopped here... *) - (* assert (vf = v') by admit. subst v'. *) - (* exists j; eexists; split. *) - (* * econstructor; eauto. *) - (* - inv match_fd'; eauto. *) - (* - exploit (Genv.match_genvs_allowed_calls match_W1_W2); eauto. *) - (* - eapply (Genv.match_genvs_not_ptr_list_inj); eauto. *) - (* exploit (Genv.match_genvs_find_comp match_W1_W2); eauto. intros <-. *) - (* erewrite <- (Genv.match_genvs_type_of_call); eauto. *) - (* - exploit (Genv.match_genvs_find_comp match_W1_W2); eauto. intros <-. *) - (* exploit (@call_trace_inj _ _ _ _ ge1 ge2); eauto. *) - (* simpl. apply Genv.globalenvs_match in match_W1_W2. *) - (* intros sy. pose proof (Genv.mge_symb match_W1_W2 sy). unfold Genv.find_symbol; eauto. *) - (* * (* Case analysis: are we changing side or not? *) *) - (* destruct (s (comp_of fd)) eqn:side. *) - (* - apply LeftControl; eauto; try now inv match_fd'; auto. *) - (* simpl. apply right_cont_injection_kcall_right; eauto. *) - (* - inv match_fd'; unfold in_side in *; simpl in *; *) - (* unfold comp_of in *; simpl in side; unfold comp_of in *; simpl in side; *) - (* try congruence. *) - (* apply RightControl; eauto. *) - (* constructor; eauto. *) - (* simpl. apply right_cont_injection_kcall_right; eauto. *) + exploit eval_expr_injection; eauto. + intros [v' [? ?]]. + exploit eval_exprlist_injection; eauto. + intros [vs' [? ?]]. + exploit (Genv.find_funct_match match_W1_W2); eauto. + intros [? [fd' [find_fd' [match_fd' _]]]]. + assert (vf = v') by admit. subst v'. + exists j; eexists; split. + * econstructor; eauto. + - inv match_fd'; eauto. + - exploit (Genv.match_genvs_allowed_calls match_W1_W2); eauto. + - eapply (Genv.match_genvs_not_ptr_list_inj); eauto. + exploit (Genv.match_genvs_find_comp match_W1_W2); eauto. intros <-. + erewrite <- (Genv.match_genvs_type_of_call); eauto. + - exploit (Genv.match_genvs_find_comp match_W1_W2); eauto. intros <-. + exploit (@call_trace_inj _ _ _ _ ge1 ge2); eauto. + unfold ge2, ge1. simpl. apply Genv.globalenvs_match in match_W1_W2. + intros sy. pose proof (Genv.mge_symb match_W1_W2 sy). unfold Genv.find_symbol; eauto. + * (* Case analysis: are we changing side or not? *) + destruct (s (comp_of fd)) eqn:side. + - apply LeftControl; eauto; try now inv match_fd'; auto. + simpl. apply right_cont_injection_kcall_right; eauto. + - inv match_fd'; unfold in_side in *; simpl in *; + unfold comp_of in *; simpl in side; unfold comp_of in *; simpl in side; + try congruence. + apply RightControl; eauto. + constructor; eauto. + simpl. apply right_cont_injection_kcall_right; eauto. + (* step_builtin *) exploit eval_exprlist_injection; eauto. - auto. intros [vs' [? ?]]. exploit ec_mem_inject; eauto. admit. admit. admit. intros [j' [? [? [? [? [? [? [? [? ?]]]]]]]]]. @@ -1297,41 +580,36 @@ Qed. - admit. - admit. - admit. - - admit. - - admit. - * admit. - (* destruct H10. *) - (* split. intros ? ? ? ?. *) - (* exploit H10; eauto. intros [b' [? ?]]. *) - (* exists b'; split; eauto. *) - (* intros ? ?. *) - (* exploit H14; eauto. *) + * destruct H10. + split. intros ? ? ? ?. + exploit H10; eauto. intros [b' [? ?]]. + exists b'; split; eauto. + intros ? ?. + exploit H14; eauto. * intros ? ? ?. - admit. - (* destruct optid. *) - (* - simpl in *. rewrite PTree.gsspec in *. *) - (* destruct (peq i i0); subst. *) - (* inv H14. eexists; split; eauto. *) - (* exploit H11; eauto. intros [? [? ?]]; eauto. *) - (* - exploit H11; eauto. intros [? [? ?]]; eauto. *) + destruct optid. + - simpl in *. rewrite PTree.gsspec in *. + destruct (peq i i0); subst. + inv H14. eexists; split; eauto. + exploit H11; eauto. intros [? [? ?]]; eauto. + - exploit H11; eauto. intros [? [? ?]]; eauto. + (* step_seq*) exists j; eexists; split; [constructor | apply RightControl]; auto. constructor; auto. constructor; auto. + (* step_skip_seq *) - inv RCONTINJ. + inv H7. exists j; eexists; split; [constructor | apply RightControl]; auto. constructor; auto. + (* step_continue_seq *) - inv RCONTINJ. + inv H7. exists j; eexists; split; [constructor | apply RightControl]; auto. constructor; auto. + (* step_break_seq *) - inv RCONTINJ. + inv H7. exists j; eexists; split; [constructor | apply RightControl]; auto. constructor; auto. + (* step_ifthenelse *) exploit eval_expr_injection; eauto. - admit. intros [v' [? ?]]. destruct_mem_inj. exploit bool_val_inject; eauto. intros ?. @@ -1341,16 +619,16 @@ Qed. exists j; eexists; split; [econstructor | apply RightControl]; eauto. constructor; auto. constructor; auto. + (* step_skip_or_continue_loop1 *) - inv RCONTINJ. exists j; eexists; split; [constructor | apply RightControl]; eauto. + inv H8. exists j; eexists; split; [constructor | apply RightControl]; eauto. constructor; auto. constructor; auto. + (* step_break_loop1 *) - inv RCONTINJ. exists j; eexists; split; [apply step_break_loop1 | apply RightControl]; eauto. + inv H7. exists j; eexists; split; [apply step_break_loop1 | apply RightControl]; eauto. constructor; auto. + (* step_skip_loop2 *) - inv RCONTINJ. exists j; eexists; split; [apply step_skip_loop2 | apply RightControl]; eauto. + inv H7. exists j; eexists; split; [apply step_skip_loop2 | apply RightControl]; eauto. constructor; auto. + (* step_break_loop2 *) - inv RCONTINJ. exists j; eexists; split; [apply step_break_loop2 | apply RightControl]; eauto. + inv H7. exists j; eexists; split; [apply step_break_loop2 | apply RightControl]; eauto. constructor; auto. + (* step_return_0 *) admit. @@ -1360,7 +638,6 @@ Qed. admit. + (* step_switch *) exploit eval_expr_injection; eauto. - admit. intros [v' [? ?]]. assert (sem_switch_arg v (typeof a) = Some n -> sem_switch_arg v' (typeof a) = Some n). { intros. unfold sem_switch_arg in *. @@ -1369,10 +646,10 @@ Qed. constructor; auto. constructor; auto. + (* step_break_switch *) - inv RCONTINJ. exists j; eexists; split; [constructor | apply RightControl]; eauto. + inv H8. exists j; eexists; split; [constructor | apply RightControl]; eauto. constructor; auto. + (* step_continue_switch *) - inv RCONTINJ. exists j; eexists; split; [apply step_continue_switch | apply RightControl]; eauto. + inv H7. exists j; eexists; split; [apply step_continue_switch | apply RightControl]; eauto. constructor; auto. + (* step_label *) exists j; eexists; split; [constructor | apply RightControl]; auto. @@ -1410,558 +687,52 @@ Qed. (* execution 2: call first: x = 0 we take the else branch *) *) - Lemma parallel_concrete_E0: forall j s1 s2 s1' s2' t, - right_state_injection s j ge1 ge2 s1 s2 -> - s |= s1 ∈ Right -> (* in the context *) - step1 ge1 s1 E0 s1' -> - step1 ge2 s2 t s2' -> - exists j', - t = E0 /\ right_state_injection s j' ge1 ge2 s1' s2'. - Proof. - intros j s1 s2 s1' s2' t INJ RIGHT STEP1 STEP2. - exploit parallel_concrete; eauto. - intros [j' [s2'' [STEP2' INJ']]]. - destruct t as [| e [| e' t]]. - - destruct (step1_E0_determ STEP2 STEP2'). - eauto. - - exfalso. eapply step1_E0_event_False; eassumption. - - apply (sr_traces (semantics_receptive _)) in STEP2. - inv STEP2. inv H0. - Qed. - (* Can get rid of uses of this? *) - Lemma parallel_concrete_E0': forall j s1 s2 s1' s2' t, - right_state_injection s j ge1 ge2 s1 s2 -> - s |= s1 ∈ Right -> (* in the context *) - step1 ge2 s2 E0 s2' -> - step1 ge1 s1 t s1' -> - exists j', - t = E0 /\ right_state_injection s j' ge1 ge2 s1' s2'. + Lemma parallel_concrete_E0: forall s1 s2 s1' s2' t, + right_state_injection s j s1 s2 -> + is_right s s1 -> (* in the context *) + Csem.step ge1 s1 E0 s1' -> + Csem.step ge2 s2 t s2' -> + t = E0 /\ right_state_injection s j s1' s2'. + Proof. + intros. + exploit parallel_concrete; eauto. + intros [? [? ?]]. + assert (t = E0 /\ s2' = x). + { clear -H2 H3. + inv H2; inv H3. + - admit. + - inv H; inv H0; eauto. + } + (* rely on determinacy lemma with empty traces? *) Admitted. - Lemma parallel_abstract_E0_1: forall j s1 s2 s1', - right_state_injection s j ge1 ge2 s1 s2 -> - s |= s1 ∈ Left -> - step1 ge1 s1 E0 s1' -> - exists j', - right_state_injection s j' ge1 ge2 s1' s2. - Proof. - intros j s1 s2 s1' INJ LEFT STEP. - inversion INJ as [? ? SIDE1 SIDE2 MEMINJ CONTINJ |]; subst; clear INJ; - [| exfalso; eapply state_split_contra; eassumption]. - apply (step_E0_same_side STEP) in LEFT. - exploit right_mem_injection_left_step_E0_1; eauto. intros [j' MEMINJ']. - exploit right_cont_injection_left_step_E0_1; eauto. intros CONTINJ'. - exists j'. constructor; assumption. - Qed. - - Lemma parallel_abstract_E0_2: forall j s1 s2 s2', - right_state_injection s j ge1 ge2 s1 s2 -> - s |= s1 ∈ Left -> - step1 ge2 s2 E0 s2' -> - exists j', - right_state_injection s j' ge1 ge2 s1 s2'. - Admitted. (* Symmetric *) - - (* NOTE: Currently unused by proofs below (useful for E0 star?) *) - (* Lemma parallel_abstract_E0: forall j s1 s2 s1' s2', *) - (* right_state_injection s j ge1 ge2 s1 s2 -> *) - (* s |= s1 ∈ Left -> *) - (* step1 ge1 s1 E0 s1' -> *) - (* step1 ge2 s2 E0 s2' -> *) - (* right_state_injection s j ge1 ge2 s1' s2'. *) - (* Proof. *) - (* intros s1 s2 s1' t rs_inj is_l step1. *) - (* (* inv rs_inj. *) *) - (* (* - admit. *) *) - (* (* - admit. (* contradiction *) *) *) - (* admit. *) - (* Admitted. *) - - Lemma parallel_abstract_t: forall j s1 s2 s1' s2' t, - right_state_injection s j ge1 ge2 s1 s2 -> - s |= s1 ∈ Left -> - step1 ge1 s1 t s1' -> - step1 ge2 s2 t s2' -> - exists j', - right_state_injection s j' ge1 ge2 s1' s2'. + Lemma parallel_abstract_E0: forall s1 s2 s1' s2', + right_state_injection s j s1 s2 -> + is_left s s1 -> + Csem.step ge1 s1 E0 s1' -> + Csem.step ge2 s2 E0 s2' -> + right_state_injection s j s1' s2'. + Proof. + intros s1 s2 s1' t rs_inj is_l step1. + inv rs_inj. + - admit. + - admit. (* contradiction *) Admitted. -(* Lemma parallel_concrete p1 p2 scs1 scs2: *) -(* left_side s p1 -> (* use definitions from RSC.v *) *) -(* left_side s p2 -> (* use definitions from RSC.v *) *) -(* partial_state_equivalent s scs1 scs2 -> (* to define --> using memory injections? *) *) -(* pc_in_left_part scs1 -> (* to define *) *) -(* CS.kstep (prepare_global_env (program_link p p1)) scs1 t scs1' -> (* use step of Csem instead *) *) -(* exists2 scs2', *) -(* CS.kstep (prepare_global_env (program_link p p2)) scs2 t scs2' /\ (* use step of Csem instead *) *) -(* partial_state_equivalent s scs1' scs2'. (* to define *) *) - -Definition comp_of_event_or_default (e: event) (cp: compartment) := - match e with - | Event_syscall _ _ _ => cp - | Event_vload _ _ _ _ => cp - | Event_vstore _ _ _ _ => cp - | Event_annot _ _ => cp - | Event_call _ cp' _ _ => cp' - | Event_return _ cp' _ => cp' - end. - -Fixpoint last_comp_in_trace' (t: trace) (cp: compartment): compartment := - match t with - | nil => cp - | e :: t' => last_comp_in_trace' t' (comp_of_event_or_default e cp) - end. - -Definition last_comp_in_trace (t: trace): compartment := - last_comp_in_trace' t default_compartment. - -Definition blame_on_program (t: trace) := - s (last_comp_in_trace t) = Left. - -(** Traces and prefixes *) - -Inductive finpref_behavior : Type := - | FTerminates (t: trace) (n: int) - | FGoes_wrong (t: trace) - | FTbc (t: trace). - -Definition not_wrong_finpref (m:finpref_behavior) : Prop := - match m with - | FGoes_wrong _ => False - | _ => True - end. - -Definition prefix (m:finpref_behavior) (b:program_behavior) : Prop := - match m, b with - | FTerminates t1 n1, Terminates t2 n2 => n1 = n2 /\ t1 = t2 - | FGoes_wrong t1, Goes_wrong t2 => t1 = t2 - | FTbc t1, b => behavior_prefix t1 b - | _, _ => False - end. - -Definition finpref_trace (m : finpref_behavior) : trace := - match m with - | FTerminates t _ | FGoes_wrong t | FTbc t => t - end. - -Definition trace_finpref_prefix (t : trace) (m : finpref_behavior) : Prop := - match m with - | FTerminates t' _ | FGoes_wrong t' | FTbc t' => trace_prefix t t' - end. - -Definition finpref_trace_prefix (m : finpref_behavior) (t : trace) : Prop := - match m with - | FTerminates _ t' | FGoes_wrong t' => False - | FTbc t' => trace_prefix t' t - end. - -Definition behavior_improves_finpref (b:program_behavior) (m:finpref_behavior) := - exists t, b = Goes_wrong t /\ trace_finpref_prefix t m. - -Definition does_prefix (L: semantics) (m: finpref_behavior) : Prop := - exists b, program_behaves L b /\ prefix m b. - -(** Standard blame proof components *) - -(* parallel_concrete' goes away *) - -Lemma parallel_concrete_star_E0: forall {j s1 s1' s1'' s2 s2' s2'' e}, - right_state_injection s j ge1 ge2 s1 s2 -> - s |= s1 ∈ Right -> - Star (semantics1 W1) s1 E0 s1' -> - Step (semantics1 W1) s1' (e :: nil) s1'' -> - Star (semantics1 W2) s2 E0 s2' -> - Step (semantics1 W2) s2' (e :: nil) s2'' -> -exists j', - right_state_injection s j' ge1 ge2 s1' s2'. -Proof. - intros j s1 s1' s1'' s2 s2' s2'' e INJ RIGHT STAR1. - revert j s1'' s2 s2' s2'' e INJ RIGHT. - remember E0 as t eqn:SILENT. revert SILENT. - induction STAR1 as [s1' | s1 t1 s1' t2 s1'' ? STEP1 STAR1 IH SILENT]. - - intros _ j s1'' s2 s2' s2'' e INJ RIGHT STEP1 STAR2 STEP2. - revert s1' j s1'' s2'' e INJ RIGHT STEP1 STEP2. - remember E0 as t eqn:SILENT. revert SILENT. - induction STAR2 as [s2' | s2 t1 s2' t2 s2'' ? STEP2 STAR2 IH SILENT]; - [now eauto |]. - intros -> s1' j s1'' s2''' e INJ RIGHT STEP1 STEP2'. - symmetry in SILENT. apply Eapp_E0_inv in SILENT as [-> ->]. - destruct (parallel_concrete_E0' _ _ _ _ _ _ INJ RIGHT STEP2 STEP1) - as (_ & CONTRA & _). - discriminate. - - intros -> j s1''' s2 s2' s2'' e INJ RIGHT STEP1' STAR2 STEP2. - symmetry in SILENT. apply Eapp_E0_inv in SILENT as [-> ->]. - remember E0 as t eqn:SILENT. - revert SILENT j s1 s1' s1'' STEP1 STAR1 IH s1''' s2'' e INJ RIGHT STEP1' STEP2. - induction STAR2 as [s2' | s2 t1 s2' t2 s2'' ? STEP2 STAR2 IH' SILENT]. - + intros _ j s1 s1' s1'' STEP1 STAR1 IH s1''' s2'' e INJ RIGHT STEP1' STEP2. - destruct (parallel_concrete_E0 _ _ _ _ _ _ INJ RIGHT STEP1 STEP2) - as (_ & CONTRA & _). - discriminate. - + intros -> j s1 s1' s1'' STEP1 STAR1 IH s1''' s2''' e INJ RIGHT STEP1' STEP2'. - symmetry in SILENT. apply Eapp_E0_inv in SILENT as [-> ->]. - destruct (parallel_concrete_E0 _ _ _ _ _ _ INJ RIGHT STEP1 STEP2) - as (j' & _ & INJ'). - apply (step_E0_same_side STEP1) in RIGHT. - exact (IH eq_refl - _ _ _ _ _ _ - INJ' RIGHT STEP1' STAR2 STEP2'). -Qed. - -Lemma parallel_abstract_star_E0: forall {j s1 s1' s1'' s2 s2' s2'' e}, - right_state_injection s j ge1 ge2 s1 s2 -> - s |= s1 ∈ Left -> - Star (semantics1 W1) s1 E0 s1' -> - Step (semantics1 W1) s1' (e :: nil) s1'' -> - Star (semantics1 W2) s2 E0 s2' -> - Step (semantics1 W2) s2' (e :: nil) s2'' -> -exists j', - right_state_injection s j' ge1 ge2 s1' s2'. -Proof. - intros j s1 s1' s1'' s2 s2' s2'' e INJ LEFT STAR1. - revert j s1'' s2 s2' s2'' e INJ LEFT. - remember E0 as t eqn:SILENT. revert SILENT. - induction STAR1 as [s1' | s1 t1 s1' t2 s1'' ? STEP1 STAR1 IH SILENT]. - - intros _ j s1'' s2 s2' s2'' e INJ LEFT STEP1 STAR2 STEP2. - revert s1' j s1'' s2'' e INJ LEFT STEP1 STEP2. - remember E0 as t eqn:SILENT. revert SILENT. - induction STAR2 as [s2' | s2 t1 s2' t2 s2'' ? STEP2 STAR2 IH SILENT]; - [now eauto |]. - intros -> s1' j s1'' s2''' e INJ LEFT STEP1 STEP2'. - symmetry in SILENT. apply Eapp_E0_inv in SILENT as [-> ->]. - exploit parallel_abstract_E0_2; eauto. intros [j' INJ']. - now eapply IH; eauto. - - intros -> j s1''' s2 s2' s2'' e INJ LEFT STEP1' STAR2 STEP2. - symmetry in SILENT. apply Eapp_E0_inv in SILENT as [-> ->]. - remember E0 as t eqn:SILENT. - revert SILENT j s1''' s2'' e INJ LEFT STEP1' STEP2. - induction STAR2 as [s2' | s2 t1 s2' t2 s2'' ? STEP2 STAR2 IH' SILENT]. - + intros _ j s1''' s2'' e INJ LEFT STEP1' STEP2. - assert (exists j', right_state_injection s j' ge1 ge2 s1' s2') - as [j' INJ'] by (eapply parallel_abstract_E0_1; eauto). - apply (step_E0_same_side STEP1) in LEFT. - exact (IH eq_refl _ _ _ _ _ _ - INJ' LEFT STEP1' (star_refl _ _ _) STEP2). - + intros -> j s1''' s2''' e INJ LEFT STEP1' STEP2'. - symmetry in SILENT. apply Eapp_E0_inv in SILENT as [-> ->]. - assert (exists j', right_state_injection s j' ge1 ge2 s1 s2') - as [j' INJ'] by (eapply parallel_abstract_E0_2; eauto). - exact (IH' - STEP1 STAR1 IH eq_refl - _ _ _ _ - INJ' LEFT STEP1' STEP2'). -Qed. - -(* Related to old [context_epsilon_star_is_silent'] *) -Lemma parallel_star_E0: forall {j s1 s1' s1'' s2 s2' s2'' e}, - right_state_injection s j ge1 ge2 s1 s2 -> - Star (semantics1 W1) s1 E0 s1' -> - Step (semantics1 W1) s1' (e :: nil) s1'' -> - Star (semantics1 W2) s2 E0 s2' -> - Step (semantics1 W2) s2' (e :: nil) s2'' -> -exists j', - right_state_injection s j' ge1 ge2 s1' s2'. -Proof. - intros j s1. - destruct (state_split_decidable s1) as [LEFT | RIGHT]. - - intros; eapply parallel_abstract_star_E0; eassumption. - - intros; eapply parallel_concrete_star_E0; eassumption. -Qed. - -(* Lemma state_determinism': forall {p s s1 s2 e1 e2}, *) -(* step1 (globalenv p) s (e1 :: nil) s1 -> *) -(* step1 (globalenv p) s (e2 :: nil) s2 -> *) -(* e1 = e2 /\ s1 = s2. *) - -(* - [scs] naming scheme no longer makes sense, retooled - - No need for [s |= s1 ∈ Left] type assumption *) -Lemma parallel_exec1: forall j s1 s2 s1'' s2'' t t1 t2, - right_state_injection s j ge1 ge2 s1 s2 -> - Star (semantics1 W1) s1 (t ** t1) s1'' -> - Star (semantics1 W2) s2 (t ** t2) s2'' -> - exists s1' s2' j', - Star (semantics1 W1) s1 t s1' /\ - Star (semantics1 W2) s2 t s2' /\ - Star (semantics1 W1) s1' t1 s1'' /\ - Star (semantics1 W2) s2' t2 s2'' /\ - right_state_injection s j' ge1 ge2 s1' s2'. -Proof. - intros j s1 s2 s1'' s2'' t; revert j s1 s2 s1'' s2''. - induction t as [| e t IH]; - intros j s1 s2 s1'' s2'' t1 t2 RINJ STAR1 STAR2; - (* Base case: follows trivially from the assumptions *) - [do 3 eexists; now eauto using star_refl |]. - (* Inductive case *) - destruct (star_cons_inv (sr_traces (semantics_receptive _)) STAR1) - as (s1_1 & s1_2 & STAR1_1 & STEP1_2 & STAR1_3). - change (_ t t1) with (t ** t1) in STAR1_3. clear STAR1. - destruct (star_cons_inv (sr_traces (semantics_receptive _)) STAR2) - as (s2_1 & s2_2 & STAR2_1 & STEP2_2 & STAR2_3). - change (_ t t2) with (t ** t2) in STAR2_3. clear STAR2. - pose proof parallel_star_E0 RINJ STAR1_1 STEP1_2 STAR2_1 STEP2_2 as [j' RINJ']. - assert (exists j', right_state_injection s j' ge1 ge2 s1_2 s2_2) - as [j'' RINJ'']. { (* This can be made into a helper lemma *) - destruct (state_split_decidable s1_1) as [LEFT | RIGHT]. - - exploit parallel_abstract_t; eauto. - - exploit parallel_concrete; eauto. intros (j'' & s2_2' & STEP2_2' & RINJ''). - assert (s2_2 = s2_2') as <- - by exact (step1_event_determ STEP2_2 STEP2_2'). - now eauto. } - destruct (IH _ _ _ _ _ _ _ RINJ'' STAR1_3 STAR2_3) - as (s1' & s2' & j''' & STAR1_3_1 & STAR2_3_1 & STAR1_3_2 & STAR2_3_2 & RINJ'''). - assert (STAR1' := star_trans - (star_trans STAR1_1 (star_one _ _ _ _ _ STEP1_2) eq_refl) - STAR1_3_1 eq_refl). - assert (STAR2' := star_trans - (star_trans STAR2_1 (star_one _ _ _ _ _ STEP2_2) eq_refl) - STAR2_3_1 eq_refl). - now eauto 8. -Qed. - -Lemma parallel_exec j s1 s1' s2 s2' n t t': - right_state_injection s j ge1 ge2 s1 s2 -> - Star (semantics1 W1) s1 (t ** t') s1' -> - Star (semantics1 W2) s2 t s2' -> - Nostep (semantics1 W2) s2' -> - Smallstep.final_state (semantics1 W1) s1' n -> - s |= s2' ∈ Right -> - Smallstep.final_state (semantics1 W2) s2' n. -Proof. - rewrite <- (E0_right t) at 2. - intros part star1 star2. - exploit parallel_exec1; eauto. - clear j star1 star2 part. intros (s1'' & s2'' & (j' & _ & _ & star1 & star2 & part)). - clear s1 s2 t. rename s1'' into s1. rename s2'' into s2. rename j' into j. - intros nostep2 final1 in_prog. - apply (star_E0_same_side star2) in in_prog. - revert j s2 part star2 nostep2 final1 in_prog. - induction star1 as [s1 | s1 t1 s1' t2 s1'' t step1 _ IH]. - - intros j s2 part star2 nostep2 final1 in_prog. - assert (final2: Smallstep.final_state (semantics1 W2) s2 n). { - inv part. - - exfalso. eapply state_split_contra; now eauto. - - inv final1. - inv H1. inv RCONTINJ. inv RVALINJ. - inv star2. - + now constructor. - + now inv H1. } - inv final2. - inv star2. - + now constructor. - + now inv H. - - intros j s2 part star2 nostep2 final1 in_prog2. - pose proof right_state_injection_same_side_left part in_prog2 as in_prog1. - pose proof parallel_concrete _ _ _ _ _ part in_prog1 step1 as pc. - revert part nostep2 in_prog2 IH pc. - elim star2 using star_E0_ind'; clear s2 s2' star2. - + intros s2 _ nostep2 _ _ (_ & s2' & step2 & _). - apply nostep2 in step2. contradiction. - + intros s2 s21' s2'' step21 star2 ? part nostep2 in_prog2 IH (j' & s22' & step22 & part'). - apply (star_E0_same_side (star_one _ _ _ _ _ step21)) in in_prog2. - assert (s21' = s22') as <-. { - destruct t1 as [| e1 [| e1' t1]]. - - exact (step1_E0_determ step21 step22). - - now destruct (step1_E0_event_False step21 step22). - - apply (sr_traces (semantics_receptive _)) in step22. - inv step22. now inv H2. } - clear step21 step22. - exact (IH _ _ part' star2 nostep2 final1 in_prog2). -Qed. - -Lemma parallel_exec' j s1 s1' s2 s2' t e t': - right_state_injection s j ge1 ge2 s1 s2 -> - Star (semantics1 W1) s1 (t ** e :: t') s1' -> - Star (semantics1 W2) s2 t s2' -> - Nostep (semantics1 W2) s2' -> - s |= s2' ∈ Left. -Proof. - rewrite <- (E0_right t) at 2. - intros part star1 star2. - exploit parallel_exec1; eauto. - clear j star1 star2 part. - intros (s1'' & s2'' & (j' & _ & _ & star1 & star2 & part)) nostep2. - clear s1 s2 t. rename s1'' into s1. rename s2'' into s2. rename j' into j. - apply (star_E0_same_side star2). - destruct (state_split_decidable s2) as [in_prog2 | in_prog2]; - [exact in_prog2 |]. - exfalso. - destruct (star_cons_inv (sr_traces (semantics_receptive _)) star1) - as (s1a & s1b & star1a & step1b & _). - clear star1. - revert j s1 star1a part nostep2 in_prog2. elim star2 using star_E0_ind'; - clear s2 s2' star2. - - intros s2 j s1 star1a. - assert (exists t s1a', Step (semantics1 W1) s1 t s1a') as (t & s1a' & step). { - revert step1b. elim star1a using star_E0_ind'; now eauto. } - intros part nostep2 in_prog2. - apply (right_state_injection_same_side_left part) in in_prog2. - exploit parallel_concrete; eauto. intros (j' & s2' & step2 & part'). - specialize (nostep2 _ _ step2). contradiction. - - intros s2 s2' s2'' step2 star2 IH j s1 star1 part nostep2 in_prog2. - revert step1b IH part. elim star1 using star_E0_ind'; clear s1 s1a star1. - + intros s1 step1b _ part. - apply (right_state_injection_same_side_left part) in in_prog2. - destruct (parallel_concrete _ _ _ _ _ part in_prog2 step1b) - as (j' & s2a & step2' & part'). - exact (step1_E0_event_False step2 step2'). - + intros s1 s1a s1a' step1a star1 _ step1b IH part. - pose proof right_state_injection_same_side_left part in_prog2 as in_prog1. - destruct (parallel_concrete_E0 _ _ _ _ _ _ part in_prog1 step1a step2) - as (j' & _ & part'). - apply (star_E0_same_side (star_one _ _ _ _ _ step2)) in in_prog2. - exact (IH _ _ star1 part' nostep2 in_prog2). -Qed. - -(* CS.s_component scs2 \in domm (prog_interface c) -> *) -(* last_comp t \in domm (prog_interface c). *) -Lemma blame_last_comp_star p s1 t s2: - Smallstep.initial_state (semantics1 p) s1 -> - Star (semantics1 p) s1 t s2 -> - s |= s2 ∈ Left -> - blame_on_program t. -Proof. -Admitted. (* With default_compartment gone, needs minor adjustments *) - -(* - Related to old [partialize_partition] - - We may want to be more explicit about the initial injection *) -Lemma initial_state_injection s1 s2 : - Smallstep.initial_state (semantics1 W1) s1 -> - Smallstep.initial_state (semantics1 W2) s2 -> - exists j, - right_state_injection s j ge1 ge2 s1 s2. -Proof. -Admitted. (* Another standard assumption about initial states *) - -(* - Quantify over p vs. W1 *) -Lemma does_prefix_star - (m : finpref_behavior) - (Hprefix : does_prefix (semantics1 W1) m) - (NOT_WRONG : not_wrong_finpref m) : - exists (sti : Smallstep.state (semantics1 W1)) - (stf : Smallstep.state (semantics1 W1)), - Smallstep.initial_state (semantics1 W1) sti /\ - Star (semantics1 W1) sti (finpref_trace m) stf /\ - (forall n, - (exists t, m = FTerminates t n) -> - Smallstep.final_state (semantics1 W1) stf n). -Proof. - destruct Hprefix as [b [Hb Hmb]]. - inversion Hb as [s0 beh Hini Hbeh | Hini]; subst. - - inversion Hbeh as [? ? ? Hstar | ? ? Hstar | ? Hreact | ? ? Hstar]; subst. - (* Matching case. *) - + destruct m as [tm | tm | tm]. - * simpl in *. destruct Hmb. subst. - exists s0, s'. split; [| split]; try assumption. - intros n [? EQ]. injection EQ as ?; subst. assumption. - * contradiction. - * (* This is like the contradictory cases below. *) - destruct Hmb as [b Hb']. - destruct b as [tb | tb | tb | tb]; - try discriminate. - inversion Hb'; subst. - destruct (star_app_inv (sr_traces (semantics_receptive _)) _ _ Hstar) - as [s1 [Hstar1 Hstar2]]. - exists s0, s1. split; [| split]; try assumption. - now intros ? [t' Hcontra]. - (* The remaining cases are essentially identical. *) - + destruct m as [tm | tm | tm]; - try contradiction. - destruct Hmb as [b Hb']. - destruct b as [tb | tb | tb | tb]; - try discriminate. - inversion Hb'; subst. - destruct (star_app_inv (sr_traces (semantics_receptive _)) _ _ Hstar) - as [s1 [Hstar1 Hstar2]]. - exists s0, s1. split; [| split]; try assumption. - now intros ? [t' Hcontra]. - + destruct m as [tm | tm | tm]; - try contradiction. - destruct Hmb as [b Hb']. - destruct b as [tb | tb | tb | tb]; - try discriminate. - inversion Hb'; subst. - (* The only difference in this case is the lemma to be applied here. *) - destruct (forever_reactive_app_inv (sr_traces (semantics_receptive _)) _ _ Hreact) - as [s1 [Hstar Hreact']]. - exists s0, s1. split; [| split]; try assumption. - now intros ? [t' Hcontra]. - + (* Same script as Diverges. *) - destruct m as [tm | tm | tm]; - try contradiction. - destruct Hmb as [b Hb']. - destruct b as [tb | tb | tb | tb]; - try discriminate. - inversion Hb'; subst. - destruct (star_app_inv (sr_traces (semantics_receptive _)) _ _ Hstar) - as [s1 [Hstar1 Hstar2]]. - exists s0, s1. split; [| split]; try assumption. - now intros ? [t' Hcontra]. - - (* Contradiction on the existence of an initial state *) - destruct W1_ini as [s1 initial_s1]. specialize (Hini s1). contradiction. -Qed. - -(* - What to say about the interfaces of p1 and p2? - - Closed, linkable, well-formed *) -Lemma blame_program (m: finpref_behavior) (t': trace) - (HpCs_beh: program_behaves (semantics1 W2) (Goes_wrong t')) - (HP'_Cs_beh_new: does_prefix (semantics1 W1) m) - (Hnot_wrong': not_wrong_finpref m) - (K: trace_finpref_prefix t' m): - prefix m (Goes_wrong t') \/ blame_on_program t'. -Proof. - apply does_prefix_star in HP'_Cs_beh_new; [| easy]. - destruct HP'_Cs_beh_new as [sini1 [sfin1 [Hini1 [HStar1 Hfinal1']]]]. - inversion HpCs_beh as [sini2 ? Hini2 Hstbeh2 | Hnot_initial2]; subst; - [| destruct W2_ini as [s2 initial_s2]; - specialize (Hnot_initial2 s2); - contradiction]. - inversion Hstbeh2 as [| | | ? sfin2 HStar2 HNostep2 Hnot_final2]; subst. - assert (exists j0, right_state_injection s j0 ge1 ge2 sini1 sini2) - as [j0 Hpartialize]. - { apply initial_state_injection; assumption. } - (* Case analysis on m. FGoes_wrong can be ruled out by contradiction, - but also solved exactly like the others. *) - destruct m as [tm | tm | tm]; - (destruct K as [tm' Htm']; subst tm; - unfold finpref_trace in HStar1). - - simpl. right. - assert (Hfinal1 : Smallstep.final_state (semantics1 W1) sfin1 n). - apply Hfinal1'. eauto. - (* A good amount of simplification is possible in the new proof *) - assert (HNostep1 : Nostep (semantics1 W1) sfin1). - { simpl in Hfinal1. simpl. - inv Hfinal1. - intros tcon scon Hcontra. - inversion Hcontra. } - pose proof parallel_exec _ _ _ _ _ _ _ _ - Hpartialize - HStar1 HStar2 HNostep2 Hfinal1 - as Hparallel. - destruct (state_split_decidable sfin2) as [Hparallel1 | Hparallel1]. - + exact (blame_last_comp_star _ _ _ _ Hini2 HStar2 Hparallel1). - + specialize (Hparallel Hparallel1) as Hfinal2. - specialize (Hnot_final2 n). contradiction. - - simpl in Hnot_wrong'. contradiction. - - simpl. destruct tm'. - + left. exists (Goes_wrong nil). simpl. repeat rewrite E0_right. reflexivity. - + right. - pose proof parallel_exec' _ _ _ _ _ _ _ _ - Hpartialize - HStar1 HStar2 HNostep2 - as Hparallel. - eapply blame_last_comp_star; eassumption. -Qed. - -Require Import Complements. - -Theorem blame (t m: trace): - clight_program_has_initial_trace W2 t -> - trace_prefix m t -> - m <> t -> - program_behaves (semantics1 W1) (Goes_wrong m) -> - blame_on_program m. -Proof. -Admitted. - -End Simulation. + Lemma parallel_abstract_t: forall s1 s2 s1' s2' t, + right_state_injection s j s1 s2 -> + is_left s s1 -> + Csem.step ge1 s1 t s1' -> + Csem.step ge2 s2 t s2' -> + right_state_injection s j s1' s2'. + +Lemma parallel_concrete p1 p2 scs1 scs2: + left_side s p1 -> (* use definitions from RSC.v *) + left_side s p2 -> (* use definitions from RSC.v *) + partial_state_equivalent s scs1 scs2 -> (* to define --> using memory injections? *) + pc_in_left_part scs1 -> (* to define *) + CS.kstep (prepare_global_env (program_link p p1)) scs1 t scs1' -> (* use step of Csem instead *) + exists2 scs2', + CS.kstep (prepare_global_env (program_link p p2)) scs2 t scs2' /\ (* use step of Csem instead *) + partial_state_equivalent s scs1' scs2'. (* to define *) diff --git a/security/BtBasics.v b/security/BtBasics.v new file mode 100644 index 0000000000..59af340722 --- /dev/null +++ b/security/BtBasics.v @@ -0,0 +1,260 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + + +Section GENV. + + Context {F: Type}. + Context {V: Type}. + + Lemma genv_def_to_some_ident + (p: AST.program F V) + (NR: list_norepet (prog_defs_names p)) + ge + (GE: ge = Genv.globalenv p) + b gd + (DEF: Genv.find_def ge b = Some gd) + : + exists id b', Genv.find_symbol ge id = Some b' /\ Genv.find_def ge b' = Some gd. + Proof. + subst ge. exploit Genv.find_def_inversion; eauto. intros [id IN]. + assert (GET: (prog_defmap p) ! id = Some gd). + { unfold prog_defmap. unfold prog_defs_names in NR. apply PTree_Properties.of_list_norepet; auto. } + apply Genv.find_def_symbol in GET. destruct GET as [b' [FINDSYM FINDDEF]]. eauto. + Qed. + + Lemma genv_find_def_add_global_spec + (ge: Genv.t F V) id gd + (NEW: Genv.find_symbol ge id = None) + b gd' + (ADD: Genv.find_def (Genv.add_global ge (id, gd)) b = Some gd') + : + ((b = (Genv.genv_next ge)) /\ (gd' = gd)) \/ + ((b <> (Genv.genv_next ge)) /\ (Genv.find_def ge b = Some gd')). + Proof. + destruct (Pos.eqb_spec b (Genv.genv_next ge)). + - left; split; auto. + unfold Genv.find_def, Genv.add_global in ADD. subst; simpl in *. + rewrite PTree.gss in ADD. inversion ADD; auto. + - right; split; auto. + unfold Genv.find_def, Genv.add_global in ADD. simpl in *. + rewrite PTree.gso in ADD; auto. + Qed. + + (* Lemma genv_def_to_ident *) + (* (p: AST.program F V) *) + (* (NR: list_norepet (prog_defs_names p)) *) + (* ge *) + (* (GE: ge = Genv.globalenv p) *) + (* b gd *) + (* (DEF: Genv.find_def ge b = Some gd) *) + (* : *) + (* exists id, Genv.invert_symbol ge b = Some id. *) + (* Proof. *) + (* subst ge. unfold Genv.globalenv, Genv.add_globals, prog_defs_names in *. *) + (* destruct p; simpl in *. clear - NR DEF. *) + (* remember (Genv.empty_genv F V prog_public prog_pol) as ge. *) + (* replace (fold_left (Genv.add_global (V:=V)) prog_defs ge) with *) + (* (fold_right (fun ig g => Genv.add_global g ig) ge (rev prog_defs)) in *. *) + (* 2:{ rewrite fold_left_rev_right. f_equal. } *) + (* remember (rev prog_defs) as rev_prog_defs. *) + (* assert (RNR: list_norepet (map fst rev_prog_defs)). *) + (* { subst. rewrite map_rev. apply list_norepet_rev; auto. } *) + (* clear prog_defs NR Heqrev_prog_defs. subst ge. *) + (* revert prog_public prog_pol b gd DEF RNR. *) + (* induction rev_prog_defs; intros. *) + (* { unfold Genv.find_def in DEF. simpl in DEF. rewrite PTree.gempty in DEF. congruence. } *) + (* destruct a as [id0 gd0]. *) + (* simpl in *. specialize (IHrev_prog_defs prog_public prog_pol). *) + (* remember (fold_right (fun (ig : ident * globdef F V) (g : Genv.t F V) => Genv.add_global g ig) (Genv.empty_genv F V prog_public prog_pol) rev_prog_defs) as ge. *) + (* assert (GE: ge = Genv.globalenv (AST.mkprogram (rev rev_prog_defs) prog_public id0 prog_pol)). *) + (* { subst ge. unfold Genv.globalenv. unfold Genv.add_globals. simpl. *) + (* rewrite <- fold_left_rev_right. rewrite rev_involutive. auto. } *) + (* apply genv_find_def_add_global_spec in DEF. *) + (* { destruct DEF as [[BLK GD] | [BLK GD]]. *) + (* - subst b gd0. exists id0. *) + (* apply Genv.find_invert_symbol. unfold Genv.find_symbol, Genv.add_global; simpl. *) + (* rewrite PTree.gss. auto. *) + (* - inversion RNR; clear RNR. subst hd tl. specialize (IHrev_prog_defs _ _ GD H2). *) + (* destruct IHrev_prog_defs as [id' INV]. exists id'. *) + (* apply Genv.find_invert_symbol. unfold Genv.find_symbol, Genv.add_global; simpl. *) + (* rewrite PTree.gso. apply Genv.invert_find_symbol in INV. auto. *) + (* clear - H1 Heqge INV GE. apply Genv.invert_find_symbol in INV. *) + (* rewrite GE in INV. apply Genv.find_symbol_inversion in INV. *) + (* unfold prog_defs_names in INV. simpl in INV. *) + (* rewrite map_rev in INV. apply in_rev in INV. intros CONTRA. subst id'. auto. *) + (* } *) + (* { destruct (Genv.find_symbol ge id0) eqn:CASE; auto. exfalso. *) + (* rewrite GE in CASE. apply Genv.find_symbol_inversion in CASE. *) + (* unfold prog_defs_names in CASE. simpl in CASE. rewrite map_rev in CASE. apply in_rev in CASE. *) + (* clear - CASE RNR. inversion RNR. auto. *) + (* } *) + (* Qed. *) + +End GENV. + + +Section MEM. + + (* f doesn't map anything to [b], e.g. the counter and function parameters *) + Definition meminj_notmap (f: meminj) b := forall b0 ofs0, ~ (f b0 = Some (b, ofs0)). + + Lemma loc_out_of_reach_unchanged_on_content: + forall f b ofs m1 m1' m2' + (NOTMAP: meminj_notmap f b), + Mem.perm m1' b ofs Cur Readable -> + Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' -> + ZMap.get ofs (Mem.mem_contents m2') !! b = ZMap.get ofs (Mem.mem_contents m1') !! b. + Proof. + intros. destruct H0. apply unchanged_on_contents; eauto. + unfold loc_out_of_reach. intros. now specialize (NOTMAP _ _ H0). + Qed. + + Lemma loc_out_of_reach_unchanged_on_perm: + forall f b ofs m1 m1' m2' k p + (NOTMAP: meminj_notmap f b), + Mem.perm m1' b ofs k p -> + Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' -> + Mem.perm m2' b ofs k p. + Proof. + intros. destruct H0. apply unchanged_on_perm; eauto. + unfold loc_out_of_reach. intros. now specialize (NOTMAP _ _ H0). + eapply Mem.perm_valid_block; eauto. + Qed. + + Lemma inject_separated_notmap + f f' m m' b + (NM: meminj_notmap f b) + (VALID: Mem.valid_block m' b) + (* (INJ: Mem.inject f m m') *) + (INCR: inject_incr f f') + (SEP: inject_separated f f' m m') + : + meminj_notmap f' b. + Proof. + unfold meminj_notmap, inject_incr, inject_separated in *. + intros. intros CONTRA. specialize (NM b0 ofs0). destruct (f b0) eqn:FB. + { destruct p. specialize (INCR _ _ _ FB). rewrite CONTRA in INCR. inversion INCR; clear INCR; subst. congruence. } + specialize (SEP _ _ _ FB CONTRA). destruct SEP as [NV1 NV2]. congruence. + Qed. + +End MEM. + +Section HASINIT. + Import Smallstep. + + Variant semantics_has_initial_trace_cut (L: Smallstep.semantics) (t: trace) : Prop := + | semantics_cut_runs : + forall s, (initial_state L s) -> (exists s' beh', ((star (step L) (globalenv L)) s t s') /\ (state_behaves L s' beh')) -> semantics_has_initial_trace_cut _ t + | semantics_cut_goes_initially_wrong : (forall s : state L, ~ initial_state L s) -> (t = nil) -> semantics_has_initial_trace_cut _ t. + + Definition semantics_has_initial_trace_prefix (L: Smallstep.semantics) (t: trace): Prop := + exists beh, (program_behaves L beh) /\ (behavior_prefix t beh). + + Lemma semantics_has_initial_trace_cut_implies_prefix + L t + (HAS: semantics_has_initial_trace_cut L t) + : + semantics_has_initial_trace_prefix L t. + Proof. + inversion HAS. + - destruct H0 as (s' & beh' & STAR & BEH). red. exists (behavior_app t beh'). split. + + econstructor 1. eauto. eapply state_behaves_app; eauto. + + red. eauto. + - subst. red. eexists. split. + + econstructor 2. eauto. + + red. exists (Goes_wrong E0). reflexivity. + Qed. + + Lemma state_behaves_app_inv_one + L s1 beh t beh' + (SE: single_events L) + (BEH: state_behaves L s1 beh) + (APP: beh = behavior_app t beh') + (ONE: (Datatypes.length t = 1)%nat) + : + exists s2, (Star L s1 t s2) /\ (state_behaves L s2 beh'). + Proof. + destruct t; simpl in *. congruence. destruct t; simpl in *. 2: congruence. clear ONE. + inv BEH. + - destruct beh'; simpl in *; try congruence. inv H1. + remember (e :: t0) as tr. revert e t0 i SE Heqtr H0. induction H; intros. + { inv Heqtr. } + subst. assert (SE0: single_events L) by auto. specialize (SE _ _ _ H). inv SE. + + destruct t1; simpl in *. congruence. destruct t1; simpl in *. 2: congruence. + inv Heqtr. exists s2. split. econstructor 2. eauto. econstructor 1. traceEq. + econstructor; eauto. + + destruct t1; simpl in *. 2: lia. clear H3. + specialize (IHstar _ _ _ SE0 Heqtr H2). destruct IHstar as (s2' & STAR & TERM). + exists s2'. split; auto. econstructor 2. eauto. eauto. traceEq. + - destruct beh'; simpl in *; try congruence. inv H1. + remember (e :: t0) as tr. revert e t0 SE Heqtr H0. induction H; intros. + { inv Heqtr. } + subst. assert (SE0: single_events L) by auto. specialize (SE _ _ _ H). inv SE. + + destruct t1; simpl in *. congruence. destruct t1; simpl in *. 2: congruence. + inv Heqtr. exists s2. split. econstructor 2. eauto. econstructor 1. traceEq. + econstructor; eauto. + + destruct t1; simpl in *. 2: lia. clear H3. + specialize (IHstar _ _ SE0 Heqtr H2). destruct IHstar as (s2' & STAR & TERM). + exists s2'. split; auto. econstructor 2. eauto. eauto. traceEq. + - destruct beh'; simpl in *; try congruence. inv H0. + inv H. revert e t SE T H2 H4 H0. induction H1; intros. congruence. + subst. assert (SE0: single_events L) by auto. specialize (SE _ _ _ H). inv SE. + + destruct t1; simpl in *. congruence. destruct t1; simpl in *. 2: congruence. + clear H5. inv H3. destruct t2. + * exists s3. split. econstructor 2. eauto. eauto. traceEq. + econstructor. auto. + * exists s2. split. econstructor 2. eauto. econstructor 1. traceEq. + econstructor. econstructor. eauto. intros F. inv F. auto. + + destruct t1; simpl in *. 2: lia. clear H5. + specialize (IHstar _ _ SE0 _ H2 H4 H3). destruct IHstar as (s2' & STAR & TERM). + exists s2'. split; auto. econstructor 2. eauto. eauto. traceEq. + - destruct beh'; simpl in *; try congruence. inv H2. + remember (e :: t0) as tr. revert e t0 SE Heqtr H0 H1. induction H; intros. + { inv Heqtr. } + subst. assert (SE0: single_events L) by auto. specialize (SE _ _ _ H). inv SE. + + destruct t1; simpl in *. congruence. destruct t1; simpl in *. 2: congruence. + clear H4. inv Heqtr. exists s2. split. econstructor 2. eauto. econstructor 1. traceEq. + econstructor; eauto. + + destruct t1; simpl in *. 2: lia. clear H4. + specialize (IHstar _ _ SE0 Heqtr H2 H3). destruct IHstar as (s2' & STAR & TERM). + exists s2'. split; auto. econstructor 2. eauto. eauto. traceEq. + Qed. + + Lemma state_behaves_app_inv + L s1 beh t beh' + (SE: single_events L) + (BEH: state_behaves L s1 beh) + (APP: beh = behavior_app t beh') + : + exists s2, (Star L s1 t s2) /\ (state_behaves L s2 beh'). + Proof. + revert s1 beh beh' SE BEH APP. induction t; intros. + { rewrite behavior_app_E0 in APP. subst beh'. exists s1. split; auto. econstructor 1. } + replace (a :: t) with ((a :: E0) ++ t) in *. + 2:{ simpl. auto. } + rewrite behavior_app_assoc in APP. exploit state_behaves_app_inv_one. + 3: eapply APP. all: eauto. + intros (s2 & STAR & NEXTBEH). specialize (IHt _ _ beh' SE NEXTBEH). + exploit IHt; auto. intros (s3 & STAR2 & TERM). + exists s3. split; auto. eapply star_trans; eauto. + Qed. + + Lemma semantics_has_initial_trace_prefix_implies_cut + L t + (SE: single_events L) + (HAS: semantics_has_initial_trace_prefix L t) + : + semantics_has_initial_trace_cut L t. + Proof. + inversion HAS. destruct H as [BEH (beh' & APP)]. subst x. inversion BEH; clear BEH. + - subst beh. econstructor 1. eauto. exploit state_behaves_app_inv; eauto. + intros (s2 & STAR & BEH). exists s2, beh'. auto. + - econstructor 2. auto. destruct beh'; simpl in *; try congruence. inv H. + symmetry in H2; apply Eapp_E0_inv in H2. destruct H2; auto. + Qed. + +End HASINIT. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v new file mode 100644 index 0000000000..6aae4974f3 --- /dev/null +++ b/security/BtInfoAsm.v @@ -0,0 +1,2416 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Require Import riscV.Machregs. +Require Import riscV.Asm. +Require Import Complements. + +Require Import Tactics. +Require Import MemoryWeak MemoryDelta. +Require Import BtBasics. + + + +(* Section AUX. *) + +(* Lemma val_load_result_idem chunk v: *) +(* Val.load_result chunk (Val.load_result chunk v) = Val.load_result chunk v. *) +(* Proof. *) +(* destruct chunk, v; ss. *) +(* all: try (rewrite Int.sign_ext_idem; auto; lia). *) +(* all: try (rewrite Int.zero_ext_idem; auto; lia). *) +(* all: des_ifs. *) +(* Qed. *) + +(* Lemma extcall_cases *) +(* ef ge m args *) +(* (ECC: external_call_conds ef ge m args) *) +(* tr rv m' *) +(* (ECALL: external_call ef ge args m tr rv m') *) +(* : *) +(* (external_call_unknowns ef ge m args) \/ *) +(* (external_call_known_observables ef ge m args tr rv m') \/ *) +(* (external_call_known_silents ef ge m args tr rv m'). *) +(* Proof. *) +(* destruct ef; ss; auto. des_ifs; auto. des_ifs; auto. *) +(* - destruct tr; ss; eauto. right; left. esplits; eauto. ss. *) +(* - destruct tr; ss; eauto. right; left. esplits; eauto. ss. *) +(* - inv ECALL. right; right. esplits; eauto. econs; eauto. *) +(* - inv ECALL. right; right. esplits; eauto. econs; eauto. *) +(* right; right. esplits; eauto. econs; eauto. *) +(* - inv ECALL. right; right. esplits; eauto. econs; eauto. *) +(* - destruct tr; ss; eauto. right; left. esplits; eauto. ss. *) +(* - destruct tr; ss; eauto. right; left. esplits; eauto. ss. *) +(* - inv ECALL. right; right. esplits; eauto. econs; eauto. *) +(* Qed. *) + +(* End AUX. *) + + + +Section BUNDLE. + + Variant bundle_event : Type := + (* generate a call code + other followup events; call-ext-ret *) + | Bundle_call (tr: trace) (id: ident) (args: list eventval) (sg: signature) + (d: mem_delta) + (* generate a return code; ret *) + | Bundle_return (tr: trace) (retv: eventval) + (d: mem_delta) + (* generate a builtin code; ext *) + | Bundle_builtin (tr: trace) (ef: external_function) (args: list eventval) + (d: mem_delta) + . + + Definition bundle_trace := list (ident * bundle_event). + + Definition unbundle_ev (be: (bundle_event)): trace := + match be with + | (Bundle_call tr _ _ _ _) + | (Bundle_return tr _ _) + | (Bundle_builtin tr _ _ _) => tr + end. + + Definition unbundle (be: (ident * bundle_event)): trace := unbundle_ev (snd be). + + Fixpoint unbundle_trace (btr: bundle_trace) : trace := + match btr with + | be :: tl => (unbundle be) ++ (unbundle_trace tl) + | nil => nil + end. + + (* Lemma unbundle_trace_cons *) + (* be btr *) + (* : *) + (* unbundle_trace (be :: btr) = (unbundle be) ++ (unbundle_trace btr). *) + (* Proof. simpl. auto. Qed. *) + + (* Lemma unbundle_trace_app *) + (* btr1 btr2 *) + (* : *) + (* unbundle_trace (btr1 ++ btr2) = (unbundle_trace btr1) ++ (unbundle_trace btr2). *) + (* Proof. *) + (* revert btr2. induction btr1; intros. *) + (* { simpl. auto. } *) + (* rewrite <- app_comm_cons. rewrite ! unbundle_trace_cons. rewrite <- app_assoc. f_equal. *) + (* eauto. *) + (* Qed. *) + + (* Inductive istar {genv state : Type} *) + (* (step : genv -> state -> (ident * bundle_event) -> state -> Prop) (ge : genv) : *) + (* state -> bundle_trace -> state -> Prop := *) + (* istar_refl : forall s : state, istar step ge s nil s *) + (* | istar_step : forall (s1 : state) ev (s2 : state) (t2 : bundle_trace) (s3 : state) (t : bundle_trace), *) + (* step ge s1 ev s2 -> istar step ge s2 t2 s3 -> t = ev :: t2 -> istar step ge s1 t s3. *) + + (* Lemma istar_trans *) + (* genv state (step: genv -> state -> _ -> state -> Prop) ge *) + (* s1 t1 s2 *) + (* (ISTAR1: istar step ge s1 t1 s2) *) + (* t2 s3 *) + (* (ISTAR2: istar step ge s2 t2 s3) *) + (* t *) + (* (TR: t = t1 ++ t2) *) + (* : *) + (* istar step ge s1 t s3. *) + (* Proof. *) + (* revert_until ISTAR1. induction ISTAR1; intros. *) + (* { simpl in *. subst; auto. } *) + (* subst. rewrite <- app_comm_cons. econstructor 2. eapply H. *) + (* { eapply IHISTAR1. eapply ISTAR2. eauto. } *) + (* auto. *) + (* Qed. *) + +End BUNDLE. + + +Section EVENT. + + Definition typ_to_eventval (ty: typ): eventval := + match ty with + | Tint => EVint Int.zero + | Tfloat => EVfloat Floats.Float.zero + | Tlong => EVlong Int64.zero + | Tsingle => EVsingle Floats.Float32.zero + | Tany32 => EVint Int.zero + | Tany64 => EVlong Int64.zero + end. + + Definition typ_to_eventvals (ty: list typ): list eventval := map typ_to_eventval ty. + + (* Inductive call_trace_cross {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> block -> list val -> list typ -> trace -> ident -> list eventval -> Prop := *) + (* | call_trace_cross_cross : forall (cp cp' : compartment) (b : block) (vargs : list val) (vl : list eventval) (ty : list typ) (i : ident) tr, *) + (* Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> *) + (* Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> *) + (* (tr = Event_call cp cp' i vl :: nil) -> *) + (* call_trace_cross ge cp cp' b vargs ty tr i vl. *) + + (* Inductive return_trace_cross {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> eventval -> Prop := *) + (* | return_trace_cross_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype) tr, *) + (* Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> *) + (* (tr = Event_return cp cp' res :: nil) -> *) + (* return_trace_cross ge cp cp' v ty tr res. *) + + (* external call *) + Definition senv_invert_symbol_total (ge: Senv.t) (b: block) : ident := + match Senv.invert_symbol ge b with + | Some id => id + | _ => xH + end. + + Definition val_to_eventval (ge: Senv.t) (v: val): eventval := + match v with + | Vundef => EVint Int.zero + | Vint n => EVint n + | Vlong n => EVlong n + | Vfloat n => EVfloat n + | Vsingle n => EVsingle n + | Vptr b o => let id := senv_invert_symbol_total ge b in EVptr_global id o + end. + + Definition vals_to_eventvals (ge: Senv.t) (vs: list val): list eventval := map (val_to_eventval ge) vs. + + (* Lemma eventval_match_val_to_eventval *) + (* ge ev ty v *) + (* (EVM: eventval_match ge ev ty v) *) + (* : *) + (* val_to_eventval ge v = ev. *) + (* Proof. *) + (* inv EVM; simpl; auto. *) + (* unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. *) + (* Qed. *) + + (* Lemma eventval_list_match_vals_to_eventvals *) + (* ge evs tys vs *) + (* (EVM: eventval_list_match ge evs tys vs) *) + (* : *) + (* vals_to_eventvals ge vs = evs. *) + (* Proof. *) + (* induction EVM; simpl; auto. *) + (* rewrite IHEVM. f_equal. eapply eventval_match_val_to_eventval; eauto. *) + (* Qed. *) + +End EVENT. + + + +(* Section IR. *) + +(* Variant ir_cont_type : Type := | ir_cont: block -> ir_cont_type. *) +(* Definition ir_conts := list ir_cont_type. *) + +(* Definition crossing_comp {F V} (ge: Genv.t F V) (cp cp': compartment) := *) +(* Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall. *) + +(* Definition ir_state := option (block * mem * ir_conts)%type. *) + +(* Variant ir_step (ge: Asm.genv) : ir_state -> (ident * bundle_event) -> ir_state -> Prop := *) +(* | ir_step_cross_call_internal *) +(* cur m1 ik *) +(* tr id evargs sg *) +(* cp cp' vargs *) +(* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) +(* b f_next *) +(* (FINDB: Genv.find_symbol ge id = Some b) *) +(* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.Internal f_next)) *) +(* (CP': cp' = comp_of f_next) *) +(* (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) *) +(* (NPTR: crossing_comp ge cp cp' -> Forall not_ptr vargs) *) +(* (SIG: sg = Asm.fn_sig f_next) *) +(* (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) *) +(* d m2 *) +(* (DELTA: mem_delta_apply_wf ge cp d (Some m1) = Some m2) *) +(* (PUB: public_first_order ge m2) *) +(* id_cur *) +(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) +(* : *) +(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call tr id evargs sg d) (Some (b, m2, (ir_cont cur) :: ik)) *) +(* | ir_step_cross_return_internal *) +(* cur m1 next ik ik_tl *) +(* tr evretv *) +(* cp_cur cp_next vretv *) +(* (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) +(* sg fd_cur *) +(* (FINDFD: Genv.find_funct_ptr ge cur = Some (fd_cur)) *) +(* (* in Asm, stack has the sig *) *) +(* (SIG: sg = Asm.funsig fd_cur) *) +(* (NPTR: crossing_comp ge cp_next cp_cur -> not_ptr vretv) *) +(* (NEXTCP: cp_next = Genv.find_comp ge (Vptr next Ptrofs.zero)) *) +(* f_next *) +(* (INTERNAL: Genv.find_funct_ptr ge next = Some (AST.Internal f_next)) *) +(* (* internal return: memory changes in Clight-side, so need inj-relation *) *) +(* (TR: return_trace_cross ge cp_next cp_cur vretv (sig_res sg) tr evretv) *) +(* (CONT: ik = (ir_cont next) :: ik_tl) *) +(* d m2 *) +(* (DELTA: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m2) *) +(* (PUB: public_first_order ge m2) *) +(* id_cur *) +(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) +(* : *) +(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_return tr evretv d) (Some (next, m2, ik_tl)) *) +(* | ir_step_intra_call_external *) +(* cur m1 m2 ik *) +(* tr id evargs sg *) +(* cp_cur *) +(* (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) +(* b_ext ef cp_ext *) +(* (FINDB: Genv.find_symbol ge id = Some b_ext) *) +(* (FINDF: Genv.find_funct ge (Vptr b_ext Ptrofs.zero) = Some (AST.External ef)) *) +(* (EXTCP: cp_ext = comp_of ef) *) +(* (INTRA: Genv.type_of_call ge cp_cur cp_ext = Genv.InternalCall) *) +(* (SIG: sg = ef_sig ef) *) +(* d m1' *) +(* (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') *) +(* vargs vretv *) +(* (EC: external_call ef ge vargs m1' tr vretv m2) *) +(* (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ *) +(* (external_call_known_observables ef ge m1' vargs tr vretv m2 /\ d = [])) *) +(* (ARGS: evargs = vals_to_eventvals ge vargs) *) +(* id_cur *) +(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) +(* : *) +(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call tr id evargs sg d) (Some (cur, m2, ik)) *) +(* | ir_step_builtin *) +(* cur m1 m2 ik *) +(* tr ef evargs *) +(* cp_cur *) +(* (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) +(* (ALLOWED: comp_of ef = cp_cur) *) +(* d m1' *) +(* (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') *) +(* vargs vretv *) +(* (EC: external_call ef ge vargs m1' tr vretv m2) *) +(* (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ *) +(* (external_call_known_observables ef ge m1' vargs tr vretv m2 /\ d = [])) *) +(* (ARGS: evargs = vals_to_eventvals ge vargs) *) +(* id_cur *) +(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) +(* : *) +(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) *) +(* | ir_step_cross_call_external1 *) +(* (* early cut at call *) *) +(* cur m1 ik *) +(* tr id evargs sg *) +(* cp cp' vargs *) +(* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) +(* b ef *) +(* (FINDB: Genv.find_symbol ge id = Some b) *) +(* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.External ef)) *) +(* (CP': cp' = comp_of ef) *) +(* (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) *) +(* (NPTR: crossing_comp ge cp cp' -> Forall not_ptr vargs) *) +(* (SIG: sg = ef_sig ef) *) +(* (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) *) +(* id_cur *) +(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) +(* : *) +(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call tr id evargs sg []) None *) +(* | ir_step_cross_call_external2 *) +(* (* early cut at call-ext_call *) *) +(* cur m1 ik *) +(* tr1 id evargs sg *) +(* cp cp' vargs *) +(* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) +(* b ef *) +(* (FINDB: Genv.find_symbol ge id = Some b) *) +(* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.External ef)) *) +(* (CP': cp' = comp_of ef) *) +(* (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) *) +(* (NPTR: crossing_comp ge cp cp' -> Forall not_ptr vargs) *) +(* (SIG: sg = ef_sig ef) *) +(* (TR1: call_trace_cross ge cp cp' b vargs (sig_args sg) tr1 id evargs) *) +(* (* external function part *) *) +(* d m1' *) +(* (MEM: mem_delta_apply_wf ge cp d (Some m1) = Some m1') *) +(* tr2 m2 vretv *) +(* (TR2: external_call ef ge vargs m1' tr2 vretv m2) *) +(* (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ *) +(* (external_call_known_observables ef ge m1' vargs tr2 vretv m2 /\ d = [])) *) +(* (ARGS: evargs = vals_to_eventvals ge vargs) *) +(* id_cur *) +(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) +(* : *) +(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call (tr1 ++ tr2) id evargs sg d) None *) +(* | ir_step_cross_call_external3 *) +(* (* early cut at call-ext_call *) *) +(* cur m1 ik *) +(* tr1 id evargs sg *) +(* cp cp' vargs *) +(* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) +(* b ef *) +(* (FINDB: Genv.find_symbol ge id = Some b) *) +(* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.External ef)) *) +(* (CP': cp' = comp_of ef) *) +(* (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) *) +(* (NPTR: crossing_comp ge cp cp' -> Forall not_ptr vargs) *) +(* (SIG: sg = ef_sig ef) *) +(* (TR1: call_trace_cross ge cp cp' b vargs (sig_args sg) tr1 id evargs) *) +(* (* external function part *) *) +(* d m1' *) +(* (MEM: mem_delta_apply_wf ge cp d (Some m1) = Some m1') *) +(* tr2 m2 vretv *) +(* (TR2: external_call ef ge vargs m1' tr2 vretv m2) *) +(* (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ *) +(* (external_call_known_observables ef ge m1' vargs tr2 vretv m2 /\ d = [])) *) +(* (ARGS: evargs = vals_to_eventvals ge vargs) *) +(* (* return part *) *) +(* tr3 evretv *) +(* (NPTR: crossing_comp ge cp cp' -> not_ptr vretv) *) +(* f_cur *) +(* (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal f_cur)) *) +(* (TR3: return_trace_cross ge cp cp' vretv (sig_res sg) tr3 evretv) *) +(* id_cur *) +(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) +(* : *) +(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg d) (Some (cur, m2, ik)). *) + +(* End IR. *) + + +(* Section AUX. *) + +(* Definition wf_ge {F V} (ge: Genv.t F V) := exists (p: AST.program F V), (list_norepet (prog_defs_names p)) /\ (ge = Genv.globalenv p). *) + +(* Lemma wf_ge_block_to_id *) +(* F V (ge: Genv.t F V) *) +(* (WF: wf_ge ge) *) +(* b gd *) +(* (DEF: Genv.find_def ge b = Some gd) *) +(* : *) +(* exists id, Genv.invert_symbol ge b = Some id. *) +(* Proof. destruct WF as (p & A & B). eapply genv_def_to_ident; eauto. Qed. *) + +(* Lemma val_is_ptr_or_not *) +(* (v: val) *) +(* : *) +(* (forall b o, v <> Vptr b o) \/ (exists b o, v = Vptr b o). *) +(* Proof. destruct v; eauto. all: left; intros; intros F; inv F. Qed. *) + +(* End AUX. *) + + +(* Section MEASURE. *) + +(* Inductive star_measure {genv state : Type} (step : genv -> state -> trace -> state -> Prop) (ge : genv) : nat -> state -> trace -> state -> Prop := *) +(* star_measure_refl : forall s : state, star_measure step ge O s E0 s *) +(* | star_step : forall n (s1 : state) (t1 : trace) (s2 : state) (t2 : trace) (s3 : state) (t : trace), *) +(* step ge s1 t1 s2 -> star_measure step ge n s2 t2 s3 -> t = t1 ** t2 -> star_measure step ge (S n) s1 t s3. *) + +(* Lemma measure_star *) +(* genv state *) +(* (step : genv -> state -> trace -> state -> Prop) *) +(* (ge : genv) *) +(* s0 tr s1 *) +(* (STAR: star step ge s0 tr s1) *) +(* : *) +(* exists n, star_measure step ge n s0 tr s1. *) +(* Proof. *) +(* induction STAR. *) +(* { exists O. constructor 1. } *) +(* destruct IHSTAR as (n & NEXT). exists (S n). econstructor 2. eapply H. eapply NEXT. auto. *) +(* Qed. *) + +(* End MEASURE. *) + + +(* Section CONDS. *) + +(* Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (forall ofs, ~ Mem.perm m b ofs Max Freeable). *) + +(* Definition public_rev_perm ge m1 m2 := *) +(* forall b, match meminj_public ge b with *) +(* | Some (b', del) => forall ofs k p, Mem.perm m2 b' (ofs + del) k p -> Mem.perm m1 b ofs k p *) +(* | None => True *) +(* end. *) + +(* End CONDS. *) + + +(* Section FROMASM. *) + +(* Import ListNotations. *) + +(* Ltac Simplif_all := *) +(* ((rewrite Asmgenproof0.nextinstr_inv in * by eauto with asmgen) *) +(* || (rewrite Asmgenproof0.nextinstr_inv1 in * by eauto with asmgen) *) +(* || (rewrite Pregmap.gss in *) +(* || (rewrite Asmgenproof0.nextinstr_pc in *) +(* || (rewrite Pregmap.gso in * by eauto with asmgen)); auto with asmgen. *) + +(* Ltac Simpl_all := repeat Simplif_all. *) + +(* Ltac simpl_before_exists := *) +(* repeat (Simpl_all; *) +(* match goal with *) +(* (* Goto *) *) +(* | _: goto_label _ _ ?rs _ = Next _ _ |- _ => *) +(* unfold goto_label in *; destruct label_pos; try congruence *) +(* | _: eval_branch _ _ ?rs _ _ = Next _ _ |- _ => *) +(* unfold eval_branch in *; simpl in * *) +(* | _: exec_load _ _ _ _ _ _ _ _ _ = Next _ _ |- _ => *) +(* unfold exec_load in *; simpl in * *) +(* | _: exec_store _ _ _ _ _ _ _ _ = Next _ _ |- _ => *) +(* unfold exec_store in *; simpl in * *) +(* | _: context [Val.cmp_bool] |- _ => *) +(* unfold Val.cmp_bool in *; simpl in * *) +(* | _: context [Val.cmpl_bool] |- _ => *) +(* unfold Val.cmpl_bool in *; simpl in * *) +(* | _: context [eval_offset _ ?ofs] |- _ => *) +(* destruct ofs; simpl in * *) + +(* | |- context [Ptrofs.repr 0] => replace (Ptrofs.repr 0) with Ptrofs.zero by reflexivity; auto *) +(* | H: context [Ptrofs.repr 0] |- _ => replace (Ptrofs.repr 0) with Ptrofs.zero in H by reflexivity; auto *) +(* | |- context [Ptrofs.add _ Ptrofs.zero] => rewrite Ptrofs.add_zero; auto *) +(* | H: context [Ptrofs.add _ Ptrofs.zero] |- _ => rewrite Ptrofs.add_zero in H; simpl in *; try congruence *) +(* | |- context [Ptrofs.sub _ Ptrofs.zero] => rewrite Ptrofs.sub_zero_l; auto *) +(* | H: context [Ptrofs.sub _ Ptrofs.zero] |- _ => rewrite Ptrofs.sub_zero_l in H; simpl in *; try congruence *) + +(* (* hypothesis manipulation *) *) +(* | _: context [match ?rs1 ?i with | _ => _ end] |- _ => *) +(* destruct (rs1 i) eqn:?; try congruence; simpl in *; eauto *) + +(* | _: context [Val.offset_ptr (?rs1 ?i) _] |- _ => *) +(* destruct (rs1 i) eqn:?; try congruence; simpl in *; eauto *) + +(* | H: Next _ _ = Next _ _ |- _ => inv H *) +(* | H: Some _ = Some _ |- _ => inv H *) +(* | H: Some _ = None |- _ => inv H *) +(* | H: None = Some _ |- _ => inv H *) +(* | H: Stuck = Next _ _ |- _ => inv H *) +(* | H: Next _ _ = Stuck |- _ => inv H *) +(* | H: negb _ = true |- _ => apply negb_true_iff in H *) +(* | H: negb _ = false |- _ => apply negb_false_iff in H *) +(* | H: Int.eq ?x ?x = false |- _ => rewrite Int.eq_true in H *) +(* | H: Int64.eq ?x ?x = false |- _ => rewrite Int64.eq_true in H *) +(* | H: false = true |- _ => congruence *) +(* | H: true = false |- _ => congruence *) +(* | H: ?x = false, H': ?x = true |- _ => congruence *) +(* | H: match ?x with | _ => _ end = Next _ _ |- _ => *) +(* let eq := fresh "eq" in *) +(* destruct x eqn:eq; simpl in *; try congruence *) +(* | _: context [?rs1 ### ?rs] |- context [?rs3 ### ?rs] => *) +(* let i := fresh "i" in destruct rs as [| i]; simpl in * *) +(* | _: context [?rs1 ## ?rs] |- context [?rs3 ## ?rs] => *) +(* let i := fresh "i" in destruct rs as [| i]; simpl in * *) +(* | H: ?x = _ |- context [if ?x then _ else _] => *) +(* rewrite H; simpl *) +(* | H: ?x = _ |- context [match ?x with | _ => _ end] => *) +(* rewrite H; simpl *) +(* | |- context [(if ?x then _ else _) = Next _ _] => *) +(* let eq := fresh "eq" in destruct x eqn:eq; simpl in * *) +(* | |- context [(match ?x with | _ => _ end) = Next _ _] => *) +(* let eq := fresh "eq" in destruct x eqn:eq; simpl in * *) + +(* end); *) +(* simpl. *) + +(* Lemma public_not_freeable_free_inj_none *) +(* ge m *) +(* (NFREE: public_not_freeable ge m) *) +(* b lo hi cp m' *) +(* (FREE: Mem.free m b lo hi cp = Some m') *) +(* (BOUND: (lo < hi)%Z) *) +(* : *) +(* meminj_public ge b = None. *) +(* Proof. *) +(* destruct (meminj_public ge b) eqn:INJPUB; auto. exfalso. *) +(* eapply Mem.free_range_perm in FREE. unfold Mem.range_perm in FREE. *) +(* eapply NFREE. erewrite INJPUB. congruence. eapply Mem.perm_cur_max; apply FREE. *) +(* instantiate (1:=lo). lia. *) +(* Qed. *) + +(* Lemma public_not_freeable_store *) +(* ge m1 *) +(* (NFREE: public_not_freeable ge m1) *) +(* chunk b ofs v cp m2 *) +(* (STORE: Mem.store chunk m1 b ofs v cp = Some m2) *) +(* : *) +(* public_not_freeable ge m2. *) +(* Proof. *) +(* unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). *) +(* apply NFREE; eapply Mem.perm_store_2; eauto. *) +(* Qed. *) + +(* Lemma public_not_freeable_bytes *) +(* ge m1 *) +(* (NFREE: public_not_freeable ge m1) *) +(* b ofs mvs cp m2 *) +(* (STORE: Mem.storebytes m1 b ofs mvs cp = Some m2) *) +(* : *) +(* public_not_freeable ge m2. *) +(* Proof. *) +(* unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). *) +(* apply NFREE; eapply Mem.perm_storebytes_2; eauto. *) +(* Qed. *) + +(* Lemma public_not_freeable_alloc *) +(* ge m1 *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m1) *) +(* (NFREE: public_not_freeable ge m1) *) +(* cp lo hi m2 bn *) +(* (STORE: Mem.alloc m1 cp lo hi = (m2, bn)) *) +(* : *) +(* public_not_freeable ge m2. *) +(* Proof. *) +(* unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). *) +(* apply NFREE. eapply Mem.perm_alloc_4; eauto. *) +(* intros EQ; subst b'. apply H'. apply NALLOC. erewrite Mem.alloc_result; eauto. lia. *) +(* Qed. *) + +(* Lemma public_not_freeable_free *) +(* ge m1 *) +(* (NFREE: public_not_freeable ge m1) *) +(* b lo hi cp m2 *) +(* (STORE: Mem.free m1 b lo hi cp = Some m2) *) +(* : *) +(* public_not_freeable ge m2. *) +(* Proof. *) +(* unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). *) +(* apply NFREE. eapply Mem.perm_free_3; eauto. *) +(* Qed. *) + +(* Lemma public_not_freeable_exec_instr *) +(* (ge: genv) f i rs m cp rs' m' *) +(* (NFREE: public_not_freeable ge m) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m) *) +(* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) +(* : *) +(* public_not_freeable ge m'. *) +(* Proof. *) +(* destruct i; simpl in EXEC. *) +(* all: try (inv EXEC; eauto). *) +(* all: simpl_before_exists; eauto. *) +(* all: try *) +(* (match goal with *) +(* | H: context [Mem.alloc] |- _ => idtac *) +(* | H: context [Mem.free] |- _ => idtac *) +(* | H: Mem.store ?ch ?m ?b ?ofs ?v ?cp = _ |- _ => *) +(* eapply public_not_freeable_store; eauto *) +(* end). *) +(* { eapply public_not_freeable_store. eapply public_not_freeable_alloc; eauto. eauto. } *) +(* { eapply public_not_freeable_free; eauto. } *) +(* Qed. *) + +(* Lemma public_rev_perm_store *) +(* ge m1 m' *) +(* (PRP: public_rev_perm ge m1 m') *) +(* chunk b ofs v cp m2 *) +(* (STORE: Mem.store chunk m1 b ofs v cp = Some m2) *) +(* : *) +(* public_rev_perm ge m2 m'. *) +(* Proof. *) +(* unfold public_rev_perm in *; intros. specialize (PRP b0). des_ifs. intros. *) +(* exploit PRP; eauto. intros. eapply Mem.perm_store_1; eauto. *) +(* Qed. *) + +(* Lemma public_rev_perm_bytes *) +(* ge m1 m' *) +(* (PRP: public_rev_perm ge m1 m') *) +(* b ofs mvs cp m2 *) +(* (STORE: Mem.storebytes m1 b ofs mvs cp = Some m2) *) +(* : *) +(* public_rev_perm ge m2 m'. *) +(* Proof. *) +(* unfold public_rev_perm in *; intros. specialize (PRP b0). des_ifs. intros. *) +(* exploit PRP; eauto. intros. eapply Mem.perm_storebytes_1; eauto. *) +(* Qed. *) + +(* Lemma public_rev_perm_alloc *) +(* ge m1 m' *) +(* (PRP: public_rev_perm ge m1 m') *) +(* cp lo hi m2 bn *) +(* (STORE: Mem.alloc m1 cp lo hi = (m2, bn)) *) +(* : *) +(* public_rev_perm ge m2 m'. *) +(* Proof. *) +(* unfold public_rev_perm in *; intros. specialize (PRP b). des_ifs. intros. *) +(* exploit PRP; eauto. intros. eapply Mem.perm_alloc_1; eauto. *) +(* Qed. *) + +(* Lemma public_rev_perm_free *) +(* ge m1 m' *) +(* (NFREE: public_not_freeable ge m1) *) +(* (PRP: public_rev_perm ge m1 m') *) +(* b lo hi cp m2 *) +(* (STORE: Mem.free m1 b lo hi cp = Some m2) *) +(* : *) +(* public_rev_perm ge m2 m'. *) +(* Proof. *) +(* unfold public_rev_perm in *; intros. specialize (PRP b0). des_ifs; clarify. intros. *) +(* exploit Mem.free_result; eauto. intros RES. unfold Mem.unchecked_free in RES. des_ifs. *) +(* { eapply PRP; eauto. } *) +(* exploit PRP; eauto. intros. eapply Mem.perm_free_1; eauto. *) +(* exploit Mem.free_range_perm; eauto. instantiate (1:=lo). lia. *) +(* intros PF. destruct (Pos.eqb_spec b b0); auto. subst b0. right. *) +(* unfold public_not_freeable in NFREE. exploit NFREE. rewrite Heq. congruence. 2: clarify. *) +(* eapply Mem.perm_max; eauto. *) +(* Qed. *) + +(* Lemma public_rev_perm_exec_instr *) +(* (ge: genv) f i rs m cp rs' m' *) +(* (NFREE: public_not_freeable ge m) *) +(* m0 *) +(* (PRP: public_rev_perm ge m m0) *) +(* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) +(* : *) +(* public_rev_perm ge m' m0. *) +(* Proof. *) +(* destruct i; simpl in EXEC. *) +(* all: try (inv EXEC; eauto). *) +(* all: simpl_before_exists; eauto. *) +(* all: try *) +(* (match goal with *) +(* | H: context [Mem.alloc] |- _ => idtac *) +(* | H: context [Mem.free] |- _ => idtac *) +(* | H: Mem.store ?ch ?m ?b ?ofs ?v ?cp = _ |- _ => *) +(* eapply public_rev_perm_store; eauto *) +(* end). *) +(* { eapply public_rev_perm_store. eapply public_rev_perm_alloc; eauto. eauto. } *) +(* { eapply public_rev_perm_free; eauto. } *) +(* Qed. *) + +(* Lemma meminj_not_alloc_delta *) +(* j m0 *) +(* (NALLOC: meminj_not_alloc j m0) *) +(* d m1 *) +(* (APPD: mem_delta_apply d (Some m0) = Some m1) *) +(* : *) +(* meminj_not_alloc j m1. *) +(* Proof. *) +(* revert m0 NALLOC m1 APPD. induction d; intros. *) +(* { simpl in *. inv APPD. auto. } *) +(* rewrite mem_delta_apply_cons in APPD. destruct a. *) +(* - destruct d0 as (((ch & ptr) & v) & cp). ss. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. *) +(* unfold meminj_not_alloc in *. intros. eapply NALLOC. destruct ptr; ss. erewrite Mem.nextblock_store in H; eauto. *) +(* - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. *) +(* unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_store in H; eauto. *) +(* - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. *) +(* unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_storebytes in H; eauto. *) +(* - destruct d0 as ((cp & lo) & hi). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. *) +(* unfold meminj_not_alloc in *. intros. eapply NALLOC. destruct (Mem.alloc m0 cp lo hi) eqn:MA. simpl in *. inv MEM. erewrite Mem.nextblock_alloc in H; eauto. lia. *) +(* - destruct d0 as (((b & lo) & hi) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. *) +(* unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_free in H; eauto. *) +(* Qed. *) + +(* Lemma exec_instr_is_return *) +(* ge f i rs m cp rs' m' *) +(* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) +(* (ISRET: is_return i = true) *) +(* : *) +(* (exists v, rs' = (rs # PC <- v)) /\ (m' = m). *) +(* Proof. destruct i; simpl in *; clarify. split; eauto. Qed. *) + +(* Lemma exec_instr_is_call *) +(* ge f i rs m cp rs' m' *) +(* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) +(* sig *) +(* (ISRET: sig_call i = Some sig) *) +(* : *) +(* (rs' X1 = Val.offset_ptr rs#PC Ptrofs.one) /\ (m' = m). *) +(* Proof. destruct i; simpl in *; clarify. Qed. *) + +(* Lemma mem_delta_exec_instr *) +(* (ge: genv) f i rs m cp rs' m' *) +(* (NFREE: public_not_freeable ge m) *) +(* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) +(* m0 d *) +(* (DELTA0: mem_delta_inj_wf cp (meminj_public ge) d) *) +(* (DELTA1: mem_delta_apply d (Some m0) = Some m) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) +(* : *) +(* exists d', (mem_delta_inj_wf cp (meminj_public ge) d') /\ (mem_delta_apply d' (Some m0) = Some m'). *) +(* Proof. *) +(* destruct i; simpl in EXEC. *) +(* all: try (inv EXEC; eauto). *) +(* all: simpl_before_exists; eauto. *) +(* all: try *) +(* (match goal with *) +(* | H: context [Mem.alloc] |- _ => idtac *) +(* | H: context [Mem.free] |- _ => idtac *) +(* | H: Mem.store ?ch ?m ?b (Ptrofs.unsigned ?ofs) ?v ?cp = _ |- _ => *) +(* exists (d ++ [mem_delta_kind_storev (ch, Vptr b ofs, v, cp)]); split *) +(* end; *) +(* [apply Forall_app; split; [auto | constructor; ss; auto] *) +(* | rewrite mem_delta_apply_app; (match goal with | H: mem_delta_apply _ _ = Some _ |- _ => rewrite H end; simpl; auto) ]). *) +(* { match goal with *) +(* | _: Mem.alloc _ ?cp1 ?lo ?hi = _, _: Mem.store ?ch _ ?b ?ofs ?v ?cp2 = _ |- _ => *) +(* exists (d ++ ([mem_delta_kind_alloc (cp1, lo, hi)] ++ [mem_delta_kind_store (ch, b, ofs, v, cp2)])) *) +(* end. *) +(* split. *) +(* - apply Forall_app; split; auto. apply Forall_app; split; constructor; simpl; auto. *) +(* hexploit meminj_not_alloc_delta. eauto. eapply DELTA1. intros NALLOC2. apply NALLOC2. *) +(* exploit Mem.alloc_result; eauto. lia. *) +(* - rewrite mem_delta_apply_app. rewrite DELTA1. rewrite mem_delta_apply_app. simpl. rewrite Heqp. simpl. auto. *) +(* } *) +(* { destruct (Z.leb_spec sz 0); cycle 1. *) +(* { match goal with *) +(* | _: Mem.free _ ?b ?lo ?hi ?cp = _ |- _ => *) +(* exists (d ++ [mem_delta_kind_free (b, lo, hi, cp)]) *) +(* end. *) +(* split. *) +(* - apply Forall_app; split; auto. constructor; auto. simpl. destruct (meminj_public ge b) eqn:INJPUB; auto. exfalso. *) +(* eapply Mem.free_range_perm in Heqo0. unfold Mem.range_perm in Heqo0. eapply NFREE. erewrite INJPUB. congruence. eapply Mem.perm_cur_max; apply Heqo0. instantiate (1:=0%Z). lia. *) +(* - rewrite mem_delta_apply_app. rewrite DELTA1. simpl. auto. *) +(* } *) +(* { apply Mem.free_result in Heqo0. unfold Mem.unchecked_free in Heqo0. unfold zle in Heqo0. des_ifs. eexists; eauto. } *) +(* } *) +(* Qed. *) + +(* End FROMASM. *) + + +(* Section INVS. *) + +(* Import ListNotations. *) + +(* Definition wf_stackframe (ge: Asm.genv) (fr: stackframe) := *) +(* match fr with *) +(* | Stackframe b _ _ _ _ => match Genv.find_funct_ptr ge b with *) +(* | Some (Internal f) => True *) +(* | _ => False *) +(* end *) +(* end. *) +(* Definition wf_stack (ge: Asm.genv) (sk: stack) := Forall (wf_stackframe ge) sk. *) + +(* Definition wf_regset (ge: Asm.genv) (rs: regset) := *) +(* match rs PC with *) +(* | Vptr b _ => match Genv.find_funct_ptr ge b with *) +(* | Some (Internal f) => True *) +(* | _ => False *) +(* end *) +(* | _ => False *) +(* end. *) + +(* Definition wf_asm (ge: Asm.genv) (ast: Asm.state) := *) +(* match ast with *) +(* | State sk rs m => (wf_stack ge sk) /\ (wf_regset ge rs) *) +(* | _ => False *) +(* end. *) + + +(* Definition wf_ir_cur (ge: Asm.genv) (cur: block) := *) +(* match Genv.find_funct_ptr ge cur with *) +(* | Some (Internal f) => True *) +(* | _ => False *) +(* end. *) + +(* Definition wf_ir_cont (ge: Asm.genv) (ik: ir_cont_type) := *) +(* match ik with *) +(* | ir_cont b => match Genv.find_funct_ptr ge b with *) +(* | Some (Internal f) => True *) +(* | _ => False *) +(* end *) +(* end. *) +(* Definition wf_ir_conts (ge: Asm.genv) (ik: ir_conts) := Forall (wf_ir_cont ge) ik. *) + + +(* Definition match_cur_stack_sig (cur: block) (ge: Asm.genv) (sk: stack) := *) +(* match Genv.find_funct_ptr ge cur with *) +(* | Some fd => Asm.funsig fd = sig_of_call sk *) +(* | _ => False *) +(* end. *) + +(* Definition match_cur_regset (cur: block) (ge: Asm.genv) (rs: regset) := *) +(* Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs PC). *) + +(* Inductive match_stack (ge: Asm.genv): ir_conts -> stack -> Prop := *) +(* | match_stack_nil *) +(* : *) +(* match_stack ge [] [] *) +(* | match_stack_cons *) +(* next ik_tl *) +(* b cp sg v ofs sk_tl *) +(* (COMP: Genv.find_comp ge (Vptr next Ptrofs.zero) = Genv.find_comp ge (Vptr b Ptrofs.zero)) *) +(* (SIG: match_cur_stack_sig next ge sk_tl) *) +(* (TL: match_stack ge ik_tl sk_tl) *) +(* : *) +(* match_stack ge (ir_cont next :: ik_tl) (Stackframe b cp sg v ofs :: sk_tl). *) + +(* Definition match_mem (ge: Senv.t) cp (k: meminj) (d: mem_delta) (m_a0 m_i m_a1: mem): Prop := *) +(* let j := meminj_public ge in *) +(* (Mem.inject k m_a0 m_i) /\ (inject_incr j k) /\ *) +(* (meminj_not_alloc j m_a0) /\ (public_not_freeable ge m_a1) /\ *) +(* (mem_delta_inj_wf cp j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1) /\ *) +(* (public_rev_perm ge m_a1 m_i). *) + +(* Definition match_state (ge: Asm.genv) (k: meminj) (m_a0: mem) (d: mem_delta) (ast: Asm.state) (ist: ir_state): Prop := *) +(* match ast, ist with *) +(* | State sk rs m_a, Some (cur, m_i, ik) => *) +(* (wf_ir_cur ge cur) /\ (wf_ir_conts ge ik) /\ *) +(* (match_cur_stack_sig cur ge sk) /\ (match_cur_regset cur ge rs) /\ *) +(* (match_stack ge ik sk) /\ (match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) +(* | _, _ => False *) +(* end. *) + +(* End INVS. *) + + +(* Section PROOF. *) + +(* Import ListNotations. *) + +(* Ltac end_case := do 2 eexists; split; [|constructor 1]; auto. *) + +(* Lemma asm_step_current_pc *) +(* cpm ge st rs m t s' *) +(* (STEP: step_fix cpm ge (State st rs m) t s') *) +(* : *) +(* exists b ofs, rs PC = Vptr b ofs. *) +(* Proof. destruct (rs PC) eqn:NEXTPC. 1,2,3,4,5: inv STEP; rewrite NEXTPC in H2; inv H2. eauto. Qed. *) + +(* Lemma asm_step_some_fundef *) +(* cpm ge st rs m t s' *) +(* (STEP: step_fix cpm ge (State st rs m) t s') *) +(* b ofs *) +(* (NEXTPC: rs PC = Vptr b ofs) *) +(* : *) +(* exists fd, Genv.find_funct_ptr ge b = Some fd. *) +(* Proof. destruct (Genv.find_funct_ptr ge b) eqn:CASE; eauto. exfalso. inv STEP; rewrite NEXTPC in H2; inv H2; rewrite CASE in H3; inv H3. Qed. *) + +(* Lemma asm_to_ir_compose *) +(* ge ist0 t t1 t2 *) +(* (ISTARS: exists btr1 ist1, *) +(* (unbundle_trace btr1 = t1 /\ istar ir_step ge ist0 btr1 ist1) *) +(* /\ exists btr2 ist2, *) +(* (unbundle_trace btr2 = t2 /\ istar ir_step ge ist1 btr2 ist2)) *) +(* (TR: t = t1 ** t2) *) +(* : *) +(* exists (btr : bundle_trace) (ist' : ir_state), *) +(* unbundle_trace btr = t /\ istar ir_step ge ist0 btr ist'. *) +(* Proof. *) +(* subst. destruct ISTARS as (btr1 & ist1 & (UTR1 & ISTAR1) & btr2 & ist2 & (UTR2 & ISTAR2)). *) +(* exists (btr1 ++ btr2). exists ist2. split; auto. *) +(* { rewrite unbundle_trace_app. rewrite UTR1, UTR2. auto. } *) +(* { eapply istar_trans; eauto. } *) +(* Qed. *) + + +(* Lemma visible_fo_meminj_fo *) +(* (ge: Senv.t) m tys args *) +(* (VFO: visible_fo ge m tys args) *) +(* : *) +(* meminj_first_order (meminj_public ge) m. *) +(* Proof. *) +(* destruct VFO as [PFO _]. ii. unfold public_first_order in PFO. unfold meminj_public in H. des_ifs. *) +(* exploit PFO; eauto. apply Senv.invert_find_symbol. auto. *) +(* Qed. *) + +(* Lemma external_call_unknowns_fo *) +(* ef (ge: Senv.t) m args *) +(* (ECC: external_call_unknowns ef ge m args) *) +(* : *) +(* meminj_first_order (meminj_public ge) m. *) +(* Proof. *) +(* unfold external_call_unknowns in ECC. des_ifs; eapply visible_fo_meminj_fo; eauto. *) +(* Qed. *) + +(* Lemma symbols_inject_meminj_public *) +(* F V (ge: Genv.t F V) *) +(* : *) +(* symbols_inject (meminj_public ge) ge ge. *) +(* Proof. *) +(* unfold symbols_inject. splits; intros; unfold meminj_public in *; auto. *) +(* - des_ifs. *) +(* - erewrite Senv.find_invert_symbol; eauto. rewrite H. eauto. *) +(* - des_ifs. *) +(* Qed. *) + +(* Lemma visible_fo_val_inject_list *) +(* (ge: Senv.t) m tys args *) +(* (VFO: visible_fo ge m tys args) *) +(* : *) +(* Val.inject_list (meminj_public ge) args args. *) +(* Proof. *) +(* destruct VFO as [PFO VP]. induction VP; ss. econs; eauto. clear dependent l. clear dependent l'. inv H; auto. *) +(* destruct H0 as [id [INV PUB]]. *) +(* econs. unfold meminj_public. rewrite INV. rewrite PUB. eauto. rewrite Ptrofs.add_zero. auto. *) +(* Qed. *) + +(* Lemma external_call_unknowns_val_inject_list *) +(* ef (ge: Senv.t) m args *) +(* (ECC: external_call_unknowns ef ge m args) *) +(* : *) +(* Val.inject_list (meminj_public ge) args args. *) +(* Proof. *) +(* unfold external_call_unknowns in ECC. des_ifs; eapply visible_fo_val_inject_list; eauto. *) +(* Qed. *) + +(* Lemma public_rev_perm_delta_apply_inj *) +(* d ge m m_i m_i' cp *) +(* (PRP: public_rev_perm ge m m_i) *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m_i) = Some m_i') *) +(* : *) +(* public_rev_perm ge m m_i'. *) +(* Proof. *) +(* revert_until d. induction d; intros. *) +(* { unfold mem_delta_apply_wf in APPD. ss. clarify. } *) +(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs; clarify; eauto. *) +(* exploit mem_delta_apply_wf_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. *) +(* eapply IHd; clear IHd. 2: eauto. *) +(* unfold public_rev_perm in *. intros. specialize (PRP b). des_ifs. intros. *) +(* eapply PRP. unfold wf_mem_delta_kind_b in Heq. des_ifs. ss. unfold mem_delta_apply_storev in STORE. des_ifs. *) +(* destruct v0; ss. eapply Mem.perm_store_2; eauto. *) +(* Qed. *) + +(* Lemma mem_perm_any_to_nonempty *) +(* m b ofs k p *) +(* (PERM: Mem.perm m b ofs k p) *) +(* : *) +(* Mem.perm m b ofs k Nonempty. *) +(* Proof. *) +(* unfold Mem.perm in *. remember ((Mem.mem_access m) !! b ofs k) as k'. clear - PERM. destruct k'; ss. destruct p; ss; try constructor. *) +(* Qed. *) + +(* Lemma loc_first_order_memval_inject_preserves *) +(* (ge: Senv.t) m m' b ofs *) +(* (LFO: loc_first_order m b ofs) *) +(* (MVINJ: memval_inject (meminj_public ge) (ZMap.get ofs (Mem.mem_contents m) !! b) (ZMap.get ofs (Mem.mem_contents m') !! b)) *) +(* : *) +(* loc_first_order m' b ofs. *) +(* Proof. *) +(* unfold loc_first_order in *. remember (ZMap.get ofs (Mem.mem_contents m) !! b) as mv1. remember (ZMap.get ofs (Mem.mem_contents m') !! b) as mv2. *) +(* clear - LFO MVINJ. inv MVINJ; ss. *) +(* Qed. *) + +(* Lemma visible_fo_mem_inj *) +(* (ge: Senv.t) m tys args *) +(* (VFO: visible_fo ge m tys args) *) +(* m' *) +(* (MEMINJ: Mem.inject (meminj_public ge) m m') *) +(* (PRP: public_rev_perm ge m m') *) +(* : *) +(* visible_fo ge m' tys args. *) +(* Proof. *) +(* destruct VFO as [PFO VP]. split; auto. clear VP. clear - PFO MEMINJ PRP. *) +(* unfold public_first_order in *. intros. specialize (PRP b). unfold meminj_public in PRP. *) +(* exploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV, PUBLIC in PRP. *) +(* specialize (PRP ofs). rewrite Z.add_0_r in PRP. exploit PFO; eauto. intros LFO. *) +(* inv MEMINJ. inv mi_inj. exploit mi_memval. *) +(* { unfold meminj_public. rewrite INV, PUBLIC. eauto. } *) +(* { eauto. } *) +(* intros MVINJ. clear - LFO MVINJ. rewrite Z.add_0_r in MVINJ. eapply loc_first_order_memval_inject_preserves; eauto. *) +(* Qed. *) + +(* Lemma external_call_unknowns_mem_inj *) +(* (ge: Senv.t) m ef args *) +(* (ECC: external_call_unknowns ef ge m args) *) +(* m' *) +(* (MEMINJ: Mem.inject (meminj_public ge) m m') *) +(* (PRP: public_rev_perm ge m m') *) +(* : *) +(* external_call_unknowns ef ge m' args. *) +(* Proof. *) +(* unfold external_call_unknowns in *. des_ifs; eapply visible_fo_mem_inj; eauto. *) +(* Qed. *) + +(* Lemma match_mem_external_call_establish1 *) +(* (ge: genv) cp k d m_a0 m_i m *) +(* (MEM: match_mem ge cp k d m_a0 m_i m) *) +(* ef args t res m' *) +(* (EXTCALL: external_call ef ge args m t res m') *) +(* (ECC: external_call_unknowns ef ge m args) *) +(* : *) +(* exists m1 m2 res', *) +(* (mem_delta_apply_wf ge cp d (Some m_i) = Some m1) /\ *) +(* (external_call ef ge args m1 t res' m2) /\ *) +(* (external_call_unknowns ef ge m1 args) /\ *) +(* (exists k2, match_mem ge cp k2 [] m' m2 m' /\ Val.inject k2 res res') *) +(* . *) +(* Proof. *) +(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* (* reestablish meminj *) *) +(* exploit mem_delta_apply_establish_inject; eauto. *) +(* (* { apply meminj_public_strict. } *) *) +(* { eapply external_call_unknowns_fo. eauto. } *) +(* intros (m_i' & APPD' & MEMINJ'). *) +(* hexploit ec_mem_inject. eapply external_call_spec. 2: eapply EXTCALL. all: eauto. *) +(* (* hexploit external_call_mem_inject. 2: eapply EXTCALL. all: eauto. *) *) +(* { instantiate (1:=ge). apply symbols_inject_meminj_public. } *) +(* { instantiate (1:=args). eapply external_call_unknowns_val_inject_list; eauto. } *) +(* intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). *) +(* assert (MM': match_mem ge cp f' [] m' m_i'' m'). *) +(* { unfold match_mem. simpl. *) +(* assert (PNF: public_not_freeable ge m'). *) +(* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. *) +(* clear - EXTCALL MEM3 NALLOC. unfold public_not_freeable in *. intros. *) +(* specialize (MEM3 _ H). intros CC. apply (MEM3 ofs); clear MEM3. *) +(* eapply external_call_max_perm; eauto. unfold Mem.valid_block. *) +(* unfold meminj_not_alloc in NALLOC. unfold Plt. *) +(* destruct (Pos.ltb_spec b (Mem.nextblock m)); auto. *) +(* specialize (NALLOC _ H0). congruence. *) +(* } *) +(* pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. *) +(* assert (MNA: meminj_not_alloc (meminj_public ge) m'). *) +(* { clear - EXTCALL NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) +(* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b EXTCALL). *) +(* destruct (Pos.leb_spec (Mem.nextblock m) b); auto. *) +(* unfold Mem.valid_block in H0. apply H0 in H1. exfalso. unfold Plt in H1. lia. *) +(* } *) +(* splits; auto. *) +(* { constructor. } *) +(* { hexploit public_rev_perm_delta_apply_inj; eauto. intros PRP2. clear - MEM3 PRP2 EXTCALL EXTCALL' PNF NALLOC MEMINJ' MEMINJ'' INCRINJ'. *) +(* unfold public_rev_perm in *. intros. specialize (PRP2 b). des_ifs. intros. *) +(* hexploit Mem.perm_inject_inv. eapply MEMINJ''. eapply INCRINJ'. eapply Heq. eauto. intros [PERM | PERM]; auto. *) +(* pose proof Heq as PUB. unfold meminj_public in PUB. des_ifs. *) +(* assert (VB: Mem.valid_block m b0). *) +(* { unfold meminj_not_alloc in NALLOC. unfold Mem.valid_block. destruct (Pos.ltb_spec b0 (Mem.nextblock m)); auto. exfalso. *) +(* exploit NALLOC; eauto. intros. clarify. *) +(* } *) +(* exfalso. apply PERM. eapply external_call_public_not_freeable; eauto. *) +(* { eapply PRP2. eapply external_call_max_perm. eauto. *) +(* { eapply Mem.valid_block_inject_2; eauto. } *) +(* eapply Mem.perm_max. eapply mem_perm_any_to_nonempty. eauto. *) +(* } *) +(* { unfold public_not_freeable in MEM3. eapply MEM3. rewrite Heq. congruence. } *) +(* } *) +(* } *) +(* exists m_i', m_i'', vres'. splits; eauto. *) +(* { assert (PRP: public_rev_perm ge m m_i'). *) +(* { eapply public_rev_perm_delta_apply_inj; eauto. } *) +(* clear - ECC MEMINJ' PRP. eapply external_call_unknowns_mem_inj; eauto. *) +(* } *) +(* Qed. *) + + +(* Lemma asm_to_ir_returnstate_nccc_internal *) +(* cpm (ge: genv) n n0 *) +(* (LT: (n0 < n)%nat) *) +(* (IH: forall y : nat, *) +(* (y < n)%nat -> *) +(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) +(* wf_ge ge -> *) +(* wf_asm ge ast -> *) +(* star_measure (step_fix cpm) ge y ast tr ast' -> *) +(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) +(* match_state ge k m_a0 d ast ist -> *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) +(* (WFGE: wf_ge ge) *) +(* cur ik *) +(* (WFIR0 : wf_ir_cur ge cur) *) +(* (WFIR1 : wf_ir_conts ge ik) *) +(* st (rs: regset) *) +(* (WFASM1: wf_stack ge st) *) +(* (MTST0 : match_cur_stack_sig cur ge st) *) +(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) +(* (MTST2 : match_stack ge ik st) *) +(* k d m_a0 m_i m_a *) +(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) +(* t' ast' *) +(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) +(* t'' ast'' *) +(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) +(* (NCCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) <> Genv.CrossCompartmentCall) *) +(* b1 ofs1 *) +(* (NEXTPC: rs PC = Vptr b1 ofs1) *) +(* f *) +(* (NEXTF : Genv.find_funct_ptr ge b1 = Some (Internal f)) *) +(* : *) +(* exists (btr : bundle_trace) (ist' : ir_state), *) +(* unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) +(* Proof. *) +(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* (** step --- ReturnState *) *) +(* inv STEP. inv EV; simpl in *. *) +(* 2:{ rewrite H in NCCC. congruence with NCCC. } *) +(* (** return is nccc *) *) +(* clear H. pose proof STAR as STAR0. inv STAR. *) +(* (* end case *) *) +(* { end_case. } *) +(* (* has next step - internal -> done*) *) +(* rename H into STEP, H0 into STAR. *) +(* (** next is internal *) *) +(* exploit IH; clear IH. 4: eapply STAR0. lia. all: auto. *) +(* { simpl. split. *) +(* - unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. *) +(* - unfold wf_regset in *. rewrite NEXTPC, NEXTF. auto. *) +(* } *) +(* { instantiate (4:=k). instantiate (3:=m_a0). instantiate (2:=d). instantiate (1:=Some (cur, m_i, ik)). *) +(* assert (st' = st). *) +(* { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) +(* subst st'. simpl. split; auto. split; auto. split; auto. split. *) +(* { unfold match_cur_regset in *. rewrite CURCOMP. unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. auto. } *) +(* split; auto. *) +(* { unfold match_mem. splits; auto. } *) +(* } *) +(* intros (btr & ist' & UTR & ISTAR'). *) +(* exists btr, ist'. split; auto. *) +(* Qed. *) + +(* Lemma match_mem_external_call_establish2 *) +(* ge cp k d m_a0 m_i m *) +(* (MEM: match_mem ge cp k d m_a0 m_i m) *) +(* ef args t res m' *) +(* (EXTCALL: external_call ef ge args m t res m') *) +(* (ECKO: external_call_known_observables ef ge m args t res m') *) +(* : *) +(* (external_call ef ge args m_i t res m_i) /\ *) +(* (external_call_known_observables ef ge m_i args t res m_i) /\ *) +(* (match_mem ge cp k d m_a0 m_i m') *) +(* . *) +(* Proof. *) +(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* unfold external_call_known_observables in ECKO. *) +(* des_ifs; simpl in *. *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. *) +(* 1,2: econs; econs; eauto. unfold match_mem. splits; auto. *) +(* } *) +(* { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. *) +(* 1,2: econs; econs; eauto. unfold match_mem. splits; auto. *) +(* } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. esplits; eauto. *) +(* 1,2: econs; eauto. unfold match_mem. splits; auto. *) +(* } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. esplits; eauto. *) +(* 1,2: econs; eauto. unfold match_mem. splits; auto. *) +(* } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) +(* Qed. *) + +(* Lemma match_mem_external_call_establish *) +(* (ge: genv) cp k d m_a0 m_i m *) +(* (MEM: match_mem ge cp k d m_a0 m_i m) *) +(* ef args t res m' *) +(* (EXTCALL: external_call ef ge args m t res m') *) +(* (ECC: external_call_unknowns ef ge m args \/ external_call_known_observables ef ge m args t res m') *) +(* : *) +(* exists d' m1 m2 res', *) +(* (mem_delta_apply_wf ge cp d' (Some m_i) = Some m1) /\ *) +(* (external_call ef ge args m1 t res' m2) /\ *) +(* ((external_call_unknowns ef ge m1 args) \/ (external_call_known_observables ef ge m1 args t res' m2 /\ d' = [])) /\ *) +(* (exists k2 d2 m_a02, match_mem ge cp k2 d2 m_a02 m2 m' /\ (Val.inject k2 res res' \/ (res = res'))) *) +(* . *) +(* Proof. *) +(* destruct ECC as [ECC | ECC]. *) +(* - exploit match_mem_external_call_establish1; eauto. intros. des. esplits; eauto. *) +(* - exploit match_mem_external_call_establish2; eauto. intros. des. esplits; eauto. ss. *) +(* Qed. *) + +(* Lemma asm_to_ir_step_external *) +(* cpm (ge: genv) *) +(* (WFGE: wf_ge ge) *) +(* cur ik *) +(* (WFIR0 : wf_ir_cur ge cur) *) +(* (WFIR1 : wf_ir_conts ge ik) *) +(* st (rs: regset) *) +(* (WFASM1: wf_stack ge st) *) +(* (MTST0 : match_cur_stack_sig cur ge st) *) +(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) +(* (MTST2 : match_stack ge ik st) *) +(* k d m_a0 m_i m_a *) +(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) +(* t ast' *) +(* (STEP: step_fix cpm ge (State st rs m_a) t ast') *) +(* b1 ofs1 *) +(* (NEXTPC: rs PC = Vptr b1 ofs1) *) +(* ef *) +(* (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) *) +(* n t' ast'' *) +(* (STAR: star_measure (step_fix cpm) ge n ast' t' ast'') *) +(* : *) +(* exists (btr : bundle_trace) k' d' m_a0' m_i' m_a', *) +(* (unbundle_trace btr = t) /\ *) +(* (istar ir_step ge (Some (cur, m_i, ik)) btr (Some (cur, m_i', ik))) /\ *) +(* (match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m_a') /\ *) +(* (exists res, star_measure (step_fix cpm) ge n *) +(* (ReturnState st (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) # PC <- (rs X1) m_a') t' ast''). *) +(* Proof. *) +(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). *) +(* { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. *) +(* des_ifs. eapply wf_ge_block_to_id; eauto. *) +(* } *) +(* des. rename H into IDCUR. *) +(* (* take a step *) *) +(* inv STEP. *) +(* (* invalid *) *) +(* 1,2,3,4: rewrite NEXTPC in H2; inv H2; rewrite NEXTF in H3; inv H3. *) +(* rewrite NEXTPC in H2; inv H2; rewrite NEXTF in H3; inv H3. *) +(* exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF). *) +(* exploit wf_ge_block_to_id; eauto. intros (ef_id & INVSYMB). *) +(* exploit Genv.invert_find_symbol. eapply INVSYMB. intros FINDSYMB. clear TEMP. *) +(* exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. *) + +(* - (* extcall is unknown *) *) +(* exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. *) +(* intros. des. *) +(* exists ([(id_cur, Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (d))]). *) +(* do 5 eexists. splits; simpl. 3: eapply x3. apply app_nil_r. *) +(* 2:{ exists res. auto. } *) +(* econstructor 2. 2: econstructor 1. 2: eauto. *) +(* eapply ir_step_intra_call_external; eauto. *) +(* { unfold Genv.type_of_call in *. rewrite CURCOMP, <- REC_CURCOMP. rewrite NEXTPC. simpl. *) +(* unfold Genv.find_comp. setoid_rewrite NEXTF. rewrite Pos.eqb_refl. auto. *) +(* } *) + +(* - (* extcall is known and observable *) *) +(* rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_observables in ECKO. *) +(* des_ifs; simpl in *. *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) +(* exists ([(id_cur, Bundle_call [Event_vload chunk id ofs ev] ef_id [EVptr_global id ofs] {| sig_args := [Tptr]; sig_res := rettype_of_chunk chunk; sig_cc := cc_default |} ([]))]). *) +(* exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. *) +(* econstructor 2. 2: econstructor 1. 2: auto. *) +(* eapply ir_step_intra_call_external. all: eauto. *) +(* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) +(* { ss. } *) +(* { simpl. econstructor. econstructor 1; eauto. } *) +(* { simpl. right. split; auto. econs; eauto. econs. econs; eauto. } *) +(* { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } *) +(* splits; auto. *) +(* } *) +(* { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. *) +(* exists ([(id_cur, Bundle_call [Event_vstore chunk id ofs ev] ef_id [EVptr_global id ofs; ev] {| sig_args := [Tptr; type_of_chunk chunk]; sig_res := Tvoid; sig_cc := cc_default |} ([]))]). *) +(* exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. *) +(* econstructor 2. 2: econstructor 1. 2: auto. *) +(* eapply ir_step_intra_call_external. all: eauto. *) +(* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) +(* { ss. } *) +(* { instantiate (2:=[Vptr b0 ofs; Val.load_result chunk v]). *) +(* simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. *) +(* } *) +(* { simpl. right. split; auto. *) +(* splits; ss; auto. econs; eauto. econs; eauto. rewrite val_load_result_idem. auto. des. *) +(* unfold load_whole_chunk in *. rewrite val_load_result_idem. auto. *) +(* } *) +(* { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. *) +(* f_equal. erewrite eventval_match_val_to_eventval; eauto. *) +(* } *) +(* splits; auto. *) +(* } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. *) +(* exists ([(id_cur, Bundle_call [Event_annot text args0] ef_id (vals_to_eventvals ge args) {| sig_args := targs; sig_res := Tvoid; sig_cc := cc_default |} ([]))]). *) +(* exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. *) +(* econstructor 2. 2: econstructor 1. 2: auto. *) +(* eapply ir_step_intra_call_external. all: eauto. *) +(* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) +(* { ss. } *) +(* { simpl. econstructor. auto. } *) +(* { simpl. right. split; auto. econs; eauto. econs. auto. } *) +(* splits; auto. *) +(* } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. *) +(* exists ([(id_cur, Bundle_call [Event_annot text [arg]] ef_id [val_to_eventval ge res] {| sig_args := [targ]; sig_res := targ; sig_cc := cc_default |} ([]))]). *) +(* exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. *) +(* econstructor 2. 2: econstructor 1. 2: auto. *) +(* eapply ir_step_intra_call_external. all: eauto. *) +(* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) +(* { ss. } *) +(* { simpl. econstructor. eauto. } *) +(* { simpl. right. split; auto. econs; eauto. econs. auto. } *) +(* { simpl. auto. } *) +(* splits; auto. *) +(* } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) + +(* - (* extcall is known and silent *) *) +(* rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_silents in ECKS. *) +(* des_ifs; ss; clarify. *) +(* { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. *) +(* exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. *) +(* } *) +(* { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. *) +(* exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. *) +(* } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) +(* exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. *) +(* } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) +(* exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs, v, cp)]), m_a0, m_i, m'. simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. *) +(* { eapply public_not_freeable_store; eauto. } *) +(* { setoid_rewrite Forall_app. split; auto. econs; auto. ss. *) +(* rewrite CURCOMP. rewrite <- REC_CURCOMP. rewrite NEXTPC. ss. unfold Genv.find_comp. setoid_rewrite NEXTF. ss. *) +(* } *) +(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) +(* { eapply public_rev_perm_store; eauto. } *) +(* } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) +(* exists [], k, (d ++ [mem_delta_kind_alloc (cp, (- size_chunk Mptr), (Ptrofs.unsigned sz)); mem_delta_kind_store (Mptr, b0, (- size_chunk Mptr), (Vptrofs sz), cp)]), m_a0, m_i, m'. *) +(* simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. *) +(* { eapply public_not_freeable_store. 2: eauto. eapply public_not_freeable_alloc. *) +(* 3: eauto. all: auto. *) +(* eapply meminj_not_alloc_delta; eauto. *) +(* } *) +(* { setoid_rewrite Forall_app. split; auto. econs; auto. *) +(* { simpl. auto. } *) +(* econs; auto. simpl. hexploit Mem.alloc_result; eauto. hexploit meminj_not_alloc_delta; eauto. *) +(* intros. apply H1. lia. *) +(* } *) +(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. rewrite H. simpl. auto. } *) +(* { eapply public_rev_perm_store. 2: eauto. eapply public_rev_perm_alloc. *) +(* 2: eauto. all: auto. *) +(* } *) +(* } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) +(* - exists [], k, (d ++ [mem_delta_kind_free (b0, (Ptrofs.unsigned lo - size_chunk Mptr)%Z, (Ptrofs.unsigned lo + Ptrofs.unsigned sz)%Z, cp)]), m_a0, m_i, m'. *) +(* simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. *) +(* { eapply public_not_freeable_free; eauto. } *) +(* { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. *) +(* eapply public_not_freeable_free_inj_none; eauto. *) +(* { unfold size_chunk. unfold Mptr. des_ifs; lia. } *) +(* } *) +(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) +(* { eapply public_rev_perm_free; eauto. } *) +(* - exists [], k, d, m_a0, m_i, m'. *) +(* simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. *) +(* } *) +(* { destruct ECKS as [_ [OBS NPUB]]. inv EXTCALL. *) +(* exists [], k, (d ++ [mem_delta_kind_bytes (bdst, (Ptrofs.unsigned odst), bytes, cp)]), m_a0, m_i, m'. *) +(* simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. *) +(* { eapply public_not_freeable_bytes; eauto. } *) +(* { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. *) +(* clear - NPUB. simpl in NPUB. unfold meminj_public. des_ifs. exfalso. apply NPUB. *) +(* exists i. auto. *) +(* } *) +(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) +(* { eapply public_rev_perm_bytes; eauto. } *) +(* } *) + +(* { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) +(* exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. *) +(* } *) + +(* Qed. *) + +(* Lemma asm_to_ir_builtin *) +(* (ge: genv) *) +(* m_a0 *) +(* (WFGE: wf_ge ge) *) +(* rs m st *) +(* (WFASM: wf_asm ge (State st rs m)) *) +(* cur m_i ik k d *) +(* (MTST: match_state ge k m_a0 d (State st rs m) (Some (cur, m_i, ik))) *) +(* t1 ef vres m' b ofs f vargs *) +(* (CURPC: rs PC = Vptr b ofs) *) +(* (CURF: Genv.find_funct_ptr ge b = Some (Internal f)) *) +(* (EXTCALL: external_call ef ge vargs m t1 vres m') *) +(* (ALLOWED: comp_of ef = comp_of f) *) +(* (ECC: external_call_conds ef ge m vargs) *) +(* : *) +(* exists (btr : bundle_trace) k' d' m_a0' m_i', *) +(* (unbundle_trace btr = t1) /\ *) +(* (istar ir_step ge (Some (cur, m_i, ik)) btr (Some (cur, m_i', ik))) /\ *) +(* (match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m'). *) +(* Proof. *) +(* ss. destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). *) +(* destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* destruct WFASM as [WFASM0 WFASM1]. *) +(* assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). *) +(* { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. *) +(* des_ifs. eapply wf_ge_block_to_id; eauto. *) +(* } *) +(* des. rename H into IDCUR. *) +(* exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. *) + +(* - (* extcall is unknown *) *) +(* exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. *) +(* intros. des. *) +(* exists ([(id_cur, Bundle_builtin t1 ef (vals_to_eventvals ge vargs) d)]). *) +(* do 4 eexists. splits; simpl. 3: eapply x3. apply app_nil_r. *) +(* econstructor 2. 2: econstructor 1. 2: eauto. *) +(* eapply ir_step_builtin; eauto. *) +(* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) +(* setoid_rewrite CURF. ss. *) +(* } *) + +(* - (* extcall is known and observable *) *) +(* unfold external_call_known_observables in ECKO. *) +(* des_ifs; simpl in *. *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) +(* exists ([(id_cur, Bundle_builtin [Event_vload chunk id ofs0 ev] (EF_vload cp chunk) [EVptr_global id ofs0] [])]). *) +(* exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. *) +(* econstructor 2. 2: econstructor 1. 2: auto. *) +(* eapply ir_step_builtin. all: eauto. *) +(* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) +(* setoid_rewrite CURF. ss. *) +(* } *) +(* { ss. } *) +(* { simpl. econstructor. econstructor 1; eauto. } *) +(* { simpl. right. split; auto. econs; eauto. econs. econs; eauto. } *) +(* { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } *) +(* splits; auto. *) +(* } *) +(* { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. *) +(* exists ([(id_cur, Bundle_builtin [Event_vstore chunk id ofs0 ev] (EF_vstore cp chunk) [EVptr_global id ofs0; ev] [])]). *) +(* exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. *) +(* econstructor 2. 2: econstructor 1. 2: auto. *) +(* eapply ir_step_builtin. all: eauto. *) +(* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) +(* setoid_rewrite CURF. ss. *) +(* } *) +(* { ss. } *) +(* { instantiate (2:=[Vptr b0 ofs0; Val.load_result chunk v]). *) +(* simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. *) +(* } *) +(* { simpl. right. split; auto. splits; eauto. econs. econs; eauto. rewrite val_load_result_idem. auto. *) +(* unfold load_whole_chunk in *. rewrite val_load_result_idem. auto. *) +(* } *) +(* { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. *) +(* f_equal. erewrite eventval_match_val_to_eventval; eauto. *) +(* } *) +(* splits; auto. *) +(* } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. *) +(* exists ([(id_cur, Bundle_builtin [Event_annot text args] (EF_annot cp kind text targs) (vals_to_eventvals ge vargs) [])]). *) +(* exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. *) +(* econstructor 2. 2: econstructor 1. 2: auto. *) +(* eapply ir_step_builtin. all: eauto. *) +(* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) +(* setoid_rewrite CURF. ss. *) +(* } *) +(* { ss. } *) +(* { simpl. econstructor. auto. } *) +(* { simpl. right. split; auto. econs; eauto. econs. auto. } *) +(* splits; auto. *) +(* } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. *) +(* exists ([(id_cur, Bundle_builtin [Event_annot text [arg]] (EF_annot_val cp kind text targ) [val_to_eventval ge vres] [])]). *) +(* exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. *) +(* econstructor 2. 2: econstructor 1. 2: auto. *) +(* eapply ir_step_builtin. all: eauto. *) +(* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) +(* setoid_rewrite CURF. ss. *) +(* } *) +(* { ss. } *) +(* { simpl. econstructor. eauto. } *) +(* { simpl. right. split; auto. econs; eauto. econs. auto. } *) +(* { simpl. auto. } *) +(* splits; auto. *) +(* } *) +(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) + +(* - (* extcall is known and silent *) *) +(* unfold external_call_known_silents in ECKS. des_ifs; ss; clarify. *) +(* { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. *) +(* exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. *) +(* } *) +(* { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. *) +(* exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. *) +(* } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) +(* exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. *) +(* } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) +(* exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs0, v, cp)]), m_a0, m_i. simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. *) +(* { eapply public_not_freeable_store; eauto. } *) +(* { setoid_rewrite Forall_app. split; auto. econs; auto. ss. *) +(* rewrite MTST1. rewrite CURPC. ss. unfold Genv.find_comp. setoid_rewrite CURF. auto. *) +(* } *) +(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) +(* { eapply public_rev_perm_store; eauto. } *) +(* } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) +(* exists [], k, (d ++ [mem_delta_kind_alloc (cp, (- size_chunk Mptr), (Ptrofs.unsigned sz)); mem_delta_kind_store (Mptr, b0, (- size_chunk Mptr), (Vptrofs sz), cp)]), m_a0, m_i. *) +(* simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. *) +(* { eapply public_not_freeable_store. 2: eauto. eapply public_not_freeable_alloc. *) +(* 3: eauto. all: auto. *) +(* eapply meminj_not_alloc_delta; eauto. *) +(* } *) +(* { setoid_rewrite Forall_app. split; auto. econs; auto. *) +(* { simpl. auto. } *) +(* econs; auto. simpl. hexploit Mem.alloc_result; eauto. hexploit meminj_not_alloc_delta; eauto. *) +(* intros. apply H1. lia. *) +(* } *) +(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. rewrite H. simpl. auto. } *) +(* { eapply public_rev_perm_store. 2: eauto. eapply public_rev_perm_alloc. *) +(* 2: eauto. all: auto. *) +(* } *) +(* } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) +(* - exists [], k, (d ++ [mem_delta_kind_free (b0, (Ptrofs.unsigned lo - size_chunk Mptr)%Z, (Ptrofs.unsigned lo + Ptrofs.unsigned sz)%Z, cp)]), m_a0, m_i. *) +(* simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. *) +(* { eapply public_not_freeable_free; eauto. } *) +(* { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. *) +(* eapply public_not_freeable_free_inj_none; eauto. *) +(* { unfold size_chunk. unfold Mptr. des_ifs; lia. } *) +(* } *) +(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) +(* { eapply public_rev_perm_free; eauto. } *) +(* - exists [], k, d, m_a0, m_i. *) +(* simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. *) +(* } *) +(* { destruct ECKS as [_ [OBS NPUB]]. inv EXTCALL. *) +(* exists [], k, (d ++ [mem_delta_kind_bytes (bdst, (Ptrofs.unsigned odst), bytes, cp)]), m_a0, m_i. *) +(* simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. *) +(* { eapply public_not_freeable_bytes; eauto. } *) +(* { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. *) +(* clear - NPUB. simpl in NPUB. unfold meminj_public. des_ifs. exfalso. apply NPUB. *) +(* exists i. auto. *) +(* } *) +(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) +(* { eapply public_rev_perm_bytes; eauto. } *) +(* } *) + +(* { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } *) +(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) +(* exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. *) +(* } *) + +(* Qed. *) + + +(* Lemma asm_to_ir_returnstate_undef_nccc_external *) +(* cpm (ge: genv) n n0 *) +(* (LT: (n0 < n)%nat) *) +(* (IH: forall y : nat, *) +(* (y < n)%nat -> *) +(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) +(* wf_ge ge -> *) +(* wf_asm ge ast -> *) +(* star_measure (step_fix cpm) ge y ast tr ast' -> *) +(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) +(* match_state ge k m_a0 d ast ist -> *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) +(* (WFGE: wf_ge ge) *) +(* cur ik *) +(* (WFIR0 : wf_ir_cur ge cur) *) +(* (WFIR1 : wf_ir_conts ge ik) *) +(* st (rs: regset) *) +(* (WFASM1: wf_stack ge st) *) +(* (MTST0 : match_cur_stack_sig cur ge st) *) +(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) +(* (MTST2 : match_stack ge ik st) *) +(* k d m_a0 m_i m_a *) +(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) +(* (RSX: rs X1 = Vundef) *) +(* t' ast' *) +(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) +(* t'' ast'' *) +(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) +(* (NCCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) <> Genv.CrossCompartmentCall) *) +(* b1 ofs1 *) +(* (NEXTPC: rs PC = Vptr b1 ofs1) *) +(* ef *) +(* (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) *) +(* : *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) +(* Proof. *) +(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* (** step --- ReturnState *) *) +(* inv STEP. inv EV; simpl in *. *) +(* 2:{ rewrite H in NCCC. congruence with NCCC. } *) +(* (** return is nccc *) *) +(* clear H. pose proof STAR as STAR0. inv STAR. *) +(* (* end case *) *) +(* { end_case. } *) +(* (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) *) +(* (* take a step *) *) +(* rename H into STEP, H0 into STAR. *) + +(* assert (st' = st). *) +(* { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) +(* subst st'. *) +(* exploit asm_to_ir_step_external. *) +(* 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. *) +(* all: eauto. *) +(* { rr; splits; eauto. } *) +(* clear STEP STAR. *) +(* intros (btr1 & k' & d' & m_a0' & m_i' & m_a' & UTR1 & ISTAR1 & MM' & (res & STAR)). *) +(* eapply asm_to_ir_compose. 2: eauto. do 2 eexists. split; eauto. clear btr1 UTR1 ISTAR1. *) + +(* assert (STUCK: (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) *) +(* # PC <- (rs X1) PC = Vundef). *) +(* { rewrite Pregmap.gss. auto. } *) +(* inv STAR. *) +(* (* end case *) *) +(* { exists []. eexists. split; auto. econstructor 1. } *) +(* (* now at Returnstate *) *) +(* inv H; simpl in *. rewrite Pregmap.gss in *. inv H0. *) +(* (* end case *) *) +(* { inv EV. *) +(* (* return is NCCC - silent *) *) +(* { exists []. simpl. eexists. split; auto. econstructor 1. } *) +(* (* return is CCC - return event *) *) +(* { unfold Genv.type_of_call in H. des_ifs. unfold update_stack_return in STUPD0. *) +(* clear H. rewrite Pregmap.gss in *. *) +(* rewrite Pos.eqb_sym in Heq. rewrite Heq in STUPD0. des_ifs. *) +(* pose proof Heq as NEQ. eapply Pos.eqb_neq in NEQ. specialize (PC_RA0 NEQ). *) +(* (* stuck --- return PC is Vundef *) *) +(* rewrite STUCK in PC_RA0. clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. *) +(* } *) +(* } *) +(* (* stuck case *) *) +(* inv H; simpl in *; rewrite Pregmap.gss in *; rewrite STUCK in H5; inv H5. *) +(* Qed. *) + +(* Lemma asm_to_ir_returnstate_ccc *) +(* cpm (ge: genv) n n0 *) +(* (LT: (n0 < n)%nat) *) +(* (IH: forall y : nat, *) +(* (y < n)%nat -> *) +(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) +(* wf_ge ge -> *) +(* wf_asm ge ast -> *) +(* star_measure (step_fix cpm) ge y ast tr ast' -> *) +(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) +(* match_state ge k m_a0 d ast ist -> *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) +(* (WFGE: wf_ge ge) *) +(* cur ik *) +(* (WFIR0 : wf_ir_cur ge cur) *) +(* (WFIR1 : wf_ir_conts ge ik) *) +(* st (rs: regset) *) +(* (WFASM1: wf_stack ge st) *) +(* (MTST0 : match_cur_stack_sig cur ge st) *) +(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) +(* (MTST2 : match_stack ge ik st) *) +(* k d m_a0 m_i m_a *) +(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) +(* t' ast' *) +(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) +(* t'' ast'' *) +(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) +(* (CCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) = Genv.CrossCompartmentCall) *) +(* : *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) +(* Proof. *) +(* assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). *) +(* { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. *) +(* des_ifs. eapply wf_ge_block_to_id; eauto. *) +(* } *) +(* des. rename H into IDCUR. *) +(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* (** step --- ReturnState *) *) +(* inv STEP. inv EV; simpl in *. *) +(* { rewrite CCC in H. congruence with H. } *) +(* clear H. specialize (CHECKPUB CCC). *) +(* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) +(* unfold Genv.type_of_call in CCC. des_ifs. clear CCC. unfold update_stack_return in STUPD. *) +(* rewrite Pos.eqb_sym in Heq. rewrite Heq in STUPD. des_ifs. *) +(* pose proof Heq as NEQ. eapply Pos.eqb_neq in NEQ. specialize (PC_RA NEQ). *) +(* destruct s as [b3 cp3 sig3 rv3 ptr3]. simpl in *. *) +(* inv WFASM1. simpl in *. des_ifs. clear H2. inv MTST2. *) +(* hexploit mem_delta_apply_establish_inject. eapply MEM0. 1,2,3,4: eauto. *) +(* { clear - CHECKPUB. ii. unfold public_first_order in CHECKPUB. unfold meminj_public in H. des_ifs. *) +(* eapply CHECKPUB; eauto. apply Senv.invert_find_symbol; auto. *) +(* } *) +(* intros (m_i' & APPD & MEMINJ). *) +(* exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. *) +(* { simpl. split; auto. unfold wf_regset. rewrite PC_RA. rewrite Heq0. auto. } *) +(* { instantiate (4:=(meminj_public ge)). instantiate (3:=m_a). instantiate (2:=[]). *) +(* instantiate (1:=Some (next, m_i', ik_tl)). simpl. splits; auto. *) +(* { inv WFIR1. simpl in *. auto. } *) +(* { inv WFIR1. auto. } *) +(* { unfold match_cur_regset. rewrite COMP. rewrite PC_RA. auto. } *) +(* { rr; splits; auto. eapply meminj_not_alloc_delta; eauto. ss. eapply public_rev_perm_delta_apply_inj; eauto. *) +(* } *) +(* } *) +(* intros (btr & ist' & UTR & ISTAR'). *) +(* exists ((id_cur, Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs PC)) (Genv.find_comp ge (Vptr cur Ptrofs.zero)) res] res d) :: btr), ist'. *) +(* simpl. rewrite UTR. split; auto. *) +(* econstructor 2. 2: eapply ISTAR'. 2: auto. *) +(* inv WFIR1. simpl in *. des_ifs. clear H2. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. *) +(* eapply ir_step_cross_return_internal. 6: eapply Heq1. all: eauto. *) +(* { rewrite COMP. rewrite PC_RA. simpl. auto. } *) +(* { constructor; auto. *) +(* { unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. } *) +(* { replace (funsig (Internal f2)) with sig3; auto. unfold match_cur_stack_sig in MTST0. des_ifs. } *) +(* } *) +(* { hexploit public_rev_perm_delta_apply_inj. eauto. eapply APPD. intros REVP. clear - MEMINJ CHECKPUB REVP. *) +(* unfold public_first_order in *. i. *) +(* exploit Senv.find_invert_symbol; eauto. intros INV. *) +(* assert (PERM: Mem.perm m_a b ofs Cur Readable). *) +(* { specialize (REVP b). unfold meminj_public in REVP. rewrite INV, PUBLIC in REVP. apply REVP. rewrite Z.add_0_r. auto. } *) +(* eapply loc_first_order_memval_inject_preserves. eapply CHECKPUB; eauto. *) +(* instantiate (1:=ge). inv MEMINJ. inv mi_inj. replace ofs with (ofs + 0)%Z at 2 by lia. eapply mi_memval; auto. *) +(* unfold meminj_public. rewrite INV, PUBLIC. auto. *) +(* } *) +(* Qed. *) + +(* Lemma asm_to_ir_returnstate_undef *) +(* cpm (ge: genv) n n0 *) +(* (LT: (n0 < n)%nat) *) +(* (IH: forall y : nat, *) +(* (y < n)%nat -> *) +(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) +(* wf_ge ge -> *) +(* wf_asm ge ast -> *) +(* star_measure (step_fix cpm) ge y ast tr ast' -> *) +(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) +(* match_state ge k m_a0 d ast ist -> *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) +(* (WFGE: wf_ge ge) *) +(* cur ik *) +(* (WFIR0 : wf_ir_cur ge cur) *) +(* (WFIR1 : wf_ir_conts ge ik) *) +(* st (rs: regset) *) +(* (WFASM1: wf_stack ge st) *) +(* (MTST0 : match_cur_stack_sig cur ge st) *) +(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) +(* (MTST2 : match_stack ge ik st) *) +(* k d m_a0 m_i m_a *) +(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) +(* (RSX: rs X1 = Vundef) *) +(* t' ast' *) +(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) +(* t'' ast'' *) +(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) +(* : *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) +(* Proof. *) +(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* (** step --- ReturnState *) *) +(* pose proof STEP as STEP0. inv STEP. inv EV; simpl in *. *) +(* (** return is nccc *) *) +(* { rename H into NCCC. pose proof STAR as STAR0. inv STAR. *) +(* (* end case *) *) +(* { end_case. } *) +(* (* has next step - if internal, done; if external, ub by RSX *) *) +(* rename H into STEP, H0 into STAR. exploit asm_step_current_pc. eapply STEP. intros (b1 & ofs1 & NEXTPC). *) +(* exploit asm_step_some_fundef. eapply STEP. eapply NEXTPC. intros (fd & NEXTF). *) +(* destruct fd. *) +(* (** next is internal *) *) +(* { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. *) +(* 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. *) +(* } *) +(* (** next is external --- undef *) *) +(* { exploit asm_to_ir_returnstate_undef_nccc_external. 2: eapply IH. *) +(* 12: eapply STAR0. 11: eapply STEP0. all: eauto. rr; splits; eauto. *) +(* } *) +(* } *) +(* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) +(* { exploit asm_to_ir_returnstate_ccc. 2: eapply IH. *) +(* 11: eapply STAR. 10: eapply STEP0. all: eauto. rr; splits; eauto. *) +(* } *) +(* Qed. *) + +(* Lemma asm_to_ir_returnstate_nccc_external *) +(* cpm (ge: genv) n n0 *) +(* (LT: (n0 < n)%nat) *) +(* (IH: forall y : nat, *) +(* (y < n)%nat -> *) +(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) +(* wf_ge ge -> *) +(* wf_asm ge ast -> *) +(* star_measure (step_fix cpm) ge y ast tr ast' -> *) +(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) +(* match_state ge k m_a0 d ast ist -> *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) +(* (WFGE: wf_ge ge) *) +(* cur ik *) +(* (WFIR0 : wf_ir_cur ge cur) *) +(* (WFIR1 : wf_ir_conts ge ik) *) +(* st (rs: regset) *) +(* (WFASM1: wf_stack ge st) *) +(* (MTST0 : match_cur_stack_sig cur ge st) *) +(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) +(* (MTST2 : match_stack ge ik st) *) +(* k d m_a0 m_i m_a *) +(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) +(* t' ast' *) +(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) +(* t'' ast'' *) +(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) +(* (NCCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) <> Genv.CrossCompartmentCall) *) +(* b1 ofs1 *) +(* (NEXTPC: rs PC = Vptr b1 ofs1) *) +(* ef *) +(* (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) *) +(* : *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) +(* Proof. *) +(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* (** step --- ReturnState *) *) +(* inv STEP. inv EV; simpl in *. *) +(* 2:{ rewrite H in NCCC. congruence with NCCC. } *) +(* (** return is nccc *) *) +(* clear H. pose proof STAR as STAR0. inv STAR. *) +(* (* end case *) *) +(* { end_case. } *) +(* (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) *) +(* (* take a step *) *) +(* rename H into STEP, H0 into STAR. *) + +(* assert (st' = st). *) +(* { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) +(* subst st'. *) +(* exploit asm_to_ir_step_external. *) +(* 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. *) +(* all: eauto. *) +(* { rr; splits; eauto. } *) +(* clear STEP STAR. *) +(* intros (btr1 & k' & d' & m_a0' & m_i' & m_a' & UTR1 & ISTAR1 & MM' & (res & STAR)). *) +(* eapply asm_to_ir_compose. 2: eauto. do 2 eexists. split; eauto. clear btr1 UTR1 ISTAR1. *) + +(* inv STAR. *) +(* (* end case *) *) +(* { exists []. eexists. split; auto. econstructor 1. } *) +(* (* now at Returnstate *) *) +(* eapply asm_to_ir_returnstate_undef. 2: eapply IH. 12: eapply H0. 11: eapply H. *) +(* all: eauto. lia. *) +(* { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } *) +(* Qed. *) + +(* Lemma asm_to_ir_returnstate *) +(* cpm (ge: genv) n n0 *) +(* (LT: (n0 < n)%nat) *) +(* (IH: forall y : nat, *) +(* (y < n)%nat -> *) +(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) +(* wf_ge ge -> *) +(* wf_asm ge ast -> *) +(* star_measure (step_fix cpm) ge y ast tr ast' -> *) +(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) +(* match_state ge k m_a0 d ast ist -> *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) +(* (WFGE: wf_ge ge) *) +(* cur ik *) +(* (WFIR0 : wf_ir_cur ge cur) *) +(* (WFIR1 : wf_ir_conts ge ik) *) +(* st (rs: regset) *) +(* (WFASM1: wf_stack ge st) *) +(* (MTST0 : match_cur_stack_sig cur ge st) *) +(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) +(* (MTST2 : match_stack ge ik st) *) +(* k d m_a0 m_i m_a *) +(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) +(* t' ast' *) +(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) +(* t'' ast'' *) +(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) +(* : *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) +(* Proof. *) +(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* (** step --- ReturnState *) *) +(* pose proof STEP as STEP0. inv STEP. inv EV; simpl in *. *) +(* (** return is nccc *) *) +(* { rename H into NCCC. pose proof STAR as STAR0. inv STAR. *) +(* (* end case *) *) +(* { end_case. } *) +(* (* has next step - if internal, done; if external, one external step and X1 = undef *) *) +(* rename H into STEP, H0 into STAR. exploit asm_step_current_pc. eapply STEP. intros (b1 & ofs1 & NEXTPC). *) +(* exploit asm_step_some_fundef. eapply STEP. eapply NEXTPC. intros (fd & NEXTF). *) +(* destruct fd. *) +(* (** next is internal *) *) +(* { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. *) +(* 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. *) +(* } *) +(* (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) *) +(* { exploit asm_to_ir_returnstate_nccc_external. 2: eapply IH. *) +(* 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. *) +(* } *) +(* } *) +(* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) +(* { exploit asm_to_ir_returnstate_ccc. 2: eapply IH. *) +(* 11: eapply STAR. 10: eapply STEP0. all: eauto. rr; splits; eauto. *) +(* } *) +(* Qed. *) + +(* Lemma asm_to_ir_nccc_internal *) +(* cpm ge n n' *) +(* (LT: (n < n')%nat) *) +(* (IH: forall y : nat, *) +(* (y < n')%nat -> *) +(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) +(* wf_ge ge -> *) +(* wf_asm ge ast -> *) +(* star_measure (step_fix cpm) ge y ast tr ast' -> *) +(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) +(* match_state ge k m_a0 d ast ist -> *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) +(* m_a0 ast' *) +(* (WFGE: wf_ge ge) *) +(* rs m st *) +(* (WFASM: wf_asm ge (State st rs m)) *) +(* ist k d *) +(* (MTST: match_state ge k m_a0 d (State st rs m) ist) *) +(* t2 rs' m' *) +(* (STAR: star_measure (step_fix cpm) ge n (State st rs' m') t2 ast') *) +(* b ofs f i b' ofs' *) +(* (H0: rs PC = Vptr b ofs) *) +(* (H1: Genv.find_funct_ptr ge b = Some (Internal f)) *) +(* (H2: find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i) *) +(* (H3: exec_instr ge f i rs m (comp_of f) = Next rs' m') *) +(* (NEXTPC: rs' PC = Vptr b' ofs') *) +(* (ALLOWED: comp_of f = Genv.find_comp_ignore_offset ge (Vptr b' ofs')) *) +(* : *) +(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t2 /\ istar ir_step ge ist btr ist'. *) +(* Proof. *) +(* destruct (Genv.find_funct_ptr ge b') eqn:NEXTF. *) +(* (* no next function *) *) +(* 2:{ move STAR after NEXTF. inv STAR. *) +(* (* end case *) *) +(* { end_case. } *) +(* (* take a step *) *) +(* { inv H. *) +(* (* invalid *) *) +(* all: exfalso; rewrite NEXTPC in H8; inv H8; rewrite NEXTF in H9; inv H9. *) +(* } *) +(* } *) +(* unfold match_state in MTST. destruct ist as [[[cur m_i] ik] |]. *) +(* 2:{ inv MTST. } *) +(* destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* exploit mem_delta_exec_instr. eapply MEM3. eapply H3. *) +(* { replace (comp_of f) with (Genv.find_comp ge (Vptr cur Ptrofs.zero)). eapply MEM4. *) +(* rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. auto. *) +(* } *) +(* eapply MEM5. auto. intros (d' & MEM4' & MEM5'). *) +(* destruct f0. *) + +(* (** has next function --- internal *) *) +(* { assert (WFASM': wf_asm ge (State st rs' m')). *) +(* { clear IH. unfold wf_asm in *. destruct WFASM as [WFASM0 WFASM1]. split; [auto|]. *) +(* unfold wf_regset in *. rewrite H0, H1 in WFASM1. rewrite NEXTPC, NEXTF. auto. *) +(* } *) +(* assert (MTST': match_state ge k m_a0 d' (State st rs' m') (Some (cur, m_i, ik))). *) +(* { clear IH. split. auto. split. auto. split. auto. split. *) +(* { unfold match_cur_regset in *. rewrite NEXTPC. rewrite <- ALLOWED. rewrite MTST1. *) +(* unfold Genv.find_comp_ignore_offset. rewrite H0. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. *) +(* rewrite H1. auto. *) +(* } *) +(* split. auto. *) +(* { unfold match_mem. splits; auto. *) +(* eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. *) +(* { replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. *) +(* rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. auto. *) +(* } *) +(* eapply public_rev_perm_exec_instr. 3: eapply H3. all: auto. *) +(* } *) +(* } *) +(* exploit IH. 4: eapply STAR. 3: apply WFASM'. 3: eapply MTST'. all: auto. *) +(* } *) + +(* (** has next function --- external *) *) +(* { move STAR after NEXTF. inv STAR. *) +(* (* end case *) *) +(* { end_case. } *) +(* (* take a step *) *) +(* destruct WFASM as [WFASM0 WFASM1]. *) +(* exploit asm_to_ir_step_external. 12: eapply H4. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply H. all: eauto. *) +(* { inv H. *) +(* 1,2,3,4: rewrite NEXTPC in H8; inv H8; rewrite NEXTF in H9; inv H9. *) +(* rewrite <- REC_CURCOMP. rewrite H8. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H8; inv H8. rewrite <- ALLOWED. *) +(* unfold Genv.find_comp. setoid_rewrite H1. auto. *) +(* } *) +(* { instantiate (4:=k). instantiate (3:=d'). unfold match_mem. splits; eauto. *) +(* eapply public_not_freeable_exec_instr; eauto. eapply meminj_not_alloc_delta; eauto. *) +(* { replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. *) +(* rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. auto. *) +(* } *) +(* eapply public_rev_perm_exec_instr; eauto. *) +(* } *) +(* intros (btr' & k' & d'0 & m_a0' & m_i' & m_a' & UTR' & ISTAR' & MM' & (res' & STAR')). *) +(* eapply asm_to_ir_compose. 2: eauto. *) +(* exists btr'. eexists. split. *) +(* { split; auto. eapply ISTAR'. } *) +(* clear btr' UTR' ISTAR'. rename H into STEP0, H4 into STAR0. *) +(* inv STAR'. *) +(* { end_case. } *) +(* exploit asm_to_ir_returnstate_undef. 2: eapply IH. 12: eapply H4. 11: eapply H. 9: eapply MM'. all: eauto. *) +(* { lia. } *) +(* { inv STEP0. *) +(* 1,2,3,4: rewrite NEXTPC in H8; inv H8; rewrite NEXTF in H9; inv H9. *) +(* rewrite <- REC_CURCOMP. rewrite H8. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H8; inv H8. rewrite <- ALLOWED. *) +(* unfold Genv.find_comp. setoid_rewrite H1. auto. *) +(* } *) +(* { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } *) +(* } *) +(* Qed. *) + +(* Lemma asm_to_ir_ccc_external1 *) +(* ge rs cur *) +(* (MTST1 : match_cur_regset cur ge rs) *) +(* rs' e b ofs f args *) +(* (H0 : rs PC = Vptr b ofs) *) +(* (H1 : Genv.find_funct_ptr ge b = Some (Internal f)) *) +(* ofs0 b0 *) +(* (ALLOWED : Genv.allowed_call ge (comp_of f) (Vptr b0 Ptrofs.zero)) *) +(* (NEXTPC : rs' PC = Vptr b0 ofs0) *) +(* (TYPEC : Genv.type_of_call ge (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) = Genv.CrossCompartmentCall) *) +(* (NO_CROSS_PTR : Forall not_ptr args) *) +(* (CALLSIG : Genv.find_funct_ptr ge b0 = Some (External e)) *) +(* vl i0 *) +(* (H3 : Genv.invert_symbol ge b0 = Some i0) *) +(* (H4 : eventval_list_match ge vl (sig_args (ef_sig e)) args) *) +(* : *) +(* exists cp cp' sg, *) +(* (cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) /\ *) +(* (Genv.find_symbol ge i0 = Some b0) /\ *) +(* (Genv.find_funct ge (Vptr b0 Ptrofs.zero) = Some (External e)) /\ *) +(* (cp' = comp_of e) /\ *) +(* (Genv.allowed_call ge cp (Vptr b0 Ptrofs.zero)) /\ *) +(* (crossing_comp ge cp cp' -> Forall not_ptr args) /\ *) +(* (sg = ef_sig e) /\ *) +(* (call_trace_cross ge cp cp' b0 args (sig_args sg) [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl). *) +(* Proof. *) +(* assert (EQC : Genv.find_comp ge (Vptr b Ptrofs.zero) = comp_of f). *) +(* { unfold Genv.find_comp. setoid_rewrite H1. auto. } *) +(* assert (EQC2 : Genv.find_comp ge (Vptr b0 Ptrofs.zero) = comp_of e). *) +(* { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } *) +(* do 3 eexists. *) +(* ss. splits; auto. *) +(* - eapply Genv.invert_find_symbol; auto. *) +(* - replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. *) +(* - econs; auto. *) +(* + unfold Genv.type_of_call. *) +(* replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. *) +(* replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. *) +(* + replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. *) +(* replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. *) +(* Qed. *) + +(* Lemma arguments_same *) +(* rs m sig args1 args2 *) +(* (CARGS: call_arguments rs m sig args1) *) +(* (EARGS: extcall_arguments rs m sig args2) *) +(* : *) +(* args1 = args2. *) +(* Proof. *) +(* unfold call_arguments in CARGS. unfold extcall_arguments in EARGS. *) +(* unfold Conventions.loc_parameters in CARGS. remember (Conventions1.loc_arguments sig) as clas. clear dependent sig. *) +(* move args1 after rs. revert_until args1. induction args1; ss; intros. *) +(* { inv CARGS. symmetry in H0. apply map_eq_nil in H0. subst. inv EARGS. auto. } *) +(* inv CARGS. symmetry in H. apply map_eq_cons in H. des; clarify. *) +(* inv EARGS. f_equal. *) +(* 2:{ eapply IHargs1; eauto. } *) +(* clear - H2 H1. inv H1; ss. *) +(* - inv H2. inv H. *) +(* + ss. inv H1; auto. *) +(* + inv H1; auto. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H2, H5. rewrite H2 in H5. inv H5. auto. *) +(* - inv H2. inv H. *) +(* + inv H0. *) +(* * inv H4. inv H6. auto. *) +(* * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H1, H4. rewrite H1 in H4. inv H4. auto. *) +(* + inv H0. *) +(* * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H2, H5. rewrite H2 in H5. inv H5. auto. *) +(* * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H1, H2, H5, H7. rewrite H2 in H7. rewrite H1 in H5. clarify. *) +(* Qed. *) + + +(* (* If main is External, treat it as a different case - *) +(* the trace can start with Event_syscall, without a preceding Event_call *) *) +(* Theorem asm_to_ir *) +(* cpm (ge: genv) m_a0 *) +(* ast ast' tr *) +(* (WFGE: wf_ge ge) *) +(* (WFASM: wf_asm ge ast) *) +(* (STAR: star (Asm.step_fix cpm) ge ast tr ast') *) +(* ist k d *) +(* (MTST: match_state ge k m_a0 d ast ist) *) +(* : *) +(* exists btr ist', (unbundle_trace btr = tr) /\ (istar (ir_step) ge ist btr ist'). *) +(* Proof. *) +(* apply measure_star in STAR. destruct STAR as (n & STAR). *) +(* move n before ge. revert m_a0 ast ast' tr WFGE WFASM STAR ist k d MTST. *) +(* pattern n. apply (well_founded_induction Nat.lt_wf_0). intros n1 IH. intros. *) +(* inv STAR; subst. *) +(* (* end case *) *) +(* { end_case. } *) +(* rename H0 into STAR. inv H; simpl. *) + +(* - (** internal *) *) +(* eapply asm_to_ir_nccc_internal; eauto. *) + +(* - (** internal_call *) *) +(* assert (EQC: (Genv.find_comp_ignore_offset ge (Vptr b Ptrofs.zero)) = (comp_of f)). *) +(* { ss. unfold Genv.find_comp. setoid_rewrite H1. auto. } *) +(* destruct (Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs'))) eqn:TYPEC. *) +(* (* case nccc: same as the previous *) *) +(* { assert (st' = st). *) +(* { unfold Genv.type_of_call in TYPEC. des_ifs. unfold update_stack_call in STUPD. rewrite EQC in STUPD. rewrite NEXTPC, Heq in STUPD. inv STUPD. auto. } *) +(* subst. *) +(* exploit asm_to_ir_nccc_internal. 2: eapply IH. 5: eapply STAR. all: eauto. rewrite <- EQC; auto. *) +(* { unfold Genv.type_of_call in TYPEC. des_ifs. rewrite Pos.eqb_eq in Heq. auto. } *) +(* intros RES. inv EV. simpl. apply RES. rewrite TYPEC in H. inv H. *) +(* } *) + +(* (* case ccc *) *) +(* { destruct ist as [[[cur m_i] ik] |]; ss. *) +(* destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). *) +(* destruct WFASM as [WFASM0 WFASM1]. *) +(* specialize (CALLSIG eq_refl). des. *) +(* exploit exec_instr_is_call; eauto. clear H2 H3 H4. intros (RSX & MEM). subst m'. *) +(* assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). *) +(* { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. *) +(* des_ifs. eapply wf_ge_block_to_id; eauto. *) +(* } *) +(* des. rename H into IDCUR. *) +(* destruct fd. *) +(* (* calling internal function *) *) +(* { inv EV. *) +(* { rewrite TYPEC in H. clarify. } *) +(* clear H. clarify. unfold update_stack_call in STUPD. des_ifs. *) +(* { unfold Genv.type_of_call in TYPEC. rewrite NEXTPC in Heq. rewrite <- EQC in TYPEC. ss. rewrite Heq in TYPEC. inv TYPEC. } *) +(* ss. eapply asm_to_ir_compose. *) +(* 2:{ instantiate (2:=[Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl]). simpl. eauto. } *) +(* assert (EQC2: (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) = comp_of f0). *) +(* { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } *) +(* specialize (CHECKPUB eq_refl). *) +(* pose proof MTST3 as MEM. destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) +(* hexploit mem_delta_apply_establish_inject. eapply MEM0. 1,2,3,4: eauto. *) +(* { clear - CHECKPUB. ii. unfold public_first_order in CHECKPUB. unfold meminj_public in H. des_ifs. *) +(* eapply CHECKPUB; eauto. apply Senv.invert_find_symbol; auto. *) +(* } *) +(* intros (m_i' & APPD & MEMINJ). *) +(* exists ([(id_cur, Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (fn_sig f0) d)]). eexists. split. *) +(* { simpl. split; auto. econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_cross_call_internal. *) +(* 7: eauto. 6: intros; eapply NO_CROSS_PTR; auto. 3: setoid_rewrite CALLSIG; auto. 3,4: eauto. *) +(* { rewrite MTST1. rewrite <- EQC, H0. simpl. auto. } *) +(* { apply Genv.invert_find_symbol; auto. } *) +(* { econs; auto. } *) +(* { replace (comp_of f) with (Genv.find_comp ge (Vptr cur Ptrofs.zero)). eapply APPD. rewrite MTST1. rewrite H0. ss. } *) +(* { hexploit public_rev_perm_delta_apply_inj. eauto. eapply APPD. intros REVP. clear - MEMINJ CHECKPUB REVP. *) +(* unfold public_first_order in *. i. *) +(* exploit Senv.find_invert_symbol; eauto. intros INV. *) +(* assert (PERM: Mem.perm m b ofs Cur Readable). *) +(* { specialize (REVP b). unfold meminj_public in REVP. rewrite INV, PUBLIC in REVP. apply REVP. rewrite Z.add_0_r. auto. } *) +(* eapply loc_first_order_memval_inject_preserves. eapply CHECKPUB; eauto. *) +(* instantiate (1:=ge). inv MEMINJ. inv mi_inj. replace ofs with (ofs + 0)%Z at 2 by lia. eapply mi_memval; auto. *) +(* unfold meminj_public. rewrite INV, PUBLIC. auto. *) +(* } *) +(* auto. *) +(* } *) +(* rewrite H0 in RSX. simpl in RSX. inv RSX. *) +(* eapply IH. 4: eapply STAR. all: auto. *) +(* { ss. split. *) +(* - econs; auto. ss. rewrite H1. auto. *) +(* - unfold wf_regset. rewrite NEXTPC. rewrite CALLSIG. auto. *) +(* } *) +(* unfold match_state. splits; eauto. *) +(* - unfold wf_ir_cur. rewrite CALLSIG. auto. *) +(* - econs; eauto. *) +(* - unfold match_cur_stack_sig. rewrite CALLSIG. ss. *) +(* - unfold match_cur_regset. rewrite NEXTPC. ss. *) +(* - econs; eauto. rewrite MTST1. rewrite H0. ss. *) +(* - instantiate (3:=(meminj_public ge)). instantiate (2:=[]). instantiate (1:=m). *) +(* rr; splits; auto. eapply meminj_not_alloc_delta; eauto. ss. eapply public_rev_perm_delta_apply_inj; eauto. *) +(* } *) +(* (* calling external function *) *) +(* { assert (EQC2: (Genv.find_comp ge (Vptr b' Ptrofs.zero)) = comp_of e). *) +(* { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } *) +(* inv EV. *) +(* { rewrite TYPEC in H. clarify. } *) +(* clear H. clarify. unfold update_stack_call in STUPD. des_ifs. *) +(* { unfold Genv.type_of_call in TYPEC. rewrite NEXTPC in Heq. rewrite <- EQC in TYPEC. ss. rewrite Heq in TYPEC. inv TYPEC. } *) +(* pose proof STAR as STAR0. move STAR after H4. *) +(* exploit asm_to_ir_ccc_external1. eapply MTST1. eapply H0. eapply H1. eapply ALLOWED. eapply NEXTPC. all: auto. eapply CALLSIG. eapply H3. eapply H4. *) +(* intros (cp & cp' & sg & FACT1 & FACT2 & FACT3 & FACT4 & FACT5 & FACT6 & FACT7 & FACT8). subst. *) +(* inv STAR; ss. *) +(* (* subcase 1 *) *) +(* { exists ([(id_cur, Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (ef_sig e) [])]). eexists. ss. split; auto. *) +(* econs 2. 2: econs 1. 2: eauto. eapply ir_step_cross_call_external1. *) +(* 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply FACT3. 2: eapply FACT2. all: eauto. *) +(* } *) +(* rename H into STEP, H2 into STAR, TYPEC into CCC, CALLSIG into NEXTF. inv STEP. *) +(* 1,2,3,4: rewrite NEXTPC in H6; inv H6; rewrite NEXTF in H7; inv H7. *) +(* rewrite NEXTPC in H6; inv H6. rewrite NEXTF in H7; inv H7. ss. clear REC_CURCOMP. rename H8 into EXTCALL, H11 into EXTARGS. *) +(* assert (NEQCP: comp_of f <> comp_of ef). *) +(* { rewrite <- EQC2. clear - CCC. intros CC. unfold Genv.type_of_call in CCC. rewrite CC in CCC. rewrite Pos.eqb_refl in CCC. inv CCC. } *) +(* exploit extcall_cases. eapply ECC. eapply EXTCALL. clear ECC. rewrite <- or_assoc. intros [ECC | ECC]. *) +(* 2:{ exfalso. clear - NEXTF NEQCP ALLOWED ECC. destruct ALLOWED as [A | A]. *) +(* { rewrite A in NEQCP. unfold Genv.find_comp in NEQCP. setoid_rewrite NEXTF in NEQCP. auto. } *) +(* unfold Genv.allowed_cross_call in A. destruct A as (i & cp' & INV & OK & _). unfold Genv.find_funct_ptr in NEXTF. specialize (OK _ NEXTF). *) +(* destruct ef; ss; clarify. des_ifs. des_ifs. *) +(* { destruct ECC as [ECC1 ECC2]. subst. inv ECC1. } *) +(* { destruct ECC as [ECC1 ECC2]. subst. inv ECC1. } *) +(* } *) +(* exploit arguments_same; eauto. intros EQ. subst args0. *) +(* exploit match_mem_external_call_establish; eauto. intros. *) +(* destruct x0 as (d' & m1 & m2 & res' & EFACT1 & EFACT2 & EFACT3 & (k2 & d2 & m_a02 & MM)). *) +(* inv STAR. *) +(* (* subcase 2 *) *) +(* { exists ([(id_cur, Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1) i0 vl (ef_sig ef) (d'))]). eexists. split; auto. *) +(* econs 2. 2: econs 1. 2: eauto. eapply ir_step_cross_call_external2. *) +(* 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply FACT3. 2: eapply FACT2. all: eauto. *) +(* erewrite eventval_list_match_vals_to_eventvals; eauto. *) +(* } *) +(* rename H into STEP, H2 into STAR. inv STEP. ss. rewrite Pregmap.gss in *. destruct MM as [MM VAL]. *) +(* (* subcase 3 *) *) +(* pose proof WFIR0 as CUR. unfold wf_ir_cur in CUR. des_ifs. clear CUR. rename Heq1 into CUR. *) +(* unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. des_ifs. *) +(* { exfalso. rewrite Heq0, RSX, H0 in Heq1. ss. rewrite Pos.eqb_sym, Heq in Heq1. congruence with Heq1. } *) +(* clear PC_RA. inv EV. *) +(* { exfalso. apply H. rewrite Heq0, RSX, H0. ss. unfold Genv.type_of_call. rewrite Heq. auto. } *) +(* assert (RES: (return_value (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) (ef_sig ef)) = res). *) +(* { exploit NO_CROSS_PTR0; auto. clear. intros NPTR. *) +(* unfold return_value, loc_external_result in *. remember (Conventions1.loc_result (ef_sig ef)) as rpmr. *) +(* unfold Conventions1.loc_result in Heqrpmr. des_ifs. *) +(* ss. rewrite ! (Pregmap.gso (j:=PC)) in *; ss. rewrite ! Pregmap.gss in *. rewrite Pregmap.gso, Pregmap.gss in *; ss. *) +(* unfold Val.longofwords, Val.hiword, Val.loword in *. des_ifs. *) +(* rewrite Int64.ofwords_recompose. auto. *) +(* } *) +(* eapply asm_to_ir_compose. *) +(* 2:{ instantiate (1:=t3). rewrite app_comm_cons. setoid_rewrite app_assoc. eauto. } *) +(* exists ([(id_cur, Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1 ++ [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0]) i0 vl (ef_sig ef) (d'))]). eexists. split. *) +(* { split; auto. *) +(* { ss. rewrite app_nil_r. auto. } *) +(* econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_cross_call_external3. *) +(* 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply NEXTF. 2: eapply FACT2. all: eauto. *) +(* { erewrite eventval_list_match_vals_to_eventvals; eauto. } *) +(* { intros. exploit NO_CROSS_PTR0; auto. rewrite RES. clear - VAL. intros. destruct VAL as [VAL | VAL]. *) +(* - pose proof Val.inject_list_not_ptr. specialize (H k2 [res] [res']). exploit H. econs; eauto. econs; eauto. intros. inv x1. auto. *) +(* - subst; auto. *) +(* } *) +(* { econs; eauto. *) +(* - setoid_rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. clear - NEQCP. *) +(* unfold Genv.type_of_call. rewrite <- Pos.eqb_neq in NEQCP. setoid_rewrite NEQCP. auto. *) +(* - instantiate (1:=res0). rewrite RES in H2, NO_CROSS_PTR0. exploit NO_CROSS_PTR0; auto. intros NPTR. *) +(* clear - H2 NPTR VAL. destruct VAL as [VAL | VAL]; subst; auto. remember (proj_rettype (sig_res (ef_sig ef))) as ty. clear dependent ef. *) +(* inv VAL; ss; eauto. *) +(* - f_equal. f_equal. rewrite Heq0, RSX. rewrite MTST1, H0. ss. rewrite NEXTPC. ss. *) +(* } *) +(* } *) +(* rewrite H0 in RSX. ss. inv RSX. eapply IH. 4: eapply STAR. all: auto. *) +(* { ss. splits; auto. unfold wf_regset in *. rewrite Pregmap.gss. rewrite Heq0. rewrite H1. auto. } *) +(* { ss. splits; auto. *) +(* - unfold match_cur_regset in *. rewrite Pregmap.gss. rewrite Heq0. rewrite MTST1. rewrite H0. ss. *) +(* - eauto. *) +(* } *) +(* } *) +(* } *) + +(* - (** internal_return *) *) +(* destruct ist as [[[cur m_i] ik] |]; ss. *) +(* destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). *) +(* destruct WFASM as [WFASM0 WFASM1]. *) +(* inv STAR. *) +(* { end_case. } *) +(* rename H into STEP, H5 into STAR. *) +(* exploit exec_instr_is_return. eapply H3. auto. intros ((v & NEXTPC) & TEMP). subst m'. *) +(* eapply asm_to_ir_returnstate. 2: eapply IH. 11: eapply STAR. 10: eapply STEP. *) +(* all: eauto. *) +(* { rewrite <- REC_CURCOMP. apply MTST1. } *) + +(* - (** return *) *) +(* exfalso. unfold wf_asm in WFASM. contradiction WFASM. *) + +(* - (** builtin *) *) +(* destruct ist as [[[cur m_i] ik] |]; ss. *) +(* exploit asm_to_ir_builtin; eauto. *) +(* destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). *) +(* clear dependent k. clear dependent d. clear dependent m_a0. *) +(* intros (btr1 & k & d & m_a & m_i' & UTR1 & ISTAR1 & MEM). *) +(* eapply asm_to_ir_compose. 2: eauto. exists btr1. eexists. split. *) +(* { split; eauto. } *) +(* clear dependent btr1. clear dependent m_i. rename m_i' into m_i. *) +(* destruct WFASM as [WFASM0 WFASM1]. *) +(* remember (nextinstr (set_res (map_builtin_res preg_of res) vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs # X1 <- Vundef) # X31 <- Vundef))) as rs'. *) +(* assert (NEXTPC: rs' PC = Val.offset_ptr (rs PC) Ptrofs.one). *) +(* { subst rs'. clear. unfold nextinstr. simpl. *) +(* rewrite Pregmap.gss. f_equal. rewrite ! Asmgenproof0.set_res_other; ss. *) +(* rewrite Asmgenproof0.undef_regs_other_2. *) +(* rewrite Pregmap.gso. rewrite Pregmap.gso. all: ss; auto. *) +(* rewrite Asmgenproof0.preg_notin_charact. intros. destruct mr; ss. *) +(* } *) +(* eapply IH. 4: eapply STAR. all: auto. *) +(* { simpl. split; auto. unfold wf_regset in *. rewrite NEXTPC, H0. simpl. rewrite H1. auto. } *) +(* { simpl. splits. 6: eapply MEM. all: auto. unfold match_cur_regset in *. *) +(* rewrite NEXTPC, H0. ss. rewrite MTST1, H0. ss. *) +(* } *) + +(* - (** external *) *) +(* exfalso. destruct WFASM as [WFASM0 WFASM1]. unfold wf_regset in WFASM1. *) +(* rewrite H0 in WFASM1. rewrite H1 in WFASM1. contradiction WFASM1. *) + +(* Qed. *) + +(* End PROOF. *) + +(* Section INIT. *) + +(* Definition wf_program {F V} (p: AST.program F V) := list_norepet (prog_defs_names p). *) + +(* Lemma wf_program_wf_ge *) +(* F V (p: AST.program F V) *) +(* (WFP: wf_program p) *) +(* : *) +(* wf_ge (Genv.globalenv p). *) +(* Proof. unfold wf_ge; eauto. Qed. *) + +(* Definition wf_main (p: Asm.program) := *) +(* exists b, (Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b) /\ *) +(* (exists f, Genv.find_funct_ptr (Genv.globalenv p) b = Some (Internal f)). *) + +(* Definition wf_main_sig (p: Asm.program) := *) +(* forall b f, (Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b) -> *) +(* (Genv.find_funct_ptr (Genv.globalenv p) b = Some (Internal f)) -> *) +(* fn_sig f = signature_main. *) + +(* Lemma wf_asm_initial_state *) +(* p ast *) +(* (WFMAIN: wf_main p) *) +(* (INIT: initial_state p ast) *) +(* : *) +(* wf_asm (Genv.globalenv p) ast. *) +(* Proof. *) +(* unfold wf_main in WFMAIN. des. inv INIT. unfold wf_asm. split. *) +(* { unfold initial_stack. ss. } *) +(* { unfold wf_regset. subst rs0. rewrite Pregmap.gso; ss. rewrite Pregmap.gso; ss. rewrite Pregmap.gss. *) +(* (* unfold fundef in *. *) *) +(* unfold Genv.symbol_address. subst ge. rewrite WFMAIN, WFMAIN0. auto. *) +(* } *) +(* Qed. *) + +(* Variant ir_initial_state (p: Asm.program): ir_state -> Prop := *) +(* | ir_initial_state_intro: forall cur m0, *) +(* let ge := Genv.globalenv p in *) +(* Genv.find_symbol ge (prog_main p) = Some cur -> *) +(* (exists f, Genv.find_funct_ptr ge cur = Some (Internal f)) -> *) +(* Genv.init_mem p = Some m0 -> *) +(* ir_initial_state p (Some (cur, m0, [])). *) + +(* Lemma ir_has_initial_state *) +(* p ast *) +(* (WFMAIN: wf_main p) *) +(* (INIT: Asm.initial_state p ast) *) +(* : *) +(* exists ist, ir_initial_state p ist. *) +(* Proof. *) +(* unfold wf_main in WFMAIN. des. inv INIT. *) +(* exists (Some (b, m0, [])). econs; eauto. *) +(* Qed. *) + +(* Lemma match_state_initial_state *) +(* p ast ist *) +(* (WFMAINSIG: wf_main_sig p) *) +(* (INITA: Asm.initial_state p ast) *) +(* (INITI: ir_initial_state p ist) *) +(* ge *) +(* (GE: ge = Genv.globalenv p) *) +(* : *) +(* exists m0 j, (Genv.init_mem p = Some m0) /\ (match_state ge j m0 [] ast ist). *) +(* Proof. *) +(* inv INITA. inv INITI. des. specialize (WFMAINSIG _ _ H0 H1). *) +(* clarify. exists m0, (Mem.flat_inj (Mem.nextblock m0)). esplits; eauto. unfold match_state. subst ge. splits. *) +(* - unfold wf_ir_cur. rewrite H1. auto. *) +(* - econs. *) +(* - unfold match_cur_stack_sig. rewrite H1. ss. *) +(* - unfold match_cur_regset. subst rs0. rewrite Pregmap.gso; ss. rewrite Pregmap.gso; ss. rewrite Pregmap.gss. *) +(* unfold Genv.symbol_address. subst ge0. rewrite H0. ss. *) +(* - econs. *) +(* - unfold match_mem. *) +(* assert (MNA: meminj_not_alloc (meminj_public (Genv.globalenv p)) m0). *) +(* { unfold meminj_not_alloc. intros. unfold meminj_public. des_ifs. exfalso. apply Senv.invert_find_symbol in Heq. exploit Genv.find_symbol_not_fresh. eauto. *) +(* eapply Heq. intros CC. unfold Mem.valid_block in CC. unfold Plt in CC. lia. *) +(* } *) +(* splits; ss; auto. *) +(* + eapply Genv.initmem_inject; eauto. *) +(* + ii. unfold meminj_public in H. unfold Mem.flat_inj. des_ifs. exfalso. *) +(* apply n; clear n. unfold Plt. destruct (Pos.ltb_spec b' (Mem.nextblock m0)); auto. *) +(* exfalso. specialize (MNA _ H). unfold meminj_public in MNA. rewrite Heq, Heq0 in MNA. clarify. *) +(* + ii. unfold meminj_public in H. des_ifs. clear - Heq Heq0 H3 H2. exploit Senv.invert_find_symbol; eauto. intros FIND. rename H2 into INITM, H3 into FREE. clear - INITM FREE FIND. *) +(* eapply Genv.find_symbol_find_def_inversion in FIND. des. destruct g. *) +(* * exploit Genv.init_mem_characterization_2; eauto. *) +(* { unfold Genv.find_funct_ptr. rewrite FIND. eauto. } *) +(* intros [CUR CC]. exploit CC. eapply FREE. intros. des; clarify. *) +(* * exploit Genv.init_mem_characterization; eauto. *) +(* { unfold Genv.find_var_info. rewrite FIND. eauto. } *) +(* intros [_ [CC [_ _]]]. exploit CC. eapply FREE. intros. des. clear - x1. unfold Genv.perm_globvar in x1. des_ifs; inv x1. *) +(* + ii. unfold meminj_public. des_ifs. intros. rewrite Z.add_0_r in H. auto. *) +(* Qed. *) + +(* End INIT. *) diff --git a/security/BtInfoAsmBound.v b/security/BtInfoAsmBound.v new file mode 100644 index 0000000000..12b2327213 --- /dev/null +++ b/security/BtInfoAsmBound.v @@ -0,0 +1,82 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Require Import riscV.Machregs. +Require Import riscV.Asm. +Require Import Complements. + +Require Import Tactics. +Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. + + + +(* Section AXIOM. *) + +(* Definition extcall_observable (sem: extcall_sem) (sg: signature): Prop := *) +(* forall ge vargs m1 t vres m2, *) +(* sem ge vargs m1 t vres m2 -> t <> E0. *) + +(* Definition external_functions_observable := *) +(* forall id sg, extcall_observable (external_functions_sem id sg) sg. *) + +(* Definition inline_assembly_observable := *) +(* forall cp id sg, extcall_observable (inline_assembly_sem cp id sg) sg. *) + +(* (* Axiom external_functions_observable: *) *) +(* (* forall id sg, extcall_observable (external_functions_sem id sg) sg. *) *) + +(* (* Axiom inline_assembly_observable: *) *) +(* (* forall cp id sg, extcall_observable (inline_assembly_sem cp id sg) sg. *) *) + +(* End AXIOM. *) + +(* Section BOUND. *) + +(* Hypothesis EFO: external_functions_observable. *) +(* Hypothesis IAO: inline_assembly_observable. *) + +(* Lemma external_call_observable_length *) +(* ef ge vargs m1 tr vretv m2 *) +(* (EC: external_call ef ge vargs m1 tr vretv m2) *) +(* (ECCASES : external_call_unknowns ef ge m1 vargs \/ *) +(* external_call_known_observables ef ge m1 vargs tr vretv m2) *) +(* : *) +(* (1 <= length tr)%nat. *) +(* Proof. *) +(* des. *) +(* - unfold external_functions_observable in EFO. unfold extcall_observable in EFO. *) +(* unfold inline_assembly_observable in IAO. unfold extcall_observable in IAO. *) +(* cut (tr <> E0). *) +(* { i. destruct tr; ss. lia. } *) +(* destruct ef; ss; eauto. *) +(* + unfold builtin_or_external_sem in EC. des_ifs; ss; eauto. *) +(* + unfold builtin_or_external_sem in EC. des_ifs; ss; eauto. *) +(* - destruct ef; ss; des; clarify; try (inv EC; ss). *) +(* + destruct tr; ss. lia. *) +(* + destruct tr; ss. lia. *) +(* Qed. *) + +(* Lemma bundle_trace_bounded *) +(* ge ist ist' btr *) +(* (ISTAR: istar (ir_step) ge ist btr ist') *) +(* : *) +(* (length btr <= length (unbundle_trace btr))%nat. *) +(* Proof. *) +(* induction ISTAR. ss. subst. ss. *) +(* apply Nat.succ_le_mono in IHISTAR. etransitivity. eauto. clear IHISTAR. *) +(* rewrite app_length. cut (1 <= length (unbundle ev))%nat. lia. *) +(* unfold unbundle. *) +(* inv H; ss. *) +(* - inv TR; ss. *) +(* - inv TR; ss. *) +(* - eapply external_call_observable_length; eauto. des; auto. *) +(* - eapply external_call_observable_length; eauto. des; auto. *) +(* - inv TR; ss. *) +(* - inv TR1; ss. lia. *) +(* - inv TR1; ss. lia. *) +(* Qed. *) + +(* End BOUND. *) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v new file mode 100644 index 0000000000..11e96b8511 --- /dev/null +++ b/security/MemoryDelta.v @@ -0,0 +1,1165 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. +Require Import MemoryWeak. +Require Import Tactics. + +Section AUX. + +(* Lemma alloc_left_unmapped_winject_keep: *) +(* forall f m1 m2 c lo hi m1' b1, *) +(* winject f m1 m2 -> *) +(* Mem.alloc m1 c lo hi = (m1', b1) -> *) +(* winject f m1' m2. *) +(* Proof. *) +(* intros. set (f' := fun b => if eq_block b b1 then None else f b). *) +(* cut (winject f' m1' m2 /\ inject_incr f f' /\ f' b1 = None /\ (forall b, b <> b1 -> f' b = f b)). *) +(* { clear - f'. intros (INJ & INCR & _ & _). unfold inject_incr in INCR. *) +(* assert (f' = f). *) +(* { eapply Axioms.functional_extensionality. intros x. destruct (eq_block x b1). *) +(* - subst x. destruct (f b1) eqn:FB. *) +(* + destruct p. specialize (INCR _ _ _ FB). auto. *) +(* + subst f'. simpl. rewrite pred_dec_true; auto. *) +(* - subst f'. simpl. rewrite pred_dec_false; auto. *) +(* } *) +(* rewrite <- H. apply INJ. *) +(* } *) +(* inversion H. assert (inject_incr f f'). *) +(* red; unfold f'; intros. destruct (eq_block b b1). subst b. *) +(* assert (f b1 = None). eauto with mem. congruence. *) +(* auto. *) +(* assert (mem_winj f' m1 m2). *) +(* inversion mwi_inj; constructor; eauto with mem. *) +(* unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. *) +(* unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. *) +(* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) +(* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) +(* eapply mwi_align; eauto. *) +(* split. constructor. *) +(* (* inj *) *) +(* eapply alloc_left_unmapped_winj; eauto. unfold f'; apply dec_eq_true. *) +(* (* freeblocks *) *) +(* intros. unfold f'. destruct (eq_block b b1). auto. *) +(* apply mi_freeblocks. red; intro; elim H3. eauto with mem. *) +(* (* mappedblocks *) *) +(* unfold f'; intros. destruct (eq_block b b1). congruence. eauto. *) +(* (* no overlap *) *) +(* unfold f'; red; intros. *) +(* destruct (eq_block b0 b1); destruct (eq_block b2 b1); try congruence. *) +(* eapply mwi_no_overlap. eexact H3. eauto. eauto. *) +(* exploit Mem.perm_alloc_inv. eauto. eexact H6. rewrite dec_eq_false; auto. *) +(* exploit Mem.perm_alloc_inv. eauto. eexact H7. rewrite dec_eq_false; auto. *) +(* (* representable *) *) +(* unfold f'; intros. *) +(* destruct (eq_block b b1); try discriminate. *) +(* eapply mwi_representable; try eassumption. *) +(* destruct H4; eauto using Mem.perm_alloc_4. *) +(* (* perm inv *) *) +(* intros. unfold f' in H3; destruct (eq_block b0 b1); try discriminate. *) +(* exploit mwi_perm_inv; eauto. *) +(* intuition eauto using Mem.perm_alloc_1, Mem.perm_alloc_4. *) +(* (* incr *) *) +(* split. auto. *) +(* (* image *) *) +(* split. unfold f'; apply dec_eq_true. *) +(* (* incr *) *) +(* intros; unfold f'; apply dec_eq_false; auto. *) +(* Qed. *) + +(* Lemma alloc_left_unmapped_inject_keep: *) +(* forall f m1 m2 c lo hi m1' b1, *) +(* Mem.inject f m1 m2 -> *) +(* Mem.alloc m1 c lo hi = (m1', b1) -> *) +(* Mem.inject f m1' m2. *) +(* Proof. *) +(* intros. set (f' := fun b => if eq_block b b1 then None else f b). *) +(* cut (Mem.inject f' m1' m2 /\ inject_incr f f' /\ f' b1 = None /\ (forall b, b <> b1 -> f' b = f b)). *) +(* { clear - f'. intros (INJ & INCR & _ & _). unfold inject_incr in INCR. *) +(* assert (f' = f). *) +(* { eapply Axioms.functional_extensionality. intros x. destruct (eq_block x b1). *) +(* - subst x. destruct (f b1) eqn:FB. *) +(* + destruct p. specialize (INCR _ _ _ FB). auto. *) +(* + subst f'. simpl. rewrite pred_dec_true; auto. *) +(* - subst f'. simpl. rewrite pred_dec_false; auto. *) +(* } *) +(* rewrite <- H. apply INJ. *) +(* } *) +(* inversion H. assert (inject_incr f f'). *) +(* red; unfold f'; intros. destruct (eq_block b b1). subst b. *) +(* assert (f b1 = None). eauto with mem. congruence. *) +(* auto. *) +(* assert (Mem.mem_inj f' m1 m2). *) +(* inversion mi_inj; constructor; eauto with mem. *) +(* unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. *) +(* unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. *) +(* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) +(* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) +(* eapply mi_align; eauto. *) +(* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) +(* apply memval_inject_incr with f; auto. *) +(* split. constructor. *) +(* (* inj *) *) +(* eapply Mem.alloc_left_unmapped_inj; eauto. unfold f'; apply dec_eq_true. *) +(* (* freeblocks *) *) +(* intros. unfold f'. destruct (eq_block b b1). auto. *) +(* apply mi_freeblocks. red; intro; elim H3. eauto with mem. *) +(* (* mappedblocks *) *) +(* unfold f'; intros. destruct (eq_block b b1). congruence. eauto. *) +(* (* no overlap *) *) +(* unfold f'; red; intros. *) +(* destruct (eq_block b0 b1); destruct (eq_block b2 b1); try congruence. *) +(* eapply mi_no_overlap. eexact H3. eauto. eauto. *) +(* exploit Mem.perm_alloc_inv. eauto. eexact H6. rewrite dec_eq_false; auto. *) +(* exploit Mem.perm_alloc_inv. eauto. eexact H7. rewrite dec_eq_false; auto. *) +(* (* representable *) *) +(* unfold f'; intros. *) +(* destruct (eq_block b b1); try discriminate. *) +(* eapply mi_representable; try eassumption. *) +(* destruct H4; eauto using Mem.perm_alloc_4. *) +(* (* perm inv *) *) +(* intros. unfold f' in H3; destruct (eq_block b0 b1); try discriminate. *) +(* exploit mi_perm_inv; eauto. *) +(* intuition eauto using Mem.perm_alloc_1, Mem.perm_alloc_4. *) +(* (* incr *) *) +(* split. auto. *) +(* (* image *) *) +(* split. unfold f'; apply dec_eq_true. *) +(* (* incr *) *) +(* intros; unfold f'; apply dec_eq_false; auto. *) +(* Qed. *) + +End AUX. + + +(* Section PUBINJ. *) + + (* (* Memory injection for public global symbols: visible for external calls *) *) + (* Definition meminj_public (ge: Senv.t): meminj := *) + (* fun b => match Senv.invert_symbol ge b with *) + (* | Some id => if Senv.public_symbol ge id then Some (b, 0%Z) else None *) + (* | None => None *) + (* end. *) + +(* Definition meminj_strict (j: meminj) := forall b1 b2 b' ofsd1 ofsd2, j b1 = Some (b', ofsd1) -> j b2 = Some (b', ofsd2) -> b1 = b2. *) + +(* Lemma meminj_public_strict ge: meminj_strict (meminj_public ge). *) +(* Proof. *) +(* unfold meminj_strict. intros. unfold meminj_public in *; simpl in *. *) +(* destruct (Senv.invert_symbol ge b1) eqn:INV1. 2: congruence. destruct (Senv.public_symbol ge i) eqn:PUB1. 2: congruence. inv H. *) +(* destruct (Senv.invert_symbol ge b2) eqn:INV2. 2: congruence. destruct (Senv.public_symbol ge i0) eqn:PUB2. 2: congruence. inv H0. *) +(* auto. *) +(* Qed. *) + +(* End PUBINJ. *) + +Section MEMDELTA. + + (** Memory delta data and apply *) + + (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) + Definition mem_delta_storev := (memory_chunk * val * val * compartment)%type. + Definition mem_delta_store := (memory_chunk * block * Z * val * compartment)%type. + Definition mem_delta_bytes := (block * Z * (list memval) * compartment)%type. + Definition mem_delta_alloc := (compartment * Z * Z)%type. + Definition mem_delta_free := (block * Z * Z * compartment)%type. + + Inductive mem_delta_kind := + | mem_delta_kind_storev (d: mem_delta_storev) + | mem_delta_kind_store (d: mem_delta_store) + | mem_delta_kind_bytes (d: mem_delta_bytes) + | mem_delta_kind_alloc (d: mem_delta_alloc) + | mem_delta_kind_free (d: mem_delta_free) + . + + (* order: old to new *) + Definition mem_delta := list mem_delta_kind. + + (* Definition mem_delta_apply_storev (om: option mem) (d: mem_delta_storev): option mem := *) + (* let '(ch, ptr, v, cp) := d in *) + (* match om with *) + (* | Some m => Mem.storev ch m ptr v cp *) + (* | None => None *) + (* end. *) + +(* Lemma mem_delta_apply_storev_none *) +(* d *) +(* : *) +(* mem_delta_apply_storev None d = None. *) +(* Proof. unfold mem_delta_apply_storev. destruct d as [[[d0 d2] d3] d4]. auto. Qed. *) + +(* Definition mem_delta_apply_store (om: option mem) (d: mem_delta_store): option mem := *) +(* let '(ch, b, ofs, v, cp) := d in *) +(* match om with *) +(* | Some m => Mem.store ch m b ofs v cp *) +(* | None => None *) +(* end. *) + +(* Lemma mem_delta_apply_store_none *) +(* d *) +(* : *) +(* mem_delta_apply_store None d = None. *) +(* Proof. unfold mem_delta_apply_store. destruct d as [[[[d0 d1] d2] d3] d4]. auto. Qed. *) + +(* Definition mem_delta_apply_bytes (om: option mem) (d: mem_delta_bytes): option mem := *) +(* let '(b, ofs, mvs, cp) := d in *) +(* match om with *) +(* | Some m => Mem.storebytes m b ofs mvs cp *) +(* | None => None *) +(* end. *) + +(* Lemma mem_delta_apply_bytes_none *) +(* d *) +(* : *) +(* mem_delta_apply_bytes None d = None. *) +(* Proof. unfold mem_delta_apply_bytes. destruct d as [[[d0 d1] d2] d3]. auto. Qed. *) + +(* Definition mem_delta_apply_alloc (om: option mem) (d: mem_delta_alloc): option mem := *) +(* let '(cp, lo, hi) := d in *) +(* match om with *) +(* | Some m => Some (fst (Mem.alloc m cp lo hi)) *) +(* | None => None *) +(* end. *) + +(* Lemma mem_delta_apply_alloc_none *) +(* d *) +(* : *) +(* mem_delta_apply_alloc None d = None. *) +(* Proof. unfold mem_delta_apply_alloc. destruct d as [[d0 d1] d2]. auto. Qed. *) + +(* Definition mem_delta_apply_free (om: option mem) (d: mem_delta_free): option mem := *) +(* let '(b, lo, hi, cp) := d in *) +(* match om with *) +(* | Some m => Mem.free m b lo hi cp *) +(* | None => None *) +(* end. *) + +(* Lemma mem_delta_apply_free_none *) +(* d *) +(* : *) +(* mem_delta_apply_free None d = None. *) +(* Proof. unfold mem_delta_apply_free. destruct d as [[[d0 d1] d2] d3]. auto. Qed. *) + +(* Definition mem_delta_apply_kind (data: mem_delta_kind) (om: option mem) : option mem := *) +(* match data with *) +(* | mem_delta_kind_storev d => mem_delta_apply_storev om d *) +(* | mem_delta_kind_store d => mem_delta_apply_store om d *) +(* | mem_delta_kind_bytes d => mem_delta_apply_bytes om d *) +(* | mem_delta_kind_alloc d => mem_delta_apply_alloc om d *) +(* | mem_delta_kind_free d => mem_delta_apply_free om d *) +(* end. *) + +(* Definition mem_delta_apply (d: mem_delta) (om0: option mem) : option mem := *) +(* fold_left (fun om data => mem_delta_apply_kind data om) d om0. *) + +(* Lemma mem_delta_apply_cons *) +(* d m0 k *) +(* : *) +(* mem_delta_apply (k :: d) m0 = *) +(* match k with *) +(* | mem_delta_kind_storev dd => mem_delta_apply d (mem_delta_apply_storev (m0) dd) *) +(* | mem_delta_kind_store dd => mem_delta_apply d (mem_delta_apply_store (m0) dd) *) +(* | mem_delta_kind_bytes dd => mem_delta_apply d (mem_delta_apply_bytes (m0) dd) *) +(* | mem_delta_kind_alloc dd => mem_delta_apply d (mem_delta_apply_alloc (m0) dd) *) +(* | mem_delta_kind_free dd => mem_delta_apply d (mem_delta_apply_free (m0) dd) *) +(* end. *) +(* Proof. simpl. destruct k; auto. Qed. *) + +(* Lemma mem_delta_apply_app *) +(* d0 d1 m0 *) +(* : *) +(* mem_delta_apply (d0 ++ d1) m0 = mem_delta_apply d1 (mem_delta_apply d0 m0). *) +(* Proof. *) +(* revert d1 m0. induction d0; intros. *) +(* { simpl. auto. } *) +(* rewrite <- app_comm_cons. rewrite ! mem_delta_apply_cons. destruct a; auto. *) +(* Qed. *) + +(* Lemma mem_delta_apply_none *) +(* d *) +(* : *) +(* mem_delta_apply d None = None. *) +(* Proof. *) +(* induction d; auto. rewrite mem_delta_apply_cons. *) +(* destruct a; *) +(* [rewrite mem_delta_apply_storev_none | rewrite mem_delta_apply_store_none | rewrite mem_delta_apply_bytes_none | rewrite mem_delta_apply_alloc_none | rewrite mem_delta_apply_free_none]; rewrite IHd; auto. *) +(* Qed. *) + +(* Lemma mem_delta_apply_some *) +(* d om m' *) +(* (APPD: mem_delta_apply d om = Some m') *) +(* : *) +(* exists m, om = Some m. *) +(* Proof. destruct om; eauto. rewrite mem_delta_apply_none in APPD. inv APPD. Qed. *) + +End MEMDELTA. + + +(* Section WFDELTA. *) +(* (** only wf delta is applied for back transltation *) *) + +(* (* Refer to encode_val *) *) +(* Definition wf_chunk_val_b (ch: memory_chunk) (v: val) := *) +(* match v with *) +(* | Vundef => false *) +(* | Vint n => *) +(* match ch with *) +(* | Mint8signed | Mint8unsigned => true *) +(* | Mint16signed | Mint16unsigned => true *) +(* | Mint32 => true *) +(* | _ => false *) +(* end *) +(* | Vlong n => *) +(* match ch with *) +(* | Mint64 => true *) +(* | Many32 => false *) +(* | Many64 => false *) +(* | _ => false *) +(* end *) +(* | Vfloat n => *) +(* match ch with *) +(* | Mfloat64 => true *) +(* | Many32 => false *) +(* | Many64 => false *) +(* | _ => false *) +(* end *) +(* | Vsingle n => *) +(* match ch with *) +(* | Mfloat32 => true *) +(* | Many32 => false *) +(* | Many64 => false *) +(* | _ => false *) +(* end *) +(* | Vptr _ _ => false *) +(* end. *) + +(* Definition wf_mem_delta_storev_b (ge: Senv.t) (cp0: compartment) (d: mem_delta_storev) := *) +(* let '(ch, ptr, v, cp) := d in *) +(* match ptr with *) +(* | Vptr b ofs => match Senv.invert_symbol ge b with *) +(* | Some id => (Senv.public_symbol ge id) && (wf_chunk_val_b ch v) && (Pos.eqb cp0 cp) *) +(* | _ => false *) +(* end *) +(* | _ => false *) +(* end. *) + +(* Definition wf_mem_delta_kind_b (ge: Senv.t) cp0 (d: mem_delta_kind) := *) +(* match d with | mem_delta_kind_storev dd => wf_mem_delta_storev_b ge cp0 dd | _ => false end. *) + +(* Definition get_wf_mem_delta (ge: Senv.t) cp0 (d: mem_delta): mem_delta := *) +(* filter (wf_mem_delta_kind_b ge cp0) d. *) + +(* Lemma get_wf_mem_delta_cons *) +(* ge cp0 d k *) +(* : *) +(* get_wf_mem_delta ge cp0 (k :: d) = *) +(* if (wf_mem_delta_kind_b ge cp0 k) then k :: (get_wf_mem_delta ge cp0 d) else (get_wf_mem_delta ge cp0 d). *) +(* Proof. ss. Qed. *) + +(* Lemma get_wf_mem_delta_app *) +(* ge cp0 d0 d1 *) +(* : *) +(* get_wf_mem_delta ge cp0 (d0 ++ d1) = (get_wf_mem_delta ge cp0 d0) ++ (get_wf_mem_delta ge cp0 d1). *) +(* Proof. apply filter_app. Qed. *) + + +(* Definition mem_delta_apply_wf ge cp0 (d: mem_delta) (om0: option mem): option mem := *) +(* mem_delta_apply (get_wf_mem_delta ge cp0 d) om0. *) + +(* Lemma mem_delta_apply_wf_cons *) +(* ge cp0 d m0 k *) +(* : *) +(* mem_delta_apply_wf ge cp0 (k :: d) m0 = *) +(* if (wf_mem_delta_kind_b ge cp0 k) then mem_delta_apply_wf ge cp0 d (mem_delta_apply_kind k m0) else mem_delta_apply_wf ge cp0 d m0. *) +(* Proof. unfold mem_delta_apply_wf at 1. rewrite get_wf_mem_delta_cons. des_ifs. Qed. *) + +(* Lemma mem_delta_apply_wf_app *) +(* ge cp0 d0 d1 m0 *) +(* : *) +(* mem_delta_apply_wf ge cp0 (d0 ++ d1) m0 = *) +(* mem_delta_apply_wf ge cp0 d1 (mem_delta_apply_wf ge cp0 d0 m0). *) +(* Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_app. apply mem_delta_apply_app. Qed. *) + +(* Lemma mem_delta_apply_wf_none *) +(* ge cp0 d *) +(* : *) +(* mem_delta_apply_wf ge cp0 d None = None. *) +(* Proof. unfold mem_delta_apply_wf. apply mem_delta_apply_none. Qed. *) + +(* Lemma mem_delta_apply_wf_some *) +(* ge cp0 d m0 m1 *) +(* (APPD: mem_delta_apply_wf ge cp0 d m0 = Some m1) *) +(* : *) +(* exists m, m0 = Some m. *) +(* Proof. unfold mem_delta_apply_wf in APPD. exploit mem_delta_apply_some; eauto. Qed. *) + +(* End WFDELTA. *) + + +(* Section PROPS. *) + +(* (** Delta and location relations *) *) + +(* Let mcps := PTree.t compartment. *) + +(* Definition mem_delta_unchanged_storev (d: mem_delta_storev) (b': block) (ofs': Z): Prop := *) +(* let '(ch, ptr, v, cp) := d in *) +(* match ptr with *) +(* | Vptr b ofs0 => let ofs := (Ptrofs.unsigned ofs0) in (b = b') -> (ofs > ofs' \/ ofs + (size_chunk ch) <= ofs') *) +(* | _ => True *) +(* end. *) + +(* Lemma mem_delta_unchanged_on_storev *) +(* d m m' *) +(* (APPD: mem_delta_apply_storev (Some m) d = (Some m')) *) +(* : *) +(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged_storev d b ofs) m m'. *) +(* Proof. *) +(* destruct d as (((ch & ptr) & v) & cp). ss. unfold Mem.storev in APPD. des_ifs. *) +(* eapply Mem.store_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. *) +(* Qed. *) + +(* Definition mem_delta_unchanged_store (d: mem_delta_store) (b': block) (ofs': Z): Prop := *) +(* let '(ch, b, ofs, v, cp) := d in (b = b') -> (ofs > ofs' \/ ofs + (size_chunk ch) <= ofs'). *) + +(* Lemma mem_delta_unchanged_on_store *) +(* d m m' *) +(* (APPD: mem_delta_apply_store (Some m) d = (Some m')) *) +(* : *) +(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged_store d b ofs) m m'. *) +(* Proof. *) +(* destruct d as ((((ch & b) & ofs) & v) & cp). ss. *) +(* eapply Mem.store_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. *) +(* Qed. *) + +(* Definition mem_delta_unchanged_bytes (d: mem_delta_bytes) (b': block) (ofs': Z): Prop := *) +(* let '(b, ofs, mvs, cp) := d in *) +(* (b = b') -> (ofs > ofs' \/ ofs + Z.of_nat (Datatypes.length mvs) <= ofs'). *) + +(* Lemma mem_delta_unchanged_on_bytes *) +(* d m m' *) +(* (APPD: mem_delta_apply_bytes (Some m) d = (Some m')) *) +(* : *) +(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged_bytes d b ofs) m m'. *) +(* Proof. *) +(* destruct d as (((b & ofs) & mvs) & cp). simpl in *. *) +(* eapply Mem.storebytes_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. *) +(* Qed. *) + +(* Definition mem_delta_unchanged_alloc (d: mem_delta_alloc) (b': block) (ofs': Z): Prop := *) +(* let '(cp, lo, hi) := d in *) +(* True. *) + +(* Lemma mem_delta_unchanged_on_alloc *) +(* d m m' *) +(* (APPD: mem_delta_apply_alloc (Some m) d = (Some m')) *) +(* : *) +(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged_alloc d b ofs) m m'. *) +(* Proof. *) +(* destruct d as ((cp & lo) & hi). simpl in *. destruct (Mem.alloc m cp lo hi) eqn:ALLOC; simpl in *. inv APPD. *) +(* eapply Mem.alloc_unchanged_on. eauto. *) +(* Qed. *) + +(* Definition mem_delta_unchanged_free (d: mem_delta_free) (b': block) (ofs': Z): Prop := *) +(* let '(b, lo, hi, cp) := d in *) +(* (b = b') -> (lo > ofs' \/ hi <= ofs'). *) + +(* Lemma mem_delta_unchanged_on_free *) +(* d m m' *) +(* (APPD: mem_delta_apply_free (Some m) d = (Some m')) *) +(* : *) +(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged_free d b ofs) m m'. *) +(* Proof. *) +(* destruct d as (((b & lo) & hi) & cp). simpl in *. *) +(* eapply Mem.free_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. *) +(* Qed. *) + +(* Definition mem_delta_kind_unchanged (k: mem_delta_kind) (b: block) (ofs: Z) := *) +(* match k with *) +(* | mem_delta_kind_storev dd => mem_delta_unchanged_storev dd b ofs *) +(* | mem_delta_kind_store dd => mem_delta_unchanged_store dd b ofs *) +(* | mem_delta_kind_bytes dd => mem_delta_unchanged_bytes dd b ofs *) +(* | mem_delta_kind_alloc dd => mem_delta_unchanged_alloc dd b ofs *) +(* | mem_delta_kind_free dd => mem_delta_unchanged_free dd b ofs *) +(* end. *) + +(* Definition mem_delta_unchanged (d: mem_delta) (b: block) (ofs: Z) := *) +(* Forall (fun k => mem_delta_kind_unchanged k b ofs) d. *) + +(* Lemma mem_delta_unchanged_on *) +(* d m m' *) +(* (APPD: mem_delta_apply d (Some m) = Some m') *) +(* : *) +(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged d b ofs) m m'. *) +(* Proof. *) +(* revert m m' APPD. induction d; intros; simpl. *) +(* { simpl in APPD. inv APPD. apply Mem.unchanged_on_refl. } *) +(* rewrite mem_delta_apply_cons in APPD. destruct a. *) +(* - destruct d0 as [[[ch ptr] v] cp]. destruct (mem_delta_apply_storev (Some m) (ch, ptr, v, cp)) eqn:MEM. *) +(* 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } *) +(* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) +(* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } *) +(* { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_storev. eauto. *) +(* intros. simpl. des_ifs. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. *) +(* } *) +(* - destruct d0 as [[[[ch b] ofs] v] cp]. destruct (mem_delta_apply_store (Some m) (ch, b, ofs, v, cp)) eqn:MEM. *) +(* 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } *) +(* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) +(* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } *) +(* { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_store. eauto. *) +(* intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. *) +(* } *) +(* - destruct d0 as [[[b ofs] mvs] cp]. destruct (mem_delta_apply_bytes (Some m) (b, ofs, mvs, cp)) eqn:MEM. *) +(* 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } *) +(* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) +(* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } *) +(* { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_bytes. eauto. *) +(* intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. *) +(* } *) +(* - destruct d0 as [[cp lo] hi]. destruct (mem_delta_apply_alloc (Some m) (cp, lo, hi)) eqn:MEM. *) +(* 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } *) +(* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) +(* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } *) +(* { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_alloc. eauto. *) +(* intros. simpl. auto. *) +(* } *) +(* - destruct d0 as [[[b lo] hi] cp]. destruct (mem_delta_apply_free (Some m) (b, lo, hi, cp)) eqn:MEM. *) +(* 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } *) +(* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) +(* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } *) +(* { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_free. eauto. *) +(* intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. *) +(* } *) +(* Qed. *) + +(* Lemma mem_delta_wf_unchanged_on *) +(* ge cp d m m' *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) +(* : *) +(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged (get_wf_mem_delta ge cp d) b ofs) m m'. *) +(* Proof. eapply mem_delta_unchanged_on; eauto. Qed. *) + +(* Lemma get_from_setN_same_upto_ofs *) +(* ofs0 ofs l ofsd *) +(* (OFS: ofs0 <= ofs < ofs0 + Z.of_nat (Datatypes.length l)) *) +(* (mc1 mc2 : (ZMap.t memval)) *) +(* : *) +(* ZMap.get ofs (Mem.setN l ofs0 mc1) = ZMap.get (ofs + ofsd) (Mem.setN l (ofs0 + ofsd) mc2). *) +(* Proof. *) +(* revert ofs0 ofs ofsd OFS mc1 mc2. induction l; simpl; intros. *) +(* { lia. } *) +(* destruct (Z.eqb_spec ofs0 ofs). *) +(* { subst ofs0. clear OFS. rewrite ! Mem.setN_outside; try lia. rewrite ! ZMap.gss. auto. } *) +(* { replace (ofs0 + ofsd + 1) with ((ofs0 + 1) + ofsd) by lia. eapply IHl. lia. } *) +(* Qed. *) + +(* Lemma get_from_setN_same *) +(* ofs0 ofs l *) +(* (OFS: ofs0 <= ofs < ofs0 + Z.of_nat (Datatypes.length l)) *) +(* (mc1 mc2 : (ZMap.t memval)) *) +(* : *) +(* ZMap.get ofs (Mem.setN l ofs0 mc1) = ZMap.get ofs (Mem.setN l ofs0 mc2). *) +(* Proof. *) +(* replace ofs with (ofs + 0) at 2 by lia. replace ofs0 with (ofs0 + 0) at 2 by lia. eapply get_from_setN_same_upto_ofs; auto. *) +(* Qed. *) + +(* Lemma mem_store_same_upto_ofs *) +(* ofs ofs0 ch0 v0 cp0 ofsd b b' m1 m2 m1' m2' *) +(* (OFS: ofs0 <= ofs < ofs0 + size_chunk ch0) *) +(* (MEM1: Mem.store ch0 m1 b ofs0 v0 cp0 = Some m1') *) +(* (MEM2: Mem.store ch0 m2 b' (ofs0 + ofsd) v0 cp0 = Some m2') *) +(* : *) +(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get (ofs + ofsd) (Mem.mem_contents m2') !! b'. *) +(* Proof. *) +(* apply Mem.store_mem_contents in MEM1, MEM2. rewrite MEM1, MEM2. rewrite ! PMap.gss. *) +(* rewrite size_chunk_conv, <- (encode_val_length ch0 v0) in OFS. *) +(* remember (encode_val ch0 v0) as l. remember (Mem.mem_contents m1) as mc1. remember (Mem.mem_contents m2) as mc2. clear - OFS. *) +(* eapply get_from_setN_same_upto_ofs. auto. *) +(* Qed. *) + + +(* Definition mem_delta_changed_storev (d: mem_delta_storev) (b': block) (ofs': Z): Prop := *) +(* let '(ch, ptr, v, cp) := d in *) +(* match ptr with *) +(* | Vptr b ofs0 => let ofs := Ptrofs.unsigned ofs0 in (b = b') /\ (ofs <= ofs' < ofs + (size_chunk ch)) *) +(* | _ => False *) +(* end. *) + +(* Lemma mem_delta_changed_storev_same *) +(* d b ofs *) +(* (CHG: mem_delta_changed_storev d b ofs) *) +(* m1 m1' m2 m2' *) +(* (APPD1: mem_delta_apply_storev (Some m1) d = Some m1') *) +(* (APPD2: mem_delta_apply_storev (Some m2) d = Some m2') *) +(* : *) +(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. *) +(* Proof. *) +(* destruct d as [[[ch0 ptr0] v0] cp0]. unfold mem_delta_changed_storev in CHG. des_ifs. *) +(* destruct CHG as (BLK & OFS). subst b0. *) +(* simpl in *. replace ofs with (ofs + 0) at 2 by lia. eapply mem_store_same_upto_ofs; eauto. *) +(* rewrite Z.add_0_r. eauto. *) +(* Qed. *) + +(* Definition mem_delta_changed_store (d: mem_delta_store) (b': block) (ofs': Z): Prop := *) +(* let '(ch, b, ofs, v, cp) := d in *) +(* (b = b') /\ (ofs <= ofs' < ofs + (size_chunk ch)). *) + +(* Lemma mem_delta_changed_store_same *) +(* d b ofs *) +(* (CHG: mem_delta_changed_store d b ofs) *) +(* m1 m1' m2 m2' *) +(* (APPD1: mem_delta_apply_store (Some m1) d = Some m1') *) +(* (APPD2: mem_delta_apply_store (Some m2) d = Some m2') *) +(* : *) +(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. *) +(* Proof. *) +(* destruct d as [[[[ch0 b0] ofs0] v0] cp0]. destruct CHG as (BLK & OFS). subst b0. *) +(* simpl in *. replace ofs with (ofs + 0) at 2 by lia. eapply mem_store_same_upto_ofs; eauto. *) +(* replace (ofs0 + 0) with ofs0 by lia. eauto. *) +(* Qed. *) + +(* Definition mem_delta_changed_bytes (d: mem_delta_bytes) (b': block) (ofs': Z): Prop := *) +(* let '(b, ofs, mvs, cp) := d in *) +(* (b = b') /\ (ofs <= ofs' < ofs + Z.of_nat (Datatypes.length mvs)). *) + +(* Lemma mem_delta_changed_bytes_same *) +(* d b ofs *) +(* (CHG: mem_delta_changed_bytes d b ofs) *) +(* m1 m1' m2 m2' *) +(* (APPD1: mem_delta_apply_bytes (Some m1) d = Some m1') *) +(* (APPD2: mem_delta_apply_bytes (Some m2) d = Some m2') *) +(* : *) +(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. *) +(* Proof. *) +(* destruct d as [[[b0 ofs0] mvs0] cp0]. destruct CHG as (BLK & OFS). subst b0. *) +(* simpl in *. apply Mem.storebytes_mem_contents in APPD1, APPD2. rewrite APPD1, APPD2. rewrite ! PMap.gss. *) +(* eapply get_from_setN_same. auto. *) +(* Qed. *) + +(* Definition mem_delta_changed_alloc (d: mem_delta_alloc) (b': block) (ofs': Z): Prop := *) +(* let '(cp, lo, hi) := d in *) +(* False. *) + +(* Lemma mem_delta_changed_alloc_same *) +(* d b ofs *) +(* (CHG: mem_delta_changed_alloc d b ofs) *) +(* m1 m1' m2 m2' *) +(* (APPD1: mem_delta_apply_alloc (Some m1) d = Some m1') *) +(* (APPD2: mem_delta_apply_alloc (Some m2) d = Some m2') *) +(* : *) +(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. *) +(* Proof. *) +(* unfold mem_delta_changed_alloc in CHG. destruct d. destruct p. inv CHG. *) +(* Qed. *) + +(* Definition mem_delta_changed_free (d: mem_delta_free) (b': block) (ofs': Z): Prop := *) +(* let '(b, lo, hi, cp) := d in *) +(* (b = b') /\ (lo <= ofs' < hi). *) + +(* Definition mem_delta_kind_changed (k: mem_delta_kind) (b: block) (ofs: Z) := *) +(* match k with *) +(* | mem_delta_kind_storev dd => mem_delta_changed_storev dd b ofs *) +(* | mem_delta_kind_store dd => mem_delta_changed_store dd b ofs *) +(* | mem_delta_kind_bytes dd => mem_delta_changed_bytes dd b ofs *) +(* | mem_delta_kind_alloc dd => mem_delta_changed_alloc dd b ofs *) +(* | mem_delta_kind_free dd => mem_delta_changed_free dd b ofs *) +(* end. *) + +(* Definition mem_delta_changed (d: mem_delta) (b: block) (ofs: Z) := *) +(* Exists (fun k => mem_delta_kind_changed k b ofs) d. *) + + +(* (** Propperties *) *) +(* Lemma mem_delta_cases_storev *) +(* d b ofs *) +(* : *) +(* mem_delta_unchanged_storev d b ofs \/ mem_delta_changed_storev d b ofs. *) +(* Proof. destruct d as [[[ch0 ptr0] v0] cp0]. ss. des_ifs; auto. lia. Qed. *) + +(* Lemma mem_delta_cases_store *) +(* d b ofs *) +(* : *) +(* mem_delta_unchanged_store d b ofs \/ mem_delta_changed_store d b ofs. *) +(* Proof. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. simpl. lia. Qed. *) + +(* Lemma mem_delta_cases_bytes *) +(* d b ofs *) +(* : *) +(* mem_delta_unchanged_bytes d b ofs \/ mem_delta_changed_bytes d b ofs. *) +(* Proof. destruct d as [[[b0 ofs0] mvs] cp0]. simpl. lia. Qed. *) + +(* Lemma mem_delta_cases_alloc *) +(* d b ofs *) +(* : *) +(* mem_delta_unchanged_alloc d b ofs \/ mem_delta_changed_alloc d b ofs. *) +(* Proof. destruct d as [[x y] z]. simpl. auto. Qed. *) + +(* Lemma mem_delta_cases_free *) +(* d b ofs *) +(* : *) +(* mem_delta_unchanged_free d b ofs \/ mem_delta_changed_free d b ofs. *) +(* Proof. destruct d as [[[b0 lo] hi] cp0]. simpl. lia. Qed. *) + +(* Lemma mem_delta_cases_kind *) +(* d b ofs *) +(* : *) +(* mem_delta_kind_unchanged d b ofs \/ mem_delta_kind_changed d b ofs. *) +(* Proof. destruct d; simpl. apply mem_delta_cases_storev. apply mem_delta_cases_store. apply mem_delta_cases_bytes. apply mem_delta_cases_alloc. apply mem_delta_cases_free. Qed. *) + +(* Lemma mem_delta_unchanged_or_changed *) +(* d b ofs *) +(* : *) +(* mem_delta_unchanged d b ofs \/ mem_delta_changed d b ofs. *) +(* Proof. *) +(* induction d. *) +(* { left. constructor 1. } *) +(* destruct IHd. *) +(* 2:{ right. constructor 2. auto. } *) +(* destruct (mem_delta_cases_kind a b ofs). *) +(* - left. constructor; auto. *) +(* - right. constructor 1; auto. *) +(* Qed. *) + +(* End PROPS. *) + +(* Section PROOFS. *) +(* (** Props for proofs *) *) + +(* Definition mem_delta_kind_inj_wf (cp0: compartment) (j: meminj): mem_delta_kind -> Prop := *) +(* fun data => *) +(* match data with *) +(* | mem_delta_kind_storev (ch, ptr, v, cp) => cp = cp0 *) +(* | mem_delta_kind_store (ch, b, ofs, v, cp) => (j b) = None *) +(* | mem_delta_kind_bytes (b, ofs, mvs, cp) => (j b) = None *) +(* | mem_delta_kind_free (b, lo, hi, cp) => (j b) = None *) +(* | _ => True *) +(* end. *) + +(* Definition mem_delta_inj_wf cp (j: meminj): mem_delta -> Prop := *) +(* fun d => Forall (fun data => mem_delta_kind_inj_wf cp j data) d. *) + +(* Definition meminj_first_order (j: meminj) (m: mem) := *) +(* forall b ofs, (j b <> None) -> (Mem.perm m b ofs Cur Readable) -> loc_first_order m b ofs. *) + +(* Definition meminj_not_alloc (j: meminj) (m: mem) := forall b, (Mem.nextblock m <= b)%positive -> j b = None. *) + + +(* Lemma mem_storev_first_order_wf_chunk_val *) +(* ch m b i v cp m' *) +(* (MEM: Mem.storev ch m (Vptr b i) v cp = Some m') *) +(* ofs *) +(* (FO: loc_first_order m' b ofs) *) +(* (CHG: Ptrofs.unsigned i <= ofs < Ptrofs.unsigned i + size_chunk ch) *) +(* : *) +(* wf_chunk_val_b ch v. *) +(* Proof. *) +(* unfold loc_first_order in FO. ss. exploit Mem.store_mem_contents; eauto. intros CNT. *) +(* rewrite CNT in FO. remember (Ptrofs.unsigned i) as ofs0. rewrite PMap.gss in FO. remember ((Mem.mem_contents m) !! b) as mcv. clear - FO CHG. *) +(* assert (IN: In (ZMap.get ofs (Mem.setN (encode_val ch v) ofs0 mcv)) (encode_val ch v)). *) +(* { eapply Mem.setN_in. rewrite encode_val_length. rewrite <- size_chunk_conv. auto. } *) +(* remember (ZMap.get ofs (Mem.setN (encode_val ch v) ofs0 mcv)) as mv. clear - FO IN. *) +(* destruct ch; destruct v; ss; des; clarify. *) +(* 1,2: des_ifs; ss; des; clarify. *) +(* Qed. *) + +(* Lemma list_forall_filter *) +(* A (P: A -> Prop) l B *) +(* (FA: Forall P l) *) +(* : *) +(* Forall P (filter B l). *) +(* Proof. induction FA; ss. des_ifs. econs; eauto. Qed. *) + +(* Lemma mem_delta_unchanged_implies_wf_unchanged *) +(* ge cp d b ofs *) +(* (UNCHG: mem_delta_unchanged d b ofs) *) +(* : *) +(* mem_delta_unchanged (get_wf_mem_delta ge cp d) b ofs. *) +(* Proof. eapply list_forall_filter; eauto. Qed. *) + +(* Lemma mem_delta_changed_only_by_storev *) +(* ge cp d b ofs *) +(* (WF: mem_delta_inj_wf cp (meminj_public ge) d) *) +(* (INJ: (meminj_public ge) b <> None) *) +(* (CHG: mem_delta_changed d b ofs) *) +(* m1 m1' m2 m2' *) +(* (APPD1: mem_delta_apply d (Some m1) = Some m1') *) +(* (APPD2: mem_delta_apply_wf ge cp d (Some m2) = Some m2') *) +(* (PERM1: Mem.perm m1 b ofs Cur Readable) *) +(* (PERM2: Mem.perm m2 b ofs Cur Readable) *) +(* (FO: loc_first_order m1' b ofs) *) +(* : *) +(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. *) +(* Proof. *) +(* revert WF CHG m1 m1' m2 m2' APPD1 APPD2 PERM1 PERM2 FO. induction d; intros. *) +(* { inv CHG. } *) +(* rewrite mem_delta_apply_cons in APPD1. rewrite mem_delta_apply_wf_cons in APPD2. inv WF. rename H1 into WF1, H2 into WF2. inv CHG. *) +(* (* not chagned by the head *) *) +(* 2:{ specialize (IHd WF2 H0). destruct a. *) +(* - destruct d0 as [[[ch0 ptr0] v0] cp0]. des_ifs. *) +(* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) +(* exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) +(* ss. unfold Mem.storev in MEM1. des_ifs. ss. eapply IHd; eauto. 1,2: eapply Mem.perm_store_1; eauto. *) +(* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) +(* exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) +(* ss. unfold Mem.storev in MEM1. destruct ptr0; ss; clarify. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. *) +(* - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. des_ifs. *) +(* exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) +(* ss. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. *) +(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. *) +(* eapply Mem.perm_storebytes_1; eauto. *) +(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[x y] z]. simpl in *. eapply IHd; eauto. *) +(* destruct (Mem.alloc m1 x y z) eqn: ALLOC. ss. inv MEM1. eapply Mem.perm_alloc_1; eauto. *) +(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. *) +(* eapply Mem.perm_free_1; eauto. left. ii. subst w. clarify. *) +(* } *) +(* rename H0 into CHG. destruct (mem_delta_unchanged_or_changed d b ofs). *) +(* (* overwrite by the tail *) *) +(* 2:{ specialize (IHd WF2 H). destruct a. *) +(* - destruct d0 as [[[ch0 ptr0] v0] cp0]. des_ifs. *) +(* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) +(* exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) +(* ss. unfold Mem.storev in MEM1. des_ifs. ss. eapply IHd; eauto. 1,2: eapply Mem.perm_store_1; eauto. *) +(* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) +(* exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) +(* ss. unfold Mem.storev in MEM1. destruct ptr0; ss; clarify. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. *) +(* - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. des_ifs. *) +(* exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) +(* ss. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. *) +(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. *) +(* eapply Mem.perm_storebytes_1; eauto. *) +(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[x y] z]. simpl in *. eapply IHd; eauto. *) +(* destruct (Mem.alloc m1 x y z) eqn: ALLOC. ss. *) +(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. *) +(* eapply Mem.perm_free_1; eauto. left. ii. subst w. clarify. *) +(* } *) +(* rename H into UNCHG. clear IHd. *) +(* { destruct a. *) +(* 2,3,5: ss; des_ifs; ss; des; clarify. *) +(* 2:{ destruct d0 as [[x y] z]. ss. } *) +(* destruct d0 as [[[ch0 ptr0] v0] cp0]. ss. destruct ptr0; ss. des; clarify. *) +(* assert (exists id, Senv.invert_symbol ge b = Some id /\ Senv.public_symbol ge id). *) +(* { clear - INJ. unfold meminj_public in INJ. des_ifs. eauto. } *) +(* des. rename H into INV, H0 into PUB. rewrite INV, PUB in APPD2. *) +(* exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) +(* eapply mem_delta_unchanged_on in APPD1. exploit (Mem.unchanged_on_contents _ _ _ APPD1 b ofs); auto. *) +(* { eapply Mem.perm_store_1; eauto. } *) +(* intros H. rewrite H. *) +(* assert (FO2: loc_first_order mi1 b ofs). *) +(* { unfold loc_first_order in *. rewrite <- H. auto. } *) +(* exploit mem_storev_first_order_wf_chunk_val. 2,3: eauto. ss. eauto. *) +(* intros WFCV. rewrite WFCV in APPD2. rewrite Pos.eqb_refl in APPD2. des_ifs. *) +(* exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) +(* eapply mem_delta_wf_unchanged_on in APPD2; auto. exploit (Mem.unchanged_on_contents _ _ _ APPD2 b ofs); auto. *) +(* { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. } *) +(* { eapply Mem.perm_store_1; eauto. } *) +(* intros H0. rewrite H0. replace ofs with (ofs + 0)%Z at 2 by lia. *) +(* eapply mem_store_same_upto_ofs; eauto. rewrite Z.add_0_r. eauto. *) +(* } *) +(* Qed. *) + +(* Lemma store_left_mapped_winj: *) +(* forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta, *) +(* mem_winj f m1 m2 -> *) +(* Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> *) +(* f b1 = Some (b2, delta) -> *) +(* mem_winj f n1 m2. *) +(* Proof. *) +(* intros. *) +(* inv H. constructor. *) +(* (* perm *) *) +(* intros. eapply mwi_perm; eauto. eapply Mem.perm_store_2; eauto. *) +(* (* own *) *) +(* intros. eapply mwi_own. eauto. apply (proj2 (Mem.store_can_access_block_inj _ _ _ _ _ _ _ H0 _ _)). auto. *) +(* (* align *) *) +(* intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. red; intros; eauto with mem. *) +(* Qed. *) + +(* Lemma store_left_mapped_winject: *) +(* forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta, *) +(* winject f m1 m2 -> *) +(* Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> *) +(* f b1 = Some (b2, delta) -> *) +(* winject f n1 m2. *) +(* Proof. *) +(* intros. inversion H. exploit store_left_mapped_winj; eauto. intros MI. constructor. *) +(* (* winj *) *) +(* auto. *) +(* (* freeblocks *) *) +(* eauto with mem. *) +(* (* mappedblocks *) *) +(* eauto with mem. *) +(* (* no overlap *) *) +(* red; intros. eauto with mem. *) +(* (* representable *) *) +(* intros. eapply mwi_representable; try eassumption. *) +(* destruct H3; eauto with mem. *) +(* (* perm inv *) *) +(* intros. exploit mwi_perm_inv; eauto using Mem.perm_store_2. *) +(* intuition eauto using Mem.perm_store_1, Mem.perm_store_2. *) +(* Qed. *) + +(* Lemma store_left_winject: *) +(* forall f chunk m1 b1 ofs v1 cp n1 m2, *) +(* winject f m1 m2 -> *) +(* Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> *) +(* winject f n1 m2. *) +(* Proof. *) +(* intros. destruct (f b1) eqn:FB. *) +(* - destruct p. eapply store_left_mapped_winject; eauto. *) +(* - eapply store_unmapped_winject; eauto. *) +(* Qed. *) + +(* Lemma storebytes_left_mapped_winj: *) +(* forall f m1 b1 ofs v1 cp n1 m2 b2 delta, *) +(* mem_winj f m1 m2 -> *) +(* Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> *) +(* f b1 = Some (b2, delta) -> *) +(* mem_winj f n1 m2. *) +(* Proof. *) +(* intros. *) +(* inv H. constructor. *) +(* (* perm *) *) +(* intros. eapply mwi_perm; eauto. eapply Mem.perm_storebytes_2; eauto. *) +(* (* own *) *) +(* intros. eapply mwi_own; eauto. eapply Mem.storebytes_can_access_block_inj_2; eauto. *) +(* (* align *) *) +(* intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. *) +(* red; intros. eapply Mem.perm_storebytes_2; eauto. *) +(* Qed. *) + +(* Lemma storebytes_left_mapped_winject: *) +(* forall f m1 b1 ofs v1 cp n1 m2 b2 delta, *) +(* winject f m1 m2 -> *) +(* Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> *) +(* f b1 = Some (b2, delta) -> *) +(* winject f n1 m2. *) +(* Proof. *) +(* intros. inversion H. exploit storebytes_left_mapped_winj; eauto. intros MI. constructor. *) +(* (* winj *) *) +(* auto. *) +(* (* freeblocks *) *) +(* eauto with mem. *) +(* (* mappedblocks *) *) +(* eauto with mem. *) +(* (* no overlap *) *) +(* red; intros. eauto with mem. *) +(* (* representable *) *) +(* intros. eapply mwi_representable; try eassumption. *) +(* destruct H3; eauto with mem. *) +(* (* perm inv *) *) +(* intros. exploit mwi_perm_inv; eauto using Mem.perm_storebytes_2. *) +(* intuition eauto using Mem.perm_storebytes_1, Mem.perm_storebytes_2. *) +(* Qed. *) + +(* Lemma storebytes_left_winject: *) +(* forall f m1 b1 ofs v1 cp n1 m2, *) +(* winject f m1 m2 -> *) +(* Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> *) +(* winject f n1 m2. *) +(* Proof. *) +(* intros. destruct (f b1) eqn:FB. *) +(* - destruct p. eapply storebytes_left_mapped_winject; eauto. *) +(* - eapply storebytes_unmapped_winject; eauto. *) +(* Qed. *) + +(* Lemma mem_delta_apply_preserves_winject *) +(* ge cp0 m0 m0' *) +(* (WINJ0: winject (meminj_public ge) m0 m0') *) +(* (d: mem_delta) *) +(* m1 *) +(* (APPD: mem_delta_apply d (Some m0) = Some m1) *) +(* : *) +(* exists m1', (mem_delta_apply_wf ge cp0 d (Some m0') = Some m1') /\ (winject (meminj_public ge) m1 m1'). *) +(* Proof. *) +(* revert m0 m0' WINJ0 m1 APPD. induction d; intros. *) +(* { inv APPD. exists m0'. ss. } *) +(* rewrite mem_delta_apply_cons in APPD. rewrite mem_delta_apply_wf_cons. destruct a. *) +(* - exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. des_ifs. *) +(* + destruct d0 as (((ch & ptr) & v) & cp). destruct ptr; ss. destruct ((meminj_public ge) b) as [[b' ofs']|] eqn:JB. *) +(* * exploit store_mapped_winject; eauto. instantiate (1:=v). intros (mi0 & MEM' & WINJ1). specialize (IHd _ _ WINJ1 _ APPD). destruct IHd as (m1' & APPD' & WINJ'). *) +(* unfold meminj_public in JB. des_ifs. rewrite Z.add_0_r in MEM'. rewrite MEM'. eauto. *) +(* * exploit store_unmapped_winject; eauto. unfold meminj_public in JB. des_ifs. *) +(* + destruct d0 as (((ch & ptr) & v) & cp). destruct ptr; ss. exploit store_left_winject; eauto. *) +(* - destruct d0 as ((((ch & b) & ofs) & v) & cp). ss. exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. *) +(* exploit store_left_winject; eauto. *) +(* - destruct d0 as (((b & ofs) & mvs) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. ss. exploit storebytes_left_winject; eauto. *) +(* - destruct d0 as ((cp & lo) & hi). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. *) +(* ss. destruct (Mem.alloc m0 cp lo hi) eqn:ALLOC; simpl in *. inv MEM. exploit alloc_left_unmapped_winject_keep; eauto. *) +(* - destruct d0 as (((b & lo) & hi) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. ss. exploit free_left_winject; eauto. *) +(* Qed. *) + +(* Lemma mem_delta_apply_keeps_perm *) +(* cp j d *) +(* (DWF: mem_delta_inj_wf cp j d) *) +(* m0 m1 *) +(* (APPD : mem_delta_apply d (Some m0) = Some m1) *) +(* b ofs *) +(* (INJ: j b <> None) *) +(* K P *) +(* (PERM: Mem.perm m1 b ofs K P) *) +(* (BOUND: (b < Mem.nextblock m0)%positive) *) +(* : *) +(* Mem.perm m0 b ofs K P. *) +(* Proof. *) +(* revert DWF m0 APPD BOUND. induction d; intros. *) +(* { simpl in *. inv APPD; auto. } *) +(* inv DWF. rename H1 into DWF1, H2 into DWF2. rewrite mem_delta_apply_cons in APPD. specialize (IHd DWF2). *) +(* destruct a; exploit mem_delta_apply_some; eauto; intros (mi & MEM); rewrite MEM in APPD; specialize (IHd _ APPD). *) +(* - destruct d0 as (((ch0 & ptr0) & v0) & cp0). ss. clarify. destruct ptr0; ss. eapply Mem.perm_store_2; eauto. eapply IHd. erewrite Mem.nextblock_store; eauto. *) +(* - destruct d0 as ((((ch0 & b0) & ofs0) & v0) & cp0). simpl in *. eapply Mem.perm_store_2; eauto. eapply IHd. erewrite Mem.nextblock_store; eauto. *) +(* - destruct d0 as (((b0 & ofs0) & mvs0) & cp0). simpl in *. eapply Mem.perm_storebytes_2; eauto. eapply IHd. erewrite Mem.nextblock_storebytes; eauto. *) +(* - destruct d0 as ((cp0 & lo0) & hi0). simpl in *. destruct (Mem.alloc m0 cp0 lo0 hi0) eqn:ALLOC. simpl in *. inv MEM. *) +(* exploit Mem.alloc_result; eauto. intros; subst b0. exploit Mem.nextblock_alloc; eauto. intros EQ. *) +(* eapply Mem.perm_alloc_4. eauto. eapply IHd. lia. lia. *) +(* - destruct d0 as (((b0 & lo0) & hi0) & cp0). simpl in *. *) +(* eapply Mem.perm_free_3; eauto. eapply IHd. erewrite Mem.nextblock_free; eauto. *) +(* Qed. *) + +(* Lemma loc_first_order_always_memval_inject *) +(* m b ofs *) +(* (FO: loc_first_order m b ofs) *) +(* j v *) +(* (VINJ: memval_inject j (ZMap.get ofs (Mem.mem_contents m) !! b) v) *) +(* : *) +(* forall k, memval_inject k (ZMap.get ofs (Mem.mem_contents m) !! b) v. *) +(* Proof. *) +(* unfold loc_first_order in FO. destruct (ZMap.get ofs (Mem.mem_contents m) !! b) eqn:MV; try contradiction. *) +(* inv VINJ. intros. constructor. *) +(* Qed. *) + +(* Lemma mem_delta_apply_establish_inject *) +(* (ge: Senv.t) (k: meminj) m0 m0' *) +(* (INJ: Mem.inject k m0 m0') *) +(* (INCR: inject_incr (meminj_public ge) k) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) +(* (d: mem_delta) cp *) +(* (DWF: mem_delta_inj_wf cp (meminj_public ge) d) *) +(* m1 *) +(* (APPD: mem_delta_apply d (Some m0) = Some m1) *) +(* (FO: meminj_first_order (meminj_public ge) m1) *) +(* : *) +(* exists m1', (mem_delta_apply_wf ge cp d (Some m0') = Some m1') /\ (Mem.inject (meminj_public ge) m1 m1'). *) +(* Proof. *) +(* exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. *) +(* exploit mem_delta_apply_preserves_winject; eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. *) +(* apply winject_to_inject; auto. unfold mem_inj_val. intros. *) +(* exploit mem_delta_apply_keeps_perm; eauto. congruence. *) +(* { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). *) +(* { eapply NALLOC. lia. } *) +(* congruence. *) +(* } *) +(* intros PERM0. pose proof H as INJPUB. unfold meminj_public in H. des_ifs. rename Heq into INV, Heq0 into ISPUB. *) +(* rename b2 into b1. destruct (mem_delta_unchanged_or_changed d b1 ofs). *) +(* - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. *) +(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. *) +(* { inv INJ. inv mi_inj. specialize (mi_memval _ _ _ _ (INCR _ _ _ INJPUB) PERM0). eapply loc_first_order_always_memval_inject; eauto. *) +(* exploit FO. erewrite INJPUB. congruence. eauto. unfold loc_first_order; intros. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. *) +(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. *) +(* } *) +(* { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } *) +(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } *) +(* - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. *) +(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } *) +(* { exploit FO; eauto. rewrite INJPUB. congruence. } *) +(* intros. rewrite Z.add_0_r, <- x0. *) +(* exploit FO; eauto. rewrite INJPUB; ss. intros. unfold loc_first_order in x1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. *) +(* Qed. *) + +(* Import Mem. *) + +(* Lemma mem_delta_apply_establish_inject_preprocess *) +(* (ge: Senv.t) (k: meminj) m0 m0' *) +(* (INJ: Mem.inject k m0 m0') *) +(* pch pb pofs pv pcp m0'' *) +(* (PRE: store pch m0' pb pofs pv pcp = Some m0'') *) +(* (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) *) +(* (INCR: inject_incr (meminj_public ge) k) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) +(* (d: mem_delta) cp *) +(* (DWF: mem_delta_inj_wf cp (meminj_public ge) d) *) +(* m1 *) +(* (APPD: mem_delta_apply d (Some m0) = Some m1) *) +(* (FO: meminj_first_order (meminj_public ge) m1) *) +(* : *) +(* exists m1', (mem_delta_apply_wf ge cp d (Some m0'') = Some m1') /\ (Mem.inject (meminj_public ge) m1 m1'). *) +(* Proof. *) +(* exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. *) +(* hexploit store_outside_winject. eauto. *) +(* { intros. eapply PREB. rewrite H. eauto. } *) +(* eapply PRE. clear WINJ. intros WINJ. *) +(* exploit mem_delta_apply_preserves_winject. eapply WINJ. eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. *) +(* apply winject_to_inject; auto. unfold mem_inj_val. intros. *) +(* exploit mem_delta_apply_keeps_perm; eauto. congruence. *) +(* { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). *) +(* { eapply NALLOC. lia. } *) +(* congruence. *) +(* } *) +(* intros PERM0. pose proof H as INJPUB. unfold meminj_public in H. des_ifs. rename Heq into INV, Heq0 into ISPUB. *) +(* rename b2 into b1. *) +(* assert (NOT_PRE: b1 <> pb). *) +(* { intros EQ. subst b1. eapply PREB. eapply INJPUB. } *) +(* destruct (mem_delta_unchanged_or_changed d b1 ofs). *) +(* - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. *) +(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. *) +(* { inv INJ. inv mi_inj0. specialize (mi_memval0 _ _ _ _ (INCR _ _ _ INJPUB) PERM0). eapply loc_first_order_always_memval_inject; eauto. *) +(* - exploit FO. erewrite INJPUB. congruence. eauto. unfold loc_first_order; intros. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. *) +(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. *) +(* - erewrite (store_mem_contents _ m0' _ _ _ _ m0''). 2: eapply PRE. rewrite PMap.gso. 2: auto. eauto. *) +(* } *) +(* { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } *) +(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } *) +(* - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. *) +(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } *) +(* { exploit FO; eauto. rewrite INJPUB. congruence. } *) +(* intros. rewrite Z.add_0_r, <- x0. *) +(* exploit FO; eauto. rewrite INJPUB; ss. intros. unfold loc_first_order in x1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. *) +(* Qed. *) + +(* Lemma mem_delta_apply_establish_inject_preprocess_gen *) +(* (ge: Senv.t) (k: meminj) m0 m0' *) +(* (INJ: Mem.inject k m0 m0') *) +(* pch pb pofs pv pcp m0'' *) +(* (PRE: store pch m0' pb pofs pv pcp = Some m0'') *) +(* (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) *) +(* (INCR: inject_incr (meminj_public ge) k) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) +(* (d: mem_delta) cp *) +(* (DWF: mem_delta_inj_wf cp (meminj_public ge) d) *) +(* m1 *) +(* (APPD: mem_delta_apply d (Some m0) = Some m1) *) +(* : *) +(* exists m1', (mem_delta_apply_wf ge cp d (Some m0'') = Some m1') /\ *) +(* ((meminj_first_order (meminj_public ge) m1) -> Mem.inject (meminj_public ge) m1 m1'). *) +(* Proof. *) +(* exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. *) +(* hexploit store_outside_winject. eauto. *) +(* { intros. eapply PREB. rewrite H. eauto. } *) +(* eapply PRE. clear WINJ. intros WINJ. *) +(* exploit mem_delta_apply_preserves_winject. eapply WINJ. eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. *) +(* intros FO. apply winject_to_inject; auto. unfold mem_inj_val. intros. *) +(* exploit mem_delta_apply_keeps_perm; eauto. congruence. *) +(* { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). *) +(* { eapply NALLOC. lia. } *) +(* congruence. *) +(* } *) +(* intros PERM0. pose proof H as INJPUB. unfold meminj_public in H. des_ifs. rename Heq into INV, Heq0 into ISPUB. *) +(* rename b2 into b1. *) +(* assert (NOT_PRE: b1 <> pb). *) +(* { intros EQ. subst b1. eapply PREB. eapply INJPUB. } *) +(* destruct (mem_delta_unchanged_or_changed d b1 ofs). *) +(* - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. *) +(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. *) +(* { inv INJ. inv mi_inj0. specialize (mi_memval0 _ _ _ _ (INCR _ _ _ INJPUB) PERM0). eapply loc_first_order_always_memval_inject; eauto. *) +(* - exploit FO. erewrite INJPUB. congruence. eauto. unfold loc_first_order; intros. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. *) +(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. *) +(* - erewrite (store_mem_contents _ m0' _ _ _ _ m0''). 2: eapply PRE. rewrite PMap.gso. 2: auto. eauto. *) +(* } *) +(* { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } *) +(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } *) +(* - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. *) +(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } *) +(* { exploit FO; eauto. rewrite INJPUB. congruence. } *) +(* intros. rewrite Z.add_0_r, <- x0. *) +(* exploit FO; eauto. rewrite INJPUB; ss. intros. unfold loc_first_order in x1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. *) +(* Qed. *) + +(* End PROOFS. *) diff --git a/security/MemoryWeak.v b/security/MemoryWeak.v new file mode 100644 index 0000000000..2e5b157a9e --- /dev/null +++ b/security/MemoryWeak.v @@ -0,0 +1,1768 @@ +Require Import Zwf. +Require Import Axioms. +Require Import Coqlib. +Require Intv. +Require Import Maps. +Require Archi. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Split. +Require Export Memdata. +Require Export Memtype. +Require Import Memory. + +(* To avoid useless definitions of inductors in extracted code. *) +Local Unset Elimination Schemes. +Local Unset Case Analysis Schemes. + +Local Notation "a # b" := (PMap.get b a) (at level 1). + + +Section WINJ. + + Import Mem. + + (** * Generic weak injections *) + + (** A memory state [m1] generically weakly injects into another memory state [m2] via the + memory injection [f] if the following conditions hold: +- each access in [m2] that corresponds to a valid access in [m1] + is itself valid; + *) + + Record mem_winj (f: meminj) (m1 m2: mem) : Prop := + mk_mem_winj { + mwi_perm: + forall b1 b2 delta ofs k p, + f b1 = Some(b2, delta) -> + perm m1 b1 ofs k p -> + perm m2 b2 (ofs + delta) k p; + mwi_own: + forall b1 b2 delta cp, + f b1 = Some(b2, delta) -> + can_access_block m1 b1 cp -> + can_access_block m2 b2 cp; + mwi_align: + forall b1 b2 delta chunk ofs p, + f b1 = Some(b2, delta) -> + range_perm m1 b1 ofs (ofs + size_chunk chunk) Max p -> + (align_chunk chunk | delta); + }. + + (** Preservation of permissions *) + + Lemma perm_winj: + forall f m1 m2 b1 ofs k p b2 delta, + mem_winj f m1 m2 -> + perm m1 b1 ofs k p -> + f b1 = Some(b2, delta) -> + perm m2 b2 (ofs + delta) k p. + Proof. + intros. eapply mwi_perm; eauto. + Qed. + + Lemma range_perm_winj: + forall f m1 m2 b1 lo hi k p b2 delta, + mem_winj f m1 m2 -> + range_perm m1 b1 lo hi k p -> + f b1 = Some(b2, delta) -> + range_perm m2 b2 (lo + delta) (hi + delta) k p. + Proof. + intros; red; intros. + replace ofs with ((ofs - delta) + delta) by lia. + eapply perm_winj; eauto. apply H0. lia. + Qed. + + Lemma can_access_block_winj: + forall f m1 m2 b1 cp b2 delta, + mem_winj f m1 m2 -> + can_access_block m1 b1 cp -> + f b1 = Some(b2, delta) -> + can_access_block m2 b2 cp. + Proof. + intros; red. + eapply mwi_own; eauto. + Qed. + + Lemma valid_access_winj: + forall f m1 m2 b1 b2 delta chunk ofs p cp, + mem_winj f m1 m2 -> + f b1 = Some(b2, delta) -> + valid_access m1 chunk b1 ofs p cp -> + valid_access m2 chunk b2 (ofs + delta) p cp. + Proof. + intros. destruct H1 as [A [B C]]. constructor. + replace (ofs + delta + size_chunk chunk) + with ((ofs + size_chunk chunk) + delta) by lia. + eapply range_perm_winj; eauto. + split. eapply mwi_own; eauto. + apply Z.divide_add_r; auto. eapply mwi_align; eauto with mem. + Qed. + + (** Preservation of stores. *) + + Lemma setN_winj: + forall (access: Z -> Prop) delta f vl1 vl2, + list_forall2 (memval_inject f) vl1 vl2 -> + forall p c1 c2, + (forall q, access q -> memval_inject f (ZMap.get q c1) (ZMap.get (q + delta) c2)) -> + (forall q, access q -> memval_inject f (ZMap.get q (setN vl1 p c1)) + (ZMap.get (q + delta) (setN vl2 (p + delta) c2))). + Proof. + induction 1; intros; simpl. + auto. + replace (p + delta + 1) with ((p + 1) + delta) by lia. + apply IHlist_forall2; auto. + intros. rewrite ZMap.gsspec at 1. destruct (ZIndexed.eq q0 p). subst q0. + rewrite ZMap.gss. auto. + rewrite ZMap.gso. auto. unfold ZIndexed.t in *. lia. + Qed. + + Definition meminj_no_overlap (f: meminj) (m: mem) : Prop := + forall b1 b1' delta1 b2 b2' delta2 ofs1 ofs2, + b1 <> b2 -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + perm m b1 ofs1 Max Nonempty -> + perm m b2 ofs2 Max Nonempty -> + b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2. + + Lemma store_mapped_winj: + forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta v2, + mem_winj f m1 m2 -> + store chunk m1 b1 ofs v1 cp = Some n1 -> + meminj_no_overlap f m1 -> + f b1 = Some (b2, delta) -> + exists n2, + store chunk m2 b2 (ofs + delta) v2 cp = Some n2 + /\ mem_winj f n1 n2. + Proof. + intros. + assert (valid_access m2 chunk b2 (ofs + delta) Writable cp). + eapply valid_access_winj; eauto with mem. + destruct (valid_access_store _ _ _ _ _ v2 H3) as [n2 STORE]. + exists n2; split. auto. + constructor. + (* perm *) + intros. eapply perm_store_1; [eexact STORE|]. + eapply mwi_perm; eauto. + eapply perm_store_2; eauto. + (* own *) + intros. + apply (proj1 (store_can_access_block_inj _ _ _ _ _ _ _ STORE _ _)). + eapply mwi_own; try eassumption. + apply (proj2 (store_can_access_block_inj _ _ _ _ _ _ _ H0 _ _)). + assumption. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. + red; intros; eauto with mem. + Qed. + + Lemma store_unmapped_winj: + forall f chunk m1 b1 ofs v1 cp n1 m2, + mem_winj f m1 m2 -> + store chunk m1 b1 ofs v1 cp = Some n1 -> + f b1 = None -> + mem_winj f n1 m2. + Proof. + intros. constructor. + (* perm *) + intros. eapply mwi_perm; eauto with mem. + (* own *) + intros. eapply mwi_own; eauto. + (* RB: NOTE: Should be solvable by properly extended hint databases. *) + apply (proj2 (store_can_access_block_inj _ _ _ _ _ _ _ H0 _ _)). + assumption. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. + red; intros; eauto with mem. + Qed. + + Lemma store_outside_winj: + forall f m1 m2 chunk b ofs v cp m2', + mem_winj f m1 m2 -> + (forall b' delta ofs', + f b' = Some(b, delta) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + size_chunk chunk -> False) -> + store chunk m2 b ofs v cp = Some m2' -> + mem_winj f m1 m2'. + Proof. + intros. inv H. constructor. + (* perm *) + eauto with mem. + (* own *) + intros. + (* RB: NOTE: Ditto re: hint databases. *) + apply (proj1 (store_can_access_block_inj _ _ _ _ _ _ _ H1 _ _)); eauto. + (* access *) + intros; eapply mwi_align0; eauto. + Qed. + + Lemma storebytes_mapped_winj: + forall f m1 b1 ofs bytes1 cp n1 m2 b2 delta bytes2, + mem_winj f m1 m2 -> + storebytes m1 b1 ofs bytes1 cp = Some n1 -> + meminj_no_overlap f m1 -> + f b1 = Some (b2, delta) -> + list_forall2 (memval_inject f) bytes1 bytes2 -> + exists n2, + storebytes m2 b2 (ofs + delta) bytes2 cp = Some n2 + /\ mem_winj f n1 n2. + Proof. + intros. inversion H. + assert (range_perm m2 b2 (ofs + delta) (ofs + delta + Z.of_nat (length bytes2)) Cur Writable). + replace (ofs + delta + Z.of_nat (length bytes2)) + with ((ofs + Z.of_nat (length bytes1)) + delta). + eapply range_perm_winj; eauto with mem. + rewrite (list_forall2_length H3). lia. + (* eapply storebytes_range_perm; eauto. *) + destruct (range_perm_storebytes _ _ _ _ cp H4) as [n2 STORE]. + eapply can_access_block_winj; try eassumption. eapply storebytes_can_access_block_1; eassumption. + exists n2; split. eauto. + constructor. + (* perm *) + intros. + eapply perm_storebytes_1; [apply STORE |]. + eapply mwi_perm0; eauto. + eapply perm_storebytes_2; eauto. + (* own *) + intros. + eapply storebytes_can_access_block_inj_1; [apply STORE |]. + eapply mwi_own0; eauto. + eapply storebytes_can_access_block_inj_2; eauto. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. + red; intros. eapply perm_storebytes_2; eauto. + Qed. + + Lemma storebytes_unmapped_winj: + forall f m1 b1 ofs bytes1 cp n1 m2, + mem_winj f m1 m2 -> + storebytes m1 b1 ofs bytes1 cp = Some n1 -> + f b1 = None -> + mem_winj f n1 m2. + Proof. + intros. inversion H. + constructor. + (* perm *) + intros. eapply mwi_perm0; eauto. eapply perm_storebytes_2; eauto. + (* own *) + intros. + eapply mwi_own0; try eassumption. + eapply storebytes_can_access_block_inj_2; eassumption. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. + red; intros. eapply perm_storebytes_2; eauto. + Qed. + + Lemma storebytes_outside_winj: + forall f m1 m2 b ofs bytes2 cp m2', + mem_winj f m1 m2 -> + (forall b' delta ofs', + f b' = Some(b, delta) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + Z.of_nat (length bytes2) -> False) -> + storebytes m2 b ofs bytes2 cp = Some m2' -> + mem_winj f m1 m2'. + Proof. + intros. inversion H. constructor. + (* perm *) + intros. eapply perm_storebytes_1; eauto with mem. + (* own *) + intros. eapply storebytes_can_access_block_inj_1; eauto. + (* align *) + eauto. + Qed. + + Lemma storebytes_empty_winj: + forall f m1 b1 ofs1 cp1 m1' m2 b2 ofs2 cp2 m2', + mem_winj f m1 m2 -> + storebytes m1 b1 ofs1 nil cp1 = Some m1' -> + storebytes m2 b2 ofs2 nil cp2 = Some m2' -> + mem_winj f m1' m2'. + Proof. + intros. destruct H. constructor. + (* perm *) + intros. + eapply perm_storebytes_1; eauto. + eapply mwi_perm0; eauto. + eapply perm_storebytes_2; eauto. + (* own *) + intros. + eapply storebytes_can_access_block_inj_1; eauto. + eapply mwi_own0; eauto. + eapply storebytes_can_access_block_inj_2; eauto. + (* align *) + intros. eapply mwi_align0 with (ofs := ofs) (p := p); eauto. + red; intros. eapply perm_storebytes_2; eauto. + Qed. + +(** Preservation of allocations *) + + Lemma alloc_right_winj: + forall f m1 m2 c lo hi b2 m2', + mem_winj f m1 m2 -> + alloc m2 c lo hi = (m2', b2) -> + mem_winj f m1 m2'. + Proof. + intros. injection H0. intros NEXT MEM. + inversion H. constructor. + (* perm *) + intros. eapply perm_alloc_1; eauto. + (* own *) + intros. eapply alloc_can_access_block_other_inj_1; eauto. + (* align *) + eauto. + Qed. + + (* Remark can_access_block_component : *) + (* forall m b cp cp', can_access_block m b cp -> can_access_block m b 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 c, + mem_winj f m1' m2. + Proof. + Admitted. + (* intros. inversion H. constructor. *) + (* (* perm *) *) + (* intros. *) + (* exploit perm_alloc_inv; eauto. intros. destruct (eq_block b0 b1). subst b0. *) + (* rewrite H4 in H5; inv H5. eauto. eauto. *) + (* (* own *) *) + (* intros. destruct cp as [cp |]; [| trivial]. destruct (eq_block b0 b1). *) + (* { *) + (* subst b0. rewrite H4 in H5. inv H5. *) + (* apply owned_new_block in H0. *) + (* unfold can_access_block in *. rewrite H0 in H6. inv H6. *) + (* exact OWN. *) + (* } *) + (* { *) + (* eapply mwi_own0; eauto. eapply alloc_can_access_block_other_inj_2; eassumption. *) + (* } *) + (* (* align *) *) + (* intros. destruct (eq_block b0 b1). *) + (* subst b0. assert (delta0 = delta) by congruence. subst delta0. *) + (* assert (lo <= ofs < hi). *) + (* { eapply perm_alloc_3; eauto. apply H6. generalize (size_chunk_pos chunk); lia. } *) + (* assert (lo <= ofs + size_chunk chunk - 1 < hi). *) + (* { eapply perm_alloc_3; eauto. apply H6. generalize (size_chunk_pos chunk); lia. } *) + (* apply H2. lia. *) + (* eapply mwi_align0 with (ofs := ofs) (p := p); eauto. *) + (* red; intros. eapply perm_alloc_4; eauto. *) + (* Qed. *) + + Lemma free_left_winj: + forall f m1 m2 b lo hi cp m1', + mem_winj f m1 m2 -> + free m1 b lo hi cp = Some m1' -> + mem_winj f m1' m2. + Proof. + intros. exploit free_result; eauto. intro FREE. inversion H. constructor. + (* perm *) + intros. eauto with mem. + (* own *) + intros. eapply mwi_own0; eauto. eapply free_can_access_block_inj_2; eassumption. + (* align *) + intros. eapply mwi_align0 with (ofs := ofs) (p := p); eauto. + red; intros; eapply perm_free_3; eauto. + Qed. + + Lemma free_right_winj: + forall f m1 m2 b lo hi cp m2', + mem_winj f m1 m2 -> + free m2 b lo hi cp = Some m2' -> + (forall b' delta ofs k p, + f b' = Some(b, delta) -> + perm m1 b' ofs k p -> lo <= ofs + delta < hi -> False) -> + mem_winj f m1 m2'. + Proof. + intros. exploit free_result; eauto. intro FREE. inversion H. + assert (PERM: + forall b1 b2 delta ofs k p, + f b1 = Some (b2, delta) -> + perm m1 b1 ofs k p -> perm m2' b2 (ofs + delta) k p). + intros. + intros. eapply perm_free_1; eauto. + destruct (eq_block b2 b); auto. subst b. right. + assert (~ (lo <= ofs + delta < hi)). red; intros; eapply H1; eauto. + lia. + constructor. + (* perm *) + auto. + (* own *) + intros. eapply free_can_access_block_inj_1; eauto. + (* align *) + eapply mwi_align0; eauto. + Qed. + + (** Preservation of [drop_perm] operations. *) + + Lemma drop_unmapped_winj: + forall f m1 m2 b lo hi p cp m1', + mem_winj f m1 m2 -> + drop_perm m1 b lo hi p cp = Some m1' -> + f b = None -> + mem_winj f m1' m2. + Proof. + intros. inv H. constructor. + (* perm *) + intros. eapply mwi_perm0; eauto. eapply perm_drop_4; eauto. + (* own *) + intros. eapply mwi_own0; eauto. eapply can_access_block_drop_2; eauto. + (* align *) + intros. eapply mwi_align0 with (ofs := ofs) (p := p0); eauto. + red; intros; eapply perm_drop_4; eauto. + Qed. + + Lemma drop_mapped_winj: + forall f m1 m2 b1 b2 delta lo hi p cp m1', + mem_winj f m1 m2 -> + drop_perm m1 b1 lo hi p cp = Some m1' -> + meminj_no_overlap f m1 -> + (* forall DISP : meminj_no_dispute f m1, *) + f b1 = Some(b2, delta) -> + exists m2', + drop_perm m2 b2 (lo + delta) (hi + delta) p cp = Some m2' + /\ mem_winj f m1' m2'. + Proof. + intros. + assert ({ m2' | drop_perm m2 b2 (lo + delta) (hi + delta) p cp = Some m2' }). + apply range_perm_drop_2. red; intros. + replace ofs with ((ofs - delta) + delta) by lia. + eapply perm_winj; eauto. eapply range_perm_drop_1; eauto. lia. + eapply mwi_own; eauto. eapply can_access_block_drop_3; eauto. + destruct X as [m2' DROP]. exists m2'; split; auto. + inv H. + constructor. + (* perm *) + intros. + assert (perm m2 b3 (ofs + delta0) k p0). + eapply mwi_perm0; eauto. eapply perm_drop_4; eauto. + destruct (eq_block b1 b0). + (* b1 = b0 *) + subst b0. rewrite H2 in H; inv H. + destruct (zlt (ofs + delta0) (lo + delta0)). eapply perm_drop_3; eauto. + destruct (zle (hi + delta0) (ofs + delta0)). eapply perm_drop_3; eauto. + assert (perm_order p p0). + eapply perm_drop_2. eexact H0. instantiate (1 := ofs). lia. eauto. + apply perm_implies with p; auto. + eapply perm_drop_1. eauto. lia. + (* b1 <> b0 *) + eapply perm_drop_3; eauto. + destruct (eq_block b3 b2); auto. + destruct (zlt (ofs + delta0) (lo + delta)); auto. + destruct (zle (hi + delta) (ofs + delta0)); auto. + exploit H1; eauto. + instantiate (1 := ofs + delta0 - delta). + apply perm_cur_max. apply perm_implies with Freeable. + eapply range_perm_drop_1; eauto. lia. auto with mem. + eapply perm_drop_4; eauto. eapply perm_max. apply perm_implies with p0. eauto. + eauto with mem. + intuition. + (* own *) + intros. + pose proof can_access_block_drop_2 _ _ _ _ _ _ _ H0 _ _ H3 as Hown1. + pose proof can_access_block_drop_3 _ _ _ _ _ _ _ DROP as Hown2. + pose proof mwi_own0 _ _ _ _ H Hown1 as Hown3. + eapply can_access_block_drop_1; eassumption. + (* align *) + intros. eapply mwi_align0 with (ofs := ofs) (p := p0); eauto. + red; intros; eapply perm_drop_4; eauto. + Qed. + + Lemma drop_outside_winj: forall f m1 m2 b lo hi p cp m2', + mem_winj f m1 m2 -> + drop_perm m2 b lo hi p cp = Some m2' -> + (forall b' delta ofs' k p, + f b' = Some(b, delta) -> + perm m1 b' ofs' k p -> + lo <= ofs' + delta < hi -> False) -> + mem_winj f m1 m2'. + Proof. + intros. inv H. constructor. + (* perm *) + intros. eapply perm_drop_3; eauto. + destruct (eq_block b2 b); auto. subst b2. right. + destruct (zlt (ofs + delta) lo); auto. + destruct (zle hi (ofs + delta)); auto. + byContradiction. exploit H1; eauto. lia. + (* own *) + intros. eapply can_access_block_drop_1; eauto. + (* align *) + eapply mwi_align0; eauto. + Qed. + + + + (** * Memory injections *) + + (** A memory state [m1] injects into another memory state [m2] via the + memory injection [f] if the following conditions hold: +- each access in [m2] that corresponds to a valid access in [m1] + is itself valid; +- unallocated blocks in [m1] must be mapped to [None] by [f]; +- if [f b = Some(b', delta)], [b'] must be valid in [m2]; +- distinct blocks in [m1] are mapped to non-overlapping sub-blocks in [m2]; +- the sizes of [m2]'s blocks are representable with unsigned machine integers; +- pointers that could be represented using unsigned machine integers remain + representable after the injection. + *) + + Record winject' (f: meminj) (m1 m2: mem) : Prop := + mk_winject { + mwi_inj: + mem_winj f m1 m2; + mi_freeblocks: + forall b, ~(valid_block m1 b) -> f b = None; + mwi_mappedblocks: + forall b b' delta, f b = Some(b', delta) -> valid_block m2 b'; + mwi_no_overlap: + meminj_no_overlap f m1; + mwi_representable: + forall b b' delta ofs, + f b = Some(b', delta) -> + perm m1 b (Ptrofs.unsigned ofs) Max Nonempty \/ perm m1 b (Ptrofs.unsigned ofs - 1) Max Nonempty -> + delta >= 0 /\ 0 <= Ptrofs.unsigned ofs + delta <= Ptrofs.max_unsigned; + mwi_perm_inv: + forall b1 ofs b2 delta k p, + f b1 = Some(b2, delta) -> + perm m2 b2 (ofs + delta) k p -> + perm m1 b1 ofs k p \/ ~perm m1 b1 ofs Max Nonempty + }. + Definition winject := winject'. + + Local Hint Resolve mwi_mappedblocks: mem. + + (** Preservation of access validity and pointer validity *) + + Theorem valid_block_winject_1: + forall f m1 m2 b1 b2 delta, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + valid_block m1 b1. + Proof. + intros. inv H. destruct (plt b1 (nextblock m1)). auto. + assert (f b1 = None). eapply mi_freeblocks; eauto. congruence. + Qed. + + Theorem valid_block_winject_2: + forall f m1 m2 b1 b2 delta, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + valid_block m2 b2. + Proof. + intros. eapply mwi_mappedblocks; eauto. + Qed. + + Local Hint Resolve valid_block_winject_1 valid_block_winject_2: mem. + + Theorem perm_winject: + forall f m1 m2 b1 b2 delta ofs k p, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + perm m1 b1 ofs k p -> perm m2 b2 (ofs + delta) k p. + Proof. + intros. inv H0. eapply perm_winj; eauto. + Qed. + + Theorem perm_winject_inv: + forall f m1 m2 b1 ofs b2 delta k p, + winject f m1 m2 -> + f b1 = Some(b2, delta) -> + perm m2 b2 (ofs + delta) k p -> + perm m1 b1 ofs k p \/ ~perm m1 b1 ofs Max Nonempty. + Proof. + intros. eapply mwi_perm_inv; eauto. + Qed. + + Theorem range_perm_winject: + forall f m1 m2 b1 b2 delta lo hi k p, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + range_perm m1 b1 lo hi k p -> range_perm m2 b2 (lo + delta) (hi + delta) k p. + Proof. + intros. inv H0. eapply range_perm_winj; eauto. + Qed. + + Theorem valid_access_winject: + forall f m1 m2 chunk b1 ofs b2 delta p cp, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + valid_access m1 chunk b1 ofs p cp -> + valid_access m2 chunk b2 (ofs + delta) p cp. + Proof. + intros. eapply valid_access_winj; eauto. apply mwi_inj; auto. + Qed. + + (* Theorem valid_pointer_winject: *) + (* forall f m1 m2 b1 ofs b2 delta, *) + (* f b1 = Some(b2, delta) -> *) + (* winject f m1 m2 -> *) + (* valid_pointer m1 b1 ofs = true -> *) + (* valid_pointer m2 b2 (ofs + delta) = true. *) + (* Proof. *) + (* intros. *) + (* pose proof valid_pointer_can_access_block _ _ _ H1 as [cp Hown]. *) + (* unfold can_access_block in Hown. *) + (* rewrite (valid_pointer_valid_access_nonpriv _ _ _ _ Hown) in H1. *) + (* rewrite valid_pointer_valid_access_nonpriv. *) + (* eapply valid_access_winject; eauto. *) + (* inv H0. inv mwi_inj0. eapply mwi_own0 with (cp := Some cp); eauto. *) + (* Qed. *) + + (* Theorem weak_valid_pointer_winject: *) + (* forall f m1 m2 b1 ofs b2 delta, *) + (* f b1 = Some(b2, delta) -> *) + (* winject f m1 m2 -> *) + (* weak_valid_pointer m1 b1 ofs = true -> *) + (* weak_valid_pointer m2 b2 (ofs + delta) = true. *) + (* Proof. *) + (* intros until 2. unfold weak_valid_pointer. rewrite !orb_true_iff. *) + (* replace (ofs + delta - 1) with ((ofs - 1) + delta) by lia. *) + (* intros []; eauto using valid_pointer_winject. *) + (* Qed. *) + + (** The following lemmas establish the absence of machine integer overflow + during address computations. *) + + Lemma address_winject: + forall f m1 m2 b1 ofs1 b2 delta p, + winject f m1 m2 -> + perm m1 b1 (Ptrofs.unsigned ofs1) Cur p -> + f b1 = Some (b2, delta) -> + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) = Ptrofs.unsigned ofs1 + delta. + Proof. + intros. + assert (perm m1 b1 (Ptrofs.unsigned ofs1) Max Nonempty) by eauto with mem. + exploit mwi_representable; eauto. intros [A B]. + assert (0 <= delta <= Ptrofs.max_unsigned). + generalize (Ptrofs.unsigned_range ofs1). lia. + unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr; lia. + Qed. + + Lemma address_winject': + forall f m1 m2 chunk b1 ofs1 cp b2 delta, + winject f m1 m2 -> + valid_access m1 chunk b1 (Ptrofs.unsigned ofs1) Nonempty cp -> + f b1 = Some (b2, delta) -> + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) = Ptrofs.unsigned ofs1 + delta. + Proof. + intros. destruct H0. eapply address_winject; eauto. + apply H0. generalize (size_chunk_pos chunk). lia. + Qed. + + Theorem weak_valid_pointer_winject_no_overflow: + forall f m1 m2 b ofs b' delta, + winject f m1 m2 -> + weak_valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> + f b = Some(b', delta) -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. + Proof. + intros. rewrite weak_valid_pointer_spec in H0. + rewrite ! valid_pointer_nonempty_perm in H0. + exploit mwi_representable; eauto. destruct H0; eauto with mem. + intros [A B]. + pose proof (Ptrofs.unsigned_range ofs). + rewrite Ptrofs.unsigned_repr; lia. + Qed. + + Theorem valid_pointer_winject_no_overflow: + forall f m1 m2 b ofs b' delta, + winject f m1 m2 -> + valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> + f b = Some(b', delta) -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. + Proof. + eauto using weak_valid_pointer_winject_no_overflow, valid_pointer_implies. + Qed. + + (* Theorem valid_pointer_winject_val: *) + (* forall f m1 m2 b ofs b' ofs', *) + (* winject f m1 m2 -> *) + (* valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> *) + (* Val.inject f (Vptr b ofs) (Vptr b' ofs') -> *) + (* valid_pointer m2 b' (Ptrofs.unsigned ofs') = true. *) + (* Proof. *) + (* intros. inv H1. *) + (* pose proof valid_pointer_can_access_block _ _ _ H0 as [cp Hown]. *) + (* erewrite address_winject'; eauto. *) + (* eapply valid_pointer_winject; eauto. *) + (* rewrite valid_pointer_valid_access_nonpriv in H0. eauto. *) + (* eauto. *) + (* Qed. *) + + (* Theorem weak_valid_pointer_winject_val: *) + (* forall f m1 m2 b ofs b' ofs', *) + (* winject f m1 m2 -> *) + (* weak_valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> *) + (* Val.inject f (Vptr b ofs) (Vptr b' ofs') -> *) + (* weak_valid_pointer m2 b' (Ptrofs.unsigned ofs') = true. *) + (* Proof. *) + (* intros. inv H1. *) + (* exploit weak_valid_pointer_winject; eauto. intros W. *) + (* rewrite weak_valid_pointer_spec in H0. *) + (* rewrite ! valid_pointer_nonempty_perm in H0. *) + (* exploit mwi_representable; eauto. destruct H0; eauto with mem. *) + (* intros [A B]. *) + (* pose proof (Ptrofs.unsigned_range ofs). *) + (* unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr; auto; lia. *) + (* Qed. *) + + (* Theorem winject_no_overlap: *) + (* forall f m1 m2 b1 b2 b1' b2' delta1 delta2 ofs1 ofs2, *) + (* winject f m1 m2 -> *) + (* b1 <> b2 -> *) + (* f b1 = Some (b1', delta1) -> *) + (* f b2 = Some (b2', delta2) -> *) + (* perm m1 b1 ofs1 Max Nonempty -> *) + (* perm m1 b2 ofs2 Max Nonempty -> *) + (* b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2. *) + (* Proof. *) + (* intros. inv H. eapply mwi_no_overlap0; eauto. *) + (* Qed. *) + + (* Theorem different_pointers_winject: *) + (* forall f m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, *) + (* winject f m m' -> *) + (* b1 <> b2 -> *) + (* valid_pointer m b1 (Ptrofs.unsigned ofs1) = true -> *) + (* valid_pointer m b2 (Ptrofs.unsigned ofs2) = true -> *) + (* f b1 = Some (b1', delta1) -> *) + (* f b2 = Some (b2', delta2) -> *) + (* b1' <> b2' \/ *) + (* Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> *) + (* Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). *) + (* Proof. *) + (* intros. *) + (* destruct (valid_pointer_can_access_block _ _ _ H1) as [cp1 Hown1]. *) + (* destruct (valid_pointer_can_access_block _ _ _ H2) as [cp2 Hown2]. *) + (* rewrite valid_pointer_valid_access_nonpriv in H1. *) + (* rewrite valid_pointer_valid_access_nonpriv in H2. *) + (* rewrite (address_winject' _ _ _ _ _ _ (Some cp1) _ _ H H1 H3). *) + (* rewrite (address_winject' _ _ _ _ _ _ (Some cp2) _ _ H H2 H4). *) + (* inv H1. simpl in H5. inv H2. simpl in H1. *) + (* eapply mwi_no_overlap; eauto. *) + (* apply perm_cur_max. apply (H5 (Ptrofs.unsigned ofs1)). lia. *) + (* apply perm_cur_max. apply (H1 (Ptrofs.unsigned ofs2)). lia. *) + (* congruence. *) + (* congruence. *) + (* Qed. *) + + (* Theorem disjoint_or_equal_winject: *) + (* forall f m m' b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 sz, *) + (* winject f m m' -> *) + (* f b1 = Some(b1', delta1) -> *) + (* f b2 = Some(b2', delta2) -> *) + (* range_perm m b1 ofs1 (ofs1 + sz) Max Nonempty -> *) + (* range_perm m b2 ofs2 (ofs2 + sz) Max Nonempty -> *) + (* sz > 0 -> *) + (* b1 <> b2 \/ ofs1 = ofs2 \/ ofs1 + sz <= ofs2 \/ ofs2 + sz <= ofs1 -> *) + (* b1' <> b2' \/ ofs1 + delta1 = ofs2 + delta2 *) + (* \/ ofs1 + delta1 + sz <= ofs2 + delta2 *) + (* \/ ofs2 + delta2 + sz <= ofs1 + delta1. *) + (* Proof. *) + (* intros. *) + (* destruct (eq_block b1 b2). *) + (* assert (b1' = b2') by congruence. assert (delta1 = delta2) by congruence. subst. *) + (* destruct H5. congruence. right. destruct H5. left; congruence. right. lia. *) + (* destruct (eq_block b1' b2'); auto. subst. right. right. *) + (* set (i1 := (ofs1 + delta1, ofs1 + delta1 + sz)). *) + (* set (i2 := (ofs2 + delta2, ofs2 + delta2 + sz)). *) + (* change (snd i1 <= fst i2 \/ snd i2 <= fst i1). *) + (* apply Intv.range_disjoint'; simpl; try lia. *) + (* unfold Intv.disjoint, Intv.In; simpl; intros. red; intros. *) + (* exploit mwi_no_overlap; eauto. *) + (* instantiate (1 := x - delta1). apply H2. lia. *) + (* instantiate (1 := x - delta2). apply H3. lia. *) + (* intuition. *) + (* Qed. *) + + (* Theorem aligned_area_winject: *) + (* forall f m m' b ofs al sz b' delta cp, *) + (* winject f m m' -> *) + (* al = 1 \/ al = 2 \/ al = 4 \/ al = 8 -> sz > 0 -> *) + (* (al | sz) -> *) + (* range_perm m b ofs (ofs + sz) Cur Nonempty -> *) + (* (al | ofs) -> *) + (* f b = Some(b', delta) -> *) + (* forall OWN : can_access_block m b cp, *) + (* (al | ofs + delta). *) + (* Proof. *) + (* intros. *) + (* assert (P: al > 0) by lia. *) + (* assert (Q: Z.abs al <= Z.abs sz). apply Zdivide_bounds; auto. lia. *) + (* rewrite Z.abs_eq in Q; try lia. rewrite Z.abs_eq in Q; try lia. *) + (* assert (R: exists chunk, al = align_chunk chunk /\ al = size_chunk chunk). *) + (* destruct H0. subst; exists Mint8unsigned; auto. *) + (* destruct H0. subst; exists Mint16unsigned; auto. *) + (* destruct H0. subst; exists Mint32; auto. *) + (* subst; exists Mint64; auto. *) + (* destruct R as [chunk [A B]]. *) + (* assert (valid_access m chunk b ofs Nonempty cp). *) + (* split. red; intros; apply H3. lia. *) + (* split. assumption. congruence. *) + (* exploit valid_access_winject; eauto. intros [C [D E]]. *) + (* congruence. *) + (* Qed. *) + + (* (** Preservation of stores *) *) + + (* Theorem store_mapped_winject: *) + (* forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta v2, *) + (* winject f m1 m2 -> *) + (* store chunk m1 b1 ofs v1 cp = Some n1 -> *) + (* f b1 = Some (b2, delta) -> *) + (* exists n2, *) + (* store chunk m2 b2 (ofs + delta) v2 cp = Some n2 *) + (* /\ winject f n1 n2. *) + (* Proof. *) + (* intros. inversion H. *) + (* exploit store_mapped_winj; eauto. intros [n2 [STORE MI]]. *) + (* exists n2; split. eauto. constructor. *) + (* (* winj *) *) + (* auto. *) + (* (* freeblocks *) *) + (* eauto with mem. *) + (* (* mappedblocks *) *) + (* eauto with mem. *) + (* (* no overlap *) *) + (* red; intros. eauto with mem. *) + (* (* representable *) *) + (* intros. eapply mwi_representable; try eassumption. *) + (* destruct H3; eauto with mem. *) + (* (* perm inv *) *) + (* intros. exploit mwi_perm_inv0; eauto using perm_store_2. *) + (* intuition eauto using perm_store_1, perm_store_2. *) + (* Qed. *) + + (* Theorem store_unmapped_winject: *) + (* forall f chunk m1 b1 ofs v1 cp n1 m2, *) + (* winject f m1 m2 -> *) + (* store chunk m1 b1 ofs v1 cp = Some n1 -> *) + (* f b1 = None -> *) + (* winject f n1 m2. *) + (* Proof. *) + (* intros. inversion H. *) + (* constructor. *) + (* (* winj *) *) + (* eapply store_unmapped_winj; eauto. *) + (* (* freeblocks *) *) + (* eauto with mem. *) + (* (* mappedblocks *) *) + (* eauto with mem. *) + (* (* no overlap *) *) + (* red; intros. eauto with mem. *) + (* (* representable *) *) + (* intros. eapply mwi_representable; try eassumption. *) + (* destruct H3; eauto with mem. *) + (* (* perm inv *) *) + (* intros. exploit mwi_perm_inv0; eauto using perm_store_2. *) + (* intuition eauto using perm_store_1, perm_store_2. *) + (* Qed. *) + + (* Theorem store_outside_winject: *) + (* forall f m1 m2 chunk b ofs v cp m2', *) + (* winject f m1 m2 -> *) + (* (forall b' delta ofs', *) + (* f b' = Some(b, delta) -> *) + (* perm m1 b' ofs' Cur Readable -> *) + (* ofs <= ofs' + delta < ofs + size_chunk chunk -> False) -> *) + (* store chunk m2 b ofs v cp = Some m2' -> *) + (* winject f m1 m2'. *) + (* Proof. *) + (* intros. inversion H. constructor. *) + (* (* winj *) *) + (* eapply store_outside_winj; eauto. *) + (* (* freeblocks *) *) + (* auto. *) + (* (* mappedblocks *) *) + (* eauto with mem. *) + (* (* no overlap *) *) + (* auto. *) + (* (* representable *) *) + (* eauto with mem. *) + (* (* perm inv *) *) + (* intros. eauto using perm_store_2. *) + (* Qed. *) + + (* Theorem storev_mapped_winject: *) + (* forall f chunk m1 a1 v1 cp n1 m2 a2 v2, *) + (* winject f m1 m2 -> *) + (* storev chunk m1 a1 v1 cp = Some n1 -> *) + (* Val.inject f a1 a2 -> *) + (* Val.inject f v1 v2 -> *) + (* exists n2, *) + (* storev chunk m2 a2 v2 cp = Some n2 /\ winject f n1 n2. *) + (* Proof. *) + (* intros. inv H1; simpl in H0; try discriminate. *) + (* unfold storev. *) + (* replace (Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta))) *) + (* with (Ptrofs.unsigned ofs1 + delta). *) + (* eapply store_mapped_winject; eauto. *) + (* symmetry. eapply address_winject'; eauto with mem. *) + (* Qed. *) + + (* Theorem storebytes_mapped_winject: *) + (* forall f m1 b1 ofs bytes1 cp n1 m2 b2 delta bytes2, *) + (* winject f m1 m2 -> *) + (* storebytes m1 b1 ofs bytes1 cp = Some n1 -> *) + (* f b1 = Some (b2, delta) -> *) + (* list_forall2 (memval_inject f) bytes1 bytes2 -> *) + (* exists n2, *) + (* storebytes m2 b2 (ofs + delta) bytes2 cp = Some n2 *) + (* /\ winject f n1 n2. *) + (* Proof. *) + (* intros. inversion H. *) + (* exploit storebytes_mapped_winj; eauto. intros [n2 [STORE MI]]. *) + (* exists n2; split. eauto. constructor. *) + (* (* winj *) *) + (* auto. *) + (* (* freeblocks *) *) + (* intros. apply mi_freeblocks0. red; intros; elim H3; eapply storebytes_valid_block_1; eauto. *) + (* (* mappedblocks *) *) + (* intros. eapply storebytes_valid_block_1; eauto. *) + (* (* no overlap *) *) + (* red; intros. eapply mwi_no_overlap0; eauto; eapply perm_storebytes_2; eauto. *) + (* (* representable *) *) + (* intros. eapply mwi_representable0; eauto. *) + (* destruct H4; eauto using perm_storebytes_2. *) + (* (* perm inv *) *) + (* intros. exploit mwi_perm_inv0; eauto using perm_storebytes_2. *) + (* intuition eauto using perm_storebytes_1, perm_storebytes_2. *) + (* Qed. *) + + (* Theorem storebytes_unmapped_winject: *) + (* forall f m1 b1 ofs bytes1 cp n1 m2, *) + (* winject f m1 m2 -> *) + (* storebytes m1 b1 ofs bytes1 cp = Some n1 -> *) + (* f b1 = None -> *) + (* winject f n1 m2. *) + (* Proof. *) + (* intros. inversion H. *) + (* constructor. *) + (* (* winj *) *) + (* eapply storebytes_unmapped_winj; eauto. *) + (* (* freeblocks *) *) + (* intros. apply mi_freeblocks0. red; intros; elim H2; eapply storebytes_valid_block_1; eauto. *) + (* (* mappedblocks *) *) + (* eauto with mem. *) + (* (* no overlap *) *) + (* red; intros. eapply mwi_no_overlap0; eauto; eapply perm_storebytes_2; eauto. *) + (* (* representable *) *) + (* intros. eapply mwi_representable0; eauto. *) + (* destruct H3; eauto using perm_storebytes_2. *) + (* (* perm inv *) *) + (* intros. exploit mwi_perm_inv0; eauto. *) + (* intuition eauto using perm_storebytes_1, perm_storebytes_2. *) + (* Qed. *) + + (* Theorem storebytes_outside_winject: *) + (* forall f m1 m2 b ofs bytes2 cp m2', *) + (* winject f m1 m2 -> *) + (* (forall b' delta ofs', *) + (* f b' = Some(b, delta) -> *) + (* perm m1 b' ofs' Cur Readable -> *) + (* ofs <= ofs' + delta < ofs + Z.of_nat (length bytes2) -> False) -> *) + (* storebytes m2 b ofs bytes2 cp = Some m2' -> *) + (* winject f m1 m2'. *) + (* Proof. *) + (* intros. inversion H. constructor. *) + (* (* winj *) *) + (* eapply storebytes_outside_winj; eauto. *) + (* (* freeblocks *) *) + (* auto. *) + (* (* mappedblocks *) *) + (* intros. eapply storebytes_valid_block_1; eauto. *) + (* (* no overlap *) *) + (* auto. *) + (* (* representable *) *) + (* auto. *) + (* (* perm inv *) *) + (* intros. eapply mwi_perm_inv0; eauto using perm_storebytes_2. *) + (* Qed. *) + + (* Theorem storebytes_empty_winject: *) + (* forall f m1 b1 ofs1 cp1 m1' m2 b2 ofs2 cp2 m2', *) + (* winject f m1 m2 -> *) + (* storebytes m1 b1 ofs1 nil cp1 = Some m1' -> *) + (* storebytes m2 b2 ofs2 nil cp2 = Some m2' -> *) + (* winject f m1' m2'. *) + (* Proof. *) + (* intros. inversion H. constructor; intros. *) + (* (* winj *) *) + (* eapply storebytes_empty_winj; eauto. *) + (* (* freeblocks *) *) + (* intros. apply mi_freeblocks0. red; intros; elim H2; eapply storebytes_valid_block_1; eauto. *) + (* (* mappedblocks *) *) + (* intros. eapply storebytes_valid_block_1; eauto. *) + (* (* no overlap *) *) + (* red; intros. eapply mwi_no_overlap0; eauto; eapply perm_storebytes_2; eauto. *) + (* (* representable *) *) + (* intros. eapply mwi_representable0; eauto. *) + (* destruct H3; eauto using perm_storebytes_2. *) + (* (* perm inv *) *) + (* intros. exploit mwi_perm_inv0; eauto using perm_storebytes_2. *) + (* intuition eauto using perm_storebytes_1, perm_storebytes_2. *) + (* Qed. *) + + (* (* Preservation of allocations *) *) + + (* Theorem alloc_right_winject: *) + (* forall f m1 m2 c lo hi b2 m2', *) + (* winject f m1 m2 -> *) + (* alloc m2 c lo hi = (m2', b2) -> *) + (* winject f m1 m2'. *) + (* Proof. *) + (* intros. injection H0. intros NEXT MEM. *) + (* inversion H. constructor. *) + (* (* winj *) *) + (* eapply alloc_right_winj; eauto. *) + (* (* freeblocks *) *) + (* auto. *) + (* (* mappedblocks *) *) + (* eauto with mem. *) + (* (* no overlap *) *) + (* auto. *) + (* (* representable *) *) + (* auto. *) + (* (* perm inv *) *) + (* intros. eapply perm_alloc_inv in H2; eauto. destruct (eq_block b0 b2). *) + (* subst b0. eelim fresh_block_alloc; eauto. *) + (* eapply mwi_perm_inv0; eauto. *) + (* Qed. *) + + (* Theorem alloc_left_unmapped_winject: *) + (* forall f m1 m2 c lo hi m1' b1, *) + (* winject f m1 m2 -> *) + (* alloc m1 c lo hi = (m1', b1) -> *) + (* exists f', *) + (* winject f' m1' m2 *) + (* /\ inject_incr f f' *) + (* /\ f' b1 = None *) + (* /\ (forall b, b <> b1 -> f' b = f b). *) + (* Proof. *) + (* intros. inversion H. *) + (* set (f' := fun b => if eq_block b b1 then None else f b). *) + (* assert (inject_incr f f'). *) + (* red; unfold f'; intros. destruct (eq_block b b1). subst b. *) + (* assert (f b1 = None). eauto with mem. congruence. *) + (* auto. *) + (* assert (mem_winj f' m1 m2). *) + (* inversion mwi_inj0; constructor; eauto with mem. *) + (* unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. *) + (* unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. *) + (* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) + (* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) + (* eapply mwi_align0; eauto. *) + (* exists f'; split. constructor. *) + (* (* winj *) *) + (* eapply alloc_left_unmapped_winj; eauto. unfold f'; apply dec_eq_true. *) + (* (* freeblocks *) *) + (* intros. unfold f'. destruct (eq_block b b1). auto. *) + (* apply mi_freeblocks0. red; intro; elim H3. eauto with mem. *) + (* (* mappedblocks *) *) + (* unfold f'; intros. destruct (eq_block b b1). congruence. eauto. *) + (* (* no overlap *) *) + (* unfold f'; red; intros. *) + (* destruct (eq_block b0 b1); destruct (eq_block b2 b1); try congruence. *) + (* eapply mwi_no_overlap0. eexact H3. eauto. eauto. *) + (* exploit perm_alloc_inv. eauto. eexact H6. rewrite dec_eq_false; auto. *) + (* exploit perm_alloc_inv. eauto. eexact H7. rewrite dec_eq_false; auto. *) + (* (* representable *) *) + (* unfold f'; intros. *) + (* destruct (eq_block b b1); try discriminate. *) + (* eapply mwi_representable0; try eassumption. *) + (* destruct H4; eauto using perm_alloc_4. *) + (* (* perm inv *) *) + (* intros. unfold f' in H3; destruct (eq_block b0 b1); try discriminate. *) + (* exploit mwi_perm_inv0; eauto. *) + (* intuition eauto using perm_alloc_1, perm_alloc_4. *) + (* (* incr *) *) + (* split. auto. *) + (* (* image *) *) + (* split. unfold f'; apply dec_eq_true. *) + (* (* incr *) *) + (* intros; unfold f'; apply dec_eq_false; auto. *) + (* Qed. *) + + (* Theorem alloc_left_mapped_winject: *) + (* forall f m1 m2 c lo hi m1' b1 b2 delta, *) + (* winject f m1 m2 -> *) + (* alloc m1 c lo hi = (m1', b1) -> *) + (* valid_block m2 b2 -> *) + (* forall OWN : can_access_block m2 b2 (Some c), *) + (* 0 <= delta <= Ptrofs.max_unsigned -> *) + (* (forall ofs k p, perm m2 b2 ofs k p -> delta = 0 \/ 0 <= ofs < Ptrofs.max_unsigned) -> *) + (* (forall ofs k p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) k p) -> *) + (* winj_offset_aligned delta (hi-lo) -> *) + (* (forall b delta' ofs k p, *) + (* f b = Some (b2, delta') -> *) + (* perm m1 b ofs k p -> *) + (* lo + delta <= ofs + delta' < hi + delta -> False) -> *) + (* exists f', *) + (* winject f' m1' m2 *) + (* /\ inject_incr f f' *) + (* /\ f' b1 = Some(b2, delta) *) + (* /\ (forall b, b <> b1 -> f' b = f b). *) + (* Proof. *) + (* intros. inversion H. *) + (* set (f' := fun b => if eq_block b b1 then Some(b2, delta) else f b). *) + (* assert (inject_incr f f'). *) + (* red; unfold f'; intros. destruct (eq_block b b1). subst b. *) + (* assert (f b1 = None). eauto with mem. congruence. *) + (* auto. *) + (* assert (mem_winj f' m1 m2). *) + (* inversion mwi_inj0; constructor; eauto with mem. *) + (* unfold f'; intros. destruct (eq_block b0 b1). *) + (* inversion H8. subst b0 b3 delta0. *) + (* elim (fresh_block_alloc _ _ _ _ _ _ H0). eauto with mem. *) + (* eauto. *) + (* unfold f'; intros. destruct cp as [cp |]; [| trivial]. destruct (eq_block b0 b1). *) + (* inversion H8. subst b0 b3 delta0. *) + (* apply unowned_fresh_block with (c' := cp) in H0. contradiction. *) + (* eapply mwi_own0; eauto. *) + (* unfold f'; intros. destruct (eq_block b0 b1). *) + (* inversion H8. subst b0 b3 delta0. *) + (* elim (fresh_block_alloc _ _ _ _ _ _ H0). *) + (* eapply perm_valid_block with (ofs := ofs). apply H9. generalize (size_chunk_pos chunk); lia. *) + (* eauto. *) + (* exists f'. split. constructor. *) + (* (* winj *) *) + (* eapply alloc_left_mapped_winj; eauto. unfold f'; apply dec_eq_true. *) + (* (* freeblocks *) *) + (* unfold f'; intros. destruct (eq_block b b1). subst b. *) + (* elim H9. eauto with mem. *) + (* eauto with mem. *) + (* (* mappedblocks *) *) + (* unfold f'; intros. destruct (eq_block b b1). congruence. eauto. *) + (* (* overlap *) *) + (* unfold f'; red; intros. *) + (* exploit perm_alloc_inv. eauto. eexact H12. intros P1. *) + (* exploit perm_alloc_inv. eauto. eexact H13. intros P2. *) + (* destruct (eq_block b0 b1); destruct (eq_block b3 b1). *) + (* congruence. *) + (* inversion H10; subst b0 b1' delta1. *) + (* destruct (eq_block b2 b2'); auto. subst b2'. right; red; intros. *) + (* eapply H6; eauto. lia. *) + (* inversion H11; subst b3 b2' delta2. *) + (* destruct (eq_block b1' b2); auto. subst b1'. right; red; intros. *) + (* eapply H6; eauto. lia. *) + (* eauto. *) + (* (* representable *) *) + (* unfold f'; intros. *) + (* destruct (eq_block b b1). *) + (* subst. injection H9; intros; subst b' delta0. destruct H10. *) + (* exploit perm_alloc_inv; eauto; rewrite dec_eq_true; intro. *) + (* exploit H3. apply H4 with (k := Max) (p := Nonempty); eauto. *) + (* generalize (Ptrofs.unsigned_range_2 ofs). lia. *) + (* exploit perm_alloc_inv; eauto; rewrite dec_eq_true; intro. *) + (* exploit H3. apply H4 with (k := Max) (p := Nonempty); eauto. *) + (* generalize (Ptrofs.unsigned_range_2 ofs). lia. *) + (* eapply mwi_representable0; try eassumption. *) + (* destruct H10; eauto using perm_alloc_4. *) + (* (* perm inv *) *) + (* intros. unfold f' in H9; destruct (eq_block b0 b1). *) + (* inversion H9; clear H9; subst b0 b3 delta0. *) + (* assert (EITHER: lo <= ofs < hi \/ ~(lo <= ofs < hi)) by lia. *) + (* destruct EITHER. *) + (* left. apply perm_implies with Freeable; auto with mem. eapply perm_alloc_2; eauto. *) + (* right; intros A. eapply perm_alloc_inv in A; eauto. rewrite dec_eq_true in A. tauto. *) + (* exploit mwi_perm_inv0; eauto. intuition eauto using perm_alloc_1, perm_alloc_4. *) + (* (* incr *) *) + (* split. auto. *) + (* (* image of b1 *) *) + (* split. unfold f'; apply dec_eq_true. *) + (* (* image of others *) *) + (* intros. unfold f'; apply dec_eq_false; auto. *) + (* Qed. *) + + (* Theorem alloc_parallel_winject: *) + (* forall f m1 m2 c lo1 hi1 m1' b1 lo2 hi2, *) + (* winject f m1 m2 -> *) + (* alloc m1 c lo1 hi1 = (m1', b1) -> *) + (* lo2 <= lo1 -> hi1 <= hi2 -> *) + (* exists f', exists m2', exists b2, *) + (* alloc m2 c lo2 hi2 = (m2', b2) *) + (* /\ winject f' m1' m2' *) + (* /\ inject_incr f f' *) + (* /\ f' b1 = Some(b2, 0) *) + (* /\ (forall b, b <> b1 -> f' b = f b). *) + (* Proof. *) + (* intros. *) + (* case_eq (alloc m2 c lo2 hi2). intros m2' b2 ALLOC. *) + (* exploit alloc_left_mapped_winject. *) + (* eapply alloc_right_winject; eauto. *) + (* eauto. *) + (* instantiate (1 := b2). eauto with mem. *) + (* eapply owned_new_block; eauto. *) + (* instantiate (1 := 0). unfold Ptrofs.max_unsigned. generalize Ptrofs.modulus_pos; lia. *) + (* auto. *) + (* intros. apply perm_implies with Freeable; auto with mem. *) + (* eapply perm_alloc_2; eauto. lia. *) + (* red; intros. apply Z.divide_0_r. *) + (* intros. apply (valid_not_valid_diff m2 b2 b2); eauto with mem. *) + (* intros [f' [A [B [C D]]]]. *) + (* exists f'; exists m2'; exists b2; auto. *) + (* Qed. *) + + (* (** Preservation of [free] operations *) *) + + (* Lemma free_left_winject: *) + (* forall f m1 m2 b lo hi cp m1', *) + (* winject f m1 m2 -> *) + (* free m1 b lo hi cp = Some m1' -> *) + (* winject f m1' m2. *) + (* Proof. *) + (* intros. inversion H. constructor. *) + (* (* winj *) *) + (* eapply free_left_winj; eauto. *) + (* (* freeblocks *) *) + (* eauto with mem. *) + (* (* mappedblocks *) *) + (* auto. *) + (* (* no overlap *) *) + (* red; intros. eauto with mem. *) + (* (* representable *) *) + (* intros. eapply mwi_representable0; try eassumption. *) + (* destruct H2; eauto with mem. *) + (* (* perm inv *) *) + (* intros. exploit mwi_perm_inv0; eauto. intuition eauto using perm_free_3. *) + (* eapply perm_free_inv in H4; eauto. destruct H4 as [[A B] | A]; auto. *) + (* subst b1. right; eapply perm_free_2; eauto. *) + (* Qed. *) + + (* Lemma free_list_left_winject: *) + (* forall f m2 l cp m1 m1', *) + (* winject f m1 m2 -> *) + (* free_list m1 l cp = Some m1' -> *) + (* winject f m1' m2. *) + (* Proof. *) + (* induction l; simpl; intros. *) + (* inv H0. auto. *) + (* destruct a as [[b lo] hi]. *) + (* destruct (free m1 b lo hi) as [m11|] eqn:E; try discriminate. *) + (* apply IHl with cp m11; auto. eapply free_left_winject; eauto. *) + (* Qed. *) + + (* Lemma free_right_winject: *) + (* forall f m1 m2 b lo hi cp m2', *) + (* winject f m1 m2 -> *) + (* free m2 b lo hi cp = Some m2' -> *) + (* (forall b1 delta ofs k p, *) + (* f b1 = Some(b, delta) -> perm m1 b1 ofs k p -> *) + (* lo <= ofs + delta < hi -> False) -> *) + (* winject f m1 m2'. *) + (* Proof. *) + (* intros. inversion H. constructor. *) + (* (* winj *) *) + (* eapply free_right_winj; eauto. *) + (* (* freeblocks *) *) + (* auto. *) + (* (* mappedblocks *) *) + (* eauto with mem. *) + (* (* no overlap *) *) + (* auto. *) + (* (* representable *) *) + (* auto. *) + (* (* perm inv *) *) + (* intros. eauto using perm_free_3. *) + (* Qed. *) + + (* Lemma perm_free_list: *) + (* forall l m cp m' b ofs k p, *) + (* free_list m l cp = Some m' -> *) + (* perm m' b ofs k p -> *) + (* perm m b ofs k p /\ *) + (* (forall lo hi, In (b, lo, hi) l -> lo <= ofs < hi -> False). *) + (* Proof. *) + (* induction l; simpl; intros. *) + (* inv H. auto. *) + (* destruct a as [[b1 lo1] hi1]. *) + (* destruct (free m b1 lo1 hi1) as [m1|] eqn:E; try discriminate. *) + (* exploit IHl; eauto. intros [A B]. *) + (* split. eauto with mem. *) + (* intros. destruct H1. inv H1. *) + (* elim (perm_free_2 _ _ _ _ _ _ E ofs k p). auto. auto. *) + (* eauto. *) + (* Qed. *) + + (* Theorem free_winject: *) + (* forall f m1 l cp1 m1' m2 b lo hi cp2 m2', *) + (* winject f m1 m2 -> *) + (* free_list m1 l cp1 = Some m1' -> *) + (* free m2 b lo hi cp2 = Some m2' -> *) + (* (forall b1 delta ofs k p, *) + (* f b1 = Some(b, delta) -> *) + (* perm m1 b1 ofs k p -> lo <= ofs + delta < hi -> *) + (* exists lo1, exists hi1, In (b1, lo1, hi1) l /\ lo1 <= ofs < hi1) -> *) + (* winject f m1' m2'. *) + (* Proof. *) + (* intros. *) + (* eapply free_right_winject; eauto. *) + (* eapply free_list_left_winject; eauto. *) + (* intros. exploit perm_free_list; eauto. intros [A B]. *) + (* exploit H2; eauto. intros [lo1 [hi1 [C D]]]. eauto. *) + (* Qed. *) + + (* Theorem free_parallel_winject: *) + (* forall f m1 m2 b lo hi cp m1' b' delta, *) + (* winject f m1 m2 -> *) + (* free m1 b lo hi cp = Some m1' -> *) + (* f b = Some(b', delta) -> *) + (* exists m2', *) + (* free m2 b' (lo + delta) (hi + delta) cp = Some m2' *) + (* /\ winject f m1' m2'. *) + (* Proof. *) + (* intros. *) + (* destruct (range_perm_free m2 b' (lo + delta) (hi + delta) cp) as [m2' FREE]. *) + (* eapply range_perm_winject; eauto. eapply free_range_perm; eauto. *) + (* inv H. inv mwi_inj0. eapply mwi_own0; eauto. eapply free_can_access_block_1; eauto. *) + (* exists m2'; split; auto. *) + (* eapply free_winject with (m1 := m1) (l := (b,lo,hi)::nil); eauto. *) + (* simpl; rewrite H0; auto. *) + (* intros. destruct (eq_block b1 b). *) + (* subst b1. rewrite H1 in H2; inv H2. *) + (* exists lo, hi; split; auto with coqlib. lia. *) + (* exploit mwi_no_overlap. eexact H. eexact n. eauto. eauto. *) + (* eapply perm_max. eapply perm_implies. eauto. auto with mem. *) + (* instantiate (1 := ofs + delta0 - delta). *) + (* apply perm_cur_max. apply perm_implies with Freeable; auto with mem. *) + (* eapply free_range_perm; eauto. lia. *) + (* intros [A|A]. congruence. lia. *) + (* Qed. *) + + (* Lemma drop_outside_winject: forall f m1 m2 b lo hi p cp m2', *) + (* winject f m1 m2 -> *) + (* drop_perm m2 b lo hi p cp = Some m2' -> *) + (* (forall b' delta ofs k p, *) + (* f b' = Some(b, delta) -> *) + (* perm m1 b' ofs k p -> lo <= ofs + delta < hi -> False) -> *) + (* winject f m1 m2'. *) + (* Proof. *) + (* intros. destruct H. constructor; eauto. *) + (* eapply drop_outside_winj; eauto. *) + (* intros. unfold valid_block in *. erewrite nextblock_drop; eauto. *) + (* intros. eapply mwi_perm_inv0; eauto using perm_drop_4. *) + (* Qed. *) + + (* (** Composing two memory winjections. *) *) + + (* Lemma mem_winj_compose: *) + (* forall f f' m1 m2 m3, *) + (* mem_winj f m1 m2 -> mem_winj f' m2 m3 -> mem_winj (compose_meminj f f') m1 m3. *) + (* Proof. *) + (* intros. unfold compose_meminj. inv H; inv H0; constructor; intros. *) + (* (* perm *) *) + (* destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. *) + (* destruct (f' b') as [[b'' delta''] |] eqn:?; inv H. *) + (* replace (ofs + (delta' + delta'')) with ((ofs + delta') + delta'') by lia. *) + (* eauto. *) + (* (* own *) *) + (* destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. *) + (* destruct (f' b') as [[b'' delta''] |] eqn:?; inv H. *) + (* eapply mwi_own1; eauto. *) + (* (* align *) *) + (* destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. *) + (* destruct (f' b') as [[b'' delta''] |] eqn:?; inv H. *) + (* apply Z.divide_add_r. *) + (* eapply mwi_align0; eauto. *) + (* eapply mwi_align1 with (ofs := ofs + delta') (p := p); eauto. *) + (* red; intros. replace ofs0 with ((ofs0 - delta') + delta') by lia. *) + (* eapply mwi_perm0; eauto. apply H0. lia. *) + (* Qed. *) + + (* Theorem winject_compose: *) + (* forall f f' m1 m2 m3, *) + (* winject f m1 m2 -> winject f' m2 m3 -> *) + (* winject (compose_meminj f f') m1 m3. *) + (* Proof. *) + (* unfold compose_meminj; intros. *) + (* inv H; inv H0. constructor. *) + (* (* winj *) *) + (* eapply mem_winj_compose; eauto. *) + (* (* unmapped *) *) + (* intros. erewrite mi_freeblocks0; eauto. *) + (* (* mapped *) *) + (* intros. *) + (* destruct (f b) as [[b1 delta1] |] eqn:?; try discriminate. *) + (* destruct (f' b1) as [[b2 delta2] |] eqn:?; inv H. *) + (* eauto. *) + (* (* no overlap *) *) + (* red; intros. *) + (* destruct (f b1) as [[b1x delta1x] |] eqn:?; try discriminate. *) + (* destruct (f' b1x) as [[b1y delta1y] |] eqn:?; inv H0. *) + (* destruct (f b2) as [[b2x delta2x] |] eqn:?; try discriminate. *) + (* destruct (f' b2x) as [[b2y delta2y] |] eqn:?; inv H1. *) + (* exploit mwi_no_overlap0; eauto. intros A. *) + (* destruct (eq_block b1x b2x). *) + (* subst b1x. destruct A. congruence. *) + (* assert (delta1y = delta2y) by congruence. right; lia. *) + (* exploit mwi_no_overlap1. eauto. eauto. eauto. *) + (* eapply perm_winj. eauto. eexact H2. eauto. *) + (* eapply perm_winj. eauto. eexact H3. eauto. *) + (* intuition lia. *) + (* (* representable *) *) + (* intros. *) + (* destruct (f b) as [[b1 delta1] |] eqn:?; try discriminate. *) + (* destruct (f' b1) as [[b2 delta2] |] eqn:?; inv H. *) + (* exploit mwi_representable0; eauto. intros [A B]. *) + (* set (ofs' := Ptrofs.repr (Ptrofs.unsigned ofs + delta1)). *) + (* assert (Ptrofs.unsigned ofs' = Ptrofs.unsigned ofs + delta1). *) + (* unfold ofs'; apply Ptrofs.unsigned_repr. auto. *) + (* exploit mwi_representable1. eauto. instantiate (1 := ofs'). *) + (* rewrite H. *) + (* replace (Ptrofs.unsigned ofs + delta1 - 1) with *) + (* ((Ptrofs.unsigned ofs - 1) + delta1) by lia. *) + (* destruct H0; eauto using perm_winj. *) + (* rewrite H. lia. *) + (* (* perm inv *) *) + (* intros. *) + (* destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. *) + (* destruct (f' b') as [[b'' delta''] |] eqn:?; try discriminate. *) + (* inversion H; clear H; subst b'' delta. *) + (* replace (ofs + (delta' + delta'')) with ((ofs + delta') + delta'') in H0 by lia. *) + (* exploit mwi_perm_inv1; eauto. intros [A|A]. *) + (* eapply mwi_perm_inv0; eauto. *) + (* right; red; intros. elim A. eapply perm_winj; eauto. *) + (* Qed. *) + + + (** Winjecting a memory into itself. *) + + Definition flat_winj (thr: block) : meminj := + fun (b: block) => if plt b thr then Some(b, 0) else None. + + Definition winject_neutral (thr: block) (m: mem) := + mem_winj (flat_winj thr) m m. + + Remark flat_winj_no_overlap: + forall thr m, meminj_no_overlap (flat_winj thr) m. + Proof. + unfold flat_winj; intros; red; intros. + destruct (plt b1 thr); inversion H0; subst. + destruct (plt b2 thr); inversion H1; subst. + auto. + Qed. + + Theorem neutral_winject: + forall m, winject_neutral (nextblock m) m -> winject (flat_winj (nextblock m)) m m. + Proof. + intros. constructor. + (* meminj *) + auto. + (* freeblocks *) + unfold flat_winj, valid_block; intros. + apply pred_dec_false. auto. + (* mappedblocks *) + unfold flat_winj, valid_block; intros. + destruct (plt b (nextblock m)); inversion H0; subst. auto. + (* no overlap *) + apply flat_winj_no_overlap. + (* range *) + unfold flat_winj; intros. + destruct (plt b (nextblock m)); inv H0. generalize (Ptrofs.unsigned_range_2 ofs); lia. + (* perm inv *) + unfold flat_winj; intros. + destruct (plt b1 (nextblock m)); inv H0. + rewrite Z.add_0_r in H1; auto. + Qed. + + (* Theorem empty_winject_neutral: *) + (* forall thr, winject_neutral thr empty. *) + (* Proof. *) + (* intros; red; constructor. *) + (* (* perm *) *) + (* unfold flat_winj; intros. destruct (plt b1 thr); inv H. *) + (* replace (ofs + 0) with ofs by lia; auto. *) + (* (* own *) *) + (* intros. destruct cp as [cp| ]; [| trivial]. *) + (* unfold can_access_block, block_compartment in H0. *) + (* now rewrite PTree.gempty in H0. *) + (* (* align *) *) + (* unfold flat_winj; intros. destruct (plt b1 thr); inv H. apply Z.divide_0_r. *) + (* Qed. *) + + (* Theorem alloc_winject_neutral: *) + (* forall thr m c lo hi b m', *) + (* alloc m c lo hi = (m', b) -> *) + (* winject_neutral thr m -> *) + (* Plt (nextblock m) thr -> *) + (* winject_neutral thr m'. *) + (* Proof. *) + (* intros; red. *) + (* eapply alloc_left_mapped_winj with (m1 := m) (b2 := b) (delta := 0). *) + (* eapply alloc_right_winj; eauto. eauto. eauto with mem. *) + (* red. intros. apply Z.divide_0_r. *) + (* intros. *) + (* apply perm_implies with Freeable; auto with mem. *) + (* eapply perm_alloc_2; eauto. lia. *) + (* unfold flat_winj. apply pred_dec_true. *) + (* rewrite (alloc_result _ _ _ _ _ _ H). auto. *) + (* eapply owned_new_block; eauto. *) + (* Qed. *) + + (* Theorem drop_winject_neutral: *) + (* forall m b lo hi p cp m' thr, *) + (* drop_perm m b lo hi p cp = Some m' -> *) + (* winject_neutral thr m -> *) + (* Plt b thr -> *) + (* winject_neutral thr m'. *) + (* Proof. *) + (* unfold winject_neutral; intros. *) + (* exploit drop_mapped_winj; eauto. apply flat_winj_no_overlap. *) + (* unfold flat_winj. apply pred_dec_true; eauto. *) + (* repeat rewrite Z.add_0_r. intros [m'' [A B]]. congruence. *) + (* Qed. *) + +End WINJ. + +Section PROPS. + + Lemma mem_winj_inj_incr + j1 j2 m m' + (INCR: inject_incr j1 j2) + (WINJ: mem_winj j2 m m') + : + mem_winj j1 m m'. + Proof. inv WINJ. split; eauto. Qed. + + Lemma winject_inj_incr + j1 j2 m m' + (INCR: inject_incr j1 j2) + (WINJ: winject j2 m m') + : + winject j1 m m'. + Proof. + inv WINJ. split; eauto. eapply mem_winj_inj_incr; eauto. + { intros. destruct (j1 b) as [[b' ofs']|] eqn: JB; auto. specialize (INCR _ _ _ JB). specialize (mi_freeblocks0 _ H). rewrite INCR in mi_freeblocks0. congruence. } + { unfold meminj_no_overlap in *. intros. eapply mwi_no_overlap0; eauto. } + Qed. + + Lemma mem_inj_implies_mem_winj + j m m' + (INJ: Mem.mem_inj j m m') + : + mem_winj j m m'. + Proof. inv INJ. split; auto. Qed. + + Lemma inject_implies_winject + j m m' + (INJ: Mem.inject j m m') + : + winject j m m'. + Proof. inv INJ. split; auto. apply mem_inj_implies_mem_winj; auto. Qed. + + Definition mem_inj_val f m1 m2 := + forall (b1 : block) (ofs : Z) (b2 : block) (delta : Z), + f b1 = Some (b2, delta) -> Mem.perm m1 b1 ofs Cur Readable -> memval_inject f (ZMap.get ofs (Mem.mem_contents m1) # b1) (ZMap.get (ofs + delta) (Mem.mem_contents m2) # b2). + + Lemma mem_winj_to_mem_inj + j m m' + (WINJ: mem_winj j m m') + (INJV: mem_inj_val j m m') + : + Mem.mem_inj j m m'. + Proof. inv WINJ. split; eauto. Qed. + + Lemma winject_to_inject + j m m' + (WINJ: winject j m m') + (INJV: mem_inj_val j m m') + : + Mem.inject j m m'. + Proof. inv WINJ. split; eauto. apply mem_winj_to_mem_inj; auto. Qed. + +End PROPS. + + +(** * Weak Invariance properties between two memory states *) + +Section WUNCHANGED_ON. + +Import Mem. + +Variable P: block -> Z -> Prop. + +Record wunchanged_on (m_before m_after: mem) : Prop := mk_wunchanged_on { + wunchanged_on_nextblock: + Ple (nextblock m_before) (nextblock m_after); + wunchanged_on_perm: + forall b ofs k p, + P b ofs -> valid_block m_before b -> + (perm m_before b ofs k p <-> perm m_after b ofs k p); + wunchanged_on_own: + forall b cp, + (* P b ofs -> *) + valid_block m_before b -> (* Adjust preconditions as needed. *) + (can_access_block m_before b cp <-> can_access_block m_after b cp) +}. + +Lemma wunchanged_on_refl: + forall m, wunchanged_on m m. +Proof. + intros; constructor. apply Ple_refl. tauto. tauto. +Qed. + +Lemma valid_block_wunchanged_on: + forall m m' b, + wunchanged_on m m' -> valid_block m b -> valid_block m' b. +Proof. + unfold valid_block; intros. apply wunchanged_on_nextblock in H. extlia. +Qed. + +Lemma perm_wunchanged_on: + forall m m' b ofs k p, + wunchanged_on m m' -> P b ofs -> + perm m b ofs k p -> perm m' b ofs k p. +Proof. + intros. destruct H. apply wunchanged_on_perm0; auto. eapply perm_valid_block; eauto. +Qed. + +Lemma perm_wunchanged_on_2: + forall m m' b ofs k p, + wunchanged_on m m' -> P b ofs -> valid_block m b -> + perm m' b ofs k p -> perm m b ofs k p. +Proof. + intros. destruct H. apply wunchanged_on_perm0; auto. +Qed. + +Lemma wunchanged_on_trans: + forall m1 m2 m3, wunchanged_on m1 m2 -> wunchanged_on m2 m3 -> wunchanged_on m1 m3. +Proof. + intros; constructor. +- apply Ple_trans with (nextblock m2); apply wunchanged_on_nextblock; auto. +- intros. transitivity (perm m2 b ofs k p); apply wunchanged_on_perm; auto. + eapply valid_block_wunchanged_on; eauto. +- intros. transitivity (can_access_block m2 b cp); apply wunchanged_on_own; auto. + eapply valid_block_wunchanged_on; eauto. +Qed. + +Lemma store_wunchanged_on: + forall chunk m b ofs v cp m', + store chunk m b ofs v cp = Some m' -> + wunchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_store _ _ _ _ _ _ _ H). apply Ple_refl. +- split; intros; eauto with mem. +- eapply store_can_access_block_inj; eauto. +Qed. + +Lemma storebytes_wunchanged_on: + forall m b ofs bytes cp m', + storebytes m b ofs bytes cp = Some m' -> + wunchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_storebytes _ _ _ _ _ _ H). apply Ple_refl. +- split; intros. eapply perm_storebytes_1; eauto. eapply perm_storebytes_2; eauto. +- split. + eapply storebytes_can_access_block_inj_1; eauto. + eapply storebytes_can_access_block_inj_2; eauto. +Qed. + +Lemma alloc_wunchanged_on: + forall m c lo hi m' b, + alloc m c lo hi = (m', b) -> + wunchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_alloc _ _ _ _ _ _ H). apply Ple_succ. +- split; intros. + eapply perm_alloc_1; eauto. + eapply perm_alloc_4; eauto. + eapply valid_not_valid_diff; eauto with mem. +- destruct (peq b0 b). ++ subst b0. apply fresh_block_alloc in H. contradiction. ++ split. + eapply alloc_can_access_block_other_inj_1; eauto. + eapply alloc_can_access_block_other_inj_2; eauto. +Qed. + +Lemma free_wunchanged_on: + forall m b lo hi cp m', + free m b lo hi cp = Some m' -> + (forall i, lo <= i < hi -> ~ P b i) -> + wunchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_free _ _ _ _ _ _ H). apply Ple_refl. +- split; intros. + eapply perm_free_1; eauto. + destruct (eq_block b0 b); auto. destruct (zlt ofs lo); auto. destruct (zle hi ofs); auto. + subst b0. elim (H0 ofs). lia. auto. + eapply perm_free_3; eauto. +- split. + eapply free_can_access_block_inj_1; eauto. + eapply free_can_access_block_inj_2; eauto. +Qed. + +Lemma drop_perm_wunchanged_on: + forall m b lo hi p cp m', + drop_perm m b lo hi p cp = Some m' -> + (forall i, lo <= i < hi -> ~ P b i) -> + wunchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_drop _ _ _ _ _ _ _ H). apply Ple_refl. +- split; intros. eapply perm_drop_3; eauto. + destruct (eq_block b0 b); auto. + subst b0. + assert (~ (lo <= ofs < hi)). { red; intros; eelim H0; eauto. } + right; lia. + eapply perm_drop_4; eauto. +- split. + eapply can_access_block_drop_1; eauto. + eapply can_access_block_drop_2; eauto. +Qed. + +End WUNCHANGED_ON. + +Lemma wunchanged_on_implies: + forall (P Q: block -> Z -> Prop) m m', + wunchanged_on P m m' -> + (forall b ofs, Q b ofs -> Mem.valid_block m b -> P b ofs) -> + wunchanged_on Q m m'. +Proof. + intros. destruct H. constructor; intros. +- auto. +- apply wunchanged_on_perm0; auto. +- apply wunchanged_on_own0; auto. +Qed. diff --git a/security/Recomposition.v b/security/Recomposition.v index 3563243024..46ca0e0ab1 100644 --- a/security/Recomposition.v +++ b/security/Recomposition.v @@ -7,7 +7,7 @@ Require Import Complements. Require Import Split. #[local] Instance has_side_stackframe: has_side stackframe := - { in_side s := fun '(Stackframe b _ _ _) δ => s b = δ }. + { in_side s := fun '(Stackframe _ cp _ _ _) δ => s cp = δ }. #[local] Instance has_side_stack: has_side stack := { in_side s := fun st δ => List.Forall (fun f => s |= f ∈ δ) st }. @@ -15,9 +15,8 @@ Require Import Split. Print Instances has_side. #[local] Instance has_side_regset: has_side regset := - (* { in_side '(s, ge) := fun (rs: regset) δ => s (@Genv.find_comp fundef unit _ ge (rs PC)) = δ }. (* FIXME *) *) - { in_side '(s, ge) := fun (rs: regset) δ => exists cp, @Genv.find_comp fundef unit _ ge (rs PC) = Some cp /\ s cp = δ }. - + { in_side '(s, ge) := fun (rs: regset) δ => s (@Genv.find_comp_ignore_offset fundef unit _ ge (rs PC)) = δ }. + Variant match_fundef (s: split) (δ: side): unit -> fundef -> fundef -> Prop := | match_function_opp: forall cp sig code code', @@ -45,10 +44,10 @@ Section Invariants. Variable s: split. Variant stackframe_rel (j: meminj): stackframe -> stackframe -> Prop := - | stackframe_related: forall b b' sg sp sp' ofs ofs', + | stackframe_related: forall b b' cp sg sp sp' ofs ofs', Val.inject j (Vptr b ofs) (Vptr b' ofs') -> Val.inject j sp sp' -> - stackframe_rel j (Stackframe b sg sp ofs) (Stackframe b' sg sp' ofs') + stackframe_rel j (Stackframe b cp sg sp ofs) (Stackframe b' cp sg sp' ofs') . (* Inductive stack_rel (j: meminj) (δ: side): stack -> stack -> Prop := *) @@ -109,8 +108,8 @@ Section Invariants. delta_zero: Mem.delta_zero j; - symb_inj: symbols_inject j ge1 ge2; - (* pres_globals: meminj_preserves_globals ge1 j; *) + (* symb_inj: symbols_inject j ge1 ge2; *) + pres_globals: meminj_preserves_globals ge1 j; ple_nextblock1: Ple (Senv.nextblock ge1) (Mem.nextblock m1); ple_nextblock2: Ple (Senv.nextblock ge2) (Mem.nextblock m2); @@ -140,7 +139,7 @@ Section Invariants. (* stack_rel j δ st st' -> *) regset_rel j rs rs' -> mem_rel ge ge' j δ m m' -> - strong_equivalence ge ge' j δ (ReturnState st rs m default_compartment) (ReturnState st' rs' m' default_compartment) (* FIXME *) + strong_equivalence ge ge' j δ (ReturnState st rs m) (ReturnState st' rs' m') . Inductive weak_equivalence (ge ge': genv) (j: meminj) (δ: side): state -> state -> Prop := @@ -155,7 +154,7 @@ Section Invariants. (* (s, m') |= rs' PC ∈ opposite δ -> *) (* stack_rel j δ st st' -> *) mem_rel ge ge' j δ m m' -> - weak_equivalence ge ge' j δ (ReturnState st rs m default_compartment) (ReturnState st' rs' m' default_compartment) (* FIXME *) + weak_equivalence ge ge' j δ (ReturnState st rs m) (ReturnState st' rs' m') . End Invariants. @@ -529,42 +528,24 @@ Section Simulation. + congruence. + rewrite (rewr _ n). intros G. exploit delta_zero; eauto. - - exploit symb_inj; eauto. - intros (A & B & C & D). - split; [| split; [| split]]. + - exploit pres_globals; eauto. + intros (A & B & C). + split; [| split]. + intros. exploit A; eauto. - + intros. exploit B; eauto. rewrite <- rewr. eauto. - exploit (Mem.alloc_result m1 cp lo hi m1' b1) ; eauto. intros ->. - exploit Senv.find_symbol_below; eauto. - eapply ple_nextblock1 in m1_m3. intros ? ?. subst. - exploit Plt_Ple_trans; eauto. now apply Plt_strict. - (* exploit C; eauto. *) - + intros. exploit C; eauto. intros ?. - destruct H5 as [b2 ?]. exists b2. - rewrite rewr; eauto. - exploit (Mem.alloc_result m1 cp lo hi m1' b1) ; eauto. intros ->. - exploit Senv.find_symbol_below; eauto. - eapply ple_nextblock1 in m1_m3. intros ? ?. subst. - exploit Plt_Ple_trans; eauto. now apply Plt_strict. - + intros. destruct (Pos.eq_dec b0 b1); subst. - * assert (Senv.block_is_volatile ge1 b1 = false). - { destruct (Senv.block_is_volatile ge1 b1) eqn:?; auto. - exfalso. - exploit (Mem.alloc_result m1 cp lo hi m1' b1) ; eauto. intros ->. - exploit Senv.block_is_volatile_below; eauto. - eapply ple_nextblock1 in m1_m3. intros ?. - exploit Plt_Ple_trans; eauto. intros ?. now eapply Plt_strict; eauto. } - assert (b3 = b2) by congruence. subst b2. - assert (Senv.block_is_volatile ge3 b3 = false). - { destruct (Senv.block_is_volatile ge3 b3) eqn:?; auto. - exfalso. - exploit (Mem.alloc_result m3 cp lo hi m3' b3) ; eauto. intros ->. - exploit Senv.block_is_volatile_below; eauto. - eapply ple_nextblock2 in m1_m3. intros ?. - exploit Plt_Ple_trans; eauto. intros ?. now eapply Plt_strict; eauto. } - now congruence. - * exploit D; eauto. - rewrite <- rewr; eauto. + + intros. exploit C; eauto. + + intros. + destruct (Pos.eqb_spec b0 b1); subst. + * exploit B; eauto. intros ?. + assert (b3 = b2) by congruence; assert (delta = 0) by congruence; subst b3 delta. + unfold ge1 in *. + eapply Genv.find_var_info_match with (b := b2) in match_W1_W3 as [? [? ?]]; eauto. + replace (Genv.globalenv W3) with ge3 in H5 by reflexivity. + assert (V: Mem.valid_block m3 b2) by now eapply var_info_valid in m1_m3; eauto. + assert (nV: not (Mem.valid_block m3 b2)). + { unfold Mem.valid_block. apply Mem.alloc_result in H; subst b2. + now apply Plt_strict. } + contradiction. + * eapply C. eauto. rewrite <- rewr; eauto. - erewrite Mem.nextblock_alloc; eauto using Ple_trans, Ple_succ, ple_nextblock1. - erewrite Mem.nextblock_alloc; eauto using Ple_trans, Ple_succ, ple_nextblock2. - intros. exploit funct_preserved1; eauto. @@ -623,42 +604,24 @@ Section Simulation. + congruence. + rewrite (diff _ n). intros G. exploit delta_zero; eauto. - - exploit symb_inj; eauto. - intros (A & B & C & D). - split; [| split; [| split]]. - + intros. exploit A; eauto. - + intros. exploit B; eauto. rewrite <- diff. eauto. - exploit (Mem.alloc_result m1 cp lo hi m1' b1) ; eauto. intros ->. - exploit Senv.find_symbol_below; eauto. - eapply ple_nextblock1 in m1_m3. intros ? ?. subst. - exploit Plt_Ple_trans; eauto. now apply Plt_strict. - (* exploit C; eauto. *) - + intros. exploit C; eauto. intros ?. - destruct H1 as [b2 ?]. exists b2. - rewrite diff; eauto. - exploit (Mem.alloc_result m1 cp lo hi m1' b1) ; eauto. intros ->. - exploit Senv.find_symbol_below; eauto. - eapply ple_nextblock1 in m1_m3. intros ? ?. subst. - exploit Plt_Ple_trans; eauto. now apply Plt_strict. - + intros. destruct (Pos.eq_dec b0 b1); subst. - * assert (Senv.block_is_volatile ge1 b1 = false). - { destruct (Senv.block_is_volatile ge1 b1) eqn:?; auto. - exfalso. - exploit (Mem.alloc_result m1 cp lo hi m1' b1) ; eauto. intros ->. - exploit Senv.block_is_volatile_below; eauto. - eapply ple_nextblock1 in m1_m3. intros ?. - exploit Plt_Ple_trans; eauto. intros ?. now eapply Plt_strict; eauto. } - assert (b3 = b2) by congruence. subst b2. - assert (Senv.block_is_volatile ge3 b3 = false). - { destruct (Senv.block_is_volatile ge3 b3) eqn:?; auto. - exfalso. - exploit (Mem.alloc_result m3 cp lo hi m3' b3) ; eauto. intros ->. - exploit Senv.block_is_volatile_below; eauto. - eapply ple_nextblock2 in m1_m3. intros ?. - exploit Plt_Ple_trans; eauto. intros ?. now eapply Plt_strict; eauto. } - now congruence. - * exploit D; eauto. - rewrite <- diff; eauto. + - exploit pres_globals; eauto. + intros (A & B & C). + split; [| split]. + + intros. exploit A; eauto. + + intros. exploit C; eauto. + + intros. + destruct (Pos.eqb_spec b0 b1); subst. + * exploit B; eauto. intros ?. + assert (b3 = b2) by congruence; assert (delta = 0) by congruence; subst b3 delta. + unfold ge1 in *. + eapply Genv.find_var_info_match with (b := b2) in match_W1_W3 as [? [? ?]]; eauto. + replace (Genv.globalenv W3) with ge3 in H2 by reflexivity. + assert (V: Mem.valid_block m3 b2) by now eapply var_info_valid in m1_m3; eauto. + assert (nV: not (Mem.valid_block m3 b2)). + { unfold Mem.valid_block. apply Mem.alloc_result in alloc3; subst b2. + now apply Plt_strict. } + contradiction. + * eapply C. eauto. rewrite <- diff; eauto. - erewrite Mem.nextblock_alloc; eauto using Ple_trans, Ple_succ, ple_nextblock1. - erewrite Mem.nextblock_alloc; eauto using Ple_trans, Ple_succ, ple_nextblock2. - intros. exploit funct_preserved1; eauto. @@ -723,12 +686,11 @@ Section Simulation. constructor. - intros b. apply same_dom in m1_m3. specialize (m1_m3 b). - simpl in *. apply Mem.free_result in free1. unfold Mem.unchecked_free in free1. - destruct (zle hi lo); now subst. + simpl in *. apply Mem.free_result in free1. unfold Mem.unchecked_free in free1. now subst. - assumption. - intros b b' delta. intros G. exploit delta_zero; eauto. - - exploit symb_inj; eauto. + - exploit pres_globals; eauto. - erewrite Mem.nextblock_free; eauto using Ple_trans, Ple_succ, ple_nextblock1. - erewrite Mem.nextblock_free; eauto using Ple_trans, Ple_succ, ple_nextblock2. - intros. exploit funct_preserved1; eauto. @@ -759,8 +721,7 @@ Section Simulation. destruct (Mem.block_compartment m2 b0); destruct (Mem.block_compartment m1 b1); try congruence. - erewrite Mem.nextblock_free; eauto using Ple_trans, Ple_succ, ple_nextblock1. - intros. eapply Mem.valid_block_free_1; eauto. } - (* Qed. *) - Admitted. + Qed. Lemma store_preserves_rel_left: forall cp j__left j__right m1 m1' m2 m3 ch ofs v1 v3 b1 b3, @@ -785,7 +746,7 @@ Section Simulation. eapply Mem.store_block_compartment in store1. now rewrite store1. - assumption. - now eapply delta_zero; eauto. - - exploit symb_inj; eauto. + - exploit pres_globals; eauto. - erewrite Mem.nextblock_store; eauto using Ple_trans, Ple_succ, ple_nextblock1. - erewrite Mem.nextblock_store; eauto using Ple_trans, Ple_succ, ple_nextblock2. - intros. exploit funct_preserved1; eauto. @@ -891,18 +852,17 @@ Section Simulation. | _: context [Val.cmpl_bool] |- _ => unfold Val.cmpl_bool in *; simpl in * | _: context [eval_offset _ ?ofs] |- _ => - destruct ofs eqn:?; subst; simpl in * + destruct ofs; simpl in * - | _: context [low_half] |- _ => - unfold low_half in *; simpl in * - (* rewrite same_low_half1 in * *) + | _: context [low_half ge1] |- _ => + rewrite same_low_half1 in * | H: Mem.alloc ?m1 ?cp ?lo1 ?hi1 = (?m1', ?b1), m1_m3: mem_rel _ _ _ ?j__left Left ?m1 ?m3, m2_m3: mem_rel _ _ _ ?j__right Right ?m2 ?m3, rs1_rs3: regset_rel _ _ _ |- _ => - (* idtac "alloc case"; *) + idtac "alloc case"; let j__left' := fresh "j__left" in let m3' := fresh "m3" in let b3 := fresh "b3" in @@ -913,7 +873,7 @@ Section Simulation. let incr := fresh "incr" in apply (alloc_preserves_rel_left _ _ _ _ _ _ _ _ _ _ _ _ m1_m3 m2_m3 rs1_rs3) in H as [j__left' [m3' [b3 [alloc3 [m1'_m3' [m2_m3' [? [proj incr]]]]]]]]; - (* idtac "done with alloc"; *) + idtac "done with alloc"; clear m1_m3 rs1_rs3 m2_m3 | H: s ?cp = ?δ -> _, side_cp: s ?cp = ?δ |- _ => @@ -924,11 +884,11 @@ Section Simulation. m2_m3: mem_rel _ _ _ ?j__right Right ?m2 ?m3, ptr_inj: ?j__left ?b1 = Some (?b3, 0), rs1_rs3: regset_rel ?j__left ?rs1 ?rs3 |- _ => - (* idtac "store case"; *) + idtac "store case"; let m3' := fresh "m3" in apply (store_preserves_rel_left _ _ _ _ _ _ _ _ _ _ _ _ _ ptr_inj m1_m3 m2_m3 (rs1_rs3 r)) in H as [m3' [? [? ?]]]; - (* idtac "done with store"; *) + idtac "done with store"; clear m1_m3 m2_m3 | H: Mem.free ?m1 ?b1 ?lo ?hi ?cp = Some ?m1', @@ -936,23 +896,23 @@ Section Simulation. m2_m3: mem_rel _ _ _ ?j__right Right ?m2 ?m3, ptr_inj: ?j__left ?b1 = Some (?b3, 0) |- _ => (* rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => *) - (* idtac "free case"; *) + idtac "free case"; let m3' := fresh "m3" in apply (free_preserves_rel_left _ _ _ _ _ _ _ _ _ _ _ ptr_inj m1_m3 m2_m3) in H as [m3' [? [? ?]]]; - (* idtac "done with free"; *) + idtac "done with free"; clear m1_m3 | H: Mem.load ?ch ?m1 ?b1 ?ofs ?cp = Some ?v1, m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, ptr_inj: ?j ?b1 = Some (?b3, 0) |- _ => - idtac "load case"; + (* idtac "load case"; *) let v3 := fresh "v3" in let load3 := fresh "load3" in destruct (Mem.load_inject _ _ _ _ _ _ _ _ _ _ (partial_mem_inject _ _ _ _ _ _ _ m1_m3) H ptr_inj) as [v3 [load3 ?]]; rewrite Z.add_0_r in load3; - idtac "done with load"; + (* idtac "done with load"; *) clear H | H: Val.cmpu_bool (Mem.valid_pointer ?m1) ?op (?rs1 ?r) (?rs1 ?r') = Some ?b, @@ -1091,9 +1051,9 @@ Section Simulation. | _: context [?rs1 ## ?rs] |- context [?rs3 ## ?rs] => let i := fresh "i" in destruct rs as [| i]; simpl in * | H: ?x = _ |- context [if ?x then _ else _] => - setoid_rewrite H; simpl + rewrite H; simpl | H: ?x = _ |- context [match ?x with | _ => _ end] => - setoid_rewrite H; simpl + 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 _ _] => @@ -1180,10 +1140,10 @@ Section Simulation. intros side_cp m1_m3 m2_m3 rs1_rs3 st1_st3 exec. Local Opaque Val.cmpu_bool Val.cmplu_bool. - (* Local Opaque low_half high_half. *) destruct i; inv exec; simpl in *; - try now (simpl_before_exists; (eexists_and_split + try now (simpl_before_exists; + (eexists_and_split ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => (simpl; try reflexivity; try eassumption; solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity)))). @@ -1191,31 +1151,30 @@ Section Simulation. ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => (simpl; try reflexivity; try eassumption; solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity))). - (* apply Genv.find_symbol_match with (s := symb) in match_W1_W3. *) - exploit symb_inj. exact m1_m3. intros (A & B & C & D). - unfold Genv.symbol_address. admit. + apply Genv.find_symbol_match with (s := symb) in match_W1_W3. + unfold Genv.symbol_address. rewrite match_W1_W3. + now eapply symbol_address_inject; eauto using pres_globals. - (eexists_and_split ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => (simpl; try reflexivity; try eassumption; solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity))). - (* apply Genv.find_symbol_match with (s := symb) in match_W1_W3. *) - admit. - (* unfold Genv.symbol_address. rewrite match_W1_W3. *) - (* now eapply symbol_address_inject; eauto using pres_globals. *) - - (eexists_and_split + apply Genv.find_symbol_match with (s := symb) in match_W1_W3. + unfold Genv.symbol_address. rewrite match_W1_W3. + now eapply symbol_address_inject; eauto using pres_globals. + - simpl_before_exists. + (eexists_and_split ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => (simpl; try reflexivity; try eassumption; solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity))). apply Genv.find_symbol_match with (s := id) in match_W1_W3. - admit. - (* unfold Genv.symbol_address. rewrite match_W1_W3. *) - (* now eapply symbol_address_inject; eauto using pres_globals. *) + unfold Genv.symbol_address. rewrite match_W1_W3. + now eapply symbol_address_inject; eauto using pres_globals. - (eexists_and_split ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => (simpl; try reflexivity; try eassumption; solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity))). eapply same_high_half; eauto. - Admitted. + Qed. Lemma store_inj_outside_domain: forall f chunk m1 b1 ofs v1 cp n2 m2, @@ -1339,13 +1298,13 @@ Section Simulation. intros [[] [f' [find_f' [match_f_f' _]]]]. inv match_f_f'; simpl in *. - rewrite eq_pc in *; simpl in *. - (* destruct Ptrofs.eq_dec; try congruence. unfold ge1 in *. rewrite find_fun in H2. *) - (* simpl in *; congruence. *) - admit. + destruct Ptrofs.eq_dec; try congruence. unfold ge1 in *. rewrite find_fun in H2. + simpl in *; congruence. - pose proof (H4 PC) as inj. rewrite eq_pc in *; simpl in *. inv inj. exploit funct_preserved1; eauto. intros. assert (b2 = b) by congruence; assert (delta = 0) by congruence; subst b2 delta. + destruct Ptrofs.eq_dec; try congruence. rewrite find_fun in H2. apply Genv.globalenvs_match in match_W1_W3. apply Genv.mge_defs with (b := b) in match_W1_W3. @@ -1356,8 +1315,7 @@ Section Simulation. inv H10; repeat (split; eauto). * now rewrite Ptrofs.add_zero. * now rewrite Ptrofs.add_zero. - (* Qed. *) - Admitted. + Qed. Lemma find_comp_preserved: forall j rs rs' r @@ -1372,7 +1330,6 @@ Section Simulation. intros j rs rs' r funct_preserved1 funct_preserved2 delta_zero nundef H. specialize (H r). inv H; simpl; auto; try congruence. -(* destruct Ptrofs.eq_dec; auto. { destruct (Genv.find_funct_ptr ge1 b1) eqn:find_funct; destruct (Genv.find_funct_ptr ge3 b2) eqn:find_funct'; @@ -1397,10 +1354,7 @@ Section Simulation. exploit delta_zero; eauto; intros ->. rewrite Ptrofs.add_zero in *; congruence. } Qed. -*) - Admitted. -(* Lemma find_comp_ignore_offset_preserved: forall j rs rs' r (funct_preserved1: forall (b : block) (fd : fundef), Genv.find_funct_ptr ge1 b = Some fd -> j b = Some (b, 0)) @@ -1432,7 +1386,6 @@ Section Simulation. eapply Genv.find_funct_ptr_match_conv in match_W1_W3 as [? [f' [? [match_fd ?]]]]; eauto. congruence. Qed. -*) Lemma allowed_call_preserved: forall j cp v v' @@ -1461,11 +1414,9 @@ Section Simulation. eapply Genv.find_funct_match_conv with (v := Vptr b1 Ptrofs.zero) in match_W1_W3; eauto. destruct match_W1_W3 as [? [? [? [? ?]]]]; congruence. + destruct allowed. -(* * left; subst; auto. simpl in *; now rewrite find_v, find_v'. * right. simpl in *. rewrite find_v, find_v' in *. admit. -*) Admitted. Lemma update_stack_call_preserved_left: @@ -1484,7 +1435,6 @@ Section Simulation. Proof. intros * funct_preserved1 funct_preserved2 delta_zero left_side nundef rs1_rs3 st_rel. unfold update_stack_call. -(* erewrite find_comp_ignore_offset_preserved; eauto. destruct ((cp =? Genv.find_comp_ignore_offset ge3 (rs3 PC))%positive); auto. - intros R; inv R. @@ -1496,8 +1446,6 @@ Section Simulation. + eapply stack_rel_cons_left with (st2' := nil); simpl; eauto. constructor; auto. econstructor; eauto. Qed. -*) - Admitted. Lemma call_arguments_preserved: forall j δ m1 m3 rs1 rs3, @@ -1559,7 +1507,7 @@ Section Simulation. Definition stack_of_state (s: state) := match s with - | State st _ _ | ReturnState st _ _ _ => st + | State st _ _ | ReturnState st _ _ => st end. Lemma step_E0_strong_Left: forall (s1 s1': state), @@ -1582,7 +1530,6 @@ Section Simulation. inv weak_s2_s3. exploit exec_instr_preserved_left; simpl; eauto. intros (j__left' & rs3' & m3' & exec_instr' & m1_m3' & m2_m3' & rs1_rs3' & st_rel'). -(* assert (pc_comp: Genv.find_comp_ignore_offset ge1 (rs' PC) = Genv.find_comp_ignore_offset ge3 (rs3' PC)). { pose proof (rs1_rs3' PC) as inj_pc; rewrite NEXTPC in *; inv inj_pc. assert (delta = 0) by now eapply delta_zero with (j := j__left'); eauto. subst delta. @@ -1655,19 +1602,17 @@ Section Simulation. + econstructor; [| now eapply star_refl | now traceEq]. pose proof (rs1_rs3' PC) as inj_pc; rewrite NEXTPC in *; inv inj_pc. rewrite <- H6 in *. (* clear dependent j0. *) - exploit (delta_zero s ge1 ge3); eauto. intros ->. eapply exec_step_internal_call; eauto. - * eapply allowed_call_preserved with (v := Vptr b' Ptrofs.zero); + * exploit (delta_zero s ge1 ge3); eauto. intros ->. + eapply allowed_call_preserved with (v := Vptr b' Ptrofs.zero); eauto using funct_preserved1, funct_preserved2, delta_zero. congruence. * simpl; now rewrite find_funct. * simpl in STUPD'; now rewrite H1 in STUPD'. - * intros is_cross. unfold Genv.find_comp_ignore_offset in pc_comp. - rewrite <- pc_comp in is_cross. + * rewrite <- pc_comp. intros is_cross. specialize (NO_CROSS_PTR is_cross). now eapply Val.inject_list_not_ptr; eauto. - * inv EV. constructor. unfold Genv.find_comp_ignore_offset in pc_comp. - now rewrite <- pc_comp. + * inv EV. constructor. now rewrite <- pc_comp. + eauto. + simpl in same_side. econstructor; eauto. @@ -1738,24 +1683,24 @@ Section Simulation. (** External call *) - admit. -*) Admitted. Lemma simulation: @threeway_simulation (semantics W1) (semantics W2) (semantics W3) single_L1 single_L2 single_L3. Proof. - (* apply threeway_simulation_diagram with (strong_equivalence1 := strong_equivalence s ge1 ge3 Left) *) - (* (strong_equivalence2 := strong_equivalence s ge2 ge3 Right) *) - (* (weak_equivalence1 := weak_equivalence s ge1 ge3 Left) *) - (* (weak_equivalence2 := weak_equivalence s ge1 ge3 Right) *) - (* (order := fun _ _ => True). *) - (* - apply public_symbol_eq21. *) - (* - apply public_symbol_eq32. *) - (* - admit. *) - (* - admit. *) - (* - admit. *) - (* - *) - Admitted. + + apply threeway_simulation_diagram with (strong_equivalence1 := strong_equivalence s ge1 ge3 Left) + (strong_equivalence2 := strong_equivalence s ge2 ge3 Right) + (weak_equivalence1 := weak_equivalence s ge1 ge3 Left) + (weak_equivalence2 := weak_equivalence s ge1 ge3 Right) + (order := fun _ _ => True). + - apply public_symbol_eq21. + - apply public_symbol_eq32. + - admit. + - admit. + - admit. + - + End Simulation. diff --git a/security/Split.v b/security/Split.v index 3b70a173ff..4a7698c1ac 100644 --- a/security/Split.v +++ b/security/Split.v @@ -1,4 +1,5 @@ Require Import String. +Require Import Coqlib Maps Errors. Require Import AST. Require Import Values. @@ -27,3 +28,5 @@ Class has_side {ctx: Type} (A: Type) := { in_side s := fun a δ => s (comp_of a) = δ }. Notation "s '|=' a '∈' δ " := (in_side s a δ) (no associativity, at level 75). + + diff --git a/security/Tactics.v b/security/Tactics.v new file mode 100644 index 0000000000..bd110a077a --- /dev/null +++ b/security/Tactics.v @@ -0,0 +1,959 @@ +(* *********************************************************************) +(* *) +(* Lemmas & Tactic from coq-sflib: *) +(* https://github.com/snu-sf/sflib/blob/master/sflib.v *) +(* *) +(* *********************************************************************) + +(* *********************************************************************) +(* *) +(* Software Foundations Laboratory's Lemmas & Tactic *) +(* based on Viktor and Gil's lemmas & tactic *) +(* *) +(* *********************************************************************) + +(** This file collects a number of basic lemmas and tactics for better + proof automation, structuring large proofs, or rewriting. Most of + the rewriting support is ported from ssreflect. *) + +(** Symbols starting with [sflib__] are internal. *) + +Require Import Bool List Arith ZArith String Program. +(* Require Export paconotation newtac. *) + +Set Implicit Arguments. + +#[export] Hint Unfold not iff id: core. + +Export ListNotations. + +(* Notation "~ x" := (forall (FH: x), False) : type_scope. *) + +(* Function composition *) +Notation "f <*> g" := (compose f g) (at level 49, left associativity). + +(* ************************************************************************** *) +(** * Coersion of [bool] into [Prop] *) +(* ************************************************************************** *) + +(** Coersion of bools into Prop *) +Coercion is_true (b : bool) : Prop := b = true. + +(** Hints for auto *) +Lemma sflib__true_is_true : true. +Proof. reflexivity. Qed. + +Lemma sflib__not_false_is_true : ~ false. +Proof. discriminate. Qed. + +Lemma sflib__negb_rewrite: forall {b}, negb b -> b = false. +Proof. intros []; (reflexivity || discriminate). Qed. + +Lemma sflib__andb_split: forall {b1 b2}, b1 && b2 -> b1 /\ b2. +Proof. intros [] []; try discriminate; auto. Qed. + +#[export] Hint Resolve sflib__true_is_true sflib__not_false_is_true: core. + +(* ************************************************************************** *) +(** * Basic automation tactics *) +(* ************************************************************************** *) + +(** Set up for basic simplification *) + +Create HintDb sflib discriminated. + +(** Adaptation of the ss-reflect "[done]" tactic. *) + +Ltac sflib__basic_done := + solve [trivial with sflib | apply sym_equal; trivial | discriminate | contradiction]. + +Ltac done := unfold not in *; trivial with sflib; hnf; intros; + solve [try sflib__basic_done; split; + try sflib__basic_done; split; + try sflib__basic_done; split; + try sflib__basic_done; split; + try sflib__basic_done; split; sflib__basic_done + | match goal with H : _ -> False |- _ => solve [case H; trivial] end]. + +(** A variant of the ssr "done" tactic that performs "eassumption". *) + +Ltac edone := try eassumption; trivial; hnf; intros; + solve [try eassumption; try sflib__basic_done; split; + try eassumption; try sflib__basic_done; split; + try eassumption; try sflib__basic_done; split; + try eassumption; try sflib__basic_done; split; + try eassumption; try sflib__basic_done; split; + try eassumption; sflib__basic_done + | match goal with H : ~ _ |- _ => solve [case H; trivial] end]. + +Tactic Notation "by" tactic(tac) := (tac; done). +Tactic Notation "eby" tactic(tac) := (tac; edone). + +Ltac sflib__complaining_inj f H := + let X := fresh in + (match goal with | [|- ?P ] => set (X := P) end); + injection H; + (lazymatch goal with | [ |- f _ = f _ -> _] => fail | _ => idtac end); + clear H; intros; + subst X; + try subst. + +Ltac sflib__clarify1 := + try subst; + repeat match goal with + | [H: is_true (andb _ _) |- _] => case (sflib__andb_split H); clear H; intros ? H + | [H: is_true (negb ?x) |- _] => rewrite (sflib__negb_rewrite H) in * + | [H: is_true ?x |- _] => rewrite H in * + | [H: ?x = true |- _] => rewrite H in * + | [H: ?x = false |- _] => rewrite H in * + | [H: ?f _ = ?f _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ = ?f _ _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ _ = ?f _ _ _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ _ _ = ?f _ _ _ _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ _ _ _ = ?f _ _ _ _ _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ _ _ _ _ = ?f _ _ _ _ _ _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ _ _ _ _ _ = ?f _ _ _ _ _ _ _ |- _] => sflib__complaining_inj f H + end; try done. + +(** Perform injections & discriminations on all hypotheses *) + +Ltac clarify := + sflib__clarify1; + repeat match goal with + | H1: ?x = Some _, H2: ?x = None |- _ => rewrite H2 in H1; sflib__clarify1 + | H1: ?x = Some _, H2: ?x = Some _ |- _ => rewrite H2 in H1; sflib__clarify1 + end. + +(** Kill simple goals that require up to two econstructor calls. *) + +(* from CompCert-2.4/lib/Coqlib.v *) +Ltac inv H := inversion H; clear H; subst. + +Ltac hinv x := move x at bottom; inversion x; clarify. + +Tactic Notation "hinv" ident(a) := + (hinv a). +Tactic Notation "hinv" ident(a) ident(b) := + (hinv a; hinv b). +Tactic Notation "hinv" ident(a) ident(b) ident(c) := + (hinv a; hinv b c). +Tactic Notation "hinv" ident(a) ident(b) ident(c) ident(d) := + (hinv a b; hinv c d). + +Ltac hinvc x := hinv x; clear x. + +Tactic Notation "hinvc" ident(a) := + (hinvc a). +Tactic Notation "hinvc" ident(a) ident(b) := + (hinvc a; hinvc b). +Tactic Notation "hinvc" ident(a) ident(b) ident(c) := + (hinvc a; hinvc b c). +Tactic Notation "hinvc" ident(a) ident(b) ident(c) ident(d) := + (hinvc a b; hinvc c d). +Tactic Notation "hinvc" ident(a) ident(b) ident(c) ident(d) ident(e) := + (hinvc a b c; hinvc d e). + +Ltac simpls := simpl in *; try done. +Ltac ins := simpl in *; try done; intros. + +Tactic Notation "case_eq" constr(x) := case_eq (x). + +Tactic Notation "case_eq" constr(x) "as" simple_intropattern(H) := + destruct x as [] eqn: H; try done. + + +(* ************************************************************************** *) +(** * Basic simplication tactics *) +(* ************************************************************************** *) + +Ltac sflib__clarsimp1 := + clarify; (autorewrite with sflib in * ); try done; + match goal with + | [H: is_true ?x |- _] => rewrite H in *; sflib__clarsimp1 + | [H: ?x = true |- _] => rewrite H in *; sflib__clarsimp1 + | [H: ?x = false |- _] => rewrite H in *; sflib__clarsimp1 + | _ => clarify; auto 1 with sflib + end. + +Ltac clarsimp := intros; simpl in *; sflib__clarsimp1. + +Ltac autos := clarsimp; auto with sflib. + +(* hdesH, hdes: more general des *) + +Definition NW A (P: () -> A) : A := P (). + +Notation "<< x : t >>" := (NW (fun x => (t):Prop)) (at level 80, x name, no associativity). +Notation "<< t >>" := (NW (fun _ => t)) (at level 79, no associativity, only printing). +Notation "<< t >>" := (NW (fun _ => (t):Prop)) (at level 79, no associativity, only printing). + +Ltac unnw := unfold NW in *. +Ltac rednw := red; unnw. + +#[export] Hint Unfold NW: core. + +Ltac get_concl := lazymatch goal with [ |- ?G ] => G end. + +Ltac des1 := + match goal with + | H : NW _ |- _ => red in H + | H : exists x, NW (fun y => _) |- _ => + let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y' + | H : exists x, ?p |- _ => + let x' := fresh x in destruct H as [x' H] + | H : ?p /\ ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in + destruct H as [x' y']; + match p with | NW _ => red in x' | _ => idtac end; + match q with | NW _ => red in y' | _ => idtac end + | H : ?p <-> ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in + destruct H as [x' y']; + match p with | NW _ => unfold NW at 1 in x'; red in y' | _ => idtac end; + match q with | NW _ => unfold NW at 1 in y'; red in x' | _ => idtac end + | H : ?p \/ ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => H end in + destruct H as [x' | y']; + [ match p with | NW _ => red in x' | _ => idtac end + | match q with | NW _ => red in y' | _ => idtac end] + end. + +Ltac des := repeat des1. + +Ltac desc := + repeat match goal with + | H : exists x, NW (fun y => _) |- _ => + let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y' + | H : exists x, ?p |- _ => + let x' := fresh x in destruct H as [x' H] + | H : ?p /\ ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in + destruct H as [x' y']; + match p with | NW _ => red in x' | _ => idtac end; + match q with | NW _ => red in y' | _ => idtac end + | H : is_true (_ && _) |- _ => + let H' := fresh H in case (sflib__andb_split H); clear H; intros H H' + | H : ?x = ?x |- _ => clear H + end. + +Ltac nbdes1 := + match goal with + | H : NW _ |- _ => red in H + | H : exists x, NW (fun y => _) |- _ => + let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y' + | H : exists x, ?p |- _ => + let x' := fresh x in destruct H as [x' H] + | H : ?p /\ ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in + destruct H as [x' y']; + match p with | NW _ => red in x' | _ => idtac end; + match q with | NW _ => red in y' | _ => idtac end + | H : ?p <-> ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in + destruct H as [x' y']; + match p with | NW _ => unfold NW at 1 in x'; red in y' | _ => idtac end; + match q with | NW _ => unfold NW at 1 in y'; red in x' | _ => idtac end + (* | H : ?p \/ ?q |- _ => *) + (* let x' := match p with | NW (fun z => _) => fresh z | _ => H end in *) + (* let y' := match q with | NW (fun z => _) => fresh z | _ => H end in *) + (* destruct H as [x' | y']; *) + (* [ match p with | NW _ => red in x' | _ => idtac end *) + (* | match q with | NW _ => red in y' | _ => idtac end] *) + end. + +Ltac nbdes := repeat nbdes1. +Ltac rrnbdes H := move H at bottom; repeat red in H; nbdes. + +Ltac forall_split := + let H := fresh "__forall_split__" in first [intro; forall_split; match goal with [H:_|-_] => revert H end | split]. + +Definition _HID_ (A : Type) (a : A) := a. + +Ltac hdesHi H P x y := + let FF := fresh "__hdesfalse__" in + let TMP := fresh "__hdesHi__" in + let P1 := fresh "__hdesHi__" in + let P2 := fresh "__hdesHi__" in + evar (P1 : Prop); evar (P2 : Prop); + assert (TMP: False -> P) by + (intro FF; forall_split; + [ let G := get_concl in set (TMP := G); revert P1; instantiate (1:=G) + | let G := get_concl in set (TMP := G); revert P2; instantiate (1:=G) ]; + destruct FF); + try clear TMP; + try (try (match goal with [Def := ?G : _ |- _] => + match Def with P1 => + match goal with [_ : G |- _] => fail 4 end end end); + assert (x: P1) by (unfold P1; repeat (let x := fresh "__xhj__" in intro x; specialize (H x)); apply H)); + try unfold P1 in x; try clear P1; + try (try (match goal with [Def := ?G : _ |- _] => + match Def with P2 => + match goal with [_ : G |- _] => fail 4 end end end); + assert (y: P2) by (unfold P2; repeat (let x := fresh "__xhj__" in intro x; specialize (H x)); apply H)); + try unfold P2 in y; try clear P2; + fold (_HID_ P) in H; + try clear H. + +Ltac hdesHP H P := + let H' := fresh H in let H'' := fresh H in + match P with + | context[ NW (fun x => _) /\ NW (fun y => _) ] => + let x' := fresh x in let y' := fresh y in + hdesHi H P x' y'; red in x'; red in y' + | context[ NW (fun x => _) /\ _ ] => + let x' := fresh x in + hdesHi H P x' H'; red in x' + | context[ _ /\ NW (fun y => _) ] => + let y' := fresh y in + hdesHi H P H' y'; red in y' + | context[ _ /\ _ ] => + hdesHi H P H' H'' + | context[ NW (fun x => _) <-> NW (fun y => _) ] => + let x' := fresh x in let y' := fresh y in + hdesHi H P x' y'; red in x'; red in y' + | context[ NW (fun x => _) <-> _ ] => + let x' := fresh x in + hdesHi H P x' H'; red in x' + | context[ _ <-> NW (fun y => _) ] => + let y' := fresh y in + hdesHi H P H' y'; red in y' + | context[ _ <-> _ ] => + hdesHi H P H' H'' + end. + +Ltac hdesH H := let P := type of H in hdesHP H P; unfold _HID_ in *. + +(* +(* It works, but too slows *) +Ltac hdesF P := + match P with + | fun _ => _ /\ _ => idtac + | fun _ => _ <-> _ => idtac + | fun x => forall y : @?ty x, @?f x y => + let P' := eval cbv beta in (fun p : sigT ty => f (projT1 p) (projT2 p)) in + hdesF P' + end. + +Ltac hdes := + repeat match goal with | H : ?P |- _ => hdesF (fun _ : unit => P); hdesHP H P end; + unfold _HID_ in *. +*) + +Ltac hdesF P := + match P with | _ /\ _ => idtac | _ <-> _ => idtac | forall _, _ => + match P with | forall _, _ /\ _ => idtac | forall _, _ <-> _ => idtac | forall _ _, _ => + match P with | forall _ _, _ /\ _ => idtac | forall _ _, _ <-> _ => idtac | forall _ _ _, _ => + match P with | forall _ _ _, _ /\ _ => idtac | forall _ _ _, _ <-> _ => idtac | forall _ _ _ _, _ => + match P with | forall _ _ _ _, _ /\ _ => idtac | forall _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _, _ => + match P with | forall _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac + end end end end end end end end end end end end end end end end end end end end end. + +(** Fail if hypothesis [H] doesn't exist. *) +Ltac check_hyp H := match H with _ => idtac end. + +(** Fail if hypothesis [H1] is not [H2]. *) +Ltac check_equal H1 H2 := match H1 with H2 => idtac end. + +Ltac hdes := + repeat match goal with | H : ?P |- _ => hdesF P; hdesHP H P end; + unfold _HID_ in *. +Ltac rdes H := red in H; des. +Ltac rrdes H := move H at bottom; repeat red in H; des. +Ltac rhdes H := red in H; hdes. +Ltac rrhdes H := check_hyp H; repeat red in H; hdes. + +Tactic Notation "rrdes" ident(a) := + (rrdes a). +Tactic Notation "rrdes" ident(a) ident(b) := + (rrdes a; rrdes b). +Tactic Notation "rrdes" ident(a) ident(b) ident(c) := + (rrdes a; rrdes b c). +Tactic Notation "rrdes" ident(a) ident(b) ident(c) ident(d) := + (rrdes a b; rrdes c d). + +(** Destruct the condition of an [if] expression occuring in the goal. *) +Ltac des_if := + match goal with + | [ |- context[if ?X then _ else _] ] => destruct X + end. +(* Ltac desE_if := *) +(* match goal with *) +(* | [ |- context[if ?X then _ else _] ] => let E := fresh X in destruct X eqn:E *) +(* end. *) + +(** Destruct the condition of an [if] expression occuring in the given hypothesis. *) +Ltac des_ifH H := + match goal with + | [ H' : context[if ?X then _ else _] |- _ ] => check_equal H' H; destruct X + end. + +(* TODO tactics such as these should always do clean at the end to remove junk like [H : x = x] *) +Ltac des_ifs := + clarify; + repeat + match goal with + | |- context[match ?x with _ => _ end] => + match (type of x) with + | { _ } + { _ } => destruct x; clarify + | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify + end + | H: context[ match ?x with _ => _ end ] |- _ => + match (type of x) with + | { _ } + { _ } => destruct x; clarify + | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify + end + end. + +Ltac desf := clarify; des; des_ifs. +Ltac isd := ins; desf. + +(** Create a copy of hypothesis [H]. *) +Tactic Notation "dup" hyp(H) := + let H' := fresh H in assert (H' := H). + +(* (** Call tactic [tac] on a copy of [H]. *) *) +(* Tactic Notation "dup" hyp(H) tactic(tac) := *) +(* let H' := fresh H in assert (H' := H); tac H'. *) + +Ltac clarassoc := clarsimp; autorewrite with sflib sflibA in *; try done. + +Ltac sflib__hacksimp1 := + clarsimp; + match goal with + | H: _ |- _ => solve [rewrite H; clear H; clarsimp + |rewrite <- H; clear H; clarsimp] + | _ => solve [f_equal; clarsimp] + end. + +Ltac hacksimp := + clarsimp; + try match goal with + | H: _ |- _ => solve [rewrite H; clear H; clarsimp + |rewrite <- H; clear H; clarsimp] + | |- context[if ?p then _ else _] => solve [destruct p; sflib__hacksimp1] + | _ => solve [f_equal; clarsimp] + end. + +(* ************************************************************************** *) +(** * Delineating cases in proofs *) +(* ************************************************************************** *) + +(** Named case tactics (taken from Libtactics) *) + +Tactic Notation "assert_eq" ident(x) constr(v) := + let H := fresh in + assert (x = v) as H by reflexivity; + clear H. + +Tactic Notation "Case_aux" ident(x) constr(name) := + first [ + set (x := name); move x at top + | assert_eq x name + | fail 1 "because we are working on a different case." ]. + +Ltac Case name := Case_aux case name. +Ltac SCase name := Case_aux subcase name. +Ltac SSCase name := Case_aux subsubcase name. +Ltac SSSCase name := Case_aux subsubsubcase name. +Ltac SSSSCase name := Case_aux subsubsubsubcase name. + +(** Lightweight case tactics (without names) *) + +Tactic Notation "-" tactic(c) := + first [ + assert (WithinCaseM := True); move WithinCaseM at top + | fail 1 "because we are working on a different case." ]; c. + +Tactic Notation "+" tactic(c) := + first [ + assert (WithinCaseP := True); move WithinCaseP at top + | fail 1 "because we are working on a different case." ]; c. + +Tactic Notation "*" tactic(c) := + first [ + assert (WithinCaseS := True); move WithinCaseS at top + | fail 1 "because we are working on a different case." ]; c. + +Tactic Notation ":" tactic(c) := + first [ + assert (WithinCaseC := True); move WithinCaseC at top + | fail 1 "because we are working on a different case." ]; c. + +(* ************************************************************************** *) +(** * Exploiting a hypothesis *) +(* ************************************************************************** *) + +(** Exploit an assumption (adapted from CompCert). *) + +Tactic Notation "exploit" uconstr(t) := + refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _) _) + || refine ((fun x y => y x) (t _ _) _) + || refine ((fun x y => y x) (t _) _). + +(* When 'exploit x' generates too many sub goals, try 'hexploit x' *) + +Lemma mp: forall P Q: Type, P -> (P -> Q) -> Q. +Proof. intuition. Defined. + +Lemma mp': forall P Q : Type, (P -> Q) -> P -> Q. +Proof. intuition. Qed. + +Ltac hexploit x := eapply mp; [eapply x|]. +Ltac hexploit' x := let H := fresh in set (H := x); clear H; eapply mp; [eapply x|]. + +(* set_prop N T A performs 'assert (A : P); [|set (N := T A)]' when T is a term of type (P -> _) *) + +Ltac set_prop N T A := + let b := fresh in let ty := type of T in + match ty with (forall (_:?P), _) => assert (A: P); [|set (N := T A)] end. + +(* ************************************************************************** *) +(** * Induction tactics *) +(* ************************************************************************** *) + +Tactic Notation "induction" "[" ident_list(y) "]" ident(x) := + first [ try (intros until x); revert y; induction x + | red; try (intros until x); revert y; induction x ]. + +Tactic Notation "induction" "[" ident_list(y) "]" ident(x) "[" ident(z) "]" := + first [ try (intros until x); revert y; induction x; destruct z + | red; try (intros until x); revert y; induction x; destruct z ]. + +(** Versions with hacksimp *) + +Tactic Notation "induct" ident(x) := induction x; hacksimp. + +Tactic Notation "induct" ident(x) "[" ident(z) "]" := + induction x; destruct z; hacksimp. + +Tactic Notation "induct" "[" ident_list(y) "]" ident(x) := + first [ try (intros until x); revert y; induction x; hacksimp + | red; try (intros until x); revert y; induction x; hacksimp ]. + +Tactic Notation "induct" "[" ident_list(y) "]" ident(x) "[" ident(z) "]" := + first [ try (intros until x); revert y; induction x; destruct z; hacksimp + | red; try (intros until x); revert y; induction x; destruct z; hacksimp ]. + +Tactic Notation "edestructs" ident(a) := + (edestruct a). +Tactic Notation "edestructs" ident(a) ident(b) := + (edestruct a; edestruct b). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) := + (edestruct a; edestructs b c). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) := + (edestruct a; edestructs b c d). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) := + (edestruct a; edestructs b c d e). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) := + (edestruct a; edestructs b c d e f). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) := + (edestruct a; edestructs b c d e f g). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) := + (edestruct a; edestructs b c d e f g h). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) := + (edestruct a; edestructs b c d e f g h i). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) ident(j) := + (edestruct a; edestructs b c d e f g h i j). + +Tactic Notation "destructs" ident(a) := + (destruct a). +Tactic Notation "destructs" ident(a) ident(b) := + (destruct a; destruct b). +Tactic Notation "destructs" ident(a) ident(b) ident(c) := + (destruct a; destructs b c). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) := + (destruct a; destructs b c d). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) := + (destruct a; destructs b c d e). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) := + (destruct a; destructs b c d e f). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) := + (destruct a; destructs b c d e f g). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) := + (destruct a; destructs b c d e f g h). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) := + (destruct a; destructs b c d e f g h i). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) ident(j) := + (destruct a; destructs b c d e f g h i j). + +Tactic Notation "depdes" ident(_something_which_shold_not_occur_in_the_goal_) := + (let _x_ := type of _something_which_shold_not_occur_in_the_goal_ + in dependent destruction _something_which_shold_not_occur_in_the_goal_). +Tactic Notation "depdes" ident(a) ident(b) := + (depdes a; depdes b). +Tactic Notation "depdes" ident(a) ident(b) ident(c) := + (depdes a; depdes b c). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) := + (depdes a; depdes b c d). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) := + (depdes a; depdes b c d e). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) := + (depdes a; depdes b c d e f). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) := + (depdes a; depdes b c d e f g). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) := + (depdes a; depdes b c d e f g h). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) := + (depdes a; depdes b c d e f g h i). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) ident(j) := + (depdes a; depdes b c d e f g h i j). + +Tactic Notation "depgen" ident(x) := generalize dependent x. + +(* eappleft, eappright *) + +Ltac eappleft H := + let X := fresh "__lem__" in let X1 := fresh "__lem__" in let X2 := fresh "__lem__" in + assert (X:= H); let P := type of X in hdesHi X P X1 X2; + eapply X1; clear X1 X2. + +Ltac eappright H := + let X := fresh "__lem__" in let X1 := fresh "__lem__" in let X2 := fresh "__lem__" in + assert (X:= H); let P := type of X in hdesHi X P X1 X2; + eapply X2; clear X1 X2. + +(* guard for simpl *) + +(* for Coq8.4 *) + +Definition __guard__ A (a : A) : A := a. +Definition __GUARD__ A (a : A) : A := a. +Arguments __guard__ A a : simpl never. +Arguments __GUARD__ A a : simpl never. + +Tactic Notation "guard" constr(t) "in" hyp(H) := fold (__guard__ t) in H. +Tactic Notation "guardH" hyp(H) := let t := type of H in guard t in H. +Tactic Notation "guard" := + repeat match goal with [H: ?P |- _] => + try (match P with __guard__ _ => fail 2 end); guardH H + end. +Tactic Notation "sguard" constr(t) "in" hyp(H) := fold (__GUARD__ t) in H. +Tactic Notation "sguard" "in" hyp(H) := let t := type of H in sguard t in H. + +Ltac unguard := unfold __guard__ in *. +Ltac unguardH H := unfold __guard__ in H. +Ltac unsguard H := unfold __GUARD__ in H. + +Ltac desH H := guard; unguardH H; des; unguard. + +Ltac splits := + intros; unfold NW; + repeat match goal with + | [ |- _ /\ _ ] => split + end. +Ltac esplits := + intros; unfold NW; + repeat match goal with + | [ |- @ex _ _ ] => eexists + | [ |- _ /\ _ ] => split + | [ |- @sig _ _ ] => eexists + | [ |- @sigT _ _ ] => eexists + | [ |- @prod _ _ ] => split + end. + +Tactic Notation "replace_all" constr(e) := repeat ( + let X := fresh in assert (X: e) by (clarify; eauto; done); + first [rewrite !X | setoid_rewrite X]; clear X). + +Lemma all_conj_dist: forall A (P Q: A -> Prop), + (forall a, P a /\ Q a) -> (forall a, P a) /\ (forall a, Q a). +Proof. intros; hdes; eauto. Qed. + +(* extensionalities *) + +Tactic Notation "extensionalities" := + repeat let x := fresh in extensionality x. +Tactic Notation "extensionalities" ident(a) := + (extensionality a). +Tactic Notation "extensionalities" ident(a) ident(b) := + (extensionality a; extensionality b). +Tactic Notation "extensionalities" ident(a) ident(b) ident(c) := + (extensionality a; extensionalities b c). +Tactic Notation "extensionalities" ident(a) ident(b) ident(c) ident(d) := + (extensionality a; extensionalities b c d). +Tactic Notation "extensionalities" ident(a) ident(b) ident(c) ident(d) ident(e) := + (extensionality a; extensionalities b c d e). +Tactic Notation "extensionalities" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) := + (extensionality a; extensionalities b c d e f). + +(* short for common tactics *) + +Tactic Notation "inst" := instantiate. +Tactic Notation "econs" := econstructor. +Tactic Notation "econs" int_or_var(x) := econstructor x. +Tactic Notation "i" := intros. +Tactic Notation "ii" := repeat intro. +Tactic Notation "s" := simpl. +Tactic Notation "s" ident(a) := simpl a. +Tactic Notation "s" constr(t) := simpl t. +Tactic Notation "s" "in" hyp(H) := simpl in H. +Tactic Notation "ss" := simpls. +Tactic Notation "r" := red. +Tactic Notation "r" "in" hyp(H) := red in H. +Tactic Notation "rr" := repeat red. +Tactic Notation "rr" "in" hyp(H) := repeat red in H. + +(* running a tactic selectively on subgoals *) + +Definition __mark__ A (a : A) : A := a. + +Tactic Notation "M" := + match goal with [|-?G] => fold (__mark__ G) end. + +Tactic Notation "Mdo" tactic(tac) := + first [ try match goal with [|- __mark__ _ ] => fail 2 end | unfold __mark__; tac ]. + +Tactic Notation "Mskip" tactic(tac) := + first [ match goal with [|- __mark__ _ ] => unfold __mark__ end | tac ]. + +Tactic Notation "Mfirst" tactic(main) ";;" tactic(post) := + main; (Mdo (post; M)); (Mskip post). + +(* revert until *) + +Ltac on_last_hyp tac := + match goal with [ H : _ |- _ ] => first [ tac H | fail 1 ] end. + +Ltac revert_until id := + on_last_hyp ltac:(fun id' => + match id' with + | id => idtac + | _ => revert id' ; revert_until id + end). + +Open Scope string_scope. +Open Scope list_scope. + +Fixpoint beq_str (s1 s2: string) : bool := + match s1, s2 with + | "", "" => true + | String a s1', String b s2' => if Ascii.ascii_dec a b then beq_str s1' s2' else false + | _, _ => false + end. + +Ltac uf := (autounfold with * in *). + +Tactic Notation "patout" constr(z) "in" hyp(a) := + pattern z in a; match goal with [a:=?f z|-_] => unfold a; clear a; set (a:=f) end. + +Ltac clear_upto H := + repeat (match goal with [Hcrr : _ |- _ ] => first [ check_equal Hcrr H; fail 2 + | clear Hcrr ] end). + +Definition _Evar_sflib_ (A:Type) (x:A) := x. + +Tactic Notation "hide_evar" int_or_var(n) := let QQ := fresh "QQ" in + hget_evar n; intro; + lazymatch goal with [ H := ?X |- _] => + set (QQ := X) in *; fold (_Evar_sflib_ X) in QQ; clear H + end. + +Ltac hide_evars := repeat (hide_evar 1). + +Ltac show_evars := repeat (match goal with [ H := @_Evar_sflib_ _ _ |- _ ] => unfold + _Evar_sflib_ in H; unfold H in *; clear H end). + +Ltac revert1 := match goal with [H: _|-_] => revert H end. + +Lemma eqimpl: forall P Q : Prop, P = Q -> P -> Q. +Proof. by i; subst; auto. Qed. + +Ltac ginduction H := + move H at top; revert_until H; induction H. + +Tactic Notation "greflgen" constr(t) "as" ident(g) := + let EQ := fresh "XEQ" in + generalize (eq_refl t); generalize t at -2 as g + ; intros ? EQ ?; revert EQ. + +Ltac eadmit := + exfalso; clear; admit. + +Ltac special H := + (* eapply mp; refine (H _). *) + match type of H with + | ?A -> ?B => + let a := fresh in assert (a: A); [|specialize (H a)] + end. + +(** Useful for e.g. [ex @nil]. *) +Ltac ex x := eapply (ex_intro _ (x _)). + +Ltac inst_pairs := + repeat first + [instantiate (9 := (_, _)) + |instantiate (8 := (_, _)) + |instantiate (7 := (_, _)) + |instantiate (6 := (_, _)) + |instantiate (5 := (_, _)) + |instantiate (4 := (_, _)) + |instantiate (3 := (_, _)) + |instantiate (2 := (_, _)) + |instantiate (1 := (_, _))]. + +(* Problem: unfold fst doesn't always result in a lambda *) +(* Ltac fold_proj := *) +(* try match goal with |- context[fun _ : ?A * ?B => _] => *) +(* first [fold (@fst A B) | fold (@snd A B)]; fail *) +(* end. *) +(* Ltac fold_projH H := *) +(* match type of H with | context[fun _ : ?A * ?B => _] => *) +(* first [fold (@fst A B) in H | fold (@snd A B) in H]; fail *) +(* end. *) +(* Ltac simpl_proj := *) +(* unfold fst in *; Hdo fold_projH; fold_proj. *) + +(* Lemma simpl_fst: forall A (a: A) B (b: B), *) +(* fst (a, b) = a. *) +(* Proof. *) +(* auto. *) +(* Qed. *) + +(* Lemma simpl_snd: forall B (b: B) A (a: A), *) +(* snd (a, b) = b. *) +(* Proof. *) +(* auto. *) +(* Qed. *) + +Ltac simpl_proj := + do 5 (simpl (fst (_, _)) in *; simpl (snd (_, _)) in *). + (* ; repeat first [rewrite !simpl_fst | rewrite !simpl_snd] *) + (* ; Hdo (fun H => repeat first [rewrite !simpl_fst in H | rewrite !simpl_snd in H]). *) + +Ltac clean := + repeat match goal with + | H: True |- _ + => clear H + | H: ?x = ?y |- _ + => try (has_evar x; fail 2); try (has_evar y; fail 2); + change x with y in H; clear H + end + ; simpl_proj. + (* without the evar check, clean removes equations such as the following: + X : length (getVal ?28711 ?28712 ?28713 ?28714) = S n *) + + +Tactic Notation "lhs" tactic(tac) := + match goal with |- ?op ?lhs ?rhs => + let tmp := fresh in set (tmp := rhs); tac; unfold tmp; clear tmp + end. + +(* Variant of lhs that allows prover to combine lhs/rhs tactics in + * tacticals. For example: + * lhs (rewrite blah); rhs (rewrite blah). + * is allowed. lhs fails because the precedence for the tactic + * was higher than the ";" and so tac = rewrite blah; rhs (rewrite blah). + * TODO: Check whether it's safe to override the definition of lhs/rhs. + *) +Tactic Notation "lhs3" tactic3(tac) := + match goal with |- ?op ?lhs ?rhs => + let tmp := fresh in set (tmp := rhs); tac; unfold tmp; clear tmp + end. + +Tactic Notation "rhs" tactic(tac) := + match goal with |- ?op ?lhs ?rhs => + let tmp := fresh in set (tmp := lhs); tac; unfold tmp; clear tmp + end. + +(* See the comment for lhs3. *) +Tactic Notation "rhs3" tactic3(tac) := + match goal with |- ?op ?lhs ?rhs => + let tmp := fresh in set (tmp := lhs); tac; unfold tmp; clear tmp + end. + + +(* TODO generalize to hyps *) + + +(** Execute a tactic only if the goal contains no evars. *) +Tactic Notation "safe" tactic(tac) := + try match goal with |- ?G => try (has_evar G; fail 2); tac end. + + +(** Rename a hypothesis to a fresh name. *) +Ltac ren H := + let X := fresh H in rename H into X. + +(* (** Instantiate consecutive evars. *) *) +(* Tactic Notation "insts" constr(terms) := *) +(* Hdo (fun x => instantiate (1 := x)) terms. *) +(* (* TODO this is not very useful after all *) *) + + + +(** Automation using econstructor. + What it does is clear from the definition below. *) +Tactic Notation "econsby" tactic(tac) := + first [econstructor 1; (by tac) + |econstructor 2; (by tac) + |econstructor 3; (by tac) + |econstructor 4; (by tac) + |econstructor 5; (by tac) + |econstructor 6; (by tac) + |econstructor 7; (by tac) + |econstructor 8; (by tac) + |econstructor 9; (by tac) + |econstructor 10; (by tac) + |econstructor 11; (by tac) + |econstructor 12; (by tac) + |econstructor 13; (by tac) + |econstructor 14; (by tac) + |econstructor 15; (by tac) + |econstructor 16; (by tac) + |econstructor 17; (by tac) + |econstructor 18; (by tac) + |econstructor 19; (by tac) + |econstructor 20; (by tac) + ]. From 9120825ea63d55181202b53ec1ecb2c06022f7ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Wed, 6 Dec 2023 17:39:54 +0100 Subject: [PATCH 20/83] [Compartments] Fix proof in ValueAnalysis --- backend/Stackingproof.v | 13 +++++++---- backend/ValueAnalysis.v | 18 +++----------- common/Memory.v | 52 +++++++++++++++++++++++++++++------------ common/Separation.v | 16 +++++++++---- 4 files changed, 61 insertions(+), 38 deletions(-) diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index cca973ef18..cd78a882d5 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -230,10 +230,15 @@ Next Obligation. | Z.pos y' => Z.pos y'~0~0 | Z.neg y' => Z.neg y'~0~0 end) with (4 * bound) in *. - eapply Mem.unchanged_on_own with (b := sp) in H0. - eauto with comps. - (* eapply H0. eauto. *) - (* eapply Mem.can_access_block_valid_block; eauto. *) + simpl. destruct (plt sp (Mem.nextblock m)). + + eapply Mem.unchanged_on_own with (b := sp) in H0. + simpl; rewrite H0. + eauto with comps. auto. + + assert (cp = top). + { exploit Mem.block_compartment_valid_block; eauto. simpl in H4. + intros R; rewrite R in H4. + inv H4; auto. } + subst; auto with comps. - exploit H5; eauto. intros (v & A & B). exists v; split; auto. change (match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0 diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index e88197cd02..525e1c90b2 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -952,7 +952,7 @@ Theorem external_call_match: /\ bc_nostack bc' /\ (forall b ofs n cp, Mem.valid_block m b -> - Mem.can_access_block m b cp -> + (* Mem.can_access_block m b cp -> *) bc b = BCinvalid -> Mem.loadbytes m' b ofs n cp = Mem.loadbytes m b ofs n cp). Proof. @@ -1065,16 +1065,8 @@ Proof. destruct (j' b); congruence. - (* unmapped blocks are invariant *) intros. - destruct (Mem.can_access_block_dec m b cp0) eqn:e. eapply Mem.loadbytes_unchanged_on_1; auto. - apply UNCH1; auto. intros; red. unfold inj_of_bc; rewrite H1; auto. - contradiction. - (* destruct (Mem.can_access_block_dec m' b cp0) eqn:e'. *) - (* eapply Mem.unchanged_on_own in UNCH1; eauto. clear e'. *) - (* eapply (proj2 UNCH1) in c. contradiction. *) - (* Local Transparent Mem.loadbytes. unfold Mem.loadbytes. *) - (* rewrite e, e'. simpl. rewrite 2!andb_false_r. reflexivity. *) - (* Local Opaque Mem.loadbytes. *) + apply UNCH1; auto. intros; red. unfold inj_of_bc; rewrite H0; auto. Qed. (** ** Semantic invariant *) @@ -1386,7 +1378,6 @@ Proof. intros. rewrite K; auto. rewrite C; auto. apply bmatch_inv with m. eapply mmatch_stack; eauto. intros. apply Q; eauto. - admit. eapply external_call_nextblock; eauto. intros (bc3 & U & V & W & X & Y & Z & AA). eapply sound_succ_state with (bc := bc3); eauto. simpl; auto. @@ -1394,7 +1385,6 @@ Proof. apply sound_stack_exten with bc. apply sound_stack_inv with m. auto. intros. apply Q. red. eapply Plt_trans; eauto. - admit. rewrite C; auto with ordered_type. intros. eapply external_call_can_access_block; eauto. exact AA. @@ -1416,7 +1406,6 @@ Proof. apply sound_stack_exten with bc. apply sound_stack_inv with m. auto. intros. apply Q. red. eapply Plt_trans; eauto. - admit. rewrite C; auto with ordered_type. intros. eapply external_call_can_access_block; eauto. exact AA. @@ -1530,7 +1519,6 @@ Proof. apply sound_stack_new_bound with (Mem.nextblock m). apply sound_stack_exten with bc; auto. apply sound_stack_inv with m; auto. - intros. eapply K; eauto. admit. intros. eapply external_call_can_access_block; eauto. eapply external_call_nextblock; eauto. @@ -1552,7 +1540,7 @@ Proof. eapply sound_regular_state with (bc := bc1); eauto. apply sound_stack_exten with bc'; auto. eapply ematch_ge; eauto. apply ematch_update. auto. auto. -Admitted. +Qed. End SOUNDNESS. diff --git a/common/Memory.v b/common/Memory.v index 40df75e14d..69fdcec07f 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -5197,7 +5197,8 @@ Record unchanged_on (m_before m_after: mem) : Prop := mk_unchanged_on { ZMap.get ofs (PMap.get b m_before.(mem_contents)); unchanged_on_own: forall b, - block_compartment m_after b ⊆ block_compartment m_before b + valid_block m_before b -> (* Adjust preconditions as needed. *) + block_compartment m_after b = block_compartment m_before b (* valid_block m_before b -> (* Adjust preconditions as needed. *) *) (* (can_access_block m_before b cp -> can_access_block m_after b cp) *) }. @@ -5240,8 +5241,10 @@ Proof. eapply valid_block_unchanged_on; eauto. - intros. transitivity (ZMap.get ofs (mem_contents m2)#b); apply unchanged_on_contents; auto. eapply perm_unchanged_on; eauto. -- intros. eapply flowsto_trans; eauto using unchanged_on_own. - (* eapply unchanged_on_own; eauto. eapply unchanged_on_own; eauto. *) +- intros. transitivity (block_compartment m2 b). + (* eapply flowsto_trans; eauto. *) + eapply unchanged_on_own; eauto using valid_block_unchanged_on. + eapply unchanged_on_own; eauto using valid_block_unchanged_on. Qed. Lemma loadbytes_unchanged_on_1: @@ -5249,14 +5252,21 @@ Lemma loadbytes_unchanged_on_1: unchanged_on m m' -> valid_block m b -> (forall i, ofs <= i < ofs + n -> P b i) -> - forall OWN : can_access_block m b cp, + (* forall OWN : can_access_block m b cp, *) loadbytes m' b ofs n cp = loadbytes m b ofs n cp. Proof. intros. destruct (zle n 0). -- erewrite ! loadbytes_empty; try easy. - simpl. eapply flowsto_trans; eauto using unchanged_on_own. - (* eapply unchanged_on_own0; eauto. *) +- (* destruct (plt b (nextblock m)) as [e0 | n0]. *) + destruct (can_access_block_dec m b cp). + + erewrite ! loadbytes_empty; try easy. + simpl. erewrite unchanged_on_own; eauto. + + unfold loadbytes. + rewrite 2!andb_false_intro2; auto. + destruct can_access_block_dec; now auto. + destruct can_access_block_dec; auto. + simpl in *. + erewrite unchanged_on_own in c; eauto. contradiction. - unfold loadbytes. destruct H. destruct (range_perm_dec m b ofs (ofs + n) Cur Readable). + destruct (can_access_block_dec m b cp). @@ -5265,8 +5275,12 @@ Proof. apply unchanged_on_contents0; auto. red; intros. apply unchanged_on_perm0; auto. simpl. eapply flowsto_trans; eauto. - (* apply unchanged_on_own0; auto. *) -* contradiction. + erewrite unchanged_on_own0; auto with comps. +* simpl. + rewrite andb_false_intro2; auto. + destruct can_access_block_dec; auto. + simpl in *. + erewrite unchanged_on_own0 in c; eauto. contradiction. + setoid_rewrite pred_dec_false at 1. auto. red; intros; elim n0; red; intros. apply <- unchanged_on_perm0; auto. Qed. @@ -5293,9 +5307,15 @@ Proof. intros. pose proof loadbytes_can_access_block_inj _ _ _ _ _ _ H1 as Hown. destruct (zle n 0). -+ erewrite loadbytes_empty in *; try assumption. - inv H. - simpl. eapply flowsto_trans; eauto. ++ destruct (plt b (nextblock m)). + - rewrite <- H1. apply loadbytes_unchanged_on_1; auto. + - assert (cp = top). + { exploit block_compartment_valid_block; eauto. simpl in Hown. + intros R; rewrite R in Hown. + inv Hown; auto. } + subst cp. + erewrite loadbytes_empty in *; try assumption. + simpl; auto with comps. + rewrite <- H1. apply loadbytes_unchanged_on_1; auto. exploit loadbytes_range_perm; eauto. instantiate (1 := ofs). lia. intros. eauto with mem. @@ -5315,6 +5335,7 @@ Proof. split; auto. red; intros. eapply perm_unchanged_on; eauto. split; auto. simpl; eapply flowsto_trans; eauto using unchanged_on_own. + erewrite unchanged_on_own; eauto with comps. - rewrite pred_dec_false. auto. red; intros [A [B C]]; elim n; split; auto. red; intros; eapply perm_unchanged_on_2; eauto. Qed. @@ -5380,9 +5401,10 @@ Proof. - injection H; intros A B. rewrite <- B; simpl. rewrite PMap.gso; auto. rewrite A. eapply valid_not_valid_diff; eauto with mem. - destruct (peq b0 b). -+ subst b0. eapply unowned_fresh_block with (c' := block_compartment m b) in H; try rewrite H; auto with comps. -+ eapply alloc_lowers_comp; eauto. - (* eapply alloc_can_access_block_other_inj_1; eauto. *) ++ subst b0. + apply fresh_block_alloc in H; contradiction. ++ unfold alloc in H. inv H; subst. unfold block_compartment. simpl. + rewrite PMap.gso; auto. Qed. Lemma free_unchanged_on: diff --git a/common/Separation.v b/common/Separation.v index 7031f3dee7..3c94fbc58c 100644 --- a/common/Separation.v +++ b/common/Separation.v @@ -428,9 +428,15 @@ Next Obligation. - destruct H1; split; auto. red; intros; eapply Mem.perm_unchanged_on; eauto. simpl; auto. destruct H2. split. - simpl. - simpl; eapply flowsto_trans; eapply Mem.unchanged_on_own with (b := b) in H0; eauto. - easy. + + simpl. destruct (plt b (Mem.nextblock m)). + * simpl; eapply flowsto_trans; eapply Mem.unchanged_on_own with (b := b) in H0; eauto. + rewrite H0; eauto with comps. + * assert (cp = top). + { exploit Mem.block_compartment_valid_block; eauto. simpl in H2. + intros R; rewrite R in H2. + inv H2; auto. } + subst; auto with comps. + + easy. - exists v. split; auto. eapply Mem.load_unchanged_on; eauto. simpl; auto. Qed. Next Obligation. @@ -640,7 +646,9 @@ Next Obligation. - destruct mi_inj. constructor; intros. + eapply Mem.perm_unchanged_on; eauto. + eapply (Mem.unchanged_on_own) with (b := b2) in H0. - eapply flowsto_trans; eauto. eapply mi_own; eauto. + simpl; rewrite H0. + eapply flowsto_trans; eauto. eapply mi_own; simpl; eauto with comps. + exploit mi_mappedblocks; eauto. + eauto. + rewrite (Mem.unchanged_on_contents _ _ _ H0); eauto. - assumption. From c497ce3691590782ce48caf45e962232d6ef1d7c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Wed, 6 Dec 2023 18:05:47 +0100 Subject: [PATCH 21/83] [Compartments] Clean-up the compartment model --- common/AST.v | 84 +------------------------------------------------ common/Memory.v | 8 ----- 2 files changed, 1 insertion(+), 91 deletions(-) diff --git a/common/AST.v b/common/AST.v index 7e4951a4b1..428b9aaa3c 100644 --- a/common/AST.v +++ b/common/AST.v @@ -35,11 +35,6 @@ Definition ident_eq := peq. (** Programs entities can be grouped into compartments, which remain isolated from each other during execution. *) -(* Definition compartment : Type := positive. *) -(* Definition privileged_compartment : compartment := 1%positive. *) -(* Notation default_compartment := privileged_compartment. (* TODO: fix this *) *) -(* Definition eq_compartment (c1 c2: compartment) := *) -(* peq c1 c2. *) Module Type COMPTYPE. Parameter compartment: Type. @@ -76,33 +71,6 @@ Module CompTree := ITree (COMPARTMENT_INDEXED_TYPE). Axiom bottom_flowsto: forall cp, bottom ⊆ cp. Axiom flowsto_top: forall cp, cp ⊆ top. -Parameters join meet: compartment -> compartment -> compartment. -Notation "c '∪' c'" := (join c c') (left associativity, at level 40). -Notation "c '∩' c'" := (meet c c') (left associativity, at level 40). -Axiom join_comm: forall cp cp', cp ∪ cp' = cp' ∪ cp. -Axiom meet_comm: forall cp cp', cp ∩ cp' = cp' ∩ cp. -Axiom join_assoc: forall cp cp' cp'', cp ∪ (cp' ∪ cp'') = (cp ∪ cp') ∪ cp''. -Axiom meet_assoc: forall cp cp' cp'', cp ∩ (cp' ∩ cp'') = (cp ∩ cp') ∩ cp''. -Axiom join_absorbs_meet: forall cp cp', cp ∪ (cp ∩ cp') = cp. -Axiom meet_absorbs_join: forall cp cp', cp ∩ (cp ∪ cp') = cp. - -Lemma join_idempotent: forall cp, cp ∪ cp = cp. -Proof. - intros cp. - rewrite <- (meet_absorbs_join cp cp) at 2; rewrite join_absorbs_meet; reflexivity. -Qed. - -Lemma meet_idempotent: forall cp, cp ∩ cp = cp. -Proof. - intros cp. - rewrite <- (join_absorbs_meet cp cp) at 2; rewrite meet_absorbs_join; reflexivity. -Qed. - -Axiom flowsto_join1: forall cp cp', cp ⊆ cp ∪ cp'. -Axiom flowsto_join2: forall cp cp', cp' ⊆ cp ∪ cp'. -Axiom meet_flowsto1: forall cp cp', cp ∩ cp' ⊆ cp. -Axiom meet_flowsto2: forall cp cp', cp ∩ cp' ⊆ cp'. - End COMPTYPE. Module COMP <: COMPTYPE. @@ -186,63 +154,13 @@ End COMPARTMENT_INDEXED_TYPE. Module CompTree := ITree (COMPARTMENT_INDEXED_TYPE). -(* Axiom bottom_flowsto: forall cp, bottom ⊆ cp. *) -(* Axiom flowsto_top: forall cp, cp ⊆ top. *) - - -Definition join (c1 c2: compartment): compartment := - match c1, c2 with - | bottom', c2 => c2 - | c1, bottom' => c1 - | Comp i1, Comp i2 => if (Pos.eq_dec i1 i2) then Comp i1 else top - | _, _ => top - end. - -Definition meet (c1 c2: compartment): compartment := - match c1, c2 with - | top', c2 => c2 - | c1, top' => c1 - | Comp i1, Comp i2 => if (Pos.eq_dec i1 i2) then Comp i1 else bottom - | _, _ => bottom - end. - -Notation "c '∪' c'" := (join c c') (left associativity, at level 40). -Notation "c '∩' c'" := (meet c c') (left associativity, at level 40). -Axiom join_comm: forall cp cp', cp ∪ cp' = cp' ∪ cp. -Axiom meet_comm: forall cp cp', cp ∩ cp' = cp' ∩ cp. -Axiom join_assoc: forall cp cp' cp'', cp ∪ (cp' ∪ cp'') = (cp ∪ cp') ∪ cp''. -Axiom meet_assoc: forall cp cp' cp'', cp ∩ (cp' ∩ cp'') = (cp ∩ cp') ∩ cp''. -Axiom join_absorbs_meet: forall cp cp', cp ∪ (cp ∩ cp') = cp. -Axiom meet_absorbs_join: forall cp cp', cp ∩ (cp ∪ cp') = cp. - -Lemma join_idempotent: forall cp, cp ∪ cp = cp. -Proof. - intros cp. - rewrite <- (meet_absorbs_join cp cp) at 2; rewrite join_absorbs_meet; reflexivity. -Qed. - -Lemma meet_idempotent: forall cp, cp ∩ cp = cp. -Proof. - intros cp. - rewrite <- (join_absorbs_meet cp cp) at 2; rewrite meet_absorbs_join; reflexivity. -Qed. - -Axiom flowsto_join1: forall cp cp', cp ⊆ cp ∪ cp'. -Axiom flowsto_join2: forall cp cp', cp' ⊆ cp ∪ cp'. -Axiom meet_flowsto1: forall cp cp', cp ∩ cp' ⊆ cp. -Axiom meet_flowsto2: forall cp cp', cp ∩ cp' ⊆ cp'. - End COMP. Export COMP. Global Opaque flowsto_dec. Create HintDb comps. -#[export] Hint Resolve flowsto_refl flowsto_antisym flowsto_trans bottom_flowsto flowsto_top - join_comm meet_comm join_assoc meet_assoc flowsto_join1 flowsto_join2 meet_flowsto1 meet_flowsto2: comps. -#[export] Hint Rewrite join_idempotent meet_idempotent join_absorbs_meet meet_absorbs_join: comps. - -Print HintDb comps. +#[export] Hint Resolve flowsto_refl flowsto_antisym flowsto_trans bottom_flowsto flowsto_top: comps. Set Typeclasses Strict Resolution. diff --git a/common/Memory.v b/common/Memory.v index 69fdcec07f..55900ecaf9 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -455,7 +455,6 @@ Theorem valid_block_can_access_block_priv: can_access_block m b top. Proof. unfold can_access_block. intros. simpl; auto with comps. - Print HintDb comps. Qed. (* Theorem can_access_block_valid_block: *) @@ -3429,13 +3428,6 @@ Proof. rewrite NEXT. eauto with mem. Qed. -(* RB: NOTE: Move up, use in previous proofs. *) -Remark can_access_block_component : - forall m b cp cp', can_access_block m b cp -> can_access_block m b cp' -> can_access_block m b (cp ∪ cp'). -Proof. - simpl. intros. eapply flowsto_trans; eauto with comps. -Qed. - Lemma alloc_left_unmapped_inj: forall f m1 m2 c lo hi m1' b1, mem_inj f m1 m2 -> From 64ed87eef94888279a89e37248e132fa14c69a6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Wed, 6 Dec 2023 20:07:16 +0100 Subject: [PATCH 22/83] [Compartments] Clean a bit --- common/AST.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/common/AST.v b/common/AST.v index 428b9aaa3c..c657e2ed8a 100644 --- a/common/AST.v +++ b/common/AST.v @@ -84,7 +84,7 @@ Module COMP <: COMPTYPE. Definition compartment := compartment'. Definition bottom := bottom'. Definition top := top'. - (* Parameters top bottom: compartment. *) + Variant flowsto': compartment -> compartment -> Prop := | bottom_flowsto': forall cp, flowsto' bottom cp | flowsto_top': forall cp, flowsto' cp top From 8a9f2d94aceb00462b2bd562863e0a0a25c5d962 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Thu, 7 Dec 2023 13:50:29 +0100 Subject: [PATCH 23/83] Import testing code from old branch --- test/backtranslation/.gitignore | 39 +++ test/backtranslation/Gen.ml | 321 +++++++++++++++++++ test/backtranslation/Gen.mli | 3 + test/backtranslation/Gen_ctx.ml | 145 +++++++++ test/backtranslation/Gen_ctx.mli | 22 ++ test/backtranslation/Graph.ml | 108 +++++++ test/backtranslation/Graph.mli | 8 + test/backtranslation/Makefile | 44 +++ test/backtranslation/Util.ml | 23 ++ test/backtranslation/Util.mli | 5 + test/backtranslation/compcert.ini | 16 + test/backtranslation/test_backtranslation.ml | 93 ++++++ 12 files changed, 827 insertions(+) create mode 100644 test/backtranslation/.gitignore create mode 100644 test/backtranslation/Gen.ml create mode 100644 test/backtranslation/Gen.mli create mode 100644 test/backtranslation/Gen_ctx.ml create mode 100644 test/backtranslation/Gen_ctx.mli create mode 100644 test/backtranslation/Graph.ml create mode 100644 test/backtranslation/Graph.mli create mode 100644 test/backtranslation/Makefile create mode 100644 test/backtranslation/Util.ml create mode 100644 test/backtranslation/Util.mli create mode 100644 test/backtranslation/compcert.ini create mode 100644 test/backtranslation/test_backtranslation.ml diff --git a/test/backtranslation/.gitignore b/test/backtranslation/.gitignore new file mode 100644 index 0000000000..d09cfc755b --- /dev/null +++ b/test/backtranslation/.gitignore @@ -0,0 +1,39 @@ +*.annot +*.cmo +*.cma +*.cmi +*.a +*.o +*.cmx +*.cmxs +*.cmxa + +# ocamlbuild working directory +_build/ + +# ocamlbuild targets +*.byte +*.native + +# oasis generated files +setup.data +setup.log + +# Merlin configuring file for Vim and Emacs +.merlin + +# Dune generated files +*.install + +# Local OPAM switch +_opam/ + +# Main file to run test +test_backtranslation + +# Ignore autogenerated dependency file +.depend + +# Ignore generated visualizations of graphs +*.dot +*.png \ No newline at end of file diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml new file mode 100644 index 0000000000..3977993cc7 --- /dev/null +++ b/test/backtranslation/Gen.ml @@ -0,0 +1,321 @@ +(*let memory_chunk = + QCheck.Gen.frequencyl + AST. + [ + (1, Mint8signed); + (1, Mint8unsigned); + (1, Mint16signed); + (1, Mint16unsigned); + (1, Mint32); + (1, Mint64); + (1, Mfloat32); + (1, Mfloat64); + (1, Many32); + (1, Many64); + ] + +let positive = QCheck.Gen.(map (fun i -> Camlcoq.P.of_int (i + 1)) small_nat) +let coq_Z = QCheck.Gen.(map (fun i -> Camlcoq.Z.of_sint i) small_signed_int) +let ident = positive +let compartment = positive +let ptrofs = QCheck.Gen.map (fun i -> Integers.Ptrofs.of_int i) coq_Z +let char_list = QCheck.Gen.(small_list (char_range 'a' 'z')) + +let binary_float = + let open QCheck.Gen in + let open Binary in + let zero = map (fun b -> B754_zero b) bool in + let infinity = map (fun b -> B754_infinity b) bool in + let nan = map (fun (b, p) -> B754_nan (b, p)) (pair bool positive) in + let finite = + map (fun (b, p, z) -> B754_finite (b, p, z)) (triple bool positive coq_Z) + in + frequency [ (1, zero); (1, infinity); (1, nan); (1, finite) ] + +let eventval = + let open QCheck.Gen in + let open Events in + let evint = map (fun i -> EVint i) coq_Z in + let evlong = map (fun i -> EVlong i) coq_Z in + let evfloat = map (fun f -> EVfloat f) binary_float in + let evsingle = map (fun f -> EVfloat f) binary_float in + let evptr_global = + map (fun (i, p) -> EVptr_global (i, p)) (pair ident ptrofs) + in + frequency + [ (1, evint); (1, evlong); (1, evfloat); (1, evsingle); (1, evptr_global) ] + +let event_syscall size = + let open QCheck.Gen in + let* name = char_list in + let* args = list_size size eventval in + let* ret_val = eventval in + return (Events.Event_syscall (name, args, ret_val)) + +let event_vload = + let open QCheck.Gen in + let* mem_chunk = memory_chunk in + let* ident = ident in + let* ptr = ptrofs in + let* value = eventval in + return (Events.Event_vload (mem_chunk, ident, ptr, value)) + +let event_vstore = + let open QCheck.Gen in + let* mem_chunk = memory_chunk in + let* ident = ident in + let* ptr = ptrofs in + let* value = eventval in + return (Events.Event_vstore (mem_chunk, ident, ptr, value)) + +let event_annot size = + let open QCheck.Gen in + let* name = char_list in + let* values = list_size size eventval in + return (Events.Event_annot (name, values)) + +let event_call src_compartment trgt_compartment size = + let open QCheck.Gen in + let* ident = ident in + let* args = list_size size eventval in + return (Events.Event_call (src_compartment, trgt_compartment, ident, args)) + +let event_return src_compartment trgt_compartment = + let open QCheck.Gen in + let* ret_val = eventval in + return (Events.Event_return (src_compartment, trgt_compartment, ret_val)) + +(* TODO: also generate other mem_deltas *) +let mem_delta = QCheck.Gen.return [] + +(* QCheck generator for an event trace *) + +let trace rand_state = + let open QCheck.Gen in + (* ensure that no empty traces are generated *) + let size = small_nat rand_state + 1 in + let rec gen_trace_aux = function + | 0 -> [] + | n -> ( + let f = float_range 0.0 1.0 rand_state in + match f with + | _ when f < 0.6 -> + let n1, n2 = nat_split2 (n - 1) rand_state in + let src_compartment = compartment rand_state in + let trgt_compartment = compartment rand_state in + let arg_count = int_bound 5 in + let call = + [ + event_call src_compartment trgt_compartment arg_count rand_state; + ] + in + let between = gen_trace_aux n1 in + let ret = + [ event_return src_compartment trgt_compartment rand_state ] + in + let after = gen_trace_aux n2 in + List.concat [ call; between; ret; after ] + | _ when f < 0.7 -> + let arg_count = int_bound 5 in + event_syscall arg_count rand_state :: gen_trace_aux (n - 1) + | _ when f < 0.8 -> event_vload rand_state :: gen_trace_aux (n - 1) + | _ when f < 0.9 -> event_vstore rand_state :: gen_trace_aux (n - 1) + | _ -> + let size = int_bound 5 in + event_annot size rand_state :: gen_trace_aux (n - 1)) + in + gen_trace_aux size + +(* let ef_external = + let open QCheck.Gen in + let* compartment = compartment in + let* name = char_list in + let* signature = signature in + return (AST.EF_external (compartment, name, signature)) *) + +(* let ef_builtin = + let open QCheck.Gen in + let* compartment = compartment in + let* name = char_list in + let* signature = signature in + return (AST.EF_builtin (compartment, name, signature)) *) + +(* let ef_runtime = + let open QCheck.Gen in + let* compartment = compartment in + let* name = char_list in + let* signature = signature in + return (AST.EF_runtime (compartment, name, signature)) *) + +(* let ef_vload = + let open QCheck.Gen in + let* compartment = compartment in + let* memory_chunk = memory_chunk in + return (AST.EF_vload (compartment, memory_chunk)) *) + +(* let ef_vstore = + let open QCheck.Gen in + let* compartment = compartment in + let* memory_chunk = memory_chunk in + return (AST.EF_vload (compartment, memory_chunk)) *) + +(* let ef_malloc = QCheck.Gen.map (fun c -> AST.EF_malloc c) compartment *) +(* let ef_free = QCheck.Gen.map (fun c -> AST.EF_free c) compartment *) + +(* let ef_memcpy = + let open QCheck.Gen in + let* compartment = compartment in + let* z1 = coq_Z in + let* z2 = coq_Z in + return (AST.EF_memcpy (compartment, z1, z2)) *) + +(* let ef_annot = + let open QCheck.Gen in + let* compartment = compartment in + let* p = positive in + let* text = char_list in + let* type_list = list_size small_nat typ in + return (AST.EF_annot (compartment, p, text, type_list)) *) + +(* let ef_annot_val = + let open QCheck.Gen in + let* compartment = compartment in + let* p = positive in + let* text = char_list in + let* typ = typ in + return (AST.EF_annot_val (compartment, p, text, typ)) *) + +(* let ef_inline_asm = + let open QCheck.Gen in + let* compartment = compartment in + let* text = char_list in + let* signature = signature in + let* code = list_size small_nat char_list in + return (AST.EF_inline_asm (compartment, text, signature, code)) *) + +(* let ef_debug = + let open QCheck.Gen in + let* compartment = compartment in + let* p = positive in + let* ident = ident in + let* type_list = list_size small_nat typ in + return (AST.EF_debug (compartment, p, ident, type_list)) *) + +(* let external_function = + QCheck.Gen.frequency + [ + (1, ef_external); + (1, ef_builtin); + (1, ef_runtime); + (1, ef_vload); + (1, ef_vstore); + (1, ef_malloc); + (1, ef_free); + (1, ef_memcpy); + (1, ef_annot); + (1, ef_annot_val); + (1, ef_inline_asm); + (1, ef_debug); + ] *) + +(* let bundle_call = + let open QCheck.Gen in + let* trace = trace in + let* ident = ident in + let* args = list_size (int_bound 5) eventval in + let* sign = signature in + let* mem_delta = mem_delta in + return (BtInfoAsm.Bundle_call (trace, ident, args, sign, mem_delta)) *) + +(* let bundle_return = + let open QCheck.Gen in + let* trace = trace in + let* ret_val = eventval in + let* mem_delta = mem_delta in + return (BtInfoAsm.Bundle_return (trace, ret_val, mem_delta)) *) + +(* let bundle_builtin = + let open QCheck.Gen in + let* trace = trace in + let* ext_fun = external_function in + let* args = list_size (int_bound 5) eventval in + let* mem_delta = mem_delta in + return (BtInfoAsm.Bundle_builtin (trace, ext_fun, args, mem_delta)) *) + +(* let bundle_event = + QCheck.Gen.frequency + [ (1, bundle_call); (1, bundle_return); (1, bundle_builtin) ] *) +*) +let bundle_trace _ = QCheck.Gen.return [] +(* let open QCheck.Gen in + list_size small_nat (pair ident bundle_event) *) + +let build_prog_defs ctx = + let gvars = [] in + let raw_defs = Gen_ctx.def_list ctx in + let gfuns = + List.map + (fun (f, c, s) -> + let coq_func = + ({ fn_comp = AST.COMP.Comp (Camlcoq.P.of_int c); fn_sig = s; fn_code = [] } + : Asm.coq_function) + in + let fundef = AST.Internal coq_func in + (Camlcoq.P.of_int f, AST.Gfun fundef)) + raw_defs + in + gvars @ gfuns + +let build_prog_public ctx = + List.map Camlcoq.P.of_int (Gen_ctx.function_list ctx) + +let build_prog_main ctx = Camlcoq.P.of_int (Gen_ctx.main ctx) + +let build_prog_pol ctx = + let open Maps in + let policy_export = ref PTree.empty in + let exports = Gen_ctx.export_list ctx in + List.iter + (fun (raw_comp, raw_funcs) -> + let funcs = List.map Camlcoq.P.of_int raw_funcs in + let comp = Camlcoq.P.of_int raw_comp in + policy_export := PTree.set comp funcs !policy_export) + exports; + let policy_import = ref PTree.empty in + let imports = Gen_ctx.import_list ctx in + List.iter + (fun (comp, imps) -> + let imps = + List.map (fun (c, f) -> (AST.COMP.Comp (Camlcoq.P.of_int c), Camlcoq.P.of_int f)) imps + in + let comp = Camlcoq.P.of_int comp in + if imps <> [] then policy_import := PTree.set comp imps !policy_import + else ()) + imports; + let policy = + ({ policy_export = !policy_export; policy_import = !policy_import } + : AST.Policy.t) + in + policy + +let asm_program = + let open QCheck.Gen in + let config = + Gen_ctx. + { + num_compartments = 1; + num_exported_funcs = 1; + num_imported_funcs = 1; + max_arg_count = 1; + debug = true; + } + in + let* ctx = Gen_ctx.random config in + let prog_defs = build_prog_defs ctx in + let prog_public = build_prog_public ctx in + let prog_main = build_prog_main ctx in + let prog_pol = build_prog_pol ctx in + let asm_prog = + ({ prog_defs; prog_public; prog_main; prog_pol } : Asm.program) + in + return (asm_prog, ctx) diff --git a/test/backtranslation/Gen.mli b/test/backtranslation/Gen.mli new file mode 100644 index 0000000000..a9370ae70d --- /dev/null +++ b/test/backtranslation/Gen.mli @@ -0,0 +1,3 @@ +(*val trace : Events.event list QCheck.Gen.t *) +val bundle_trace : Gen_ctx.t -> BtInfoAsm.bundle_trace QCheck.Gen.t +val asm_program : (Asm.program * Gen_ctx.t) QCheck.Gen.t diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml new file mode 100644 index 0000000000..495e56b909 --- /dev/null +++ b/test/backtranslation/Gen_ctx.ml @@ -0,0 +1,145 @@ +module Map = Map.Make (Int) + +type exports = int list Map.t +type imports = (int * int) list Map.t +type func_sigs = AST.signature Map.t + +type t = { + exports : exports; + imports : imports; + func_sigs : func_sigs; + main : int; +} + +type gen_config = { + num_compartments : int; + num_exported_funcs : int; + num_imported_funcs : int; + max_arg_count : int; + debug : bool; +} + +type comp = int +type func = int + +let sample_typ = + QCheck.Gen.frequencyl + AST. + [ + (1, Tint); + (1, Tfloat); + (1, Tlong); + (1, Tsingle); + (1, Tany32); + (1, Tany64); + ] + +let sample_rettype = + let open QCheck.Gen in + let* f = float_range 0.0 1.0 in + if f < 1.0 /. 6.0 then map (fun t -> AST.Tret t) sample_typ + else + frequencyl + AST. + [ + (1, Tint8signed); + (1, Tint8unsigned); + (1, Tint16signed); + (1, Tint16unsigned); + (1, Tvoid); + ] + +let sample_calling_convention = + let open QCheck.Gen in + let* cc_vararg = option ~ratio:0.1 (map Camlcoq.Z.of_uint small_nat) in + let* cc_unproto = map (fun f -> f <= 0.1) (float_range 0.0 1.0) in + let* cc_structret = map (fun f -> f <= 0.1) (float_range 0.0 1.0) in + return ({ cc_vararg; cc_unproto; cc_structret } : AST.calling_convention) + +let sample_signature config = + let open QCheck.Gen in + let* arg_types = list_size (int_bound config.max_arg_count) sample_typ in + let* ret_type = sample_rettype in + let* cc = sample_calling_convention in + return AST.{ sig_args = arg_types; sig_res = ret_type; sig_cc = cc } + +let sample_exports config graph = + let open QCheck.Gen in + let compartments = Graph.vertices graph in + let n = Graph.size graph in + let pool = List.init (n * config.num_exported_funcs) succ in + let* funcs = Util.choose_disjoint n config.num_exported_funcs pool in + return (Map.of_seq (List.to_seq (List.combine compartments funcs))) + +let sample_imports graph exports rand_state = + let open QCheck.Gen in + let distribute (x, ys) = List.map (fun y -> (x, y)) ys in + let compartments = Graph.vertices graph in + let imports self = + compartments + |> List.filter (fun other -> Graph.is_adjacent self other graph) + (* int list *) + |> List.map (fun other -> (other, Map.find other exports)) + (* (int * int list) list*) + |> List.map (fun (other, funcs) -> (other, Util.sublist funcs rand_state)) + (* (int * int list) list *) + |> List.concat_map distribute + (* (int * int) list *) + in + Map.of_seq (List.to_seq (List.map (fun c -> (c, imports c)) compartments)) + +let sample_func_sigs config exports = + let open QCheck.Gen in + let compartments = List.map fst (Map.bindings exports) in + let* main_comp = oneofl compartments in + let* main = oneofl (Map.find main_comp exports) in + let all_funcs = List.concat_map snd (Map.bindings exports) in + let num_funcs = List.length all_funcs in + let* sigs = list_repeat num_funcs (sample_signature config) in + let sig_map = Map.of_seq (List.to_seq (List.combine all_funcs sigs)) in + let main_sig = + AST.{ sig_args = []; sig_res = Tret Tint; sig_cc = cc_default } + in + return (main, Map.add main main_sig sig_map) + +let dump_exports exports = + print_endline "Exports:"; + Map.iter + (fun comp funcs -> + Printf.printf "%d -> [%s]\n" comp + (String.concat ", " (List.map string_of_int funcs))) + exports + +let dump_imports imports = + let fmt = Printf.sprintf in + print_endline "Imports:"; + Map.iter + (fun self imps -> + Printf.printf "%d <- [%s]\n" self + (String.concat ", " (List.map (fun (c, f) -> fmt "%d.%d" c f) imps))) + imports + +let random config = + let open QCheck.Gen in + let* graph = Graph.random config.num_compartments in + let* exports = sample_exports config graph in + let* imports = sample_imports graph exports in + let* main, func_sigs = sample_func_sigs config exports in + if config.debug then ( + Graph.dump graph; + dump_exports exports; + dump_imports imports) + else (); + return { exports; imports; func_sigs; main } + +let main ctx = ctx.main +let function_list ctx = List.concat_map snd (Map.bindings ctx.exports) +let compartment_list ctx = List.map fst (Map.bindings ctx.imports) +let export_list ctx = Map.bindings ctx.exports +let import_list ctx = Map.bindings ctx.imports + +let def_list ctx = + let sig_of f = Map.find f ctx.func_sigs in + List.concat_map + (fun (c, fs) -> List.map (fun f -> (f, c, sig_of f)) fs) + (export_list ctx) diff --git a/test/backtranslation/Gen_ctx.mli b/test/backtranslation/Gen_ctx.mli new file mode 100644 index 0000000000..5aa78bac42 --- /dev/null +++ b/test/backtranslation/Gen_ctx.mli @@ -0,0 +1,22 @@ +type exports +type imports +type t + +type gen_config = { + num_compartments : int; + num_exported_funcs : int; + num_imported_funcs : int; + max_arg_count : int; + debug : bool; +} + +type comp = int +type func = int + +val random : gen_config -> Random.State.t -> t +val main : t -> func +val function_list : t -> func list +val compartment_list : t -> comp list +val export_list : t -> (comp * func list) list +val import_list : t -> (comp * (comp * func) list) list +val def_list : t -> (func * comp * AST.signature) list diff --git a/test/backtranslation/Graph.ml b/test/backtranslation/Graph.ml new file mode 100644 index 0000000000..8f9c4201cd --- /dev/null +++ b/test/backtranslation/Graph.ml @@ -0,0 +1,108 @@ +type t = (int * int list) list + +let gen_graph max_size rand_state : (int * int) list = + let open QCheck.Gen in + let n = int_bound max_size rand_state + 1 in + let adjacency = Array.make_matrix n n 0 in + for i = 0 to n - 1 do + let row = int_bound (n - 1) rand_state in + let col = int_bound (n - 1) rand_state in + let () = adjacency.(row).(col) <- 1 in + let () = adjacency.(col).(row) <- 1 in + () + done; + let result = ref [] in + for row = 0 to n - 1 do + for col = 0 to n - 1 do + if adjacency.(row).(col) <> 0 then + result := (Int.min row col, Int.max row col) :: !result + else () + done + done; + let compare (x1, x2) (y1, y2) = + if Int.compare x1 y1 = 0 then Int.compare x2 y2 else Int.compare x1 y1 + in + List.sort_uniq compare !result + +let normalize edge_list : (int * int) list = + let vertices = + List.sort_uniq Int.compare (List.map fst edge_list @ List.map snd edge_list) + in + let new_idcs = List.mapi (fun idx elt -> (elt, idx + 1)) vertices in + List.map + (fun (src, trgt) -> (List.assoc src new_idcs, List.assoc trgt new_idcs)) + edge_list + +let scc edge_list : (int * int) list = + match edge_list with + | [] -> [] + | (root, _) :: es -> + let did_update = ref true in + let reachable = ref [ root ] in + while !did_update do + did_update := false; + for i = 0 to List.length edge_list - 1 do + let src, trgt = List.nth edge_list i in + if List.mem src !reachable && not (List.mem trgt !reachable) then ( + reachable := trgt :: !reachable; + did_update := true) + else if List.mem trgt !reachable && not (List.mem src !reachable) then ( + reachable := src :: !reachable; + did_update := true) + else () + done + done; + List.filter + (fun (src, trgt) -> + List.exists (fun n -> n = src || n = trgt) !reachable) + edge_list + +let convert_graph edge_list = + let vertices = + List.sort_uniq Int.compare (List.map fst edge_list @ List.map snd edge_list) + in + let neighbors v = + List.sort_uniq Int.compare + (List.filter_map + (fun (w1, w2) -> + if w1 = v && not (w2 = v) then Option.some w2 + else if (not (w1 = v)) && w2 = v then Option.some w1 + else Option.none) + edge_list) + in + List.map (fun v -> (v, neighbors v)) vertices + +let random size rand_state = + rand_state |> gen_graph size |> scc |> normalize |> convert_graph + +let size = List.length +let vertices = List.map fst + +let is_adjacent self other graph = + match List.assoc_opt self graph with + | None -> false + | Some neighbors -> List.mem other neighbors + +let to_dot adj_list = + let fmt = Printf.sprintf in + let edges = + List.concat_map + (fun (src, trgts) -> + List.map (fun t -> if src < t then (src, t) else (t, src)) trgts) + adj_list + in + let compare (x1, y1) (x2, y2) = + if Int.compare x1 x2 = 0 then Int.compare y1 y2 else Int.compare x1 x2 + in + let edges = List.sort_uniq compare edges in + let string_of_edge (src, trgt) = fmt " %d -- %d;" src trgt in + let string_of_vertex v = fmt " %d;" v in + fmt "graph {\n%s\n%s\n}" + (String.concat "\n" (List.map string_of_vertex (vertices adj_list))) + (String.concat "\n" (List.map string_of_edge edges)) + +let dump graph = + Out_channel.with_open_text "graph.dot" (fun f -> + output_string f (to_dot graph)); + let _ = Unix.system "dot -Tpng graph.dot > graph.png" in + print_endline "Generated graph.png" diff --git a/test/backtranslation/Graph.mli b/test/backtranslation/Graph.mli new file mode 100644 index 0000000000..684957ce11 --- /dev/null +++ b/test/backtranslation/Graph.mli @@ -0,0 +1,8 @@ +type t + +val random : int -> Random.State.t -> t +val size : t -> int +val vertices : t -> int list +val is_adjacent : int -> int -> t -> bool +val to_dot : t -> string +val dump : t -> unit diff --git a/test/backtranslation/Makefile b/test/backtranslation/Makefile new file mode 100644 index 0000000000..9d90f1d53e --- /dev/null +++ b/test/backtranslation/Makefile @@ -0,0 +1,44 @@ +DIRS=../../extraction \ + ../../lib \ + ../../common \ + ../../backend \ + ../../cfrontend \ + ../../cparser \ + ../../driver \ + ../../export \ + ../../debug \ + ../../riscV + +INCLUDES=$(patsubst %,-I %,$(DIRS)) + +LIBS=str.cmxa + +MAIN_OBJS:=$(shell ../../tools/modorder .depend test_backtranslation.cmx) + +test_backtranslation: $(MAIN_OBJS) + ocamlfind ocamlopt -package qcheck,menhirLib -linkpkg $(INCLUDES) -o test_backtranslation $(LIBS) $+ + +test_backtranslation.byte: $(MAIN_OBJS:.cmx=.cmo) + ocamlfind ocamlc -g -package qcheck,menhirLib -linkpkg $(INCLUDES) -o test_backtranslation.byte $(LIBS:.cmxa=.cma) $+ + +%.cmi: %.mli + ocamlfind ocamlc -package qcheck,menhirLib -linkpkg $(INCLUDES) -c $< + +%.cmo: %.ml + ocamlfind ocamlc -g -package qcheck,menhirLib -linkpkg $(INCLUDES) -c $< + +%.cmx: %.ml + ocamlfind ocamlopt -package qcheck,menhirLib -linkpkg $(INCLUDES) -c $< + +depend: + ocamlfind ocamldep $(INCLUDES) *.mli *.ml > .depend + ocamlfind ocamldep $(INCLUDES) $(foreach d,$(DIRS),$(wildcard $(d)/*.ml)) >> .depend + ocamlfind ocamldep $(INCLUDES) $(foreach d,$(DIRS),$(wildcard $(d)/*.mli)) >> .depend + +include .depend + +clean: + -rm -f *.cm[ixo] + -rm -f *.o + -rm test_backtranslation + -rm test_backtranslation.byte \ No newline at end of file diff --git a/test/backtranslation/Util.ml b/test/backtranslation/Util.ml new file mode 100644 index 0000000000..8fb841d191 --- /dev/null +++ b/test/backtranslation/Util.ml @@ -0,0 +1,23 @@ +let choose_disjoint n k xs rand_state = + let open QCheck.Gen in + let take n l = List.of_seq (Seq.take n (List.to_seq l)) in + let drop n l = List.of_seq (Seq.drop n (List.to_seq l)) in + let pool = ref xs in + List.init n (fun _ -> + let n = int_bound (k - 1) rand_state + 1 in + let ns = take n !pool in + pool := drop n !pool; + ns) + +let sublist list = + match list with + | [] -> failwith "Cannot sample non-empty subset of empty set" + | [ x ] -> fun _ -> [ x ] + | xs -> + let open QCheck.Gen in + let len = List.length xs in + let* len_sublist = map succ (int_bound (len - 1)) in + (* len sublist is random in [1,len] *) + let* shuffled_list = shuffle_l xs in + shuffled_list |> List.to_seq |> Seq.take len_sublist |> List.of_seq + |> return diff --git a/test/backtranslation/Util.mli b/test/backtranslation/Util.mli new file mode 100644 index 0000000000..b39c5df11c --- /dev/null +++ b/test/backtranslation/Util.mli @@ -0,0 +1,5 @@ +val choose_disjoint : int -> int -> 'a list -> 'a list list QCheck.Gen.t +(* Sample n disjoint, non-empty subsets of size at most k from xs *) + +val sublist : 'a list -> 'a list QCheck.Gen.t +(* Sample a non-empty subset from a given list *) diff --git a/test/backtranslation/compcert.ini b/test/backtranslation/compcert.ini new file mode 100644 index 0000000000..67f60ca3c0 --- /dev/null +++ b/test/backtranslation/compcert.ini @@ -0,0 +1,16 @@ +stdlib_path=/usr/local/lib/compcert +prepro=riscv64-linux-gnu-gcc +linker=riscv64-linux-gnu-gcc +asm=riscv64-linux-gnu-gcc +prepro_options=-march=rv64imafd -mabi=lp64d -U__GNUC__ -E +asm_options=-march=rv64imafd -mabi=lp64d -c +linker_options=-march=rv64imafd -mabi=lp64d -no-pie +arch=riscV +model=64 +abi=standard +endianness=little +system=linux +has_runtime_lib=true +has_standard_headers=true +asm_supports_cfi=true +response_file_style=gnu diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml new file mode 100644 index 0000000000..79a5513b8c --- /dev/null +++ b/test/backtranslation/test_backtranslation.ml @@ -0,0 +1,93 @@ +(* Format failing test cases for output *) +let print_ident i = Printf.sprintf "%d" (Camlcoq.P.to_int i) + +let print_event e = + ignore (Format.flush_str_formatter ()); + Interp.print_event Format.str_formatter e; + " " ^ Format.flush_str_formatter () + +let print_trace t = + Printf.sprintf "[\n%s\n ]" (String.concat "\n" (List.map print_event t)) + +let print_eventval_list el = + ignore (Format.flush_str_formatter ()); + Interp.print_eventval_list Format.str_formatter el; + " " ^ Format.flush_str_formatter () + +let print_bundle_event e = + let open BtInfoAsm in + let fmt = Printf.sprintf in + match e with + | id, Bundle_call (trace, ident, args, sign, mem_delta) -> + fmt "%s:\n %s\n %s\n %s" (print_ident id) (print_trace trace) + (print_ident ident) (print_eventval_list args) + | id, Bundle_return (trace, ret_val, mem_delta) -> "bundle return" + | id, Bundle_builtin (trace, ext_fun, args, mem_delta) -> "bundle builtin" + +let print_bundle_trace _ = "printing not implemented" +(* String.concat "\n" (List.map print_bundle_event t) *) + +let print_c_light_program prog = + let version = PrintClight.Clight1 in + ignore (Format.flush_str_formatter ()); + PrintClight.print_program version Format.str_formatter prog; + print_endline (Format.flush_str_formatter ()) + +let print_compiler_errors errors = + let open Errors in + let fmt = Printf.printf in + List.iter + (fun e -> + match e with + | CTX p | POS p -> fmt "%d" (Camlcoq.P.to_int p) + | MSG chars -> List.iter (fun c -> fmt "%c" c) chars) + errors + +(* Run QCheck testing *) + +let property_under_test asm_prog bundled_trace = + let src_program = Backtranslation.gen_program bundled_trace asm_prog in + let () = print_c_light_program src_program in + Frontend.init (); + Debug.init_compile_unit "autogenerated by backtranslation"; + Sections.initialize(); + CPragmas.reset(); + (* TODO: Bring compiler in same global state as it would be after C2C.convertProgram *) + (* - add all functions from C2C.helper_functions to the src_program.prog_defs and src_program.prog_public *) + (* - the above tasks seems impossible: compiler error indicates name of function whereas the src_program has no function names anymore??? *) + (* - actually, we need to intern the strings and everything *) + (* - perhaps it would just be easier to "lift" clight to C again, dump it as a file and then trigger the entire compilation again? *) + match Compiler.transf_clight_program src_program with + | Errors.Error error_list -> + print_compiler_errors error_list; + false + | Errors.OK _ -> true + +let bundle_trace ctx = + QCheck.make ~print:print_bundle_trace (Gen.bundle_trace ctx) + +let test_backtranslation asm_prog ctx = + QCheck.Test.make ~count:1 ~name:"backtranslation" (bundle_trace ctx) + (property_under_test asm_prog) + +let _ = + let () = Random.self_init () in + let rand_state = Random.get_state () in + let asm_prog, ctx = Gen.asm_program rand_state in + let () = PrintAsm.print_program_asm Out_channel.stdout asm_prog in + QCheck_runner.run_tests [ test_backtranslation asm_prog ctx ] + +let () = + let sourcename = "fib.c" in + let ifile = "../c/fib.c" in + let ifile' = Driveraux.tmp_file ".p" in + let () = Frontend.init () in + let () = Frontend.preprocess ifile ifile' in + let csyntax = Frontend.parse_c_file sourcename ifile' in + match + Compiler.apply_partial + (Compiler.transf_c_program csyntax) + Asmexpand.expand_program + with + | Errors.OK _ -> print_endline "ok" + | Errors.Error errors -> print_compiler_errors errors; print_newline () From 4e9bb22ea9f9767f3abf4b187de1a069d07c90a6 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Thu, 7 Dec 2023 13:51:21 +0100 Subject: [PATCH 24/83] Update extraction to fix build issues --- extraction/extraction.v | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extraction/extraction.v b/extraction/extraction.v index 3466985353..d2ed1897d1 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -35,6 +35,8 @@ Require Clight. Require Compiler. Require Parser. Require Initializers. +(* Backtranslation *) +Require Backtranslation. (* Standard lib *) Require Import ExtrOcamlBasic. @@ -176,4 +178,7 @@ Separate Extraction AST.signature_main Floats.Float32.from_parsed Floats.Float.from_parsed Globalenvs.Senv.invert_symbol - Parser.translation_unit_file. + Parser.translation_unit_file + (* Back-translation code *) + Backtranslation.gen_program + Values.Vnullptr. From bf394cba649ff530dcca1be7e93886dc9eff5aab Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Thu, 7 Dec 2023 14:22:05 +0100 Subject: [PATCH 25/83] Dump clight to file and compile entire file --- test/backtranslation/.gitignore | 5 +- test/backtranslation/test_backtranslation.ml | 52 +++++++++----------- 2 files changed, 27 insertions(+), 30 deletions(-) diff --git a/test/backtranslation/.gitignore b/test/backtranslation/.gitignore index d09cfc755b..41fcdc4ac2 100644 --- a/test/backtranslation/.gitignore +++ b/test/backtranslation/.gitignore @@ -36,4 +36,7 @@ test_backtranslation # Ignore generated visualizations of graphs *.dot -*.png \ No newline at end of file +*.png + +# Ignore backtranslated code +out.c_light diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 79a5513b8c..e3a1a2b161 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -43,25 +43,34 @@ let print_compiler_errors errors = | MSG chars -> List.iter (fun c -> fmt "%c" c) chars) errors +let export_c_light_program prog file_name = + let version = PrintClight.Clight1 in + let code = + ignore (Format.flush_str_formatter ()); + PrintClight.print_program version Format.str_formatter prog; + Format.flush_str_formatter () in + let regex = Str.regexp "\\$\\([0-9]+\\)" in + let clean_code = Str.global_replace regex "ident_\\1" code in + Out_channel.with_open_text file_name (fun c -> output_string c clean_code) + (* Run QCheck testing *) let property_under_test asm_prog bundled_trace = + let source_name = "out.c_light" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in - let () = print_c_light_program src_program in - Frontend.init (); - Debug.init_compile_unit "autogenerated by backtranslation"; - Sections.initialize(); - CPragmas.reset(); - (* TODO: Bring compiler in same global state as it would be after C2C.convertProgram *) - (* - add all functions from C2C.helper_functions to the src_program.prog_defs and src_program.prog_public *) - (* - the above tasks seems impossible: compiler error indicates name of function whereas the src_program has no function names anymore??? *) - (* - actually, we need to intern the strings and everything *) - (* - perhaps it would just be easier to "lift" clight to C again, dump it as a file and then trigger the entire compilation again? *) - match Compiler.transf_clight_program src_program with - | Errors.Error error_list -> - print_compiler_errors error_list; - false + let () = export_c_light_program src_program source_name in + let ifile = "./" ^ source_name in + let ifile' = Driveraux.tmp_file ".p" in + let () = Frontend.init () in + let () = Frontend.preprocess ifile ifile' in + let csyntax = Frontend.parse_c_file source_name ifile' in + match + Compiler.apply_partial + (Compiler.transf_c_program csyntax) + Asmexpand.expand_program + with | Errors.OK _ -> true + | Errors.Error errors -> print_compiler_errors errors; print_newline (); false let bundle_trace ctx = QCheck.make ~print:print_bundle_trace (Gen.bundle_trace ctx) @@ -76,18 +85,3 @@ let _ = let asm_prog, ctx = Gen.asm_program rand_state in let () = PrintAsm.print_program_asm Out_channel.stdout asm_prog in QCheck_runner.run_tests [ test_backtranslation asm_prog ctx ] - -let () = - let sourcename = "fib.c" in - let ifile = "../c/fib.c" in - let ifile' = Driveraux.tmp_file ".p" in - let () = Frontend.init () in - let () = Frontend.preprocess ifile ifile' in - let csyntax = Frontend.parse_c_file sourcename ifile' in - match - Compiler.apply_partial - (Compiler.transf_c_program csyntax) - Asmexpand.expand_program - with - | Errors.OK _ -> print_endline "ok" - | Errors.Error errors -> print_compiler_errors errors; print_newline () From 26843d8a45556f2865f8895fa3afe3250d32dd12 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Thu, 7 Dec 2023 16:02:25 +0100 Subject: [PATCH 26/83] Make sure that main function has correct name --- test/backtranslation/test_backtranslation.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index e3a1a2b161..011f431c75 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -43,14 +43,16 @@ let print_compiler_errors errors = | MSG chars -> List.iter (fun c -> fmt "%c" c) chars) errors -let export_c_light_program prog file_name = +let export_c_light_program prog main file_name = let version = PrintClight.Clight1 in let code = ignore (Format.flush_str_formatter ()); PrintClight.print_program version Format.str_formatter prog; Format.flush_str_formatter () in + let regex_main = Str.regexp ("\\$" ^ string_of_int main ^ "(") in + let code_with_main = Str.global_replace regex_main "main(" code in let regex = Str.regexp "\\$\\([0-9]+\\)" in - let clean_code = Str.global_replace regex "ident_\\1" code in + let clean_code = Str.global_replace regex "ident_\\1" code_with_main in Out_channel.with_open_text file_name (fun c -> output_string c clean_code) (* Run QCheck testing *) @@ -58,7 +60,8 @@ let export_c_light_program prog file_name = let property_under_test asm_prog bundled_trace = let source_name = "out.c_light" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in - let () = export_c_light_program src_program source_name in + let main = Camlcoq.P.to_int asm_prog.prog_main in + let () = export_c_light_program src_program main source_name in let ifile = "./" ^ source_name in let ifile' = Driveraux.tmp_file ".p" in let () = Frontend.init () in From a13a04a9fc4d84c3190c0a9ca9b3270bc0cafdb3 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 8 Dec 2023 10:19:42 +0100 Subject: [PATCH 27/83] Generate and test larger ASM program skeletons (it fails) --- test/backtranslation/.gitignore | 4 +++- test/backtranslation/Gen.ml | 8 ++++---- test/backtranslation/test_backtranslation.ml | 3 ++- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/test/backtranslation/.gitignore b/test/backtranslation/.gitignore index 41fcdc4ac2..d0d5d153d3 100644 --- a/test/backtranslation/.gitignore +++ b/test/backtranslation/.gitignore @@ -39,4 +39,6 @@ test_backtranslation *.png # Ignore backtranslated code -out.c_light +out.c +out.c.raw +a.out diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index 3977993cc7..de039003e5 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -303,10 +303,10 @@ let asm_program = let config = Gen_ctx. { - num_compartments = 1; - num_exported_funcs = 1; - num_imported_funcs = 1; - max_arg_count = 1; + num_compartments = 5; + num_exported_funcs = 15; + num_imported_funcs = 5; + max_arg_count = 5; debug = true; } in diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 011f431c75..4867a4b450 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -49,6 +49,7 @@ let export_c_light_program prog main file_name = ignore (Format.flush_str_formatter ()); PrintClight.print_program version Format.str_formatter prog; Format.flush_str_formatter () in + Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c code); let regex_main = Str.regexp ("\\$" ^ string_of_int main ^ "(") in let code_with_main = Str.global_replace regex_main "main(" code in let regex = Str.regexp "\\$\\([0-9]+\\)" in @@ -58,7 +59,7 @@ let export_c_light_program prog main file_name = (* Run QCheck testing *) let property_under_test asm_prog bundled_trace = - let source_name = "out.c_light" in + let source_name = "out.c" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in let main = Camlcoq.P.to_int asm_prog.prog_main in let () = export_c_light_program src_program main source_name in From 6bb2d8a0a88f6cb8078d5a8c766c8a7bc85f8a4e Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 8 Dec 2023 10:43:38 +0100 Subject: [PATCH 28/83] Only allow var_args in calling convention if at least one argument is present --- test/backtranslation/Gen_ctx.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index 495e56b909..10c8f2c579 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -49,9 +49,12 @@ let sample_rettype = (1, Tvoid); ] -let sample_calling_convention = +let sample_calling_convention allow_vararg = let open QCheck.Gen in - let* cc_vararg = option ~ratio:0.1 (map Camlcoq.Z.of_uint small_nat) in + let* cc_vararg = + if allow_vararg + then option ~ratio:0.1 (map Camlcoq.Z.of_uint small_nat) + else return Option.none in let* cc_unproto = map (fun f -> f <= 0.1) (float_range 0.0 1.0) in let* cc_structret = map (fun f -> f <= 0.1) (float_range 0.0 1.0) in return ({ cc_vararg; cc_unproto; cc_structret } : AST.calling_convention) @@ -60,7 +63,7 @@ let sample_signature config = let open QCheck.Gen in let* arg_types = list_size (int_bound config.max_arg_count) sample_typ in let* ret_type = sample_rettype in - let* cc = sample_calling_convention in + let* cc = sample_calling_convention (List.length arg_types > 0) in return AST.{ sig_args = arg_types; sig_res = ret_type; sig_cc = cc } let sample_exports config graph = From 38eecfa94043950d1be93f5b730576be5246e5ad Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 8 Dec 2023 15:01:45 +0100 Subject: [PATCH 29/83] Use subprocess to compile dumped C code to ensure correct usage and setup --- test/backtranslation/Gen.ml | 8 ++++---- test/backtranslation/test_backtranslation.ml | 21 +++++++------------- 2 files changed, 11 insertions(+), 18 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index de039003e5..c4676f38a0 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -303,10 +303,10 @@ let asm_program = let config = Gen_ctx. { - num_compartments = 5; - num_exported_funcs = 15; - num_imported_funcs = 5; - max_arg_count = 5; + num_compartments = 3; + num_exported_funcs = 5; + num_imported_funcs = 3; + max_arg_count = 2; debug = true; } in diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 4867a4b450..fbb11d1d51 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -60,32 +60,25 @@ let export_c_light_program prog main file_name = let property_under_test asm_prog bundled_trace = let source_name = "out.c" in + let ccomp_cmd = "../../ccomp -quiet" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in let main = Camlcoq.P.to_int asm_prog.prog_main in let () = export_c_light_program src_program main source_name in - let ifile = "./" ^ source_name in - let ifile' = Driveraux.tmp_file ".p" in - let () = Frontend.init () in - let () = Frontend.preprocess ifile ifile' in - let csyntax = Frontend.parse_c_file source_name ifile' in - match - Compiler.apply_partial - (Compiler.transf_c_program csyntax) - Asmexpand.expand_program - with - | Errors.OK _ -> true - | Errors.Error errors -> print_compiler_errors errors; print_newline (); false + let status = Unix.system (ccomp_cmd ^ " " ^ source_name) in + match status with + | WEXITED code -> code = 0 + | WSIGNALED _ | WSTOPPED _ -> false let bundle_trace ctx = QCheck.make ~print:print_bundle_trace (Gen.bundle_trace ctx) let test_backtranslation asm_prog ctx = - QCheck.Test.make ~count:1 ~name:"backtranslation" (bundle_trace ctx) + QCheck.Test.make ~count:10 ~name:"backtranslation" (bundle_trace ctx) (property_under_test asm_prog) let _ = let () = Random.self_init () in let rand_state = Random.get_state () in let asm_prog, ctx = Gen.asm_program rand_state in - let () = PrintAsm.print_program_asm Out_channel.stdout asm_prog in + (*let () = PrintAsm.print_program_asm Out_channel.stdout asm_prog in*) QCheck_runner.run_tests [ test_backtranslation asm_prog ctx ] From 81f538ffe89b77e242800732fb44c7b5e8af0716 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 8 Dec 2023 15:07:14 +0100 Subject: [PATCH 30/83] Move printing functions to new module --- test/backtranslation/Print.ml | 44 ++++++++++++++++++ test/backtranslation/test_backtranslation.ml | 49 +------------------- 2 files changed, 46 insertions(+), 47 deletions(-) create mode 100644 test/backtranslation/Print.ml diff --git a/test/backtranslation/Print.ml b/test/backtranslation/Print.ml new file mode 100644 index 0000000000..f99e6bc065 --- /dev/null +++ b/test/backtranslation/Print.ml @@ -0,0 +1,44 @@ +(* Format failing test cases for output *) +let print_ident i = Printf.sprintf "%d" (Camlcoq.P.to_int i) + +let print_event e = + ignore (Format.flush_str_formatter ()); + Interp.print_event Format.str_formatter e; + " " ^ Format.flush_str_formatter () + +let print_trace t = + Printf.sprintf "[\n%s\n ]" (String.concat "\n" (List.map print_event t)) + +let print_eventval_list el = + ignore (Format.flush_str_formatter ()); + Interp.print_eventval_list Format.str_formatter el; + " " ^ Format.flush_str_formatter () + +let print_bundle_event e = + let open BtInfoAsm in + let fmt = Printf.sprintf in + match e with + | id, Bundle_call (trace, ident, args, sign, mem_delta) -> + fmt "%s:\n %s\n %s\n %s" (print_ident id) (print_trace trace) + (print_ident ident) (print_eventval_list args) + | id, Bundle_return (trace, ret_val, mem_delta) -> "bundle return" + | id, Bundle_builtin (trace, ext_fun, args, mem_delta) -> "bundle builtin" + +let print_bundle_trace _ = "printing not implemented" +(* String.concat "\n" (List.map print_bundle_event t) *) + +let print_c_light_program prog = + let version = PrintClight.Clight1 in + ignore (Format.flush_str_formatter ()); + PrintClight.print_program version Format.str_formatter prog; + print_endline (Format.flush_str_formatter ()) + +let print_compiler_errors errors = + let open Errors in + let fmt = Printf.printf in + List.iter + (fun e -> + match e with + | CTX p | POS p -> fmt "%d" (Camlcoq.P.to_int p) + | MSG chars -> List.iter (fun c -> fmt "%c" c) chars) + errors diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index fbb11d1d51..6d357787d0 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -1,48 +1,3 @@ -(* Format failing test cases for output *) -let print_ident i = Printf.sprintf "%d" (Camlcoq.P.to_int i) - -let print_event e = - ignore (Format.flush_str_formatter ()); - Interp.print_event Format.str_formatter e; - " " ^ Format.flush_str_formatter () - -let print_trace t = - Printf.sprintf "[\n%s\n ]" (String.concat "\n" (List.map print_event t)) - -let print_eventval_list el = - ignore (Format.flush_str_formatter ()); - Interp.print_eventval_list Format.str_formatter el; - " " ^ Format.flush_str_formatter () - -let print_bundle_event e = - let open BtInfoAsm in - let fmt = Printf.sprintf in - match e with - | id, Bundle_call (trace, ident, args, sign, mem_delta) -> - fmt "%s:\n %s\n %s\n %s" (print_ident id) (print_trace trace) - (print_ident ident) (print_eventval_list args) - | id, Bundle_return (trace, ret_val, mem_delta) -> "bundle return" - | id, Bundle_builtin (trace, ext_fun, args, mem_delta) -> "bundle builtin" - -let print_bundle_trace _ = "printing not implemented" -(* String.concat "\n" (List.map print_bundle_event t) *) - -let print_c_light_program prog = - let version = PrintClight.Clight1 in - ignore (Format.flush_str_formatter ()); - PrintClight.print_program version Format.str_formatter prog; - print_endline (Format.flush_str_formatter ()) - -let print_compiler_errors errors = - let open Errors in - let fmt = Printf.printf in - List.iter - (fun e -> - match e with - | CTX p | POS p -> fmt "%d" (Camlcoq.P.to_int p) - | MSG chars -> List.iter (fun c -> fmt "%c" c) chars) - errors - let export_c_light_program prog main file_name = let version = PrintClight.Clight1 in let code = @@ -60,7 +15,7 @@ let export_c_light_program prog main file_name = let property_under_test asm_prog bundled_trace = let source_name = "out.c" in - let ccomp_cmd = "../../ccomp -quiet" in + let ccomp_cmd = "../../ccomp -quiet > /dev/null" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in let main = Camlcoq.P.to_int asm_prog.prog_main in let () = export_c_light_program src_program main source_name in @@ -70,7 +25,7 @@ let property_under_test asm_prog bundled_trace = | WSIGNALED _ | WSTOPPED _ -> false let bundle_trace ctx = - QCheck.make ~print:print_bundle_trace (Gen.bundle_trace ctx) + QCheck.make ~print:Print.print_bundle_trace (Gen.bundle_trace ctx) let test_backtranslation asm_prog ctx = QCheck.Test.make ~count:10 ~name:"backtranslation" (bundle_trace ctx) From d1e791869ee52583d1d5e1cc1807a7dab7ba40cb Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 8 Dec 2023 17:35:12 +0100 Subject: [PATCH 31/83] Improve Makefile --- test/backtranslation/Makefile | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/backtranslation/Makefile b/test/backtranslation/Makefile index 9d90f1d53e..74ea974f08 100644 --- a/test/backtranslation/Makefile +++ b/test/backtranslation/Makefile @@ -38,7 +38,7 @@ depend: include .depend clean: - -rm -f *.cm[ixo] - -rm -f *.o - -rm test_backtranslation - -rm test_backtranslation.byte \ No newline at end of file + -@rm -f *.cm[ixo] 2>/dev/null || true + -@rm -f *.o 2>/dev/null || true + -@rm test_backtranslation 2>/dev/null || true + -@rm test_backtranslation.byte 2>/dev/null || true From a09a862953d426c89ed883eafa43713c1ee7478a Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 8 Dec 2023 17:36:25 +0100 Subject: [PATCH 32/83] Generate non-empty bundle-traces for backtranslation (tests fail) --- test/backtranslation/Gen.ml | 77 ++++++++++++++++++-- test/backtranslation/Print.ml | 22 +++--- test/backtranslation/test_backtranslation.ml | 3 +- 3 files changed, 87 insertions(+), 15 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index c4676f38a0..de9a8fe185 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -13,6 +13,7 @@ (1, Many32); (1, Many64); ] +*) let positive = QCheck.Gen.(map (fun i -> Camlcoq.P.of_int (i + 1)) small_nat) let coq_Z = QCheck.Gen.(map (fun i -> Camlcoq.Z.of_sint i) small_signed_int) @@ -32,6 +33,7 @@ let binary_float = in frequency [ (1, zero); (1, infinity); (1, nan); (1, finite) ] +(* let eventval = let open QCheck.Gen in let open Events in @@ -242,13 +244,78 @@ let trace rand_state = let* mem_delta = mem_delta in return (BtInfoAsm.Bundle_builtin (trace, ext_fun, args, mem_delta)) *) -(* let bundle_event = +let bundle_event = QCheck.Gen.frequency - [ (1, bundle_call); (1, bundle_return); (1, bundle_builtin) ] *) + [ (1, bundle_call); (1, bundle_return); (1, bundle_builtin) ] *) -let bundle_trace _ = QCheck.Gen.return [] -(* let open QCheck.Gen in - list_size small_nat (pair ident bundle_event) *) + +(* TODO: perhaps differentiate between signed/unsigned and positive/negative values? *) +let ev_int = QCheck.Gen.map (fun i -> Events.EVint i) coq_Z +let ev_float = QCheck.Gen.map (fun f -> Events.EVfloat f) binary_float +let ev_long = QCheck.Gen.map (fun l -> Events.EVlong l) coq_Z +let ev_single = QCheck.Gen.map (fun f -> Events.EVfloat f) binary_float + +let value_of_typ t = + let open QCheck.Gen in + let open AST in + match t with + | Tint -> ev_int + | Tfloat -> ev_float + | Tlong -> ev_long + | Tsingle -> ev_single + (* TODO: are ev_int and ev_long the correct values for these *) + | Tany32 -> ev_int + | Tany64 -> ev_long + +let args_for_sig sign rand_state = + List.map (fun t -> value_of_typ t rand_state) sign.AST.sig_args + +let ret_val_for_sig sign = + let open AST in + (* TODO: implement me properly *) + match sign.sig_res with + | Tint8signed -> ev_int + | Tint8unsigned -> ev_int + | Tint16signed -> ev_int + | Tint16unsigned -> ev_int + (* TODO: what is actually a valid value of type void? *) + | Tvoid -> ev_int + | Tret t -> value_of_typ t + +let bundle_trace ctx rand_state = + let open QCheck.Gen in + let size = small_nat rand_state in + let rec bundle_trace_aux curr_comp = function + | 0 -> [] + | n -> ( + let pool = ctx + |> Gen_ctx.import_list + |> List.assoc curr_comp in + match pool with + | [] -> [] (* there is no imported function we could possibly call => end trace *) + | _ -> + let trgt_comp, trgt_func = oneofl pool rand_state in + let sign = (match + (List.find_map + (fun (f, c, s) -> + if f = trgt_func && c = trgt_comp then Option.some s else Option.none) + (Gen_ctx.def_list ctx)) with + | Option.None -> failwith "Cannot lookup signature for imported function" + | Option.Some s -> s) in + let args = args_for_sig sign rand_state in + let ret_val = ret_val_for_sig sign rand_state in + let subtrace_call = [] in + let subtrace_ret = [] in + let mdelta_call = [] in + let mdelta_ret = [] in + let call = BtInfoAsm.Bundle_call (subtrace_call, Camlcoq.P.of_int trgt_func, args, sign, mdelta_call) in + let ret = BtInfoAsm.Bundle_return (subtrace_ret, ret_val, mdelta_ret) in + let between = bundle_trace_aux trgt_comp (n-1) in + List.concat [[call]; between; [ret]] + ) + in + let main_comp = 1 in (* TODO: get the compartment of the main function *) + List.mapi (fun i be -> (Camlcoq.P.of_int (i+1), be)) (bundle_trace_aux main_comp size) let build_prog_defs ctx = let gvars = [] in diff --git a/test/backtranslation/Print.ml b/test/backtranslation/Print.ml index f99e6bc065..fbf3a5bd06 100644 --- a/test/backtranslation/Print.ml +++ b/test/backtranslation/Print.ml @@ -9,23 +9,27 @@ let print_event e = let print_trace t = Printf.sprintf "[\n%s\n ]" (String.concat "\n" (List.map print_event t)) +let print_eventval ev = + ignore (Format.flush_str_formatter()); + Interp.print_eventval Format.str_formatter ev; + Format.flush_str_formatter () + let print_eventval_list el = ignore (Format.flush_str_formatter ()); Interp.print_eventval_list Format.str_formatter el; - " " ^ Format.flush_str_formatter () + Format.flush_str_formatter () let print_bundle_event e = let open BtInfoAsm in let fmt = Printf.sprintf in match e with - | id, Bundle_call (trace, ident, args, sign, mem_delta) -> - fmt "%s:\n %s\n %s\n %s" (print_ident id) (print_trace trace) - (print_ident ident) (print_eventval_list args) - | id, Bundle_return (trace, ret_val, mem_delta) -> "bundle return" - | id, Bundle_builtin (trace, ext_fun, args, mem_delta) -> "bundle builtin" - -let print_bundle_trace _ = "printing not implemented" -(* String.concat "\n" (List.map print_bundle_event t) *) + | _, Bundle_call (_, ident, args, _, _) -> + fmt "call %s(%s)\n" (print_ident ident) (print_eventval_list args) + | _, Bundle_return (_, ret_val, _) -> + fmt "ret %s\n" (print_eventval ret_val) + | _, Bundle_builtin (_, _, _, _) -> "bundle builtin" + +let print_bundle_trace t = String.concat "\n" (List.map print_bundle_event t) let print_c_light_program prog = let version = PrintClight.Clight1 in diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 6d357787d0..aacd219660 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -14,6 +14,7 @@ let export_c_light_program prog main file_name = (* Run QCheck testing *) let property_under_test asm_prog bundled_trace = + let () = print_endline (Print.print_bundle_trace bundled_trace) in let source_name = "out.c" in let ccomp_cmd = "../../ccomp -quiet > /dev/null" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in @@ -28,7 +29,7 @@ let bundle_trace ctx = QCheck.make ~print:Print.print_bundle_trace (Gen.bundle_trace ctx) let test_backtranslation asm_prog ctx = - QCheck.Test.make ~count:10 ~name:"backtranslation" (bundle_trace ctx) + QCheck.Test.make ~count:1 ~name:"backtranslation" (bundle_trace ctx) (property_under_test asm_prog) let _ = From 7082fae58501e597b325a912090519a5f6b7acc8 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 8 Dec 2023 17:38:56 +0100 Subject: [PATCH 33/83] Generate no calling convention with cc_unproto = true --- test/backtranslation/Gen_ctx.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index 10c8f2c579..78440c1599 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -55,7 +55,8 @@ let sample_calling_convention allow_vararg = if allow_vararg then option ~ratio:0.1 (map Camlcoq.Z.of_uint small_nat) else return Option.none in - let* cc_unproto = map (fun f -> f <= 0.1) (float_range 0.0 1.0) in + (* TODO: what exactly is unproto and do we care for this testing? *) + let* cc_unproto = return false in (*map (fun f -> f <= 0.1) (float_range 0.0 1.0) in*) let* cc_structret = map (fun f -> f <= 0.1) (float_range 0.0 1.0) in return ({ cc_vararg; cc_unproto; cc_structret } : AST.calling_convention) From cdd8a9602c65bccd2ad726de47b1fd5090a76fc0 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 8 Dec 2023 18:01:39 +0100 Subject: [PATCH 34/83] Fix special floating point values and missing includes for generated C code --- test/backtranslation/test_backtranslation.ml | 34 ++++++++++++++++---- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index aacd219660..1ec81c11fa 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -1,15 +1,35 @@ +let rename_special_floating_point_values code = + let r_inf = Str.regexp "inf" in + let r_nan = Str.regexp "nan" in + code + |> Str.global_replace r_inf "INFINITY" + |> Str.global_replace r_nan "NAN" + +let rename_main main code = + let regex_main = Str.regexp ("\\$" ^ string_of_int main ^ "(") in + Str.global_replace regex_main "main(" code + +let rename_funcs code = + let regex = Str.regexp "\\$\\([0-9]+\\)" in + Str.global_replace regex "ident_\\1" code + +let prepend_header code = + "#include \n" ^ code + let export_c_light_program prog main file_name = let version = PrintClight.Clight1 in - let code = + let raw_code = ignore (Format.flush_str_formatter ()); PrintClight.print_program version Format.str_formatter prog; Format.flush_str_formatter () in - Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c code); - let regex_main = Str.regexp ("\\$" ^ string_of_int main ^ "(") in - let code_with_main = Str.global_replace regex_main "main(" code in - let regex = Str.regexp "\\$\\([0-9]+\\)" in - let clean_code = Str.global_replace regex "ident_\\1" code_with_main in - Out_channel.with_open_text file_name (fun c -> output_string c clean_code) + Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); + let code = + raw_code + |> rename_main main + |> rename_funcs + |> rename_special_floating_point_values + |> prepend_header in + Out_channel.with_open_text file_name (fun c -> output_string c code) (* Run QCheck testing *) From c7028310f9d1f37b9b4cb2a60a2ab6cf0d592c63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Fri, 8 Dec 2023 18:56:54 +0100 Subject: [PATCH 35/83] [Compiler] Fix the compilation process and add instructions to test compilation on MacOS M1 --- driver/Driver.ml | 18 ++-- driver/Interp.ml | 2 +- instructions-for-testing-on-mac.md | 130 +++++++++++++++++++++++++++++ 3 files changed, 140 insertions(+), 10 deletions(-) create mode 100644 instructions-for-testing-on-mac.md diff --git a/driver/Driver.ml b/driver/Driver.ml index 912d3d241b..39941a3a2f 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -65,15 +65,15 @@ let compile_c_file sourcename ifile ofile = | Errors.Error msg -> let loc = file_loc sourcename in fatal_error loc "%a" print_error msg in - let _ = (* TEMP *) - if !Interp.emulate_backend then - match Compiler.transf_c_program csyntax with - | Errors.OK asm -> - PrintAsm.print_program_asm stderr asm; - Interp.execute_asm asm; - | Errors.Error msg -> - let loc = file_loc sourcename in - fatal_error loc "%a" print_error msg in + (* let _ = (\* TEMP *\) *) + (* if !Interp.emulate_backend then *) + (* match Compiler.transf_c_program csyntax with *) + (* | Errors.OK asm -> *) + (* PrintAsm.print_program_asm stderr asm; *) + (* Interp.execute_asm asm; *) + (* | Errors.Error msg -> *) + (* let loc = file_loc sourcename in *) + (* fatal_error loc "%a" print_error msg in *) (* Dump Asm in binary and JSON format *) AsmToJSON.print_if asm sourcename; (* Print Asm in text form *) diff --git a/driver/Interp.ml b/driver/Interp.ml index d1875ab7dd..dc21b9c6ac 100644 --- a/driver/Interp.ml +++ b/driver/Interp.ml @@ -32,7 +32,7 @@ type mode = First | Random | All let mode = ref First -let emulate_backend = ref true +let emulate_backend = ref false let emulate_fuel = ref 10000 diff --git a/instructions-for-testing-on-mac.md b/instructions-for-testing-on-mac.md new file mode 100644 index 0000000000..b71fe3c4d1 --- /dev/null +++ b/instructions-for-testing-on-mac.md @@ -0,0 +1,130 @@ +# Installing a RISC-V cross-compiler for CompCert on an M1 Mac + +## Building and installing the **RISC-V GNU Compiler Toolchain** + +[https://github.com/riscv-collab/riscv-gnu-toolchain](https://github.com/riscv-collab/riscv-gnu-toolchain) + +Installing this toolchain is a bit tricky on MacOS, for several reasons. First, to build the linux version of the cross-compiler and glibc, we need to create a case-sensitive volume and use it temporarily. Then, MacOS comes by default with outdated versions of `bison` and `gnumake`. We will need to install the new version using `homebrew`. + +### Creating a case-sensitive volume + +Use `cmd+space` to open Spotlight search, and launch the Disk Utility app. Go to `File > New Image > Blank Image` and create a new volume of sufficient size (I chose 20 GB and it was enough — the README mentions the compilation process taking around 6.5 GB). We will remove the volume after installation. + +Clone the `riscv-gnu-toolchain` repo inside that volume (it’s a folder inside `/Volumes/`). + +### Installing up-to-date versions of bison and gnumake and configuring the environment + +Use `homebrew` to install newer versions of `bison` and `gnumake`: + +```bash +brew install bison +brew install make +``` + +Read the instructions carefully, and add the following to your `$PATH`: + +```bash +export PATH="$(brew --prefix bison)/bin:/opt/homebrew/opt/make/libexec/gnubin:$PATH" +``` + +I added that line to my `.zshrc`, but it might be enough to just run it in your current shell. + +Then, go to the `/opt/homebrew/opt/make/libexec/gnubin` folder and create a symlink so that the command `gnumake` points to the right version: + +```bash +ln -s make gnumake +``` + +Increase the maximum number of file descriptors per process: `ulimit -n 4096`. The default, 256, is way too low on MacOS. + +### Building the compilation chain and installing it + +We can now configure the project, build it, and install it. First, create a new folder to install the compilation chain: `sudo mkdir /opt/riscv` and make it writable: `sudo chmod a+w /opt/riscv`. + +Then, configure the project: + +```bash +./configure --prefix=/opt/riscv --with-arch=rv64imafd --disable-gdb +``` + +We disable GDB as we’re not going to use it, and specify the exact architecture that CompCert is targeting. We can now build the chain: + +```bash +make linux +``` + +The chain will be installed in the `/opt/riscv` folder, and we can add this folder to the `$PATH` to get easier access to it. + +## Install a RISC-V emulator (Spike) + +We install Spike using the following homebrew tap: + +[https://github.com/riscv-software-src/homebrew-riscv](https://github.com/riscv-software-src/homebrew-riscv) + +```bash +brew tap riscv-software-src/riscv +``` + +However, do not install the full toolchain. Instead only install Spike and PK: + +```bash +brew install riscv-isa-sim +brew install riscv-pk +``` + +All done for the emulator! + +## Building and installing CompCert and testing it + +### Building CompCert + +Configure the project for the RISC-V backend and using the correct compilation chain, then build the project and install CompCert. + +```bash +./configure -toolprefix riscv64-unknown-linux-gnu- rv64-linux +make +sudo make install +``` + +### Testing CompCert + +Go to the `test` folder and build the tests. + +```bash +cd test +make +``` + +If everything works as expected, there should be no error. + +### Running tests in the emulator + +Compile a program of your choice with: + +```bash +ccomp -static prog.c -o prog +``` + +You must link statically or the emulator will not run the program. Then you can run the program with: + +```bash +spike pk prog +``` + +## Cleaning up after installation + +Go to `/opt/homebrew/opt/make/libexec/gnubin` and remove the symlink: + +```bash +rm gnumake +``` + +Unmount the temporary volume in the Disk Utility app. The changes to the environment should only affect the current shell, if you didn’t modify your shell configuration file, so no need to undo them. + +## Sources + +[Running 64- and 32-bit RISC-V Linux on QEMU — RISC-V - Getting Started Guide](https://risc-v-getting-started-guide.readthedocs.io/en/latest/linux-qemu.html) + +[Compile and install RISC-V cross-compiler · lowRISC](https://www.cl.cam.ac.uk/~jrrk2/docs/riscv_compile/) + +[building Linux kernel on Mac OS X](https://stackoverflow.com/questions/10018764/building-linux-kernel-on-mac-os-x) \ No newline at end of file From f5f567e42d208d87f62b946cf2db113c7a0c2df0 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 11 Dec 2023 10:24:13 +0100 Subject: [PATCH 36/83] Ensure that global variables are defined before usage --- test/backtranslation/test_backtranslation.ml | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 1ec81c11fa..52e5bda256 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -9,26 +9,35 @@ let rename_main main code = let regex_main = Str.regexp ("\\$" ^ string_of_int main ^ "(") in Str.global_replace regex_main "main(" code -let rename_funcs code = +let rename_idents code = let regex = Str.regexp "\\$\\([0-9]+\\)" in Str.global_replace regex "ident_\\1" code let prepend_header code = "#include \n" ^ code -let export_c_light_program prog main file_name = +let export_c_light_program prog file_name = let version = PrintClight.Clight1 in + let vars_before_funcs (_, def1) (_, def2) = + let open AST in + match (def1, def2) with + | (Gfun _, Gvar _) -> 1 + | (Gvar _, Gfun _) -> -1 + | _ -> 0 + in + let prog = Ctypes.{ prog with prog_defs = List.sort vars_before_funcs prog.prog_defs } in let raw_code = ignore (Format.flush_str_formatter ()); PrintClight.print_program version Format.str_formatter prog; Format.flush_str_formatter () in - Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); + let main = Camlcoq.P.to_int prog.prog_main in let code = raw_code |> rename_main main - |> rename_funcs + |> rename_idents |> rename_special_floating_point_values |> prepend_header in + Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); Out_channel.with_open_text file_name (fun c -> output_string c code) (* Run QCheck testing *) @@ -38,8 +47,7 @@ let property_under_test asm_prog bundled_trace = let source_name = "out.c" in let ccomp_cmd = "../../ccomp -quiet > /dev/null" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in - let main = Camlcoq.P.to_int asm_prog.prog_main in - let () = export_c_light_program src_program main source_name in + let () = export_c_light_program src_program source_name in let status = Unix.system (ccomp_cmd ^ " " ^ source_name) in match status with | WEXITED code -> code = 0 From a61f2ea7f5df5331df814d65a9c9d52d49653f57 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 11 Dec 2023 10:41:36 +0100 Subject: [PATCH 37/83] Clean up output --- test/backtranslation/test_backtranslation.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 52e5bda256..54f1755235 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -43,9 +43,9 @@ let export_c_light_program prog file_name = (* Run QCheck testing *) let property_under_test asm_prog bundled_trace = - let () = print_endline (Print.print_bundle_trace bundled_trace) in + (* let () = print_endline (Print.print_bundle_trace bundled_trace) in *) let source_name = "out.c" in - let ccomp_cmd = "../../ccomp -quiet > /dev/null" in + let ccomp_cmd = "../../ccomp -quiet > /dev/null 2> /dev/null" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in let () = export_c_light_program src_program source_name in let status = Unix.system (ccomp_cmd ^ " " ^ source_name) in @@ -57,7 +57,7 @@ let bundle_trace ctx = QCheck.make ~print:Print.print_bundle_trace (Gen.bundle_trace ctx) let test_backtranslation asm_prog ctx = - QCheck.Test.make ~count:1 ~name:"backtranslation" (bundle_trace ctx) + QCheck.Test.make ~count:50 ~name:"backtranslation" (bundle_trace ctx) (property_under_test asm_prog) let _ = @@ -65,4 +65,4 @@ let _ = let rand_state = Random.get_state () in let asm_prog, ctx = Gen.asm_program rand_state in (*let () = PrintAsm.print_program_asm Out_channel.stdout asm_prog in*) - QCheck_runner.run_tests [ test_backtranslation asm_prog ctx ] + QCheck_runner.run_tests ~verbose:true [ test_backtranslation asm_prog ctx ] From fbf6edeff7f77e144f3337758ddcc97f188d3121 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 11 Dec 2023 13:25:33 +0100 Subject: [PATCH 38/83] Implement generation of builtins in bundle_trace (tests fail) --- test/backtranslation/Gen.ml | 271 ++++++++----------- test/backtranslation/Gen_ctx.ml | 40 ++- test/backtranslation/Gen_ctx.mli | 7 + test/backtranslation/test_backtranslation.ml | 3 +- 4 files changed, 163 insertions(+), 158 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index de9a8fe185..09be62ffb4 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -1,19 +1,18 @@ -(*let memory_chunk = +let memory_chunk = QCheck.Gen.frequencyl AST. - [ - (1, Mint8signed); - (1, Mint8unsigned); - (1, Mint16signed); - (1, Mint16unsigned); - (1, Mint32); - (1, Mint64); - (1, Mfloat32); - (1, Mfloat64); - (1, Many32); - (1, Many64); - ] -*) + [ + (1, Mint8signed); + (1, Mint8unsigned); + (1, Mint16signed); + (1, Mint16unsigned); + (1, Mint32); + (1, Mint64); + (1, Mfloat32); + (1, Mfloat64); + (1, Many32); + (1, Many64); + ] let positive = QCheck.Gen.(map (fun i -> Camlcoq.P.of_int (i + 1)) small_nat) let coq_Z = QCheck.Gen.(map (fun i -> Camlcoq.Z.of_sint i) small_signed_int) @@ -128,127 +127,62 @@ let trace rand_state = in gen_trace_aux size -(* let ef_external = - let open QCheck.Gen in - let* compartment = compartment in - let* name = char_list in - let* signature = signature in - return (AST.EF_external (compartment, name, signature)) *) - -(* let ef_builtin = - let open QCheck.Gen in - let* compartment = compartment in - let* name = char_list in - let* signature = signature in - return (AST.EF_builtin (compartment, name, signature)) *) - -(* let ef_runtime = - let open QCheck.Gen in - let* compartment = compartment in - let* name = char_list in - let* signature = signature in - return (AST.EF_runtime (compartment, name, signature)) *) - -(* let ef_vload = - let open QCheck.Gen in - let* compartment = compartment in - let* memory_chunk = memory_chunk in - return (AST.EF_vload (compartment, memory_chunk)) *) - -(* let ef_vstore = - let open QCheck.Gen in - let* compartment = compartment in - let* memory_chunk = memory_chunk in - return (AST.EF_vload (compartment, memory_chunk)) *) - -(* let ef_malloc = QCheck.Gen.map (fun c -> AST.EF_malloc c) compartment *) -(* let ef_free = QCheck.Gen.map (fun c -> AST.EF_free c) compartment *) - -(* let ef_memcpy = - let open QCheck.Gen in - let* compartment = compartment in - let* z1 = coq_Z in - let* z2 = coq_Z in - return (AST.EF_memcpy (compartment, z1, z2)) *) - -(* let ef_annot = - let open QCheck.Gen in - let* compartment = compartment in - let* p = positive in - let* text = char_list in - let* type_list = list_size small_nat typ in - return (AST.EF_annot (compartment, p, text, type_list)) *) - -(* let ef_annot_val = - let open QCheck.Gen in - let* compartment = compartment in - let* p = positive in - let* text = char_list in - let* typ = typ in - return (AST.EF_annot_val (compartment, p, text, typ)) *) - -(* let ef_inline_asm = - let open QCheck.Gen in - let* compartment = compartment in - let* text = char_list in - let* signature = signature in - let* code = list_size small_nat char_list in - return (AST.EF_inline_asm (compartment, text, signature, code)) *) - -(* let ef_debug = - let open QCheck.Gen in - let* compartment = compartment in - let* p = positive in - let* ident = ident in - let* type_list = list_size small_nat typ in - return (AST.EF_debug (compartment, p, ident, type_list)) *) - -(* let external_function = - QCheck.Gen.frequency - [ - (1, ef_external); - (1, ef_builtin); - (1, ef_runtime); - (1, ef_vload); - (1, ef_vstore); - (1, ef_malloc); - (1, ef_free); - (1, ef_memcpy); - (1, ef_annot); - (1, ef_annot_val); - (1, ef_inline_asm); - (1, ef_debug); - ] *) - -(* let bundle_call = - let open QCheck.Gen in - let* trace = trace in - let* ident = ident in - let* args = list_size (int_bound 5) eventval in - let* sign = signature in - let* mem_delta = mem_delta in - return (BtInfoAsm.Bundle_call (trace, ident, args, sign, mem_delta)) *) - -(* let bundle_return = - let open QCheck.Gen in - let* trace = trace in - let* ret_val = eventval in - let* mem_delta = mem_delta in - return (BtInfoAsm.Bundle_return (trace, ret_val, mem_delta)) *) - -(* let bundle_builtin = - let open QCheck.Gen in - let* trace = trace in - let* ext_fun = external_function in - let* args = list_size (int_bound 5) eventval in - let* mem_delta = mem_delta in - return (BtInfoAsm.Bundle_builtin (trace, ext_fun, args, mem_delta)) *) - -let bundle_event = - QCheck.Gen.frequency - [ (1, bundle_call); (1, bundle_return); (1, bundle_builtin) ] *) +let ef_external ctx = QCheck.Gen.oneofl (Gen_ctx.external_funcs ctx) + +let ef_builtin ctx = QCheck.Gen.oneofl (Gen_ctx.builtins ctx) + +let ef_runtime ctx = QCheck.Gen.oneofl (Gen_ctx.runtime_funcs ctx) + +let ef_vload _ = + let open QCheck.Gen in + (* TODO: are there any requirement we must meet? *) + let* memory_chunk = memory_chunk in + return (AST.EF_vload (memory_chunk)) + +let ef_vstore _ = + let open QCheck.Gen in + (* TODO: are there any requirements we must meet? *) + let* memory_chunk = memory_chunk in + return (AST.EF_vstore (memory_chunk)) + +let ef_malloc _ = QCheck.Gen.return AST.EF_malloc +let ef_free _ = QCheck.Gen.return AST.EF_free + +let ef_memcpy _ = + let open QCheck.Gen in + (* TODO: are there any requirements we must meet? *) + let* z1 = coq_Z in + let* z2 = coq_Z in + return (AST.EF_memcpy (z1, z2)) + +let ef_annot _ = failwith "ef_annot is not implemented" + +let ef_annot_val _ = failwith "ef_annot_val is not implemented" + +let ef_inline_asm _ = failwith "ef_inline_asm is not implemented" + +let ef_debug _ = failwith "ef_debug is not implemented" + +let external_function ctx = + QCheck.Gen.frequency + [ + (1, ef_external ctx); + (1, ef_builtin ctx); + (1, ef_runtime ctx); + (1, ef_vload ctx); + (1, ef_vstore ctx); + (1, ef_malloc ctx); + (1, ef_free ctx); + (1, ef_memcpy ctx); + (* TODO: enable these after the corresponding functions are implemented *) + (* (0, ef_annot ctx); + (0, ef_annot_val ctx); + (0, ef_inline_asm ctx); + (0, ef_debug ctx);*) + ] + (* TODO: perhaps differentiate between signed/unsigned and positive/negative values? *) let ev_int = QCheck.Gen.map (fun i -> Events.EVint i) coq_Z let ev_float = QCheck.Gen.map (fun f -> Events.EVfloat f) binary_float @@ -282,36 +216,58 @@ let ret_val_for_sig sign = | Tvoid -> ev_int | Tret t -> value_of_typ t +let bundle_call_ret ctx curr_comp rand_state = + let open QCheck.Gen in + let pool = ctx + |> Gen_ctx.import_list + |> List.assoc curr_comp in + match pool with + | [] -> Option.none (* there is no imported function we could possibly call *) + | _ -> + let trgt_comp, trgt_func = oneofl pool rand_state in + let sign = (match + (List.find_map + (fun (f, c, s) -> + if f = trgt_func && c = trgt_comp then Option.some s else Option.none) + (Gen_ctx.def_list ctx)) with + | Option.None -> failwith "Cannot lookup signature for imported function" + | Option.Some s -> s) in + let args = args_for_sig sign rand_state in + let ret_val = ret_val_for_sig sign rand_state in + let subtrace_call = [] in + let subtrace_ret = [] in + let mdelta_call = [] in + let mdelta_ret = [] in + let call = BtInfoAsm.Bundle_call (subtrace_call, Camlcoq.P.of_int trgt_func, args, sign, mdelta_call) in + let ret = BtInfoAsm.Bundle_return (subtrace_ret, ret_val, mdelta_ret) in + Option.some (call, ret, trgt_comp) + +let bundle_builtin ctx rand_state = + let open QCheck.Gen in + let subtrace = [] in + let func = external_function ctx rand_state in + let sign = AST.ef_sig func in + let args = args_for_sig sign rand_state in + let mdelta = [] in + BtInfoAsm.Bundle_builtin (subtrace, func, args, mdelta) + let bundle_trace ctx rand_state = let open QCheck.Gen in let size = small_nat rand_state in let rec bundle_trace_aux curr_comp = function | 0 -> [] | n -> ( - let pool = ctx - |> Gen_ctx.import_list - |> List.assoc curr_comp in - match pool with - | [] -> [] (* there is no imported function we could possibly call => end trace *) + let f = float_range 0.0 1.0 rand_state in + match f with + | _ when f < 0.8 -> ( + match bundle_call_ret ctx curr_comp rand_state with + | Option.None -> [] + | Option.Some (call, ret, trgt_comp) -> + let between = bundle_trace_aux trgt_comp (n-1) in + List.concat [[call]; between; [ret]]) | _ -> - let trgt_comp, trgt_func = oneofl pool rand_state in - let sign = (match - (List.find_map - (fun (f, c, s) -> - if f = trgt_func && c = trgt_comp then Option.some s else Option.none) - (Gen_ctx.def_list ctx)) with - | Option.None -> failwith "Cannot lookup signature for imported function" - | Option.Some s -> s) in - let args = args_for_sig sign rand_state in - let ret_val = ret_val_for_sig sign rand_state in - let subtrace_call = [] in - let subtrace_ret = [] in - let mdelta_call = [] in - let mdelta_ret = [] in - let call = BtInfoAsm.Bundle_call (subtrace_call, Camlcoq.P.of_int trgt_func, args, sign, mdelta_call) in - let ret = BtInfoAsm.Bundle_return (subtrace_ret, ret_val, mdelta_ret) in - let between = bundle_trace_aux trgt_comp (n-1) in - List.concat [[call]; between; [ret]] + let b = bundle_builtin ctx rand_state in + b :: bundle_trace_aux curr_comp (n-1) ) in let main_comp = 1 in (* TODO: get the compartment of the main function *) @@ -373,6 +329,9 @@ let asm_program = num_compartments = 3; num_exported_funcs = 5; num_imported_funcs = 3; + num_external_funcs = 4; + num_builtins = 4; + num_runtime_funcs = 4; max_arg_count = 2; debug = true; } diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index 78440c1599..30e5b82ce5 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -3,18 +3,25 @@ module Map = Map.Make (Int) type exports = int list Map.t type imports = (int * int) list Map.t type func_sigs = AST.signature Map.t +type extern = AST.external_function type t = { exports : exports; imports : imports; func_sigs : func_sigs; main : int; + external_funcs : extern list; + builtins: extern list; + runtime_funcs : extern list; } type gen_config = { num_compartments : int; num_exported_funcs : int; num_imported_funcs : int; + num_external_funcs : int; + num_builtins : int; + num_runtime_funcs: int; max_arg_count : int; debug : bool; } @@ -106,6 +113,30 @@ let sample_func_sigs config exports = in return (main, Map.add main main_sig sig_map) +let sample_external_funcs config = + let open QCheck.Gen in + let gen = + let* name = small_list (char_range 'a' 'z') in + let* sign = sample_signature config in + return (AST.EF_external (name, sign)) in + list_repeat config.num_external_funcs gen + +let sample_builtins config = + let open QCheck.Gen in + let gen = + let* name = small_list (char_range 'a' 'z') in + let* sign = sample_signature config in + return (AST.EF_builtin (name, sign)) in + list_repeat config.num_builtins gen + +let sample_runtime_funcs config = + let open QCheck.Gen in + let gen = + let* name = small_list (char_range 'a' 'z') in + let* sign = sample_signature config in + return (AST.EF_runtime (name, sign)) in + list_repeat config.num_runtime_funcs gen + let dump_exports exports = print_endline "Exports:"; Map.iter @@ -128,13 +159,16 @@ let random config = let* graph = Graph.random config.num_compartments in let* exports = sample_exports config graph in let* imports = sample_imports graph exports in + let* external_funcs = sample_external_funcs config in + let* builtins = sample_builtins config in + let* runtime_funcs = sample_runtime_funcs config in let* main, func_sigs = sample_func_sigs config exports in if config.debug then ( Graph.dump graph; dump_exports exports; dump_imports imports) else (); - return { exports; imports; func_sigs; main } + return { exports; imports; func_sigs; main; external_funcs; builtins; runtime_funcs } let main ctx = ctx.main let function_list ctx = List.concat_map snd (Map.bindings ctx.exports) @@ -147,3 +181,7 @@ let def_list ctx = List.concat_map (fun (c, fs) -> List.map (fun f -> (f, c, sig_of f)) fs) (export_list ctx) + +let external_funcs ctx = ctx.external_funcs +let builtins ctx = ctx.builtins +let runtime_funcs ctx = ctx.runtime_funcs diff --git a/test/backtranslation/Gen_ctx.mli b/test/backtranslation/Gen_ctx.mli index 5aa78bac42..b99a413ee1 100644 --- a/test/backtranslation/Gen_ctx.mli +++ b/test/backtranslation/Gen_ctx.mli @@ -6,6 +6,9 @@ type gen_config = { num_compartments : int; num_exported_funcs : int; num_imported_funcs : int; + num_external_funcs : int; + num_builtins : int; + num_runtime_funcs : int; max_arg_count : int; debug : bool; } @@ -20,3 +23,7 @@ val compartment_list : t -> comp list val export_list : t -> (comp * func list) list val import_list : t -> (comp * (comp * func) list) list val def_list : t -> (func * comp * AST.signature) list + +val external_funcs : t -> AST.external_function list +val builtins : t -> AST.external_function list +val runtime_funcs : t -> AST.external_function list diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 54f1755235..3869b4fae1 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -46,6 +46,7 @@ let property_under_test asm_prog bundled_trace = (* let () = print_endline (Print.print_bundle_trace bundled_trace) in *) let source_name = "out.c" in let ccomp_cmd = "../../ccomp -quiet > /dev/null 2> /dev/null" in + let ccomp_cmd = "../../ccomp" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in let () = export_c_light_program src_program source_name in let status = Unix.system (ccomp_cmd ^ " " ^ source_name) in @@ -57,7 +58,7 @@ let bundle_trace ctx = QCheck.make ~print:Print.print_bundle_trace (Gen.bundle_trace ctx) let test_backtranslation asm_prog ctx = - QCheck.Test.make ~count:50 ~name:"backtranslation" (bundle_trace ctx) + QCheck.Test.make ~count:1 ~name:"backtranslation" (bundle_trace ctx) (property_under_test asm_prog) let _ = From e99b733d36a1572f85f3fcfbfc9af8c00d8db3a2 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 11 Dec 2023 16:16:13 +0100 Subject: [PATCH 39/83] Add non-trivial memory deltas to the trace events (tests fail) --- test/backtranslation/Gen.ml | 168 +++++++++++++++++------------------- 1 file changed, 81 insertions(+), 87 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index 09be62ffb4..af1ae54280 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -17,7 +17,7 @@ let memory_chunk = let positive = QCheck.Gen.(map (fun i -> Camlcoq.P.of_int (i + 1)) small_nat) let coq_Z = QCheck.Gen.(map (fun i -> Camlcoq.Z.of_sint i) small_signed_int) let ident = positive -let compartment = positive +let compartment = QCheck.Gen.map (fun p -> AST.COMP.Comp p) positive let ptrofs = QCheck.Gen.map (fun i -> Integers.Ptrofs.of_int i) coq_Z let char_list = QCheck.Gen.(small_list (char_range 'a' 'z')) @@ -32,102 +32,95 @@ let binary_float = in frequency [ (1, zero); (1, infinity); (1, nan); (1, finite) ] -(* -let eventval = +let mem_val ctx = let open QCheck.Gen in - let open Events in - let evint = map (fun i -> EVint i) coq_Z in - let evlong = map (fun i -> EVlong i) coq_Z in - let evfloat = map (fun f -> EVfloat f) binary_float in - let evsingle = map (fun f -> EVfloat f) binary_float in - let evptr_global = - map (fun (i, p) -> EVptr_global (i, p)) (pair ident ptrofs) - in - frequency - [ (1, evint); (1, evlong); (1, evfloat); (1, evsingle); (1, evptr_global) ] + QCheck.Gen.frequency + Memdata.[ + (1, return Undef); + (1, map (fun b -> Byte b) coq_Z); + (* TODO: add support for fragment memory values *) + ] -let event_syscall size = - let open QCheck.Gen in - let* name = char_list in - let* args = list_size size eventval in - let* ret_val = eventval in - return (Events.Event_syscall (name, args, ret_val)) +let vundef = QCheck.Gen.return Values.Vundef -let event_vload = - let open QCheck.Gen in - let* mem_chunk = memory_chunk in - let* ident = ident in - let* ptr = ptrofs in - let* value = eventval in - return (Events.Event_vload (mem_chunk, ident, ptr, value)) +let vint = QCheck.Gen.map (fun i -> Values.Vint i) coq_Z -let event_vstore = - let open QCheck.Gen in - let* mem_chunk = memory_chunk in - let* ident = ident in - let* ptr = ptrofs in - let* value = eventval in - return (Events.Event_vstore (mem_chunk, ident, ptr, value)) +let vlong = QCheck.Gen.map (fun i -> Values.Vlong i) coq_Z -let event_annot size = - let open QCheck.Gen in - let* name = char_list in - let* values = list_size size eventval in - return (Events.Event_annot (name, values)) +let vfloat = QCheck.Gen.map (fun f -> Values.Vfloat f) binary_float -let event_call src_compartment trgt_compartment size = - let open QCheck.Gen in - let* ident = ident in - let* args = list_size size eventval in - return (Events.Event_call (src_compartment, trgt_compartment, ident, args)) +let vsingle = QCheck.Gen.map (fun f -> Values.Vsingle f) binary_float -let event_return src_compartment trgt_compartment = +let vptr = let open QCheck.Gen in - let* ret_val = eventval in - return (Events.Event_return (src_compartment, trgt_compartment, ret_val)) + let* block = positive in + let* ptrofs = ptrofs in + return (Values.Vptr (block, ptrofs)) -(* TODO: also generate other mem_deltas *) -let mem_delta = QCheck.Gen.return [] +let coq_val = + QCheck.Gen.frequency + [ + (1, vundef); + (1, vint); + (1, vlong); + (1, vfloat); + (1, vsingle); + (1, vptr); + ] -(* QCheck generator for an event trace *) +let mem_delta_storev ctx = + let open QCheck.Gen in + let* chunk = memory_chunk in + let* block = positive in + let* offset = ptrofs in + let addr = Values.Vptr (block, offset) in + let* comp = compartment in + let* value = coq_val in + return (MemoryDelta.Coq_mem_delta_kind_storev (((chunk, addr), value), comp)) + +let mem_delta_store ctx = + let open QCheck.Gen in + let* chunk = memory_chunk in + let* block = positive in + let* offset = ptrofs in + let* comp = compartment in + let* value = coq_val in + return (MemoryDelta.Coq_mem_delta_kind_store ((((chunk, block), offset), value), comp)) + +let mem_delta_bytes ctx = + let open QCheck.Gen in + let* block = positive in + let* offset = ptrofs in + let* bytes = small_list (mem_val ctx) in + let* comp = compartment in + return (MemoryDelta.Coq_mem_delta_kind_bytes (((block, offset), bytes), comp)) -let trace rand_state = +let mem_delta_alloc ctx = let open QCheck.Gen in - (* ensure that no empty traces are generated *) - let size = small_nat rand_state + 1 in - let rec gen_trace_aux = function - | 0 -> [] - | n -> ( - let f = float_range 0.0 1.0 rand_state in - match f with - | _ when f < 0.6 -> - let n1, n2 = nat_split2 (n - 1) rand_state in - let src_compartment = compartment rand_state in - let trgt_compartment = compartment rand_state in - let arg_count = int_bound 5 in - let call = - [ - event_call src_compartment trgt_compartment arg_count rand_state; - ] - in - let between = gen_trace_aux n1 in - let ret = - [ event_return src_compartment trgt_compartment rand_state ] - in - let after = gen_trace_aux n2 in - List.concat [ call; between; ret; after ] - | _ when f < 0.7 -> - let arg_count = int_bound 5 in - event_syscall arg_count rand_state :: gen_trace_aux (n - 1) - | _ when f < 0.8 -> event_vload rand_state :: gen_trace_aux (n - 1) - | _ when f < 0.9 -> event_vstore rand_state :: gen_trace_aux (n - 1) - | _ -> - let size = int_bound 5 in - event_annot size rand_state :: gen_trace_aux (n - 1)) - in - gen_trace_aux size + let* comp = compartment in + let* lower = map Camlcoq.Z.of_uint small_nat in + let* len = map Camlcoq.Z.of_uint small_nat in + return (MemoryDelta.Coq_mem_delta_kind_alloc ((comp, lower), Camlcoq.Z.add lower len)) + +let mem_delta_free ctx = + let open QCheck.Gen in + let* block = positive in + let* lower = map Camlcoq.Z.of_uint small_nat in + let* len = map Camlcoq.Z.of_uint small_nat in + let* comp = compartment in + return (MemoryDelta.Coq_mem_delta_kind_free (((block, lower), Camlcoq.Z.add lower len), comp)) + +let mem_delta_kind ctx = + QCheck.Gen.frequency + [ + (1, mem_delta_storev ctx); + (1, mem_delta_store ctx); + (1, mem_delta_bytes ctx); + (1, mem_delta_alloc ctx); + (1, mem_delta_free ctx); + ] -*) +let mem_delta ctx = QCheck.Gen.small_list (mem_delta_kind ctx) let ef_external ctx = QCheck.Gen.oneofl (Gen_ctx.external_funcs ctx) @@ -236,8 +229,8 @@ let bundle_call_ret ctx curr_comp rand_state = let ret_val = ret_val_for_sig sign rand_state in let subtrace_call = [] in let subtrace_ret = [] in - let mdelta_call = [] in - let mdelta_ret = [] in + let mdelta_call = mem_delta ctx rand_state in + let mdelta_ret = mem_delta ctx rand_state in let call = BtInfoAsm.Bundle_call (subtrace_call, Camlcoq.P.of_int trgt_func, args, sign, mdelta_call) in let ret = BtInfoAsm.Bundle_return (subtrace_ret, ret_val, mdelta_ret) in Option.some (call, ret, trgt_comp) @@ -259,7 +252,8 @@ let bundle_trace ctx rand_state = | n -> ( let f = float_range 0.0 1.0 rand_state in match f with - | _ when f < 0.8 -> ( + (* TODO: also generate builtin events in the trace (for now the test fails) *) + | _ when f < 1.0 -> ( match bundle_call_ret ctx curr_comp rand_state with | Option.None -> [] | Option.Some (call, ret, trgt_comp) -> From 61baedbdcc2c5fb12e5e8be993abcb13feb6e8f2 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Wed, 13 Dec 2023 15:13:54 +0100 Subject: [PATCH 40/83] Make all runs of tests deterministic and reproducible --- test/backtranslation/Gen.ml | 22 ++++-------- test/backtranslation/Gen.mli | 2 +- test/backtranslation/test_backtranslation.ml | 37 +++++++++++++++++--- 3 files changed, 39 insertions(+), 22 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index af1ae54280..b0d82627f8 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -115,9 +115,9 @@ let mem_delta_kind ctx = [ (1, mem_delta_storev ctx); (1, mem_delta_store ctx); - (1, mem_delta_bytes ctx); + (*(1, mem_delta_bytes ctx); (1, mem_delta_alloc ctx); - (1, mem_delta_free ctx); + (1, mem_delta_free ctx);*) ] let mem_delta ctx = QCheck.Gen.small_list (mem_delta_kind ctx) @@ -211,12 +211,14 @@ let ret_val_for_sig sign = let bundle_call_ret ctx curr_comp rand_state = let open QCheck.Gen in + Printf.printf "bundle_call_ret was called\n"; let pool = ctx |> Gen_ctx.import_list |> List.assoc curr_comp in match pool with | [] -> Option.none (* there is no imported function we could possibly call *) | _ -> + Printf.printf "sampling from pool\n"; let trgt_comp, trgt_func = oneofl pool rand_state in let sign = (match (List.find_map @@ -230,6 +232,7 @@ let bundle_call_ret ctx curr_comp rand_state = let subtrace_call = [] in let subtrace_ret = [] in let mdelta_call = mem_delta ctx rand_state in + Printf.printf "generated mdelta_call of length %d\n" (List.length mdelta_call); let mdelta_ret = mem_delta ctx rand_state in let call = BtInfoAsm.Bundle_call (subtrace_call, Camlcoq.P.of_int trgt_func, args, sign, mdelta_call) in let ret = BtInfoAsm.Bundle_return (subtrace_ret, ret_val, mdelta_ret) in @@ -315,21 +318,8 @@ let build_prog_pol ctx = in policy -let asm_program = +let asm_program config = let open QCheck.Gen in - let config = - Gen_ctx. - { - num_compartments = 3; - num_exported_funcs = 5; - num_imported_funcs = 3; - num_external_funcs = 4; - num_builtins = 4; - num_runtime_funcs = 4; - max_arg_count = 2; - debug = true; - } - in let* ctx = Gen_ctx.random config in let prog_defs = build_prog_defs ctx in let prog_public = build_prog_public ctx in diff --git a/test/backtranslation/Gen.mli b/test/backtranslation/Gen.mli index a9370ae70d..7a4f1510f3 100644 --- a/test/backtranslation/Gen.mli +++ b/test/backtranslation/Gen.mli @@ -1,3 +1,3 @@ (*val trace : Events.event list QCheck.Gen.t *) val bundle_trace : Gen_ctx.t -> BtInfoAsm.bundle_trace QCheck.Gen.t -val asm_program : (Asm.program * Gen_ctx.t) QCheck.Gen.t +val asm_program : Gen_ctx.gen_config -> (Asm.program * Gen_ctx.t) QCheck.Gen.t diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 3869b4fae1..8c51046dde 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -43,7 +43,7 @@ let export_c_light_program prog file_name = (* Run QCheck testing *) let property_under_test asm_prog bundled_trace = - (* let () = print_endline (Print.print_bundle_trace bundled_trace) in *) + let () = print_endline (Print.print_bundle_trace bundled_trace) in let source_name = "out.c" in let ccomp_cmd = "../../ccomp -quiet > /dev/null 2> /dev/null" in let ccomp_cmd = "../../ccomp" in @@ -61,9 +61,36 @@ let test_backtranslation asm_prog ctx = QCheck.Test.make ~count:1 ~name:"backtranslation" (bundle_trace ctx) (property_under_test asm_prog) +let parse_args () = + let usage_msg = "test_backtranslation [-seed n] [-verbose]" in + let seed = ref 0 in + let verbose = ref false in + let anon_fun _ = failwith "Unnamed arguments are not supported" in + let speclist = + [ + ("-seed", Arg.Set_int seed, "Initial random seed"); + ("-verbose", Arg.Set verbose, "Provide verbose output") + ] in + let () = Arg.parse speclist anon_fun usage_msg in + (!seed, !verbose) + let _ = - let () = Random.self_init () in + let (seed, verbose) = parse_args () in + let config = + Gen_ctx. + { + num_compartments = 3; + num_exported_funcs = 5; + num_imported_funcs = 3; + num_external_funcs = 4; + num_builtins = 4; + num_runtime_funcs = 4; + max_arg_count = 2; + debug = verbose; + } + in + let () = if seed = 0 then Random.self_init () else Random.init seed in let rand_state = Random.get_state () in - let asm_prog, ctx = Gen.asm_program rand_state in - (*let () = PrintAsm.print_program_asm Out_channel.stdout asm_prog in*) - QCheck_runner.run_tests ~verbose:true [ test_backtranslation asm_prog ctx ] + let asm_prog, ctx = Gen.asm_program config rand_state in + if verbose then PrintAsm.print_program_asm Out_channel.stdout asm_prog else (); + QCheck_runner.run_tests ~verbose:verbose ~rand:rand_state [ test_backtranslation asm_prog ctx ] From c99987bac6c71bf0ff49b7483fcd32cf526fdfae Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Wed, 13 Dec 2023 15:43:28 +0100 Subject: [PATCH 41/83] Extract export of clight programs to compilable c files in custom module --- test/backtranslation/Export.ml | 41 +++++++++++++ test/backtranslation/Export.mli | 4 ++ test/backtranslation/test_backtranslation.ml | 62 ++++---------------- 3 files changed, 55 insertions(+), 52 deletions(-) create mode 100644 test/backtranslation/Export.ml create mode 100644 test/backtranslation/Export.mli diff --git a/test/backtranslation/Export.ml b/test/backtranslation/Export.ml new file mode 100644 index 0000000000..f50f3c3c52 --- /dev/null +++ b/test/backtranslation/Export.ml @@ -0,0 +1,41 @@ +let rename_special_floating_point_values code = + let r_inf = Str.regexp "inf" in + let r_nan = Str.regexp "nan" in + code + |> Str.global_replace r_inf "INFINITY" + |> Str.global_replace r_nan "NAN" + +let rename_main main code = + let regex_main = Str.regexp ("\\$" ^ string_of_int main ^ "(") in + Str.global_replace regex_main "main(" code + +let rename_idents code = + let regex = Str.regexp "\\$\\([0-9]+\\)" in + Str.global_replace regex "ident_\\1" code + +let prepend_header code = + "#include \n" ^ code + +let c_light_prog prog file_name = + let version = PrintClight.Clight1 in + let vars_before_funcs (_, def1) (_, def2) = + let open AST in + match (def1, def2) with + | (Gfun _, Gvar _) -> 1 + | (Gvar _, Gfun _) -> -1 + | _ -> 0 + in + let prog = Ctypes.{ prog with prog_defs = List.sort vars_before_funcs prog.prog_defs } in + let raw_code = + ignore (Format.flush_str_formatter ()); + PrintClight.print_program version Format.str_formatter prog; + Format.flush_str_formatter () in + let main = Camlcoq.P.to_int prog.prog_main in + let code = + raw_code + |> rename_main main + |> rename_idents + |> rename_special_floating_point_values + |> prepend_header in + Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); + Out_channel.with_open_text file_name (fun c -> output_string c code) diff --git a/test/backtranslation/Export.mli b/test/backtranslation/Export.mli new file mode 100644 index 0000000000..08243500e5 --- /dev/null +++ b/test/backtranslation/Export.mli @@ -0,0 +1,4 @@ +(** Export a Clight program in raw form and as (valid) compilable C code. + The exported code is written to the given filename and the suffix .raw + is used to indicate the raw variant. *) +val c_light_prog : Clight.program -> string -> unit diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 8c51046dde..72e63b1465 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -1,54 +1,11 @@ -let rename_special_floating_point_values code = - let r_inf = Str.regexp "inf" in - let r_nan = Str.regexp "nan" in - code - |> Str.global_replace r_inf "INFINITY" - |> Str.global_replace r_nan "NAN" - -let rename_main main code = - let regex_main = Str.regexp ("\\$" ^ string_of_int main ^ "(") in - Str.global_replace regex_main "main(" code - -let rename_idents code = - let regex = Str.regexp "\\$\\([0-9]+\\)" in - Str.global_replace regex "ident_\\1" code - -let prepend_header code = - "#include \n" ^ code - -let export_c_light_program prog file_name = - let version = PrintClight.Clight1 in - let vars_before_funcs (_, def1) (_, def2) = - let open AST in - match (def1, def2) with - | (Gfun _, Gvar _) -> 1 - | (Gvar _, Gfun _) -> -1 - | _ -> 0 - in - let prog = Ctypes.{ prog with prog_defs = List.sort vars_before_funcs prog.prog_defs } in - let raw_code = - ignore (Format.flush_str_formatter ()); - PrintClight.print_program version Format.str_formatter prog; - Format.flush_str_formatter () in - let main = Camlcoq.P.to_int prog.prog_main in - let code = - raw_code - |> rename_main main - |> rename_idents - |> rename_special_floating_point_values - |> prepend_header in - Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); - Out_channel.with_open_text file_name (fun c -> output_string c code) - -(* Run QCheck testing *) - +(* QCheck testing *) let property_under_test asm_prog bundled_trace = let () = print_endline (Print.print_bundle_trace bundled_trace) in let source_name = "out.c" in let ccomp_cmd = "../../ccomp -quiet > /dev/null 2> /dev/null" in let ccomp_cmd = "../../ccomp" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in - let () = export_c_light_program src_program source_name in + let () = Export.c_light_prog src_program source_name in let status = Unix.system (ccomp_cmd ^ " " ^ source_name) in match status with | WEXITED code -> code = 0 @@ -64,18 +21,19 @@ let test_backtranslation asm_prog ctx = let parse_args () = let usage_msg = "test_backtranslation [-seed n] [-verbose]" in let seed = ref 0 in - let verbose = ref false in + let debug = ref false in let anon_fun _ = failwith "Unnamed arguments are not supported" in let speclist = [ ("-seed", Arg.Set_int seed, "Initial random seed"); - ("-verbose", Arg.Set verbose, "Provide verbose output") + ("-debug", Arg.Set debug, "Provide debug output") ] in let () = Arg.parse speclist anon_fun usage_msg in - (!seed, !verbose) + (!seed, !debug) +(* Main *) let _ = - let (seed, verbose) = parse_args () in + let (seed, debug) = parse_args () in let config = Gen_ctx. { @@ -86,11 +44,11 @@ let _ = num_builtins = 4; num_runtime_funcs = 4; max_arg_count = 2; - debug = verbose; + debug = debug; } in let () = if seed = 0 then Random.self_init () else Random.init seed in let rand_state = Random.get_state () in let asm_prog, ctx = Gen.asm_program config rand_state in - if verbose then PrintAsm.print_program_asm Out_channel.stdout asm_prog else (); - QCheck_runner.run_tests ~verbose:verbose ~rand:rand_state [ test_backtranslation asm_prog ctx ] + if debug then PrintAsm.print_program_asm Out_channel.stdout asm_prog else (); + QCheck_runner.run_tests ~verbose:true ~rand:rand_state [ test_backtranslation asm_prog ctx ] From afb99deb292adbcba4816c0a44dc22119acb33ff Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Wed, 13 Dec 2023 17:04:42 +0100 Subject: [PATCH 42/83] Implement output functions for memory_deltas --- test/backtranslation/Export.ml | 6 +- test/backtranslation/Gen.ml | 5 +- test/backtranslation/Print.ml | 48 ------- test/backtranslation/Show.ml | 139 +++++++++++++++++++ test/backtranslation/test_backtranslation.ml | 4 +- 5 files changed, 143 insertions(+), 59 deletions(-) delete mode 100644 test/backtranslation/Print.ml create mode 100644 test/backtranslation/Show.ml diff --git a/test/backtranslation/Export.ml b/test/backtranslation/Export.ml index f50f3c3c52..4b3437f2e4 100644 --- a/test/backtranslation/Export.ml +++ b/test/backtranslation/Export.ml @@ -17,7 +17,6 @@ let prepend_header code = "#include \n" ^ code let c_light_prog prog file_name = - let version = PrintClight.Clight1 in let vars_before_funcs (_, def1) (_, def2) = let open AST in match (def1, def2) with @@ -26,10 +25,7 @@ let c_light_prog prog file_name = | _ -> 0 in let prog = Ctypes.{ prog with prog_defs = List.sort vars_before_funcs prog.prog_defs } in - let raw_code = - ignore (Format.flush_str_formatter ()); - PrintClight.print_program version Format.str_formatter prog; - Format.flush_str_formatter () in + let raw_code = Show.show_c_light_program prog in let main = Camlcoq.P.to_int prog.prog_main in let code = raw_code diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index b0d82627f8..d6d2bda06f 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -211,14 +211,12 @@ let ret_val_for_sig sign = let bundle_call_ret ctx curr_comp rand_state = let open QCheck.Gen in - Printf.printf "bundle_call_ret was called\n"; let pool = ctx |> Gen_ctx.import_list |> List.assoc curr_comp in match pool with | [] -> Option.none (* there is no imported function we could possibly call *) | _ -> - Printf.printf "sampling from pool\n"; let trgt_comp, trgt_func = oneofl pool rand_state in let sign = (match (List.find_map @@ -232,7 +230,6 @@ let bundle_call_ret ctx curr_comp rand_state = let subtrace_call = [] in let subtrace_ret = [] in let mdelta_call = mem_delta ctx rand_state in - Printf.printf "generated mdelta_call of length %d\n" (List.length mdelta_call); let mdelta_ret = mem_delta ctx rand_state in let call = BtInfoAsm.Bundle_call (subtrace_call, Camlcoq.P.of_int trgt_func, args, sign, mdelta_call) in let ret = BtInfoAsm.Bundle_return (subtrace_ret, ret_val, mdelta_ret) in @@ -256,7 +253,7 @@ let bundle_trace ctx rand_state = let f = float_range 0.0 1.0 rand_state in match f with (* TODO: also generate builtin events in the trace (for now the test fails) *) - | _ when f < 1.0 -> ( + | _ when f < 0.6 -> ( match bundle_call_ret ctx curr_comp rand_state with | Option.None -> [] | Option.Some (call, ret, trgt_comp) -> diff --git a/test/backtranslation/Print.ml b/test/backtranslation/Print.ml deleted file mode 100644 index fbf3a5bd06..0000000000 --- a/test/backtranslation/Print.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* Format failing test cases for output *) -let print_ident i = Printf.sprintf "%d" (Camlcoq.P.to_int i) - -let print_event e = - ignore (Format.flush_str_formatter ()); - Interp.print_event Format.str_formatter e; - " " ^ Format.flush_str_formatter () - -let print_trace t = - Printf.sprintf "[\n%s\n ]" (String.concat "\n" (List.map print_event t)) - -let print_eventval ev = - ignore (Format.flush_str_formatter()); - Interp.print_eventval Format.str_formatter ev; - Format.flush_str_formatter () - -let print_eventval_list el = - ignore (Format.flush_str_formatter ()); - Interp.print_eventval_list Format.str_formatter el; - Format.flush_str_formatter () - -let print_bundle_event e = - let open BtInfoAsm in - let fmt = Printf.sprintf in - match e with - | _, Bundle_call (_, ident, args, _, _) -> - fmt "call %s(%s)\n" (print_ident ident) (print_eventval_list args) - | _, Bundle_return (_, ret_val, _) -> - fmt "ret %s\n" (print_eventval ret_val) - | _, Bundle_builtin (_, _, _, _) -> "bundle builtin" - -let print_bundle_trace t = String.concat "\n" (List.map print_bundle_event t) - -let print_c_light_program prog = - let version = PrintClight.Clight1 in - ignore (Format.flush_str_formatter ()); - PrintClight.print_program version Format.str_formatter prog; - print_endline (Format.flush_str_formatter ()) - -let print_compiler_errors errors = - let open Errors in - let fmt = Printf.printf in - List.iter - (fun e -> - match e with - | CTX p | POS p -> fmt "%d" (Camlcoq.P.to_int p) - | MSG chars -> List.iter (fun c -> fmt "%c" c) chars) - errors diff --git a/test/backtranslation/Show.ml b/test/backtranslation/Show.ml new file mode 100644 index 0000000000..11fc8534d9 --- /dev/null +++ b/test/backtranslation/Show.ml @@ -0,0 +1,139 @@ +let fmt = Printf.sprintf + +let from_str_formatter p x = + ignore (Format.flush_str_formatter ()); + p Format.str_formatter x; + Format.flush_str_formatter() + +let show_ident i = fmt "%d" (Camlcoq.P.to_int i) + +let show_event e = from_str_formatter Interp.print_event e + +let show_trace t = + fmt "[\n%s\n ]" (String.concat "\n" (List.map show_event t)) + +let show_eventval ev = from_str_formatter Interp.print_eventval ev + +let show_eventval_list el = from_str_formatter Interp.print_eventval_list el + +let show_signature _ = "" + +let show_mem_chunk = function + | AST.Mint8signed -> "Mint8signed" + | AST.Mint8unsigned -> "Mint8unsigned" + | AST.Mint16signed -> "Mint16signed" + | AST.Mint16unsigned -> "Mint16unsigned" + | AST.Mint32 -> "Mint32" + | AST.Mint64 -> "Mint64" + | AST.Mfloat32 -> "Mfloat32" + | AST.Mfloat64 -> "Mfloat64" + | AST.Many32 -> "Many32" + | AST.Many64 -> "Many64" + +let show_block b = fmt "%d" (Camlcoq.P.to_int b) + +let show_coq_z z = fmt "%d" (Camlcoq.Z.to_int z) + +let show_float f = "" + +let show_coq_val = function + | Values.Vundef -> "undef" + | Values.Vint i -> fmt "%s" (show_coq_z i) + | Values.Vlong i -> fmt "%s" (show_coq_z i) + | Values.Vfloat f -> fmt "%s" (show_float f) + | Values.Vsingle f -> fmt "%s" (show_float f) + | Values.Vptr (b, o) -> fmt "(%s, %s)" (show_block b) (show_coq_z o) + +let show_comp = function + | AST.COMP.Coq_bottom' -> "_bottom_" + | AST.COMP.Coq_top' -> "_top_" + | AST.COMP.Comp i -> show_ident i + +let show_nat n = fmt "%d" (Camlcoq.Nat.to_int n) + +let show_quantity = function + | Memdata.Q32 -> "Q32" + | Memdata.Q64 -> "Q64" + +let show_memval = function + | Memdata.Undef -> "Undef" + | Memdata.Byte b -> fmt "%s" (show_coq_z b) + | Memdata.Fragment (cv, q, n) -> fmt "(%s, %s, %s)" (show_coq_val cv) (show_quantity q) (show_nat n) + +let show_memval_list mvl = String.concat "\n" (List.map show_memval mvl) + +let show_mem_delta_storev (((chunk, addr), value), comp) = + fmt "{ Storev | chunk = %s; addr = %s; value = %s; comp = %s }" + (show_mem_chunk chunk) + (show_coq_val addr) + (show_coq_val value) + (show_comp comp) + +let show_mem_delta_store ((((chunk, block), offset), value), comp) = + fmt "{ Store | chunk = %s; block = %s; offset = %s, value = %s; comp = %s }" + (show_mem_chunk chunk) + (show_block block) + (show_coq_z offset) + (show_coq_val value) + (show_comp comp) + +let show_mem_delta_bytes (((block, offset), bytes), comp) = + fmt "{ Bytes | block = %s; offset = %s, bytes = %s; comp = %s }" + (show_block block) + (show_coq_z offset) + (show_memval_list bytes) + (show_comp comp) + +let show_mem_delta_alloc ((comp, lower), upper) = + fmt "{ Alloc | comp = %s; lower = %s; upper = %s }" + (show_comp comp) + (show_coq_z lower) + (show_coq_z upper) + +let show_mem_delta_free (((block, lower), upper), comp) = + fmt "{ Free | block = %s; comp = %s; lower = %s; upper = %s }" + (show_block block) + (show_coq_z lower) + (show_coq_z upper) + (show_comp comp) + +let show_mem_delta_kind mdk = + let open MemoryDelta in + match mdk with + | Coq_mem_delta_kind_storev md -> show_mem_delta_storev md + | Coq_mem_delta_kind_store md -> show_mem_delta_store md + | Coq_mem_delta_kind_bytes md -> show_mem_delta_bytes md + | Coq_mem_delta_kind_alloc md -> show_mem_delta_alloc md + | Coq_mem_delta_kind_free md -> show_mem_delta_free md + +let show_memdelta md = fmt "[\n%s\n ]" (String.concat "\n" (List.map show_mem_delta_kind md)) + +let show_external_func _ = "" + +let show_bundle_event e = + let open BtInfoAsm in + match e with + | _, Bundle_call (subtrace, ident, args, sign, memdelta) -> + fmt "Call\n subtrace: %s\n ident: %s\n args:%s\n signature: %s\n mem_delta: %s\n" + (show_trace subtrace) + (show_ident ident) + (show_eventval_list args) + (show_signature sign) + (show_memdelta memdelta) + | _, Bundle_return (subtrace, ret_val, memdelta) -> + fmt "Ret\n subtrace: %s\n ret_val: %s\n mem_delta: %s\n" + (show_trace subtrace) + (show_eventval ret_val) + (show_memdelta memdelta) + | _, Bundle_builtin (subtrace, external_func, args, memdelta) -> + fmt "Builtin\n subtrace: %s\n external_func: %s\n arg: %s\n mem_delta: %s\n" + (show_trace subtrace) + (show_external_func external_func) + (show_eventval_list args) + (show_memdelta memdelta) + +let show_bundle_trace t = String.concat "\n" (List.map show_bundle_event t) + +let show_c_light_program prog = + let version = PrintClight.Clight1 in + from_str_formatter (PrintClight.print_program version) prog diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 72e63b1465..8f579bb06f 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -1,6 +1,6 @@ (* QCheck testing *) let property_under_test asm_prog bundled_trace = - let () = print_endline (Print.print_bundle_trace bundled_trace) in + let () = print_endline (Show.show_bundle_trace bundled_trace) in let source_name = "out.c" in let ccomp_cmd = "../../ccomp -quiet > /dev/null 2> /dev/null" in let ccomp_cmd = "../../ccomp" in @@ -12,7 +12,7 @@ let property_under_test asm_prog bundled_trace = | WSIGNALED _ | WSTOPPED _ -> false let bundle_trace ctx = - QCheck.make ~print:Print.print_bundle_trace (Gen.bundle_trace ctx) + QCheck.make ~print:Show.show_bundle_trace (Gen.bundle_trace ctx) let test_backtranslation asm_prog ctx = QCheck.Test.make ~count:1 ~name:"backtranslation" (bundle_trace ctx) From b7c9f874ff55f9e8cc85be7d38c0e17773f7fb8a Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 15 Dec 2023 12:08:55 +0100 Subject: [PATCH 43/83] Add global variables to the context and the ASM program --- test/backtranslation/Gen.ml | 20 +++++- test/backtranslation/Gen_ctx.ml | 70 +++++++++++++++++++- test/backtranslation/Gen_ctx.mli | 5 ++ test/backtranslation/test_backtranslation.ml | 2 + 4 files changed, 94 insertions(+), 3 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index d6d2bda06f..b437c7ced2 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -14,6 +14,7 @@ let memory_chunk = (1, Many64); ] +(* TODO: move these and others to a common file because they are also needed in Gen_ctx *) let positive = QCheck.Gen.(map (fun i -> Camlcoq.P.of_int (i + 1)) small_nat) let coq_Z = QCheck.Gen.(map (fun i -> Camlcoq.Z.of_sint i) small_signed_int) let ident = positive @@ -253,7 +254,7 @@ let bundle_trace ctx rand_state = let f = float_range 0.0 1.0 rand_state in match f with (* TODO: also generate builtin events in the trace (for now the test fails) *) - | _ when f < 0.6 -> ( + | _ when f <= 1.0 -> ( match bundle_call_ret ctx curr_comp rand_state with | Option.None -> [] | Option.Some (call, ret, trgt_comp) -> @@ -268,7 +269,22 @@ let bundle_trace ctx rand_state = List.mapi (fun i be -> (Camlcoq.P.of_int (i+1), be)) (bundle_trace_aux main_comp size) let build_prog_defs ctx = - let gvars = [] in + let raw_gvars = Gen_ctx.var_list ctx in + let gvars = + List.map + (fun (c, v, init, read_only, volatile) -> + let globvar = AST.{ + gvar_info = (); + gvar_comp = AST.COMP.Comp (Camlcoq.P.of_int c); + gvar_init = init; + gvar_readonly = read_only; + gvar_volatile = volatile; + } + in + (Camlcoq.P.of_int v, AST.Gvar globvar) + ) + raw_gvars + in let raw_defs = Gen_ctx.def_list ctx in let gfuns = List.map diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index 30e5b82ce5..8d607cb7e1 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -10,6 +10,7 @@ type t = { imports : imports; func_sigs : func_sigs; main : int; + glob_vars : (int * AST.init_data list * bool * bool) list Map.t; external_funcs : extern list; builtins: extern list; runtime_funcs : extern list; @@ -22,12 +23,15 @@ type gen_config = { num_external_funcs : int; num_builtins : int; num_runtime_funcs: int; + num_global_vars : int; + global_var_max_size : int; max_arg_count : int; debug : bool; } type comp = int type func = int +type var = int let sample_typ = QCheck.Gen.frequencyl @@ -82,6 +86,62 @@ let sample_exports config graph = let* funcs = Util.choose_disjoint n config.num_exported_funcs pool in return (Map.of_seq (List.to_seq (List.combine compartments funcs))) +(* TODO: implement me properly *) +let sample_init_data config = + let open QCheck.Gen in + let positive = QCheck.Gen.(map (fun i -> Camlcoq.P.of_int (i + 1)) small_nat) in + let coq_Z = map (fun i -> Camlcoq.Z.of_sint i) small_signed_int in + let binary_float = + let open Binary in + let zero = map (fun b -> B754_zero b) bool in + let infinity = map (fun b -> B754_infinity b) bool in + let nan = map (fun (b, p) -> B754_nan (b, p)) (pair bool positive) in + let finite = + map (fun (b, p, z) -> B754_finite (b, p, z)) (triple bool positive coq_Z) + in frequency [ (1, zero); (1, infinity); (1, nan); (1, finite) ] + in + let int8 = map (fun i -> AST.Init_int8 (Camlcoq.Z.of_sint i)) small_int in + let int16 = map (fun i -> AST.Init_int16 (Camlcoq.Z.of_sint i)) small_int in + let int32 = map (fun i -> AST.Init_int32 (Camlcoq.Z.of_sint i)) small_int in + let int64 = map (fun i -> AST.Init_int64 (Camlcoq.Z.of_sint i)) small_int in + let float32 = map (fun f -> AST.Init_float32 f) binary_float in + let float64 = map (fun f -> AST.Init_float64 f) binary_float in + let space = map (fun i -> AST.Init_space (Camlcoq.Z.of_uint i)) small_nat in + let addrof = + (* TODO: only use valid global variables as ids here? *) + let* id = map (fun i -> Camlcoq.P.of_int (i + 1)) small_nat in + let* offset = map (fun i -> Integers.Ptrofs.of_int (Camlcoq.Z.of_sint i)) small_signed_int in + return (AST.Init_addrof (id, offset)) + in + QCheck.Gen.frequency + [ + (1, int8); + (1, int16); + (1, int32); + (1, int64); + (* TODO: actually generate the variants below as soon as they are implemented in PrintAsm.ml *) + (* (1, float32); + (1, float64); + (1, space); + (1, addrof);*) + ] + +let sample_init_data_list config = + QCheck.Gen.(list_size (int_bound config.global_var_max_size) (sample_init_data config)) + +let sample_global_vars config graph exports rand_state = + let open QCheck.Gen in + let compartments = Graph.vertices graph in + let n = Graph.size graph in + let all_funcs = List.concat_map snd (Map.bindings exports) in + let max_func_ident = List.fold_left Int.max 0 all_funcs in + let pool = List.init (n * config.num_global_vars) (fun i -> i + 1 + max_func_ident) in + let read_only = (map (fun f -> f <= 0.3) (float_range 0.0 1.0)) rand_state in + let volatile = (map (fun f -> f <= 0.3) (float_range 0.0 1.0)) rand_state in + let pool_with_init_data = List.map (fun g -> (g, sample_init_data_list config rand_state, read_only, volatile)) pool in + let glob_vars = Util.choose_disjoint n config.num_global_vars pool_with_init_data rand_state in + Map.of_seq (List.to_seq (List.combine compartments glob_vars)) + let sample_imports graph exports rand_state = let open QCheck.Gen in let distribute (x, ys) = List.map (fun y -> (x, y)) ys in @@ -163,12 +223,13 @@ let random config = let* builtins = sample_builtins config in let* runtime_funcs = sample_runtime_funcs config in let* main, func_sigs = sample_func_sigs config exports in + let* glob_vars = sample_global_vars config graph exports in if config.debug then ( Graph.dump graph; dump_exports exports; dump_imports imports) else (); - return { exports; imports; func_sigs; main; external_funcs; builtins; runtime_funcs } + return { exports; imports; func_sigs; main; glob_vars; external_funcs; builtins; runtime_funcs } let main ctx = ctx.main let function_list ctx = List.concat_map snd (Map.bindings ctx.exports) @@ -182,6 +243,13 @@ let def_list ctx = (fun (c, fs) -> List.map (fun f -> (f, c, sig_of f)) fs) (export_list ctx) +let var_list ctx = + List.concat_map + (fun (comp, vars) -> List.map + (fun (id, init_datas, read_only, volatile) -> (comp, id, init_datas, read_only, volatile)) + vars) + (Map.bindings ctx.glob_vars) + let external_funcs ctx = ctx.external_funcs let builtins ctx = ctx.builtins let runtime_funcs ctx = ctx.runtime_funcs diff --git a/test/backtranslation/Gen_ctx.mli b/test/backtranslation/Gen_ctx.mli index b99a413ee1..e6d13c594e 100644 --- a/test/backtranslation/Gen_ctx.mli +++ b/test/backtranslation/Gen_ctx.mli @@ -9,12 +9,15 @@ type gen_config = { num_external_funcs : int; num_builtins : int; num_runtime_funcs : int; + num_global_vars : int; + global_var_max_size : int; max_arg_count : int; debug : bool; } type comp = int type func = int +type var = int val random : gen_config -> Random.State.t -> t val main : t -> func @@ -24,6 +27,8 @@ val export_list : t -> (comp * func list) list val import_list : t -> (comp * (comp * func) list) list val def_list : t -> (func * comp * AST.signature) list +val var_list : t -> (comp * var * AST.init_data list * bool * bool) list + val external_funcs : t -> AST.external_function list val builtins : t -> AST.external_function list val runtime_funcs : t -> AST.external_function list diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 8f579bb06f..826a28011e 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -43,6 +43,8 @@ let _ = num_external_funcs = 4; num_builtins = 4; num_runtime_funcs = 4; + num_global_vars = 4; + global_var_max_size = 4; max_arg_count = 2; debug = debug; } From 0734131aaff0227210eb4e84f8686ec3ecd46d08 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 15 Dec 2023 14:05:56 +0100 Subject: [PATCH 44/83] Ensure that all global variables are void* to avoid "incomplete type" errors --- test/backtranslation/Export.ml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/test/backtranslation/Export.ml b/test/backtranslation/Export.ml index 4b3437f2e4..3863567112 100644 --- a/test/backtranslation/Export.ml +++ b/test/backtranslation/Export.ml @@ -16,6 +16,13 @@ let rename_idents code = let prepend_header code = "#include \n" ^ code +let fix_incomplete_types code = + let r_internal = Str.regexp "^void \\(ident_[0-9]+ = {\\)" in + let r_external = Str.regexp "^extern void" in + code + |> Str.global_replace r_internal "void* \\1" + |> Str.global_replace r_external "extern void*" + let c_light_prog prog file_name = let vars_before_funcs (_, def1) (_, def2) = let open AST in @@ -32,6 +39,7 @@ let c_light_prog prog file_name = |> rename_main main |> rename_idents |> rename_special_floating_point_values - |> prepend_header in + |> prepend_header + |> fix_incomplete_types in Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); Out_channel.with_open_text file_name (fun c -> output_string c code) From 6e9fea4daf7a81d638229840139253f3a64ab396 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 15 Dec 2023 14:10:09 +0100 Subject: [PATCH 45/83] Fix renaming to float constants in math.h --- test/backtranslation/Export.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/backtranslation/Export.ml b/test/backtranslation/Export.ml index 3863567112..2170283e0c 100644 --- a/test/backtranslation/Export.ml +++ b/test/backtranslation/Export.ml @@ -1,6 +1,6 @@ let rename_special_floating_point_values code = - let r_inf = Str.regexp "inf" in - let r_nan = Str.regexp "nan" in + let r_inf = Str.regexp "\\(inf \| inff\\)" in + let r_nan = Str.regexp "\\(nan \| nanf\\)" in code |> Str.global_replace r_inf "INFINITY" |> Str.global_replace r_nan "NAN" From b9e2d4ac4c46290fb41aaf7c34472fd9ee01cc33 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 15 Dec 2023 14:55:26 +0100 Subject: [PATCH 46/83] Only use identifiers of global vars in generatied mem_deltas --- test/backtranslation/Gen.ml | 45 ++++++++++++++++++++----------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index b437c7ced2..77c0ef5921 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -69,59 +69,62 @@ let coq_val = (1, vptr); ] -let mem_delta_storev ctx = +let mem_delta_storev curr_comp ctx = let open QCheck.Gen in let* chunk = memory_chunk in - let* block = positive in + let glob_vars = List.map (fun (_, v, _, _, _) -> v) (Gen_ctx.var_list ctx) in + let* block = map Camlcoq.P.of_int (oneofl glob_vars) in let* offset = ptrofs in let addr = Values.Vptr (block, offset) in - let* comp = compartment in let* value = coq_val in + let comp = AST.COMP.Comp (Camlcoq.P.of_int curr_comp) in return (MemoryDelta.Coq_mem_delta_kind_storev (((chunk, addr), value), comp)) -let mem_delta_store ctx = +let mem_delta_store curr_comp ctx = let open QCheck.Gen in let* chunk = memory_chunk in - let* block = positive in + let glob_vars = List.map (fun (_, v, _, _, _) -> v) (Gen_ctx.var_list ctx) in + let* block = map Camlcoq.P.of_int (oneofl glob_vars) in let* offset = ptrofs in - let* comp = compartment in let* value = coq_val in + let comp = AST.COMP.Comp (Camlcoq.P.of_int curr_comp) in return (MemoryDelta.Coq_mem_delta_kind_store ((((chunk, block), offset), value), comp)) -let mem_delta_bytes ctx = +let mem_delta_bytes curr_comp ctx = let open QCheck.Gen in let* block = positive in let* offset = ptrofs in let* bytes = small_list (mem_val ctx) in - let* comp = compartment in + let comp = AST.COMP.Comp (Camlcoq.P.of_int curr_comp) in return (MemoryDelta.Coq_mem_delta_kind_bytes (((block, offset), bytes), comp)) -let mem_delta_alloc ctx = +let mem_delta_alloc curr_comp ctx = let open QCheck.Gen in - let* comp = compartment in let* lower = map Camlcoq.Z.of_uint small_nat in let* len = map Camlcoq.Z.of_uint small_nat in + let comp = AST.COMP.Comp (Camlcoq.P.of_int curr_comp) in return (MemoryDelta.Coq_mem_delta_kind_alloc ((comp, lower), Camlcoq.Z.add lower len)) -let mem_delta_free ctx = +let mem_delta_free curr_comp ctx = let open QCheck.Gen in let* block = positive in let* lower = map Camlcoq.Z.of_uint small_nat in let* len = map Camlcoq.Z.of_uint small_nat in - let* comp = compartment in + let comp = AST.COMP.Comp (Camlcoq.P.of_int curr_comp) in return (MemoryDelta.Coq_mem_delta_kind_free (((block, lower), Camlcoq.Z.add lower len), comp)) -let mem_delta_kind ctx = +let mem_delta_kind curr_comp ctx = QCheck.Gen.frequency [ - (1, mem_delta_storev ctx); - (1, mem_delta_store ctx); - (*(1, mem_delta_bytes ctx); - (1, mem_delta_alloc ctx); - (1, mem_delta_free ctx);*) + (* TODO: actually, only storev deltas are considered in BT. Check this and simplify the code *) + (1, mem_delta_storev curr_comp ctx); + (1, mem_delta_store curr_comp ctx); + (*(1, mem_delta_bytes curr_comp ctx); + (1, mem_delta_alloc curr_comp ctx); + (1, mem_delta_free curr_comp ctx);*) ] -let mem_delta ctx = QCheck.Gen.small_list (mem_delta_kind ctx) +let mem_delta curr_comp ctx = QCheck.Gen.small_list (mem_delta_kind curr_comp ctx) let ef_external ctx = QCheck.Gen.oneofl (Gen_ctx.external_funcs ctx) @@ -230,8 +233,8 @@ let bundle_call_ret ctx curr_comp rand_state = let ret_val = ret_val_for_sig sign rand_state in let subtrace_call = [] in let subtrace_ret = [] in - let mdelta_call = mem_delta ctx rand_state in - let mdelta_ret = mem_delta ctx rand_state in + let mdelta_call = mem_delta curr_comp ctx rand_state in + let mdelta_ret = mem_delta trgt_comp ctx rand_state in let call = BtInfoAsm.Bundle_call (subtrace_call, Camlcoq.P.of_int trgt_func, args, sign, mdelta_call) in let ret = BtInfoAsm.Bundle_return (subtrace_ret, ret_val, mdelta_ret) in Option.some (call, ret, trgt_comp) From 5b7045709c5900c3653d70c541b0912136e7a0ea Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 15 Dec 2023 16:14:53 +0100 Subject: [PATCH 47/83] Mark global variables as public in ASM program --- test/backtranslation/Gen.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index 77c0ef5921..f72c4bd230 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -303,7 +303,8 @@ let build_prog_defs ctx = gvars @ gfuns let build_prog_public ctx = - List.map Camlcoq.P.of_int (Gen_ctx.function_list ctx) + List.map Camlcoq.P.of_int (Gen_ctx.function_list ctx) @ + List.map (fun (_, v, _, _, _) -> Camlcoq.P.of_int v) (Gen_ctx.var_list ctx) let build_prog_main ctx = Camlcoq.P.of_int (Gen_ctx.main ctx) From dabf3c88141bd91196ecdb642b9c19157e792cdd Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 18 Dec 2023 11:41:25 +0100 Subject: [PATCH 48/83] Find block for each global var to ensure the inversion in BT works --- test/backtranslation/Gen.ml | 85 ++------------------ test/backtranslation/Gen.mli | 2 - test/backtranslation/Gen_ctx.ml | 72 +++++++++++++++++ test/backtranslation/Gen_ctx.mli | 2 + test/backtranslation/test_backtranslation.ml | 3 +- 5 files changed, 84 insertions(+), 80 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index f72c4bd230..3553fa9d99 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -73,7 +73,14 @@ let mem_delta_storev curr_comp ctx = let open QCheck.Gen in let* chunk = memory_chunk in let glob_vars = List.map (fun (_, v, _, _, _) -> v) (Gen_ctx.var_list ctx) in - let* block = map Camlcoq.P.of_int (oneofl glob_vars) in + let* ident = map Camlcoq.P.of_int (oneofl glob_vars) in + + let asm_prog = Gen_ctx.get_asm_prog ctx in + let genv = Globalenvs.Genv.globalenv asm_prog in + let block = match Globalenvs.Genv.find_symbol genv ident with + | None -> failwith "Fatal error: cannot find block for symbol for mem_delta" + | Some b -> b + in let* offset = ptrofs in let addr = Values.Vptr (block, offset) in let* value = coq_val in @@ -270,79 +277,3 @@ let bundle_trace ctx rand_state = in let main_comp = 1 in (* TODO: get the compartment of the main function *) List.mapi (fun i be -> (Camlcoq.P.of_int (i+1), be)) (bundle_trace_aux main_comp size) - -let build_prog_defs ctx = - let raw_gvars = Gen_ctx.var_list ctx in - let gvars = - List.map - (fun (c, v, init, read_only, volatile) -> - let globvar = AST.{ - gvar_info = (); - gvar_comp = AST.COMP.Comp (Camlcoq.P.of_int c); - gvar_init = init; - gvar_readonly = read_only; - gvar_volatile = volatile; - } - in - (Camlcoq.P.of_int v, AST.Gvar globvar) - ) - raw_gvars - in - let raw_defs = Gen_ctx.def_list ctx in - let gfuns = - List.map - (fun (f, c, s) -> - let coq_func = - ({ fn_comp = AST.COMP.Comp (Camlcoq.P.of_int c); fn_sig = s; fn_code = [] } - : Asm.coq_function) - in - let fundef = AST.Internal coq_func in - (Camlcoq.P.of_int f, AST.Gfun fundef)) - raw_defs - in - gvars @ gfuns - -let build_prog_public ctx = - List.map Camlcoq.P.of_int (Gen_ctx.function_list ctx) @ - List.map (fun (_, v, _, _, _) -> Camlcoq.P.of_int v) (Gen_ctx.var_list ctx) - -let build_prog_main ctx = Camlcoq.P.of_int (Gen_ctx.main ctx) - -let build_prog_pol ctx = - let open Maps in - let policy_export = ref PTree.empty in - let exports = Gen_ctx.export_list ctx in - List.iter - (fun (raw_comp, raw_funcs) -> - let funcs = List.map Camlcoq.P.of_int raw_funcs in - let comp = Camlcoq.P.of_int raw_comp in - policy_export := PTree.set comp funcs !policy_export) - exports; - let policy_import = ref PTree.empty in - let imports = Gen_ctx.import_list ctx in - List.iter - (fun (comp, imps) -> - let imps = - List.map (fun (c, f) -> (AST.COMP.Comp (Camlcoq.P.of_int c), Camlcoq.P.of_int f)) imps - in - let comp = Camlcoq.P.of_int comp in - if imps <> [] then policy_import := PTree.set comp imps !policy_import - else ()) - imports; - let policy = - ({ policy_export = !policy_export; policy_import = !policy_import } - : AST.Policy.t) - in - policy - -let asm_program config = - let open QCheck.Gen in - let* ctx = Gen_ctx.random config in - let prog_defs = build_prog_defs ctx in - let prog_public = build_prog_public ctx in - let prog_main = build_prog_main ctx in - let prog_pol = build_prog_pol ctx in - let asm_prog = - ({ prog_defs; prog_public; prog_main; prog_pol } : Asm.program) - in - return (asm_prog, ctx) diff --git a/test/backtranslation/Gen.mli b/test/backtranslation/Gen.mli index 7a4f1510f3..2f43572faf 100644 --- a/test/backtranslation/Gen.mli +++ b/test/backtranslation/Gen.mli @@ -1,3 +1 @@ -(*val trace : Events.event list QCheck.Gen.t *) val bundle_trace : Gen_ctx.t -> BtInfoAsm.bundle_trace QCheck.Gen.t -val asm_program : Gen_ctx.gen_config -> (Asm.program * Gen_ctx.t) QCheck.Gen.t diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index 8d607cb7e1..8d0a5a7cff 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -253,3 +253,75 @@ let var_list ctx = let external_funcs ctx = ctx.external_funcs let builtins ctx = ctx.builtins let runtime_funcs ctx = ctx.runtime_funcs + +let build_prog_defs ctx = + let raw_gvars = var_list ctx in + let gvars = + List.map + (fun (c, v, init, read_only, volatile) -> + let globvar = AST.{ + gvar_info = (); + gvar_comp = AST.COMP.Comp (Camlcoq.P.of_int c); + gvar_init = init; + gvar_readonly = read_only; + gvar_volatile = volatile; + } + in + (Camlcoq.P.of_int v, AST.Gvar globvar) + ) + raw_gvars + in + let raw_defs = def_list ctx in + let gfuns = + List.map + (fun (f, c, s) -> + let coq_func = + ({ fn_comp = AST.COMP.Comp (Camlcoq.P.of_int c); fn_sig = s; fn_code = [] } + : Asm.coq_function) + in + let fundef = AST.Internal coq_func in + (Camlcoq.P.of_int f, AST.Gfun fundef)) + raw_defs + in + gvars @ gfuns + +let build_prog_public ctx = + List.map Camlcoq.P.of_int (function_list ctx) @ + List.map (fun (_, v, _, _, _) -> Camlcoq.P.of_int v) (var_list ctx) + +let build_prog_main ctx = Camlcoq.P.of_int (main ctx) + +let build_prog_pol ctx = + let open Maps in + let policy_export = ref PTree.empty in + let exports = export_list ctx in + List.iter + (fun (raw_comp, raw_funcs) -> + let funcs = List.map Camlcoq.P.of_int raw_funcs in + let comp = Camlcoq.P.of_int raw_comp in + policy_export := PTree.set comp funcs !policy_export) + exports; + let policy_import = ref PTree.empty in + let imports = import_list ctx in + List.iter + (fun (comp, imps) -> + let imps = + List.map (fun (c, f) -> (AST.COMP.Comp (Camlcoq.P.of_int c), Camlcoq.P.of_int f)) imps + in + let comp = Camlcoq.P.of_int comp in + if imps <> [] then policy_import := PTree.set comp imps !policy_import + else ()) + imports; + let policy = + ({ policy_export = !policy_export; policy_import = !policy_import } + : AST.Policy.t) + in + policy + +let get_asm_prog ctx = + let prog_defs = build_prog_defs ctx in + let prog_public = build_prog_public ctx in + let prog_main = build_prog_main ctx in + let prog_pol = build_prog_pol ctx in + AST.{ prog_defs; prog_public; prog_main; prog_pol } + diff --git a/test/backtranslation/Gen_ctx.mli b/test/backtranslation/Gen_ctx.mli index e6d13c594e..29d5639f27 100644 --- a/test/backtranslation/Gen_ctx.mli +++ b/test/backtranslation/Gen_ctx.mli @@ -32,3 +32,5 @@ val var_list : t -> (comp * var * AST.init_data list * bool * bool) list val external_funcs : t -> AST.external_function list val builtins : t -> AST.external_function list val runtime_funcs : t -> AST.external_function list + +val get_asm_prog : t -> Asm.program diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 826a28011e..8ba1578693 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -51,6 +51,7 @@ let _ = in let () = if seed = 0 then Random.self_init () else Random.init seed in let rand_state = Random.get_state () in - let asm_prog, ctx = Gen.asm_program config rand_state in + let ctx = Gen_ctx.random config rand_state in + let asm_prog = Gen_ctx.get_asm_prog ctx in if debug then PrintAsm.print_program_asm Out_channel.stdout asm_prog else (); QCheck_runner.run_tests ~verbose:true ~rand:rand_state [ test_backtranslation asm_prog ctx ] From 59912cb778ffbfe4736f994ff0eb81fc8cb2fcb9 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 18 Dec 2023 12:20:30 +0100 Subject: [PATCH 49/83] Avoid linker errors for external symbols --- test/backtranslation/test_backtranslation.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 8ba1578693..4ff4041949 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -2,8 +2,8 @@ let property_under_test asm_prog bundled_trace = let () = print_endline (Show.show_bundle_trace bundled_trace) in let source_name = "out.c" in - let ccomp_cmd = "../../ccomp -quiet > /dev/null 2> /dev/null" in - let ccomp_cmd = "../../ccomp" in + let ccomp_cmd = "../../ccomp -quiet -c > /dev/null 2> /dev/null" in + let ccomp_cmd = "../../ccomp -c" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in let () = Export.c_light_prog src_program source_name in let status = Unix.system (ccomp_cmd ^ " " ^ source_name) in From 9128c306883d39e011749cc6364ba744d35b759c Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 18 Dec 2023 12:20:55 +0100 Subject: [PATCH 50/83] Improve exporting/post-processing to fix more errors --- test/backtranslation/Export.ml | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/test/backtranslation/Export.ml b/test/backtranslation/Export.ml index 2170283e0c..667c710034 100644 --- a/test/backtranslation/Export.ml +++ b/test/backtranslation/Export.ml @@ -1,6 +1,6 @@ let rename_special_floating_point_values code = - let r_inf = Str.regexp "\\(inf \| inff\\)" in - let r_nan = Str.regexp "\\(nan \| nanf\\)" in + let r_inf = Str.regexp "\\(inff\\|inf\\)" in + let r_nan = Str.regexp "\\(nanf\\|nan\\)" in code |> Str.global_replace r_inf "INFINITY" |> Str.global_replace r_nan "NAN" @@ -17,12 +17,21 @@ let prepend_header code = "#include \n" ^ code let fix_incomplete_types code = + let r_internal_const = Str.regexp "^void const \\(ident_[0-9]+ = {\\)" in let r_internal = Str.regexp "^void \\(ident_[0-9]+ = {\\)" in let r_external = Str.regexp "^extern void" in code + |> Str.global_replace r_internal_const "void* const \\1" |> Str.global_replace r_internal "void* \\1" |> Str.global_replace r_external "extern void*" +let fix_floating_point_literals code = + let regex = Str.regexp "\\([0-9]+\\)f" in + let regex_exp = Str.regexp "e\\(-?\\)\\([0-9]+\\)\\.0f" in + code + |> Str.global_replace regex "\\1.0f" + |> Str.global_replace regex_exp "e\\1\\2" + let c_light_prog prog file_name = let vars_before_funcs (_, def1) (_, def2) = let open AST in @@ -40,6 +49,7 @@ let c_light_prog prog file_name = |> rename_idents |> rename_special_floating_point_values |> prepend_header - |> fix_incomplete_types in + |> fix_incomplete_types + |> fix_floating_point_literals in Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); Out_channel.with_open_text file_name (fun c -> output_string c code) From 5449c0735d7cd255d1db9e1c6981c37a74767a0a Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 18 Dec 2023 12:55:58 +0100 Subject: [PATCH 51/83] Always print a global root seed for reproducibility --- test/backtranslation/test_backtranslation.ml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 4ff4041949..274fc4c118 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -49,7 +49,15 @@ let _ = debug = debug; } in - let () = if seed = 0 then Random.self_init () else Random.init seed in + let () = + if seed = 0 + then + (Random.self_init (); + let s = Random.full_int 10000 in + Printf.printf "seed = %d\n" s; + Random.init s) + else Random.init seed + in let rand_state = Random.get_state () in let ctx = Gen_ctx.random config rand_state in let asm_prog = Gen_ctx.get_asm_prog ctx in From fb628b9bb38ada44adeafd185138ec1c9c1c7313 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 18 Dec 2023 13:36:20 +0100 Subject: [PATCH 52/83] Ensure that pointer values in mem_deltas refer to valid global vars --- test/backtranslation/Gen.ml | 41 ++++++++++++++++++++++--------------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index 3553fa9d99..132772e39a 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -42,31 +42,38 @@ let mem_val ctx = (* TODO: add support for fragment memory values *) ] -let vundef = QCheck.Gen.return Values.Vundef +let vundef _ = QCheck.Gen.return Values.Vundef -let vint = QCheck.Gen.map (fun i -> Values.Vint i) coq_Z +let vint _ = QCheck.Gen.map (fun i -> Values.Vint i) coq_Z -let vlong = QCheck.Gen.map (fun i -> Values.Vlong i) coq_Z +let vlong _ = QCheck.Gen.map (fun i -> Values.Vlong i) coq_Z -let vfloat = QCheck.Gen.map (fun f -> Values.Vfloat f) binary_float +let vfloat _ = QCheck.Gen.map (fun f -> Values.Vfloat f) binary_float -let vsingle = QCheck.Gen.map (fun f -> Values.Vsingle f) binary_float +let vsingle _ = QCheck.Gen.map (fun f -> Values.Vsingle f) binary_float -let vptr = +let vptr ctx = let open QCheck.Gen in - let* block = positive in + let glob_vars = List.map (fun (_, v, _, _, _) -> v) (Gen_ctx.var_list ctx) in + let* ident = map Camlcoq.P.of_int (oneofl glob_vars) in + let asm_prog = Gen_ctx.get_asm_prog ctx in + let genv = Globalenvs.Genv.globalenv asm_prog in + let block = match Globalenvs.Genv.find_symbol genv ident with + | None -> failwith "Fatal error: cannot find block for symbol for vptr." + | Some b -> b + in let* ptrofs = ptrofs in return (Values.Vptr (block, ptrofs)) -let coq_val = +let coq_val ctx = QCheck.Gen.frequency [ - (1, vundef); - (1, vint); - (1, vlong); - (1, vfloat); - (1, vsingle); - (1, vptr); + (1, vundef ctx); + (1, vint ctx); + (1, vlong ctx); + (1, vfloat ctx); + (1, vsingle ctx); + (1, vptr ctx); ] let mem_delta_storev curr_comp ctx = @@ -83,7 +90,7 @@ let mem_delta_storev curr_comp ctx = in let* offset = ptrofs in let addr = Values.Vptr (block, offset) in - let* value = coq_val in + let* value = coq_val ctx in let comp = AST.COMP.Comp (Camlcoq.P.of_int curr_comp) in return (MemoryDelta.Coq_mem_delta_kind_storev (((chunk, addr), value), comp)) @@ -93,7 +100,7 @@ let mem_delta_store curr_comp ctx = let glob_vars = List.map (fun (_, v, _, _, _) -> v) (Gen_ctx.var_list ctx) in let* block = map Camlcoq.P.of_int (oneofl glob_vars) in let* offset = ptrofs in - let* value = coq_val in + let* value = coq_val ctx in let comp = AST.COMP.Comp (Camlcoq.P.of_int curr_comp) in return (MemoryDelta.Coq_mem_delta_kind_store ((((chunk, block), offset), value), comp)) @@ -125,7 +132,7 @@ let mem_delta_kind curr_comp ctx = [ (* TODO: actually, only storev deltas are considered in BT. Check this and simplify the code *) (1, mem_delta_storev curr_comp ctx); - (1, mem_delta_store curr_comp ctx); + (*(1, mem_delta_store curr_comp ctx);*) (*(1, mem_delta_bytes curr_comp ctx); (1, mem_delta_alloc curr_comp ctx); (1, mem_delta_free curr_comp ctx);*) From 5fe8f22e5e97050e88757514d861a517b20e314d Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 18 Dec 2023 14:21:35 +0100 Subject: [PATCH 53/83] Ensure that we only write to non-const global variables --- test/backtranslation/Gen.ml | 4 ++-- test/backtranslation/Gen_ctx.ml | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index 132772e39a..ee1ae40fdc 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -79,7 +79,7 @@ let coq_val ctx = let mem_delta_storev curr_comp ctx = let open QCheck.Gen in let* chunk = memory_chunk in - let glob_vars = List.map (fun (_, v, _, _, _) -> v) (Gen_ctx.var_list ctx) in + let glob_vars = List.filter_map (fun (_, v, _, read_only, _) -> if read_only then Option.none else Option.some v) (Gen_ctx.var_list ctx) in let* ident = map Camlcoq.P.of_int (oneofl glob_vars) in let asm_prog = Gen_ctx.get_asm_prog ctx in @@ -97,7 +97,7 @@ let mem_delta_storev curr_comp ctx = let mem_delta_store curr_comp ctx = let open QCheck.Gen in let* chunk = memory_chunk in - let glob_vars = List.map (fun (_, v, _, _, _) -> v) (Gen_ctx.var_list ctx) in + let glob_vars = List.filter_map (fun (_, v, _, read_only, _) -> if read_only then Option.none else Option.some v) (Gen_ctx.var_list ctx) in let* block = map Camlcoq.P.of_int (oneofl glob_vars) in let* offset = ptrofs in let* value = coq_val ctx in diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index 8d0a5a7cff..cbf06b7c12 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -136,9 +136,9 @@ let sample_global_vars config graph exports rand_state = let all_funcs = List.concat_map snd (Map.bindings exports) in let max_func_ident = List.fold_left Int.max 0 all_funcs in let pool = List.init (n * config.num_global_vars) (fun i -> i + 1 + max_func_ident) in - let read_only = (map (fun f -> f <= 0.3) (float_range 0.0 1.0)) rand_state in - let volatile = (map (fun f -> f <= 0.3) (float_range 0.0 1.0)) rand_state in - let pool_with_init_data = List.map (fun g -> (g, sample_init_data_list config rand_state, read_only, volatile)) pool in + let read_only = (map (fun f -> f <= 0.3) (float_range 0.0 1.0)) in + let volatile = (map (fun f -> f <= 0.3) (float_range 0.0 1.0)) in + let pool_with_init_data = List.map (fun g -> (g, sample_init_data_list config rand_state, read_only rand_state, volatile rand_state)) pool in let glob_vars = Util.choose_disjoint n config.num_global_vars pool_with_init_data rand_state in Map.of_seq (List.to_seq (List.combine compartments glob_vars)) From 1d92355ac8535862770d512b56a04f5ab30c129c Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 18 Dec 2023 15:22:40 +0100 Subject: [PATCH 54/83] Fix type errors with more post-processing --- test/backtranslation/Export.ml | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/test/backtranslation/Export.ml b/test/backtranslation/Export.ml index 667c710034..e71a5c756e 100644 --- a/test/backtranslation/Export.ml +++ b/test/backtranslation/Export.ml @@ -21,9 +21,9 @@ let fix_incomplete_types code = let r_internal = Str.regexp "^void \\(ident_[0-9]+ = {\\)" in let r_external = Str.regexp "^extern void" in code - |> Str.global_replace r_internal_const "void* const \\1" - |> Str.global_replace r_internal "void* \\1" - |> Str.global_replace r_external "extern void*" + |> Str.global_replace r_internal_const "int const \\1" + |> Str.global_replace r_internal "int \\1" + |> Str.global_replace r_external "extern int" let fix_floating_point_literals code = let regex = Str.regexp "\\([0-9]+\\)f" in @@ -32,6 +32,10 @@ let fix_floating_point_literals code = |> Str.global_replace regex "\\1.0f" |> Str.global_replace regex_exp "e\\1\\2" +let fix_missing_derefs code = + let regex = Str.regexp "= &\\([^;]+\\);" in + Str.global_replace regex "= *(&\\1);" code + let c_light_prog prog file_name = let vars_before_funcs (_, def1) (_, def2) = let open AST in @@ -50,6 +54,7 @@ let c_light_prog prog file_name = |> rename_special_floating_point_values |> prepend_header |> fix_incomplete_types - |> fix_floating_point_literals in + |> fix_floating_point_literals + |> fix_missing_derefs in Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); Out_channel.with_open_text file_name (fun c -> output_string c code) From 7bf3f17500c6fa7f01c971ee6f587a240c2624c3 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 18 Dec 2023 15:51:02 +0100 Subject: [PATCH 55/83] Fix warning (tests now work also for non-empty memory deltas) --- test/backtranslation/Gen_ctx.ml | 29 ++------------------ test/backtranslation/test_backtranslation.ml | 1 - 2 files changed, 3 insertions(+), 27 deletions(-) diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index cbf06b7c12..6b40d35bdc 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -86,44 +86,21 @@ let sample_exports config graph = let* funcs = Util.choose_disjoint n config.num_exported_funcs pool in return (Map.of_seq (List.to_seq (List.combine compartments funcs))) -(* TODO: implement me properly *) let sample_init_data config = + (* TODO: currently only ints are supported as init data in PrintAsm.ml. + Once this is fixed, the code below can be extended to also generate + the missing types of init data. *) let open QCheck.Gen in - let positive = QCheck.Gen.(map (fun i -> Camlcoq.P.of_int (i + 1)) small_nat) in - let coq_Z = map (fun i -> Camlcoq.Z.of_sint i) small_signed_int in - let binary_float = - let open Binary in - let zero = map (fun b -> B754_zero b) bool in - let infinity = map (fun b -> B754_infinity b) bool in - let nan = map (fun (b, p) -> B754_nan (b, p)) (pair bool positive) in - let finite = - map (fun (b, p, z) -> B754_finite (b, p, z)) (triple bool positive coq_Z) - in frequency [ (1, zero); (1, infinity); (1, nan); (1, finite) ] - in let int8 = map (fun i -> AST.Init_int8 (Camlcoq.Z.of_sint i)) small_int in let int16 = map (fun i -> AST.Init_int16 (Camlcoq.Z.of_sint i)) small_int in let int32 = map (fun i -> AST.Init_int32 (Camlcoq.Z.of_sint i)) small_int in let int64 = map (fun i -> AST.Init_int64 (Camlcoq.Z.of_sint i)) small_int in - let float32 = map (fun f -> AST.Init_float32 f) binary_float in - let float64 = map (fun f -> AST.Init_float64 f) binary_float in - let space = map (fun i -> AST.Init_space (Camlcoq.Z.of_uint i)) small_nat in - let addrof = - (* TODO: only use valid global variables as ids here? *) - let* id = map (fun i -> Camlcoq.P.of_int (i + 1)) small_nat in - let* offset = map (fun i -> Integers.Ptrofs.of_int (Camlcoq.Z.of_sint i)) small_signed_int in - return (AST.Init_addrof (id, offset)) - in QCheck.Gen.frequency [ (1, int8); (1, int16); (1, int32); (1, int64); - (* TODO: actually generate the variants below as soon as they are implemented in PrintAsm.ml *) - (* (1, float32); - (1, float64); - (1, space); - (1, addrof);*) ] let sample_init_data_list config = diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 274fc4c118..630a441f68 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -3,7 +3,6 @@ let property_under_test asm_prog bundled_trace = let () = print_endline (Show.show_bundle_trace bundled_trace) in let source_name = "out.c" in let ccomp_cmd = "../../ccomp -quiet -c > /dev/null 2> /dev/null" in - let ccomp_cmd = "../../ccomp -c" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in let () = Export.c_light_prog src_program source_name in let status = Unix.system (ccomp_cmd ^ " " ^ source_name) in From 6a3e70b9c4c766c59723638341107d222fd10fa6 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Tue, 19 Dec 2023 14:36:28 +0100 Subject: [PATCH 56/83] Make tests work with some external functions (external, builtin and runtime) --- test/backtranslation/Export.ml | 7 ++++++- test/backtranslation/Gen.ml | 11 ++++++----- test/backtranslation/Gen_ctx.ml | 6 +++--- 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/test/backtranslation/Export.ml b/test/backtranslation/Export.ml index e71a5c756e..bde34c8acc 100644 --- a/test/backtranslation/Export.ml +++ b/test/backtranslation/Export.ml @@ -36,6 +36,10 @@ let fix_missing_derefs code = let regex = Str.regexp "= &\\([^;]+\\);" in Str.global_replace regex "= *(&\\1);" code +let fix_syntax_of_builtins code = + let regex = Str.regexp "builtin \\(runtime\\|extern\\|builtin\\) \\\"\\([a-zA-Z]+\\)\\\"[ \\\t\\\n]*\\([^;]+\\);" in + Str.global_replace regex "\\2\\3;" code + let c_light_prog prog file_name = let vars_before_funcs (_, def1) (_, def2) = let open AST in @@ -55,6 +59,7 @@ let c_light_prog prog file_name = |> prepend_header |> fix_incomplete_types |> fix_floating_point_literals - |> fix_missing_derefs in + |> fix_missing_derefs + |> fix_syntax_of_builtins in Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); Out_channel.with_open_text file_name (fun c -> output_string c code) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index ee1ae40fdc..c0b3bfbced 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -182,16 +182,17 @@ let external_function ctx = (1, ef_external ctx); (1, ef_builtin ctx); (1, ef_runtime ctx); - (1, ef_vload ctx); + (* TODO: perhaps enable these if they are required + (1000, ef_vload ctx); (1, ef_vstore ctx); (1, ef_malloc ctx); (1, ef_free ctx); (1, ef_memcpy ctx); - (* TODO: enable these after the corresponding functions are implemented *) - (* (0, ef_annot ctx); + (0, ef_annot ctx); (0, ef_annot_val ctx); (0, ef_inline_asm ctx); - (0, ef_debug ctx);*) + (0, ef_debug ctx); + *) ] (* TODO: perhaps differentiate between signed/unsigned and positive/negative values? *) @@ -271,7 +272,7 @@ let bundle_trace ctx rand_state = let f = float_range 0.0 1.0 rand_state in match f with (* TODO: also generate builtin events in the trace (for now the test fails) *) - | _ when f <= 1.0 -> ( + | _ when f <= 0.7 -> ( match bundle_call_ret ctx curr_comp rand_state with | Option.None -> [] | Option.Some (call, ret, trgt_comp) -> diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index 6b40d35bdc..32ea793e1d 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -153,7 +153,7 @@ let sample_func_sigs config exports = let sample_external_funcs config = let open QCheck.Gen in let gen = - let* name = small_list (char_range 'a' 'z') in + let* name = list_size (map Int.succ small_nat) (char_range 'a' 'z') in let* sign = sample_signature config in return (AST.EF_external (name, sign)) in list_repeat config.num_external_funcs gen @@ -161,7 +161,7 @@ let sample_external_funcs config = let sample_builtins config = let open QCheck.Gen in let gen = - let* name = small_list (char_range 'a' 'z') in + let* name = list_size (map Int.succ small_nat) (char_range 'a' 'z') in let* sign = sample_signature config in return (AST.EF_builtin (name, sign)) in list_repeat config.num_builtins gen @@ -169,7 +169,7 @@ let sample_builtins config = let sample_runtime_funcs config = let open QCheck.Gen in let gen = - let* name = small_list (char_range 'a' 'z') in + let* name = list_size (map Int.succ small_nat) (char_range 'a' 'z') in let* sign = sample_signature config in return (AST.EF_runtime (name, sign)) in list_repeat config.num_runtime_funcs gen From c5c33233d2135473f4f4c288499bfb2ba38341d6 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Tue, 19 Dec 2023 15:09:51 +0100 Subject: [PATCH 57/83] Improve usability for multiple ASM progs/traces --- test/backtranslation/test_backtranslation.ml | 48 ++++++++++++++------ 1 file changed, 34 insertions(+), 14 deletions(-) diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 630a441f68..6f20ad3989 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -1,6 +1,5 @@ (* QCheck testing *) let property_under_test asm_prog bundled_trace = - let () = print_endline (Show.show_bundle_trace bundled_trace) in let source_name = "out.c" in let ccomp_cmd = "../../ccomp -quiet -c > /dev/null 2> /dev/null" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in @@ -13,26 +12,30 @@ let property_under_test asm_prog bundled_trace = let bundle_trace ctx = QCheck.make ~print:Show.show_bundle_trace (Gen.bundle_trace ctx) -let test_backtranslation asm_prog ctx = - QCheck.Test.make ~count:1 ~name:"backtranslation" (bundle_trace ctx) +let test_backtranslation name asm_prog ctx = + QCheck.Test.make ~count:1 ~name:name (bundle_trace ctx) (property_under_test asm_prog) let parse_args () = - let usage_msg = "test_backtranslation [-seed n] [-verbose]" in + let usage_msg = "test_backtranslation [-seed n] [-verbose] [-num_traces n] [-num_asm_progs n]" in let seed = ref 0 in let debug = ref false in + let num_traces = ref 10 in + let num_asm_progs = ref 10 in let anon_fun _ = failwith "Unnamed arguments are not supported" in let speclist = [ ("-seed", Arg.Set_int seed, "Initial random seed"); - ("-debug", Arg.Set debug, "Provide debug output") + ("-debug", Arg.Set debug, "Provide debug output"); + ("-num_traces", Arg.Set_int num_traces, "Set the number of traces tested per ASM program (default = 10)"); + ("-num_asm_progs", Arg.Set_int num_asm_progs, "Set the number of ASM programs (default = 10)") ] in let () = Arg.parse speclist anon_fun usage_msg in - (!seed, !debug) + (!seed, !debug, !num_traces, !num_asm_progs) (* Main *) let _ = - let (seed, debug) = parse_args () in + let (seed, debug, num_traces, num_asm_progs) = parse_args () in let config = Gen_ctx. { @@ -52,13 +55,30 @@ let _ = if seed = 0 then (Random.self_init (); - let s = Random.full_int 10000 in - Printf.printf "seed = %d\n" s; + let s = Random.full_int (Int.shift_left 1 32) in + Printf.printf "Root seed = %d\n" s; Random.init s) else Random.init seed in - let rand_state = Random.get_state () in - let ctx = Gen_ctx.random config rand_state in - let asm_prog = Gen_ctx.get_asm_prog ctx in - if debug then PrintAsm.print_program_asm Out_channel.stdout asm_prog else (); - QCheck_runner.run_tests ~verbose:true ~rand:rand_state [ test_backtranslation asm_prog ctx ] + let discard_out = Out_channel.open_text "/dev/null" in + for i = 0 to num_asm_progs - 1 do + let bound = Int.shift_left 1 32 in + let asm_seed = Random.full_int bound in + let trace_root_seed = Random.full_int bound in + let () = Random.init asm_seed in + let rand_state = Random.get_state () in + let ctx = Gen_ctx.random config rand_state in + let asm_prog = Gen_ctx.get_asm_prog ctx in + let () = Printf.printf "Testing traces for ASM program (asm_seed = %d)\n" asm_seed in + for j = 0 to num_traces - 1 do + let () = Random.init (trace_root_seed + j) in + let trace_seed = Random.full_int bound in + let () = Random.init trace_seed in + let name = Printf.sprintf "\ttest_backtranslation (trace_seed = %d)" trace_seed in + if 0 = QCheck_runner.run_tests ~out:discard_out ~rand:rand_state [ test_backtranslation name asm_prog ctx ] + then Printf.printf "%s: passed\n" name + else Printf.printf "%s: failed\n" name; + Out_channel.flush Out_channel.stdout + done + done; + Out_channel.close discard_out From dfadf6a6a2a43616ef45f2ddebe754bb87dadf58 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 12 Jan 2024 13:41:15 +0100 Subject: [PATCH 58/83] Harden against kill/abort signals for long runs --- test/backtranslation/test_backtranslation.ml | 23 +++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 6f20ad3989..5170689bba 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -61,6 +61,22 @@ let _ = else Random.init seed in let discard_out = Out_channel.open_text "/dev/null" in + let failure_seeds = ref [] in + let pass_counter = ref 0 in + let fail_counter = ref 0 in + let num_tests = num_asm_progs * num_traces in + let print_results () = + Printf.printf "\n%d/%d passed\n%d/%d failed\n" !pass_counter num_tests !fail_counter num_tests; + if List.length !failure_seeds = 0 + then () + else (Printf.printf "Failures:\n"; + List.iter (fun (a_s, t_s) -> Printf.printf "\tasm_seed = %d, trace_seed = %d\n" a_s t_s) !failure_seeds) in + let handle_abort _ = + print_results (); + Out_channel.flush Out_channel.stdout; + exit (~-1) in + Sys.set_signal Sys.sigint (Sys.Signal_handle handle_abort); + Sys.set_signal Sys.sigquit (Sys.Signal_handle handle_abort); for i = 0 to num_asm_progs - 1 do let bound = Int.shift_left 1 32 in let asm_seed = Random.full_int bound in @@ -69,16 +85,17 @@ let _ = let rand_state = Random.get_state () in let ctx = Gen_ctx.random config rand_state in let asm_prog = Gen_ctx.get_asm_prog ctx in - let () = Printf.printf "Testing traces for ASM program (asm_seed = %d)\n" asm_seed in for j = 0 to num_traces - 1 do + Printf.printf "\rTesting %d / %d asm_progs, %d / %d traces" (i+1) num_asm_progs (j+1) num_traces; Out_channel.flush Out_channel.stdout; let () = Random.init (trace_root_seed + j) in let trace_seed = Random.full_int bound in let () = Random.init trace_seed in let name = Printf.sprintf "\ttest_backtranslation (trace_seed = %d)" trace_seed in if 0 = QCheck_runner.run_tests ~out:discard_out ~rand:rand_state [ test_backtranslation name asm_prog ctx ] - then Printf.printf "%s: passed\n" name - else Printf.printf "%s: failed\n" name; + then pass_counter := !pass_counter + 1 + else (failure_seeds := (asm_seed, trace_seed) :: !failure_seeds; fail_counter := !fail_counter + 1); Out_channel.flush Out_channel.stdout done done; + print_results(); Out_channel.close discard_out From 5723447c22ec724df1504b8ffbf8246222553f6f Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 15 Jan 2024 11:00:50 +0100 Subject: [PATCH 59/83] Collect and output some statistics about the generated values --- test/backtranslation/Gen.ml | 7 +- test/backtranslation/Gen_ctx.ml | 27 ++-- test/backtranslation/Gen_ctx.mli | 3 + test/backtranslation/Stats.ml | 133 +++++++++++++++++++ test/backtranslation/test_backtranslation.ml | 53 ++++---- 5 files changed, 186 insertions(+), 37 deletions(-) create mode 100644 test/backtranslation/Stats.ml diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index c0b3bfbced..9bbdcd480c 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -138,7 +138,9 @@ let mem_delta_kind curr_comp ctx = (1, mem_delta_free curr_comp ctx);*) ] -let mem_delta curr_comp ctx = QCheck.Gen.small_list (mem_delta_kind curr_comp ctx) +let mem_delta curr_comp ctx rand_state = + let mem_delta = QCheck.Gen.small_list (mem_delta_kind curr_comp ctx) rand_state in + Stats.register_mem_delta mem_delta; mem_delta let ef_external ctx = QCheck.Gen.oneofl (Gen_ctx.external_funcs ctx) @@ -258,6 +260,7 @@ let bundle_builtin ctx rand_state = let open QCheck.Gen in let subtrace = [] in let func = external_function ctx rand_state in + let () = Stats.register_external_function func in let sign = AST.ef_sig func in let args = args_for_sig sign rand_state in let mdelta = [] in @@ -265,7 +268,7 @@ let bundle_builtin ctx rand_state = let bundle_trace ctx rand_state = let open QCheck.Gen in - let size = small_nat rand_state in + let size = int_range 0 ((Gen_ctx.get_config ctx).max_trace_len / 2) rand_state in let rec bundle_trace_aux curr_comp = function | 0 -> [] | n -> ( diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index 32ea793e1d..2b79e07ed5 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -5,17 +5,6 @@ type imports = (int * int) list Map.t type func_sigs = AST.signature Map.t type extern = AST.external_function -type t = { - exports : exports; - imports : imports; - func_sigs : func_sigs; - main : int; - glob_vars : (int * AST.init_data list * bool * bool) list Map.t; - external_funcs : extern list; - builtins: extern list; - runtime_funcs : extern list; -} - type gen_config = { num_compartments : int; num_exported_funcs : int; @@ -27,6 +16,19 @@ type gen_config = { global_var_max_size : int; max_arg_count : int; debug : bool; + max_trace_len : int; +} + +type t = { + exports : exports; + imports : imports; + func_sigs : func_sigs; + main : int; + glob_vars : (int * AST.init_data list * bool * bool) list Map.t; + external_funcs : extern list; + builtins: extern list; + runtime_funcs : extern list; + config : gen_config; } type comp = int @@ -206,7 +208,7 @@ let random config = dump_exports exports; dump_imports imports) else (); - return { exports; imports; func_sigs; main; glob_vars; external_funcs; builtins; runtime_funcs } + return { exports; imports; func_sigs; main; glob_vars; external_funcs; builtins; runtime_funcs; config } let main ctx = ctx.main let function_list ctx = List.concat_map snd (Map.bindings ctx.exports) @@ -302,3 +304,4 @@ let get_asm_prog ctx = let prog_pol = build_prog_pol ctx in AST.{ prog_defs; prog_public; prog_main; prog_pol } +let get_config ctx = ctx.config diff --git a/test/backtranslation/Gen_ctx.mli b/test/backtranslation/Gen_ctx.mli index 29d5639f27..277af8316c 100644 --- a/test/backtranslation/Gen_ctx.mli +++ b/test/backtranslation/Gen_ctx.mli @@ -13,6 +13,7 @@ type gen_config = { global_var_max_size : int; max_arg_count : int; debug : bool; + max_trace_len : int; } type comp = int @@ -34,3 +35,5 @@ val builtins : t -> AST.external_function list val runtime_funcs : t -> AST.external_function list val get_asm_prog : t -> Asm.program + +val get_config : t -> gen_config diff --git a/test/backtranslation/Stats.ml b/test/backtranslation/Stats.ml new file mode 100644 index 0000000000..7c6daaf956 --- /dev/null +++ b/test/backtranslation/Stats.ml @@ -0,0 +1,133 @@ +let inc_ref x = x := !x + 1 +let sum_refs xs = List.fold_left (fun acc el -> acc + !el) 0 xs + +let trace_len_min = ref Int.max_int +let trace_len_max = ref Int.min_int +let trace_calls = ref 0 +let trace_rets = ref 0 +let trace_builtins = ref 0 + +let register_trace trace = + trace_len_min := Int.min (List.length trace) !trace_len_min; + trace_len_max := Int.max (List.length trace) !trace_len_max; + let analyse_event = function + | BtInfoAsm.Bundle_call _ -> inc_ref trace_calls + | BtInfoAsm.Bundle_return _ -> inc_ref trace_rets + | BtInfoAsm.Bundle_builtin _ -> inc_ref trace_builtins + in + List.iter (fun (_, event) -> analyse_event event) trace + +let print_trace_stats () = + Printf.printf "Traces:\n"; + Printf.printf " Min length: %d\n" !trace_len_min; + Printf.printf " Max length: %d\n" !trace_len_max; + Printf.printf " Calls: %d\n" !trace_calls; + Printf.printf " Returns: %d\n" !trace_rets; + Printf.printf " Builtins: %d\n" !trace_builtins + +let min_comps = ref Int.max_int +let max_comps = ref Int.min_int +let min_glob_vars = ref Int.max_int +let max_glob_vars = ref Int.min_int + +let register_asm_prog asm_prog = + let count_if pred xs = List.length (List.filter pred xs) in + let is_glob_var = function + | AST.Gfun _ -> false + | AST.Gvar _ -> true + in + let exports = AST.Policy.policy_export asm_prog.AST.prog_pol in + let num_comps = List.length (Maps.PTree.elements exports) in + let num_glob_vars = count_if (fun (_, def) -> is_glob_var def) asm_prog.AST.prog_defs in + min_comps := Int.min num_comps !min_comps; + max_comps := Int.max num_comps !max_comps; + min_glob_vars := Int.min num_glob_vars !min_glob_vars; + max_glob_vars := Int.max num_glob_vars !max_glob_vars + +let print_asm_prog_stats () = + Printf.printf "ASM Programs:\n"; + Printf.printf " Min compartments: %d\n" !min_comps; + Printf.printf " Max compartments: %d\n" !max_comps; + Printf.printf " Min global vars: %d\n" !min_glob_vars; + Printf.printf " Max global vars: %d\n" !max_glob_vars + +let mem_delta_len_max = ref Int.min_int +let mem_delta_len_min = ref Int.max_int +let mem_delta_storev = ref 0 +let mem_delta_store = ref 0 +let mem_delta_bytes = ref 0 +let mem_delta_alloc = ref 0 +let mem_delta_free = ref 0 + +let register_mem_delta md = + mem_delta_len_max := Int.max (List.length md) !mem_delta_len_max; + mem_delta_len_min := Int.min (List.length md) !mem_delta_len_min; + let analyse_kinds = function + | MemoryDelta.Coq_mem_delta_kind_storev _ -> inc_ref mem_delta_storev + | MemoryDelta.Coq_mem_delta_kind_store _ -> inc_ref mem_delta_store + | MemoryDelta.Coq_mem_delta_kind_bytes _ -> inc_ref mem_delta_bytes + | MemoryDelta.Coq_mem_delta_kind_alloc _ -> inc_ref mem_delta_alloc + | MemoryDelta.Coq_mem_delta_kind_free _ -> inc_ref mem_delta_free + in + List.iter analyse_kinds md + +let print_mem_delta_stats () = + Printf.printf "Memory Deltas:\n"; + Printf.printf " Total: %d\n" (sum_refs [mem_delta_storev; mem_delta_store; mem_delta_bytes; mem_delta_alloc; mem_delta_free]); + Printf.printf " Min length: %d\n" !mem_delta_len_min; + Printf.printf " Max length: %d\n" !mem_delta_len_max; + Printf.printf " StoreV: %d\n" !mem_delta_storev; + Printf.printf " Store: %d\n" !mem_delta_store; + Printf.printf " Bytes: %d\n" !mem_delta_bytes; + Printf.printf " Alloc: %d\n" !mem_delta_alloc; + Printf.printf " Free: %d\n" !mem_delta_free + +let ef_external = ref 0 +let ef_builtin = ref 0 +let ef_runtime = ref 0 +let ef_vload = ref 0 +let ef_vstore = ref 0 +let ef_malloc = ref 0 +let ef_free = ref 0 +let ef_memcpy = ref 0 +let ef_annot = ref 0 +let ef_annot_val = ref 0 +let ef_inline_asm = ref 0 +let ef_debug = ref 0 + +let register_external_function = function + | AST.EF_external _ -> inc_ref ef_external + | AST.EF_builtin _ -> inc_ref ef_builtin + | AST.EF_runtime _ -> inc_ref ef_runtime + | AST.EF_vload _ -> inc_ref ef_vload + | AST.EF_vstore _ -> inc_ref ef_vstore + | AST.EF_malloc -> inc_ref ef_malloc + | AST.EF_free -> inc_ref ef_free + | AST.EF_memcpy _ -> inc_ref ef_memcpy + | AST.EF_annot _ -> inc_ref ef_annot + | AST.EF_annot_val _ -> inc_ref ef_annot_val + | AST.EF_inline_asm _ -> inc_ref ef_inline_asm + | AST.EF_debug _ -> inc_ref ef_debug + +let print_ef_stats () = + Printf.printf "External Functions:\n"; + Printf.printf " Total: %d\n" (sum_refs [ef_external; ef_builtin; ef_runtime; ef_vload; ef_vstore; ef_malloc; ef_free; ef_memcpy; ef_annot; ef_annot_val; ef_inline_asm; ef_debug]); + Printf.printf " EF_external: %d\n" !ef_external; + Printf.printf " EF_builtin: %d\n" !ef_builtin; + Printf.printf " EF_runtime: %d\n" !ef_runtime; + Printf.printf " EF_vload: %d\n" !ef_vload; + Printf.printf " EF_vstore: %d\n" !ef_vstore; + Printf.printf " EF_malloc: %d\n" !ef_malloc; + Printf.printf " EF_free: %d\n" !ef_free; + Printf.printf " EF_memcpy: %d\n" !ef_memcpy; + Printf.printf " EF_annot: %d\n" !ef_annot; + Printf.printf " EF_annot_val: %d\n" !ef_annot_val; + Printf.printf " EF_inline_asm: %d\n" !ef_inline_asm; + Printf.printf " EF_debug: %d\n" !ef_debug + +let print_stats () = + print_trace_stats (); + print_asm_prog_stats (); + print_mem_delta_stats (); + print_ef_stats () + diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 5170689bba..6a9435e3ef 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -1,5 +1,8 @@ (* QCheck testing *) let property_under_test asm_prog bundled_trace = + (* Collect some statistics *) + let () = Stats.register_trace bundled_trace in + let () = Stats.register_asm_prog asm_prog in let source_name = "out.c" in let ccomp_cmd = "../../ccomp -quiet -c > /dev/null 2> /dev/null" in let src_program = Backtranslation.gen_program bundled_trace asm_prog in @@ -12,9 +15,8 @@ let property_under_test asm_prog bundled_trace = let bundle_trace ctx = QCheck.make ~print:Show.show_bundle_trace (Gen.bundle_trace ctx) -let test_backtranslation name asm_prog ctx = - QCheck.Test.make ~count:1 ~name:name (bundle_trace ctx) - (property_under_test asm_prog) +let test_backtranslation asm_prog ctx = + QCheck.Test.make ~count:1 (bundle_trace ctx) (property_under_test asm_prog) let parse_args () = let usage_msg = "test_backtranslation [-seed n] [-verbose] [-num_traces n] [-num_asm_progs n]" in @@ -36,30 +38,34 @@ let parse_args () = (* Main *) let _ = let (seed, debug, num_traces, num_asm_progs) = parse_args () in - let config = - Gen_ctx. - { - num_compartments = 3; - num_exported_funcs = 5; - num_imported_funcs = 3; - num_external_funcs = 4; - num_builtins = 4; - num_runtime_funcs = 4; - num_global_vars = 4; - global_var_max_size = 4; - max_arg_count = 2; - debug = debug; - } - in let () = if seed = 0 then (Random.self_init (); - let s = Random.full_int (Int.shift_left 1 32) in - Printf.printf "Root seed = %d\n" s; - Random.init s) + let s = Random.full_int (Int.shift_left 1 32) in + Printf.printf "Root seed = %d\n" s; + Random.init s) else Random.init seed in + let gen_config () = + let open QCheck in + let rand_state = Random.get_state () in + Gen_ctx. + { + num_compartments = Gen.int_range 3 100 rand_state; + num_exported_funcs = Gen.int_range 5 100 rand_state; + num_imported_funcs = Gen.int_range 3 100 rand_state; + num_external_funcs = Gen.int_range 2 100 rand_state; + num_builtins = Gen.int_range 2 50 rand_state; + num_runtime_funcs = Gen.int_range 2 50 rand_state; + num_global_vars = Gen.int_range 2 50 rand_state; + global_var_max_size = Gen.int_range 4 100 rand_state; + max_arg_count = 10; + debug = debug; + max_trace_len = 10; + } + in + let config = gen_config () in let discard_out = Out_channel.open_text "/dev/null" in let failure_seeds = ref [] in let pass_counter = ref 0 in @@ -67,6 +73,7 @@ let _ = let num_tests = num_asm_progs * num_traces in let print_results () = Printf.printf "\n%d/%d passed\n%d/%d failed\n" !pass_counter num_tests !fail_counter num_tests; + Stats.print_stats (); if List.length !failure_seeds = 0 then () else (Printf.printf "Failures:\n"; @@ -90,8 +97,8 @@ let _ = let () = Random.init (trace_root_seed + j) in let trace_seed = Random.full_int bound in let () = Random.init trace_seed in - let name = Printf.sprintf "\ttest_backtranslation (trace_seed = %d)" trace_seed in - if 0 = QCheck_runner.run_tests ~out:discard_out ~rand:rand_state [ test_backtranslation name asm_prog ctx ] + let rand_state = Random.get_state () in + if 0 = QCheck_runner.run_tests ~out:discard_out ~rand:rand_state [ test_backtranslation asm_prog ctx ] then pass_counter := !pass_counter + 1 else (failure_seeds := (asm_seed, trace_seed) :: !failure_seeds; fail_counter := !fail_counter + 1); Out_channel.flush Out_channel.stdout From d50388a8ec8d7e430e66a012453c1a6aea7258d7 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 15 Jan 2024 12:01:36 +0100 Subject: [PATCH 60/83] Introduce "test" and "reproduction mode" to precisely reproduce possible failure --- test/backtranslation/test_backtranslation.ml | 145 +++++++++++++------ 1 file changed, 97 insertions(+), 48 deletions(-) diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 6a9435e3ef..9162d33c04 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -1,6 +1,5 @@ (* QCheck testing *) let property_under_test asm_prog bundled_trace = - (* Collect some statistics *) let () = Stats.register_trace bundled_trace in let () = Stats.register_asm_prog asm_prog in let source_name = "out.c" in @@ -18,59 +17,65 @@ let bundle_trace ctx = let test_backtranslation asm_prog ctx = QCheck.Test.make ~count:1 (bundle_trace ctx) (property_under_test asm_prog) + +(* Command line options and configurations *) +let root_seed = ref 0 +let asm_seed = ref 0 +let trace_seed = ref 0 +let debug = ref false +let num_traces = ref 10 +let num_asm_progs = ref 10 +let mode = ref "test" + let parse_args () = - let usage_msg = "test_backtranslation [-seed n] [-verbose] [-num_traces n] [-num_asm_progs n]" in - let seed = ref 0 in - let debug = ref false in - let num_traces = ref 10 in - let num_asm_progs = ref 10 in + let usage_msg = "test_backtranslation [-root_seed n] [-asm_seed n] [-trace_seed n] [-num_traces n] [-num_asm_progs n] [-vebose]" in let anon_fun _ = failwith "Unnamed arguments are not supported" in let speclist = [ - ("-seed", Arg.Set_int seed, "Initial random seed"); - ("-debug", Arg.Set debug, "Provide debug output"); + ("-root_seed", Arg.Set_int root_seed, "Root seed for all randomness"); + ("-asm_seed", Arg.Set_int asm_seed, "Seed for an ASM program (implies -num_asm_progs = 1)"); + ("-trace_seed", Arg.Set_int trace_seed, "Seed for a trace (implies -num_traces = 1)"); ("-num_traces", Arg.Set_int num_traces, "Set the number of traces tested per ASM program (default = 10)"); - ("-num_asm_progs", Arg.Set_int num_asm_progs, "Set the number of ASM programs (default = 10)") + ("-num_asm_progs", Arg.Set_int num_asm_progs, "Set the number of ASM programs (default = 10)"); + ("-verbose", Arg.Set debug, "Provide more verbose debug output") ] in let () = Arg.parse speclist anon_fun usage_msg in - (!seed, !debug, !num_traces, !num_asm_progs) + if !asm_seed != 0 then num_asm_progs := 1; + if !trace_seed != 0 then num_traces := 1; + if !asm_seed != 0 && !trace_seed != 0 && !root_seed != 0 then mode := "reproduction" -(* Main *) -let _ = - let (seed, debug, num_traces, num_asm_progs) = parse_args () in +let gen_config rand_state = + let open QCheck in + Gen_ctx. + { + num_compartments = Gen.int_range 3 100 rand_state; + num_exported_funcs = Gen.int_range 5 100 rand_state; + num_imported_funcs = Gen.int_range 3 100 rand_state; + num_external_funcs = Gen.int_range 2 100 rand_state; + num_builtins = Gen.int_range 2 50 rand_state; + num_runtime_funcs = Gen.int_range 2 50 rand_state; + num_global_vars = Gen.int_range 2 50 rand_state; + global_var_max_size = Gen.int_range 4 100 rand_state; + max_arg_count = 10; + debug = !debug; + max_trace_len = 10; + } + +(* Test mode: runs multiple (random) tests to find possible bugs *) +let test_mode _ = + let () = Printf.printf "*************\n* Test Mode *\n*************\n" in let () = - if seed = 0 - then - (Random.self_init (); - let s = Random.full_int (Int.shift_left 1 32) in - Printf.printf "Root seed = %d\n" s; - Random.init s) - else Random.init seed + if !root_seed = 0 + then (Random.self_init (); root_seed := Random.bits ()) in - let gen_config () = - let open QCheck in - let rand_state = Random.get_state () in - Gen_ctx. - { - num_compartments = Gen.int_range 3 100 rand_state; - num_exported_funcs = Gen.int_range 5 100 rand_state; - num_imported_funcs = Gen.int_range 3 100 rand_state; - num_external_funcs = Gen.int_range 2 100 rand_state; - num_builtins = Gen.int_range 2 50 rand_state; - num_runtime_funcs = Gen.int_range 2 50 rand_state; - num_global_vars = Gen.int_range 2 50 rand_state; - global_var_max_size = Gen.int_range 4 100 rand_state; - max_arg_count = 10; - debug = debug; - max_trace_len = 10; - } - in - let config = gen_config () in + let () = Random.init !root_seed in + let () = Printf.printf "Root seed = %d\n\n" !root_seed in + let config = gen_config (Random.get_state ()) in let discard_out = Out_channel.open_text "/dev/null" in let failure_seeds = ref [] in let pass_counter = ref 0 in let fail_counter = ref 0 in - let num_tests = num_asm_progs * num_traces in + let num_tests = !num_asm_progs * !num_traces in let print_results () = Printf.printf "\n%d/%d passed\n%d/%d failed\n" !pass_counter num_tests !fail_counter num_tests; Stats.print_stats (); @@ -84,18 +89,23 @@ let _ = exit (~-1) in Sys.set_signal Sys.sigint (Sys.Signal_handle handle_abort); Sys.set_signal Sys.sigquit (Sys.Signal_handle handle_abort); - for i = 0 to num_asm_progs - 1 do - let bound = Int.shift_left 1 32 in - let asm_seed = Random.full_int bound in - let trace_root_seed = Random.full_int bound in + for i = 0 to !num_asm_progs - 1 do + let asm_seed = + if !asm_seed = 0 + then Random.bits () + else !asm_seed + in let () = Random.init asm_seed in let rand_state = Random.get_state () in let ctx = Gen_ctx.random config rand_state in let asm_prog = Gen_ctx.get_asm_prog ctx in - for j = 0 to num_traces - 1 do - Printf.printf "\rTesting %d / %d asm_progs, %d / %d traces" (i+1) num_asm_progs (j+1) num_traces; Out_channel.flush Out_channel.stdout; - let () = Random.init (trace_root_seed + j) in - let trace_seed = Random.full_int bound in + for j = 0 to !num_traces - 1 do + Printf.printf "\rTesting %d / %d asm_progs, %d / %d traces" (i+1) !num_asm_progs (j+1) !num_traces; Out_channel.flush Out_channel.stdout; + let trace_seed = + if !trace_seed = 0 + then Random.bits () + else !trace_seed + in let () = Random.init trace_seed in let rand_state = Random.get_state () in if 0 = QCheck_runner.run_tests ~out:discard_out ~rand:rand_state [ test_backtranslation asm_prog ctx ] @@ -106,3 +116,42 @@ let _ = done; print_results(); Out_channel.close discard_out + +(* Reproduction mode: reproduces a single (failing) tests for debugging and analysis *) +let reproduction_mode _ = + let () = Printf.printf "*********************\n* Reproduction Mode *\n*********************\n" in + let () = assert (!root_seed != 0) in + let () = assert (!trace_seed != 0) in + let () = assert (!asm_seed != 0) in + let () = Printf.printf "Root seed = %d\nASM seed = %d\nTrace seed = %d\n" !root_seed !trace_seed !asm_seed in + let () = Random.init !root_seed in + let config = gen_config (Random.get_state ()) in + let discard_out = Out_channel.open_text "/dev/null" in + let pass_counter = ref 0 in + let fail_counter = ref 0 in + let num_tests = 1 in + let print_results () = + Printf.printf "\n%d/%d passed\n%d/%d failed\n" !pass_counter num_tests !fail_counter num_tests; + Stats.print_stats () + in + let () = Random.init !asm_seed in + let rand_state = Random.get_state () in + let ctx = Gen_ctx.random config rand_state in + let asm_prog = Gen_ctx.get_asm_prog ctx in + let () = Random.init !trace_seed in + let rand_state = Random.get_state () in + if 0 = QCheck_runner.run_tests ~out:discard_out ~rand:rand_state [ test_backtranslation asm_prog ctx ] + then pass_counter := !pass_counter + 1 + else fail_counter := !fail_counter + 1; + print_results (); + Out_channel.flush Out_channel.stdout; + Out_channel.close discard_out + +(* Main *) +let _ = + let () = parse_args () in + match !mode with + | "test" -> test_mode () + | "reproduction" -> reproduction_mode () + | _ -> failwith "Unknown mode" + From 2fe2fc18abcbf6e82c69a9f9278d98f27606c1c5 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 15 Jan 2024 12:10:58 +0100 Subject: [PATCH 61/83] Explain test and reproduction mode in help --- test/backtranslation/test_backtranslation.ml | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 9162d33c04..3ac63c4d72 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -28,7 +28,20 @@ let num_asm_progs = ref 10 let mode = ref "test" let parse_args () = - let usage_msg = "test_backtranslation [-root_seed n] [-asm_seed n] [-trace_seed n] [-num_traces n] [-num_asm_progs n] [-vebose]" in + let usage_msg = +"test_backtranslation [-root_seed n] [-asm_seed n] [-trace_seed n] [-num_traces n] [-num_asm_progs n] [-vebose] + +This tool generates a bunch of random ASM programs and traces and tests whether the backtranslated C code +compiles with CompCert. + +By default the tool runs in testing mode. In this case multiple random input value are generated to test the +given property. If any tests fail, the corresponding seeds are printed to stdout. +The corresponding options work \"as one would expect\" + +If, however, a `root_seed', an `asm_seed` and a `trace_seed` are specified, the tool runs in reproduction mode. +In this case, only one specific test is exectued (corresponding to the seeds) to facilitate debugging. +This also allows one to inspect `out.c` which is the generated C code. +" in let anon_fun _ = failwith "Unnamed arguments are not supported" in let speclist = [ From 0516e3eb59c8fa74096cc6a29f4c5448bdeaf05b Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 15 Jan 2024 12:36:07 +0100 Subject: [PATCH 62/83] Add "-out_file" to redirect output into a file --- test/backtranslation/Stats.ml | 86 ++++++++++---------- test/backtranslation/test_backtranslation.ml | 35 +++++--- 2 files changed, 67 insertions(+), 54 deletions(-) diff --git a/test/backtranslation/Stats.ml b/test/backtranslation/Stats.ml index 7c6daaf956..635e91ba59 100644 --- a/test/backtranslation/Stats.ml +++ b/test/backtranslation/Stats.ml @@ -17,13 +17,13 @@ let register_trace trace = in List.iter (fun (_, event) -> analyse_event event) trace -let print_trace_stats () = - Printf.printf "Traces:\n"; - Printf.printf " Min length: %d\n" !trace_len_min; - Printf.printf " Max length: %d\n" !trace_len_max; - Printf.printf " Calls: %d\n" !trace_calls; - Printf.printf " Returns: %d\n" !trace_rets; - Printf.printf " Builtins: %d\n" !trace_builtins +let print_trace_stats out_channel = + Printf.fprintf out_channel "Traces:\n"; + Printf.fprintf out_channel " Min length: %d\n" !trace_len_min; + Printf.fprintf out_channel " Max length: %d\n" !trace_len_max; + Printf.fprintf out_channel " Calls: %d\n" !trace_calls; + Printf.fprintf out_channel " Returns: %d\n" !trace_rets; + Printf.fprintf out_channel " Builtins: %d\n" !trace_builtins let min_comps = ref Int.max_int let max_comps = ref Int.min_int @@ -44,12 +44,12 @@ let register_asm_prog asm_prog = min_glob_vars := Int.min num_glob_vars !min_glob_vars; max_glob_vars := Int.max num_glob_vars !max_glob_vars -let print_asm_prog_stats () = - Printf.printf "ASM Programs:\n"; - Printf.printf " Min compartments: %d\n" !min_comps; - Printf.printf " Max compartments: %d\n" !max_comps; - Printf.printf " Min global vars: %d\n" !min_glob_vars; - Printf.printf " Max global vars: %d\n" !max_glob_vars +let print_asm_prog_stats out_channel = + Printf.fprintf out_channel "ASM Programs:\n"; + Printf.fprintf out_channel " Min compartments: %d\n" !min_comps; + Printf.fprintf out_channel " Max compartments: %d\n" !max_comps; + Printf.fprintf out_channel " Min global vars: %d\n" !min_glob_vars; + Printf.fprintf out_channel " Max global vars: %d\n" !max_glob_vars let mem_delta_len_max = ref Int.min_int let mem_delta_len_min = ref Int.max_int @@ -71,16 +71,16 @@ let register_mem_delta md = in List.iter analyse_kinds md -let print_mem_delta_stats () = - Printf.printf "Memory Deltas:\n"; - Printf.printf " Total: %d\n" (sum_refs [mem_delta_storev; mem_delta_store; mem_delta_bytes; mem_delta_alloc; mem_delta_free]); - Printf.printf " Min length: %d\n" !mem_delta_len_min; - Printf.printf " Max length: %d\n" !mem_delta_len_max; - Printf.printf " StoreV: %d\n" !mem_delta_storev; - Printf.printf " Store: %d\n" !mem_delta_store; - Printf.printf " Bytes: %d\n" !mem_delta_bytes; - Printf.printf " Alloc: %d\n" !mem_delta_alloc; - Printf.printf " Free: %d\n" !mem_delta_free +let print_mem_delta_stats out_channel = + Printf.fprintf out_channel "Memory Deltas:\n"; + Printf.fprintf out_channel " Total: %d\n" (sum_refs [mem_delta_storev; mem_delta_store; mem_delta_bytes; mem_delta_alloc; mem_delta_free]); + Printf.fprintf out_channel " Min length: %d\n" !mem_delta_len_min; + Printf.fprintf out_channel " Max length: %d\n" !mem_delta_len_max; + Printf.fprintf out_channel " StoreV: %d\n" !mem_delta_storev; + Printf.fprintf out_channel " Store: %d\n" !mem_delta_store; + Printf.fprintf out_channel " Bytes: %d\n" !mem_delta_bytes; + Printf.fprintf out_channel " Alloc: %d\n" !mem_delta_alloc; + Printf.fprintf out_channel " Free: %d\n" !mem_delta_free let ef_external = ref 0 let ef_builtin = ref 0 @@ -109,25 +109,25 @@ let register_external_function = function | AST.EF_inline_asm _ -> inc_ref ef_inline_asm | AST.EF_debug _ -> inc_ref ef_debug -let print_ef_stats () = - Printf.printf "External Functions:\n"; - Printf.printf " Total: %d\n" (sum_refs [ef_external; ef_builtin; ef_runtime; ef_vload; ef_vstore; ef_malloc; ef_free; ef_memcpy; ef_annot; ef_annot_val; ef_inline_asm; ef_debug]); - Printf.printf " EF_external: %d\n" !ef_external; - Printf.printf " EF_builtin: %d\n" !ef_builtin; - Printf.printf " EF_runtime: %d\n" !ef_runtime; - Printf.printf " EF_vload: %d\n" !ef_vload; - Printf.printf " EF_vstore: %d\n" !ef_vstore; - Printf.printf " EF_malloc: %d\n" !ef_malloc; - Printf.printf " EF_free: %d\n" !ef_free; - Printf.printf " EF_memcpy: %d\n" !ef_memcpy; - Printf.printf " EF_annot: %d\n" !ef_annot; - Printf.printf " EF_annot_val: %d\n" !ef_annot_val; - Printf.printf " EF_inline_asm: %d\n" !ef_inline_asm; - Printf.printf " EF_debug: %d\n" !ef_debug +let print_ef_stats out_channel = + Printf.fprintf out_channel "External Functions:\n"; + Printf.fprintf out_channel " Total: %d\n" (sum_refs [ef_external; ef_builtin; ef_runtime; ef_vload; ef_vstore; ef_malloc; ef_free; ef_memcpy; ef_annot; ef_annot_val; ef_inline_asm; ef_debug]); + Printf.fprintf out_channel " EF_external: %d\n" !ef_external; + Printf.fprintf out_channel " EF_builtin: %d\n" !ef_builtin; + Printf.fprintf out_channel " EF_runtime: %d\n" !ef_runtime; + Printf.fprintf out_channel " EF_vload: %d\n" !ef_vload; + Printf.fprintf out_channel " EF_vstore: %d\n" !ef_vstore; + Printf.fprintf out_channel " EF_malloc: %d\n" !ef_malloc; + Printf.fprintf out_channel " EF_free: %d\n" !ef_free; + Printf.fprintf out_channel " EF_memcpy: %d\n" !ef_memcpy; + Printf.fprintf out_channel " EF_annot: %d\n" !ef_annot; + Printf.fprintf out_channel " EF_annot_val: %d\n" !ef_annot_val; + Printf.fprintf out_channel " EF_inline_asm: %d\n" !ef_inline_asm; + Printf.fprintf out_channel " EF_debug: %d\n" !ef_debug -let print_stats () = - print_trace_stats (); - print_asm_prog_stats (); - print_mem_delta_stats (); - print_ef_stats () +let print_stats out_channel = + print_trace_stats out_channel; + print_asm_prog_stats out_channel; + print_mem_delta_stats out_channel; + print_ef_stats out_channel diff --git a/test/backtranslation/test_backtranslation.ml b/test/backtranslation/test_backtranslation.ml index 3ac63c4d72..20be08db05 100644 --- a/test/backtranslation/test_backtranslation.ml +++ b/test/backtranslation/test_backtranslation.ml @@ -26,6 +26,7 @@ let debug = ref false let num_traces = ref 10 let num_asm_progs = ref 10 let mode = ref "test" +let out_file = ref "" let parse_args () = let usage_msg = @@ -50,6 +51,7 @@ This also allows one to inspect `out.c` which is the generated C code. ("-trace_seed", Arg.Set_int trace_seed, "Seed for a trace (implies -num_traces = 1)"); ("-num_traces", Arg.Set_int num_traces, "Set the number of traces tested per ASM program (default = 10)"); ("-num_asm_progs", Arg.Set_int num_asm_progs, "Set the number of ASM programs (default = 10)"); + ("-out_file", Arg.Set_string out_file, "Set the output file to print the results and statstics in test mode (default = stdout)"); ("-verbose", Arg.Set debug, "Provide more verbose debug output") ] in let () = Arg.parse speclist anon_fun usage_msg in @@ -76,13 +78,18 @@ let gen_config rand_state = (* Test mode: runs multiple (random) tests to find possible bugs *) let test_mode _ = - let () = Printf.printf "*************\n* Test Mode *\n*************\n" in + let out_channel = + if !out_file = "" + then Out_channel.stdout + else Out_channel.open_text !out_file + in + let () = Printf.fprintf out_channel "*************\n* Test Mode *\n*************\n" in let () = if !root_seed = 0 then (Random.self_init (); root_seed := Random.bits ()) in let () = Random.init !root_seed in - let () = Printf.printf "Root seed = %d\n\n" !root_seed in + let () = Printf.fprintf out_channel "Root seed = %d\n\n" !root_seed in let config = gen_config (Random.get_state ()) in let discard_out = Out_channel.open_text "/dev/null" in let failure_seeds = ref [] in @@ -90,15 +97,16 @@ let test_mode _ = let fail_counter = ref 0 in let num_tests = !num_asm_progs * !num_traces in let print_results () = - Printf.printf "\n%d/%d passed\n%d/%d failed\n" !pass_counter num_tests !fail_counter num_tests; - Stats.print_stats (); + Printf.fprintf out_channel "\n%d/%d passed\n%d/%d failed\n" !pass_counter num_tests !fail_counter num_tests; + Stats.print_stats out_channel; if List.length !failure_seeds = 0 then () - else (Printf.printf "Failures:\n"; - List.iter (fun (a_s, t_s) -> Printf.printf "\tasm_seed = %d, trace_seed = %d\n" a_s t_s) !failure_seeds) in + else (Printf.fprintf out_channel "Failures:\n"; + List.iter (fun (a_s, t_s) -> Printf.fprintf out_channel "\tasm_seed = %d, trace_seed = %d\n" a_s t_s) !failure_seeds) in let handle_abort _ = print_results (); - Out_channel.flush Out_channel.stdout; + Out_channel.flush out_channel; + Out_channel.close out_channel; exit (~-1) in Sys.set_signal Sys.sigint (Sys.Signal_handle handle_abort); Sys.set_signal Sys.sigquit (Sys.Signal_handle handle_abort); @@ -113,7 +121,11 @@ let test_mode _ = let ctx = Gen_ctx.random config rand_state in let asm_prog = Gen_ctx.get_asm_prog ctx in for j = 0 to !num_traces - 1 do - Printf.printf "\rTesting %d / %d asm_progs, %d / %d traces" (i+1) !num_asm_progs (j+1) !num_traces; Out_channel.flush Out_channel.stdout; + (* This intentionally always prints to stdout even if -out_file is set *) + Printf.printf "\rTesting %d / %d asm_progs, %d / %d traces" (i+1) !num_asm_progs (j+1) !num_traces; + if j = !num_traces - 1 + then Printf.printf "\n"; + Out_channel.flush Out_channel.stdout; let trace_seed = if !trace_seed = 0 then Random.bits () @@ -124,11 +136,12 @@ let test_mode _ = if 0 = QCheck_runner.run_tests ~out:discard_out ~rand:rand_state [ test_backtranslation asm_prog ctx ] then pass_counter := !pass_counter + 1 else (failure_seeds := (asm_seed, trace_seed) :: !failure_seeds; fail_counter := !fail_counter + 1); - Out_channel.flush Out_channel.stdout + Out_channel.flush out_channel done done; print_results(); - Out_channel.close discard_out + Out_channel.close discard_out; + Out_channel.close out_channel (* Reproduction mode: reproduces a single (failing) tests for debugging and analysis *) let reproduction_mode _ = @@ -145,7 +158,7 @@ let reproduction_mode _ = let num_tests = 1 in let print_results () = Printf.printf "\n%d/%d passed\n%d/%d failed\n" !pass_counter num_tests !fail_counter num_tests; - Stats.print_stats () + Stats.print_stats Out_channel.stdout in let () = Random.init !asm_seed in let rand_state = Random.get_state () in From fd5627a9457d3ee32430e437f1c93ac82578ad87 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Mon, 15 Jan 2024 13:04:05 +0100 Subject: [PATCH 63/83] Add additional information to stat output --- test/backtranslation/Stats.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/test/backtranslation/Stats.ml b/test/backtranslation/Stats.ml index 635e91ba59..3193a1782a 100644 --- a/test/backtranslation/Stats.ml +++ b/test/backtranslation/Stats.ml @@ -77,10 +77,10 @@ let print_mem_delta_stats out_channel = Printf.fprintf out_channel " Min length: %d\n" !mem_delta_len_min; Printf.fprintf out_channel " Max length: %d\n" !mem_delta_len_max; Printf.fprintf out_channel " StoreV: %d\n" !mem_delta_storev; - Printf.fprintf out_channel " Store: %d\n" !mem_delta_store; - Printf.fprintf out_channel " Bytes: %d\n" !mem_delta_bytes; - Printf.fprintf out_channel " Alloc: %d\n" !mem_delta_alloc; - Printf.fprintf out_channel " Free: %d\n" !mem_delta_free + Printf.fprintf out_channel " Store*: %d\n" !mem_delta_store; + Printf.fprintf out_channel " Bytes*: %d\n" !mem_delta_bytes; + Printf.fprintf out_channel " Alloc*: %d\n" !mem_delta_alloc; + Printf.fprintf out_channel " Free*: %d\n" !mem_delta_free let ef_external = ref 0 let ef_builtin = ref 0 @@ -123,7 +123,8 @@ let print_ef_stats out_channel = Printf.fprintf out_channel " EF_annot: %d\n" !ef_annot; Printf.fprintf out_channel " EF_annot_val: %d\n" !ef_annot_val; Printf.fprintf out_channel " EF_inline_asm: %d\n" !ef_inline_asm; - Printf.fprintf out_channel " EF_debug: %d\n" !ef_debug + Printf.fprintf out_channel " EF_debug: %d\n" !ef_debug; + Printf.fprintf out_channel "\n\nNote: the entries marked with * are ignored (or trivial) in the backtranslation." let print_stats out_channel = print_trace_stats out_channel; From ed9d07de148bb4967976461c9f254f899050b419 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Thu, 18 Jan 2024 13:23:06 +0100 Subject: [PATCH 64/83] Add results.txt from first long run on server --- test/backtranslation/results.txt | 118 +++++++++++++++++++++++++++++++ 1 file changed, 118 insertions(+) create mode 100644 test/backtranslation/results.txt diff --git a/test/backtranslation/results.txt b/test/backtranslation/results.txt new file mode 100644 index 0000000000..688fad92f3 --- /dev/null +++ b/test/backtranslation/results.txt @@ -0,0 +1,118 @@ +************* +* Test Mode * +************* +Root seed = 517733517 + + +999927/1000000 passed +73/1000000 failed +Traces: + Min length: 0 + Max length: 10 + Calls: 1612110 + Returns: 1612110 + Builtins: 724267 +ASM Programs: + Min compartments: 1 + Max compartments: 24 + Min global vars: 2 + Max global vars: 627 +Memory Deltas: + Total: 50690988 + Min length: 0 + Max length: 99 + StoreV: 50690988 + Store*: 0 + Bytes*: 0 + Alloc*: 0 + Free*: 0 +External Functions: + Total: 724267 + EF_external: 240602 + EF_builtin: 241137 + EF_runtime: 242528 + EF_vload: 0 + EF_vstore: 0 + EF_malloc: 0 + EF_free: 0 + EF_memcpy: 0 + EF_annot: 0 + EF_annot_val: 0 + EF_inline_asm: 0 + EF_debug: 0 + + +Note: the entries marked with * are ignored (or trivial) in the backtranslation.Failures: + asm_seed = 397449245, trace_seed = 488841949 + asm_seed = 397449245, trace_seed = 564249778 + asm_seed = 397449245, trace_seed = 214829454 + asm_seed = 397449245, trace_seed = 89621070 + asm_seed = 397449245, trace_seed = 982269779 + asm_seed = 397449245, trace_seed = 813113391 + asm_seed = 397449245, trace_seed = 837155495 + asm_seed = 397449245, trace_seed = 392575445 + asm_seed = 397449245, trace_seed = 621117354 + asm_seed = 397449245, trace_seed = 661218624 + asm_seed = 397449245, trace_seed = 45336383 + asm_seed = 397449245, trace_seed = 53399730 + asm_seed = 397449245, trace_seed = 873359396 + asm_seed = 397449245, trace_seed = 811943474 + asm_seed = 397449245, trace_seed = 957773353 + asm_seed = 1003417912, trace_seed = 106788653 + asm_seed = 1003417912, trace_seed = 190882773 + asm_seed = 1003417912, trace_seed = 381994887 + asm_seed = 1003417912, trace_seed = 771535828 + asm_seed = 1003417912, trace_seed = 32833442 + asm_seed = 1003417912, trace_seed = 330964550 + asm_seed = 1003417912, trace_seed = 294676395 + asm_seed = 1003417912, trace_seed = 1061570004 + asm_seed = 1003417912, trace_seed = 1055674716 + asm_seed = 1003417912, trace_seed = 164098231 + asm_seed = 1003417912, trace_seed = 605170217 + asm_seed = 1003417912, trace_seed = 154020437 + asm_seed = 1003417912, trace_seed = 988917360 + asm_seed = 1003417912, trace_seed = 371326361 + asm_seed = 1003417912, trace_seed = 906362579 + asm_seed = 342771610, trace_seed = 624524808 + asm_seed = 342771610, trace_seed = 846098449 + asm_seed = 342771610, trace_seed = 713247464 + asm_seed = 342771610, trace_seed = 392985148 + asm_seed = 342771610, trace_seed = 816867532 + asm_seed = 342771610, trace_seed = 864059500 + asm_seed = 342771610, trace_seed = 1002536726 + asm_seed = 342771610, trace_seed = 949844794 + asm_seed = 342771610, trace_seed = 527576543 + asm_seed = 342771610, trace_seed = 601586724 + asm_seed = 342771610, trace_seed = 554444683 + asm_seed = 342771610, trace_seed = 325143823 + asm_seed = 342771610, trace_seed = 102090687 + asm_seed = 342771610, trace_seed = 936341561 + asm_seed = 342771610, trace_seed = 1018142530 + asm_seed = 342771610, trace_seed = 605266788 + asm_seed = 342771610, trace_seed = 575571132 + asm_seed = 342771610, trace_seed = 320202164 + asm_seed = 342771610, trace_seed = 1068377831 + asm_seed = 342771610, trace_seed = 671626998 + asm_seed = 342771610, trace_seed = 532769297 + asm_seed = 342771610, trace_seed = 90532869 + asm_seed = 342771610, trace_seed = 346007173 + asm_seed = 342771610, trace_seed = 598446692 + asm_seed = 967102271, trace_seed = 962331503 + asm_seed = 967102271, trace_seed = 49174791 + asm_seed = 967102271, trace_seed = 403063614 + asm_seed = 967102271, trace_seed = 424412267 + asm_seed = 967102271, trace_seed = 874125652 + asm_seed = 967102271, trace_seed = 654996055 + asm_seed = 967102271, trace_seed = 21084877 + asm_seed = 967102271, trace_seed = 371255259 + asm_seed = 967102271, trace_seed = 851046520 + asm_seed = 967102271, trace_seed = 397400406 + asm_seed = 967102271, trace_seed = 593796741 + asm_seed = 967102271, trace_seed = 634998877 + asm_seed = 967102271, trace_seed = 749975924 + asm_seed = 967102271, trace_seed = 929421922 + asm_seed = 967102271, trace_seed = 983564238 + asm_seed = 967102271, trace_seed = 886760683 + asm_seed = 967102271, trace_seed = 829395051 + asm_seed = 967102271, trace_seed = 852527047 + asm_seed = 967102271, trace_seed = 418001167 From b86f42591d1b1f4f30f42e2eb6883e2a15f4e9ae Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Thu, 18 Jan 2024 14:34:31 +0100 Subject: [PATCH 65/83] Add unique suffix to identifier to avoid name clashes --- test/backtranslation/Export.ml | 2 +- test/backtranslation/Gen_ctx.ml | 4 +++- test/backtranslation/Stats.ml | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/test/backtranslation/Export.ml b/test/backtranslation/Export.ml index bde34c8acc..1eb388d786 100644 --- a/test/backtranslation/Export.ml +++ b/test/backtranslation/Export.ml @@ -37,7 +37,7 @@ let fix_missing_derefs code = Str.global_replace regex "= *(&\\1);" code let fix_syntax_of_builtins code = - let regex = Str.regexp "builtin \\(runtime\\|extern\\|builtin\\) \\\"\\([a-zA-Z]+\\)\\\"[ \\\t\\\n]*\\([^;]+\\);" in + let regex = Str.regexp "builtin \\(runtime\\|extern\\|builtin\\) \\\"\\([a-zA-Z_0-9]+\\)\\\"[ \\\t\\\n]*\\([^;]+\\);" in Str.global_replace regex "\\2\\3;" code let c_light_prog prog file_name = diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index 2b79e07ed5..53f14915f6 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -156,8 +156,10 @@ let sample_external_funcs config = let open QCheck.Gen in let gen = let* name = list_size (map Int.succ small_nat) (char_range 'a' 'z') in + let* suffix = list_size (return 4) (char_range '0' '9') in + let unique_name = name @ ['_'] @ suffix in let* sign = sample_signature config in - return (AST.EF_external (name, sign)) in + return (AST.EF_external (unique_name, sign)) in list_repeat config.num_external_funcs gen let sample_builtins config = diff --git a/test/backtranslation/Stats.ml b/test/backtranslation/Stats.ml index 3193a1782a..9cec00eefe 100644 --- a/test/backtranslation/Stats.ml +++ b/test/backtranslation/Stats.ml @@ -124,7 +124,7 @@ let print_ef_stats out_channel = Printf.fprintf out_channel " EF_annot_val: %d\n" !ef_annot_val; Printf.fprintf out_channel " EF_inline_asm: %d\n" !ef_inline_asm; Printf.fprintf out_channel " EF_debug: %d\n" !ef_debug; - Printf.fprintf out_channel "\n\nNote: the entries marked with * are ignored (or trivial) in the backtranslation." + Printf.fprintf out_channel "\n\nNote: the entries marked with * are ignored (or trivial) in the backtranslation.\n" let print_stats out_channel = print_trace_stats out_channel; From 047dd3d7de18f7fe20725c6ead5fd75d84efaa42 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Thu, 18 Jan 2024 15:13:47 +0100 Subject: [PATCH 66/83] Implement generation for missing variants of external functions --- test/backtranslation/Gen.ml | 83 ++++++++++++++++++++++++++++++------- 1 file changed, 68 insertions(+), 15 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index 9bbdcd480c..e918befaf0 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -170,13 +170,68 @@ let ef_memcpy _ = let* z2 = coq_Z in return (AST.EF_memcpy (z1, z2)) -let ef_annot _ = failwith "ef_annot is not implemented" -let ef_annot_val _ = failwith "ef_annot_val is not implemented" +let sample_typ = + QCheck.Gen.frequencyl + AST. + [ + (1, Tint); + (1, Tfloat); + (1, Tlong); + (1, Tsingle); + (1, Tany32); + (1, Tany64); + ] + +let sample_rettype = + let open QCheck.Gen in + let* f = float_range 0.0 1.0 in + if f < 1.0 /. 6.0 then map (fun t -> AST.Tret t) sample_typ + else + frequencyl + AST. + [ + (1, Tint8signed); + (1, Tint8unsigned); + (1, Tint16signed); + (1, Tint16unsigned); + (1, Tvoid); + ] + +let ef_annot _ = + let open QCheck.Gen in + let* pos = positive in + let* text = list_size (map Int.succ small_nat) (char_range 'a' 'z') in + let* types = list_size (int_range 0 10) sample_typ in + return (AST.EF_annot (pos, text, types)) -let ef_inline_asm _ = failwith "ef_inline_asm is not implemented" +let ef_annot_val _ = + let open QCheck.Gen in + let* pos = positive in + let* text = list_size (map Int.succ small_nat) (char_range 'a' 'z') in + let* typ = sample_typ in + return (AST.EF_annot_val (pos, text, typ)) -let ef_debug _ = failwith "ef_debug is not implemented" +let ef_inline_asm _ = + let open QCheck.Gen in + let* text = list_size (int_range 0 10) (char_range 'a' 'z') in + let cc_vararg = Option.none in + let cc_unproto = false in + let cc_structret = false in + let cc = ({ cc_vararg; cc_unproto; cc_structret } : AST.calling_convention) in + let* arg_types = list_size (int_range 0 10) sample_typ in + let* ret_type = sample_rettype in + let sign = AST.{ sig_args = arg_types; sig_res = ret_type; sig_cc = cc } in + let* code = list_size (int_range 0 10) (list_size (int_range 1 10) (char_range 'a' 'z')) in + return (AST.EF_inline_asm (text, sign, code)) + +let ef_debug _ = + let open QCheck.Gen in + let* pos = positive in + (* TODO: does this need to be a "known" identifier? *) + let* ident = map Camlcoq.P.of_int small_nat in + let* types = list_size (int_range 0 10) sample_typ in + return (AST.EF_debug (pos, ident, types)) let external_function ctx = QCheck.Gen.frequency @@ -184,17 +239,15 @@ let external_function ctx = (1, ef_external ctx); (1, ef_builtin ctx); (1, ef_runtime ctx); - (* TODO: perhaps enable these if they are required - (1000, ef_vload ctx); - (1, ef_vstore ctx); - (1, ef_malloc ctx); - (1, ef_free ctx); - (1, ef_memcpy ctx); - (0, ef_annot ctx); - (0, ef_annot_val ctx); - (0, ef_inline_asm ctx); - (0, ef_debug ctx); - *) + (* (1, ef_vload ctx); *) + (* (1, ef_vstore ctx); *) + (* (1, ef_malloc ctx); *) + (* (1, ef_free ctx); *) + (* (1, ef_memcpy ctx); *) + (* (1, ef_annot ctx); *) + (* (1, ef_annot_val ctx); *) + (* (1, ef_inline_asm ctx); *) + (* (1, ef_debug ctx); *) ] (* TODO: perhaps differentiate between signed/unsigned and positive/negative values? *) From 00be091a8e2383239bf62d88e0e15023b349ce80 Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Thu, 18 Jan 2024 15:58:29 +0100 Subject: [PATCH 67/83] Support annotations and value annotations as external function --- test/backtranslation/Export.ml | 14 +++++++++++++- test/backtranslation/Gen.ml | 4 ++-- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/test/backtranslation/Export.ml b/test/backtranslation/Export.ml index 1eb388d786..b0b012ff85 100644 --- a/test/backtranslation/Export.ml +++ b/test/backtranslation/Export.ml @@ -40,6 +40,17 @@ let fix_syntax_of_builtins code = let regex = Str.regexp "builtin \\(runtime\\|extern\\|builtin\\) \\\"\\([a-zA-Z_0-9]+\\)\\\"[ \\\t\\\n]*\\([^;]+\\);" in Str.global_replace regex "\\2\\3;" code +let fix_annotations code = + let regex_annot_with_args = Str.regexp "builtin annot \\\"\\([a-zA-Z]+\\)\\\"[^(]*(\\([^)]+\\));" in + let regex_annot_no_args = Str.regexp "builtin annot \\\"\\([a-zA-Z]+\\)\\\"[^(]*();" in + let regex_annot_val_with_args = Str.regexp "builtin annot_val \\\"\\([a-zA-Z]+\\)\\\"[^(]*(\\([^)]+\\));" in + let regex_annot_val_no_args = Str.regexp "builtin annot_val \\\"\\([a-zA-Z]+\\)\\\"[^(]*();" in + code + |> Str.global_replace regex_annot_with_args "__builtin_ais_annot(\"\\1\", \\2);" + |> Str.global_replace regex_annot_no_args "__builtin_ais_annot(\"\\1\");" + |> Str.global_replace regex_annot_val_with_args "__builtin_ais_annot(\"\\1\", \\2);" + |> Str.global_replace regex_annot_val_no_args "__builtin_ais_annot(\"\\1\");" + let c_light_prog prog file_name = let vars_before_funcs (_, def1) (_, def2) = let open AST in @@ -60,6 +71,7 @@ let c_light_prog prog file_name = |> fix_incomplete_types |> fix_floating_point_literals |> fix_missing_derefs - |> fix_syntax_of_builtins in + |> fix_syntax_of_builtins + |> fix_annotations in Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); Out_channel.with_open_text file_name (fun c -> output_string c code) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index e918befaf0..5862711b45 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -244,8 +244,8 @@ let external_function ctx = (* (1, ef_malloc ctx); *) (* (1, ef_free ctx); *) (* (1, ef_memcpy ctx); *) - (* (1, ef_annot ctx); *) - (* (1, ef_annot_val ctx); *) + (1, ef_annot ctx); + (1, ef_annot_val ctx); (* (1, ef_inline_asm ctx); *) (* (1, ef_debug ctx); *) ] From bdbcf29647705cc981827598c5cb936ec77635e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Thu, 11 Jan 2024 15:36:41 +0100 Subject: [PATCH 68/83] [Common] Fix axioms for commutativity of injections and external calls --- backend/Allocation.v | 26 + backend/Allocproof.v | 27 +- backend/CSE.v | 9 + backend/CSEproof.v | 16 +- backend/CleanupLabels.v | 5 +- backend/CleanupLabelsproof.v | 5 +- backend/Cminor.v | 2 + backend/Constprop.v | 4 + backend/Constpropproof.v | 39 +- backend/Deadcode.v | 8 + backend/Deadcodeproof.v | 53 +- backend/Debugvar.v | 7 + backend/Debugvarproof.v | 9 +- backend/Inlining.v | 11 + backend/Inliningproof.v | 27 +- backend/Linearize.v | 6 + backend/Linearizeproof.v | 8 +- backend/RTLgen.v | 9 + backend/RTLgenproof.v | 11 +- backend/RTLtyping.v | 10 +- backend/Renumber.v | 5 +- backend/Renumberproof.v | 7 +- backend/Selection.v | 10 + backend/Selectionproof.v | 5 +- backend/SplitLongproof.v | 4 +- backend/Stacking.v | 9 + backend/Stackingproof.v | 14 +- backend/Tailcall.v | 7 + backend/Tailcallproof.v | 13 +- backend/Tunneling.v | 4 + backend/Tunnelingproof.v | 5 +- backend/Unusedglob.v | 8 +- backend/Unusedglobproof.v | 40 +- backend/ValueAnalysis.v | 6 +- cfrontend/C2C.ml | 11 +- cfrontend/Cminorgen.v | 19 + cfrontend/Cminorgenproof.v | 25 +- cfrontend/Cshmgen.v | 13 + cfrontend/Cshmgenproof.v | 10 +- cfrontend/Ctypes.v | 25 +- cfrontend/Ctyping.v | 26 +- cfrontend/SimplExpr.v | 13 +- cfrontend/SimplExprproof.v | 1 + cfrontend/SimplLocals.v | 18 +- cfrontend/SimplLocalsproof.v | 29 +- common/AST.v | 236 +- common/Behaviors.v | 1 + common/Determinism.v | 4 +- common/Events.v | 308 ++- common/Exec.v | 75 +- common/Globalenvs.v | 57 +- common/Linking.v | 296 ++- common/Separation.v | 6 +- common/Smallstep.v | 32 +- driver/Compiler.v | 1 + driver/Interp.ml | 5 +- riscV/Asmexpand.ml | 3 +- riscV/Asmgen.v | 9 + riscV/Asmgenproof.v | 11 +- security/Backtranslation.v | 6 +- security/BtBasics.v | 105 +- security/BtInfoAsm.v | 1104 ++++----- security/MemoryDelta.v | 2276 ++++++++--------- security/MemoryWeak.v | 963 ++++---- security/Recomposition.v | 4518 ++++++++++++++++++++++++++++++++++ 65 files changed, 7899 insertions(+), 2736 deletions(-) create mode 100644 security/Recomposition.v diff --git a/backend/Allocation.v b/backend/Allocation.v index e79d6c36fe..9eac70bd65 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -1390,6 +1390,32 @@ Definition transf_function (f: RTL.function) : res LTL.function := Definition transf_fundef (fd: RTL.fundef) : res LTL.fundef := AST.transf_partial_fundef transf_function fd. +#[global] Instance comp_transf_function: has_comp_transl_partial transf_function. +Proof. + unfold transf_function, check_function. + intros f ? H. + destruct type_function; try easy. + destruct regalloc; try easy. + destruct analyze; try easy. + destruct cp_eq_dec as [e|?]; try easy. + monadInv H. + exact e. +Qed. + +#[global] Instance comp_transf_fundef: has_comp_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 cp_eq_dec as [e|?]; try easy. + monadInv H. monadInv EQ. + exact e. + - now inv H. +Qed. + Definition transf_program (p: RTL.program) : res LTL.program := transform_partial_program transf_fundef p. diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 41db59f105..3844e54356 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -25,32 +25,6 @@ Require Import Allocation. Definition match_prog (p: RTL.program) (tp: LTL.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. -#[global] Instance comp_transf_function: has_comp_transl_partial transf_function. -Proof. - unfold transf_function, check_function. - intros f ? H. - destruct type_function; try easy. - destruct regalloc; try easy. - destruct analyze; try easy. - destruct cp_eq_dec as [e|?]; try easy. - monadInv H. - exact e. -Qed. - -#[global] Instance comp_transf_fundef: has_comp_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 cp_eq_dec as [e|?]; try easy. - monadInv H. monadInv EQ. - exact e. - - now inv H. -Qed. - Lemma transf_program_match: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. @@ -3437,6 +3411,7 @@ Proof. set (ms := fun s s' => wt_state s /\ match_states s s'). eapply forward_simulation_plus with (match_states := ms). - apply senv_preserved. +- apply senv_preserved. - intros. exploit initial_states_simulation; eauto. intros [st2 [A B]]. exists st2; split; auto. split; auto. apply wt_initial_state with (p := prog); auto. exact wt_prog. diff --git a/backend/CSE.v b/backend/CSE.v index dc772798c9..7f939211df 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -574,6 +574,15 @@ Definition transf_function (rm: romem) (f: function) : res function := f.(fn_entrypoint)) end. +#[global] Instance comp_transf_function rm: + has_comp_transl_partial (transf_function rm). +Proof. + unfold transf_function. + intros f ? H. + destruct analyze; try easy. + now inv H. +Qed. + Definition transf_fundef (rm: romem) (f: fundef) : res fundef := AST.transf_partial_fundef (transf_function rm) f. diff --git a/backend/CSEproof.v b/backend/CSEproof.v index ad6d4aa145..c56ed20a13 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -22,19 +22,10 @@ Require Import CSEdomain CombineOp CombineOpproof CSE. Definition match_prog (prog tprog: RTL.program) := match_program (fun cu f tf => transf_fundef (romem_for cu) f = OK tf) eq prog tprog. -#[global] -Instance comp_transf_function rm: - has_comp_transl_partial (transf_function rm). -Proof. - unfold transf_function. - intros f ? H. - 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. + unfold transf_program, transf_fundef. intros. eapply match_transform_partial_program_contextual; eauto. Qed. @@ -879,7 +870,7 @@ Lemma symbols_preserved: Proof (Genv.find_symbol_match TRANSF). Lemma senv_preserved: - Senv.equiv ge tge. + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof (Genv.senv_match TRANSF). Lemma functions_translated: @@ -1237,7 +1228,7 @@ Proof. apply regs_lessdef_regs; auto. - (* Ibuiltin *) - exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)); eauto. + exploit (@eval_builtin_args_lessdef _ (Genv.to_senv ge) (fun r => rs#r) (fun r => rs'#r)); eauto. intros (vargs' & A & B). exploit external_call_mem_extends; eauto. intros (v' & m1' & P & Q & R & S). @@ -1377,6 +1368,7 @@ Proof. eapply forward_simulation_step with (match_states := fun s1 s2 => sound_state prog s1 /\ match_states s1 s2). - apply senv_preserved. +- apply senv_preserved. - intros. exploit transf_initial_states; eauto. intros [s2 [A B]]. exists s2. split. auto. split. apply sound_initial; auto. auto. - intros. destruct H. eapply transf_final_states; eauto. diff --git a/backend/CleanupLabels.v b/backend/CleanupLabels.v index 960f477653..fb81275ac1 100644 --- a/backend/CleanupLabels.v +++ b/backend/CleanupLabels.v @@ -22,7 +22,7 @@ Require Import FSets FSetAVL. Require Import Coqlib Ordered. -Require Import Linear. +Require Import AST Linear. Module Labelset := FSetAVL.Make(OrderedPositive). @@ -68,5 +68,8 @@ Definition transf_function (f: function) : function := Definition transf_fundef (f: fundef) : fundef := AST.transf_fundef transf_function f. +#[global] Instance comp_match_prog: has_comp_transl transf_function. +Proof. now intros f. Qed. + Definition transf_program (p: program) : program := AST.transform_program transf_fundef p. diff --git a/backend/CleanupLabelsproof.v b/backend/CleanupLabelsproof.v index 7b0b253d3c..44c6bd28b0 100644 --- a/backend/CleanupLabelsproof.v +++ b/backend/CleanupLabelsproof.v @@ -24,10 +24,6 @@ Module LabelsetFacts := FSetFacts.Facts(Labelset). Definition match_prog (p tp: Linear.program) := match_program (fun ctx f tf => tf = transf_fundef f) eq p tp. -#[global] -Instance comp_match_prog: has_comp_transl transf_function. -Proof. now intros f. Qed. - Lemma transf_program_match: forall p, match_prog p (transf_program p). Proof. @@ -434,6 +430,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_opt. apply senv_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. eexact transf_step_correct. diff --git a/backend/Cminor.v b/backend/Cminor.v index 329c4a22ab..ea443707a6 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -190,6 +190,8 @@ Definition funsig (fd: fundef) := *) Definition genv := Genv.t fundef unit. +(* Let to_senv: genv -> Senv.t := (@Genv.to_senv _ _ (@has_comp_fundef _ has_comp_function)). *) +(* Coercion to_senv: genv >-> Senv.t. *) Definition env := PTree.t val. (** The following functions build the initial local environment at diff --git a/backend/Constprop.v b/backend/Constprop.v index c643f044ef..1f4432ab53 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -250,6 +250,10 @@ Definition transf_function (rm: romem) (f: function) : function := (PTree.map (transf_instr f an rm) f.(fn_code)) f.(fn_entrypoint). +#[global] +Instance comp_transf_function rm: has_comp_transl (transf_function rm). +Proof. now intro. Qed. + Definition transf_fundef (rm: romem) (fd: fundef) : fundef := AST.transf_fundef (transf_function rm) fd. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 75c67b45ca..99da1fa4dc 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -22,10 +22,6 @@ Require Import ConstpropOp ConstpropOpproof Constprop. Definition match_prog (prog tprog: program) := match_program (fun cu f tf => tf = transf_fundef (romem_for cu) f) eq prog tprog. -#[global] -Instance comp_transf_function rm: has_comp_transl (transf_function rm). -Proof. now intro. Qed. - Lemma transf_program_match: forall prog, match_prog prog (transf_program prog). Proof. @@ -51,7 +47,7 @@ Lemma symbols_preserved: Proof (Genv.find_symbol_match TRANSL). Lemma senv_preserved: - Senv.equiv ge tge. + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof (Genv.senv_match TRANSL). Lemma functions_translated: @@ -243,8 +239,8 @@ Qed. Lemma builtin_arg_reduction_correct: forall bc sp m rs ae, ematch bc rs ae -> forall a v, - eval_builtin_arg ge (fun r => rs#r) sp m a v -> - eval_builtin_arg ge (fun r => rs#r) sp m (builtin_arg_reduction ae a) v. + eval_builtin_arg (Genv.to_senv ge) (fun r => rs#r) sp m a v -> + eval_builtin_arg (Genv.to_senv ge) (fun r => rs#r) sp m (builtin_arg_reduction ae a) v. Proof. induction 2; simpl; eauto with barg. - specialize (H x). unfold areg. destruct (AE.get x ae); try constructor. @@ -260,8 +256,8 @@ Qed. Lemma builtin_arg_strength_reduction_correct: forall bc sp m rs ae a v c, ematch bc rs ae -> - eval_builtin_arg ge (fun r => rs#r) sp m a v -> - eval_builtin_arg ge (fun r => rs#r) sp m (builtin_arg_strength_reduction ae a c) v. + eval_builtin_arg (Genv.to_senv ge) (fun r => rs#r) sp m a v -> + eval_builtin_arg (Genv.to_senv ge) (fun r => rs#r) sp m (builtin_arg_strength_reduction ae a c) v. Proof. intros. unfold builtin_arg_strength_reduction. destruct (builtin_arg_ok (builtin_arg_reduction ae a) c). @@ -272,9 +268,9 @@ Qed. Lemma builtin_args_strength_reduction_correct: forall bc sp m rs ae, ematch bc rs ae -> forall al vl, - eval_builtin_args ge (fun r => rs#r) sp m al vl -> + eval_builtin_args (Genv.to_senv ge) (fun r => rs#r) sp m al vl -> forall cl, - eval_builtin_args ge (fun r => rs#r) sp m (builtin_args_strength_reduction ae al cl) vl. + eval_builtin_args (Genv.to_senv ge) (fun r => rs#r) sp m (builtin_args_strength_reduction ae al cl) vl. Proof. induction 2; simpl; constructor. eapply builtin_arg_strength_reduction_correct; eauto. @@ -284,13 +280,13 @@ Qed. Lemma debug_strength_reduction_correct: forall bc sp m rs ae, ematch bc rs ae -> forall al vl, - eval_builtin_args ge (fun r => rs#r) sp m al vl -> - exists vl', eval_builtin_args ge (fun r => rs#r) sp m (debug_strength_reduction ae al) vl'. + eval_builtin_args (Genv.to_senv ge) (fun r => rs#r) sp m al vl -> + exists vl', eval_builtin_args (Genv.to_senv ge) (fun r => rs#r) sp m (debug_strength_reduction ae al) vl'. Proof. induction 2; simpl. - exists (@nil val); constructor. - destruct IHlist_forall2 as (vl' & A). - assert (eval_builtin_args ge (fun r => rs#r) sp m + assert (eval_builtin_args (Genv.to_senv ge) (fun r => rs#r) sp m (a1 :: debug_strength_reduction ae al) (b1 :: vl')) by (constructor; eauto). destruct a1; try (econstructor; eassumption). @@ -300,17 +296,17 @@ Qed. Lemma builtin_strength_reduction_correct: forall cp sp bc ae rs ef args vargs m t vres m', ematch bc rs ae -> - eval_builtin_args ge (fun r => rs#r) sp m args vargs -> - external_call ef ge cp vargs m t vres m' -> + eval_builtin_args (Genv.to_senv ge) (fun r => rs#r) sp m args vargs -> + external_call ef (Genv.to_senv ge) cp vargs m t vres m' -> exists vargs', - eval_builtin_args ge (fun r => rs#r) sp m (builtin_strength_reduction ae ef args) vargs' - /\ external_call ef ge cp vargs' m t vres m'. + eval_builtin_args (Genv.to_senv ge) (fun r => rs#r) sp m (builtin_strength_reduction ae ef args) vargs' + /\ external_call ef (Genv.to_senv ge) cp vargs' m t vres m'. Proof. intros. assert (DEFAULT: forall cl, exists vargs', - eval_builtin_args ge (fun r => rs#r) sp m (builtin_args_strength_reduction ae args cl) vargs' - /\ external_call ef ge cp vargs' m t vres m'). + eval_builtin_args (Genv.to_senv ge) (fun r => rs#r) sp m (builtin_args_strength_reduction ae args cl) vargs' + /\ external_call ef (Genv.to_senv ge) cp vargs' m t vres m'). { exists vargs; split; auto. eapply builtin_args_strength_reduction_correct; eauto. } unfold builtin_strength_reduction. destruct ef; auto. @@ -589,7 +585,7 @@ Opaque builtin_strength_reduction. (State s f (Vptr sp0 Ptrofs.zero) pc' (regmap_setres res vres rs) m') s2'). { exploit builtin_strength_reduction_correct; eauto. intros (vargs' & P & Q). - exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)). + exploit (@eval_builtin_args_lessdef _ (Genv.to_senv ge) (fun r => rs#r) (fun r => rs'#r)). apply REGS. eauto. eexact P. intros (vargs'' & U & V). exploit external_call_mem_extends; eauto. @@ -731,6 +727,7 @@ Proof. exists n2; exists s2'; split; auto. left; apply plus_one; auto. exists n2; exists s2; split; auto. right; split; auto. subst t; apply star_refl. - apply senv_preserved. +- apply senv_preserved. Qed. End PRESERVATION. diff --git a/backend/Deadcode.v b/backend/Deadcode.v index 9887b5096b..1ab2283f4f 100644 --- a/backend/Deadcode.v +++ b/backend/Deadcode.v @@ -212,6 +212,14 @@ Definition transf_function (rm: romem) (f: function) : res function := Error (msg "Neededness analysis failed") end. +#[global] Instance comp_transf_function rm: has_comp_transl_partial (transf_function rm). +Proof. + unfold transf_function. + intros f ? H. + destruct analyze; try easy. + now inv H. +Qed. + Definition transf_fundef (rm: romem) (fd: fundef) : res fundef := AST.transf_partial_fundef (transf_function rm) fd. diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v index 4656e7ef1e..9e6eb06874 100644 --- a/backend/Deadcodeproof.v +++ b/backend/Deadcodeproof.v @@ -22,18 +22,10 @@ Require Import ValueDomain ValueAnalysis NeedDomain NeedOp Deadcode. Definition match_prog (prog tprog: RTL.program) := match_program (fun cu f tf => transf_fundef (romem_for cu) f = OK tf) eq prog tprog. -#[global] -Instance comp_transf_function rm: has_comp_transl_partial (transf_function rm). -Proof. - unfold transf_function. - intros f ? H. - 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. + unfold transf_program, transf_fundef. intros. eapply match_transform_partial_program_contextual; eauto. Qed. @@ -425,7 +417,7 @@ Lemma symbols_preserved: Proof (Genv.find_symbol_match TRANSF). Lemma senv_preserved: - Senv.equiv ge tge. + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof (Genv.senv_match TRANSF). Lemma functions_translated: @@ -678,7 +670,7 @@ Qed. Lemma transfer_builtin_arg_sound: forall bc e e' sp m m' a v, - eval_builtin_arg ge (fun r => e#r) (Vptr sp Ptrofs.zero) m a v -> + eval_builtin_arg (Genv.to_senv ge) (fun r => e#r) (Vptr sp Ptrofs.zero) m a v -> forall nv ne1 nm1 ne2 nm2, transfer_builtin_arg nv (ne1, nm1) a = (ne2, nm2) -> eagree e e' ne2 -> @@ -686,7 +678,7 @@ Lemma transfer_builtin_arg_sound: genv_match bc ge -> bc sp = BCstack -> exists v', - eval_builtin_arg ge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' a v' + eval_builtin_arg (Genv.to_senv ge) (fun r => e'#r) (Vptr sp Ptrofs.zero) m' a v' /\ vagree v v' nv /\ eagree e e' ne1 /\ magree m m' (nlive ge sp nm1). @@ -712,7 +704,7 @@ Proof. econstructor. simpl. unfold Senv.symbol_address; simpl; rewrite FS; eauto. apply vagree_lessdef; auto. eapply magree_monotone; eauto. intros; eapply incl_nmem_add; eauto. -- exists (Senv.symbol_address ge id ofs); intuition auto with na. constructor. +- exists (Senv.symbol_address (Genv.to_senv ge) id ofs); intuition auto with na. constructor. - destruct (transfer_builtin_arg All (ne1, nm1) hi) as [ne' nm'] eqn:TR. exploit IHeval_builtin_arg2; eauto. intros (vlo' & A & B & C & D). exploit IHeval_builtin_arg1; eauto. intros (vhi' & P & Q & R & S). @@ -730,7 +722,7 @@ Qed. Lemma transfer_builtin_args_sound: forall e sp m e' m' bc al vl, - eval_builtin_args ge (fun r => e#r) (Vptr sp Ptrofs.zero) m al vl -> + eval_builtin_args (Genv.to_senv ge) (fun r => e#r) (Vptr sp Ptrofs.zero) m al vl -> forall ne1 nm1 ne2 nm2, transfer_builtin_args (ne1, nm1) al = (ne2, nm2) -> eagree e e' ne2 -> @@ -738,7 +730,7 @@ Lemma transfer_builtin_args_sound: genv_match bc ge -> bc sp = BCstack -> exists vl', - eval_builtin_args ge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' al vl' + eval_builtin_args (Genv.to_senv ge) (fun r => e'#r) (Vptr sp Ptrofs.zero) m' al vl' /\ Val.lessdef_list vl vl' /\ eagree e e' ne1 /\ magree m m' (nlive ge sp nm1). @@ -756,8 +748,8 @@ Lemma can_eval_builtin_arg: forall sp e m e' m' P, magree m m' P -> forall a v, - eval_builtin_arg ge (fun r => e#r) (Vptr sp Ptrofs.zero) m a v -> - exists v', eval_builtin_arg tge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' a v'. + eval_builtin_arg (Genv.to_senv ge) (fun r => e#r) (Vptr sp Ptrofs.zero) m a v -> + exists v', eval_builtin_arg (Genv.to_senv tge) (fun r => e'#r) (Vptr sp Ptrofs.zero) m' a v'. Proof. intros until P; intros MA. assert (LD: forall chunk addr cp v, @@ -783,8 +775,8 @@ Lemma can_eval_builtin_args: forall sp e m e' m' P, magree m m' P -> forall al vl, - eval_builtin_args ge (fun r => e#r) (Vptr sp Ptrofs.zero) m al vl -> - exists vl', eval_builtin_args tge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' al vl'. + eval_builtin_args (Genv.to_senv ge) (fun r => e#r) (Vptr sp Ptrofs.zero) m al vl -> + exists vl', eval_builtin_args (Genv.to_senv tge) (fun r => e'#r) (Vptr sp Ptrofs.zero) m' al vl'. Proof. induction 2. - exists (@nil val); constructor. @@ -797,12 +789,12 @@ Qed. Lemma transf_volatile_store: forall cp v1 v2 v1' v2' m tm chunk sp nm t v m', - volatile_store_sem chunk ge cp (v1::v2::nil) m t v m' -> + volatile_store_sem chunk (Genv.to_senv ge) cp (v1::v2::nil) m t v m' -> Val.lessdef v1 v1' -> vagree v2 v2' (store_argument chunk) -> magree m tm (nlive ge sp nm) -> v = Vundef /\ - exists tm', volatile_store_sem chunk ge cp (v1'::v2'::nil) tm t Vundef tm' + exists tm', volatile_store_sem chunk (Genv.to_senv ge) cp (v1'::v2'::nil) tm t Vundef tm' /\ magree m' tm' (nlive ge sp nm). Proof. intros. inv H. split; auto. @@ -1037,7 +1029,7 @@ Ltac UseTransfer := intros (tv1 & A & B & C & D). (* unfold comp_of in ALLOWED; simpl in ALLOWED; subst _x. *) inv H1. simpl in B. inv B. - assert (X: exists tvres, volatile_load ge (comp_of f) chunk tm b ofs t tvres /\ Val.lessdef vres tvres). + assert (X: exists tvres, volatile_load (Genv.to_senv ge) (comp_of f) chunk tm b ofs t tvres /\ Val.lessdef vres tvres). { inv H2. * exists (Val.load_result chunk v); split; auto. constructor; auto. @@ -1052,7 +1044,7 @@ Ltac UseTransfer := econstructor; split. eapply exec_Ibuiltin; eauto. simpl. (* rewrite comp_transf_function; eauto. *) - apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. + apply eval_builtin_args_preserved with (ge1 := ge) (* (CF1 := @has_comp_fundef _ has_comp_function) *). exact symbols_preserved. constructor. eauto. constructor. (* rewrite comp_transf_function; eauto. *) eapply external_call_symbols_preserved. apply senv_preserved. @@ -1116,6 +1108,7 @@ Ltac UseTransfer := eapply exec_Ibuiltin; eauto. (* rewrite <- comp_transf_function; eauto. *) apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. + constructor. eauto. constructor. eauto. constructor. rewrite <- comp_transf_function; eauto. eapply external_call_symbols_preserved. apply senv_preserved. @@ -1147,23 +1140,27 @@ Ltac UseTransfer := econstructor; split. eapply exec_Ibuiltin; eauto. (* rewrite <- comp_transf_function; eauto. *) - apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + apply eval_builtin_args_preserved with (ge1 := ge); eauto. + exact symbols_preserved. eapply external_call_symbols_preserved. apply senv_preserved. constructor. eapply eventval_list_match_lessdef; eauto 2 with na. + erewrite <- comp_transf_function; eauto. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. + (* annot val *) destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x2) as (ne1, nm1) eqn:TR. InvSoundState. exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D). - inv H1. inv B. inv H6. + inv H1. inv B. inv H7. econstructor; split. eapply exec_Ibuiltin; eauto. (* rewrite <- comp_transf_function; eauto. *) - apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + apply eval_builtin_args_preserved with (ge1 := ge); eauto. + exact symbols_preserved. eapply external_call_symbols_preserved. apply senv_preserved. constructor. eapply eventval_match_lessdef; eauto 2 with na. + erewrite <- comp_transf_function; eauto. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. + (* debug *) @@ -1189,7 +1186,8 @@ Ltac UseTransfer := intros (v' & tm' & P & Q & R & S). econstructor; split. eapply exec_Ibuiltin; eauto. - apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + apply eval_builtin_args_preserved with (ge1 := ge); eauto. + exact symbols_preserved. rewrite <- comp_transf_function; eauto. eapply external_call_symbols_preserved. apply senv_preserved. eauto. eapply match_succ_states; eauto. simpl; auto. @@ -1294,6 +1292,7 @@ Proof. apply forward_simulation_step with (match_states := fun s1 s2 => sound_state prog s1 /\ match_states s1 s2). - apply senv_preserved. +- apply senv_preserved. - simpl; intros. exploit transf_initial_states; eauto. intros [st2 [A B]]. exists st2; intuition. eapply sound_initial; eauto. - simpl; intros. destruct H. eapply transf_final_states; eauto. diff --git a/backend/Debugvar.v b/backend/Debugvar.v index f75a998dbb..2342c91a1b 100644 --- a/backend/Debugvar.v +++ b/backend/Debugvar.v @@ -364,6 +364,13 @@ Definition transf_function (f: function) : res function := Definition transf_fundef (fd: fundef) : res fundef := AST.transf_partial_fundef transf_function fd. +#[global] Instance comp_transf_function: has_comp_transl_partial transf_function. +Proof. + unfold transf_function. + intros f ? H. + now destruct ana_function; inv H. +Qed. + Definition transf_program (p: program) : res program := transform_partial_program transf_fundef p. diff --git a/backend/Debugvarproof.v b/backend/Debugvarproof.v index d6a0539f8c..09c734c0c3 100644 --- a/backend/Debugvarproof.v +++ b/backend/Debugvarproof.v @@ -23,14 +23,6 @@ Require Import Debugvar. Definition match_prog (p tp: program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. -#[global] -Instance comp_transf_function: has_comp_transl_partial transf_function. -Proof. - unfold transf_function. - intros f ? H. - now destruct ana_function; inv H. -Qed. - Lemma transf_program_match: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. @@ -660,6 +652,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_plus. apply senv_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. eexact transf_step_correct. diff --git a/backend/Inlining.v b/backend/Inlining.v index d4468701a3..40404ab16b 100644 --- a/backend/Inlining.v +++ b/backend/Inlining.v @@ -472,6 +472,17 @@ Definition transf_function (fenv: funenv) (f: function) : Errors.res function := Definition transf_fundef (fenv: funenv) (fd: fundef) : Errors.res fundef := AST.transf_partial_fundef (transf_function fenv) fd. +#[global] Instance comp_transl_function fenv: + has_comp_transl_partial (transf_function fenv). +Proof. + unfold transf_function. + intros f tf H; try now inv H. + destruct (expand_function _ _ _). + destruct (zlt _ _); try easy. + simpl in *. + now inv H. +Qed. + Definition transf_program (p: program): Errors.res program := let fenv := funenv_program p in AST.transform_partial_program (transf_fundef fenv) p. diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index 8f2e580e30..ea661f154c 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -20,18 +20,6 @@ Require Import Inlining Inliningspec. Definition match_prog (prog tprog: program) := match_program (fun cunit f tf => transf_fundef (funenv_program cunit) f = OK tf) eq prog tprog. -#[global] -Instance comp_transl_function fenv: - has_comp_transl_partial (transf_function fenv). -Proof. - unfold transf_function. - intros f tf H; try now inv 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. @@ -46,12 +34,14 @@ Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. +Let HYPOTHESIS := @has_comp_fundef function _. + Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof (Genv.find_symbol_match TRANSF). Lemma senv_preserved: - Senv.equiv ge tge. + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof (Genv.senv_match TRANSF). Lemma functions_translated: @@ -493,8 +483,8 @@ Lemma tr_builtin_arg: F sp = Some(sp', ctx.(dstk)) -> Mem.inject F m m' -> forall a v, - eval_builtin_arg ge (fun r => rs#r) (Vptr sp Ptrofs.zero) m a v -> - exists v', eval_builtin_arg tge (fun r => rs'#r) (Vptr sp' Ptrofs.zero) m' (sbuiltinarg ctx a) v' + eval_builtin_arg (Genv.to_senv ge) (fun r => rs#r) (Vptr sp Ptrofs.zero) m a v -> + exists v', eval_builtin_arg (Genv.to_senv tge) (fun r => rs'#r) (Vptr sp' Ptrofs.zero) m' (sbuiltinarg ctx a) v' /\ Val.inject F v v'. Proof. intros until m'; intros MG AG SP MI. induction 1; simpl. @@ -508,7 +498,7 @@ Proof. simpl. econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. intros (v' & A & B). exists v'; split; auto. econstructor. simpl. rewrite Ptrofs.add_zero_l; eauto. - econstructor; split. constructor. simpl. econstructor; eauto. rewrite ! Ptrofs.add_zero_l; auto. -- assert (Val.inject F (Senv.symbol_address ge id ofs) (Senv.symbol_address tge id ofs)). +- assert (Val.inject F (Senv.symbol_address (Genv.to_senv ge) id ofs) (Senv.symbol_address (Genv.to_senv tge) id ofs)). { unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. rewrite symbols_preserved. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. inv MG. econstructor. eauto. rewrite Ptrofs.add_zero; auto. } @@ -534,8 +524,8 @@ Lemma tr_builtin_args: F sp = Some(sp', ctx.(dstk)) -> Mem.inject F m m' -> forall al vl, - eval_builtin_args ge (fun r => rs#r) (Vptr sp Ptrofs.zero) m al vl -> - exists vl', eval_builtin_args tge (fun r => rs'#r) (Vptr sp' Ptrofs.zero) m' (map (sbuiltinarg ctx) al) vl' + eval_builtin_args (Genv.to_senv ge) (fun r => rs#r) (Vptr sp Ptrofs.zero) m al vl -> + exists vl', eval_builtin_args (Genv.to_senv tge) (fun r => rs'#r) (Vptr sp' Ptrofs.zero) m' (map (sbuiltinarg ctx) al) vl' /\ Val.inject_list F vl vl'. Proof. induction 5; simpl. @@ -1606,6 +1596,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_star. apply senv_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. eexact step_simulation. diff --git a/backend/Linearize.v b/backend/Linearize.v index c07dd5888e..e8d7e03d8e 100644 --- a/backend/Linearize.v +++ b/backend/Linearize.v @@ -214,5 +214,11 @@ Definition transf_function (f: LTL.function) : res Linear.function := Definition transf_fundef (f: LTL.fundef) : res Linear.fundef := AST.transf_partial_fundef transf_function f. +#[global] Instance comp_transf_fundef: has_comp_transl_partial transf_function. +Proof. + unfold transf_function. + intros f ? H; now monadInv H. +Qed. + Definition transf_program (p: LTL.program) : res Linear.program := transform_partial_program transf_fundef p. diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index 466ab205be..c5ecdbbaf1 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -24,13 +24,6 @@ Module NodesetFacts := FSetFacts.Facts(Nodeset). Definition match_prog (p: LTL.program) (tp: Linear.program) := match_program (fun ctx f tf => transf_fundef f = OK tf) eq p tp. -#[global] -Instance comp_transf_fundef: has_comp_transl_partial transf_function. -Proof. - unfold transf_function. - intros f ? H; now monadInv H. -Qed. - Lemma transf_program_match: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. @@ -842,6 +835,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_star. apply senv_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. eexact transf_step_correct. diff --git a/backend/RTLgen.v b/backend/RTLgen.v index 3946e438cd..4d4c422abb 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -690,6 +690,15 @@ Definition transl_function (f: CminorSel.function) : Errors.res RTL.function := nentry) end. +#[global] Instance comp_transl_function: has_comp_transl_partial transl_function. +Proof. + intros f y H. + destruct (transl_function f) eqn:EQ; simpl in H; try congruence. inv H. + unfold transl_function in EQ. + destruct (transl_fun f init_state) as [|[] ? ?] eqn:?; simpl in EQ; try congruence. inv EQ. + reflexivity. +Qed. + Definition transl_fundef := transf_partial_fundef transl_function. (** Translation of a whole program. *) diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index e221970e40..0cb2c7738f 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -350,18 +350,10 @@ Require Import Errors. Definition match_prog (p: CminorSel.program) (tp: RTL.program) := match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp. -#[global] Instance comp_transl_function: has_comp_transl_partial transl_function. -Proof. - unfold transl_function. - intros f tf H; simpl in *. - destruct (transl_fun _ _) as [|[??] ? ?]; try discriminate. - now inv H. -Qed. - Lemma transf_program_match: forall p tp, transl_program p = OK tp -> match_prog p tp. Proof. - intros. apply match_transform_partial_program; auto. + intros. eapply match_transform_partial_program; auto. Qed. @@ -1756,6 +1748,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_star_wf with (order := lt_state). apply senv_preserved. + apply senv_preserved. eexact transl_initial_states. eexact transl_final_states. apply lt_state_wf. diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index f7a9484967..105c2d35b4 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -945,11 +945,11 @@ Proof. (* Icall *) assert (wt_fundef fd). destruct ros; simpl in H0. - pattern fd. apply Genv.find_funct_prop with unit p (rs#r). + pattern fd. apply Genv.find_funct_prop with unit _ p (rs#r). exact wt_p. exact H0. unfold find_function in H0. simpl in H0. caseEq (Genv.find_symbol ge i); intros; rewrite H1 in H0. - pattern fd. apply Genv.find_funct_ptr_prop with unit p b. + pattern fd. apply Genv.find_funct_ptr_prop with unit _ p b. exact wt_p. exact H0. discriminate. econstructor; eauto. @@ -958,11 +958,11 @@ Proof. (* Itailcall *) assert (wt_fundef fd). destruct ros; simpl in H0. - pattern fd. apply Genv.find_funct_prop with unit p (rs#r). + pattern fd. apply Genv.find_funct_prop with unit _ p (rs#r). exact wt_p. now eauto. unfold find_function in H0. simpl in H0. caseEq (Genv.find_symbol ge i); intros; rewrite H1 in H0. - pattern fd. apply Genv.find_funct_ptr_prop with unit p b. + pattern fd. apply Genv.find_funct_ptr_prop with unit _ p b. exact wt_p. now eauto. discriminate. econstructor; eauto. @@ -993,7 +993,7 @@ Lemma wt_initial_state: forall S, initial_state p S -> wt_state S. Proof. intros. inv H. constructor. constructor. rewrite H3; auto. - pattern f. apply Genv.find_funct_ptr_prop with unit p b. + pattern f. apply Genv.find_funct_ptr_prop with unit _ p b. exact wt_p. exact H2. rewrite H3. constructor. Qed. diff --git a/backend/Renumber.v b/backend/Renumber.v index 6e6bc72854..7e1ab696fe 100644 --- a/backend/Renumber.v +++ b/backend/Renumber.v @@ -15,7 +15,7 @@ Require Import Coqlib. Require Import Maps. Require Import Postorder. -Require Import RTL. +Require Import AST RTL. (** CompCert's dataflow analyses (module [Kildall]) are more precise and run faster when the sequence [1, 2, 3, ...] is a postorder @@ -77,5 +77,8 @@ Definition transf_function (f: function) : function := Definition transf_fundef (fd: fundef) : fundef := AST.transf_fundef transf_function fd. +#[global] Instance comp_transf_function: has_comp_transl transf_function. +Proof. now intros. Qed. + Definition transf_program (p: program) : program := AST.transform_program transf_fundef p. diff --git a/backend/Renumberproof.v b/backend/Renumberproof.v index c053ce89c3..ec21f1b07c 100644 --- a/backend/Renumberproof.v +++ b/backend/Renumberproof.v @@ -20,10 +20,6 @@ Require Import Op Registers RTL Renumber. Definition match_prog (p tp: RTL.program) := match_program (fun ctx f tf => tf = transf_fundef f) eq p tp. -#[global] -Instance comp_transf_function: has_comp_transl transf_function. -Proof. now intros. Qed. - Lemma transf_program_match: forall p, match_prog p (transf_program p). Proof. @@ -56,7 +52,7 @@ Lemma symbols_preserved: Proof (Genv.find_symbol_transf TRANSL). Lemma senv_preserved: - Senv.equiv ge tge. + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof (Genv.senv_transf TRANSL). Lemma sig_preserved: @@ -334,6 +330,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_step. apply senv_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. exact step_simulation. diff --git a/backend/Selection.v b/backend/Selection.v index 60d0851362..1380e1e591 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -467,6 +467,16 @@ Definition sel_function (dm: PTree.t globdef) (hf: helper_functions) (f: Cminor. Definition sel_fundef (dm: PTree.t globdef) (hf: helper_functions) (f: Cminor.fundef) : res fundef := transf_partial_fundef (sel_function dm hf) f. +Instance sel_fundef_comp dm hf: has_comp_transl_partial (sel_fundef dm hf). +Proof. + unfold has_comp_transl_partial. + intros. unfold sel_fundef in H. + destruct x; auto. + - simpl in H. monadInv H. unfold sel_function in EQ. + monadInv EQ. reflexivity. + - simpl in H. inv H. reflexivity. +Qed. + (** Setting up the helper functions. *) (** We build a partial mapping from global identifiers to their definitions, diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 80f58fcae6..5918f1c570 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -936,7 +936,7 @@ Hypothesis HF: helper_functions_declared cunit hf. Lemma sel_builtin_default_correct: forall optid ef al sp e1 m1 vl t v m2 e1' m1' k, Cminor.eval_exprlist ge sp e1 m1 (comp_of f) al vl -> - external_call ef ge (comp_of f) vl m1 t v m2 -> + external_call ef (Genv.to_senv ge) (comp_of f) vl m1 t v m2 -> env_lessdef e1 e1' -> Mem.extends m1 m1' -> exists e2' m2', plus step tge (State f (sel_builtin_default optid ef al) k sp e1' m1') @@ -958,7 +958,7 @@ Qed. Lemma sel_builtin_correct: forall optid ef al sp e1 m1 vl t v m2 e1' m1' k, Cminor.eval_exprlist ge sp e1 m1 (comp_of f) al vl -> - external_call ef ge (comp_of f) vl m1 t v m2 -> + external_call ef (Genv.to_senv ge) (comp_of f) vl m1 t v m2 -> env_lessdef e1 e1' -> Mem.extends m1 m1' -> (* forall ALLOWED: Policy.allowed_call (comp_of f) (External ef), *) exists e2' m2', @@ -1663,6 +1663,7 @@ Proof. set (MS := fun S T => match_states S T /\ wt_state S). apply forward_simulation_eventually_star with (measure := measure) (match_states := MS). - apply senv_preserved. +- apply senv_preserved. - intros S INIT. exploit sel_initial_states; eauto. intros (T & P & Q). assert (W: wt_state S). { eapply wt_initial_state. eexact wt_prog. auto. } unfold MS. diff --git a/backend/SplitLongproof.v b/backend/SplitLongproof.v index 38becfdbef..dd9e9ebaa1 100644 --- a/backend/SplitLongproof.v +++ b/backend/SplitLongproof.v @@ -23,10 +23,10 @@ Local Open Scope string_scope. (** * Properties of the helper functions *) -Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := +Definition helper_declared {F V: Type} {CF: has_comp F} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := (prog_defmap p)!id = Some (Gfun (External (EF_runtime name sg))). -Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) V) (hf: helper_functions) : Prop := +Definition helper_functions_declared {F V: Type} {CF: has_comp F} (p: AST.program (AST.fundef F) V) (hf: helper_functions) : Prop := helper_declared p i64_dtos "__compcert_i64_dtos" sig_f_l /\ helper_declared p i64_dtou "__compcert_i64_dtou" sig_f_l /\ helper_declared p i64_stod "__compcert_i64_stod" sig_l_f diff --git a/backend/Stacking.v b/backend/Stacking.v index 99592133b2..34d6dfbc0e 100644 --- a/backend/Stacking.v +++ b/backend/Stacking.v @@ -201,5 +201,14 @@ Definition transf_function (f: Linear.function) : res Mach.function := Definition transf_fundef (f: Linear.fundef) : res Mach.fundef := AST.transf_partial_fundef transf_function f. +#[global] Instance comp_transf_function: has_comp_transl_partial transf_function. +Proof. + unfold transf_function. + intros f tf H. + destruct negb; try easy. + destruct zlt; try easy. + now monadInv H. +Qed. + Definition transf_program (p: Linear.program) : res Mach.program := transform_partial_program transf_fundef p. diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index cd78a882d5..b5f551a424 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -26,16 +26,6 @@ Local Open Scope sep_scope. Definition match_prog (p: Linear.program) (tp: Mach.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. -#[global] -Instance comp_transf_function: has_comp_transl_partial transf_function. -Proof. - unfold transf_function. - intros f tf H. - destruct negb; try easy. - destruct zlt; try easy. - now monadInv H. -Qed. - Lemma transf_program_match: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. @@ -2349,6 +2339,8 @@ Proof. intros [vargs' [P Q]]. rewrite <- sep_assoc, sep_comm, sep_assoc in SEP. exploit external_call_parallel_rule; eauto. + (* TODO: why can't Coq find the instance automatically?? *) + eapply has_comp_fundef. eapply Linear.has_comp_function. clear SEP; intros (j' & res' & m1' & EC & RES & SEP & INCR & ISEP). rewrite <- sep_assoc, sep_comm, sep_assoc in SEP. econstructor; split. @@ -2468,6 +2460,7 @@ Proof. exploit transl_external_arguments; eauto. apply sep_proj1 in SEP; eauto. intros [vl [ARGS VINJ]]. rewrite sep_comm, sep_assoc in SEP. exploit external_call_parallel_rule; eauto. + eapply has_comp_fundef. eapply Linear.has_comp_function. intros (j' & res' & m1' & A & B & C & D & E). econstructor; split. apply plus_one. eapply exec_function_external; eauto. @@ -2583,6 +2576,7 @@ Proof. set (ms := fun s s' => wt_state s /\ match_states s s'). eapply forward_simulation_plus with (match_states := ms). - apply senv_preserved. +- apply senv_preserved. - intros. exploit transf_initial_states; eauto. intros [st2 [A B]]. exists st2; split; auto. split; auto. apply wt_initial_state with (prog := prog); auto. exact wt_prog. diff --git a/backend/Tailcall.v b/backend/Tailcall.v index 8e6a7d8676..e73ac5d8bc 100644 --- a/backend/Tailcall.v +++ b/backend/Tailcall.v @@ -127,5 +127,12 @@ Definition transf_function (ce: compenv) (f: function) : function := Definition transf_fundef (ce: compenv) (fd: fundef) : fundef := AST.transf_fundef (transf_function ce) fd. +#[global] Instance comp_transf_function cenv: has_comp_transl (transf_function cenv). +Proof. + unfold transf_function, RTL.transf_function. + intros f; simpl; trivial. + now destruct zeq. +Qed. + Definition transf_program (p: program) : program := transform_program (transf_fundef (compenv_program p)) p. diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index b95b3d8c06..577c42db85 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -206,14 +206,6 @@ Qed. Definition match_prog (p tp: RTL.program) := match_program (fun cu f tf => tf = transf_fundef (compenv_program cu) f) eq p tp. -#[global] -Instance comp_transf_function cenv: has_comp_transl (transf_function cenv). -Proof. - unfold transf_function, RTL.transf_function. - intros f; simpl; trivial. - now destruct zeq. -Qed. - Lemma transf_program_match: forall p, match_prog p (transf_program p). Proof. @@ -247,7 +239,7 @@ Lemma funct_ptr_translated: Proof (Genv.find_funct_ptr_match TRANSL). Lemma senv_preserved: - Senv.equiv ge tge. + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof (Genv.senv_match TRANSL). Lemma sig_preserved: @@ -742,7 +734,7 @@ Proof. - (* builtin *) TransfInstr. - exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)); eauto. + exploit (@eval_builtin_args_lessdef _ (Genv.to_senv ge) (fun r => rs#r) (fun r => rs'#r)); eauto. intros (vargs' & P & Q). exploit external_call_mem_extends; eauto. intros [v' [m'1 [A [B [C D]]]]]. @@ -902,6 +894,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_opt with (measure := measure); eauto. apply senv_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. exact transf_step_correct. diff --git a/backend/Tunneling.v b/backend/Tunneling.v index a5433b414d..2437f56bd7 100644 --- a/backend/Tunneling.v +++ b/backend/Tunneling.v @@ -189,5 +189,9 @@ Definition tunnel_function (f: LTL.function) : LTL.function := Definition tunnel_fundef (f: LTL.fundef) : LTL.fundef := transf_fundef tunnel_function f. +#[global] +Instance comp_tunnel_fundef: has_comp_transl tunnel_function. +Proof. now intro. Qed. + Definition tunnel_program (p: LTL.program) : LTL.program := transform_program tunnel_fundef p. diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index 76ce598d6b..c55ff82273 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -22,10 +22,6 @@ Require Import Tunneling. Definition match_prog (p tp: program) := match_program (fun ctx f tf => tf = tunnel_fundef f) eq p tp. -#[global] -Instance comp_tunnel_fundef: has_comp_transl tunnel_function. -Proof. now intro. Qed. - Lemma transf_program_match: forall p, match_prog p (tunnel_program p). Proof. @@ -860,6 +856,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_opt. apply senv_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. eexact tunnel_step_correct. diff --git a/backend/Unusedglob.v b/backend/Unusedglob.v index 22a0f2b550..df9d8195a6 100644 --- a/backend/Unusedglob.v +++ b/backend/Unusedglob.v @@ -126,7 +126,7 @@ Fixpoint filter_globdefs (used: IS.t) (accu defs: list (ident * globdef fundef u Definition global_defined (p: program) (pm: prog_map) (id: ident) : bool := match pm!id with Some _ => true | None => ident_eq id (prog_main p) end. -Definition transform_program (p: program) : res program := +Program Definition transform_program (p: program) : res program := let pm := prog_defmap p in match used_globals p pm with | None => Error (msg "Unusedglob: analysis failed") @@ -136,8 +136,10 @@ Definition transform_program (p: program) : res program := prog_public := p.(prog_public); prog_main := p.(prog_main); prog_pol := p.(prog_pol); - prog_pol_pub := p.(prog_pol_pub); |} + prog_pol_pub := p.(prog_pol_pub); + prog_agr_comps := _ |} else Error (msg "Unusedglob: reference to undefined global") end. - +Next Obligation. +Admitted. diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index 4cd1f52aa9..c7572b3778 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -434,14 +434,16 @@ Theorem transf_program_match: forall p tp, transform_program p = OK tp -> match_prog p tp. Proof. unfold transform_program; intros p tp TR. set (pm := prog_defmap p) in *. - destruct (used_globals p pm) as [u|] eqn:U; try discriminate. - destruct (IS.for_all (global_defined p pm) u) eqn:DEF; inv TR. - exists u; split. - apply used_globals_valid; auto. - constructor; simpl; auto. - intros. unfold prog_defmap; simpl. apply filter_globdefs_map. - apply filter_globdefs_unique_names. -Qed. + admit. +Admitted. +(* destruct (used_globals p pm) as [u|] eqn:U; try discriminate. *) +(* destruct (IS.for_all (global_defined p pm) u) eqn:DEF; inv TR. *) +(* exists u; split. *) +(* apply used_globals_valid; auto. *) +(* constructor; simpl; auto. *) +(* intros. unfold prog_defmap; simpl. apply filter_globdefs_map. *) +(* apply filter_globdefs_unique_names. *) +(* Qed. *) (** * Semantic preservation *) @@ -591,14 +593,14 @@ Proof. Qed. Lemma globals_symbols_inject: - forall j, meminj_preserves_globals j -> symbols_inject j ge tge. + forall j cp, meminj_preserves_globals j -> symbols_inject j (Genv.to_senv ge) (Genv.to_senv tge) cp. Proof. intros. assert (E1: Genv.genv_public ge = p.(prog_public)). { apply Genv.globalenv_public. } assert (E2: Genv.genv_public tge = p.(prog_public)). { unfold tge; rewrite Genv.globalenv_public. eapply match_prog_public; eauto. } - split; [|split;[|split]]; intros. + split; [|split; [|split; [| split]]]; intros. + simpl; unfold Genv.public_symbol; rewrite E1, E2. destruct (Genv.find_symbol tge id) as [b'|] eqn:TFS. exploit symbols_inject_3; eauto. intros (b & FS & INJ). rewrite FS. auto. @@ -624,6 +626,10 @@ Proof. rewrite Genv.find_var_info_iff in V2. exploit defs_rev_inject; eauto. intros (A & B). rewrite <- Genv.find_var_info_iff in A. congruence. + + simpl. unfold ge, tge. + unfold Genv.globalenv. + rewrite 2!Genv.genv_pol_add_globals. simpl. + erewrite <- match_prog_pol; eauto. Qed. Lemma symbol_address_inject: @@ -877,7 +883,7 @@ Proof. * apply Genv.find_invert_symbol. apply Genv.invert_find_symbol in H21. pose proof (globals_symbols_inject) as E. - specialize (E j H). unfold symbols_inject in E. + specialize (E j cp 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_in_genv. now rewrite D. @@ -917,7 +923,7 @@ Proof. * apply Genv.find_invert_symbol. apply Genv.invert_find_symbol in H21. pose proof (globals_symbols_inject) as E. - specialize (E j H). unfold symbols_inject in E. + specialize (E j cp 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. * now rewrite <- H22. @@ -1455,9 +1461,14 @@ Proof. intros. eapply forward_simulation_step. exploit globals_symbols_inject. apply init_meminj_preserves_globals. intros [A B]. exact A. + exploit globals_symbols_inject. apply init_meminj_preserves_globals. intros (A & B & C & D & E). + intros; rewrite E; eauto. eexact transf_initial_states. eexact transf_final_states. eexact step_simulation. + Unshelve. + exact bottom. + exact bottom. Qed. End SOUNDNESS. @@ -1619,7 +1630,8 @@ Proof. + rewrite W. constructor; simpl; intros. * eapply match_prog_main; eauto. * rewrite (match_prog_public _ _ _ B1), (match_prog_public _ _ _ B2). auto. -* rewrite (match_prog_pol _ _ _ B1). auto. +* rewrite (match_prog_pol _ _ _ B1). rewrite (match_prog_pol _ _ _ B2). + admit. * rewrite ! prog_defmap_elements, !PTree.gcombine by auto. rewrite (match_prog_def _ _ _ B1 id), (match_prog_def _ _ _ B2 id). rewrite ISF.union_b. @@ -1645,6 +1657,6 @@ Proof. destruct (IS.mem id used1), (IS.mem id used2); auto. } * intros. apply PTree.elements_keys_norepet. -Qed. +Admitted. Global Instance TransfSelectionLink : TransfLink match_prog := link_match_program. diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index 525e1c90b2..ee984d88bb 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -958,7 +958,7 @@ Theorem external_call_match: Proof. intros until am; intros EC GENV ARGS RO MM NOSTACK. (* Part 1: using ec_mem_inject *) - exploit (@external_call_mem_inject ef _ _ ge cp vargs m t vres m' (inj_of_bc bc) m vargs). + exploit (@external_call_mem_inject ef _ _ ge _ cp vargs m t vres m' (inj_of_bc bc) m vargs). apply inj_of_bc_preserves_globals; auto. exact EC. eapply mmatch_inj; eauto. eapply mmatch_below; eauto. @@ -1428,7 +1428,7 @@ Proof. inv H2. * (* true volatile access *) assert (V: vmatch bc v (Ifptr Glob)). - { inv H3; simpl in *; constructor. econstructor. eapply GE; eauto. } + { inv H4; simpl in *; constructor. econstructor. eapply GE; eauto. } destruct (va_strict tt). apply vmatch_lub_r. apply vnormalize_sound. auto. apply vnormalize_sound. eapply vmatch_ge; eauto. constructor. constructor. * (* normal memory access *) @@ -2051,7 +2051,7 @@ Lemma aaddr_arg_sound: forall cunit prog s f sp pc e m a b ofs, sound_state prog (State s f (Vptr sp Ptrofs.zero) pc e m) -> linkorder cunit prog -> - eval_builtin_arg (Genv.globalenv prog) (fun r => e#r) (Vptr sp Ptrofs.zero) m a (Vptr b ofs) -> + eval_builtin_arg (Genv.to_senv (Genv.globalenv prog)) (fun r => e#r) (Vptr sp Ptrofs.zero) m a (Vptr b ofs) -> exists bc, pmatch bc b ofs (aaddr_arg (analyze (romem_for cunit) f)!!pc a) /\ genv_match bc (Genv.globalenv prog) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index d1deb4ca47..1c9dfacad2 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -1484,7 +1484,8 @@ let of_list' l = (* FIXME: this is very ad-hoc. I'm worried that by generating new names using "intern_string", we might be doing something bad. Ideally, we should inspect *) (* the rest of the file and figure out how the translation between C.ident and AST.ident works. *) -let build_policy (imports: C.import list) (exports: C.export list): AST.Policy.t = +let build_policy (gl: (AST.ident * ('f Ctypes.fundef, Ctypes.coq_type) AST.globdef) list) + (imports: C.import list) (exports: C.export list): AST.Policy.t = let open AST.Policy in let exports' = List.map (function Export(id1, id2) -> (Comp (intern_string id1.name), intern_string id2.name)) exports in let exports'': AST.ident list CompTree.t = of_list' exports' in @@ -1492,8 +1493,10 @@ let build_policy (imports: C.import list) (exports: C.export list): AST.Policy.t (Comp (intern_string id1.name), (Comp (intern_string id2.name), intern_string id3.name))) imports in let imports'': (compartment * AST.ident) list Maps.PTree.t = of_list' imports' in (* let imports'': (AST.compartment * AST.ident) list Maps.PTree.t = Maps.PTree_Properties.of_list [] in *) - let p = { policy_export = exports''; - policy_import = imports'' } in + let p = { policy_comps = Maps.PTree_Properties.of_list (List.map (function (id, gd) -> + (id, AST.comp_of (AST.comp_of (AST.has_comp_globdef (Ctypes.has_comp_fundef Csyntax.has_comp_function))) gd)) gl); + policy_export = exports''; + policy_import = imports'' } in p (** Complete the debug information of struct/unions *) @@ -1567,7 +1570,7 @@ let convertProgram (p, (imports, exports)) = let gl3 = add_helper_functions cps gl2 in comp_env := Maps.PTree.empty; let p' = - { prog_pol = build_policy imports exports ; + { prog_pol = build_policy gl3 imports exports ; prog_defs = gl3; prog_public = public_globals gl3; prog_main = intern_string !Clflags.main_function_name; diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v index 33067c9f03..40a5c0e90b 100644 --- a/cfrontend/Cminorgen.v +++ b/cfrontend/Cminorgen.v @@ -277,5 +277,24 @@ Definition transl_function (f: Csharpminor.function): res function := Definition transl_fundef (f: Csharpminor.fundef): res fundef := transf_partial_fundef transl_function f. +#[global] +Instance comp_transl_funbody ce stacksize: + has_comp_transl_partial (transl_funbody ce stacksize). +Proof. + unfold transl_funbody. + intros f tf H. + now monadInv H. +Qed. + +#[global] +Instance comp_transl_function: has_comp_transl_partial transl_function. +Proof. + unfold transl_function, transl_funbody. + intros f tf H. + destruct build_compilenv. + destruct zle; try easy. + now monadInv H. +Qed. + Definition transl_program (p: Csharpminor.program) : res program := transform_partial_program transl_fundef p. diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index d83762ebee..2c52ddac1e 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -25,29 +25,10 @@ Local Open Scope error_monad_scope. Definition match_prog (p: Csharpminor.program) (tp: Cminor.program) := match_program (fun cu f tf => transl_fundef f = OK tf) eq p tp. -#[global] -Instance comp_transl_funbody ce stacksize: - has_comp_transl_partial (transl_funbody ce stacksize). -Proof. - unfold transl_funbody. - intros f tf H. - now monadInv H. -Qed. - -#[global] -Instance comp_transl_function: has_comp_transl_partial transl_function. -Proof. - unfold transl_function, transl_funbody. - intros f tf H. - destruct build_compilenv. - destruct zle; try easy. - now monadInv H. -Qed. - Lemma transf_program_match: forall p tp, transl_program p = OK tp -> match_prog p tp. Proof. - intros. apply match_transform_partial_program; auto. + intros. eapply match_transform_partial_program; auto. Qed. Section TRANSLATION. @@ -2151,6 +2132,8 @@ Proof. intros [tvargs [EVAL2 VINJ2]]. exploit match_callstack_match_globalenvs; eauto. intros [hi' MG]. exploit external_call_mem_inject; eauto. + (* TODO: why can't Coq find this on its own? *) + eapply has_comp_fundef. eapply Csharpminor.has_comp_function. eapply inj_preserves_globals; eauto. intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR SEPARATED]]]]]]]]]. left; econstructor; split. @@ -2318,6 +2301,7 @@ Opaque PTree.set. monadInv TR. exploit match_callstack_match_globalenvs; eauto. intros [hi MG]. exploit external_call_mem_inject; eauto. + eapply has_comp_fundef. eapply Csharpminor.has_comp_function. eapply inj_preserves_globals; eauto. intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR SEPARATED]]]]]]]]]. left; econstructor; split. @@ -2392,6 +2376,7 @@ Theorem transl_program_correct: Proof. eapply forward_simulation_star; eauto. apply senv_preserved. + apply senv_preserved. eexact transl_initial_states. eexact transl_final_states. eexact transl_step_correct. diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index ea952bcb15..b1785d0ad0 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -775,6 +775,19 @@ Definition transl_fundef (ce: composite_env) (id: ident) (f: Clight.fundef) : re Definition transl_globvar (id: ident) (ty: type) := OK tt. +#[global] Instance comp_transl_function ctx: has_comp_transl_partial (transl_function ctx). +Proof. + unfold transl_function. now intros ?? H; monadInv H. +Qed. + +Instance comp_transl_fundef ctx: forall id, has_comp_transl_partial (transl_fundef ctx id). +Proof. + intros id f tf. + destruct f; simpl; intros H; try monadInv H. + - exploit comp_transl_function; eauto. + - destruct signature_eq; try congruence. inv H; auto. +Qed. + Definition transl_program (p: Clight.program) : res program := transform_partial_program2 (transl_fundef p.(prog_comp_env)) transl_globvar p. diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index c5d9bdf030..1f007c963d 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -33,14 +33,7 @@ Definition match_varinfo (v: type) (tv: unit) := True. Definition match_prog (p: Clight.program) (tp: Csharpminor.program) : Prop := match_program_gen match_fundef match_varinfo p p tp. -#[global] -Instance comp_transl_function ctx: has_comp_transl_partial (transl_function ctx). -Proof. - unfold transl_function. now intros ?? H; monadInv H. -Qed. - -#[global] -Instance comp_match_fundef: has_comp_match match_fundef. +#[global] Instance comp_match_fundef: has_comp_match match_fundef. Proof. intros cu ? ? [f tf H|]; trivial. exact (comp_transl_partial _ H). @@ -2090,6 +2083,7 @@ Theorem transl_program_correct: Proof. eapply forward_simulation_plus. apply senv_preserved. + apply senv_preserved. eexact transl_initial_states. eexact transl_final_states. eexact transl_step. diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index 0a29656911..7517e64af9 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -1499,6 +1499,7 @@ Set Implicit Arguments. Section PROGRAMS. Variable F: Type. +Context {CF: has_comp F}. (** Functions can either be defined ([Internal]) or declared as external functions ([External]). *) @@ -1507,7 +1508,7 @@ Inductive fundef : Type := | Internal: F -> fundef | External: external_function -> typelist -> type -> calling_convention -> fundef. -#[export] Instance has_comp_fundef {CF: has_comp F} : has_comp fundef := +#[export] Instance has_comp_fundef : has_comp fundef := fun fd => match fd with | Internal f => comp_of f @@ -1531,6 +1532,7 @@ Record program : Type := { prog_comp_env: composite_env; prog_comp_env_eq: build_composite_env prog_types = OK prog_comp_env; prog_pol_pub: Policy.in_pub prog_pol prog_public; + prog_agr_comps : agr_comps prog_pol prog_defs; }. Definition program_of_program (p: program) : AST.program fundef type := @@ -1538,10 +1540,22 @@ Definition program_of_program (p: program) : AST.program fundef type := AST.prog_public := p.(prog_public); AST.prog_main := p.(prog_main); AST.prog_pol := p.(prog_pol); - AST.prog_pol_pub := p.(prog_pol_pub) |}. + AST.prog_pol_pub := p.(prog_pol_pub); + AST.prog_agr_comps := p.(prog_agr_comps); + |}. Coercion program_of_program: program >-> AST.program. +Lemma agr_enforce_update_policy: + forall (pol : Policy.t) (defs : list (ident * globdef fundef type)) + (public: list ident), + agr_comps (Policy.enforce_in_pub (update_policy pol defs) public) defs. +Proof. + intros. + unfold Policy.enforce_in_pub. + exploit agr_update_policy; eauto. +Qed. + Program Definition make_program (types: list composite_definition) (defs: list (ident * globdef fundef type)) (public: list ident) @@ -1552,15 +1566,17 @@ Program Definition make_program (types: list composite_definition) OK {| prog_defs := defs; prog_public := public; prog_main := main; - prog_pol := Policy.enforce_in_pub pol public; + prog_pol := Policy.enforce_in_pub (update_policy pol defs) public; prog_types := types; prog_comp_env := ce; prog_comp_env_eq := _; - prog_pol_pub := Policy.enforce_in_pub_correct pol public; |} + prog_pol_pub := Policy.enforce_in_pub_correct pol public; + prog_agr_comps := (agr_enforce_update_policy _ _ _) |} end. End PROGRAMS. +Arguments program F {CF}. Arguments External {F} _ _ _ _. Unset Implicit Arguments. @@ -1875,6 +1891,7 @@ Definition link_program {F:Type} {CF: has_comp F} (p1 p2: program F): option (pr prog_comp_env := env; prog_comp_env_eq := P; prog_pol_pub := p.(AST.prog_pol_pub); + prog_agr_comps := p.(AST.prog_agr_comps); |} end end diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v index 31a2433591..dbefd7ee3a 100644 --- a/cfrontend/Ctyping.v +++ b/cfrontend/Ctyping.v @@ -930,6 +930,28 @@ Definition retype_fundef (ce: composite_env) (e: typenv) (fd: fundef) : res fund assertion (rettype_eq (ef_sig ef).(sig_res) (rettype_of_type res)); OK fd end. +Lemma todo_fix: forall (tp: AST.program fundef type) (p: program), + agr_comps (AST.prog_pol tp) (AST.prog_defs tp) -> + agr_comps (prog_pol p) (AST.prog_defs tp). +Proof. + Admitted. + +Instance has_comp_retype_function (ce: composite_env) (e: typenv): + has_comp_transl_partial (retype_function ce e). +Proof. + intros f tf. + unfold retype_function. intros H. + monadInv H. reflexivity. +Qed. + +Instance has_comp_retype_fundef (ce: composite_env) (e: typenv): + has_comp_transl_partial (retype_fundef ce e). +Proof. + intros f tf. + destruct f; simpl; intros H; monadInv H; auto. + exploit has_comp_retype_function; eauto. +Qed. + Definition typecheck_program (p: program) : res program := let e := bind_globdef (PTree.empty _) p.(prog_defs) in let ce := p.(prog_comp_env) in @@ -941,7 +963,9 @@ Definition typecheck_program (p: program) : res program := prog_types := p.(prog_types); prog_comp_env := ce; prog_comp_env_eq := p.(prog_comp_env_eq); - prog_pol_pub := p.(prog_pol_pub) |}. + prog_pol_pub := p.(prog_pol_pub); + prog_agr_comps := todo_fix tp p tp.(AST.prog_agr_comps) + |}. (** Soundness of the smart constructors. *) diff --git a/cfrontend/SimplExpr.v b/cfrontend/SimplExpr.v index 91e080589f..c3173c9683 100644 --- a/cfrontend/SimplExpr.v +++ b/cfrontend/SimplExpr.v @@ -630,10 +630,19 @@ Definition transl_fundef (fd: Csyntax.fundef) : res fundef := OK (External ef targs tres cc) end. +#[global] Instance comp_transl_fundef: + has_comp_transl_partial (transl_fundef). +Proof. + intros f tf. destruct f; intros H; monadInv H; auto. + unfold transl_function in EQ. destruct transl_stmt; try congruence. + inv EQ; auto. +Qed. + End SIMPL_EXPR. Local Open Scope error_monad_scope. + Definition transl_program (p: Csyntax.program) : res program := do p1 <- AST.transform_partial_program (transl_fundef p.(prog_comp_env)) p; OK {| prog_defs := AST.prog_defs p1; @@ -643,4 +652,6 @@ Definition transl_program (p: Csyntax.program) : res program := prog_types := prog_types p; prog_comp_env := prog_comp_env p; prog_comp_env_eq := prog_comp_env_eq p; - prog_pol_pub := AST.prog_pol_pub p1; |}. + prog_pol_pub := AST.prog_pol_pub p1; + prog_agr_comps := AST.prog_agr_comps p1; + |}. diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index a0e8574229..09b5867802 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -2596,6 +2596,7 @@ Theorem transl_program_correct: Proof. eapply forward_simulation_star_wf with (order := ltof _ measure). eapply senv_preserved. + eapply senv_preserved. eexact transl_initial_states. eexact transl_final_states. apply well_founded_ltof. diff --git a/cfrontend/SimplLocals.v b/cfrontend/SimplLocals.v index 143597d370..ce387478cd 100644 --- a/cfrontend/SimplLocals.v +++ b/cfrontend/SimplLocals.v @@ -291,6 +291,21 @@ Definition transf_fundef (fd: fundef) : res fundef := | External ef targs tres cconv => OK (External ef targs tres cconv) end. +#[global] +Instance comp_transf_function: has_comp_transl_partial transf_function. +Proof. + unfold transf_function. + intros f ? H; monadInv H; trivial. +Qed. + +#[global] +Instance comp_transf_fundef: has_comp_transl_partial transf_fundef. +Proof. + unfold transf_fundef, transf_function. + intros [f|ef] ? H; monadInv H; trivial. + now monadInv EQ. +Qed. + Definition transf_program (p: program) : res program := do p1 <- AST.transform_partial_program transf_fundef p; OK {| prog_defs := AST.prog_defs p1; @@ -300,4 +315,5 @@ Definition transf_program (p: program) : res program := prog_types := prog_types p; prog_comp_env := prog_comp_env p; prog_comp_env_eq := prog_comp_env_eq p; - prog_pol_pub := AST.prog_pol_pub p1; |}. + prog_pol_pub := AST.prog_pol_pub p1; + prog_agr_comps := AST.prog_agr_comps p1; |}. diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index 344f94a338..01e14a6ee0 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -25,26 +25,11 @@ Definition match_prog (p tp: program) : Prop := match_program (fun ctx f tf => transf_fundef f = OK tf) eq p tp /\ prog_types tp = prog_types p. -#[global] -Instance comp_transf_function: has_comp_transl_partial transf_function. -Proof. - unfold transf_function. - intros f ? H; monadInv H; trivial. -Qed. - -#[global] -Instance comp_transf_fundef: has_comp_transl_partial transf_fundef. -Proof. - unfold transf_fundef, transf_function. - intros [f|ef] ? H; monadInv H; trivial. - now monadInv EQ. -Qed. - Lemma match_transf_program: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. - unfold transf_program; intros. monadInv H. - split; auto. apply match_transform_partial_program. rewrite EQ. destruct x; auto. + unfold transf_program; intros. monadInv H. + split; auto. eapply match_transform_partial_program. rewrite EQ. destruct x; auto. Qed. Section PRESERVATION. @@ -2268,7 +2253,10 @@ Proof. (* builtin *) exploit eval_simpl_exprlist; eauto with compat. intros [CASTED [tvargs [C D]]]. - exploit external_call_mem_inject; eauto. apply match_globalenvs_preserves_globals; eauto with compat. + exploit external_call_mem_inject; eauto. + (* TODO: why can't Coq find the instance automatically? *) + eapply has_comp_fundef. eapply has_comp_function. + apply match_globalenvs_preserves_globals; eauto with compat. intros [j' [tvres [tm' [P [Q [R [S [T [U V]]]]]]]]]. econstructor; split. apply plus_one. econstructor; eauto. @@ -2457,7 +2445,9 @@ Proof. (* external function *) monadInv TRFD. inv FUNTY. - exploit external_call_mem_inject; eauto. apply match_globalenvs_preserves_globals. + exploit external_call_mem_inject; eauto. + eapply has_comp_fundef. eapply has_comp_function. + apply match_globalenvs_preserves_globals. eapply match_cont_globalenv. eexact (MCONT VSet.empty top). intros [j' [tvres [tm' [P [Q [R [S [T [U V]]]]]]]]]. econstructor; split. @@ -2528,6 +2518,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_plus. apply senv_preserved. + apply senv_preserved. eexact initial_states_simulation. eexact final_states_simulation. eexact step_simulation. diff --git a/common/AST.v b/common/AST.v index c657e2ed8a..82b9d4b94b 100644 --- a/common/AST.v +++ b/common/AST.v @@ -492,6 +492,7 @@ Instance has_comp_globvar V : has_comp (globvar V) := @gvar_comp _. Module Policy. Record t: Type := mkpolicy { + policy_comps: PTree.t compartment; policy_export: CompTree.t (list ident); policy_import: CompTree.t (list (compartment * ident)) }. @@ -511,7 +512,8 @@ Module Policy. policy is well-formed, we might be running spurious filters, which could have performance impacts in compilation. *) Definition enforce_in_pub (pol: t) (pubs: list ident) := - {| policy_export := + {| policy_comps := pol.(policy_comps); + policy_export := CompTree.map1 (filter (fun id : ident => in_dec ident_eq id pubs)) pol.(policy_export); @@ -538,7 +540,8 @@ Module Policy. Qed. (* The empty policy is the policy where there is no imported procedure and no exported procedure for all compartments *) - Definition empty_pol: t := mkpolicy (CompTree.empty (list ident)) (CompTree.empty (list (compartment * ident))). + Definition empty_pol: t := mkpolicy (PTree.empty compartment) + (CompTree.empty (list ident)) (CompTree.empty (list (compartment * ident))). (* Decidable equality for the elements contained in the policies *) Definition list_id_eq: forall (x y: list ident), @@ -562,6 +565,7 @@ Module Policy. (* Defines an equivalence between two policies: two policies are equivalent iff for each compartment, they define the same exported and imported procedures *) Definition eqb (t1 t2: t): bool := + PTree.beq cp_eq_dec t1.(policy_comps) t2.(policy_comps) && CompTree.beq list_id_eq t1.(policy_export) t2.(policy_export) && CompTree.beq list_cpt_id_eq t1.(policy_import) t2.(policy_import). @@ -570,12 +574,15 @@ Module Policy. Proof. intros pol. unfold eqb. + assert (PTree.beq cp_eq_dec (policy_comps pol) (policy_comps pol) = true). + rewrite PTree.beq_correct. + intros x. destruct ((policy_comps pol) ! x); auto. destruct cp_eq_dec; auto. assert (PTree.beq (fun x y : list ident => list_id_eq x y) (policy_export pol) (policy_export pol) = true). rewrite PTree.beq_correct. intros x. destruct ((policy_export pol) ! x); auto. destruct (list_id_eq l l); auto. unfold CompTree.beq. - rewrite H. simpl. + rewrite H, H0. simpl. rewrite PTree.beq_correct. intros x. destruct ((policy_import pol) ! x); auto. destruct (list_cpt_id_eq l l); auto. @@ -585,36 +592,59 @@ Module Policy. Proof. intros pol pol' H. unfold eqb in *. - apply andb_prop in H as [H1 H2]. - assert (H1': PTree.beq (fun x y : list ident => list_id_eq x y) (policy_export pol') (policy_export pol) = true). + apply andb_prop in H as [H2 H3]. + apply andb_prop in H2 as [H1 H2]. + assert (H1': PTree.beq cp_eq_dec (policy_comps pol') (policy_comps pol) = true). rewrite PTree.beq_correct. rewrite PTree.beq_correct in H1. - intros x. specialize (H1 x). destruct ((policy_export pol') ! x); auto. + intros x. specialize (H1 x). destruct ((policy_comps pol') ! x); auto. + destruct ((policy_comps pol) ! x); auto. + destruct (cp_eq_dec c0 c); subst. + destruct (cp_eq_dec c c); auto. + destruct (cp_eq_dec c c0); auto. + assert (H2': PTree.beq (fun x y : list ident => list_id_eq x y) (policy_export pol') (policy_export pol) = true). + rewrite PTree.beq_correct. rewrite PTree.beq_correct in H2. + intros x. specialize (H2 x). destruct ((policy_export pol') ! x); auto. destruct ((policy_export pol) ! x); auto. destruct (list_id_eq l0 l); subst. destruct (list_id_eq l l); auto. destruct (list_id_eq l l0); auto. - assert (H2': PTree.beq (fun x y => list_cpt_id_eq x y) (policy_import pol') (policy_import pol) = true). - rewrite PTree.beq_correct. rewrite PTree.beq_correct in H2. - intros x. specialize (H2 x). destruct ((policy_import pol') ! x); auto. + assert (H3': PTree.beq (fun x y => list_cpt_id_eq x y) (policy_import pol') (policy_import pol) = true). + rewrite PTree.beq_correct. rewrite PTree.beq_correct in H3. + intros x. specialize (H3 x). destruct ((policy_import pol') ! x); auto. destruct ((policy_import pol) ! x); auto. destruct (list_cpt_id_eq l0 l); subst. destruct (list_cpt_id_eq l l); auto. destruct (list_cpt_id_eq l l0); auto. unfold CompTree.beq. - rewrite H1', H2'. auto. + rewrite H1', H2', H3'. auto. Qed. - Lemma eqb_trans: forall pol pol' pol'', eqb pol pol' = true -> eqb pol' pol'' = true -> eqb pol pol'' = true. + Lemma eqb_trans: forall pol pol' pol'', eqb pol pol' = true -> + eqb pol' pol'' = true -> eqb pol pol'' = true. Proof. intros pol pol' pol'' H1 H2. unfold eqb in *. + apply andb_prop in H1 as [H1 H1'']. apply andb_prop in H1 as [H1 H1']. + apply andb_prop in H2 as [H2 H2'']. apply andb_prop in H2 as [H2 H2']. - assert (H3: PTree.beq (fun x y : list ident => list_id_eq x y) (policy_export pol) (policy_export pol'') = true). + assert (H3: PTree.beq cp_eq_dec (policy_comps pol) (policy_comps pol'') = true). { clear -H1 H2. rewrite PTree.beq_correct in H1, H2. rewrite PTree.beq_correct. intros x. specialize (H1 x); specialize (H2 x). + destruct ((policy_comps pol) ! x); + destruct ((policy_comps pol') ! x); + destruct ((policy_comps pol'') ! x); auto. + destruct (cp_eq_dec c c0); + destruct (cp_eq_dec c0 c1); + destruct (cp_eq_dec c c1); auto. + now subst. } + assert (H3': PTree.beq (fun x y : list ident => list_id_eq x y) (policy_export pol) (policy_export pol'') = true). + { clear -H1' H2'. + rewrite PTree.beq_correct in H1', H2'. + rewrite PTree.beq_correct. + intros x. specialize (H1' x); specialize (H2' x). destruct ((policy_export pol) ! x); destruct ((policy_export pol') ! x); destruct ((policy_export pol'') ! x); auto. @@ -623,11 +653,11 @@ Module Policy. destruct (list_id_eq l l1); auto. now subst. } - assert (H3': PTree.beq (fun x y => list_cpt_id_eq x y) (policy_import pol) (policy_import pol'') = true). - { clear -H1' H2'. - rewrite PTree.beq_correct in H1', H2'. + assert (H3'': PTree.beq (fun x y => list_cpt_id_eq x y) (policy_import pol) (policy_import pol'') = true). + { clear -H1'' H2''. + rewrite PTree.beq_correct in H1'', H2''. rewrite PTree.beq_correct. - intros x. specialize (H1' x); specialize (H2' x). + intros x. specialize (H1'' x); specialize (H2'' x). destruct ((policy_import pol) ! x); destruct ((policy_import pol') ! x); destruct ((policy_import pol'') ! x); auto. @@ -670,23 +700,33 @@ Instance has_comp_globdef F V {CF: has_comp F} : has_comp (globdef F V) := | Gvar v => comp_of v end. -Record program (F V: Type) : Type := mkprogram { +Definition agr_comps {F V: Type} {CF: has_comp F} (pol: Policy.t) (defs: list (ident * globdef F V)): Prop := + Forall + (fun idg => pol.(Policy.policy_comps) ! (fst idg) = Some (comp_of (snd idg))) + defs /\ + forall (id: ident) (cp: compartment), + pol.(Policy.policy_comps) ! id = Some cp -> + exists gd, In (id, gd) defs /\ cp = comp_of gd. + +Record program (F V: Type) {CF: has_comp F} : Type := mkprogram { prog_defs: list (ident * globdef F V); prog_public: list ident; prog_main: ident; prog_pol: Policy.t; prog_pol_pub: Policy.in_pub prog_pol prog_public; + prog_agr_comps: agr_comps prog_pol prog_defs; }. -Arguments mkprogram {F V} _ _ _ _ _. +Arguments program F V {CF}. +Arguments mkprogram {F V CF} _ _ _ _ _ _. -Definition prog_defs_names (F V: Type) (p: program F V) : list ident := +Definition prog_defs_names (F V: Type) {CF: has_comp F} (p: program F V) : list ident := List.map fst p.(prog_defs). (** The "definition map" of a program maps names of globals to their definitions. If several definitions have the same name, the one appearing last in [p.(prog_defs)] wins. *) -Definition prog_defmap (F V: Type) (p: program F V) : PTree.t (globdef F V) := +Definition prog_defmap (F V: Type) {CF: has_comp F} (p: program F V) : PTree.t (globdef F V) := PTree_Properties.of_list p.(prog_defs). (* FIXME: I don't think this is needed anymore *) @@ -696,6 +736,7 @@ Definition prog_defmap (F V: Type) (p: program F V) : PTree.t (globdef F V) := Section DEFMAP. Variables F V: Type. +Context {CF: has_comp F}. Variable p: program F V. Lemma in_prog_defmap: @@ -735,11 +776,32 @@ End DEFMAP. (** We now define a general iterator over programs that applies a given code transformation function to all function descriptions and leaves the other parts of the program unchanged. *) +Section TRANSF_POL. + +Variable B W: Type. +Context {CB: has_comp B}. +Definition update_list_comps (defs: list (ident * globdef B W)): PTree.t compartment := + PTree_Properties.of_list (List.map (fun '(id, a) => (id, comp_of a)) defs). + +Definition update_policy (pol: Policy.t) (defs: list (ident * globdef B W)): Policy.t := + {| Policy.policy_comps := update_list_comps defs; + Policy.policy_import := pol.(Policy.policy_import); + Policy.policy_export := pol.(Policy.policy_export); + |}. + +Lemma agr_update_policy (pol: Policy.t) (defs: list (ident * globdef B W)): + agr_comps (update_policy pol defs) defs. +Proof. + unfold agr_comps; simpl; split. +Admitted. +End TRANSF_POL. Section TRANSF_PROGRAM. Variable A B V: Type. +Context {CA: has_comp A} {CB: has_comp B}. Variable transf: A -> B. +Context {comp_transf: has_comp_transl transf}. Definition transform_program_globdef (idg: ident * globdef A V) : ident * globdef B V := match idg with @@ -747,16 +809,41 @@ Definition transform_program_globdef (idg: ident * globdef A V) : ident * globde | (id, Gvar v) => (id, Gvar v) end. + +Lemma agr_comps_transf: forall {pol defs}, + agr_comps pol defs -> + agr_comps pol (List.map transform_program_globdef defs). +Proof. + unfold agr_comps; intros pol defs [H G]. + split. + - clear G. induction H. + + now simpl. + + simpl; constructor. + * destruct x as [id [fd | vd]]; simpl in *. + -- now rewrite comp_transf. + -- assumption. + * assumption. + - clear H. + intros id cp H. + specialize (G id cp H) as [gd [R S]]; subst cp. + eapply in_map with (f := transform_program_globdef) in R. + destruct gd; simpl; eauto. +Qed. + Definition transform_program (p: program A V) : program B V := mkprogram (List.map transform_program_globdef p.(prog_defs)) p.(prog_public) p.(prog_main) + (* (update_policy p.(prog_pol) (List.map transform_program_globdef p.(prog_defs))) *) p.(prog_pol) - p.(prog_pol_pub). + p.(prog_pol_pub) + (agr_comps_transf p.(prog_agr_comps)). End TRANSF_PROGRAM. +Arguments transform_program [A B V] {CA CB} transf {comp_transf} p. + (** The following is a more general presentation of [transform_program]: - Global variable information can be transformed, in addition to function definitions. @@ -772,7 +859,10 @@ Local Open Scope error_monad_scope. Section TRANSF_PROGRAM_GEN. Variables A B V W: Type. +Context {CA: has_comp A} {CB: has_comp B}. Variable transf_fun: ident -> A -> res B. +Context {Cf: forall id, has_comp_transl_partial (transf_fun id)}. +(* Context {comp_transf: has_comp_match transf}. *) Variable transf_var: ident -> V -> res W. Definition transf_globvar (i: ident) (g: globvar V) : res (globvar W) := @@ -796,9 +886,79 @@ Fixpoint transf_globdefs (l: list (ident * globdef A V)) : res (list (ident * gl end end. -Definition transform_partial_program2 (p: program A V) : res (program B W) := - do gl' <- transf_globdefs p.(prog_defs); - OK (mkprogram gl' p.(prog_public) p.(prog_main) p.(prog_pol) p.(prog_pol_pub)). +Lemma agr_comps_transf_partial: forall {pol defs defs'}, + agr_comps pol defs -> + transf_globdefs defs = OK defs' -> + agr_comps pol defs'. +Proof. + unfold agr_comps; intros pol defs defs' [H G] def_trans. + split. + { clear G. revert defs' def_trans. + induction H. + - now intros defs' H; simpl in H; inv H. + - intros defs' defs'_OK. + destruct x as [id [fd | vd]] eqn:?; simpl in *. + + destruct transf_fun eqn:?; try congruence; simpl in *. + monadInv defs'_OK. + simpl; constructor. + * simpl. + apply has_comp_transl_partial_match_contextual with (g := fun id => id) in Cf. + now rewrite Cf in H; eauto. + * now eauto. + + destruct transf_globvar eqn:?; try congruence; simpl in *. + monadInv defs'_OK. + simpl; constructor. + * now monadInv Heqr; eauto. + * now eauto. } + { clear H. + intros id cp H. + specialize (G id cp H) as [gd [R S]]; subst cp. + clear -R def_trans Cf. + revert defs' def_trans. + induction defs. + - inv R. + - intros defs' def_trans. inv R. + + destruct gd; simpl in *; eauto. + * destruct transf_fun eqn:transf_id_f; try congruence. + monadInv def_trans. + exists (Gfun b); split; [left |]; eauto. + now rewrite Cf; eauto. + * destruct transf_globvar eqn:transf_id_v; try congruence. + monadInv def_trans. + exists (Gvar g); split; [left |]; eauto. + monadInv transf_id_v; auto. + + destruct a as [? []]; simpl in def_trans. + * destruct transf_fun eqn:transf_id_f; try congruence. + monadInv def_trans. + exploit IHdefs; eauto. intros [gd0 [? ?]]. + exists gd0; split; [right |]; eauto. + * destruct transf_globvar eqn:transf_id_v; try congruence. + monadInv def_trans. + exploit IHdefs; eauto. intros [gd0 [? ?]]. + exists gd0; split; [right |]; eauto. } +Qed. + +Record defs_with_proof (p: program A V) := + { gl: res (list (ident * globdef B W)); + proof: forall l, gl = OK l -> agr_comps (prog_pol p) l }. + +Program Definition truc (p: program A V): (defs_with_proof p) := + {| gl := transf_globdefs p.(prog_defs); |}. +Next Obligation. + eapply agr_comps_transf_partial; eauto using prog_agr_comps. +Qed. + +Program Definition transform_partial_program2 (p: program A V) : res (program B W) := + match transf_globdefs p.(prog_defs) with + | OK gl' => + OK (mkprogram gl' + p.(prog_public) + p.(prog_main) + p.(prog_pol) + p.(prog_pol_pub) + (agr_comps_transf_partial p.(prog_agr_comps) _)) + | Error err => Error err + end. End TRANSF_PROGRAM_GEN. @@ -809,27 +969,41 @@ End TRANSF_PROGRAM_GEN. Section TRANSF_PARTIAL_PROGRAM. Variable A B V: Type. +Context {CA: has_comp A} {CB: has_comp B}. Variable transf_fun: A -> res B. +Context {comp_transf_fun: has_comp_transl_partial transf_fun}. Definition transform_partial_program (p: program A V) : res (program B V) := transform_partial_program2 (fun i f => transf_fun f) (fun i v => OK v) p. End TRANSF_PARTIAL_PROGRAM. +Arguments transform_partial_program [A B V] {CA CB} transf_fun {comp_transf_fun} p. + +Instance comp_transf_total_to_partial {A B: Type} {CA: has_comp A} {CB: has_comp B} (transf_fun: A -> B) + {comp_transf_fun: has_comp_transl transf_fun}: + has_comp_transl_partial (fun f => OK (transf_fun f)). +Proof. + intros x y H. inv H. rewrite comp_transf_fun. reflexivity. +Defined. Lemma transform_program_partial_program: - forall (A B V: Type) (transf_fun: A -> B) (p: program A V), + forall (A B V: Type) {CA: has_comp A} {CB: has_comp B} (transf_fun: A -> B) + {comp_transf_fun: has_comp_transl transf_fun} (p: program A V), transform_partial_program (fun f => OK (transf_fun f)) p = OK (transform_program transf_fun p). Proof. intros. unfold transform_partial_program, transform_partial_program2. assert (EQ: forall l, - transf_globdefs (fun i f => OK (transf_fun f)) (fun i (v: V) => OK v) l = - OK (List.map (transform_program_globdef transf_fun) l)). + transf_globdefs (fun i f => OK (transf_fun f)) (fun i (v: V) => OK v) l = + OK (List.map (transform_program_globdef transf_fun) l)). { induction l as [ | [id g] l]; simpl. - - auto. - - destruct g; simpl; rewrite IHl; simpl. auto. destruct v; auto. + - auto. + - destruct g; simpl; rewrite IHl; simpl. auto. destruct v; auto. } - rewrite EQ; simpl. auto. -Qed. + specialize (EQ (prog_defs p)). + clear -EQ. + Require Import ssreflect. + move: eq_refl. intros e. +Admitted. (** * External functions *) diff --git a/common/Behaviors.v b/common/Behaviors.v index 1f7f62263b..fcf5991791 100644 --- a/common/Behaviors.v +++ b/common/Behaviors.v @@ -567,6 +567,7 @@ Proof. set (ms := fun (s: state L) (ts: state (atomic L)) => ts = (E0,s)). apply forward_simulation_plus with ms; intros. auto. + auto. exists (E0,s1); split. simpl; auto. red; auto. red in H. subst s2. simpl; auto. red in H0. subst s2. exists (E0,s1'); split. diff --git a/common/Determinism.v b/common/Determinism.v index 8c6cc690ad..c63748a017 100644 --- a/common/Determinism.v +++ b/common/Determinism.v @@ -116,8 +116,8 @@ Lemma match_possible_traces: Proof. intros. inv H; inv H1; inv H0. auto. - inv H7; inv H6. inv H9; inv H10. split; congruence. - inv H7; inv H6. inv H9; inv H10. split; congruence. + inv H8; inv H7. inv H10; inv H11. split; congruence. + inv H9; inv H8. inv H11; inv H12. split; congruence. inv H4; inv H3. inv H6; inv H7. split; congruence. inv H4; inv H3. inv H7; inv H6. auto. inv H4; inv H3. diff --git a/common/Events.v b/common/Events.v index 487f84c6bd..e74dc56199 100644 --- a/common/Events.v +++ b/common/Events.v @@ -272,6 +272,7 @@ Section EVENTVAL. (** Symbol environment used to translate between global variable names and their block identifiers. *) Variable ge: Senv.t. +Variable cp: compartment. (** Translation between values and event values. *) @@ -287,6 +288,7 @@ Inductive eventval_match: eventval -> typ -> val -> Prop := | ev_match_ptr: forall id b ofs, Senv.public_symbol ge id = true -> Senv.find_symbol ge id = Some b -> + (* Senv.find_comp ge id ⊆ cp -> *) eventval_match (EVptr_global id ofs) Tptr (Vptr b ofs). Inductive eventval_list_match: list eventval -> list typ -> list val -> Prop := @@ -371,10 +373,18 @@ Definition eventval_type (ev: eventval) : typ := | EVptr_global id ofs => Tptr end. +Definition eventval_comp (ev: eventval) : compartment := + match ev with + | EVint _ | EVlong _ | EVfloat _ | EVsingle _ => bottom + | EVptr_global id ofs => Senv.find_comp ge id + end. + Lemma eventval_match_receptive: forall ev1 ty v1 ev2, eventval_match ev1 ty v1 -> - eventval_valid ev1 -> eventval_valid ev2 -> eventval_type ev1 = eventval_type ev2 -> + eventval_valid ev1 -> eventval_valid ev2 -> + eventval_type ev1 = eventval_type ev2 -> + (* eventval_comp ev1 = eventval_comp ev2 -> *) exists v2, eventval_match ev2 ty v2. Proof. intros. unfold eventval_type, Tptr in H2. remember Archi.ptr64 as ptr64. @@ -382,9 +392,11 @@ Proof. - exists (Vint i0); constructor. - simpl in H1; exploit Senv.public_symbol_exists; eauto. intros [b FS]. exists (Vptr b i1); rewrite H3. constructor; auto. + (* simpl in H3. rewrite <- H3. auto with comps. *) - exists (Vlong i0); constructor. - simpl in H1; exploit Senv.public_symbol_exists; eauto. intros [b FS]. exists (Vptr b i1); rewrite H3; constructor; auto. + (* simpl in H3. rewrite <- H3. auto with comps. *) - exists (Vfloat f0); constructor. - destruct Archi.ptr64; discriminate. - exists (Vsingle f0); constructor; auto. @@ -395,6 +407,7 @@ Proof. - destruct Archi.ptr64; discriminate. - exploit Senv.public_symbol_exists. eexact H1. intros [b' FS]. exists (Vptr b' i0); constructor; auto. + (* simpl in H3. rewrite <- H3. assumption. *) Qed. Lemma eventval_match_valid: @@ -417,6 +430,7 @@ End EVENTVAL. Section EVENTVAL_INV. Variables ge1 ge2: Senv.t. +Variable cp: compartment. Hypothesis public_preserved: forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id. @@ -430,6 +444,29 @@ Qed. Hypothesis symbols_preserved: forall id, Senv.find_symbol ge2 id = Senv.find_symbol ge1 id. +Hypothesis comp_preserved: + forall id, Senv.find_comp ge2 id = Senv.find_comp ge1 id. + +Lemma eventval_comp_preserved: + forall ev, eventval_comp ge2 ev = eventval_comp ge1 ev. +Proof. + intros. destruct ev; simpl in *; auto with comps. +Qed. + +Lemma eventval_list_comp_preserved: + forall args, Forall (fun ev => eventval_comp ge1 ev ⊆ cp) args -> + Forall (fun ev => eventval_comp ge2 ev ⊆ cp) args. +Proof. + intros args H. + induction H. + - constructor. + - constructor; eauto. + destruct x; auto. + simpl in *. + (* now eapply flowsto_trans. *) + now rewrite comp_preserved. +Qed. + Lemma eventval_match_preserved: forall ev ty v, eventval_match ge1 ev ty v -> eventval_match ge2 ev ty v. @@ -437,6 +474,7 @@ Proof. induction 1; constructor; auto. rewrite public_preserved; auto. rewrite symbols_preserved; auto. + (* rewrite comp_preserved; auto. *) Qed. Lemma eventval_list_match_preserved: @@ -454,6 +492,7 @@ Section EVENTVAL_INJECT. Variable f: block -> option (block * Z). Variable ge1 ge2: Senv.t. +Variable cp: compartment. Definition symbols_inject : Prop := (forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id) @@ -462,39 +501,48 @@ Definition symbols_inject : Prop := 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 -> + Senv.find_comp ge1 id ⊆ cp -> 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.block_is_volatile ge2 b2 = Senv.block_is_volatile ge1 b1) +/\ (forall id, + (* f b1 = Some(b2, delta) -> Senv.find_symbol ge1 id = Some b1 -> *) + Senv.find_comp ge1 id = Senv.find_comp ge2 id). Hypothesis symb_inj: symbols_inject. Lemma eventval_match_inject: forall ev ty v1 v2, + forall (COMP: eventval_comp ge1 ev ⊆ cp), eventval_match ge1 ev ty v1 -> Val.inject f v1 v2 -> eventval_match ge2 ev ty v2. Proof. intros. inv H; inv H0; try constructor; auto. - destruct symb_inj as (A & B & C & D). exploit C; eauto. intros [b3 [EQ FS]]. rewrite H4 in EQ; inv EQ. + destruct symb_inj as (A & B & C & D & E). exploit C; eauto. intros [b3 [EQ FS]]. + rewrite H4 in EQ; inv EQ. rewrite Ptrofs.add_zero. constructor; auto. rewrite A; auto. Qed. Lemma eventval_match_inject_2: forall ev ty v1, + forall (COMP: eventval_comp ge1 ev ⊆ cp), eventval_match ge1 ev ty v1 -> exists v2, eventval_match ge2 ev ty v2 /\ Val.inject f v1 v2. Proof. intros. inv H; try (econstructor; split; eauto; constructor; fail). - destruct symb_inj as (A & B & C & D). exploit C; eauto. intros [b2 [EQ FS]]. - exists (Vptr b2 ofs); split. econstructor; eauto. - econstructor; eauto. rewrite Ptrofs.add_zero; auto. + destruct symb_inj as (A & B & C & D & E). exploit C; eauto. intros [b2 [EQ FS]]. + exists (Vptr b2 ofs); split. econstructor; eauto. econstructor; eauto. rewrite Ptrofs.add_zero; auto. Qed. Lemma eventval_list_match_inject: forall evl tyl vl1, eventval_list_match ge1 evl tyl vl1 -> + forall (COMP: Forall (fun ev => eventval_comp ge1 ev ⊆ cp) evl), forall vl2, Val.inject_list f vl1 vl2 -> eventval_list_match ge2 evl tyl vl2. Proof. induction 1; intros. inv H; constructor. - inv H1. constructor. eapply eventval_match_inject; eauto. eauto. + inv H1. + inv COMP. + constructor. eapply eventval_match_inject; eauto. + eauto. Qed. End EVENTVAL_INJECT. @@ -515,18 +563,22 @@ Inductive match_traces: trace -> trace -> Prop := match_traces nil nil | match_traces_syscall: forall id args res1 res2, eventval_valid ge res1 -> eventval_valid ge res2 -> eventval_type res1 = eventval_type res2 -> + (* eventval_comp ge res1 = eventval_comp ge res2 -> *) + eventval_comp ge res1 = eventval_comp ge res2 -> match_traces (Event_syscall id args res1 :: nil) (Event_syscall id args res2 :: nil) | match_traces_vload: forall chunk id ofs res1 res2, eventval_valid ge res1 -> eventval_valid ge res2 -> eventval_type res1 = eventval_type res2 -> + eventval_comp ge res1 ⊆ Senv.find_comp ge id -> + eventval_comp ge res2 ⊆ Senv.find_comp ge id -> match_traces (Event_vload chunk id ofs res1 :: nil) (Event_vload chunk id ofs res2 :: nil) | match_traces_vstore: forall chunk id ofs arg, match_traces (Event_vstore chunk id ofs arg :: nil) (Event_vstore chunk id ofs arg :: nil) | match_traces_annot: forall id args, match_traces (Event_annot id args :: nil) (Event_annot id args :: nil) - | match_traces_call: forall cp cp' id args, - match_traces (Event_call cp cp' id args :: nil) (Event_call cp cp' id args :: nil) - | match_traces_return: forall cp cp' res, - match_traces (Event_return cp cp' res :: nil) (Event_return cp cp' res :: nil). + | match_traces_call: forall cp1 cp2 id args, + match_traces (Event_call cp1 cp2 id args :: nil) (Event_call cp1 cp2 id args :: nil) + | match_traces_return: forall cp1 cp2 res, + match_traces (Event_return cp1 cp2 res :: nil) (Event_return cp1 cp2 res :: nil). End MATCH_TRACES. @@ -535,14 +587,24 @@ End MATCH_TRACES. Section MATCH_TRACES_INV. Variables ge1 ge2: Senv.t. +Variable cp: compartment. Hypothesis public_preserved: forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id. +Hypothesis comp_preserved: + forall id, Senv.find_comp ge2 id = Senv.find_comp ge1 id. Lemma match_traces_preserved: forall t1 t2, match_traces ge1 t1 t2 -> match_traces ge2 t1 t2. Proof. - induction 1; constructor; auto; eapply eventval_valid_preserved; eauto. + induction 1; constructor; auto; + try (match goal with + | |- eventval_valid _ _ => eapply eventval_valid_preserved + | |- eventval_comp _ _ ⊆ _ => + destruct res1, res2; simpl in *; auto; rewrite !comp_preserved; auto + | |- eventval_comp _ _ = eventval_comp _ _ => + destruct res1, res2; simpl in *; auto; rewrite !comp_preserved; auto + end; eauto). Qed. End MATCH_TRACES_INV. @@ -585,7 +647,11 @@ Inductive volatile_load (ge: Senv.t) (cp: compartment): | volatile_load_vol: forall chunk m b ofs id ev v, Senv.block_is_volatile ge b = true -> Senv.find_symbol ge id = Some b -> + (* Condition: we're doing a volatile load to a location [cp] is allowed to access *) + Senv.find_comp ge id ⊆ cp -> eventval_match ge ev (type_of_chunk chunk) v -> + (* we load a value (that might be a pointer) that is allowed to be stored inside this location *) + eventval_comp ge ev ⊆ Senv.find_comp ge id -> volatile_load ge cp chunk m b ofs (Event_vload chunk id ofs ev :: nil) (Val.load_result chunk v) @@ -600,7 +666,11 @@ Inductive volatile_store (ge: Senv.t) (cp: compartment): | volatile_store_vol: forall chunk m b ofs id ev v, Senv.block_is_volatile ge b = true -> Senv.find_symbol ge id = Some b -> + (* Condition: we're doing a volatile store to a location [cp] is allowed to access *) + Senv.find_comp ge id ⊆ cp -> eventval_match ge ev (type_of_chunk chunk) (Val.load_result chunk v) -> + (* Condition: what we're storing can be stored in this location *) + eventval_comp ge ev ⊆ Senv.find_comp ge id -> volatile_store ge cp chunk m b ofs v (Event_vstore chunk id ofs ev :: nil) m @@ -628,19 +698,6 @@ in extcall_caller_independent. Definition extcall_sem : Type := Senv.t -> compartment -> list val -> mem -> trace -> val -> mem -> Prop. -(* (** This invariant guarantees that external calls performed to [cp] can *) -(* correctly use either [cp1] or [cp2] to find out who the calling compartment *) -(* is. *) *) -(* Definition uptodate_caller (cp cp1 cp2: compartment) := *) -(* needs_calling_comp cp = true -> *) -(* cp1 = cp2. *) - -(* Definition extcall_caller_independent (cp: compartment) (sem: extcall_sem) := *) -(* forall ge cp1 cp2 args m t v m', *) -(* uptodate_caller cp cp1 cp2 -> *) -(* sem ge cp1 args m t v m' -> *) -(* sem ge cp2 args m t v m'. *) - (** We now specify the expected properties of this predicate. *) Definition loc_out_of_bounds (m: mem) (b: block) (ofs: Z) : Prop := @@ -746,7 +803,7 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : in the following sense. *) ec_mem_inject: forall ge1 ge2 vargs m1 t vres m2 f m1' vargs', - symbols_inject f ge1 ge2 -> + symbols_inject f ge1 ge2 cp -> sem ge1 cp vargs m1 t vres m2 -> Mem.inject f m1 m1' -> Val.inject_list f vargs vargs' -> @@ -808,9 +865,13 @@ Lemma volatile_load_preserved: volatile_load ge1 cp chunk m b ofs t v -> volatile_load ge2 cp chunk m b ofs t v. Proof. - intros. destruct H as (A & B & C). inv H0; econstructor; eauto. - rewrite A; auto. + intros. destruct H as (A & B & C & D). inv H0; econstructor; eauto. + rewrite A; auto. rewrite D; auto. eapply eventval_match_preserved; eauto. + rewrite D; auto with comps. + eapply flowsto_trans; eauto. + erewrite eventval_comp_preserved; eauto with comps. + (* intros; rewrite D; auto with comps. *) Qed. Lemma volatile_load_extends: @@ -830,20 +891,26 @@ Qed. Lemma volatile_load_inject: forall ge1 ge2 cp f chunk m b ofs t v b' ofs' m', - symbols_inject f ge1 ge2 -> + symbols_inject f ge1 ge2 cp -> volatile_load ge1 cp chunk m b ofs t v -> Val.inject f (Vptr b ofs) (Vptr b' ofs') -> Mem.inject f m m' -> exists v', volatile_load ge2 cp chunk m' b' ofs' t v' /\ Val.inject f v v'. Proof. - intros until m'; intros SI VL VI MI. generalize SI; intros (A & B & C & D). + intros until m'; intros SI VL VI MI. generalize SI; intros (A & B & C & D & E). inv VL. - (* volatile load *) inv VI. exploit B; eauto. intros [U V]. subst delta. - exploit eventval_match_inject_2; eauto. intros (v2 & X & Y). + exploit eventval_match_inject_2; eauto. + eapply flowsto_trans; eauto. + intros (v2 & X & Y). rewrite Ptrofs.add_zero. exists (Val.load_result chunk v2); split. constructor; auto. erewrite D; eauto. + + erewrite <- E; eauto. + { erewrite <- E; eauto. + erewrite <- eventval_comp_preserved; eauto. } apply Val.load_result_inject. auto. - (* normal load *) exploit Mem.loadv_inject; eauto. simpl; eauto. simpl; intros (v2 & X & Y). @@ -886,10 +953,6 @@ Proof. - inv H; auto. (* readonly *) - inv H; auto. -(* (* mem alloc *) *) -(* - inv H; congruence. *) -(* (* outside cp *) *) -(* - inv H; apply Mem.unchanged_on_refl. *) (* mem extends *) - inv H. inv H1. inv H6. inv H4. exploit volatile_load_extends; eauto. intros [v' [A B]]. @@ -911,6 +974,7 @@ Proof. eapply eventval_match_valid; eauto. eapply eventval_match_valid; eauto. eapply eventval_match_same_type; eauto. + auto. auto. intros EQ; inv EQ. assert (v = v0) by (eapply eventval_match_determ_1; eauto). subst v0. auto. @@ -935,9 +999,11 @@ Lemma volatile_store_preserved: volatile_store ge1 cp chunk m1 b ofs v t m2 -> volatile_store ge2 cp chunk m1 b ofs v t m2. Proof. - intros. destruct H as (A & B & C). inv H0; econstructor; eauto. + intros. destruct H as (A & B & C & D). inv H0; econstructor; eauto. rewrite A; auto. + rewrite D; auto. eapply eventval_match_preserved; eauto. + erewrite <- eventval_comp_preserved, D; eauto. Qed. Lemma unchanged_on_readonly: @@ -996,7 +1062,7 @@ Qed. Lemma volatile_store_inject: forall ge1 ge2 cp f chunk m1 b ofs v t m2 m1' b' ofs' v', - symbols_inject f ge1 ge2 -> + symbols_inject f ge1 ge2 cp -> volatile_store ge1 cp chunk m1 b ofs v t m2 -> Val.inject f (Vptr b ofs) (Vptr b' ofs') -> Val.inject f v v' -> @@ -1008,13 +1074,17 @@ Lemma volatile_store_inject: /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2'. Proof. intros until v'; intros SI VS AI VI MI. - generalize SI; intros (P & Q & R & S). + generalize SI; intros (P & Q & R & S & T). inv VS. - (* volatile store *) inv AI. exploit Q; eauto. intros [A B]. subst delta. rewrite Ptrofs.add_zero. exists m1'; split. constructor; auto. erewrite S; eauto. - eapply eventval_match_inject; eauto. apply Val.load_result_inject. auto. + rewrite <- T; auto. + eapply eventval_match_inject; eauto. + eapply flowsto_trans; eauto. + apply Val.load_result_inject. auto. + erewrite <- eventval_comp_preserved, <- T; eauto. intuition auto with mem. - (* normal store *) inversion AI; subst. @@ -1066,14 +1136,6 @@ Proof. + eapply Mem.loadbytes_can_access_block_inj; eauto. + simpl. erewrite <- Mem.store_block_compartment; eauto. eapply Mem.loadbytes_can_access_block_inj; eauto. - -(* (* mem alloc *) *) -(* - inv H. inv H2. congruence. *) -(* exploit Mem.store_valid_block_2; eauto. congruence. *) -(* (* outside cp *) *) -(* - inv H. inv H0. apply Mem.unchanged_on_refl. *) -(* eapply Mem.store_unchanged_on; eauto. *) - (* mem extends*) - inv H. inv H1. inv H6. inv H7. inv H4. exploit volatile_store_extends; eauto. intros [m2' [A [B C]]]. @@ -1082,7 +1144,6 @@ Proof. - inv H0. inv H2. inv H7. inv H8. inversion H5; subst. exploit volatile_store_inject; eauto. intros [m2' [A [B [C D]]]]. exists f; exists Vundef; exists m2'; intuition. constructor; auto. red; intros; congruence. - (* inv H3. congruence. eapply Mem.store_valid_block_2 in H2; eauto. congruence. *) (* trace length *) - inv H; inv H0; simpl; lia. (* receptive *) @@ -1150,17 +1211,6 @@ Proof. eapply Mem.alloc_can_access_block_other_inj_2; eauto. simpl. erewrite <- Mem.store_block_compartment; eauto. eapply Mem.loadbytes_can_access_block_inj; eauto. - -(* (* mem alloc *) *) -(* - inv H. *) -(* destruct (eq_block b0 b). *) -(* subst b0. *) -(* { erewrite Mem.store_block_compartment; eauto. *) -(* erewrite Mem.alloc_block_compartment; eauto. rewrite peq_true. eauto. } *) -(* exploit Mem.store_valid_block_2; eauto. intros ?. *) -(* exploit Mem.valid_block_alloc_inv; eauto. intros [|]; congruence. *) -(* (* outside cp *) *) -(* - inv H. eapply UNCHANGED; eauto. *) (* mem extends *) - inv H. inv H1. inv H7. assert (SZ: v2 = Vptrofs sz). @@ -1191,12 +1241,6 @@ Proof. red; intros. destruct (eq_block b1 b). subst b1. rewrite C in H2. inv H2. eauto with mem. rewrite D in H2 by auto. congruence. - (* destruct (eq_block b0 b); subst. *) - (* { erewrite Mem.store_block_compartment; eauto. *) - (* erewrite Mem.alloc_block_compartment; eauto. rewrite peq_true. eauto. } *) - (* eapply Mem.store_valid_block_2 in H2; eauto. *) - (* clear ALLOC. *) - (* exploit Mem.valid_block_alloc_inv; eauto. intros [ | ]; congruence. *) (* trace length *) - inv H; simpl; lia. (* receptive *) @@ -1257,14 +1301,6 @@ Proof. * eapply Mem.free_can_access_block_inj_2; eauto. eapply Mem.loadbytes_can_access_block_inj; eauto. * eapply Mem.loadbytes_can_access_block_inj; eauto. -(* (* mem alloc *) *) -(* - inv H; try congruence. *) -(* exploit Mem.valid_block_free_2; eauto. congruence. *) -(* (* outside cp *) *) -(* - inv H. *) -(* eapply Mem.free_unchanged_on; eauto. intros. unfold loc_not_in_compartment. *) -(* exploit Mem.free_can_access_block_1; eauto. *) -(* eapply Mem.unchanged_on_refl. *) (* mem extends *) - inv H. + inv H1. inv H8. inv H6. @@ -1384,14 +1420,6 @@ Proof. apply Mem.perm_cur_max. eapply Mem.storebytes_range_perm; eauto. eapply Mem.storebytes_can_access_block_inj_2; eauto. eapply Mem.loadbytes_can_access_block_inj; eauto. -(* - (* new blocks *) *) -(* intros. *) -(* inv H. *) -(* exploit Mem.storebytes_valid_block_2; eauto. congruence. *) -(* (* outside cp *) *) -(* - intros. inv H. *) -(* eapply Mem.storebytes_unchanged_on; eauto. intros. unfold loc_not_in_compartment. *) -(* exploit Mem.storebytes_can_access_block_1; eauto. *) - (* extensions *) intros. inv H. inv H1. inv H13. inv H14. inv H10. inv H11. @@ -1499,6 +1527,8 @@ Inductive extcall_annot_sem (text: string) (targs: list typ) (ge: Senv.t) (cp: c list val -> mem -> trace -> val -> mem -> Prop := | extcall_annot_sem_intro: forall vargs m args, eventval_list_match ge args targs vargs -> + (* Condition: only output from the current compartment *) + Forall (fun ev : eventval => eventval_comp ge ev ⊆ cp) args -> extcall_annot_sem text targs ge cp vargs m (Event_annot text args :: E0) Vundef m. Lemma extcall_annot_ok: @@ -1510,8 +1540,9 @@ Proof. (* well typed *) - inv H. simpl. auto. (* symbols *) -- destruct H as (A & B & C). inv H0. econstructor; eauto. +- destruct H as (A & B & C & D). inv H0. econstructor; eauto. eapply eventval_list_match_preserved; eauto. + eapply eventval_list_comp_preserved; eauto. (* valid blocks *) - inv H; auto. (* accessibility *) @@ -1520,11 +1551,6 @@ Proof. - inv H; auto. (* readonly *) - inv H; auto. -(* (* mem alloc *) *) -(* - inv H. congruence. *) -(* (* outside cp *) *) -(* - intros. inv H. *) -(* eapply Mem.unchanged_on_refl. *) (* mem extends *) - inv H. exists Vundef; exists m1'; intuition. @@ -1535,6 +1561,8 @@ Proof. exists f; exists Vundef; exists m1'; intuition. econstructor; eauto. eapply eventval_list_match_inject; eauto. + destruct H as (A & B & C & D & E). + eapply eventval_list_comp_preserved with (ge1 := ge1); eauto. red; intros; congruence. (* trace length *) - inv H; simpl; lia. @@ -1553,6 +1581,8 @@ Inductive extcall_annot_val_sem (text: string) (targ: typ) (ge: Senv.t) (cp: com list val -> mem -> trace -> val -> mem -> Prop := | extcall_annot_val_sem_intro: forall varg m arg, eventval_match ge arg targ varg -> + (* Condition: only output from the current compartment *) + eventval_comp ge arg ⊆ cp -> extcall_annot_val_sem text targ ge cp (varg :: nil) m (Event_annot text (arg :: nil) :: E0) varg m. Lemma extcall_annot_val_ok: @@ -1564,8 +1594,9 @@ Proof. (* well typed *) - inv H. eapply eventval_match_type; eauto. (* symbols *) -- destruct H as (A & B & C). inv H0. econstructor; eauto. +- destruct H as (A & B & C & D). inv H0. econstructor; eauto. eapply eventval_match_preserved; eauto. + erewrite eventval_comp_preserved; eauto. (* valid blocks *) - inv H; auto. (* accessibility *) @@ -1574,21 +1605,18 @@ Proof. - inv H; auto. (* readonly *) - inv H; auto. -(* (* mem alloc *) *) -(* - inv H; congruence. *) -(* (* outside cp *) *) -(* - intros. inv H. *) -(* eapply Mem.unchanged_on_refl. *) (* mem extends *) -- inv H. inv H1. inv H6. +- inv H. inv H1. inv H7. exists v2; exists m1'; intuition. econstructor; eauto. eapply eventval_match_lessdef; eauto. (* mem inject *) -- inv H0. inv H2. inv H7. +- inv H0. inv H2. inv H8. exists f; exists v'; exists m1'; intuition. econstructor; eauto. eapply eventval_match_inject; eauto. + destruct H as (A & B & C & D & E). + erewrite eventval_comp_preserved; eauto. red; intros; congruence. (* trace length *) - inv H; simpl; lia. @@ -1790,48 +1818,6 @@ Ltac external_call_caller_independent := econstructor; eauto. -(* Lemma external_call_caller_independent: *) -(* forall ef: external_function, *) -(* extcall_caller_independent (comp_of ef) (external_call ef). *) -(* Proof. *) -(* destruct ef; simpl; try easy; *) -(* eauto with caller_independent; *) -(* try solve [external_call_caller_independent]. *) -(* { *) -(* intros ge cp1 cp2 args m t v m'. *) -(* unfold uptodate_caller, needs_calling_comp, needs_calling_comp_map. simpl. *) -(* rewrite PMap.gsspec, PMap.gi. *) -(* destruct (peq cp default_compartment) as [|neq]; try easy. *) -(* intros E. rewrite E; trivial. *) -(* } *) -(* { *) -(* intros ge cp1 cp2 args m t v m'. *) -(* unfold uptodate_caller, needs_calling_comp, needs_calling_comp_map. simpl. *) -(* rewrite PMap.gsspec, PMap.gi. *) -(* destruct (peq (comp_of (EF_vstore chunk)) privileged_compartment) as [|neq]; try easy. *) -(* intros E. rewrite E; trivial. *) -(* } *) -(* intros ge cp1 cp2 args m t v m'. *) -(* unfold uptodate_caller, needs_calling_comp, needs_calling_comp_map. simpl. *) -(* rewrite PMap.gsspec, PMap.gi. *) -(* destruct (peq (comp_of EF_malloc) privileged_compartment) as [|neq]; try easy. *) -(* intros E. rewrite E; trivial. *) -(* (* RB: NOTE: Two new goals left to solve. One of them can be solved by an *) -(* identical procedure. *) *) -(* intros ge cp1 cp2 args m t v m'. *) -(* unfold uptodate_caller, needs_calling_comp, needs_calling_comp_map. simpl. *) -(* rewrite PMap.gsspec, PMap.gi. *) -(* destruct (peq (comp_of EF_free) privileged_compartment) as [|neq]; try easy. *) -(* intros E. rewrite E; trivial. *) -(* (* RB: NOTE: The last goal, on EF_memcpy, cannot be solved by means of this *) -(* strategy, and needs a closer look. *) *) -(* intros ge cp1 cp2 args m t v m'. *) -(* unfold uptodate_caller, needs_calling_comp, needs_calling_comp_map. simpl. *) -(* rewrite PMap.gsspec, PMap.gi. *) -(* destruct (peq (comp_of (EF_memcpy sz al)) privileged_compartment) as [|neq]; try easy. *) -(* intros E. rewrite E; trivial. *) -(* Qed. *) - Theorem external_call_spec: forall ef cp, extcall_properties (external_call ef) cp (ef_sig ef). @@ -1892,27 +1878,24 @@ Definition meminj_preserves_globals (F V: Type) (ge: Genv.t F V) (f: block -> op (forall id b, Genv.find_symbol ge id = Some b -> f b = Some(b, 0)) /\ (forall b gv, Genv.find_var_info ge b = Some gv -> f b = Some(b, 0)) /\ (forall b1 b2 delta gv, Genv.find_var_info ge b2 = Some gv -> f b1 = Some(b2, delta) -> b2 = b1). + (* /\ (forall id, Genv.find_comp_of_ident ge id = Genv.find_comp_) *) Lemma external_call_mem_inject: - forall ef F V (ge: Genv.t F V) cp vargs m1 t vres m2 f m1' vargs', + forall ef F V (ge: Genv.t F V) {CF: has_comp F} cp vargs m1 t vres m2 f m1' vargs', meminj_preserves_globals ge f -> - external_call ef ge cp vargs m1 t vres m2 -> + external_call ef (Genv.to_senv ge) cp vargs m1 t vres m2 -> Mem.inject f m1 m1' -> Val.inject_list f vargs vargs' -> exists f', exists vres', exists m2', - external_call ef ge cp vargs' m1' t vres' m2' + external_call ef (Genv.to_senv ge) cp 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'. - (* /\ (forall b : block, *) - (* ~ Mem.valid_block m1 b -> *) - (* Mem.valid_block m2 b -> *) - (* exists b' : block, f' b = Some (b', 0) /\ Mem.block_compartment m2 b = cp). *) Proof. - intros. destruct H as (A & B & C). eapply external_call_mem_inject_gen with (ge1 := ge); eauto. + intros. destruct H as (A & B & C). eapply external_call_mem_inject_gen with (ge1 := (Genv.to_senv ge)); eauto. repeat split; intros. + simpl in H3. exploit A; eauto. intros EQ; rewrite EQ in H; inv H. auto. + simpl in H3. exploit A; eauto. intros EQ; rewrite EQ in H; inv H. auto. @@ -2020,23 +2003,29 @@ Section EVAL_BUILTIN_ARG_PRESERVED. Variables A F1 V1 F2 V2: Type. Variable ge1: Genv.t F1 V1. Variable ge2: Genv.t F2 V2. +Context {CF1: has_comp F1} {CF2: has_comp F2}. Variable e: A -> val. Variable sp: val. Variable m: mem. +Let se1 := Genv.to_senv ge1. +Let se2 := Genv.to_senv ge2. + Hypothesis symbols_preserved: forall id, Genv.find_symbol ge2 id = Genv.find_symbol ge1 id. +Hypothesis comp_preserved: + forall id, Genv.find_comp_of_ident ge2 id = Genv.find_comp_of_ident ge1 id. Lemma eval_builtin_arg_preserved: - forall a v, eval_builtin_arg ge1 e sp m a v -> eval_builtin_arg ge2 e sp m a v. + forall a v, eval_builtin_arg se1 e sp m a v -> eval_builtin_arg se2 e sp m a v. Proof. - assert (EQ: forall id ofs, Senv.symbol_address ge2 id ofs = Senv.symbol_address ge1 id ofs). + assert (EQ: forall id ofs, Senv.symbol_address se2 id ofs = Senv.symbol_address se1 id ofs). { unfold Senv.symbol_address; simpl; intros. rewrite symbols_preserved; auto. } induction 1; eauto with barg. rewrite <- EQ in H; eauto with barg. rewrite <- EQ; eauto with barg. Qed. Lemma eval_builtin_args_preserved: - forall al vl, eval_builtin_args ge1 e sp m al vl -> eval_builtin_args ge2 e sp m al vl. + forall al vl, eval_builtin_args se1 e sp m al vl -> eval_builtin_args se2 e sp m al vl. Proof. induction 1; constructor; auto; eapply eval_builtin_arg_preserved; eauto. Qed. @@ -2096,6 +2085,7 @@ Section INFORM_TRACES. Variable F V: Type. Variable ge: Genv.t F V. +Context {CF: has_comp F}. Inductive call_trace: compartment -> compartment -> val -> list val -> list typ -> trace -> Prop := | call_trace_intra: forall cp cp' vf vargs ty, @@ -2105,7 +2095,7 @@ Inductive call_trace: compartment -> compartment -> val -> list val -> list typ Genv.type_of_call cp cp' = Genv.CrossCompartmentCall -> vf = Vptr b ofs -> Genv.invert_symbol ge b = Some i -> - eventval_list_match ge vl ty vargs -> + eventval_list_match (Genv.to_senv ge) vl ty vargs -> call_trace cp cp' vf vargs ty (Event_call cp cp' i vl :: nil). Lemma call_trace_same_cp: @@ -2133,7 +2123,7 @@ Inductive return_trace: compartment -> compartment -> val -> rettype -> trace -> return_trace cp cp' v ty E0 | return_trace_cross: forall cp cp' res v ty, Genv.type_of_call cp cp' = Genv.CrossCompartmentCall -> - eventval_match ge res (proj_rettype ty) v -> + eventval_match (Genv.to_senv ge) res (proj_rettype ty) v -> return_trace cp cp' v ty (Event_return cp cp' res :: nil) . @@ -2144,6 +2134,7 @@ Section INFORM_TRACES_INJECT. Variable F' V': Type. Variable ge: Genv.t F V. Variable ge': Genv.t F' V'. + Context {CF: has_comp F} {CF': has_comp F'}. Variable j: meminj. @@ -2194,9 +2185,10 @@ Section INFORM_TRACES_PRESERVED. Variable F' V': Type. Variable ge: Genv.t F V. Variable ge': Genv.t F' V'. + Context {CF: has_comp F} {CF': has_comp F'}. Variable symbols_preserved: forall (s: ident), Genv.find_symbol ge' s = Genv.find_symbol ge s. - Variable senv_preserved: Senv.equiv ge ge'. + Variable senv_preserved: Senv.equiv (Genv.to_senv ge) (Genv.to_senv ge'). Lemma call_trace_lessdef: forall cp cp' vf vs vs' tys t, @@ -2212,7 +2204,7 @@ Section INFORM_TRACES_PRESERVED. apply Genv.find_invert_symbol. now rewrite symbols_preserved. eapply eventval_list_match_lessdef; eauto. - eapply eventval_list_match_preserved with (ge1 := ge); try eapply senv_preserved; eauto. + eapply eventval_list_match_preserved with (ge1 := Genv.to_senv ge); try eapply senv_preserved; eauto. Qed. Lemma call_trace_eq: @@ -2237,7 +2229,7 @@ Section INFORM_TRACES_PRESERVED. - constructor; auto. - constructor; auto. eapply eventval_match_lessdef; eauto. - eapply eventval_match_preserved with (ge1 := ge); try eapply senv_preserved; eauto. + eapply eventval_match_preserved with (ge1 := Genv.to_senv ge); try eapply senv_preserved; eauto. Qed. Lemma return_trace_eq: @@ -2270,12 +2262,12 @@ Section DETERMINISM. Qed. Lemma call_trace_determ: - forall {F V} {ge: Genv.t F V} {cp cp' vf vargs ty t1 t2}, + forall {F V} {ge: Genv.t F V} {CF: has_comp F} {cp cp' vf vargs ty t1 t2}, call_trace ge cp cp' vf vargs ty t1 -> call_trace ge cp cp' vf vargs ty t2 -> t1 = t2. Proof. - intros F V ge cp cp' vf vargs ty t1 t2 CALL1 CALL2. + intros F V ge CF cp cp' vf vargs ty t1 t2 CALL1 CALL2. inv CALL1; inv CALL2. - reflexivity. - contradiction. @@ -2287,12 +2279,12 @@ Section DETERMINISM. Qed. Lemma return_trace_determ: - forall {F V} {ge: Genv.t F V} {cp cp' v ty t1 t2}, + forall {F V} {ge: Genv.t F V} {CF: has_comp F} {cp cp' v ty t1 t2}, return_trace ge cp cp' v ty t1 -> return_trace ge cp cp' v ty t2 -> t1 = t2. Proof. - intros F V ge cp cp' v ty t1 t2 RET1 RET2. + intros F V ge CF cp cp' v ty t1 t2 RET1 RET2. inv RET1; inv RET2. - reflexivity. - contradiction. diff --git a/common/Exec.v b/common/Exec.v index 54dfba62e9..859e9b7b63 100644 --- a/common/Exec.v +++ b/common/Exec.v @@ -47,6 +47,7 @@ Local Open Scope option_monad_scope. Section Exec. Variable F V: Type. +Context {CF: has_comp F}. Variable ge: Genv.t F V. Definition eventval_of_val (v: val) (t: typ) : option eventval := @@ -97,14 +98,14 @@ Ltac mydestr := end. Lemma eventval_of_val_sound: - forall v t ev, eventval_of_val v t = Some ev -> eventval_match ge ev t v. + forall v t ev, eventval_of_val v t = Some ev -> eventval_match (Genv.to_senv ge) ev t v. Proof. intros until ev. destruct v; simpl; mydestr; constructor. auto. apply Genv.invert_find_symbol; auto. Qed. Lemma eventval_of_val_complete: - forall ev t v, eventval_match ge ev t v -> eventval_of_val v t = Some ev. + forall ev t v, eventval_match (Genv.to_senv ge) ev t v -> eventval_of_val v t = Some ev. Proof. induction 1; simpl. - auto. @@ -116,7 +117,7 @@ Proof. Qed. Lemma list_eventval_of_val_sound: - forall vl tl evl, list_eventval_of_val vl tl = Some evl -> eventval_list_match ge evl tl vl. + forall vl tl evl, list_eventval_of_val vl tl = Some evl -> eventval_list_match (Genv.to_senv ge) evl tl vl. Proof with try discriminate. induction vl; destruct tl; simpl; intros; inv H. constructor. @@ -126,20 +127,20 @@ Proof with try discriminate. Qed. Lemma list_eventval_of_val_complete: - forall evl tl vl, eventval_list_match ge evl tl vl -> list_eventval_of_val vl tl = Some evl. + forall evl tl vl, eventval_list_match (Genv.to_senv ge) evl tl vl -> list_eventval_of_val vl tl = Some evl. Proof. induction 1; simpl. auto. rewrite (eventval_of_val_complete _ _ _ H). rewrite IHeventval_list_match. auto. Qed. Lemma val_of_eventval_sound: - forall ev t v, val_of_eventval ev t = Some v -> eventval_match ge ev t v. + forall ev t v, val_of_eventval ev t = Some v -> eventval_match (Genv.to_senv ge) ev t v. Proof. intros until v. destruct ev; simpl; mydestr; constructor; auto. Qed. Lemma val_of_eventval_complete: - forall ev t v, eventval_match ge ev t v -> val_of_eventval ev t = Some v. + forall ev t v, eventval_match (Genv.to_senv ge) ev t v -> val_of_eventval ev t = Some v. Proof. induction 1; simpl. - auto. @@ -222,9 +223,11 @@ Definition do_volatile_load (w: world) (chunk: memory_chunk) (cp: compartment) ( : option (world * trace * val) := if Genv.block_is_volatile ge b then do id <- Genv.invert_symbol ge b; + check (flowsto_dec (Senv.find_comp (Genv.to_senv ge) id) cp); match nextworld_vload w chunk id ofs with | None => None | Some(res, w') => + check (flowsto_dec (eventval_comp (Genv.to_senv ge) res) (Senv.find_comp (Genv.to_senv ge) id)); do vres <- val_of_eventval res (type_of_chunk chunk); Some(w', Event_vload chunk id ofs res :: nil, Val.load_result chunk vres) end @@ -236,7 +239,9 @@ Definition do_volatile_store (w: world) (chunk: memory_chunk) (cp: compartment) : option (world * trace * mem * val) := if Genv.block_is_volatile ge b then do id <- Genv.invert_symbol ge b; + check (flowsto_dec (Senv.find_comp (Genv.to_senv ge) id) cp); do ev <- eventval_of_val (Val.load_result chunk v) (type_of_chunk chunk); + check (flowsto_dec (eventval_comp (Genv.to_senv ge) ev) (Senv.find_comp (Genv.to_senv ge) id)); do w' <- nextworld_vstore w chunk id ofs ev; Some(w', Event_vstore chunk id ofs ev :: nil, m, v) else @@ -246,7 +251,7 @@ Definition do_volatile_store (w: world) (chunk: memory_chunk) (cp: compartment) Lemma do_volatile_load_sound: forall w chunk cp m b ofs w' t v, do_volatile_load w chunk cp m b ofs = Some(w', t, v) -> - volatile_load ge cp chunk m b ofs t v /\ possible_trace w t w'. + volatile_load (Genv.to_senv ge) cp chunk m b ofs t v /\ possible_trace w t w'. Proof. intros until v. unfold do_volatile_load. mydestr. destruct p as [ev w'']. mydestr. @@ -261,21 +266,22 @@ Proof. Qed. Lemma do_volatile_load_complete: - forall w chunk cp m b ofs w' t v -, - volatile_load ge cp chunk m b ofs t v -> possible_trace w t w' -> + forall w chunk cp m b ofs w' t v , + volatile_load (Genv.to_senv ge) cp chunk m b ofs t v -> possible_trace w t w' -> do_volatile_load w chunk cp m b ofs = Some(w', t, v). Proof. unfold do_volatile_load; intros. inv H; simpl in *. - rewrite H1. rewrite (Genv.find_invert_symbol _ _ H2). inv H0. inv H8. inv H6. rewrite H9. - rewrite (val_of_eventval_complete _ _ _ H3). auto. + rewrite H1. rewrite (Genv.find_invert_symbol _ _ H2). inv H0. inv H8. inv H10. rewrite H12. + destruct flowsto_dec; try congruence. + destruct flowsto_dec; try congruence. + rewrite (val_of_eventval_complete _ _ _ H4). auto. rewrite H1. rewrite H2. inv H0. auto. Qed. Lemma do_volatile_store_sound: forall w chunk cp m b ofs v w' t m' v', do_volatile_store w chunk cp m b ofs v = Some(w', t, m', v') -> - volatile_store ge cp chunk m b ofs v t m' /\ possible_trace w t w' /\ v' = v. + volatile_store (Genv.to_senv ge) cp chunk m b ofs v t m' /\ possible_trace w t w' /\ v' = v. Proof. intros until v'. unfold do_volatile_store. mydestr. split. constructor; auto. apply Genv.invert_find_symbol; auto. @@ -288,17 +294,19 @@ Qed. Lemma do_volatile_store_complete: forall w chunk cp m b ofs v w' t m', - volatile_store ge cp chunk m b ofs v t m' -> possible_trace w t w' -> + volatile_store (Genv.to_senv ge) cp chunk m b ofs v t m' -> possible_trace w t w' -> do_volatile_store w chunk cp m b ofs v = Some(w', t, m', v). Proof. unfold do_volatile_store; intros. inv H; simpl in *. rewrite H1. rewrite (Genv.find_invert_symbol _ _ H2). - rewrite (eventval_of_val_complete _ _ _ H3). - inv H0. inv H8. inv H6. rewrite H9. auto. + rewrite (eventval_of_val_complete _ _ _ H4). + inv H0. inv H8. inv H10. rewrite H12. + destruct flowsto_dec; try congruence. + destruct flowsto_dec; try congruence. + auto. rewrite H1. rewrite H2. inv H0. auto. Qed. - (** External calls *) Variable do_external_function: @@ -412,6 +420,7 @@ Definition do_ef_memcpy (sz al: Z) Definition do_ef_annot (text: string) (targs: list typ) (cp: compartment) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := do args <- list_eventval_of_val vargs targs; + check (forallb (fun ev => flowsto_dec (eventval_comp (Genv.to_senv ge) ev) cp)) args; Some(w, Event_annot text args :: E0, Vundef, m). Definition do_ef_annot_val (text: string) (targ: typ) @@ -419,6 +428,7 @@ Definition do_ef_annot_val (text: string) (targ: typ) match vargs with | varg :: nil => do arg <- eventval_of_val varg targ; + check (flowsto_dec (eventval_comp (Genv.to_senv ge) arg) cp); Some(w, Event_annot text (arg :: nil) :: E0, varg, m) | _ => None end. @@ -431,13 +441,13 @@ Definition do_builtin_or_external (name: string) (sg: signature) (cp: compartmen (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match lookup_builtin_function name sg with | Some bf => match builtin_function_sem bf vargs with Some v => Some(w, E0, v, m) | None => None end - | None => do_external_function name sg ge cp w vargs m + | None => do_external_function name sg (Genv.to_senv ge) cp w vargs m end. Definition do_external (ef: external_function): compartment -> world -> list val -> mem -> option (world * trace * val * mem) := match ef with - | EF_external name sg => do_external_function name sg ge + | EF_external name sg => do_external_function name sg (Genv.to_senv ge) | EF_builtin name sg => do_builtin_or_external name sg | EF_runtime name sg => do_builtin_or_external name sg | EF_vload chunk => do_ef_volatile_load chunk @@ -447,14 +457,14 @@ Definition do_external (ef: external_function): | EF_memcpy sz al => do_ef_memcpy sz al | EF_annot kind text targs => do_ef_annot text targs | EF_annot_val kind text targ => do_ef_annot_val text targ - | EF_inline_asm text sg clob => do_inline_assembly text sg ge + | EF_inline_asm text sg clob => do_inline_assembly text sg (Genv.to_senv ge) | EF_debug kind text targs => do_ef_debug kind text targs end. Lemma do_ef_external_sound: forall ef cp w vargs m w' t vres m', do_external ef cp w vargs m = Some(w', t, vres, m') -> - external_call ef ge cp vargs m t vres m' /\ possible_trace w t w'. + external_call ef (Genv.to_senv ge) cp vargs m t vres m' /\ possible_trace w t w'. Proof with try congruence. intros until m'. assert (SIZE: forall v sz, do_alloc_size v = Some sz -> v = Vptrofs sz). @@ -462,7 +472,7 @@ Proof with try congruence. intros EQ; inv EQ; f_equal; symmetry; eauto with ptrofs. } assert (BF_EX: forall name sg, do_builtin_or_external name sg cp w vargs m = Some (w', t, vres, m') -> - builtin_or_external_sem name sg ge cp vargs m t vres m' /\ possible_trace w t w'). + builtin_or_external_sem name sg (Genv.to_senv ge) cp vargs m t vres m' /\ possible_trace w t w'). { unfold do_builtin_or_external, builtin_or_external_sem; intros. destruct (lookup_builtin_function name sg ) as [bf|]. - destruct (builtin_function_sem bf vargs) as [vres1|] eqn:BF; inv H. @@ -507,10 +517,12 @@ Proof with try congruence. - (* EF_annot *) unfold do_ef_annot. mydestr. split. constructor. apply list_eventval_of_val_sound; auto. + rewrite forallb_forall in Heqb. rewrite Forall_forall. + intros. exploit Heqb; eauto. now destruct flowsto_dec; eauto. econstructor. constructor; eauto. constructor. - (* EF_annot_val *) unfold do_ef_annot_val. destruct vargs... destruct vargs... mydestr. - split. constructor. apply eventval_of_val_sound; auto. + split. constructor. apply eventval_of_val_sound; auto. auto. econstructor. constructor; eauto. constructor. - (* EF_inline_asm *) eapply do_inline_assembly_sound; eauto. @@ -520,7 +532,7 @@ Qed. Lemma do_ef_external_complete: forall ef cp w vargs m w' t vres m', - external_call ef ge cp vargs m t vres m' -> possible_trace w t w' -> + external_call ef (Genv.to_senv ge) cp vargs m t vres m' -> possible_trace w t w' -> do_external ef cp w vargs m = Some(w', t, vres, m'). Proof. intros. @@ -529,7 +541,7 @@ Proof. rewrite Ptrofs.of_int64_to_int64; auto. rewrite Ptrofs.of_int_to_int; auto. } assert (BF_EX: forall name sg, - builtin_or_external_sem name sg ge cp vargs m t vres m' -> + builtin_or_external_sem name sg (Genv.to_senv ge) cp vargs m t vres m' -> do_builtin_or_external name sg cp w vargs m = Some (w', t, vres, m')). { unfold do_builtin_or_external, builtin_or_external_sem; intros. destruct (lookup_builtin_function name sg) as [bf|]. @@ -561,11 +573,16 @@ Proof. inv H0. rewrite Decidable_complete. rewrite H7; rewrite H8; auto. red. tauto. - (* EF_annot *) - inv H; unfold do_ef_annot. inv H0. inv H6. inv H4. - rewrite (list_eventval_of_val_complete _ _ _ H1). auto. + inv H; unfold do_ef_annot. inv H0. inv H7. inv H5. + rewrite (list_eventval_of_val_complete _ _ _ H1). + rewrite Forall_forall in H2. + assert (H: forallb (fun ev : eventval => flowsto_dec (eventval_comp (Genv.to_senv ge) ev) cp) args = true). + { rewrite forallb_forall. intros. exploit H2; eauto. now destruct flowsto_dec; eauto. } + now rewrite H. - (* EF_annot_val *) - inv H; unfold do_ef_annot_val. inv H0. inv H6. inv H4. - rewrite (eventval_of_val_complete _ _ _ H1). auto. + inv H; unfold do_ef_annot_val. inv H0. inv H7. inv H5. + rewrite (eventval_of_val_complete _ _ _ H1). + now destruct flowsto_dec; auto. - (* EF_inline_asm *) eapply do_inline_assembly_complete; eauto. - (* EF_debug *) diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 868b9508e0..66dc86711a 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -69,6 +69,7 @@ Local Unset Case Analysis Schemes. (** Symbol environments are a restricted view of global environments, focusing on symbol names and their associated blocks. They do not contain mappings from blocks to function or variable definitions. *) +(* Symbol environments now also contain compartment information. *) Module Senv. @@ -79,6 +80,7 @@ Record t: Type := mksenv { invert_symbol: block -> option ident; block_is_volatile: block -> bool; nextblock: block; + find_comp: ident -> compartment; (** Properties *) find_symbol_injective: forall id1 id2 b, find_symbol id1 = Some b -> find_symbol id2 = Some b -> id1 = id2; @@ -130,7 +132,8 @@ Qed. Definition equiv (se1 se2: t) : Prop := (forall id, find_symbol se2 id = find_symbol se1 id) /\ (forall id, public_symbol se2 id = public_symbol se1 id) - /\ (forall b, block_is_volatile se2 b = block_is_volatile se1 b). + /\ (forall b, block_is_volatile se2 b = block_is_volatile se1 b) + /\ (forall id, find_comp se2 id = find_comp se1 id). End Senv. @@ -767,6 +770,13 @@ Qed. (** ** Coercing a global environment into a symbol environment *) +Definition to_map_ident (p: PTree.t compartment): ident -> compartment := + fun id => + match p ! id with + | Some cp => cp + | None => bottom + end. + Definition to_senv (ge: t) : Senv.t := @Senv.mksenv (find_symbol ge) @@ -774,6 +784,7 @@ Definition to_senv (ge: t) : Senv.t := (invert_symbol ge) (block_is_volatile ge) ge.(genv_next) + (to_map_ident ge.(genv_policy).(Policy.policy_comps)) ge.(genv_vars_inj) (invert_find_symbol ge) (find_invert_symbol ge) @@ -2298,6 +2309,21 @@ Proof. intros. destruct globalenvs_match. apply mge_symb0. Qed. +Theorem find_comp_match: + forall (s : ident), + find_comp_of_ident (globalenv tp) s = find_comp_of_ident (globalenv p) s. +Proof. + intros. destruct globalenvs_match. unfold find_comp_of_ident. + rewrite find_symbol_match. + destruct (find_symbol (globalenv p) s); try reflexivity. + unfold find_comp_of_block. + unfold find_def. specialize (mge_defs0 b). + inv mge_defs0; auto. + inv H1; auto. + - exploit match_fundef_comp; eauto. + - inv H2; auto. +Qed. + Theorem senv_match: Senv.equiv (to_senv (globalenv p)) (to_senv (globalenv tp)). Proof. @@ -2312,6 +2338,18 @@ Proof. inv R; auto. inv H1; auto. inv H2; auto. +- intros. + destruct progmatch as (P & Q & R & S). + unfold globalenv. rewrite !genv_pol_add_globals. + simpl. apply andb_prop in S as [S _]. + apply andb_prop in S as [S _]. + unfold to_map_ident. + rewrite PTree.beq_correct in S. + specialize (S id). + destruct ((Policy.policy_comps (prog_pol tp)) ! id) eqn:?; + destruct ((Policy.policy_comps (prog_pol p)) ! id) eqn:?; try contradiction. + destruct cp_eq_dec; auto; try discriminate. + reflexivity. Qed. Lemma store_init_data_list_match: @@ -2436,10 +2474,11 @@ Proof. clear -H1 EQPOL. rewrite genv_pol_add_globals. rewrite genv_pol_add_globals in H1. - unfold Policy.eqb in EQPOL. apply andb_prop in EQPOL. - destruct EQPOL as [EQPOL1 EQPOL2]. - eapply CompTree.beq_sound with (x := cp) in EQPOL1. + unfold Policy.eqb in EQPOL. + apply andb_prop in EQPOL. destruct EQPOL as [EQPOL EQPOL3]. + apply andb_prop in EQPOL. destruct EQPOL as [EQPOL1 EQPOL2]. eapply CompTree.beq_sound with (x := cp) in EQPOL2. + eapply CompTree.beq_sound with (x := cp) in EQPOL3. (* rewrite PTree.beq_correct in EQPOL2. *) (* specialize (EQPOL2 cp). *) simpl in *. @@ -2453,12 +2492,13 @@ Proof. simpl in *. clear -H2 EQPOL CF2. rewrite genv_pol_add_globals. rewrite genv_pol_add_globals in H2. - unfold Policy.eqb in EQPOL. apply andb_prop in EQPOL. - destruct EQPOL as [EQPOL1 EQPOL2]. + unfold Policy.eqb in EQPOL. + apply andb_prop in EQPOL. destruct EQPOL as [EQPOL EQPOL3]. + apply andb_prop in EQPOL. destruct EQPOL as [EQPOL1 EQPOL2]. set (cp := find_comp_of_block (add_globals (empty_genv F1 V1 prog_pol_pub) prog_defs) b). fold cp in H2. - eapply CompTree.beq_sound with (x := cp) in EQPOL1. eapply CompTree.beq_sound with (x := cp) in EQPOL2. + eapply CompTree.beq_sound with (x := cp) in EQPOL3. (* rewrite PTree.beq_correct in EQPOL2. *) (* specialize (EQPOL2 cp). *) simpl in *. @@ -2816,3 +2856,6 @@ End TRANSFORM_TOTAL. End Genv. Coercion Genv.to_senv: Genv.t >-> Senv.t. + +(* Try to see if this solves the coercion problem. We need Coq 8.16 for that*) +(* #[reversible] Coercion Genv.to_senv. *) diff --git a/common/Linking.v b/common/Linking.v index caca70fec9..71897e89fc 100644 --- a/common/Linking.v +++ b/common/Linking.v @@ -47,9 +47,17 @@ Class Linker (A: Type) := { linkorder: A -> A -> Prop; linkorder_refl: forall x, linkorder x x; linkorder_trans: forall x y z, linkorder x y -> linkorder y z -> linkorder x z; - link_linkorder: forall x y z, link x y = Some z -> linkorder x z /\ linkorder y z + link_linkorder: forall x y z, link x y = Some z -> linkorder x z /\ linkorder y z; }. +(* has_comp_match *) +(* Class has_comp_linker {A: Type} {CA: has_comp A} (LA: Linker A) := *) +(* link_comp : forall x y z, *) +(* link x y = Some z -> *) +(* ((comp_of x = bottom /\ comp_of y = comp_of z) \/ *) +(* (comp_of y = bottom /\ comp_of x = comp_of z) \/ *) +(* (comp_of x = comp_of z /\ comp_of y = comp_of z)). *) + (** Linking function definitions. External functions of the [EF_external] kind can link with internal function definitions; the result of linking is the internal definition. Two external functions can link @@ -96,6 +104,22 @@ Next Obligation. + destruct (external_function_eq e e0); inv H. split; constructor. Defined. +(* Global Instance Linker_fundef_comp (F: Type) {CP: has_comp F}: *) +(* has_comp_linker (Linker_fundef F). *) +(* Proof. *) +(* unfold has_comp_linker, Linker_fundef. *) +(* intros x y z H. *) +(* unfold link, link_fundef in H. *) +(* destruct x, y; try congruence. *) +(* - destruct e; try congruence; right; left; split; auto with comps. *) +(* inv H; auto with comps. *) +(* - destruct e; try congruence; left; split; auto with comps. *) +(* inv H; subst; auto with comps. *) +(* - destruct (external_function_eq e e0); try congruence; right; right; split; auto with comps. *) +(* inv H; subst; auto with comps. *) +(* inv H; subst; auto with comps. *) +(* Qed. *) + Global Opaque Linker_fundef. (** Linking variable initializers. We adopt the following conventions: @@ -166,7 +190,8 @@ Definition link_vardef {V: Type} {LV: Linker V} (v1 v2: globvar V) := match link v1.(gvar_init) v2.(gvar_init) with | None => None | Some init => - if cp_eq_dec v1.(gvar_comp) v2.(gvar_comp) (* FIXME: use the meet or join!! (figure out which one makes sense) *) + if cp_eq_dec v1.(gvar_comp) v2.(gvar_comp) + (* FIXME: use the meet or join!! (figure out which one makes sense) *) && eqb v1.(gvar_readonly) v2.(gvar_readonly) && eqb v1.(gvar_volatile) v2.(gvar_volatile) then Some {| gvar_info := info; gvar_init := init; @@ -206,6 +231,21 @@ Next Obligation. split; constructor; tauto. Defined. +(* Global Instance Linker_vardef_comp (V: Type) {LV: Linker V}: *) +(* has_comp_linker (Linker_vardef V). *) +(* Proof. *) +(* unfold has_comp_linker, link, Linker_vardef, link_vardef. *) +(* intros. *) +(* right; right. *) +(* destruct (link (gvar_info x) (gvar_info y)) eqn:?; try congruence. *) +(* destruct (link (gvar_init x) (gvar_init y)) eqn:?; try congruence. *) +(* destruct andb eqn:EQ; try congruence. inv H. simpl in *. *) +(* apply andb_prop in EQ as [EQ1 EQ3]. *) +(* apply andb_prop in EQ1 as [EQ1 EQ2]. *) +(* destruct (cp_eq_dec (gvar_comp x) (gvar_comp y)) as [e | ?]; try discriminate. *) +(* now rewrite e. *) +(* Qed. *) + Global Opaque Linker_vardef. (** A trivial linker for the trivial var info [unit]. *) @@ -257,6 +297,20 @@ Next Obligation. split; constructor; tauto. Defined. +(* Global Instance Linker_def_comp (F V: Type) {CF: has_comp F} {LF: Linker F} (* {CLF: has_comp_linker LF} *){LV: Linker V}: *) +(* has_comp_linker (Linker_def F V). *) +(* Proof. *) +(* unfold has_comp_linker, Linker_def. *) +(* intros x y z H. *) +(* unfold link, link_def in H. *) +(* destruct x, y; try congruence. *) +(* - destruct (link f f0) eqn:EQ; try congruence. *) +(* inv H. *) +(* specialize (CLF _ _ _ EQ). auto. *) +(* - destruct (link v v0) eqn:EQ; try congruence. *) +(* inv H. simpl. *) +(* pose proof (Linker_vardef_comp _ _ _ _ EQ). auto. *) +(* Qed. *) Global Opaque Linker_def. (** Linking two compilation units. Compilation units are represented like @@ -275,7 +329,9 @@ Global Opaque Linker_def. Section LINKER_PROG. -Context {F V: Type} {LF: Linker F} {LV: Linker V} (p1 p2: program F V). +Context {F V: Type} {CF: has_comp F} {LF: Linker F} {LV: Linker V} + (* {CLF: has_comp_linker LF} (* {CLV: Has_Comp_Linker LV} *) *) + (p1 p2: program F V). Let dm1 := prog_defmap p1. Let dm2 := prog_defmap p2. @@ -302,6 +358,137 @@ Lemma link_prog_subproof : Proof. Admitted. +(* Definition link_pol_comp (oc1 oc2: option compartment) := *) +(* match oc1, oc2 with *) +(* | None, oc2 => oc2 *) +(* | oc1, None => oc1 *) +(* | Some c1, Some c2 => *) +(* if cp_eq_dec c1 bottom then Some c2 *) +(* else if cp_eq_dec c2 bottom then Some c1 *) +(* else if cp_eq_dec c1 c2 then Some c1 *) +(* else None *) +(* end. *) + +(* Definition link_pol_check (x: ident) (c1: compartment) := *) +(* match link_pol_comp (Some c1) p2.(prog_pol).(Policy.policy_comps)!x with *) +(* | Some _ => true *) +(* | None => false *) +(* end. *) + +Definition link_pol_comp: PTree.t compartment := + let defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2) in + PTree_Properties.of_list (List.map (fun '(id, a) => (id, comp_of a)) defs). + + +Definition link_pol (pol1 pol2: Policy.t): Policy.t := + let comb := link_pol_comp in + {| Policy.policy_comps := comb; + Policy.policy_export := pol1.(Policy.policy_export); + Policy.policy_import := pol1.(Policy.policy_import); + |}. + +Lemma prog_agr_comps_link: + agr_comps (link_pol p1.(prog_pol) p2.(prog_pol)) + (PTree.elements (PTree.combine link_prog_merge dm1 dm2)). +Proof. + Admitted. + + +(* Definition link_pol (pol1 pol2: Policy.t): Policy.t := *) +(* let comb := *) +(* PTree.combine link_pol_comp pol1.(Policy.policy_comps) pol2.(Policy.policy_comps) in *) +(* {| Policy.policy_comps := comb; *) +(* Policy.policy_export := pol1.(Policy.policy_export); *) +(* Policy.policy_import := pol1.(Policy.policy_import); *) +(* |}. *) + + +(* Lemma prog_agr_comps_link: *) +(* PTree_Properties.for_all p1.(prog_pol).(Policy.policy_comps) link_pol_check = true -> *) +(* agr_comps (link_pol p1.(prog_pol) p2.(prog_pol)) *) +(* (PTree.elements (PTree.combine link_prog_merge dm1 dm2)). *) +(* Proof. *) +(* intros H. *) +(* rewrite PTree_Properties.for_all_correct in H. *) +(* unfold agr_comps. *) +(* split. *) +(* { *) +(* apply Forall_forall. *) +(* intros [id gd] found_in. *) +(* simpl. exploit PTree.elements_complete; eauto. *) +(* intros G. *) +(* rewrite PTree.gcombine in G; [| reflexivity]. *) +(* unfold link_prog_merge in G. *) +(* rewrite PTree.gcombine; [| reflexivity]. *) +(* destruct (dm1 ! id) eqn:dm1_id. *) +(* - unfold link_pol_check in H. *) +(* pose proof p1.(prog_agr_comps) as [R S]. *) +(* rewrite Forall_forall in R. apply in_prog_defmap in dm1_id. *) +(* specialize (R (id, g) dm1_id). simpl in R. *) +(* specialize (H id (comp_of g) (R)). *) +(* rewrite R in *. *) +(* destruct (dm2 ! id) eqn:dm2_id. *) +(* + pose proof p2.(prog_agr_comps) as [R' S']. *) +(* rewrite Forall_forall in R'. apply in_prog_defmap in dm2_id. *) +(* specialize (R' (id, g0) dm2_id). simpl in R'. *) +(* eapply Linker_def_comp with (V := V) in CLF. *) +(* specialize (CLF _ _ _ G). *) +(* rewrite R'; simpl. *) +(* intuition. *) +(* * destruct (cp_eq_dec); try congruence. *) +(* * destruct (cp_eq_dec); try congruence. *) +(* destruct (cp_eq_dec); try congruence. *) +(* * destruct (cp_eq_dec); try congruence. *) +(* destruct (cp_eq_dec); try congruence. *) +(* destruct (cp_eq_dec); try congruence. *) +(* + inv G. simpl. *) +(* pose proof p2.(prog_agr_comps) as [_ S']. *) +(* destruct ((Policy.policy_comps (prog_pol p2))! id) eqn:EQ. *) +(* * specialize (S' _ _ EQ) as [gd' [? ?]]. subst. *) +(* assert (C: In id (prog_defs_names p2)). *) +(* { unfold prog_defs_names. eapply in_map with (f := fst) in H0; eauto. } *) +(* exploit prog_defmap_dom; eauto. *) +(* intros [? C']. unfold dm2 in *. congruence. *) +(* * reflexivity. *) +(* - pose proof p2.(prog_agr_comps) as [R' S']. *) +(* rewrite Forall_forall in R'. apply in_prog_defmap in G as dm2_id. *) +(* specialize (R' (id, gd) dm2_id). simpl in R'. *) +(* rewrite R'. *) +(* pose proof p1.(prog_agr_comps) as [_ S]. *) +(* destruct ((Policy.policy_comps (prog_pol p1))! id) eqn:EQ. *) +(* + specialize (S _ _ EQ) as [gd' [? ?]]. subst. *) +(* assert (C: In id (prog_defs_names p1)). *) +(* { unfold prog_defs_names. eapply in_map with (f := fst) in H0; eauto. } *) +(* exploit prog_defmap_dom; eauto. *) +(* intros [? C']. unfold dm1 in *. congruence. *) +(* + reflexivity. *) +(* } *) +(* { *) +(* intros id cp G. *) +(* simpl in *. *) +(* rewrite PTree.gcombine in G; eauto. *) +(* unfold link_pol_comp in G. *) + +(* pose proof p1.(prog_agr_comps) as [R S]. *) +(* pose proof p2.(prog_agr_comps) as [R' S']. *) +(* destruct ((Policy.policy_comps (prog_pol p1)) ! id) eqn:EQ. *) +(* - destruct ((Policy.policy_comps (prog_pol p2)) ! id) eqn:EQ'. *) +(* + specialize (S _ _ EQ) as [gd1 [in1 ?]]; specialize (S' _ _ EQ') as [gd2 [in2 ?]]; subst. *) + + +(* - pose proof p2.(prog_agr_comps) as [R' S']. *) +(* specialize (S' _ _ G) as [gd [? ?]]; subst. *) +(* eexists. split; [|reflexivity]. *) +(* eapply PTree.elements_correct. *) +(* rewrite PTree.gcombine; eauto. unfold link_prog_merge. *) +(* pose proof p1.(prog_agr_comps) as [R S]. *) +(* assert (dm1_id: dm1 ! id = None). *) +(* { destruct (dm1 ! id) eqn:EQ'; try congruence. exfalso. *) +(* rewrite Forall_forall in R. admit. } *) +(* admit. *) +(* } *) +(* Admitted. *) + Definition link_prog := if ident_eq p1.(prog_main) p2.(prog_main) && PTree_Properties.for_all dm1 link_prog_check then @@ -311,8 +498,9 @@ Definition link_prog := Some {| prog_main := p1.(prog_main); prog_public := p1.(prog_public) ++ p2.(prog_public); prog_defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2); - prog_pol := p1.(prog_pol); - prog_pol_pub := link_prog_subproof yes; |} + prog_pol := link_pol (prog_pol p1) (prog_pol p2); + prog_pol_pub := link_prog_subproof yes; + prog_agr_comps := prog_agr_comps_link |} | right _ => None end else @@ -330,8 +518,9 @@ Lemma link_prog_inv: p = {| prog_main := p1.(prog_main); prog_public := p1.(prog_public) ++ p2.(prog_public); prog_defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2); - prog_pol := p1.(prog_pol); - prog_pol_pub := link_prog_subproof yes |}. + prog_pol := link_pol (prog_pol p1) (prog_pol p2); + prog_pol_pub := link_prog_subproof yes; + prog_agr_comps := prog_agr_comps_link |}. Proof. unfold link_prog; intros p E. destruct (ident_eq (prog_main p1) (prog_main p2)); try discriminate. @@ -359,8 +548,9 @@ Lemma link_prog_succeeds: Some {| prog_main := p1.(prog_main); prog_public := p1.(prog_public) ++ p2.(prog_public); prog_defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2); - prog_pol := p1.(prog_pol); + prog_pol := link_pol (prog_pol p1) (prog_pol p2); prog_pol_pub := link_prog_subproof yes; + prog_agr_comps := prog_agr_comps_link; |}. Proof. intros. unfold link_prog. unfold proj_sumbool. rewrite H, dec_eq_true. simpl. @@ -373,15 +563,22 @@ Proof. Qed. Lemma prog_defmap_elements: - forall (m: PTree.t (globdef F V)) pub mn pol H x, - (prog_defmap {| prog_defs := PTree.elements m; prog_public := pub; prog_main := mn; prog_pol := pol; prog_pol_pub := H |})!x = m!x. + forall (m: PTree.t (globdef F V)) pub mn pol H H' x, + (prog_defmap {| prog_defs := PTree.elements m; + prog_public := pub; + prog_main := mn; + prog_pol := pol; + prog_pol_pub := H; + prog_agr_comps := H'; + |})!x = m!x. Proof. intros. unfold prog_defmap; simpl. apply PTree_Properties.of_list_elements. Qed. End LINKER_PROG. -Global Program Instance Linker_prog (F V: Type) {LF: Linker F} {LV: Linker V} : Linker (program F V) := { +Global Program Instance Linker_prog (F V: Type) {CF: has_comp F} {LF: Linker F} (* {CLF: has_comp_linker LF} *) + {LV: Linker V} : Linker (program F V) := { link := link_prog; linkorder := fun p1 p2 => p1.(prog_main) = p2.(prog_main) @@ -424,7 +621,7 @@ Next Obligation. Defined. Lemma prog_defmap_linkorder: - forall {F V: Type} {LF: Linker F} {LV: Linker V} (p1 p2: program F V) id gd1, + forall {F V: Type} {CF: has_comp F} {LF: Linker F} (* {CLF: has_comp_linker LF} *) {LV: Linker V} (p1 p2: program F V) id gd1, linkorder p1 p2 -> (prog_defmap p1)!id = Some gd1 -> exists gd2, (prog_defmap p2)!id = Some gd2 /\ linkorder gd1 gd2. @@ -448,8 +645,9 @@ Global Opaque Linker_prog. Section MATCH_PROGRAM_GENERIC. -Context {C F1 V1 F2 V2: Type} {LC: Linker C} {LF: Linker F1} {LV: Linker V1}. +Context {C F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LC: Linker C} {LF: Linker F1} {LV: Linker V1}. Variable match_fundef: C -> F1 -> F2 -> Prop. +(* Context {comp_match_fundef: has_comp_match match_fundef}. *) Variable match_varinfo: V1 -> V2 -> Prop. Inductive match_globvar: globvar V1 -> globvar V2 -> Prop := @@ -500,14 +698,15 @@ End MATCH_PROGRAM_GENERIC. (** In many cases, the context for [match_program_gen] is the source program or source compilation unit itself. We provide a specialized definition for this case. *) -Definition match_program {F1 V1 F2 V2: Type} {LF: Linker F1} {LV: Linker V1} +Definition match_program {F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LF: Linker F1} + (* {CLF: has_comp_linker LF} *) {LV: Linker V1} (match_fundef: program F1 V1 -> F1 -> F2 -> Prop) (match_varinfo: V1 -> V2 -> Prop) (p1: program F1 V1) (p2: program F2 V2) : Prop := match_program_gen match_fundef match_varinfo p1 p1 p2. Lemma match_program_main: - forall {F1 V1 F2 V2: Type} {LF: Linker F1} {LV: Linker V1} + forall {F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LF: Linker F1} (* {CLF: has_comp_linker LF} *) {LV: Linker V1} {match_fundef: program F1 V1 -> F1 -> F2 -> Prop} {match_varinfo: V1 -> V2 -> Prop} {p1: program F1 V1} {p2: program F2 V2}, @@ -539,10 +738,12 @@ Qed. and the [match_program] predicate. *) Theorem match_transform_partial_program2: - forall {C F1 V1 F2 V2: Type} {LC: Linker C} {LF: Linker F1} {LV: Linker V1} + forall {C F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LC: Linker C} {LF: Linker F1} + {LV: Linker V1} (match_fundef: C -> F1 -> F2 -> Prop) (match_varinfo: V1 -> V2 -> Prop) (transf_fun: ident -> F1 -> res F2) + {Cf: forall id, has_comp_transl_partial (transf_fun id)} (transf_var: ident -> V1 -> res V2) (ctx: C) (p: program F1 V1) (tp: program F2 V2), transform_partial_program2 transf_fun transf_var p = OK tp -> @@ -550,24 +751,39 @@ Theorem match_transform_partial_program2: (forall i v tv, transf_var i v = OK tv -> match_varinfo v tv) -> match_program_gen match_fundef match_varinfo ctx p tp. Proof. - unfold transform_partial_program2; intros. monadInv H. - red; simpl; split; auto. - revert x EQ. generalize (prog_defs p). - induction l as [ | [i g] l]; simpl; intros. -- monadInv EQ. constructor. -- destruct g as [f|v]. -+ destruct (transf_fun i f) as [tf|?] eqn:TF; monadInv EQ. - constructor; auto. split; simpl; auto. econstructor. apply linkorder_refl. eauto. -+ destruct (transf_globvar transf_var i v) as [tv|?] eqn:TV; monadInv EQ. - constructor; auto. split; simpl; auto. constructor. - monadInv TV. destruct v; simpl; constructor. eauto. -- split; auto. split; auto. apply Policy.eqb_refl. -Qed. + unfold transform_partial_program2; intros. +Admitted. +(* dependent types issue *) +(* monadInv H. *) +(* red; simpl; split; auto. *) +(* revert x EQ. generalize (prog_defs p). *) +(* induction l as [ | [i g] l]; simpl; intros. *) +(* - monadInv EQ. constructor. *) +(* - destruct g as [f|v]. *) +(* + destruct (transf_fun i f) as [tf|?] eqn:TF; monadInv EQ. *) +(* constructor; auto. split; simpl; auto. econstructor. apply linkorder_refl. eauto. *) +(* + destruct (transf_globvar transf_var i v) as [tv|?] eqn:TV; monadInv EQ. *) +(* constructor; auto. split; simpl; auto. constructor. *) +(* monadInv TV. destruct v; simpl; constructor. eauto. *) +(* - split; auto. split; auto. *) +(* destruct (prog_pol p); simpl; auto. *) +(* unfold update_policy; simpl; auto. *) +(* unfold Policy.eqb; rewrite !andb_true_iff; repeat split; simpl; auto. *) +(* + rewrite PTree.beq_correct. intros id. *) +(* unfold update_list_comps. admit. *) +(* + rewrite PTree.beq_correct. *) +(* intros y. destruct (policy_export ! y); auto. *) +(* destruct (Policy.list_id_eq l l); auto. *) +(* + rewrite PTree.beq_correct. *) +(* intros y. destruct (policy_import ! y); auto. *) +(* destruct (Policy.list_cpt_id_eq l l); auto. *) +(* Admitted. *) Theorem match_transform_partial_program_contextual: - forall {A B V: Type} {LA: Linker A} {LV: Linker V} + forall {A B V: Type} {CA: has_comp A} {CB: has_comp B} {LA: Linker A} {LV: Linker V} (match_fundef: program A V -> A -> B -> Prop) (transf_fun: A -> res B) + {comp_transf_fun: has_comp_transl_partial transf_fun} (p: program A V) (tp: program B V), transform_partial_program transf_fun p = OK tp -> (forall f tf, transf_fun f = OK tf -> match_fundef p f tf) -> @@ -580,9 +796,10 @@ Proof. Qed. Theorem match_transform_program_contextual: - forall {A B V: Type} {LA: Linker A} {LV: Linker V} + forall {A B V: Type} {CA: has_comp A} {CB: has_comp B} {LA: Linker A} {LV: Linker V} (match_fundef: program A V -> A -> B -> Prop) (transf_fun: A -> B) + {comp_transf: has_comp_transl transf_fun} (p: program A V), (forall f, match_fundef p f (transf_fun f)) -> match_program match_fundef eq p (transform_program transf_fun p). @@ -597,8 +814,9 @@ Qed. function transformation does not depend on the compilation unit. *) Theorem match_transform_partial_program: - forall {A B V: Type} {LA: Linker A} {LV: Linker V} + forall {A B V: Type} {CA: has_comp A} {CB: has_comp B} {LA: Linker A} {LV: Linker V} (transf_fun: A -> res B) + {comp_transf_fun: has_comp_transl_partial transf_fun} (p: program A V) (tp: program B V), transform_partial_program transf_fun p = OK tp -> match_program (fun cu f tf => transf_fun f = OK tf) eq p tp. @@ -610,8 +828,9 @@ Proof. Qed. Theorem match_transform_program: - forall {A B V: Type} {LA: Linker A} {LV: Linker V} + forall {A B V: Type} {CA: has_comp A} {CB: has_comp B} {LA: Linker A} {LV: Linker V} (transf: A -> B) + {comp_transf: has_comp_transl transf} (p: program A V), match_program (fun cu f tf => tf = transf f) eq p (transform_program transf p). Proof. @@ -622,7 +841,7 @@ Qed. Section LINK_MATCH_PROGRAM. -Context {C F1 V1 F2 V2: Type} {LC: Linker C} {LF1: Linker F1} {LF2: Linker F2} {LV1: Linker V1} {LV2: Linker V2}. +Context {C F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LC: Linker C} {LF1: Linker F1} {LF2: Linker F2} {LV1: Linker V1} {LV2: Linker V2}. Variable match_fundef: C -> F1 -> F2 -> Prop. Variable match_varinfo: V1 -> V2 -> Prop. @@ -728,8 +947,13 @@ Proof. exploit link_match_globdef. eexact H2. eexact H3. eauto. eauto. eauto. intros (tg & TL & MG). rewrite Z, TL. constructor; auto. + rewrite R; simpl; auto. -+ rewrite R; simpl. split; congruence. -Qed. ++ rewrite R; simpl. split; try congruence. + unfold Policy.eqb. + rewrite !andb_true_iff. unfold CompTree.beq. simpl. + admit. + (* unfold Policy.eqb in D1. *) + (* rewrite andb_true_iff in D1. unfold CompTree.beq in D1. simpl in D1. auto. *) +Admitted. End LINK_MATCH_PROGRAM. diff --git a/common/Separation.v b/common/Separation.v index 3c94fbc58c..cb586fa72d 100644 --- a/common/Separation.v +++ b/common/Separation.v @@ -879,12 +879,12 @@ Proof. Qed. Lemma external_call_parallel_rule: - forall (F V: Type) ef (ge: Genv.t F V) cp vargs1 m1 t vres1 m1' m2 j P vargs2, - external_call ef ge cp vargs1 m1 t vres1 m1' -> + forall (F V: Type) {CF: has_comp F} ef (ge: Genv.t F V) cp vargs1 m1 t vres1 m1' m2 j P vargs2, + external_call ef (Genv.to_senv ge) cp vargs1 m1 t vres1 m1' -> m2 |= minjection j m1 ** globalenv_inject ge j ** P -> Val.inject_list j vargs1 vargs2 -> exists j' vres2 m2', - external_call ef ge cp vargs2 m2 t vres2 m2' + external_call ef (Genv.to_senv ge) cp vargs2 m2 t vres2 m2' /\ Val.inject j' vres1 vres2 /\ m2' |= minjection j' m1' ** globalenv_inject ge j' ** P /\ inject_incr j j' diff --git a/common/Smallstep.v b/common/Smallstep.v index b4bb46cd59..c8b537016c 100644 --- a/common/Smallstep.v +++ b/common/Smallstep.v @@ -537,7 +537,7 @@ Record semantics : Type := Semantics_gen { (** The form used in earlier CompCert versions, for backward compatibility. *) -Definition Semantics {state funtype vartype: Type} +Definition Semantics {state funtype vartype: Type} {CF: AST.has_comp funtype} (step: Genv.t funtype vartype -> state -> trace -> state -> Prop) (initial_state: state -> Prop) (final_state: state -> int -> Prop) @@ -584,7 +584,9 @@ Record fsim_properties (L1 L2: semantics) (index: Type) (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ order i' i)) /\ match_states i' s1' s2'; fsim_public_preserved: - forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id; + fsim_comp_preserved: + forall id, Senv.find_comp (symbolenv L2) id = Senv.find_comp (symbolenv L1) id }. Arguments fsim_properties: clear implicits. @@ -625,6 +627,8 @@ Variable L2: semantics. Hypothesis public_preserved: forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. +Hypothesis comp_preserved: + forall id, Senv.find_comp (symbolenv L2) id = Senv.find_comp (symbolenv L1) id. Variable match_states: state L1 -> state L2 -> Prop. @@ -671,6 +675,7 @@ Proof. - intros. destruct H0. subst i. exploit simulation; eauto. intros [s2' [A B]]. exists s1'; exists s2'; intuition auto. - auto. +- auto. Qed. End SIMULATION_STAR_WF. @@ -793,6 +798,8 @@ Hypothesis simulation: /\ Eventually L1 n s1' (fun s1'' => match_states i' s1'' s2'). Hypothesis public_preserved: forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. +Hypothesis comp_preserved: + forall id, Senv.find_comp (symbolenv L2) id = Senv.find_comp (symbolenv L1) id. Lemma forward_simulation_eventually: forward_simulation L1 L2. Proof. @@ -816,6 +823,7 @@ Proof. right; split. apply star_refl. apply lex_ord_right; lia. exact B. - apply public_preserved. +- apply comp_preserved. Qed. End FORWARD_SIMU_EVENTUALLY. @@ -830,6 +838,8 @@ Variable match_states: state L1 -> state L2 -> Prop. Hypothesis public_preserved: forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. +Hypothesis comp_preserved: + forall id, Senv.find_comp (symbolenv L2) id = Senv.find_comp (symbolenv L1) id. Hypothesis initial_states: forall s1, initial_state L1 s1 -> exists s2, initial_state L2 s2 /\ match_states s1 s2. @@ -857,6 +867,7 @@ Proof. - intros. exploit simulation; eauto. intros (n & s2' & A & B). exists n, O, s2'; auto. - auto. +- auto. Qed. End FORWARD_SIMU_EVENTUALLY_PLUS. @@ -902,6 +913,7 @@ Proof. right; split. apply star_refl. apply lex_ord_left; lia. auto. - auto. +- auto. Qed. End FORWARD_SIMU_EVENTUALLY_STAR_WF. @@ -1044,6 +1056,8 @@ Proof. exists s3; auto. - (* symbols *) intros. transitivity (Senv.public_symbol (symbolenv L2) id); eapply fsim_public_preserved; eauto. +- (* comps *) + intros. transitivity (Senv.find_comp (symbolenv L2) id); eapply fsim_comp_preserved; eauto. Qed. (** * Receptiveness and determinacy *) @@ -1159,6 +1173,8 @@ Hypothesis simulation: Hypothesis public_preserved: forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. +Hypothesis comp_preserved: + forall id, Senv.find_comp (symbolenv L2) id = Senv.find_comp (symbolenv L1) id. Lemma star_match_eventually: forall s1 s1', Star L1 s1 E0 s1' -> @@ -1198,6 +1214,8 @@ Variable match_states: state L1 -> state L2 -> Prop. Hypothesis public_preserved: forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. +Hypothesis comp_preserved: + forall id, Senv.find_comp (symbolenv L2) id = Senv.find_comp (symbolenv L1) id. Hypothesis match_initial_states: forall s1, initial_state L1 s1 -> @@ -1235,6 +1253,7 @@ Proof. exploit simulation; eauto. intros (s1'' & s2' & A & B & C). exists s1'', s1'', s2'. auto. - assumption. +- assumption. Qed. End SIMU_DETERM_STAR. @@ -1356,6 +1375,8 @@ Variable L2: semantics. Hypothesis public_preserved: forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. +Hypothesis comp_preserved: + forall id, Senv.find_comp (symbolenv L2) id = Senv.find_comp (symbolenv L1) id. Variable match_states: state L1 -> state L2 -> Prop. @@ -1698,6 +1719,7 @@ Proof. right; intuition. eapply match_traces_preserved with (ge1 := (symbolenv L2)); auto. intros; symmetry; apply (fsim_public_preserved FS). + intros; symmetry; apply (fsim_comp_preserved FS). Qed. Lemma f2b_determinacy_star: @@ -2026,6 +2048,8 @@ Proof. eapply ffs_simulation; eauto. - (* symbols preserved *) simpl. exact (fsim_public_preserved sim). +- (* comp preserved *) + simpl. exact (fsim_comp_preserved sim). Qed. (** Likewise, a backward simulation from a single-event semantics [L1] to a semantics [L2] @@ -2525,9 +2549,13 @@ Context {single_L1: single_events L1} {single_L2: single_events L2} {single_L3: Hypothesis public_preserved: forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. +Hypothesis comp_preserved: + forall id, Senv.find_comp (symbolenv L2) id = Senv.find_comp (symbolenv L1) id. Hypothesis public_preserved': forall id, Senv.public_symbol (symbolenv L3) id = Senv.public_symbol (symbolenv L2) id. +Hypothesis comp_preserved': + forall id, Senv.find_comp (symbolenv L3) id = Senv.find_comp (symbolenv L2) id. Variable strong_equivalence1: state L1 -> state L3 -> Prop. Variable strong_equivalence2: state L2 -> state L3 -> Prop. diff --git a/driver/Compiler.v b/driver/Compiler.v index cb451a5189..a8f22b82f2 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -422,6 +422,7 @@ Remark forward_simulation_identity: Proof. intros. apply forward_simulation_step with (fun s1 s2 => s2 = s1); intros. - auto. +- auto. - exists s1; auto. - subst s2; auto. - subst s2. exists s1'; auto. diff --git a/driver/Interp.ml b/driver/Interp.ml index dc21b9c6ac..128cb07423 100644 --- a/driver/Interp.ml +++ b/driver/Interp.ml @@ -681,7 +681,8 @@ let execute prog = | Some prog1 -> let wprog = world_program prog1 in let wge = globalenv wprog in - match Genv.init_mem (Ctypes.has_comp_fundef has_comp_function) (program_of_program wprog) with + match Genv.init_mem (Ctypes.has_comp_fundef has_comp_function) + (program_of_program has_comp_function wprog) with | None -> fprintf p "ERROR: World memory state undefined@."; exit 126 | Some wm -> @@ -764,7 +765,7 @@ let execute_asm prog = pp_set_max_indent p 30; pp_set_max_boxes p 10; let wprog = world_program_asm prog in - let wge = Genv.globalenv wprog in + let wge = Genv.globalenv (AST.has_comp_fundef Asm.has_comp_function) wprog in match Genv.init_mem (AST.has_comp_fundef Asm.has_comp_function) wprog with | None -> fprintf p "ERROR: World memory state undefined@."; exit 126 diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index a8cd941bfc..12c432fa5b 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -798,4 +798,5 @@ let expand_fundef id = function Errors.OK (External ef) let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p + AST.transform_partial_program2 (AST.has_comp_fundef Asm.has_comp_function) (AST.has_comp_fundef Asm.has_comp_function) + expand_fundef (fun id v -> Errors.OK v) p diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index d606946c61..9fdf62cf36 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -933,6 +933,15 @@ Definition transf_function (f: Mach.function) : res Asm.function := Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := transf_partial_fundef transf_function f. +#[global] Instance comp_transf_function: has_comp_transl_partial transf_function. +Proof. + unfold transf_function, transl_function. + intros f ? H; monadInv H; trivial. + destruct transl_code'; simpl in *; try easy. + inv EQ. destruct zlt; try easy. + now inv EQ0. +Qed. + Definition transf_program (p: Mach.program) : res Asm.program := transform_partial_program transf_fundef p. diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 978ac78f1a..ba620e9ef7 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -21,16 +21,6 @@ Require Import Asmgen Asmgenproof0 Asmgenproof1. Definition match_prog (p: Mach.program) (tp: Asm.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. -#[global] -Instance comp_transf_function: has_comp_transl_partial transf_function. -Proof. - unfold transf_function, transl_function. - intros f ? H; monadInv H; trivial. - destruct transl_code'; simpl in *; try easy. - inv EQ. destruct zlt; try easy. - now inv EQ0. -Qed. - Lemma transf_program_match: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. @@ -1664,6 +1654,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_star with (measure := measure). apply senv_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. exact step_simulation. diff --git a/security/Backtranslation.v b/security/Backtranslation.v index b7328b95c5..d12e19a966 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -558,7 +558,7 @@ Section GEN. Program Definition gen_program tr (a_p: Asm.program): Clight.program := let a_ge := Genv.globalenv a_p in - @Build_program _ + @Build_program _ _ (gen_prog_defs a_ge tr a_p.(AST.prog_defs)) (AST.prog_public a_p) (AST.prog_main a_p) @@ -566,7 +566,9 @@ Section GEN. [] (@PTree.empty composite) _ - _. + _ _. + Next Obligation. + Admitted. Next Obligation. Admitted. diff --git a/security/BtBasics.v b/security/BtBasics.v index 59af340722..63e140cfbb 100644 --- a/security/BtBasics.v +++ b/security/BtBasics.v @@ -7,7 +7,7 @@ Require Import Split. Section GENV. - Context {F: Type}. + Context {F: Type} {CF: has_comp F}. Context {V: Type}. Lemma genv_def_to_some_ident @@ -44,55 +44,60 @@ Section GENV. 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. *) + Lemma genv_def_to_ident + (p: AST.program F V) + (NR: list_norepet (prog_defs_names p)) + (AGR: agr_comps p.(prog_pol) (rev (prog_defs 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 AGR DEF. + remember (Genv.empty_genv F V prog_pol_pub) 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 prog_pol_pub b gd DEF AGR 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 prog_pol_pub). + 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_pol_pub) rev_prog_defs) as ge. + assert (AGR': agr_comps prog_pol (rev rev_prog_defs)) by admit. + assert (GE: ge = Genv.globalenv (AST.mkprogram (rev rev_prog_defs) prog_public id0 prog_pol prog_pol_pub AGR')). + { 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. + assert (AGR'': agr_comps prog_pol rev_prog_defs) by admit. + specialize (IHrev_prog_defs _ _ GD AGR'' 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. + } + Admitted. End GENV. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 6aae4974f3..076deecff1 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -14,40 +14,40 @@ Require Import BtBasics. -(* Section AUX. *) - -(* Lemma val_load_result_idem chunk v: *) -(* Val.load_result chunk (Val.load_result chunk v) = Val.load_result chunk v. *) -(* Proof. *) -(* destruct chunk, v; ss. *) -(* all: try (rewrite Int.sign_ext_idem; auto; lia). *) -(* all: try (rewrite Int.zero_ext_idem; auto; lia). *) -(* all: des_ifs. *) -(* Qed. *) - -(* Lemma extcall_cases *) -(* ef ge m args *) -(* (ECC: external_call_conds ef ge m args) *) -(* tr rv m' *) -(* (ECALL: external_call ef ge args m tr rv m') *) -(* : *) -(* (external_call_unknowns ef ge m args) \/ *) -(* (external_call_known_observables ef ge m args tr rv m') \/ *) -(* (external_call_known_silents ef ge m args tr rv m'). *) -(* Proof. *) -(* destruct ef; ss; auto. des_ifs; auto. des_ifs; auto. *) -(* - destruct tr; ss; eauto. right; left. esplits; eauto. ss. *) -(* - destruct tr; ss; eauto. right; left. esplits; eauto. ss. *) -(* - inv ECALL. right; right. esplits; eauto. econs; eauto. *) -(* - inv ECALL. right; right. esplits; eauto. econs; eauto. *) -(* right; right. esplits; eauto. econs; eauto. *) -(* - inv ECALL. right; right. esplits; eauto. econs; eauto. *) -(* - destruct tr; ss; eauto. right; left. esplits; eauto. ss. *) -(* - destruct tr; ss; eauto. right; left. esplits; eauto. ss. *) -(* - inv ECALL. right; right. esplits; eauto. econs; eauto. *) -(* Qed. *) +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. *) +End AUX. @@ -82,47 +82,47 @@ 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 -> (ident * bundle_event) -> state -> Prop) (ge : genv) : *) - (* state -> bundle_trace -> state -> Prop := *) - (* istar_refl : forall s : state, istar step ge s nil s *) - (* | istar_step : forall (s1 : state) ev (s2 : state) (t2 : bundle_trace) (s3 : state) (t : bundle_trace), *) - (* step ge s1 ev s2 -> istar step ge s2 t2 s3 -> t = ev :: t2 -> istar step ge s1 t s3. *) - - (* Lemma istar_trans *) - (* genv state (step: genv -> state -> _ -> state -> Prop) ge *) - (* s1 t1 s2 *) - (* (ISTAR1: istar step ge s1 t1 s2) *) - (* t2 s3 *) - (* (ISTAR2: istar step ge s2 t2 s3) *) - (* t *) - (* (TR: t = t1 ++ t2) *) - (* : *) - (* istar step ge s1 t s3. *) - (* Proof. *) - (* revert_until ISTAR1. induction ISTAR1; intros. *) - (* { simpl in *. subst; auto. } *) - (* subst. rewrite <- app_comm_cons. econstructor 2. eapply H. *) - (* { eapply IHISTAR1. eapply ISTAR2. eauto. } *) - (* auto. *) - (* Qed. *) + Lemma unbundle_trace_cons + be btr + : + unbundle_trace (be :: btr) = (unbundle be) ++ (unbundle_trace btr). + Proof. simpl. auto. Qed. + + Lemma unbundle_trace_app + btr1 btr2 + : + unbundle_trace (btr1 ++ btr2) = (unbundle_trace btr1) ++ (unbundle_trace btr2). + Proof. + revert btr2. induction btr1; intros. + { simpl. auto. } + rewrite <- app_comm_cons. rewrite ! unbundle_trace_cons. rewrite <- app_assoc. f_equal. + eauto. + Qed. + + Inductive istar {genv state : Type} + (step : genv -> state -> (ident * bundle_event) -> state -> Prop) (ge : genv) : + state -> bundle_trace -> state -> Prop := + istar_refl : forall s : state, istar step ge s nil s + | istar_step : forall (s1 : state) ev (s2 : state) (t2 : bundle_trace) (s3 : state) (t : bundle_trace), + step ge s1 ev s2 -> istar step ge s2 t2 s3 -> t = ev :: t2 -> istar step ge s1 t s3. + + Lemma istar_trans + genv state (step: genv -> state -> _ -> state -> Prop) ge + s1 t1 s2 + (ISTAR1: istar step ge s1 t1 s2) + t2 s3 + (ISTAR2: istar step ge s2 t2 s3) + t + (TR: t = t1 ++ t2) + : + istar step ge s1 t s3. + Proof. + revert_until ISTAR1. induction ISTAR1; intros. + { simpl in *. subst; auto. } + subst. rewrite <- app_comm_cons. econstructor 2. eapply H. + { eapply IHISTAR1. eapply ISTAR2. eauto. } + auto. + Qed. End BUNDLE. @@ -141,18 +141,18 @@ Section EVENT. Definition typ_to_eventvals (ty: list typ): list eventval := map typ_to_eventval ty. - (* Inductive call_trace_cross {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> block -> list val -> list typ -> trace -> ident -> list eventval -> Prop := *) - (* | call_trace_cross_cross : forall (cp cp' : compartment) (b : block) (vargs : list val) (vl : list eventval) (ty : list typ) (i : ident) tr, *) - (* Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> *) - (* Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> *) - (* (tr = Event_call cp cp' i vl :: nil) -> *) - (* call_trace_cross ge cp cp' b vargs ty tr i vl. *) + Inductive 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 cp cp' = Genv.CrossCompartmentCall -> + Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> + (tr = Event_call cp cp' i vl :: nil) -> + call_trace_cross ge cp cp' b vargs ty tr i vl. - (* Inductive return_trace_cross {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> eventval -> Prop := *) - (* | return_trace_cross_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype) tr, *) - (* Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> *) - (* (tr = Event_return cp cp' res :: nil) -> *) - (* return_trace_cross ge cp cp' v ty tr res. *) + 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 cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> + (tr = Event_return cp cp' res :: nil) -> + return_trace_cross ge cp cp' v ty tr res. (* external call *) Definition senv_invert_symbol_total (ge: Senv.t) (b: block) : ident := @@ -173,123 +173,125 @@ Section EVENT. Definition vals_to_eventvals (ge: Senv.t) (vs: list val): list eventval := map (val_to_eventval ge) vs. - (* Lemma eventval_match_val_to_eventval *) - (* ge ev ty v *) - (* (EVM: eventval_match ge ev ty v) *) - (* : *) - (* val_to_eventval ge v = ev. *) - (* Proof. *) - (* inv EVM; simpl; auto. *) - (* unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. *) - (* Qed. *) - - (* Lemma eventval_list_match_vals_to_eventvals *) - (* ge evs tys vs *) - (* (EVM: eventval_list_match ge evs tys vs) *) - (* : *) - (* vals_to_eventvals ge vs = evs. *) - (* Proof. *) - (* induction EVM; simpl; auto. *) - (* rewrite IHEVM. f_equal. eapply eventval_match_val_to_eventval; eauto. *) - (* Qed. *) + Lemma eventval_match_val_to_eventval + ge ev ty v + (EVM: eventval_match ge ev ty v) + : + val_to_eventval ge v = ev. + Proof. + inv EVM; simpl; auto. + unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. + Qed. + + Lemma eventval_list_match_vals_to_eventvals + ge evs tys vs + (EVM: eventval_list_match ge evs tys vs) + : + vals_to_eventvals ge vs = evs. + Proof. + induction EVM; simpl; auto. + rewrite IHEVM. f_equal. eapply eventval_match_val_to_eventval; eauto. + Qed. End EVENT. -(* Section IR. *) - -(* Variant ir_cont_type : Type := | ir_cont: block -> ir_cont_type. *) -(* Definition ir_conts := list ir_cont_type. *) - -(* Definition crossing_comp {F V} (ge: Genv.t F V) (cp cp': compartment) := *) -(* Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall. *) - -(* Definition ir_state := option (block * mem * ir_conts)%type. *) - -(* Variant ir_step (ge: Asm.genv) : ir_state -> (ident * bundle_event) -> ir_state -> Prop := *) -(* | ir_step_cross_call_internal *) -(* cur m1 ik *) -(* tr id evargs sg *) -(* cp cp' vargs *) -(* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) -(* b f_next *) -(* (FINDB: Genv.find_symbol ge id = Some b) *) -(* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.Internal f_next)) *) -(* (CP': cp' = comp_of f_next) *) -(* (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) *) -(* (NPTR: crossing_comp ge cp cp' -> Forall not_ptr vargs) *) -(* (SIG: sg = Asm.fn_sig f_next) *) -(* (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) *) -(* d m2 *) -(* (DELTA: mem_delta_apply_wf ge cp d (Some m1) = Some m2) *) -(* (PUB: public_first_order ge m2) *) -(* id_cur *) -(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) -(* : *) -(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call tr id evargs sg d) (Some (b, m2, (ir_cont cur) :: ik)) *) -(* | ir_step_cross_return_internal *) -(* cur m1 next ik ik_tl *) -(* tr evretv *) -(* cp_cur cp_next vretv *) -(* (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) -(* sg fd_cur *) -(* (FINDFD: Genv.find_funct_ptr ge cur = Some (fd_cur)) *) -(* (* in Asm, stack has the sig *) *) -(* (SIG: sg = Asm.funsig fd_cur) *) -(* (NPTR: crossing_comp ge cp_next cp_cur -> not_ptr vretv) *) -(* (NEXTCP: cp_next = Genv.find_comp ge (Vptr next Ptrofs.zero)) *) -(* f_next *) -(* (INTERNAL: Genv.find_funct_ptr ge next = Some (AST.Internal f_next)) *) -(* (* internal return: memory changes in Clight-side, so need inj-relation *) *) -(* (TR: return_trace_cross ge cp_next cp_cur vretv (sig_res sg) tr evretv) *) -(* (CONT: ik = (ir_cont next) :: ik_tl) *) -(* d m2 *) -(* (DELTA: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m2) *) -(* (PUB: public_first_order ge m2) *) -(* id_cur *) -(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) -(* : *) -(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_return tr evretv d) (Some (next, m2, ik_tl)) *) -(* | ir_step_intra_call_external *) -(* cur m1 m2 ik *) -(* tr id evargs sg *) -(* cp_cur *) -(* (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) -(* b_ext ef cp_ext *) -(* (FINDB: Genv.find_symbol ge id = Some b_ext) *) -(* (FINDF: Genv.find_funct ge (Vptr b_ext Ptrofs.zero) = Some (AST.External ef)) *) -(* (EXTCP: cp_ext = comp_of ef) *) -(* (INTRA: Genv.type_of_call ge cp_cur cp_ext = Genv.InternalCall) *) -(* (SIG: sg = ef_sig ef) *) -(* d m1' *) -(* (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') *) -(* vargs vretv *) -(* (EC: external_call ef ge vargs m1' tr vretv m2) *) -(* (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ *) -(* (external_call_known_observables ef ge m1' vargs tr vretv m2 /\ d = [])) *) -(* (ARGS: evargs = vals_to_eventvals ge vargs) *) -(* id_cur *) -(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) -(* : *) -(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call tr id evargs sg d) (Some (cur, m2, ik)) *) -(* | ir_step_builtin *) -(* cur m1 m2 ik *) -(* tr ef evargs *) -(* cp_cur *) -(* (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) -(* (ALLOWED: comp_of ef = cp_cur) *) -(* d m1' *) -(* (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') *) -(* vargs vretv *) -(* (EC: external_call ef ge vargs m1' tr vretv m2) *) -(* (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ *) -(* (external_call_known_observables ef ge m1' vargs tr vretv m2 /\ d = [])) *) -(* (ARGS: evargs = vals_to_eventvals ge vargs) *) -(* id_cur *) -(* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) -(* : *) -(* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) *) +Section IR. + + Variant ir_cont_type : Type := | ir_cont: block -> ir_cont_type. + Definition ir_conts := list ir_cont_type. + + Definition crossing_comp {F V} (ge: Genv.t F V) (cp cp': compartment) := + Genv.type_of_call cp cp' = Genv.CrossCompartmentCall. + + Definition ir_state := option (block * mem * ir_conts)%type. + + Instance has_comp_fundef: has_comp Asm.fundef. + Proof. + eapply has_comp_fundef. eapply has_comp_function. + Qed. + + Variant ir_step (ge: Asm.genv) : ir_state -> (ident * bundle_event) -> ir_state -> Prop := + | ir_step_cross_call_internal + cur m1 ik + tr id evargs sg + cp cp' vargs + (CURCP: cp = Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) + b f_next + (FINDB: Genv.find_symbol ge id = Some b) + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.Internal f_next)) + (CP': cp' = comp_of f_next) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr vargs) + (SIG: sg = Asm.fn_sig f_next) + (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) + d m2 + (DELTA: mem_delta_apply_wf ge cp d (Some m1) = Some m2) + (* (PUB: public_first_order ge m2) *) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call tr id evargs sg d) (Some (b, m2, (ir_cont cur) :: ik)) + | ir_step_cross_return_internal + cur m1 next ik ik_tl + tr evretv + cp_cur cp_next vretv + (CURCP: cp_cur = Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) + sg fd_cur + (FINDFD: Genv.find_funct_ptr ge cur = Some (fd_cur)) + (* in Asm, stack has the sig *) + (* (SIG: sg = Asm.funsig fd_cur) *) + (NPTR: crossing_comp ge cp_next cp_cur -> not_ptr vretv) + (NEXTCP: cp_next = Genv.find_comp_in_genv ge (Vptr next Ptrofs.zero)) + f_next + (INTERNAL: Genv.find_funct_ptr ge next = Some (AST.Internal f_next)) + (* internal return: memory changes in Clight-side, so need inj-relation *) + (TR: return_trace_cross ge cp_next cp_cur vretv (sig_res sg) tr evretv) + (CONT: ik = (ir_cont next) :: ik_tl) + d m2 + (DELTA: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m2) + (* (PUB: public_first_order ge m2) *) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_return tr evretv d) (Some (next, m2, ik_tl)) + | ir_step_intra_call_external + cur m1 m2 ik + tr id evargs sg + cp_cur + (CURCP: cp_cur = Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) + b_ext ef + (FINDB: Genv.find_symbol ge id = Some b_ext) + (FINDF: Genv.find_funct ge (Vptr b_ext Ptrofs.zero) = Some (AST.External ef)) + (SIG: sg = ef_sig ef) + d m1' + (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') + vargs vretv + (EC: external_call ef ge cp_cur vargs m1' tr vretv m2) + (* (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ *) + (* (external_call_known_observables ef ge m1' vargs tr vretv m2 /\ d = [])) *) + (ARGS: evargs = vals_to_eventvals ge vargs) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call tr id evargs sg d) (Some (cur, m2, ik)) + | ir_step_builtin + cur m1 m2 ik + tr ef evargs + cp_cur + (CURCP: cp_cur = Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) + d m1' + (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') + vargs vretv + (EC: external_call ef ge cp_cur vargs m1' tr vretv m2) + (* (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ *) + (* (external_call_known_observables ef ge m1' vargs tr vretv m2 /\ d = [])) *) + (ARGS: evargs = vals_to_eventvals ge vargs) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) (* | ir_step_cross_call_external1 *) (* (* early cut at call *) *) (* cur m1 ik *) @@ -366,59 +368,61 @@ End EVENT. (* (IDCUR: Genv.invert_symbol ge cur = Some id_cur) *) (* : *) (* ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg d) (Some (cur, m2, ik)). *) - -(* End IR. *) + . +End IR. -(* Section AUX. *) +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). *) + Definition wf_ge {F V} {CF: has_comp F} + (ge: Genv.t F V) := exists (p: AST.program F V), (list_norepet (prog_defs_names p)) /\ (ge = Genv.globalenv p) /\ + (agr_comps p.(prog_pol) (rev (prog_defs 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 wf_ge_block_to_id + F V {CF: has_comp F} (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 & C). 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. *) + Lemma val_is_ptr_or_not + (v: val) + : + (forall b o, v <> Vptr b o) \/ (exists b o, v = Vptr b o). + Proof. destruct v; eauto. all: left; intros; intros F; inv F. Qed. -(* End AUX. *) +End AUX. -(* Section MEASURE. *) +Section MEASURE. -(* Inductive star_measure {genv state : Type} (step : genv -> state -> trace -> state -> Prop) (ge : genv) : nat -> state -> trace -> state -> Prop := *) -(* star_measure_refl : forall s : state, star_measure step ge O s E0 s *) -(* | star_step : forall n (s1 : state) (t1 : trace) (s2 : state) (t2 : trace) (s3 : state) (t : trace), *) -(* step ge s1 t1 s2 -> star_measure step ge n s2 t2 s3 -> t = t1 ** t2 -> star_measure step ge (S n) s1 t s3. *) + Inductive star_measure {genv state : Type} (step : genv -> state -> trace -> state -> Prop) (ge : genv) : nat -> state -> trace -> state -> Prop := + star_measure_refl : forall s : state, star_measure step ge O s E0 s + | star_step : forall n (s1 : state) (t1 : trace) (s2 : state) (t2 : trace) (s3 : state) (t : trace), + step ge s1 t1 s2 -> star_measure step ge n s2 t2 s3 -> t = t1 ** t2 -> star_measure step ge (S n) s1 t s3. -(* Lemma measure_star *) -(* genv state *) -(* (step : genv -> state -> trace -> state -> Prop) *) -(* (ge : genv) *) -(* s0 tr s1 *) -(* (STAR: star step ge s0 tr s1) *) -(* : *) -(* exists n, star_measure step ge n s0 tr s1. *) -(* Proof. *) -(* induction STAR. *) -(* { exists O. constructor 1. } *) -(* destruct IHSTAR as (n & NEXT). exists (S n). econstructor 2. eapply H. eapply NEXT. auto. *) -(* Qed. *) + Lemma measure_star + genv state + (step : genv -> state -> trace -> state -> Prop) + (ge : genv) + s0 tr s1 + (STAR: star step ge s0 tr s1) + : + exists n, star_measure step ge n s0 tr s1. + Proof. + induction STAR. + { exists O. constructor 1. } + destruct IHSTAR as (n & NEXT). exists (S n). econstructor 2. eapply H. eapply NEXT. auto. + Qed. -(* End MEASURE. *) +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_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 *) @@ -429,248 +433,248 @@ End EVENT. (* End CONDS. *) -(* Section FROMASM. *) - -(* Import ListNotations. *) - -(* Ltac Simplif_all := *) -(* ((rewrite Asmgenproof0.nextinstr_inv in * by eauto with asmgen) *) -(* || (rewrite Asmgenproof0.nextinstr_inv1 in * by eauto with asmgen) *) -(* || (rewrite Pregmap.gss in *) -(* || (rewrite Asmgenproof0.nextinstr_pc in *) -(* || (rewrite Pregmap.gso in * by eauto with asmgen)); auto with asmgen. *) - -(* Ltac Simpl_all := repeat Simplif_all. *) - -(* Ltac simpl_before_exists := *) -(* repeat (Simpl_all; *) -(* match goal with *) -(* (* Goto *) *) -(* | _: goto_label _ _ ?rs _ = Next _ _ |- _ => *) -(* unfold goto_label in *; destruct label_pos; try congruence *) -(* | _: eval_branch _ _ ?rs _ _ = Next _ _ |- _ => *) -(* unfold eval_branch in *; simpl in * *) -(* | _: exec_load _ _ _ _ _ _ _ _ _ = Next _ _ |- _ => *) -(* unfold exec_load in *; simpl in * *) -(* | _: exec_store _ _ _ _ _ _ _ _ = Next _ _ |- _ => *) -(* unfold exec_store in *; simpl in * *) -(* | _: context [Val.cmp_bool] |- _ => *) -(* unfold Val.cmp_bool in *; simpl in * *) -(* | _: context [Val.cmpl_bool] |- _ => *) -(* unfold Val.cmpl_bool in *; simpl in * *) -(* | _: context [eval_offset _ ?ofs] |- _ => *) -(* destruct ofs; simpl in * *) - -(* | |- context [Ptrofs.repr 0] => replace (Ptrofs.repr 0) with Ptrofs.zero by reflexivity; auto *) -(* | H: context [Ptrofs.repr 0] |- _ => replace (Ptrofs.repr 0) with Ptrofs.zero in H by reflexivity; auto *) -(* | |- context [Ptrofs.add _ Ptrofs.zero] => rewrite Ptrofs.add_zero; auto *) -(* | H: context [Ptrofs.add _ Ptrofs.zero] |- _ => rewrite Ptrofs.add_zero in H; simpl in *; try congruence *) -(* | |- context [Ptrofs.sub _ Ptrofs.zero] => rewrite Ptrofs.sub_zero_l; auto *) -(* | H: context [Ptrofs.sub _ Ptrofs.zero] |- _ => rewrite Ptrofs.sub_zero_l in H; simpl in *; try congruence *) - -(* (* hypothesis manipulation *) *) -(* | _: context [match ?rs1 ?i with | _ => _ end] |- _ => *) -(* destruct (rs1 i) eqn:?; try congruence; simpl in *; eauto *) - -(* | _: context [Val.offset_ptr (?rs1 ?i) _] |- _ => *) -(* destruct (rs1 i) eqn:?; try congruence; simpl in *; eauto *) - -(* | H: Next _ _ = Next _ _ |- _ => inv H *) -(* | H: Some _ = Some _ |- _ => inv H *) -(* | H: Some _ = None |- _ => inv H *) -(* | H: None = Some _ |- _ => inv H *) -(* | H: Stuck = Next _ _ |- _ => inv H *) -(* | H: Next _ _ = Stuck |- _ => inv H *) -(* | H: negb _ = true |- _ => apply negb_true_iff in H *) -(* | H: negb _ = false |- _ => apply negb_false_iff in H *) -(* | H: Int.eq ?x ?x = false |- _ => rewrite Int.eq_true in H *) -(* | H: Int64.eq ?x ?x = false |- _ => rewrite Int64.eq_true in H *) -(* | H: false = true |- _ => congruence *) -(* | H: true = false |- _ => congruence *) -(* | H: ?x = false, H': ?x = true |- _ => congruence *) -(* | H: match ?x with | _ => _ end = Next _ _ |- _ => *) -(* let eq := fresh "eq" in *) -(* destruct x eqn:eq; simpl in *; try congruence *) -(* | _: context [?rs1 ### ?rs] |- context [?rs3 ### ?rs] => *) -(* let i := fresh "i" in destruct rs as [| i]; simpl in * *) -(* | _: context [?rs1 ## ?rs] |- context [?rs3 ## ?rs] => *) -(* let i := fresh "i" in destruct rs as [| i]; simpl in * *) -(* | H: ?x = _ |- context [if ?x then _ else _] => *) -(* rewrite H; simpl *) -(* | H: ?x = _ |- context [match ?x with | _ => _ end] => *) -(* rewrite H; simpl *) -(* | |- context [(if ?x then _ else _) = Next _ _] => *) -(* let eq := fresh "eq" in destruct x eqn:eq; simpl in * *) -(* | |- context [(match ?x with | _ => _ end) = Next _ _] => *) -(* let eq := fresh "eq" in destruct x eqn:eq; simpl in * *) - -(* end); *) -(* simpl. *) - -(* Lemma public_not_freeable_free_inj_none *) -(* ge m *) -(* (NFREE: public_not_freeable ge m) *) -(* b lo hi cp m' *) -(* (FREE: Mem.free m b lo hi cp = Some m') *) -(* (BOUND: (lo < hi)%Z) *) -(* : *) -(* meminj_public ge b = None. *) -(* Proof. *) -(* destruct (meminj_public ge b) eqn:INJPUB; auto. exfalso. *) -(* eapply Mem.free_range_perm in FREE. unfold Mem.range_perm in FREE. *) -(* eapply NFREE. erewrite INJPUB. congruence. eapply Mem.perm_cur_max; apply FREE. *) -(* instantiate (1:=lo). lia. *) -(* Qed. *) +Section FROMASM. + + Import ListNotations. + + Ltac Simplif_all := + ((rewrite Asmgenproof0.nextinstr_inv in * by eauto with asmgen) + || (rewrite Asmgenproof0.nextinstr_inv1 in * by eauto with asmgen) + || (rewrite Pregmap.gss in *) + || (rewrite Asmgenproof0.nextinstr_pc in *) + || (rewrite Pregmap.gso in * by eauto with asmgen)); auto with asmgen. + + Ltac Simpl_all := repeat Simplif_all. + + Ltac simpl_before_exists := + repeat (Simpl_all; + match goal with + (* Goto *) + | _: goto_label _ _ ?rs _ = Next _ _ |- _ => + unfold goto_label in *; destruct label_pos; try congruence + | _: eval_branch _ _ ?rs _ _ = Next _ _ |- _ => + unfold eval_branch in *; simpl in * + | _: exec_load _ _ _ _ _ _ _ _ _ = Next _ _ |- _ => + unfold exec_load in *; simpl in * + | _: exec_store _ _ _ _ _ _ _ _ = Next _ _ |- _ => + unfold exec_store in *; simpl in * + | _: context [Val.cmp_bool] |- _ => + unfold Val.cmp_bool in *; simpl in * + | _: context [Val.cmpl_bool] |- _ => + unfold Val.cmpl_bool in *; simpl in * + | _: context [eval_offset _ ?ofs] |- _ => + destruct ofs; simpl in * + + | |- context [Ptrofs.repr 0] => replace (Ptrofs.repr 0) with Ptrofs.zero by reflexivity; auto + | H: context [Ptrofs.repr 0] |- _ => replace (Ptrofs.repr 0) with Ptrofs.zero in H by reflexivity; auto + | |- context [Ptrofs.add _ Ptrofs.zero] => rewrite Ptrofs.add_zero; auto + | H: context [Ptrofs.add _ Ptrofs.zero] |- _ => rewrite Ptrofs.add_zero in H; simpl in *; try congruence + | |- context [Ptrofs.sub _ Ptrofs.zero] => rewrite Ptrofs.sub_zero_l; auto + | H: context [Ptrofs.sub _ Ptrofs.zero] |- _ => rewrite Ptrofs.sub_zero_l in H; simpl in *; try congruence + + (* hypothesis manipulation *) + | _: context [match ?rs1 ?i with | _ => _ end] |- _ => + destruct (rs1 i) eqn:?; try congruence; simpl in *; eauto + + | _: context [Val.offset_ptr (?rs1 ?i) _] |- _ => + destruct (rs1 i) eqn:?; try congruence; simpl in *; eauto + + | H: Next _ _ = Next _ _ |- _ => inv H + | H: Some _ = Some _ |- _ => inv H + | H: Some _ = None |- _ => inv H + | H: None = Some _ |- _ => inv H + | H: Stuck = Next _ _ |- _ => inv H + | H: Next _ _ = Stuck |- _ => inv H + | H: negb _ = true |- _ => apply negb_true_iff in H + | H: negb _ = false |- _ => apply negb_false_iff in H + | H: Int.eq ?x ?x = false |- _ => rewrite Int.eq_true in H + | H: Int64.eq ?x ?x = false |- _ => rewrite Int64.eq_true in H + | H: false = true |- _ => congruence + | H: true = false |- _ => congruence + | H: ?x = false, H': ?x = true |- _ => congruence + | H: match ?x with | _ => _ end = Next _ _ |- _ => + let eq := fresh "eq" in + destruct x eqn:eq; simpl in *; try congruence + | _: context [?rs1 ### ?rs] |- context [?rs3 ### ?rs] => + let i := fresh "i" in destruct rs as [| i]; simpl in * + | _: context [?rs1 ## ?rs] |- context [?rs3 ## ?rs] => + let i := fresh "i" in destruct rs as [| i]; simpl in * + | H: ?x = _ |- context [if ?x then _ else _] => + rewrite H; simpl + | H: ?x = _ |- context [match ?x with | _ => _ end] => + rewrite H; simpl + | |- context [(if ?x then _ else _) = Next _ _] => + let eq := fresh "eq" in destruct x eqn:eq; simpl in * + | |- context [(match ?x with | _ => _ end) = Next _ _] => + let eq := fresh "eq" in destruct x eqn:eq; simpl in * + + end); + simpl. + + (* Lemma public_not_freeable_free_inj_none *) + (* ge m *) + (* (NFREE: public_not_freeable ge m) *) + (* b lo hi cp m' *) + (* (FREE: Mem.free m b lo hi cp = Some m') *) + (* (BOUND: (lo < hi)%Z) *) + (* : *) + (* meminj_public ge b = None. *) + (* Proof. *) + (* destruct (meminj_public ge b) eqn:INJPUB; auto. exfalso. *) + (* eapply Mem.free_range_perm in FREE. unfold Mem.range_perm in FREE. *) + (* eapply NFREE. erewrite INJPUB. congruence. eapply Mem.perm_cur_max; apply FREE. *) + (* instantiate (1:=lo). lia. *) + (* Qed. *) -(* Lemma public_not_freeable_store *) -(* ge m1 *) -(* (NFREE: public_not_freeable ge m1) *) -(* chunk b ofs v cp m2 *) -(* (STORE: Mem.store chunk m1 b ofs v cp = Some m2) *) -(* : *) -(* public_not_freeable ge m2. *) -(* Proof. *) -(* unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). *) -(* apply NFREE; eapply Mem.perm_store_2; eauto. *) -(* Qed. *) + (* Lemma public_not_freeable_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_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_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_free *) + (* ge m1 *) + (* (NFREE: public_not_freeable ge m1) *) + (* b lo hi cp m2 *) + (* (STORE: Mem.free m1 b lo hi cp = Some m2) *) + (* : *) + (* public_not_freeable ge m2. *) + (* Proof. *) + (* unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). *) + (* apply NFREE. eapply Mem.perm_free_3; eauto. *) + (* Qed. *) -(* Lemma public_not_freeable_exec_instr *) -(* (ge: genv) f i rs m cp rs' m' *) -(* (NFREE: public_not_freeable ge m) *) -(* (NALLOC: meminj_not_alloc (meminj_public ge) m) *) -(* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) -(* : *) -(* public_not_freeable ge m'. *) -(* Proof. *) -(* destruct i; simpl in EXEC. *) -(* all: try (inv EXEC; eauto). *) -(* all: simpl_before_exists; eauto. *) -(* all: try *) -(* (match goal with *) -(* | H: context [Mem.alloc] |- _ => idtac *) -(* | H: context [Mem.free] |- _ => idtac *) -(* | H: Mem.store ?ch ?m ?b ?ofs ?v ?cp = _ |- _ => *) -(* eapply public_not_freeable_store; eauto *) -(* end). *) -(* { eapply public_not_freeable_store. eapply public_not_freeable_alloc; eauto. eauto. } *) -(* { eapply public_not_freeable_free; eauto. } *) -(* Qed. *) + (* Lemma public_not_freeable_exec_instr *) + (* (ge: genv) f i rs m cp rs' m' *) + (* (NFREE: public_not_freeable ge m) *) + (* (NALLOC: meminj_not_alloc (meminj_public ge) m) *) + (* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) + (* : *) + (* public_not_freeable ge m'. *) + (* Proof. *) + (* destruct i; simpl in EXEC. *) + (* all: try (inv EXEC; eauto). *) + (* all: simpl_before_exists; eauto. *) + (* all: try *) + (* (match goal with *) + (* | H: context [Mem.alloc] |- _ => idtac *) + (* | H: context [Mem.free] |- _ => idtac *) + (* | H: Mem.store ?ch ?m ?b ?ofs ?v ?cp = _ |- _ => *) + (* eapply public_not_freeable_store; eauto *) + (* end). *) + (* { eapply public_not_freeable_store. eapply public_not_freeable_alloc; eauto. eauto. } *) + (* { eapply public_not_freeable_free; eauto. } *) + (* Qed. *) -(* Lemma public_rev_perm_store *) -(* ge m1 m' *) -(* (PRP: public_rev_perm ge m1 m') *) -(* chunk b ofs v cp m2 *) -(* (STORE: Mem.store chunk m1 b ofs v cp = Some m2) *) -(* : *) -(* public_rev_perm ge m2 m'. *) -(* Proof. *) -(* unfold public_rev_perm in *; intros. specialize (PRP b0). des_ifs. intros. *) -(* exploit PRP; eauto. intros. eapply Mem.perm_store_1; eauto. *) -(* Qed. *) + (* Lemma public_rev_perm_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_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_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_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 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 *) @@ -759,93 +763,93 @@ End EVENT. (* } *) (* Qed. *) -(* End FROMASM. *) +End FROMASM. -(* Section INVS. *) +Section INVS. -(* Import ListNotations. *) + Import ListNotations. -(* Definition wf_stackframe (ge: Asm.genv) (fr: stackframe) := *) -(* match fr with *) -(* | Stackframe b _ _ _ _ => match Genv.find_funct_ptr ge b with *) -(* | Some (Internal f) => True *) -(* | _ => False *) -(* end *) -(* end. *) -(* Definition wf_stack (ge: Asm.genv) (sk: stack) := Forall (wf_stackframe ge) sk. *) - -(* Definition wf_regset (ge: Asm.genv) (rs: regset) := *) -(* match rs PC with *) -(* | Vptr b _ => match Genv.find_funct_ptr ge b with *) -(* | Some (Internal f) => True *) -(* | _ => False *) -(* end *) -(* | _ => False *) -(* end. *) - -(* Definition wf_asm (ge: Asm.genv) (ast: Asm.state) := *) -(* match ast with *) -(* | State sk rs m => (wf_stack ge sk) /\ (wf_regset ge rs) *) -(* | _ => False *) -(* end. *) - - -(* Definition wf_ir_cur (ge: Asm.genv) (cur: block) := *) -(* match Genv.find_funct_ptr ge cur with *) -(* | Some (Internal f) => True *) -(* | _ => False *) -(* end. *) - -(* Definition wf_ir_cont (ge: Asm.genv) (ik: ir_cont_type) := *) -(* match ik with *) -(* | ir_cont b => match Genv.find_funct_ptr ge b with *) -(* | Some (Internal f) => True *) -(* | _ => False *) -(* end *) -(* end. *) -(* Definition wf_ir_conts (ge: Asm.genv) (ik: ir_conts) := Forall (wf_ir_cont ge) ik. *) - - -(* Definition match_cur_stack_sig (cur: block) (ge: Asm.genv) (sk: stack) := *) -(* match Genv.find_funct_ptr ge cur with *) -(* | Some fd => Asm.funsig fd = sig_of_call sk *) -(* | _ => False *) -(* end. *) - -(* Definition match_cur_regset (cur: block) (ge: Asm.genv) (rs: regset) := *) -(* Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs PC). *) - -(* Inductive match_stack (ge: Asm.genv): ir_conts -> stack -> Prop := *) -(* | match_stack_nil *) -(* : *) -(* match_stack ge [] [] *) -(* | match_stack_cons *) -(* next ik_tl *) -(* b cp sg v ofs sk_tl *) -(* (COMP: Genv.find_comp ge (Vptr next Ptrofs.zero) = Genv.find_comp ge (Vptr b Ptrofs.zero)) *) -(* (SIG: match_cur_stack_sig next ge sk_tl) *) -(* (TL: match_stack ge ik_tl sk_tl) *) -(* : *) -(* match_stack ge (ir_cont next :: ik_tl) (Stackframe b cp sg v ofs :: sk_tl). *) - -(* Definition match_mem (ge: Senv.t) cp (k: meminj) (d: mem_delta) (m_a0 m_i m_a1: mem): Prop := *) -(* let j := meminj_public ge in *) -(* (Mem.inject k m_a0 m_i) /\ (inject_incr j k) /\ *) -(* (meminj_not_alloc j m_a0) /\ (public_not_freeable ge m_a1) /\ *) -(* (mem_delta_inj_wf cp j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1) /\ *) -(* (public_rev_perm ge m_a1 m_i). *) - -(* Definition match_state (ge: Asm.genv) (k: meminj) (m_a0: mem) (d: mem_delta) (ast: Asm.state) (ist: ir_state): Prop := *) -(* match ast, ist with *) -(* | State sk rs m_a, Some (cur, m_i, ik) => *) -(* (wf_ir_cur ge cur) /\ (wf_ir_conts ge ik) /\ *) -(* (match_cur_stack_sig cur ge sk) /\ (match_cur_regset cur ge rs) /\ *) -(* (match_stack ge ik sk) /\ (match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) -(* | _, _ => False *) -(* end. *) - -(* End INVS. *) + Definition wf_stackframe (ge: Asm.genv) (fr: stackframe) := + match fr with + | Stackframe b _ _ _ => match Genv.find_funct_ptr ge b with + | Some (Internal f) => True + | _ => False + end + end. + Definition wf_stack (ge: Asm.genv) (sk: stack) := Forall (wf_stackframe ge) sk. + + Definition wf_regset (ge: Asm.genv) (rs: regset) := + match rs PC with + | Vptr b _ => match Genv.find_funct_ptr ge b with + | Some (Internal f) => True + | _ => False + end + | _ => False + end. + + Definition wf_asm (ge: Asm.genv) (ast: Asm.state) := + match ast with + | State sk rs m _ => (wf_stack ge sk) /\ (wf_regset ge rs) + | _ => False + end. + + + Definition wf_ir_cur (ge: Asm.genv) (cur: block) := + match Genv.find_funct_ptr ge cur with + | Some (Internal f) => True + | _ => False + end. + + Definition wf_ir_cont (ge: Asm.genv) (ik: ir_cont_type) := + match ik with + | ir_cont b => match Genv.find_funct_ptr ge b with + | Some (Internal f) => True + | _ => False + end + end. + Definition wf_ir_conts (ge: Asm.genv) (ik: ir_conts) := Forall (wf_ir_cont ge) ik. + + + (* Definition match_cur_stack_sig (cur: block) (ge: Asm.genv) (sk: stack) := *) + (* match Genv.find_funct_ptr ge cur with *) + (* | Some fd => Asm.funsig fd = sig_of_call sk *) + (* | _ => False *) + (* end. *) + + Definition match_cur_regset (cur: block) (ge: Asm.genv) (rs: regset) := + Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = Genv.find_comp_in_genv ge (rs PC). + + Inductive match_stack (ge: Asm.genv): ir_conts -> stack -> Prop := + | match_stack_nil + : + match_stack ge [] [] + | match_stack_cons + next ik_tl + b sg v ofs sk_tl + (COMP: Genv.find_comp_in_genv ge (Vptr next Ptrofs.zero) = Genv.find_comp_in_genv ge (Vptr b Ptrofs.zero)) + (* (SIG: match_cur_stack_sig next ge sk_tl) *) + (TL: match_stack ge ik_tl sk_tl) + : + match_stack ge (ir_cont next :: ik_tl) (Stackframe b sg v ofs :: sk_tl). + + Definition match_mem (ge: Senv.t) cp (k: meminj) (d: mem_delta) (m_a0 m_i m_a1: mem): Prop := + let j := meminj_public ge in + (Mem.inject k m_a0 m_i) /\ (inject_incr j k) /\ + (meminj_not_alloc j m_a0) /\ (* (public_not_freeable ge m_a1) /\ *) + (mem_delta_inj_wf cp j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1). + (* (public_rev_perm ge m_a1 m_i). *) + + Definition match_state (ge: Asm.genv) (k: meminj) (m_a0: mem) (d: mem_delta) (ast: Asm.state) (ist: ir_state): Prop := + match ast, ist with + | State sk rs m_a _, Some (cur, m_i, ik) => + (wf_ir_cur ge cur) /\ (wf_ir_conts ge ik) /\ + (* (match_cur_stack_sig cur ge sk) *) (* /\ *)(match_cur_regset cur ge rs) /\ + (match_stack ge ik sk) /\ (match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + | _, _ => False + end. + +End INVS. (* Section PROOF. *) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index 11e96b8511..786b570085 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -6,151 +6,151 @@ Require Import Tactics. Section AUX. -(* Lemma alloc_left_unmapped_winject_keep: *) -(* forall f m1 m2 c lo hi m1' b1, *) -(* winject f m1 m2 -> *) -(* Mem.alloc m1 c lo hi = (m1', b1) -> *) -(* winject f m1' m2. *) -(* Proof. *) -(* intros. set (f' := fun b => if eq_block b b1 then None else f b). *) -(* cut (winject f' m1' m2 /\ inject_incr f f' /\ f' b1 = None /\ (forall b, b <> b1 -> f' b = f b)). *) -(* { clear - f'. intros (INJ & INCR & _ & _). unfold inject_incr in INCR. *) -(* assert (f' = f). *) -(* { eapply Axioms.functional_extensionality. intros x. destruct (eq_block x b1). *) -(* - subst x. destruct (f b1) eqn:FB. *) -(* + destruct p. specialize (INCR _ _ _ FB). auto. *) -(* + subst f'. simpl. rewrite pred_dec_true; auto. *) -(* - subst f'. simpl. rewrite pred_dec_false; auto. *) -(* } *) -(* rewrite <- H. apply INJ. *) -(* } *) -(* inversion H. assert (inject_incr f f'). *) -(* red; unfold f'; intros. destruct (eq_block b b1). subst b. *) -(* assert (f b1 = None). eauto with mem. congruence. *) -(* auto. *) -(* assert (mem_winj f' m1 m2). *) -(* inversion mwi_inj; constructor; eauto with mem. *) -(* unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. *) -(* unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. *) -(* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) -(* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) -(* eapply mwi_align; eauto. *) -(* split. constructor. *) -(* (* inj *) *) -(* eapply alloc_left_unmapped_winj; eauto. unfold f'; apply dec_eq_true. *) -(* (* freeblocks *) *) -(* intros. unfold f'. destruct (eq_block b b1). auto. *) -(* apply mi_freeblocks. red; intro; elim H3. eauto with mem. *) -(* (* mappedblocks *) *) -(* unfold f'; intros. destruct (eq_block b b1). congruence. eauto. *) -(* (* no overlap *) *) -(* unfold f'; red; intros. *) -(* destruct (eq_block b0 b1); destruct (eq_block b2 b1); try congruence. *) -(* eapply mwi_no_overlap. eexact H3. eauto. eauto. *) -(* exploit Mem.perm_alloc_inv. eauto. eexact H6. rewrite dec_eq_false; auto. *) -(* exploit Mem.perm_alloc_inv. eauto. eexact H7. rewrite dec_eq_false; auto. *) -(* (* representable *) *) -(* unfold f'; intros. *) -(* destruct (eq_block b b1); try discriminate. *) -(* eapply mwi_representable; try eassumption. *) -(* destruct H4; eauto using Mem.perm_alloc_4. *) -(* (* perm inv *) *) -(* intros. unfold f' in H3; destruct (eq_block b0 b1); try discriminate. *) -(* exploit mwi_perm_inv; eauto. *) -(* intuition eauto using Mem.perm_alloc_1, Mem.perm_alloc_4. *) -(* (* incr *) *) -(* split. auto. *) -(* (* image *) *) -(* split. unfold f'; apply dec_eq_true. *) -(* (* incr *) *) -(* intros; unfold f'; apply dec_eq_false; auto. *) -(* Qed. *) - -(* Lemma alloc_left_unmapped_inject_keep: *) -(* forall f m1 m2 c lo hi m1' b1, *) -(* Mem.inject f m1 m2 -> *) -(* Mem.alloc m1 c lo hi = (m1', b1) -> *) -(* Mem.inject f m1' m2. *) -(* Proof. *) -(* intros. set (f' := fun b => if eq_block b b1 then None else f b). *) -(* cut (Mem.inject f' m1' m2 /\ inject_incr f f' /\ f' b1 = None /\ (forall b, b <> b1 -> f' b = f b)). *) -(* { clear - f'. intros (INJ & INCR & _ & _). unfold inject_incr in INCR. *) -(* assert (f' = f). *) -(* { eapply Axioms.functional_extensionality. intros x. destruct (eq_block x b1). *) -(* - subst x. destruct (f b1) eqn:FB. *) -(* + destruct p. specialize (INCR _ _ _ FB). auto. *) -(* + subst f'. simpl. rewrite pred_dec_true; auto. *) -(* - subst f'. simpl. rewrite pred_dec_false; auto. *) -(* } *) -(* rewrite <- H. apply INJ. *) -(* } *) -(* inversion H. assert (inject_incr f f'). *) -(* red; unfold f'; intros. destruct (eq_block b b1). subst b. *) -(* assert (f b1 = None). eauto with mem. congruence. *) -(* auto. *) -(* assert (Mem.mem_inj f' m1 m2). *) -(* inversion mi_inj; constructor; eauto with mem. *) -(* unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. *) -(* unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. *) -(* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) -(* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) -(* eapply mi_align; eauto. *) -(* unfold f'; intros. destruct (eq_block b0 b1). congruence. *) -(* apply memval_inject_incr with f; auto. *) -(* split. constructor. *) -(* (* inj *) *) -(* eapply Mem.alloc_left_unmapped_inj; eauto. unfold f'; apply dec_eq_true. *) -(* (* freeblocks *) *) -(* intros. unfold f'. destruct (eq_block b b1). auto. *) -(* apply mi_freeblocks. red; intro; elim H3. eauto with mem. *) -(* (* mappedblocks *) *) -(* unfold f'; intros. destruct (eq_block b b1). congruence. eauto. *) -(* (* no overlap *) *) -(* unfold f'; red; intros. *) -(* destruct (eq_block b0 b1); destruct (eq_block b2 b1); try congruence. *) -(* eapply mi_no_overlap. eexact H3. eauto. eauto. *) -(* exploit Mem.perm_alloc_inv. eauto. eexact H6. rewrite dec_eq_false; auto. *) -(* exploit Mem.perm_alloc_inv. eauto. eexact H7. rewrite dec_eq_false; auto. *) -(* (* representable *) *) -(* unfold f'; intros. *) -(* destruct (eq_block b b1); try discriminate. *) -(* eapply mi_representable; try eassumption. *) -(* destruct H4; eauto using Mem.perm_alloc_4. *) -(* (* perm inv *) *) -(* intros. unfold f' in H3; destruct (eq_block b0 b1); try discriminate. *) -(* exploit mi_perm_inv; eauto. *) -(* intuition eauto using Mem.perm_alloc_1, Mem.perm_alloc_4. *) -(* (* incr *) *) -(* split. auto. *) -(* (* image *) *) -(* split. unfold f'; apply dec_eq_true. *) -(* (* incr *) *) -(* intros; unfold f'; apply dec_eq_false; auto. *) -(* Qed. *) + 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. *) +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. *) + (* 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. *) + 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. *) + 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. *) +End PUBINJ. Section MEMDELTA. @@ -174,992 +174,1024 @@ Section MEMDELTA. (* order: old to new *) Definition mem_delta := list mem_delta_kind. - (* Definition mem_delta_apply_storev (om: option mem) (d: mem_delta_storev): option mem := *) - (* let '(ch, ptr, v, cp) := d in *) - (* match om with *) - (* | Some m => Mem.storev ch m ptr v cp *) - (* | None => None *) - (* end. *) - -(* Lemma mem_delta_apply_storev_none *) -(* d *) -(* : *) -(* mem_delta_apply_storev None d = None. *) -(* Proof. unfold mem_delta_apply_storev. destruct d as [[[d0 d2] d3] d4]. auto. Qed. *) - -(* Definition mem_delta_apply_store (om: option mem) (d: mem_delta_store): option mem := *) -(* let '(ch, b, ofs, v, cp) := d in *) -(* match om with *) -(* | Some m => Mem.store ch m b ofs v cp *) -(* | None => None *) -(* end. *) - -(* Lemma mem_delta_apply_store_none *) -(* d *) -(* : *) -(* mem_delta_apply_store None d = None. *) -(* Proof. unfold mem_delta_apply_store. destruct d as [[[[d0 d1] d2] d3] d4]. auto. Qed. *) - -(* Definition mem_delta_apply_bytes (om: option mem) (d: mem_delta_bytes): option mem := *) -(* let '(b, ofs, mvs, cp) := d in *) -(* match om with *) -(* | Some m => Mem.storebytes m b ofs mvs cp *) -(* | None => None *) -(* end. *) - -(* Lemma mem_delta_apply_bytes_none *) -(* d *) -(* : *) -(* mem_delta_apply_bytes None d = None. *) -(* Proof. unfold mem_delta_apply_bytes. destruct d as [[[d0 d1] d2] d3]. auto. Qed. *) - -(* Definition mem_delta_apply_alloc (om: option mem) (d: mem_delta_alloc): option mem := *) -(* let '(cp, lo, hi) := d in *) -(* match om with *) -(* | Some m => Some (fst (Mem.alloc m cp lo hi)) *) -(* | None => None *) -(* end. *) - -(* Lemma mem_delta_apply_alloc_none *) -(* d *) -(* : *) -(* mem_delta_apply_alloc None d = None. *) -(* Proof. unfold mem_delta_apply_alloc. destruct d as [[d0 d1] d2]. auto. Qed. *) - -(* Definition mem_delta_apply_free (om: option mem) (d: mem_delta_free): option mem := *) -(* let '(b, lo, hi, cp) := d in *) -(* match om with *) -(* | Some m => Mem.free m b lo hi cp *) -(* | None => None *) -(* end. *) - -(* Lemma mem_delta_apply_free_none *) -(* d *) -(* : *) -(* mem_delta_apply_free None d = None. *) -(* Proof. unfold mem_delta_apply_free. destruct d as [[[d0 d1] d2] d3]. auto. Qed. *) - -(* Definition mem_delta_apply_kind (data: mem_delta_kind) (om: option mem) : option mem := *) -(* match data with *) -(* | mem_delta_kind_storev d => mem_delta_apply_storev om d *) -(* | mem_delta_kind_store d => mem_delta_apply_store om d *) -(* | mem_delta_kind_bytes d => mem_delta_apply_bytes om d *) -(* | mem_delta_kind_alloc d => mem_delta_apply_alloc om d *) -(* | mem_delta_kind_free d => mem_delta_apply_free om d *) -(* end. *) - -(* Definition mem_delta_apply (d: mem_delta) (om0: option mem) : option mem := *) -(* fold_left (fun om data => mem_delta_apply_kind data om) d om0. *) - -(* Lemma mem_delta_apply_cons *) -(* d m0 k *) -(* : *) -(* mem_delta_apply (k :: d) m0 = *) -(* match k with *) -(* | mem_delta_kind_storev dd => mem_delta_apply d (mem_delta_apply_storev (m0) dd) *) -(* | mem_delta_kind_store dd => mem_delta_apply d (mem_delta_apply_store (m0) dd) *) -(* | mem_delta_kind_bytes dd => mem_delta_apply d (mem_delta_apply_bytes (m0) dd) *) -(* | mem_delta_kind_alloc dd => mem_delta_apply d (mem_delta_apply_alloc (m0) dd) *) -(* | mem_delta_kind_free dd => mem_delta_apply d (mem_delta_apply_free (m0) dd) *) -(* end. *) -(* Proof. simpl. destruct k; auto. Qed. *) - -(* Lemma mem_delta_apply_app *) -(* d0 d1 m0 *) -(* : *) -(* mem_delta_apply (d0 ++ d1) m0 = mem_delta_apply d1 (mem_delta_apply d0 m0). *) -(* Proof. *) -(* revert d1 m0. induction d0; intros. *) -(* { simpl. auto. } *) -(* rewrite <- app_comm_cons. rewrite ! mem_delta_apply_cons. destruct a; auto. *) -(* Qed. *) - -(* Lemma mem_delta_apply_none *) -(* d *) -(* : *) -(* mem_delta_apply d None = None. *) -(* Proof. *) -(* induction d; auto. rewrite mem_delta_apply_cons. *) -(* destruct a; *) -(* [rewrite mem_delta_apply_storev_none | rewrite mem_delta_apply_store_none | rewrite mem_delta_apply_bytes_none | rewrite mem_delta_apply_alloc_none | rewrite mem_delta_apply_free_none]; rewrite IHd; auto. *) -(* Qed. *) - -(* Lemma mem_delta_apply_some *) -(* d om m' *) -(* (APPD: mem_delta_apply d om = Some m') *) -(* : *) -(* exists m, om = Some m. *) -(* Proof. destruct om; eauto. rewrite mem_delta_apply_none in APPD. inv APPD. Qed. *) + Definition mem_delta_apply_storev (om: option mem) (d: mem_delta_storev): option mem := + let '(ch, ptr, v, cp) := d in + match om with + | Some m => Mem.storev ch m ptr v cp + | None => None + end. + + Lemma mem_delta_apply_storev_none + d + : + mem_delta_apply_storev None d = None. + Proof. unfold mem_delta_apply_storev. destruct d as [[[d0 d2] d3] d4]. auto. Qed. + + Definition mem_delta_apply_store (om: option mem) (d: mem_delta_store): option mem := + let '(ch, b, ofs, v, cp) := d in + match om with + | Some m => Mem.store ch m b ofs v cp + | None => None + end. + + Lemma mem_delta_apply_store_none + d + : + mem_delta_apply_store None d = None. + Proof. unfold mem_delta_apply_store. destruct d as [[[[d0 d1] d2] d3] d4]. auto. Qed. + + Definition mem_delta_apply_bytes (om: option mem) (d: mem_delta_bytes): option mem := + let '(b, ofs, mvs, cp) := d in + match om with + | Some m => Mem.storebytes m b ofs mvs cp + | None => None + end. + + Lemma mem_delta_apply_bytes_none + d + : + mem_delta_apply_bytes None d = None. + Proof. unfold mem_delta_apply_bytes. destruct d as [[[d0 d1] d2] d3]. auto. Qed. + + Definition mem_delta_apply_alloc (om: option mem) (d: mem_delta_alloc): option mem := + let '(cp, lo, hi) := d in + match om with + | Some m => Some (fst (Mem.alloc m cp lo hi)) + | None => None + end. + + Lemma mem_delta_apply_alloc_none + d + : + mem_delta_apply_alloc None d = None. + Proof. unfold mem_delta_apply_alloc. destruct d as [[d0 d1] d2]. auto. Qed. + + Definition mem_delta_apply_free (om: option mem) (d: mem_delta_free): option mem := + let '(b, lo, hi, cp) := d in + match om with + | Some m => Mem.free m b lo hi cp + | None => None + end. + + Lemma mem_delta_apply_free_none + d + : + mem_delta_apply_free None d = None. + Proof. unfold mem_delta_apply_free. destruct d as [[[d0 d1] d2] d3]. auto. Qed. + + Definition mem_delta_apply_kind (data: mem_delta_kind) (om: option mem) : option mem := + match data with + | mem_delta_kind_storev d => mem_delta_apply_storev om d + | mem_delta_kind_store d => mem_delta_apply_store om d + | mem_delta_kind_bytes d => mem_delta_apply_bytes om d + | mem_delta_kind_alloc d => mem_delta_apply_alloc om d + | mem_delta_kind_free d => mem_delta_apply_free om d + end. + + Definition mem_delta_apply (d: mem_delta) (om0: option mem) : option mem := + fold_left (fun om data => mem_delta_apply_kind data om) d om0. + + Lemma mem_delta_apply_cons + d m0 k + : + mem_delta_apply (k :: d) m0 = + match k with + | mem_delta_kind_storev dd => mem_delta_apply d (mem_delta_apply_storev (m0) dd) + | mem_delta_kind_store dd => mem_delta_apply d (mem_delta_apply_store (m0) dd) + | mem_delta_kind_bytes dd => mem_delta_apply d (mem_delta_apply_bytes (m0) dd) + | mem_delta_kind_alloc dd => mem_delta_apply d (mem_delta_apply_alloc (m0) dd) + | mem_delta_kind_free dd => mem_delta_apply d (mem_delta_apply_free (m0) dd) + end. + Proof. simpl. destruct k; auto. Qed. + + Lemma mem_delta_apply_app + d0 d1 m0 + : + mem_delta_apply (d0 ++ d1) m0 = mem_delta_apply d1 (mem_delta_apply d0 m0). + Proof. + revert d1 m0. induction d0; intros. + { simpl. auto. } + rewrite <- app_comm_cons. rewrite ! mem_delta_apply_cons. destruct a; auto. + Qed. + + Lemma mem_delta_apply_none + d + : + mem_delta_apply d None = None. + Proof. + induction d; auto. rewrite mem_delta_apply_cons. + destruct a; + [rewrite mem_delta_apply_storev_none | rewrite mem_delta_apply_store_none | rewrite mem_delta_apply_bytes_none | rewrite mem_delta_apply_alloc_none | rewrite mem_delta_apply_free_none]; rewrite IHd; auto. + Qed. + + Lemma mem_delta_apply_some + d om m' + (APPD: mem_delta_apply d om = Some m') + : + exists m, om = Some m. + Proof. destruct om; eauto. rewrite mem_delta_apply_none in APPD. inv APPD. Qed. End MEMDELTA. -(* Section WFDELTA. *) -(* (** only wf delta is applied for back transltation *) *) - -(* (* Refer to encode_val *) *) -(* Definition wf_chunk_val_b (ch: memory_chunk) (v: val) := *) -(* match v with *) -(* | Vundef => false *) -(* | Vint n => *) -(* match ch with *) -(* | Mint8signed | Mint8unsigned => true *) -(* | Mint16signed | Mint16unsigned => true *) -(* | Mint32 => true *) -(* | _ => false *) -(* end *) -(* | Vlong n => *) -(* match ch with *) -(* | Mint64 => true *) -(* | Many32 => false *) -(* | Many64 => false *) -(* | _ => false *) -(* end *) -(* | Vfloat n => *) -(* match ch with *) -(* | Mfloat64 => true *) -(* | Many32 => false *) -(* | Many64 => false *) -(* | _ => false *) -(* end *) -(* | Vsingle n => *) -(* match ch with *) -(* | Mfloat32 => true *) -(* | Many32 => false *) -(* | Many64 => false *) -(* | _ => false *) -(* end *) -(* | Vptr _ _ => false *) -(* end. *) - -(* Definition wf_mem_delta_storev_b (ge: Senv.t) (cp0: compartment) (d: mem_delta_storev) := *) -(* let '(ch, ptr, v, cp) := d in *) -(* match ptr with *) -(* | Vptr b ofs => match Senv.invert_symbol ge b with *) -(* | Some id => (Senv.public_symbol ge id) && (wf_chunk_val_b ch v) && (Pos.eqb cp0 cp) *) -(* | _ => false *) -(* end *) -(* | _ => false *) -(* end. *) - -(* Definition wf_mem_delta_kind_b (ge: Senv.t) cp0 (d: mem_delta_kind) := *) -(* match d with | mem_delta_kind_storev dd => wf_mem_delta_storev_b ge cp0 dd | _ => false end. *) - -(* Definition get_wf_mem_delta (ge: Senv.t) cp0 (d: mem_delta): mem_delta := *) -(* filter (wf_mem_delta_kind_b ge cp0) d. *) - -(* Lemma get_wf_mem_delta_cons *) -(* ge cp0 d k *) -(* : *) -(* get_wf_mem_delta ge cp0 (k :: d) = *) -(* if (wf_mem_delta_kind_b ge cp0 k) then k :: (get_wf_mem_delta ge cp0 d) else (get_wf_mem_delta ge cp0 d). *) -(* Proof. ss. Qed. *) - -(* Lemma get_wf_mem_delta_app *) -(* ge cp0 d0 d1 *) -(* : *) -(* get_wf_mem_delta ge cp0 (d0 ++ d1) = (get_wf_mem_delta ge cp0 d0) ++ (get_wf_mem_delta ge cp0 d1). *) -(* Proof. apply filter_app. Qed. *) - - -(* Definition mem_delta_apply_wf ge cp0 (d: mem_delta) (om0: option mem): option mem := *) -(* mem_delta_apply (get_wf_mem_delta ge cp0 d) om0. *) - -(* Lemma mem_delta_apply_wf_cons *) -(* ge cp0 d m0 k *) -(* : *) -(* mem_delta_apply_wf ge cp0 (k :: d) m0 = *) -(* if (wf_mem_delta_kind_b ge cp0 k) then mem_delta_apply_wf ge cp0 d (mem_delta_apply_kind k m0) else mem_delta_apply_wf ge cp0 d m0. *) -(* Proof. unfold mem_delta_apply_wf at 1. rewrite get_wf_mem_delta_cons. des_ifs. Qed. *) - -(* Lemma mem_delta_apply_wf_app *) -(* ge cp0 d0 d1 m0 *) -(* : *) -(* mem_delta_apply_wf ge cp0 (d0 ++ d1) m0 = *) -(* mem_delta_apply_wf ge cp0 d1 (mem_delta_apply_wf ge cp0 d0 m0). *) -(* Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_app. apply mem_delta_apply_app. Qed. *) - -(* Lemma mem_delta_apply_wf_none *) -(* ge cp0 d *) -(* : *) -(* mem_delta_apply_wf ge cp0 d None = None. *) -(* Proof. unfold mem_delta_apply_wf. apply mem_delta_apply_none. Qed. *) - -(* Lemma mem_delta_apply_wf_some *) -(* ge cp0 d m0 m1 *) -(* (APPD: mem_delta_apply_wf ge cp0 d m0 = Some m1) *) -(* : *) -(* exists m, m0 = Some m. *) -(* Proof. unfold mem_delta_apply_wf in APPD. exploit mem_delta_apply_some; eauto. Qed. *) - -(* End WFDELTA. *) - - -(* Section PROPS. *) - -(* (** Delta and location relations *) *) - -(* Let mcps := PTree.t compartment. *) - -(* Definition mem_delta_unchanged_storev (d: mem_delta_storev) (b': block) (ofs': Z): Prop := *) -(* let '(ch, ptr, v, cp) := d in *) -(* match ptr with *) -(* | Vptr b ofs0 => let ofs := (Ptrofs.unsigned ofs0) in (b = b') -> (ofs > ofs' \/ ofs + (size_chunk ch) <= ofs') *) -(* | _ => True *) -(* end. *) - -(* Lemma mem_delta_unchanged_on_storev *) -(* d m m' *) -(* (APPD: mem_delta_apply_storev (Some m) d = (Some m')) *) -(* : *) -(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged_storev d b ofs) m m'. *) -(* Proof. *) -(* destruct d as (((ch & ptr) & v) & cp). ss. unfold Mem.storev in APPD. des_ifs. *) -(* eapply Mem.store_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. *) -(* Qed. *) - -(* Definition mem_delta_unchanged_store (d: mem_delta_store) (b': block) (ofs': Z): Prop := *) -(* let '(ch, b, ofs, v, cp) := d in (b = b') -> (ofs > ofs' \/ ofs + (size_chunk ch) <= ofs'). *) - -(* Lemma mem_delta_unchanged_on_store *) -(* d m m' *) -(* (APPD: mem_delta_apply_store (Some m) d = (Some m')) *) -(* : *) -(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged_store d b ofs) m m'. *) -(* Proof. *) -(* destruct d as ((((ch & b) & ofs) & v) & cp). ss. *) -(* eapply Mem.store_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. *) -(* Qed. *) - -(* Definition mem_delta_unchanged_bytes (d: mem_delta_bytes) (b': block) (ofs': Z): Prop := *) -(* let '(b, ofs, mvs, cp) := d in *) -(* (b = b') -> (ofs > ofs' \/ ofs + Z.of_nat (Datatypes.length mvs) <= ofs'). *) - -(* Lemma mem_delta_unchanged_on_bytes *) -(* d m m' *) -(* (APPD: mem_delta_apply_bytes (Some m) d = (Some m')) *) -(* : *) -(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged_bytes d b ofs) m m'. *) -(* Proof. *) -(* destruct d as (((b & ofs) & mvs) & cp). simpl in *. *) -(* eapply Mem.storebytes_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. *) -(* Qed. *) - -(* Definition mem_delta_unchanged_alloc (d: mem_delta_alloc) (b': block) (ofs': Z): Prop := *) -(* let '(cp, lo, hi) := d in *) -(* True. *) - -(* Lemma mem_delta_unchanged_on_alloc *) -(* d m m' *) -(* (APPD: mem_delta_apply_alloc (Some m) d = (Some m')) *) -(* : *) -(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged_alloc d b ofs) m m'. *) -(* Proof. *) -(* destruct d as ((cp & lo) & hi). simpl in *. destruct (Mem.alloc m cp lo hi) eqn:ALLOC; simpl in *. inv APPD. *) -(* eapply Mem.alloc_unchanged_on. eauto. *) -(* Qed. *) - -(* Definition mem_delta_unchanged_free (d: mem_delta_free) (b': block) (ofs': Z): Prop := *) -(* let '(b, lo, hi, cp) := d in *) -(* (b = b') -> (lo > ofs' \/ hi <= ofs'). *) - -(* Lemma mem_delta_unchanged_on_free *) -(* d m m' *) -(* (APPD: mem_delta_apply_free (Some m) d = (Some m')) *) -(* : *) -(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged_free d b ofs) m m'. *) -(* Proof. *) -(* destruct d as (((b & lo) & hi) & cp). simpl in *. *) -(* eapply Mem.free_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. *) -(* Qed. *) - -(* Definition mem_delta_kind_unchanged (k: mem_delta_kind) (b: block) (ofs: Z) := *) -(* match k with *) -(* | mem_delta_kind_storev dd => mem_delta_unchanged_storev dd b ofs *) -(* | mem_delta_kind_store dd => mem_delta_unchanged_store dd b ofs *) -(* | mem_delta_kind_bytes dd => mem_delta_unchanged_bytes dd b ofs *) -(* | mem_delta_kind_alloc dd => mem_delta_unchanged_alloc dd b ofs *) -(* | mem_delta_kind_free dd => mem_delta_unchanged_free dd b ofs *) -(* end. *) - -(* Definition mem_delta_unchanged (d: mem_delta) (b: block) (ofs: Z) := *) -(* Forall (fun k => mem_delta_kind_unchanged k b ofs) d. *) - -(* Lemma mem_delta_unchanged_on *) -(* d m m' *) -(* (APPD: mem_delta_apply d (Some m) = Some m') *) -(* : *) -(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged d b ofs) m m'. *) -(* Proof. *) -(* revert m m' APPD. induction d; intros; simpl. *) -(* { simpl in APPD. inv APPD. apply Mem.unchanged_on_refl. } *) -(* rewrite mem_delta_apply_cons in APPD. destruct a. *) -(* - destruct d0 as [[[ch ptr] v] cp]. destruct (mem_delta_apply_storev (Some m) (ch, ptr, v, cp)) eqn:MEM. *) -(* 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } *) -(* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) -(* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } *) -(* { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_storev. eauto. *) -(* intros. simpl. des_ifs. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. *) -(* } *) -(* - destruct d0 as [[[[ch b] ofs] v] cp]. destruct (mem_delta_apply_store (Some m) (ch, b, ofs, v, cp)) eqn:MEM. *) -(* 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } *) -(* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) -(* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } *) -(* { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_store. eauto. *) -(* intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. *) -(* } *) -(* - destruct d0 as [[[b ofs] mvs] cp]. destruct (mem_delta_apply_bytes (Some m) (b, ofs, mvs, cp)) eqn:MEM. *) -(* 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } *) -(* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) -(* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } *) -(* { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_bytes. eauto. *) -(* intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. *) -(* } *) -(* - destruct d0 as [[cp lo] hi]. destruct (mem_delta_apply_alloc (Some m) (cp, lo, hi)) eqn:MEM. *) -(* 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } *) -(* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) -(* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } *) -(* { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_alloc. eauto. *) -(* intros. simpl. auto. *) -(* } *) -(* - destruct d0 as [[[b lo] hi] cp]. destruct (mem_delta_apply_free (Some m) (b, lo, hi, cp)) eqn:MEM. *) -(* 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } *) -(* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) -(* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } *) -(* { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_free. eauto. *) -(* intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. *) -(* } *) -(* Qed. *) - -(* Lemma mem_delta_wf_unchanged_on *) -(* ge cp d m m' *) -(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) -(* : *) -(* Mem.unchanged_on (fun b ofs => mem_delta_unchanged (get_wf_mem_delta ge cp d) b ofs) m m'. *) -(* Proof. eapply mem_delta_unchanged_on; eauto. Qed. *) - -(* Lemma get_from_setN_same_upto_ofs *) -(* ofs0 ofs l ofsd *) -(* (OFS: ofs0 <= ofs < ofs0 + Z.of_nat (Datatypes.length l)) *) -(* (mc1 mc2 : (ZMap.t memval)) *) -(* : *) -(* ZMap.get ofs (Mem.setN l ofs0 mc1) = ZMap.get (ofs + ofsd) (Mem.setN l (ofs0 + ofsd) mc2). *) -(* Proof. *) -(* revert ofs0 ofs ofsd OFS mc1 mc2. induction l; simpl; intros. *) -(* { lia. } *) -(* destruct (Z.eqb_spec ofs0 ofs). *) -(* { subst ofs0. clear OFS. rewrite ! Mem.setN_outside; try lia. rewrite ! ZMap.gss. auto. } *) -(* { replace (ofs0 + ofsd + 1) with ((ofs0 + 1) + ofsd) by lia. eapply IHl. lia. } *) -(* Qed. *) - -(* Lemma get_from_setN_same *) -(* ofs0 ofs l *) -(* (OFS: ofs0 <= ofs < ofs0 + Z.of_nat (Datatypes.length l)) *) -(* (mc1 mc2 : (ZMap.t memval)) *) -(* : *) -(* ZMap.get ofs (Mem.setN l ofs0 mc1) = ZMap.get ofs (Mem.setN l ofs0 mc2). *) -(* Proof. *) -(* replace ofs with (ofs + 0) at 2 by lia. replace ofs0 with (ofs0 + 0) at 2 by lia. eapply get_from_setN_same_upto_ofs; auto. *) -(* Qed. *) - -(* Lemma mem_store_same_upto_ofs *) -(* ofs ofs0 ch0 v0 cp0 ofsd b b' m1 m2 m1' m2' *) -(* (OFS: ofs0 <= ofs < ofs0 + size_chunk ch0) *) -(* (MEM1: Mem.store ch0 m1 b ofs0 v0 cp0 = Some m1') *) -(* (MEM2: Mem.store ch0 m2 b' (ofs0 + ofsd) v0 cp0 = Some m2') *) -(* : *) -(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get (ofs + ofsd) (Mem.mem_contents m2') !! b'. *) -(* Proof. *) -(* apply Mem.store_mem_contents in MEM1, MEM2. rewrite MEM1, MEM2. rewrite ! PMap.gss. *) -(* rewrite size_chunk_conv, <- (encode_val_length ch0 v0) in OFS. *) -(* remember (encode_val ch0 v0) as l. remember (Mem.mem_contents m1) as mc1. remember (Mem.mem_contents m2) as mc2. clear - OFS. *) -(* eapply get_from_setN_same_upto_ofs. auto. *) -(* Qed. *) - - -(* Definition mem_delta_changed_storev (d: mem_delta_storev) (b': block) (ofs': Z): Prop := *) -(* let '(ch, ptr, v, cp) := d in *) -(* match ptr with *) -(* | Vptr b ofs0 => let ofs := Ptrofs.unsigned ofs0 in (b = b') /\ (ofs <= ofs' < ofs + (size_chunk ch)) *) -(* | _ => False *) -(* end. *) - -(* Lemma mem_delta_changed_storev_same *) -(* d b ofs *) -(* (CHG: mem_delta_changed_storev d b ofs) *) -(* m1 m1' m2 m2' *) -(* (APPD1: mem_delta_apply_storev (Some m1) d = Some m1') *) -(* (APPD2: mem_delta_apply_storev (Some m2) d = Some m2') *) -(* : *) -(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. *) -(* Proof. *) -(* destruct d as [[[ch0 ptr0] v0] cp0]. unfold mem_delta_changed_storev in CHG. des_ifs. *) -(* destruct CHG as (BLK & OFS). subst b0. *) -(* simpl in *. replace ofs with (ofs + 0) at 2 by lia. eapply mem_store_same_upto_ofs; eauto. *) -(* rewrite Z.add_0_r. eauto. *) -(* Qed. *) - -(* Definition mem_delta_changed_store (d: mem_delta_store) (b': block) (ofs': Z): Prop := *) -(* let '(ch, b, ofs, v, cp) := d in *) -(* (b = b') /\ (ofs <= ofs' < ofs + (size_chunk ch)). *) - -(* Lemma mem_delta_changed_store_same *) -(* d b ofs *) -(* (CHG: mem_delta_changed_store d b ofs) *) -(* m1 m1' m2 m2' *) -(* (APPD1: mem_delta_apply_store (Some m1) d = Some m1') *) -(* (APPD2: mem_delta_apply_store (Some m2) d = Some m2') *) -(* : *) -(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. *) -(* Proof. *) -(* destruct d as [[[[ch0 b0] ofs0] v0] cp0]. destruct CHG as (BLK & OFS). subst b0. *) -(* simpl in *. replace ofs with (ofs + 0) at 2 by lia. eapply mem_store_same_upto_ofs; eauto. *) -(* replace (ofs0 + 0) with ofs0 by lia. eauto. *) -(* Qed. *) - -(* Definition mem_delta_changed_bytes (d: mem_delta_bytes) (b': block) (ofs': Z): Prop := *) -(* let '(b, ofs, mvs, cp) := d in *) -(* (b = b') /\ (ofs <= ofs' < ofs + Z.of_nat (Datatypes.length mvs)). *) - -(* Lemma mem_delta_changed_bytes_same *) -(* d b ofs *) -(* (CHG: mem_delta_changed_bytes d b ofs) *) -(* m1 m1' m2 m2' *) -(* (APPD1: mem_delta_apply_bytes (Some m1) d = Some m1') *) -(* (APPD2: mem_delta_apply_bytes (Some m2) d = Some m2') *) -(* : *) -(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. *) -(* Proof. *) -(* destruct d as [[[b0 ofs0] mvs0] cp0]. destruct CHG as (BLK & OFS). subst b0. *) -(* simpl in *. apply Mem.storebytes_mem_contents in APPD1, APPD2. rewrite APPD1, APPD2. rewrite ! PMap.gss. *) -(* eapply get_from_setN_same. auto. *) -(* Qed. *) - -(* Definition mem_delta_changed_alloc (d: mem_delta_alloc) (b': block) (ofs': Z): Prop := *) -(* let '(cp, lo, hi) := d in *) -(* False. *) - -(* Lemma mem_delta_changed_alloc_same *) -(* d b ofs *) -(* (CHG: mem_delta_changed_alloc d b ofs) *) -(* m1 m1' m2 m2' *) -(* (APPD1: mem_delta_apply_alloc (Some m1) d = Some m1') *) -(* (APPD2: mem_delta_apply_alloc (Some m2) d = Some m2') *) -(* : *) -(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. *) -(* Proof. *) -(* unfold mem_delta_changed_alloc in CHG. destruct d. destruct p. inv CHG. *) -(* Qed. *) - -(* Definition mem_delta_changed_free (d: mem_delta_free) (b': block) (ofs': Z): Prop := *) -(* let '(b, lo, hi, cp) := d in *) -(* (b = b') /\ (lo <= ofs' < hi). *) - -(* Definition mem_delta_kind_changed (k: mem_delta_kind) (b: block) (ofs: Z) := *) -(* match k with *) -(* | mem_delta_kind_storev dd => mem_delta_changed_storev dd b ofs *) -(* | mem_delta_kind_store dd => mem_delta_changed_store dd b ofs *) -(* | mem_delta_kind_bytes dd => mem_delta_changed_bytes dd b ofs *) -(* | mem_delta_kind_alloc dd => mem_delta_changed_alloc dd b ofs *) -(* | mem_delta_kind_free dd => mem_delta_changed_free dd b ofs *) -(* end. *) - -(* Definition mem_delta_changed (d: mem_delta) (b: block) (ofs: Z) := *) -(* Exists (fun k => mem_delta_kind_changed k b ofs) d. *) - - -(* (** Propperties *) *) -(* Lemma mem_delta_cases_storev *) -(* d b ofs *) -(* : *) -(* mem_delta_unchanged_storev d b ofs \/ mem_delta_changed_storev d b ofs. *) -(* Proof. destruct d as [[[ch0 ptr0] v0] cp0]. ss. des_ifs; auto. lia. Qed. *) - -(* Lemma mem_delta_cases_store *) -(* d b ofs *) -(* : *) -(* mem_delta_unchanged_store d b ofs \/ mem_delta_changed_store d b ofs. *) -(* Proof. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. simpl. lia. Qed. *) - -(* Lemma mem_delta_cases_bytes *) -(* d b ofs *) -(* : *) -(* mem_delta_unchanged_bytes d b ofs \/ mem_delta_changed_bytes d b ofs. *) -(* Proof. destruct d as [[[b0 ofs0] mvs] cp0]. simpl. lia. Qed. *) - -(* Lemma mem_delta_cases_alloc *) -(* d b ofs *) -(* : *) -(* mem_delta_unchanged_alloc d b ofs \/ mem_delta_changed_alloc d b ofs. *) -(* Proof. destruct d as [[x y] z]. simpl. auto. Qed. *) - -(* Lemma mem_delta_cases_free *) -(* d b ofs *) -(* : *) -(* mem_delta_unchanged_free d b ofs \/ mem_delta_changed_free d b ofs. *) -(* Proof. destruct d as [[[b0 lo] hi] cp0]. simpl. lia. Qed. *) - -(* Lemma mem_delta_cases_kind *) -(* d b ofs *) -(* : *) -(* mem_delta_kind_unchanged d b ofs \/ mem_delta_kind_changed d b ofs. *) -(* Proof. destruct d; simpl. apply mem_delta_cases_storev. apply mem_delta_cases_store. apply mem_delta_cases_bytes. apply mem_delta_cases_alloc. apply mem_delta_cases_free. Qed. *) - -(* Lemma mem_delta_unchanged_or_changed *) -(* d b ofs *) -(* : *) -(* mem_delta_unchanged d b ofs \/ mem_delta_changed d b ofs. *) -(* Proof. *) -(* induction d. *) -(* { left. constructor 1. } *) -(* destruct IHd. *) -(* 2:{ right. constructor 2. auto. } *) -(* destruct (mem_delta_cases_kind a b ofs). *) -(* - left. constructor; auto. *) -(* - right. constructor 1; auto. *) -(* Qed. *) - -(* End PROPS. *) - -(* Section PROOFS. *) -(* (** Props for proofs *) *) - -(* Definition mem_delta_kind_inj_wf (cp0: compartment) (j: meminj): mem_delta_kind -> Prop := *) -(* fun data => *) -(* match data with *) -(* | mem_delta_kind_storev (ch, ptr, v, cp) => cp = cp0 *) -(* | mem_delta_kind_store (ch, b, ofs, v, cp) => (j b) = None *) -(* | mem_delta_kind_bytes (b, ofs, mvs, cp) => (j b) = None *) -(* | mem_delta_kind_free (b, lo, hi, cp) => (j b) = None *) -(* | _ => True *) -(* end. *) - -(* Definition mem_delta_inj_wf cp (j: meminj): mem_delta -> Prop := *) -(* fun d => Forall (fun data => mem_delta_kind_inj_wf cp j data) d. *) - -(* Definition meminj_first_order (j: meminj) (m: mem) := *) -(* forall b ofs, (j b <> None) -> (Mem.perm m b ofs Cur Readable) -> loc_first_order m b ofs. *) - -(* Definition meminj_not_alloc (j: meminj) (m: mem) := forall b, (Mem.nextblock m <= b)%positive -> j b = None. *) - - -(* Lemma mem_storev_first_order_wf_chunk_val *) -(* ch m b i v cp m' *) -(* (MEM: Mem.storev ch m (Vptr b i) v cp = Some m') *) -(* ofs *) -(* (FO: loc_first_order m' b ofs) *) -(* (CHG: Ptrofs.unsigned i <= ofs < Ptrofs.unsigned i + size_chunk ch) *) -(* : *) -(* wf_chunk_val_b ch v. *) -(* Proof. *) -(* unfold loc_first_order in FO. ss. exploit Mem.store_mem_contents; eauto. intros CNT. *) -(* rewrite CNT in FO. remember (Ptrofs.unsigned i) as ofs0. rewrite PMap.gss in FO. remember ((Mem.mem_contents m) !! b) as mcv. clear - FO CHG. *) -(* assert (IN: In (ZMap.get ofs (Mem.setN (encode_val ch v) ofs0 mcv)) (encode_val ch v)). *) -(* { eapply Mem.setN_in. rewrite encode_val_length. rewrite <- size_chunk_conv. auto. } *) -(* remember (ZMap.get ofs (Mem.setN (encode_val ch v) ofs0 mcv)) as mv. clear - FO IN. *) -(* destruct ch; destruct v; ss; des; clarify. *) -(* 1,2: des_ifs; ss; des; clarify. *) -(* Qed. *) - -(* Lemma list_forall_filter *) -(* A (P: A -> Prop) l B *) -(* (FA: Forall P l) *) -(* : *) -(* Forall P (filter B l). *) -(* Proof. induction FA; ss. des_ifs. econs; eauto. Qed. *) - -(* Lemma mem_delta_unchanged_implies_wf_unchanged *) -(* ge cp d b ofs *) -(* (UNCHG: mem_delta_unchanged d b ofs) *) -(* : *) -(* mem_delta_unchanged (get_wf_mem_delta ge cp d) b ofs. *) -(* Proof. eapply list_forall_filter; eauto. Qed. *) - -(* Lemma mem_delta_changed_only_by_storev *) -(* ge cp d b ofs *) -(* (WF: mem_delta_inj_wf cp (meminj_public ge) d) *) -(* (INJ: (meminj_public ge) b <> None) *) -(* (CHG: mem_delta_changed d b ofs) *) -(* m1 m1' m2 m2' *) -(* (APPD1: mem_delta_apply d (Some m1) = Some m1') *) -(* (APPD2: mem_delta_apply_wf ge cp d (Some m2) = Some m2') *) -(* (PERM1: Mem.perm m1 b ofs Cur Readable) *) -(* (PERM2: Mem.perm m2 b ofs Cur Readable) *) -(* (FO: loc_first_order m1' b ofs) *) -(* : *) -(* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. *) -(* Proof. *) -(* revert WF CHG m1 m1' m2 m2' APPD1 APPD2 PERM1 PERM2 FO. induction d; intros. *) -(* { inv CHG. } *) -(* rewrite mem_delta_apply_cons in APPD1. rewrite mem_delta_apply_wf_cons in APPD2. inv WF. rename H1 into WF1, H2 into WF2. inv CHG. *) -(* (* not chagned by the head *) *) -(* 2:{ specialize (IHd WF2 H0). destruct a. *) -(* - destruct d0 as [[[ch0 ptr0] v0] cp0]. des_ifs. *) -(* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) -(* exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) -(* ss. unfold Mem.storev in MEM1. des_ifs. ss. eapply IHd; eauto. 1,2: eapply Mem.perm_store_1; eauto. *) -(* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) -(* exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) -(* ss. unfold Mem.storev in MEM1. destruct ptr0; ss; clarify. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. *) -(* - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. des_ifs. *) -(* exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) -(* ss. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. *) -(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. *) -(* eapply Mem.perm_storebytes_1; eauto. *) -(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[x y] z]. simpl in *. eapply IHd; eauto. *) -(* destruct (Mem.alloc m1 x y z) eqn: ALLOC. ss. inv MEM1. eapply Mem.perm_alloc_1; eauto. *) -(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. *) -(* eapply Mem.perm_free_1; eauto. left. ii. subst w. clarify. *) -(* } *) -(* rename H0 into CHG. destruct (mem_delta_unchanged_or_changed d b ofs). *) -(* (* overwrite by the tail *) *) -(* 2:{ specialize (IHd WF2 H). destruct a. *) -(* - destruct d0 as [[[ch0 ptr0] v0] cp0]. des_ifs. *) -(* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) -(* exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) -(* ss. unfold Mem.storev in MEM1. des_ifs. ss. eapply IHd; eauto. 1,2: eapply Mem.perm_store_1; eauto. *) -(* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) -(* exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) -(* ss. unfold Mem.storev in MEM1. destruct ptr0; ss; clarify. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. *) -(* - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. des_ifs. *) -(* exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) -(* ss. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. *) -(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. *) -(* eapply Mem.perm_storebytes_1; eauto. *) -(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[x y] z]. simpl in *. eapply IHd; eauto. *) -(* destruct (Mem.alloc m1 x y z) eqn: ALLOC. ss. *) -(* - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. *) -(* eapply Mem.perm_free_1; eauto. left. ii. subst w. clarify. *) -(* } *) -(* rename H into UNCHG. clear IHd. *) -(* { destruct a. *) -(* 2,3,5: ss; des_ifs; ss; des; clarify. *) -(* 2:{ destruct d0 as [[x y] z]. ss. } *) -(* destruct d0 as [[[ch0 ptr0] v0] cp0]. ss. destruct ptr0; ss. des; clarify. *) -(* assert (exists id, Senv.invert_symbol ge b = Some id /\ Senv.public_symbol ge id). *) -(* { clear - INJ. unfold meminj_public in INJ. des_ifs. eauto. } *) -(* des. rename H into INV, H0 into PUB. rewrite INV, PUB in APPD2. *) -(* exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) -(* eapply mem_delta_unchanged_on in APPD1. exploit (Mem.unchanged_on_contents _ _ _ APPD1 b ofs); auto. *) -(* { eapply Mem.perm_store_1; eauto. } *) -(* intros H. rewrite H. *) -(* assert (FO2: loc_first_order mi1 b ofs). *) -(* { unfold loc_first_order in *. rewrite <- H. auto. } *) -(* exploit mem_storev_first_order_wf_chunk_val. 2,3: eauto. ss. eauto. *) -(* intros WFCV. rewrite WFCV in APPD2. rewrite Pos.eqb_refl in APPD2. des_ifs. *) -(* exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) -(* eapply mem_delta_wf_unchanged_on in APPD2; auto. exploit (Mem.unchanged_on_contents _ _ _ APPD2 b ofs); auto. *) -(* { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. } *) -(* { eapply Mem.perm_store_1; eauto. } *) -(* intros H0. rewrite H0. replace ofs with (ofs + 0)%Z at 2 by lia. *) -(* eapply mem_store_same_upto_ofs; eauto. rewrite Z.add_0_r. eauto. *) -(* } *) -(* Qed. *) - -(* Lemma store_left_mapped_winj: *) -(* forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta, *) -(* mem_winj f m1 m2 -> *) -(* Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> *) -(* f b1 = Some (b2, delta) -> *) -(* mem_winj f n1 m2. *) -(* Proof. *) -(* intros. *) -(* inv H. constructor. *) -(* (* perm *) *) -(* intros. eapply mwi_perm; eauto. eapply Mem.perm_store_2; eauto. *) -(* (* own *) *) -(* intros. eapply mwi_own. eauto. apply (proj2 (Mem.store_can_access_block_inj _ _ _ _ _ _ _ H0 _ _)). auto. *) -(* (* align *) *) -(* intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. red; intros; eauto with mem. *) -(* Qed. *) - -(* Lemma store_left_mapped_winject: *) -(* forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta, *) -(* winject f m1 m2 -> *) -(* Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> *) -(* f b1 = Some (b2, delta) -> *) -(* winject f n1 m2. *) -(* Proof. *) -(* intros. inversion H. exploit store_left_mapped_winj; eauto. intros MI. constructor. *) -(* (* winj *) *) -(* auto. *) -(* (* freeblocks *) *) -(* eauto with mem. *) -(* (* mappedblocks *) *) -(* eauto with mem. *) -(* (* no overlap *) *) -(* red; intros. eauto with mem. *) -(* (* representable *) *) -(* intros. eapply mwi_representable; try eassumption. *) -(* destruct H3; eauto with mem. *) -(* (* perm inv *) *) -(* intros. exploit mwi_perm_inv; eauto using Mem.perm_store_2. *) -(* intuition eauto using Mem.perm_store_1, Mem.perm_store_2. *) -(* Qed. *) - -(* Lemma store_left_winject: *) -(* forall f chunk m1 b1 ofs v1 cp n1 m2, *) -(* winject f m1 m2 -> *) -(* Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> *) -(* winject f n1 m2. *) -(* Proof. *) -(* intros. destruct (f b1) eqn:FB. *) -(* - destruct p. eapply store_left_mapped_winject; eauto. *) -(* - eapply store_unmapped_winject; eauto. *) -(* Qed. *) - -(* Lemma storebytes_left_mapped_winj: *) -(* forall f m1 b1 ofs v1 cp n1 m2 b2 delta, *) -(* mem_winj f m1 m2 -> *) -(* Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> *) -(* f b1 = Some (b2, delta) -> *) -(* mem_winj f n1 m2. *) -(* Proof. *) -(* intros. *) -(* inv H. constructor. *) -(* (* perm *) *) -(* intros. eapply mwi_perm; eauto. eapply Mem.perm_storebytes_2; eauto. *) -(* (* own *) *) -(* intros. eapply mwi_own; eauto. eapply Mem.storebytes_can_access_block_inj_2; eauto. *) -(* (* align *) *) -(* intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. *) -(* red; intros. eapply Mem.perm_storebytes_2; eauto. *) -(* Qed. *) - -(* Lemma storebytes_left_mapped_winject: *) -(* forall f m1 b1 ofs v1 cp n1 m2 b2 delta, *) -(* winject f m1 m2 -> *) -(* Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> *) -(* f b1 = Some (b2, delta) -> *) -(* winject f n1 m2. *) -(* Proof. *) -(* intros. inversion H. exploit storebytes_left_mapped_winj; eauto. intros MI. constructor. *) -(* (* winj *) *) -(* auto. *) -(* (* freeblocks *) *) -(* eauto with mem. *) -(* (* mappedblocks *) *) -(* eauto with mem. *) -(* (* no overlap *) *) -(* red; intros. eauto with mem. *) -(* (* representable *) *) -(* intros. eapply mwi_representable; try eassumption. *) -(* destruct H3; eauto with mem. *) -(* (* perm inv *) *) -(* intros. exploit mwi_perm_inv; eauto using Mem.perm_storebytes_2. *) -(* intuition eauto using Mem.perm_storebytes_1, Mem.perm_storebytes_2. *) -(* Qed. *) - -(* Lemma storebytes_left_winject: *) -(* forall f m1 b1 ofs v1 cp n1 m2, *) -(* winject f m1 m2 -> *) -(* Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> *) -(* winject f n1 m2. *) -(* Proof. *) -(* intros. destruct (f b1) eqn:FB. *) -(* - destruct p. eapply storebytes_left_mapped_winject; eauto. *) -(* - eapply storebytes_unmapped_winject; eauto. *) -(* Qed. *) - -(* Lemma mem_delta_apply_preserves_winject *) -(* ge cp0 m0 m0' *) -(* (WINJ0: winject (meminj_public ge) m0 m0') *) -(* (d: mem_delta) *) -(* m1 *) -(* (APPD: mem_delta_apply d (Some m0) = Some m1) *) -(* : *) -(* exists m1', (mem_delta_apply_wf ge cp0 d (Some m0') = Some m1') /\ (winject (meminj_public ge) m1 m1'). *) -(* Proof. *) -(* revert m0 m0' WINJ0 m1 APPD. induction d; intros. *) -(* { inv APPD. exists m0'. ss. } *) -(* rewrite mem_delta_apply_cons in APPD. rewrite mem_delta_apply_wf_cons. destruct a. *) -(* - exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. des_ifs. *) -(* + destruct d0 as (((ch & ptr) & v) & cp). destruct ptr; ss. destruct ((meminj_public ge) b) as [[b' ofs']|] eqn:JB. *) -(* * exploit store_mapped_winject; eauto. instantiate (1:=v). intros (mi0 & MEM' & WINJ1). specialize (IHd _ _ WINJ1 _ APPD). destruct IHd as (m1' & APPD' & WINJ'). *) -(* unfold meminj_public in JB. des_ifs. rewrite Z.add_0_r in MEM'. rewrite MEM'. eauto. *) -(* * exploit store_unmapped_winject; eauto. unfold meminj_public in JB. des_ifs. *) -(* + destruct d0 as (((ch & ptr) & v) & cp). destruct ptr; ss. exploit store_left_winject; eauto. *) -(* - destruct d0 as ((((ch & b) & ofs) & v) & cp). ss. exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. *) -(* exploit store_left_winject; eauto. *) -(* - destruct d0 as (((b & ofs) & mvs) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. ss. exploit storebytes_left_winject; eauto. *) -(* - destruct d0 as ((cp & lo) & hi). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. *) -(* ss. destruct (Mem.alloc m0 cp lo hi) eqn:ALLOC; simpl in *. inv MEM. exploit alloc_left_unmapped_winject_keep; eauto. *) -(* - destruct d0 as (((b & lo) & hi) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. ss. exploit free_left_winject; eauto. *) -(* Qed. *) - -(* Lemma mem_delta_apply_keeps_perm *) -(* cp j d *) -(* (DWF: mem_delta_inj_wf cp j d) *) -(* m0 m1 *) -(* (APPD : mem_delta_apply d (Some m0) = Some m1) *) -(* b ofs *) -(* (INJ: j b <> None) *) -(* K P *) -(* (PERM: Mem.perm m1 b ofs K P) *) -(* (BOUND: (b < Mem.nextblock m0)%positive) *) -(* : *) -(* Mem.perm m0 b ofs K P. *) -(* Proof. *) -(* revert DWF m0 APPD BOUND. induction d; intros. *) -(* { simpl in *. inv APPD; auto. } *) -(* inv DWF. rename H1 into DWF1, H2 into DWF2. rewrite mem_delta_apply_cons in APPD. specialize (IHd DWF2). *) -(* destruct a; exploit mem_delta_apply_some; eauto; intros (mi & MEM); rewrite MEM in APPD; specialize (IHd _ APPD). *) -(* - destruct d0 as (((ch0 & ptr0) & v0) & cp0). ss. clarify. destruct ptr0; ss. eapply Mem.perm_store_2; eauto. eapply IHd. erewrite Mem.nextblock_store; eauto. *) -(* - destruct d0 as ((((ch0 & b0) & ofs0) & v0) & cp0). simpl in *. eapply Mem.perm_store_2; eauto. eapply IHd. erewrite Mem.nextblock_store; eauto. *) -(* - destruct d0 as (((b0 & ofs0) & mvs0) & cp0). simpl in *. eapply Mem.perm_storebytes_2; eauto. eapply IHd. erewrite Mem.nextblock_storebytes; eauto. *) -(* - destruct d0 as ((cp0 & lo0) & hi0). simpl in *. destruct (Mem.alloc m0 cp0 lo0 hi0) eqn:ALLOC. simpl in *. inv MEM. *) -(* exploit Mem.alloc_result; eauto. intros; subst b0. exploit Mem.nextblock_alloc; eauto. intros EQ. *) -(* eapply Mem.perm_alloc_4. eauto. eapply IHd. lia. lia. *) -(* - destruct d0 as (((b0 & lo0) & hi0) & cp0). simpl in *. *) -(* eapply Mem.perm_free_3; eauto. eapply IHd. erewrite Mem.nextblock_free; eauto. *) -(* Qed. *) - -(* Lemma loc_first_order_always_memval_inject *) -(* m b ofs *) -(* (FO: loc_first_order m b ofs) *) -(* j v *) -(* (VINJ: memval_inject j (ZMap.get ofs (Mem.mem_contents m) !! b) v) *) -(* : *) -(* forall k, memval_inject k (ZMap.get ofs (Mem.mem_contents m) !! b) v. *) -(* Proof. *) -(* unfold loc_first_order in FO. destruct (ZMap.get ofs (Mem.mem_contents m) !! b) eqn:MV; try contradiction. *) -(* inv VINJ. intros. constructor. *) -(* Qed. *) - -(* Lemma mem_delta_apply_establish_inject *) -(* (ge: Senv.t) (k: meminj) m0 m0' *) -(* (INJ: Mem.inject k m0 m0') *) -(* (INCR: inject_incr (meminj_public ge) k) *) -(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) -(* (d: mem_delta) cp *) -(* (DWF: mem_delta_inj_wf cp (meminj_public ge) d) *) -(* m1 *) -(* (APPD: mem_delta_apply d (Some m0) = Some m1) *) -(* (FO: meminj_first_order (meminj_public ge) m1) *) -(* : *) -(* exists m1', (mem_delta_apply_wf ge cp d (Some m0') = Some m1') /\ (Mem.inject (meminj_public ge) m1 m1'). *) -(* Proof. *) -(* exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. *) -(* exploit mem_delta_apply_preserves_winject; eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. *) -(* apply winject_to_inject; auto. unfold mem_inj_val. intros. *) -(* exploit mem_delta_apply_keeps_perm; eauto. congruence. *) -(* { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). *) -(* { eapply NALLOC. lia. } *) -(* congruence. *) -(* } *) -(* intros PERM0. pose proof H as INJPUB. unfold meminj_public in H. des_ifs. rename Heq into INV, Heq0 into ISPUB. *) -(* rename b2 into b1. destruct (mem_delta_unchanged_or_changed d b1 ofs). *) -(* - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. *) -(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. *) -(* { inv INJ. inv mi_inj. specialize (mi_memval _ _ _ _ (INCR _ _ _ INJPUB) PERM0). eapply loc_first_order_always_memval_inject; eauto. *) -(* exploit FO. erewrite INJPUB. congruence. eauto. unfold loc_first_order; intros. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. *) -(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. *) -(* } *) -(* { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } *) -(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } *) -(* - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. *) -(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } *) -(* { exploit FO; eauto. rewrite INJPUB. congruence. } *) -(* intros. rewrite Z.add_0_r, <- x0. *) -(* exploit FO; eauto. rewrite INJPUB; ss. intros. unfold loc_first_order in x1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. *) -(* Qed. *) - -(* Import Mem. *) - -(* Lemma mem_delta_apply_establish_inject_preprocess *) -(* (ge: Senv.t) (k: meminj) m0 m0' *) -(* (INJ: Mem.inject k m0 m0') *) -(* pch pb pofs pv pcp m0'' *) -(* (PRE: store pch m0' pb pofs pv pcp = Some m0'') *) -(* (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) *) -(* (INCR: inject_incr (meminj_public ge) k) *) -(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) -(* (d: mem_delta) cp *) -(* (DWF: mem_delta_inj_wf cp (meminj_public ge) d) *) -(* m1 *) -(* (APPD: mem_delta_apply d (Some m0) = Some m1) *) -(* (FO: meminj_first_order (meminj_public ge) m1) *) -(* : *) -(* exists m1', (mem_delta_apply_wf ge cp d (Some m0'') = Some m1') /\ (Mem.inject (meminj_public ge) m1 m1'). *) -(* Proof. *) -(* exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. *) -(* hexploit store_outside_winject. eauto. *) -(* { intros. eapply PREB. rewrite H. eauto. } *) -(* eapply PRE. clear WINJ. intros WINJ. *) -(* exploit mem_delta_apply_preserves_winject. eapply WINJ. eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. *) -(* apply winject_to_inject; auto. unfold mem_inj_val. intros. *) -(* exploit mem_delta_apply_keeps_perm; eauto. congruence. *) -(* { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). *) -(* { eapply NALLOC. lia. } *) -(* congruence. *) -(* } *) -(* intros PERM0. pose proof H as INJPUB. unfold meminj_public in H. des_ifs. rename Heq into INV, Heq0 into ISPUB. *) -(* rename b2 into b1. *) -(* assert (NOT_PRE: b1 <> pb). *) -(* { intros EQ. subst b1. eapply PREB. eapply INJPUB. } *) -(* destruct (mem_delta_unchanged_or_changed d b1 ofs). *) -(* - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. *) -(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. *) -(* { inv INJ. inv mi_inj0. specialize (mi_memval0 _ _ _ _ (INCR _ _ _ INJPUB) PERM0). eapply loc_first_order_always_memval_inject; eauto. *) -(* - exploit FO. erewrite INJPUB. congruence. eauto. unfold loc_first_order; intros. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. *) -(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. *) -(* - erewrite (store_mem_contents _ m0' _ _ _ _ m0''). 2: eapply PRE. rewrite PMap.gso. 2: auto. eauto. *) -(* } *) -(* { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } *) -(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } *) -(* - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. *) -(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } *) -(* { exploit FO; eauto. rewrite INJPUB. congruence. } *) -(* intros. rewrite Z.add_0_r, <- x0. *) -(* exploit FO; eauto. rewrite INJPUB; ss. intros. unfold loc_first_order in x1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. *) -(* Qed. *) - -(* Lemma mem_delta_apply_establish_inject_preprocess_gen *) -(* (ge: Senv.t) (k: meminj) m0 m0' *) -(* (INJ: Mem.inject k m0 m0') *) -(* pch pb pofs pv pcp m0'' *) -(* (PRE: store pch m0' pb pofs pv pcp = Some m0'') *) -(* (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) *) -(* (INCR: inject_incr (meminj_public ge) k) *) -(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) -(* (d: mem_delta) cp *) -(* (DWF: mem_delta_inj_wf cp (meminj_public ge) d) *) -(* m1 *) -(* (APPD: mem_delta_apply d (Some m0) = Some m1) *) -(* : *) -(* exists m1', (mem_delta_apply_wf ge cp d (Some m0'') = Some m1') /\ *) -(* ((meminj_first_order (meminj_public ge) m1) -> Mem.inject (meminj_public ge) m1 m1'). *) -(* Proof. *) -(* exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. *) -(* hexploit store_outside_winject. eauto. *) -(* { intros. eapply PREB. rewrite H. eauto. } *) -(* eapply PRE. clear WINJ. intros WINJ. *) -(* exploit mem_delta_apply_preserves_winject. eapply WINJ. eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. *) -(* intros FO. apply winject_to_inject; auto. unfold mem_inj_val. intros. *) -(* exploit mem_delta_apply_keeps_perm; eauto. congruence. *) -(* { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). *) -(* { eapply NALLOC. lia. } *) -(* congruence. *) -(* } *) -(* intros PERM0. pose proof H as INJPUB. unfold meminj_public in H. des_ifs. rename Heq into INV, Heq0 into ISPUB. *) -(* rename b2 into b1. *) -(* assert (NOT_PRE: b1 <> pb). *) -(* { intros EQ. subst b1. eapply PREB. eapply INJPUB. } *) -(* destruct (mem_delta_unchanged_or_changed d b1 ofs). *) -(* - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. *) -(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. *) -(* { inv INJ. inv mi_inj0. specialize (mi_memval0 _ _ _ _ (INCR _ _ _ INJPUB) PERM0). eapply loc_first_order_always_memval_inject; eauto. *) -(* - exploit FO. erewrite INJPUB. congruence. eauto. unfold loc_first_order; intros. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. *) -(* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. *) -(* - erewrite (store_mem_contents _ m0' _ _ _ _ m0''). 2: eapply PRE. rewrite PMap.gso. 2: auto. eauto. *) -(* } *) -(* { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } *) -(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } *) -(* - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. *) -(* { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } *) -(* { exploit FO; eauto. rewrite INJPUB. congruence. } *) -(* intros. rewrite Z.add_0_r, <- x0. *) -(* exploit FO; eauto. rewrite INJPUB; ss. intros. unfold loc_first_order in x1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. *) -(* Qed. *) - -(* End PROOFS. *) +Section WFDELTA. + (** only wf delta is applied for back transltation *) + + (* Refer to encode_val *) + Definition wf_chunk_val_b (ch: memory_chunk) (v: val) := + match v with + | Vundef => false + | Vint n => + match ch with + | Mint8signed | Mint8unsigned => true + | Mint16signed | Mint16unsigned => true + | Mint32 => true + | _ => false + end + | Vlong n => + match ch with + | Mint64 => true + | Many32 => false + | Many64 => false + | _ => false + end + | Vfloat n => + match ch with + | Mfloat64 => true + | Many32 => false + | Many64 => false + | _ => false + end + | Vsingle n => + match ch with + | Mfloat32 => true + | Many32 => false + | Many64 => false + | _ => false + end + | Vptr _ _ => false + end. + + Definition wf_mem_delta_storev_b (ge: Senv.t) (cp0: compartment) (d: mem_delta_storev) := + let '(ch, ptr, v, cp) := d in + match ptr with + | Vptr b ofs => match Senv.invert_symbol ge b with + | Some id => (Senv.public_symbol ge id) && (wf_chunk_val_b ch v) && (cp_eq_dec cp0 cp) + | _ => false + end + | _ => false + end. + + Definition wf_mem_delta_kind_b (ge: Senv.t) cp0 (d: mem_delta_kind) := + match d with | mem_delta_kind_storev dd => wf_mem_delta_storev_b ge cp0 dd | _ => false end. + + Definition get_wf_mem_delta (ge: Senv.t) cp0 (d: mem_delta): mem_delta := + filter (wf_mem_delta_kind_b ge cp0) d. + + Lemma get_wf_mem_delta_cons + ge cp0 d k + : + get_wf_mem_delta ge cp0 (k :: d) = + if (wf_mem_delta_kind_b ge cp0 k) then k :: (get_wf_mem_delta ge cp0 d) else (get_wf_mem_delta ge cp0 d). + Proof. ss. Qed. + + Lemma get_wf_mem_delta_app + ge cp0 d0 d1 + : + get_wf_mem_delta ge cp0 (d0 ++ d1) = (get_wf_mem_delta ge cp0 d0) ++ (get_wf_mem_delta ge cp0 d1). + Proof. apply filter_app. Qed. + + + Definition mem_delta_apply_wf ge cp0 (d: mem_delta) (om0: option mem): option mem := + mem_delta_apply (get_wf_mem_delta ge cp0 d) om0. + + Lemma mem_delta_apply_wf_cons + ge cp0 d m0 k + : + mem_delta_apply_wf ge cp0 (k :: d) m0 = + if (wf_mem_delta_kind_b ge cp0 k) then mem_delta_apply_wf ge cp0 d (mem_delta_apply_kind k m0) else mem_delta_apply_wf ge cp0 d m0. + Proof. unfold mem_delta_apply_wf at 1. rewrite get_wf_mem_delta_cons. des_ifs. Qed. + + Lemma mem_delta_apply_wf_app + ge cp0 d0 d1 m0 + : + mem_delta_apply_wf ge cp0 (d0 ++ d1) m0 = + mem_delta_apply_wf ge cp0 d1 (mem_delta_apply_wf ge cp0 d0 m0). + Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_app. apply mem_delta_apply_app. Qed. + + Lemma mem_delta_apply_wf_none + ge cp0 d + : + mem_delta_apply_wf ge cp0 d None = None. + Proof. unfold mem_delta_apply_wf. apply mem_delta_apply_none. Qed. + + Lemma mem_delta_apply_wf_some + ge cp0 d m0 m1 + (APPD: mem_delta_apply_wf ge cp0 d m0 = Some m1) + : + exists m, m0 = Some m. + Proof. unfold mem_delta_apply_wf in APPD. exploit mem_delta_apply_some; eauto. Qed. + +End WFDELTA. + + +Section PROPS. + + (** Delta and location relations *) + + Let mcps := PTree.t compartment. + + Definition mem_delta_unchanged_storev (d: mem_delta_storev) (b': block) (ofs': Z): Prop := + let '(ch, ptr, v, cp) := d in + match ptr with + | Vptr b ofs0 => let ofs := (Ptrofs.unsigned ofs0) in (b = b') -> (ofs > ofs' \/ ofs + (size_chunk ch) <= ofs') + | _ => True + end. + + Lemma mem_delta_unchanged_on_storev + d m m' + (APPD: mem_delta_apply_storev (Some m) d = (Some m')) + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged_storev d b ofs) m m'. + Proof. + destruct d as (((ch & ptr) & v) & cp). ss. unfold Mem.storev in APPD. des_ifs. + eapply Mem.store_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. + Qed. + + Definition mem_delta_unchanged_store (d: mem_delta_store) (b': block) (ofs': Z): Prop := + let '(ch, b, ofs, v, cp) := d in (b = b') -> (ofs > ofs' \/ ofs + (size_chunk ch) <= ofs'). + + Lemma mem_delta_unchanged_on_store + d m m' + (APPD: mem_delta_apply_store (Some m) d = (Some m')) + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged_store d b ofs) m m'. + Proof. + destruct d as ((((ch & b) & ofs) & v) & cp). ss. + eapply Mem.store_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. + Qed. + + Definition mem_delta_unchanged_bytes (d: mem_delta_bytes) (b': block) (ofs': Z): Prop := + let '(b, ofs, mvs, cp) := d in + (b = b') -> (ofs > ofs' \/ ofs + Z.of_nat (Datatypes.length mvs) <= ofs'). + + Lemma mem_delta_unchanged_on_bytes + d m m' + (APPD: mem_delta_apply_bytes (Some m) d = (Some m')) + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged_bytes d b ofs) m m'. + Proof. + destruct d as (((b & ofs) & mvs) & cp). simpl in *. + eapply Mem.storebytes_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. + Qed. + + Definition mem_delta_unchanged_alloc (d: mem_delta_alloc) (b': block) (ofs': Z): Prop := + let '(cp, lo, hi) := d in + True. + + Lemma mem_delta_unchanged_on_alloc + d m m' + (APPD: mem_delta_apply_alloc (Some m) d = (Some m')) + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged_alloc d b ofs) m m'. + Proof. + destruct d as ((cp & lo) & hi). simpl in *. destruct (Mem.alloc m cp lo hi) eqn:ALLOC; simpl in *. inv APPD. + eapply Mem.alloc_unchanged_on. eauto. + Qed. + + Definition mem_delta_unchanged_free (d: mem_delta_free) (b': block) (ofs': Z): Prop := + let '(b, lo, hi, cp) := d in + (b = b') -> (lo > ofs' \/ hi <= ofs'). + + Lemma mem_delta_unchanged_on_free + d m m' + (APPD: mem_delta_apply_free (Some m) d = (Some m')) + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged_free d b ofs) m m'. + Proof. + destruct d as (((b & lo) & hi) & cp). simpl in *. + eapply Mem.free_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. + Qed. + + Definition mem_delta_kind_unchanged (k: mem_delta_kind) (b: block) (ofs: Z) := + match k with + | mem_delta_kind_storev dd => mem_delta_unchanged_storev dd b ofs + | mem_delta_kind_store dd => mem_delta_unchanged_store dd b ofs + | mem_delta_kind_bytes dd => mem_delta_unchanged_bytes dd b ofs + | mem_delta_kind_alloc dd => mem_delta_unchanged_alloc dd b ofs + | mem_delta_kind_free dd => mem_delta_unchanged_free dd b ofs + end. + + Definition mem_delta_unchanged (d: mem_delta) (b: block) (ofs: Z) := + Forall (fun k => mem_delta_kind_unchanged k b ofs) d. + + Lemma mem_delta_unchanged_on + d m m' + (APPD: mem_delta_apply d (Some m) = Some m') + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged d b ofs) m m'. + Proof. + revert m m' APPD. induction d; intros; simpl. + { simpl in APPD. inv APPD. apply Mem.unchanged_on_refl. } + rewrite mem_delta_apply_cons in APPD. destruct a. + - destruct d0 as [[[ch ptr] v] cp]. destruct (mem_delta_apply_storev (Some m) (ch, ptr, v, cp)) eqn:MEM. + 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } + { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_storev. eauto. + intros. simpl. des_ifs. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. + } + - destruct d0 as [[[[ch b] ofs] v] cp]. destruct (mem_delta_apply_store (Some m) (ch, b, ofs, v, cp)) eqn:MEM. + 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } + { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_store. eauto. + intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. + } + - destruct d0 as [[[b ofs] mvs] cp]. destruct (mem_delta_apply_bytes (Some m) (b, ofs, mvs, cp)) eqn:MEM. + 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } + { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_bytes. eauto. + intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. + } + - destruct d0 as [[cp lo] hi]. destruct (mem_delta_apply_alloc (Some m) (cp, lo, hi)) eqn:MEM. + 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } + { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_alloc. eauto. + intros. simpl. auto. + } + - destruct d0 as [[[b lo] hi] cp]. destruct (mem_delta_apply_free (Some m) (b, lo, hi, cp)) eqn:MEM. + 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } + { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_free. eauto. + intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. + } + Qed. + + Lemma mem_delta_wf_unchanged_on + ge cp d m m' + (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged (get_wf_mem_delta ge cp d) b ofs) m m'. + Proof. eapply mem_delta_unchanged_on; eauto. Qed. + + Lemma get_from_setN_same_upto_ofs + ofs0 ofs l ofsd + (OFS: ofs0 <= ofs < ofs0 + Z.of_nat (Datatypes.length l)) + (mc1 mc2 : (ZMap.t memval)) + : + ZMap.get ofs (Mem.setN l ofs0 mc1) = ZMap.get (ofs + ofsd) (Mem.setN l (ofs0 + ofsd) mc2). + Proof. + revert ofs0 ofs ofsd OFS mc1 mc2. induction l; simpl; intros. + { lia. } + destruct (Z.eqb_spec ofs0 ofs). + { subst ofs0. clear OFS. rewrite ! Mem.setN_outside; try lia. rewrite ! ZMap.gss. auto. } + { replace (ofs0 + ofsd + 1) with ((ofs0 + 1) + ofsd) by lia. eapply IHl. lia. } + Qed. + + Lemma get_from_setN_same + ofs0 ofs l + (OFS: ofs0 <= ofs < ofs0 + Z.of_nat (Datatypes.length l)) + (mc1 mc2 : (ZMap.t memval)) + : + ZMap.get ofs (Mem.setN l ofs0 mc1) = ZMap.get ofs (Mem.setN l ofs0 mc2). + Proof. + replace ofs with (ofs + 0) at 2 by lia. replace ofs0 with (ofs0 + 0) at 2 by lia. eapply get_from_setN_same_upto_ofs; auto. + Qed. + + Lemma mem_store_same_upto_ofs + ofs ofs0 ch0 v0 cp0 ofsd b b' m1 m2 m1' m2' + (OFS: ofs0 <= ofs < ofs0 + size_chunk ch0) + (MEM1: Mem.store ch0 m1 b ofs0 v0 cp0 = Some m1') + (MEM2: Mem.store ch0 m2 b' (ofs0 + ofsd) v0 cp0 = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get (ofs + ofsd) (Mem.mem_contents m2') !! b'. + Proof. + apply Mem.store_mem_contents in MEM1, MEM2. rewrite MEM1, MEM2. rewrite ! PMap.gss. + rewrite size_chunk_conv, <- (encode_val_length ch0 v0) in OFS. + remember (encode_val ch0 v0) as l. remember (Mem.mem_contents m1) as mc1. remember (Mem.mem_contents m2) as mc2. clear - OFS. + eapply get_from_setN_same_upto_ofs. auto. + Qed. + + + Definition mem_delta_changed_storev (d: mem_delta_storev) (b': block) (ofs': Z): Prop := + let '(ch, ptr, v, cp) := d in + match ptr with + | Vptr b ofs0 => let ofs := Ptrofs.unsigned ofs0 in (b = b') /\ (ofs <= ofs' < ofs + (size_chunk ch)) + | _ => False + end. + + Lemma mem_delta_changed_storev_same + d b ofs + (CHG: mem_delta_changed_storev d b ofs) + m1 m1' m2 m2' + (APPD1: mem_delta_apply_storev (Some m1) d = Some m1') + (APPD2: mem_delta_apply_storev (Some m2) d = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. + Proof. + destruct d as [[[ch0 ptr0] v0] cp0]. unfold mem_delta_changed_storev in CHG. des_ifs. + destruct CHG as (BLK & OFS). subst b0. + simpl in *. replace ofs with (ofs + 0) at 2 by lia. eapply mem_store_same_upto_ofs; eauto. + rewrite Z.add_0_r. eauto. + Qed. + + Definition mem_delta_changed_store (d: mem_delta_store) (b': block) (ofs': Z): Prop := + let '(ch, b, ofs, v, cp) := d in + (b = b') /\ (ofs <= ofs' < ofs + (size_chunk ch)). + + Lemma mem_delta_changed_store_same + d b ofs + (CHG: mem_delta_changed_store d b ofs) + m1 m1' m2 m2' + (APPD1: mem_delta_apply_store (Some m1) d = Some m1') + (APPD2: mem_delta_apply_store (Some m2) d = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. + Proof. + destruct d as [[[[ch0 b0] ofs0] v0] cp0]. destruct CHG as (BLK & OFS). subst b0. + simpl in *. replace ofs with (ofs + 0) at 2 by lia. eapply mem_store_same_upto_ofs; eauto. + replace (ofs0 + 0) with ofs0 by lia. eauto. + Qed. + + Definition mem_delta_changed_bytes (d: mem_delta_bytes) (b': block) (ofs': Z): Prop := + let '(b, ofs, mvs, cp) := d in + (b = b') /\ (ofs <= ofs' < ofs + Z.of_nat (Datatypes.length mvs)). + + Lemma mem_delta_changed_bytes_same + d b ofs + (CHG: mem_delta_changed_bytes d b ofs) + m1 m1' m2 m2' + (APPD1: mem_delta_apply_bytes (Some m1) d = Some m1') + (APPD2: mem_delta_apply_bytes (Some m2) d = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. + Proof. + destruct d as [[[b0 ofs0] mvs0] cp0]. destruct CHG as (BLK & OFS). subst b0. + simpl in *. apply Mem.storebytes_mem_contents in APPD1, APPD2. rewrite APPD1, APPD2. rewrite ! PMap.gss. + eapply get_from_setN_same. auto. + Qed. + + Definition mem_delta_changed_alloc (d: mem_delta_alloc) (b': block) (ofs': Z): Prop := + let '(cp, lo, hi) := d in + False. + + Lemma mem_delta_changed_alloc_same + d b ofs + (CHG: mem_delta_changed_alloc d b ofs) + m1 m1' m2 m2' + (APPD1: mem_delta_apply_alloc (Some m1) d = Some m1') + (APPD2: mem_delta_apply_alloc (Some m2) d = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. + Proof. + unfold mem_delta_changed_alloc in CHG. destruct d. destruct p. inv CHG. + Qed. + + Definition mem_delta_changed_free (d: mem_delta_free) (b': block) (ofs': Z): Prop := + let '(b, lo, hi, cp) := d in + (b = b') /\ (lo <= ofs' < hi). + + Definition mem_delta_kind_changed (k: mem_delta_kind) (b: block) (ofs: Z) := + match k with + | mem_delta_kind_storev dd => mem_delta_changed_storev dd b ofs + | mem_delta_kind_store dd => mem_delta_changed_store dd b ofs + | mem_delta_kind_bytes dd => mem_delta_changed_bytes dd b ofs + | mem_delta_kind_alloc dd => mem_delta_changed_alloc dd b ofs + | mem_delta_kind_free dd => mem_delta_changed_free dd b ofs + end. + + Definition mem_delta_changed (d: mem_delta) (b: block) (ofs: Z) := + Exists (fun k => mem_delta_kind_changed k b ofs) d. + + + (** Propperties *) + Lemma mem_delta_cases_storev + d b ofs + : + mem_delta_unchanged_storev d b ofs \/ mem_delta_changed_storev d b ofs. + Proof. destruct d as [[[ch0 ptr0] v0] cp0]. ss. des_ifs; auto. lia. Qed. + + Lemma mem_delta_cases_store + d b ofs + : + mem_delta_unchanged_store d b ofs \/ mem_delta_changed_store d b ofs. + Proof. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. simpl. lia. Qed. + + Lemma mem_delta_cases_bytes + d b ofs + : + mem_delta_unchanged_bytes d b ofs \/ mem_delta_changed_bytes d b ofs. + Proof. destruct d as [[[b0 ofs0] mvs] cp0]. simpl. lia. Qed. + + Lemma mem_delta_cases_alloc + d b ofs + : + mem_delta_unchanged_alloc d b ofs \/ mem_delta_changed_alloc d b ofs. + Proof. destruct d as [[x y] z]. simpl. auto. Qed. + + Lemma mem_delta_cases_free + d b ofs + : + mem_delta_unchanged_free d b ofs \/ mem_delta_changed_free d b ofs. + Proof. destruct d as [[[b0 lo] hi] cp0]. simpl. lia. Qed. + + Lemma mem_delta_cases_kind + d b ofs + : + mem_delta_kind_unchanged d b ofs \/ mem_delta_kind_changed d b ofs. + Proof. destruct d; simpl. apply mem_delta_cases_storev. apply mem_delta_cases_store. apply mem_delta_cases_bytes. apply mem_delta_cases_alloc. apply mem_delta_cases_free. Qed. + + Lemma mem_delta_unchanged_or_changed + d b ofs + : + mem_delta_unchanged d b ofs \/ mem_delta_changed d b ofs. + Proof. + induction d. + { left. constructor 1. } + destruct IHd. + 2:{ right. constructor 2. auto. } + destruct (mem_delta_cases_kind a b ofs). + - left. constructor; auto. + - right. constructor 1; auto. + Qed. + +End PROPS. + +Section PROOFS. + (** Props for proofs *) + + Definition mem_delta_kind_inj_wf (cp0: compartment) (j: meminj): mem_delta_kind -> Prop := + fun data => + match data with + | mem_delta_kind_storev (ch, ptr, v, cp) => cp = cp0 + | mem_delta_kind_store (ch, b, ofs, v, cp) => (j b) = None + | mem_delta_kind_bytes (b, ofs, mvs, cp) => (j b) = None + | mem_delta_kind_free (b, lo, hi, cp) => (j b) = None + | _ => True + end. + + Definition mem_delta_inj_wf cp (j: meminj): mem_delta -> Prop := + fun d => Forall (fun data => mem_delta_kind_inj_wf cp j data) d. + + (* Definition meminj_first_order (j: meminj) (m: mem) := *) + (* forall b ofs, (j b <> None) -> (Mem.perm m b ofs Cur Readable) -> loc_first_order m b ofs. *) + + Definition meminj_not_alloc (j: meminj) (m: mem) := forall b, (Mem.nextblock m <= b)%positive -> j b = None. + + + Lemma mem_storev_first_order_wf_chunk_val + ch m b i v cp m' + (MEM: Mem.storev ch m (Vptr b i) v cp = Some m') + ofs + (* (FO: loc_first_order m' b ofs) *) + (CHG: Ptrofs.unsigned i <= ofs < Ptrofs.unsigned i + size_chunk ch) + : + wf_chunk_val_b ch v. + Proof. + (* unfold loc_first_order in FO. *) + ss. exploit Mem.store_mem_contents; eauto. intros CNT. + (* rewrite CNT in FO. *) + remember (Ptrofs.unsigned i) as ofs0. + (* rewrite PMap.gss in FO. *) + remember ((Mem.mem_contents m) !! b) as mcv. clear - mcv (* 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 - IN. + destruct ch; destruct v; ss; des; clarify. + 1,2: des_ifs; ss; des; clarify. + all: admit. (* very bad break? *) + Admitted. + + Lemma list_forall_filter + A (P: A -> Prop) l B + (FA: Forall P l) + : + Forall P (filter B l). + Proof. induction FA; ss. des_ifs. econs; eauto. Qed. + + Lemma mem_delta_unchanged_implies_wf_unchanged + ge cp d b ofs + (UNCHG: mem_delta_unchanged d b ofs) + : + mem_delta_unchanged (get_wf_mem_delta ge cp d) b ofs. + Proof. eapply list_forall_filter; eauto. Qed. + + Lemma mem_delta_changed_only_by_storev + ge cp d b ofs + (WF: mem_delta_inj_wf cp (meminj_public ge) d) + (INJ: (meminj_public ge) b <> None) + (CHG: mem_delta_changed d b ofs) + m1 m1' m2 m2' + (APPD1: mem_delta_apply d (Some m1) = Some m1') + (APPD2: mem_delta_apply_wf ge cp d (Some m2) = Some m2') + (PERM1: Mem.perm m1 b ofs Cur Readable) + (PERM2: Mem.perm m2 b ofs Cur Readable) + (* (FO: loc_first_order m1' b ofs) *) + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. + Proof. + revert WF CHG m1 m1' m2 m2' APPD1 APPD2 PERM1 PERM2 (* FO *). induction d; intros. + { inv CHG. } + rewrite mem_delta_apply_cons in APPD1. rewrite mem_delta_apply_wf_cons in APPD2. inv WF. rename H1 into WF1, H2 into WF2. inv CHG. + (* not chagned by the head *) + 2:{ specialize (IHd WF2 H0). destruct a. + - destruct d0 as [[[ch0 ptr0] v0] cp0]. des_ifs. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + ss. unfold Mem.storev in MEM1. des_ifs. ss. eapply IHd; eauto. 1,2: eapply Mem.perm_store_1; eauto. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + ss. unfold Mem.storev in MEM1. destruct ptr0; ss; clarify. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. + - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. des_ifs. + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + ss. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. + eapply Mem.perm_storebytes_1; eauto. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[x y] z]. simpl in *. eapply IHd; eauto. + destruct (Mem.alloc m1 x y z) eqn: ALLOC. ss. inv MEM1. eapply Mem.perm_alloc_1; eauto. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. + eapply Mem.perm_free_1; eauto. left. ii. subst w. clarify. + } + rename H0 into CHG. destruct (mem_delta_unchanged_or_changed d b ofs). + (* overwrite by the tail *) + 2:{ specialize (IHd WF2 H). destruct a. + - destruct d0 as [[[ch0 ptr0] v0] cp0]. des_ifs. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + ss. unfold Mem.storev in MEM1. des_ifs. ss. eapply IHd; eauto. 1,2: eapply Mem.perm_store_1; eauto. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + ss. unfold Mem.storev in MEM1. destruct ptr0; ss; clarify. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. + - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. des_ifs. + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + ss. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. + eapply Mem.perm_storebytes_1; eauto. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[x y] z]. simpl in *. eapply IHd; eauto. + destruct (Mem.alloc m1 x y z) eqn: ALLOC. ss. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. + eapply Mem.perm_free_1; eauto. left. ii. subst w. clarify. + } + rename H into UNCHG. clear IHd. + { destruct a. + 2,3,5: ss; des_ifs; ss; des; clarify. + 2:{ destruct d0 as [[x y] z]. ss. } + destruct d0 as [[[ch0 ptr0] v0] cp0]. ss. destruct ptr0; ss. des; clarify. + assert (exists id, Senv.invert_symbol ge b = Some id /\ Senv.public_symbol ge id). + { clear - INJ. unfold meminj_public in INJ. des_ifs. eauto. } + des. rename H into INV, H0 into PUB. rewrite INV, PUB in APPD2. + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + eapply mem_delta_unchanged_on in APPD1. exploit (Mem.unchanged_on_contents _ _ _ APPD1 b ofs); auto. + { eapply Mem.perm_store_1; eauto. } + intros H. rewrite H. + ss. + (* 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. + destruct (cp_eq_dec cp cp); try contradiction. + ss. + (* rewrite Pos.eqb_refl in APPD2. *) + des_ifs. + exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + eapply mem_delta_wf_unchanged_on in APPD2; auto. exploit (Mem.unchanged_on_contents _ _ _ APPD2 b ofs); auto. + { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. } + { eapply Mem.perm_store_1; eauto. } + intros H0. rewrite H0. replace ofs with (ofs + 0)%Z at 2 by lia. + eapply mem_store_same_upto_ofs; eauto. rewrite Z.add_0_r. eauto. + } + Qed. + + Lemma store_left_mapped_winj: + forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta, + mem_winj f m1 m2 -> + Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + mem_winj f n1 m2. + Proof. + intros. + inv H. constructor. + (* perm *) + intros. eapply mwi_perm; eauto. eapply Mem.perm_store_2; eauto. + (* own *) + intros. eapply mwi_own. eauto. apply (proj2 (Mem.store_can_access_block_inj _ _ _ _ _ _ _ H0 _ _)). auto. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. red; intros; eauto with mem. + Qed. + + Lemma store_left_mapped_winject: + forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta, + winject f m1 m2 -> + Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + winject f n1 m2. + Proof. + intros. inversion H. exploit store_left_mapped_winj; eauto. intros MI. constructor. + (* winj *) + auto. + (* freeblocks *) + eauto with mem. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + red; intros. eauto with mem. + (* representable *) + intros. eapply mwi_representable; try eassumption. + destruct H3; eauto with mem. + (* perm inv *) + intros. exploit mwi_perm_inv; eauto using Mem.perm_store_2. + intuition eauto using Mem.perm_store_1, Mem.perm_store_2. + Qed. + + Lemma store_left_winject: + forall f chunk m1 b1 ofs v1 cp n1 m2, + winject f m1 m2 -> + Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> + winject f n1 m2. + Proof. + intros. destruct (f b1) eqn:FB. + - destruct p. eapply store_left_mapped_winject; eauto. + - eapply store_unmapped_winject; eauto. + Qed. + + Lemma storebytes_left_mapped_winj: + forall f m1 b1 ofs v1 cp n1 m2 b2 delta, + mem_winj f m1 m2 -> + Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + mem_winj f n1 m2. + Proof. + intros. + inv H. constructor. + (* perm *) + intros. eapply mwi_perm; eauto. eapply Mem.perm_storebytes_2; eauto. + (* own *) + intros. eapply mwi_own; eauto. eapply Mem.storebytes_can_access_block_inj_2; eauto. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. + red; intros. eapply Mem.perm_storebytes_2; eauto. + Qed. + + Lemma storebytes_left_mapped_winject: + forall f m1 b1 ofs v1 cp n1 m2 b2 delta, + winject f m1 m2 -> + Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + winject f n1 m2. + Proof. + intros. inversion H. exploit storebytes_left_mapped_winj; eauto. intros MI. constructor. + (* winj *) + auto. + (* freeblocks *) + eauto with mem. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + red; intros. eauto with mem. + (* representable *) + intros. eapply mwi_representable; try eassumption. + destruct H3; eauto with mem. + (* perm inv *) + intros. exploit mwi_perm_inv; eauto using Mem.perm_storebytes_2. + intuition eauto using Mem.perm_storebytes_1, Mem.perm_storebytes_2. + Qed. + + Lemma storebytes_left_winject: + forall f m1 b1 ofs v1 cp n1 m2, + winject f m1 m2 -> + Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> + winject f n1 m2. + Proof. + intros. destruct (f b1) eqn:FB. + - destruct p. eapply storebytes_left_mapped_winject; eauto. + - eapply storebytes_unmapped_winject; eauto. + Qed. + + Lemma mem_delta_apply_preserves_winject + ge cp0 m0 m0' + (WINJ0: winject (meminj_public ge) m0 m0') + (d: mem_delta) + m1 + (APPD: mem_delta_apply d (Some m0) = Some m1) + : + exists m1', (mem_delta_apply_wf ge cp0 d (Some m0') = Some m1') /\ (winject (meminj_public ge) m1 m1'). + Proof. + revert m0 m0' WINJ0 m1 APPD. induction d; intros. + { inv APPD. exists m0'. ss. } + rewrite mem_delta_apply_cons in APPD. rewrite mem_delta_apply_wf_cons. destruct a. + - exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. des_ifs. + + destruct d0 as (((ch & ptr) & v) & cp). destruct ptr; ss. destruct ((meminj_public ge) b) as [[b' ofs']|] eqn:JB. + * exploit store_mapped_winject; eauto. instantiate (1:=v). intros (mi0 & MEM' & WINJ1). specialize (IHd _ _ WINJ1 _ APPD). destruct IHd as (m1' & APPD' & WINJ'). + unfold meminj_public in JB. des_ifs. rewrite Z.add_0_r in MEM'. rewrite MEM'. eauto. + * exploit store_unmapped_winject; eauto. unfold meminj_public in JB. des_ifs. + + destruct d0 as (((ch & ptr) & v) & cp). destruct ptr; ss. exploit store_left_winject; eauto. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). ss. exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. + exploit store_left_winject; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. ss. exploit storebytes_left_winject; eauto. + - destruct d0 as ((cp & lo) & hi). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. + ss. destruct (Mem.alloc m0 cp lo hi) eqn:ALLOC; simpl in *. inv MEM. exploit alloc_left_unmapped_winject_keep; eauto. + - destruct d0 as (((b & lo) & hi) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. ss. + exploit free_left_winject; eauto. + Qed. + + Lemma mem_delta_apply_keeps_perm + cp j d + (DWF: mem_delta_inj_wf cp j d) + m0 m1 + (APPD : mem_delta_apply d (Some m0) = Some m1) + b ofs + (INJ: j b <> None) + K P + (PERM: Mem.perm m1 b ofs K P) + (BOUND: (b < Mem.nextblock m0)%positive) + : + Mem.perm m0 b ofs K P. + Proof. + revert DWF m0 APPD BOUND. induction d; intros. + { simpl in *. inv APPD; auto. } + inv DWF. rename H1 into DWF1, H2 into DWF2. rewrite mem_delta_apply_cons in APPD. specialize (IHd DWF2). + destruct a; exploit mem_delta_apply_some; eauto; intros (mi & MEM); rewrite MEM in APPD; specialize (IHd _ APPD). + - destruct d0 as (((ch0 & ptr0) & v0) & cp0). ss. clarify. destruct ptr0; ss. eapply Mem.perm_store_2; eauto. eapply IHd. erewrite Mem.nextblock_store; eauto. + - destruct d0 as ((((ch0 & b0) & ofs0) & v0) & cp0). simpl in *. eapply Mem.perm_store_2; eauto. eapply IHd. erewrite Mem.nextblock_store; eauto. + - destruct d0 as (((b0 & ofs0) & mvs0) & cp0). simpl in *. eapply Mem.perm_storebytes_2; eauto. eapply IHd. erewrite Mem.nextblock_storebytes; eauto. + - destruct d0 as ((cp0 & lo0) & hi0). simpl in *. destruct (Mem.alloc m0 cp0 lo0 hi0) eqn:ALLOC. simpl in *. inv MEM. + exploit Mem.alloc_result; eauto. intros; subst b0. exploit Mem.nextblock_alloc; eauto. intros EQ. + eapply Mem.perm_alloc_4. eauto. eapply IHd. lia. lia. + - destruct d0 as (((b0 & lo0) & hi0) & cp0). simpl in *. + eapply Mem.perm_free_3; eauto. eapply IHd. erewrite Mem.nextblock_free; eauto. + Qed. + + (* Lemma loc_first_order_always_memval_inject *) + (* m b ofs *) + (* (FO: loc_first_order m b ofs) *) + (* j v *) + (* (VINJ: memval_inject j (ZMap.get ofs (Mem.mem_contents m) !! b) v) *) + (* : *) + (* forall k, memval_inject k (ZMap.get ofs (Mem.mem_contents m) !! b) v. *) + (* Proof. *) + (* (* unfold loc_first_order in FO. *) *) + (* destruct (ZMap.get ofs (Mem.mem_contents m) !! b) eqn:MV; try contradiction. *) + (* inv VINJ. intros. constructor. *) + (* inv VINJ. intros. constructor. *) + (* inv VINJ. intros. constructor. *) + (* Qed. *) + + Lemma mem_delta_apply_establish_inject + (ge: Senv.t) (k: meminj) m0 m0' + (INJ: Mem.inject k m0 m0') + (INCR: inject_incr (meminj_public ge) k) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + (d: mem_delta) cp + (DWF: mem_delta_inj_wf cp (meminj_public ge) d) + m1 + (APPD: mem_delta_apply d (Some m0) = Some m1) + (* (FO: meminj_first_order (meminj_public ge) m1) *) + : + exists m1', (mem_delta_apply_wf ge cp d (Some m0') = Some m1') /\ (Mem.inject (meminj_public ge) m1 m1'). + Proof. + exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. + exploit mem_delta_apply_preserves_winject; eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. + apply winject_to_inject; auto. unfold mem_inj_val. intros. + exploit mem_delta_apply_keeps_perm; eauto. congruence. + { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). + { eapply NALLOC. lia. } + congruence. + } + intros PERM0. pose proof H as INJPUB. unfold meminj_public in H. des_ifs. rename Heq into INV, Heq0 into ISPUB. + rename b2 into b1. destruct (mem_delta_unchanged_or_changed d b1 ofs). + - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. + erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. + { inv INJ. inv mi_inj. specialize (mi_memval _ _ _ _ (INCR _ _ _ INJPUB) PERM0). + (* eapply loc_first_order_always_memval_inject; eauto. *) + (* exploit FO. *) + (* erewrite INJPUB. *) + (* congruence. eauto. unfold loc_first_order; intros. *) + destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. + admit. admit. admit. + (* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. *) + } + { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } + { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } + - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. + { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } + (* { exploit FO; eauto. rewrite INJPUB. congruence. } *) + intros. rewrite Z.add_0_r, <- x0. + (* exploit FO; eauto. *) + (* rewrite INJPUB; ss. intros. unfold loc_first_order in x1. *) + destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. + admit. admit. + Admitted. + + 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). + admit. + (* 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. + admit. admit. + Admitted. + + 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). + admit. + (* 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. + admit. admit. + Admitted. + +End PROOFS. diff --git a/security/MemoryWeak.v b/security/MemoryWeak.v index 2e5b157a9e..0d67456934 100644 --- a/security/MemoryWeak.v +++ b/security/MemoryWeak.v @@ -13,8 +13,7 @@ Require Export Memdata. Require Export Memtype. Require Import Memory. -(* To avoid useless definitions of inductors in extracted code. *) -Local Unset Elimination Schemes. +(* 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). @@ -359,34 +358,35 @@ Section WINJ. forall OWN : can_access_block m2 b2 c, mem_winj f m1' m2. Proof. - Admitted. - (* 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. *) + 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. + eapply flowsto_trans; eauto with comps. rewrite <- H5; auto with comps. + auto with comps. + 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', @@ -638,13 +638,13 @@ Section WINJ. (* 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. *) + (* 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: *) @@ -844,466 +844,467 @@ Section WINJ. (* (** Preservation of stores *) *) - (* Theorem store_mapped_winject: *) - (* forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta v2, *) - (* winject f m1 m2 -> *) - (* store chunk m1 b1 ofs v1 cp = Some n1 -> *) - (* f b1 = Some (b2, delta) -> *) - (* exists n2, *) - (* store chunk m2 b2 (ofs + delta) v2 cp = Some n2 *) - (* /\ winject f n1 n2. *) - (* Proof. *) - (* intros. inversion H. *) - (* exploit store_mapped_winj; eauto. intros [n2 [STORE MI]]. *) - (* exists n2; split. eauto. constructor. *) - (* (* winj *) *) - (* auto. *) - (* (* freeblocks *) *) - (* eauto with mem. *) - (* (* mappedblocks *) *) - (* eauto with mem. *) - (* (* no overlap *) *) - (* red; intros. eauto with mem. *) - (* (* representable *) *) - (* intros. eapply mwi_representable; try eassumption. *) - (* destruct H3; eauto with mem. *) - (* (* perm inv *) *) - (* intros. exploit mwi_perm_inv0; eauto using perm_store_2. *) - (* intuition eauto using perm_store_1, perm_store_2. *) - (* Qed. *) + Theorem store_mapped_winject: + forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta v2, + winject f m1 m2 -> + store chunk m1 b1 ofs v1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + exists n2, + store chunk m2 b2 (ofs + delta) v2 cp = Some n2 + /\ winject f n1 n2. + Proof. + intros. inversion H. + exploit store_mapped_winj; eauto. intros [n2 [STORE MI]]. + exists n2; split. eauto. constructor. + (* winj *) + auto. + (* freeblocks *) + eauto with mem. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + red; intros. eauto with mem. + (* representable *) + intros. eapply mwi_representable; try eassumption. + destruct H3; eauto with mem. + (* perm inv *) + intros. exploit mwi_perm_inv0; eauto using perm_store_2. + intuition eauto using perm_store_1, perm_store_2. + Qed. - (* Theorem store_unmapped_winject: *) - (* forall f chunk m1 b1 ofs v1 cp n1 m2, *) - (* winject f m1 m2 -> *) - (* store chunk m1 b1 ofs v1 cp = Some n1 -> *) - (* f b1 = None -> *) - (* winject f n1 m2. *) - (* Proof. *) - (* intros. inversion H. *) - (* constructor. *) - (* (* winj *) *) - (* eapply store_unmapped_winj; eauto. *) - (* (* freeblocks *) *) - (* eauto with mem. *) - (* (* mappedblocks *) *) - (* eauto with mem. *) - (* (* no overlap *) *) - (* red; intros. eauto with mem. *) - (* (* representable *) *) - (* intros. eapply mwi_representable; try eassumption. *) - (* destruct H3; eauto with mem. *) - (* (* perm inv *) *) - (* intros. exploit mwi_perm_inv0; eauto using perm_store_2. *) - (* intuition eauto using perm_store_1, perm_store_2. *) - (* Qed. *) + Theorem store_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 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 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_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_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_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. *) + 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 *) *) + (* 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_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_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_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 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. + subst; auto with comps. auto. + 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. *) + 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. + unfold can_access_block; erewrite (owned_new_block _ _ _ _ _ _ ALLOC); eauto with comps. + 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 *) *) + (** 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_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_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 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, *) diff --git a/security/Recomposition.v b/security/Recomposition.v new file mode 100644 index 0000000000..f3f65f8a02 --- /dev/null +++ b/security/Recomposition.v @@ -0,0 +1,4518 @@ +Require Import Coqlib Maps Errors Integers. +Require Import Integers Floats AST Linking. +Require Import AST Globalenvs Linking Smallstep Events Behaviors Memory Values. +Require Import Op Locations Mach Conventions Asm. +Require Import Complements. + +Require Import Split. + +Print Instances has_side. + +Variant match_fundef: fundef -> fundef -> Prop := + | match_fundef_internal: + forall cp sig code code', + match_fundef (Internal {| fn_comp := cp; fn_sig := sig; fn_code := code |}) + (Internal {| fn_comp := cp; fn_sig := sig; fn_code := code' |}) + | match_fundef_external: + forall ef, + match_fundef (External ef) (External ef) +. + +#[local] Instance has_comp_match_fundef (A: Type): has_comp_match (fun _:A => match_fundef). +intros ? x y H. +inv H; auto. +Qed. + +Definition match_varinfo (_ _: unit) := True. + +Variant match_globdef: globdef fundef unit -> globdef fundef unit -> Prop := + | match_globdef_fundef: forall f f', + match_fundef f f' -> + match_globdef (Gfun f) (Gfun f') + | match_globdef_varinfo: forall v v', + match_globvar match_varinfo v v' -> + match_globdef (Gvar v) (Gvar v') +. + +Remark match_globdef_refl: forall gd, + match_globdef gd gd. +Proof. + intros [[[] |]| []]; repeat constructor. +Qed. + +Definition kept_genv (s: split) (ge: genv) (δ: side) (id: ident): bool := + match Genv.find_symbol ge id with + | Some b => + match (Genv.genv_defs ge)!b with + | None => false + | Some gd => side_eq (s (comp_of gd)) δ + end + | None => false + end. + +Definition kept_prog (s: split) (p: program) (δ: side) (id: ident): bool := + kept_genv s (Genv.globalenv p) δ id. + +Record match_prog (s: split) (δ: side) (p p__recomp: program): Prop := { + match_prog_main: + p__recomp.(prog_main) = p.(prog_main); + match_prog_public: + p__recomp.(prog_public) = p.(prog_public); + match_prog_pol: + p__recomp.(prog_pol) = p.(prog_pol); + match_prog_def: + forall id, + kept_prog s p δ id = true -> + (prog_defmap p__recomp)!id = (prog_defmap p)!id; + match_prog_notdef: + forall id, + kept_prog s p δ id = false -> + option_rel match_globdef (prog_defmap p)!id (prog_defmap p__recomp)!id ; + (* This means that anything defined as public must be defined both in [p] and [p__recomp] *) + match_prog_unique: + list_norepet (prog_defs_names p__recomp) + }. + +Section MEMINJ. + + Variable s: split. + Variable δ: side. + + Variable p p__recomp: program. + Hypothesis MATCH: match_prog s δ p p__recomp. + + + Let ge := (Genv.globalenv p). + Let ge__recomp := (Genv.globalenv p__recomp). + + Lemma transform_find_symbol_1: + forall id b, + Genv.find_symbol ge id = Some b -> + exists b', Genv.find_symbol ge__recomp id = Some b'. + Proof. + intros id b H. + assert (A: exists g, (prog_defmap p)!id = Some g). + { apply prog_defmap_dom. eapply Genv.find_symbol_inversion; eauto. } + destruct A as (g & P). + destruct (kept_prog s p δ id) eqn:ktept. + - apply Genv.find_symbol_exists with g. + apply in_prog_defmap. + erewrite match_prog_def by eauto. auto. + - exploit match_prog_notdef; eauto. + intros G; inv G; try congruence. + eapply Genv.find_symbol_exists. + apply in_prog_defmap; eauto. + Qed. + + Lemma transform_find_symbol_2: + forall id b, + Genv.find_symbol ge__recomp id = Some b -> + exists b', Genv.find_symbol ge id = Some b'. + Proof. + intros id b H. + assert (A: exists g, (prog_defmap p__recomp)!id = Some g). + { apply prog_defmap_dom. eapply Genv.find_symbol_inversion; eauto. } + destruct A as (g & P). + destruct (kept_genv s ge δ id) eqn:kept. + - erewrite match_prog_def in P by eauto. + apply Genv.find_symbol_exists with g. + apply in_prog_defmap. auto. + - exploit match_prog_notdef; eauto. + intros G; inv G; try congruence. + eapply Genv.find_symbol_exists. + apply in_prog_defmap; eauto. + Qed. + + Lemma match_prog_comp_of_main: + comp_of_main p__recomp = comp_of_main p. + Proof. + Admitted. + + + (** Injections that preserve used globals. *) + Record meminj_preserves_globals (j: meminj): Prop := { + symbols_inject1: forall id b b' delta, + j b = Some (b', delta) -> + Genv.find_symbol ge id = Some b -> + delta = 0 /\ Genv.find_symbol ge__recomp id = Some b'; + symbols_inject2: forall id b, + Genv.find_symbol ge id = Some b -> + exists b', Genv.find_symbol ge__recomp id = Some b' /\ j b = Some(b', 0); + symbols_inject3: forall id b', + Genv.find_symbol ge__recomp id = Some b' -> + exists b, Genv.find_symbol ge id = Some b /\ j b = Some (b', 0); + defs_inject: forall b b' delta gd, + j b = Some(b', delta) -> Genv.find_def ge b = Some gd -> + exists gd', Genv.find_def ge__recomp b' = Some gd' /\ + delta = 0 /\ + match_globdef gd gd' /\ + (forall id, Genv.find_symbol ge id = Some b -> kept_genv s ge δ id = true -> + gd' = gd); + defs_rev_inject: forall b b' delta gd, + j b = Some(b', delta) -> Genv.find_def ge__recomp b' = Some gd -> + exists gd', Genv.find_def ge b = Some gd' /\ delta = 0 /\ match_globdef gd' gd; + }. + + Definition init_meminj: meminj := + fun b => + match Genv.invert_symbol ge b with + | Some id => + match Genv.find_symbol ge__recomp id with + | Some b' => Some (b', 0) + | None => None + end + | None => None + end. + + Remark init_meminj_eq: + forall id b b', + Genv.find_symbol ge id = Some b -> Genv.find_symbol ge__recomp id = Some b' -> + init_meminj b = Some(b', 0). + Proof. + intros. unfold init_meminj. erewrite Genv.find_invert_symbol by eauto. + rewrite H0. auto. + Qed. + + Remark init_meminj_invert: + forall b b' delta, + init_meminj b = Some(b', delta) -> + delta = 0 /\ exists id, Genv.find_symbol ge id = Some b /\ Genv.find_symbol ge__recomp id = Some b'. + Proof. + unfold init_meminj; intros. + destruct (Genv.invert_symbol ge b) as [id|] eqn:S; try discriminate. + destruct (Genv.find_symbol ge__recomp id) as [b''|] eqn:F; inv H. + split. auto. exists id. split. apply Genv.invert_find_symbol; auto. auto. + Qed. + + Lemma init_meminj_preserves_globals: + meminj_preserves_globals init_meminj. + Proof. + constructor; intros. + - exploit init_meminj_invert; eauto. intros (A & id1 & B & C). + assert (id1 = id) by (eapply (Genv.genv_vars_inj ge); eauto). subst id1. + auto. + - exploit transform_find_symbol_1; eauto. intros (b' & F). exists b'; split; auto. + eapply init_meminj_eq; eauto. + - exploit transform_find_symbol_2; eauto. intros (b & F). + exists b; split; auto. eapply init_meminj_eq; eauto. + - exploit init_meminj_invert; eauto. intros (A & id & B & C). + destruct (kept_genv s ge δ id) eqn:kept. + + assert ((prog_defmap p)!id = Some gd). + { rewrite Genv.find_def_symbol. exists b; auto. } + assert ((prog_defmap p__recomp)!id = Some gd). + { erewrite match_prog_def by eauto. auto. } + rewrite Genv.find_def_symbol in H2. destruct H2 as (b1 & P & Q). + fold ge__recomp in P. replace b' with b1 by congruence. + exists gd. split; auto. split; auto. split; auto. + apply match_globdef_refl. + + assert ((prog_defmap p)!id = Some gd). + { rewrite Genv.find_def_symbol. exists b; auto. } + exploit match_prog_notdef; eauto. + intros G; inv G; try congruence. + assert (x = gd) by congruence; subst x. + symmetry in H3. rewrite Genv.find_def_symbol in H3. destruct H3 as (b1 & P & Q). + fold ge__recomp in P. replace b' with b1 by congruence. + eexists. split; eauto. split; auto. split; auto. + intros id' D. apply Genv.find_invert_symbol in B, D. + assert (id = id') by congruence; subst id'. congruence. + - exploit init_meminj_invert; eauto. intros (A & id & B & C). + destruct (kept_genv s ge δ id) eqn:kept. + + assert ((prog_defmap p__recomp)!id = Some gd). + { rewrite Genv.find_def_symbol. exists b'; auto. } + exists gd; split; [| split]; auto using match_globdef_refl. + erewrite match_prog_def in H1 by eauto. + rewrite Genv.find_def_symbol in H1. destruct H1 as (b1 & P & Q). + fold ge in P. replace b with b1 by congruence. auto. + + pose proof Genv.find_def_symbol as F. + exploit Genv.find_symbol_find_def_inversion; eauto. + intros (gd_recomp & find_gd_recomp). + exploit Genv.find_symbol_find_def_inversion; [exact B|]. + intros (gd_base & find_gd_base). + assert (H1: exists b, Genv.find_symbol (Genv.globalenv p) id = Some b /\ + Genv.find_def (Genv.globalenv p) b = Some gd_base) by eauto. + assert (H2: exists b, Genv.find_symbol (Genv.globalenv p__recomp) id = Some b /\ + Genv.find_def (Genv.globalenv p__recomp) b = Some gd_recomp) by eauto. + apply F in H1, H2. + assert (gd = gd_recomp) by (unfold ge__recomp in *; congruence). subst gd_recomp. + eexists; split; [| split]; eauto. + exploit match_prog_notdef; eauto. rewrite H1, H2; intros D. + inv D; auto. + Qed. + + Lemma symbol_address_inject: + forall j id ofs, + meminj_preserves_globals j -> + Val.inject j (Genv.symbol_address ge id ofs) (Genv.symbol_address ge__recomp id ofs). + Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. + exploit symbols_inject2; eauto. intros (b' & TFS & INJ). rewrite TFS. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. + Qed. + + Lemma globals_symbols_inject: + forall j, meminj_preserves_globals j -> symbols_inject j ge ge__recomp. + Proof. + intros. + assert (E1: Genv.genv_public ge = p.(prog_public)). + { unfold ge. apply Genv.globalenv_public. } + assert (E2: Genv.genv_public ge__recomp = p.(prog_public)). + { unfold ge__recomp; rewrite Genv.globalenv_public. eapply match_prog_public; eauto. } + split; [|split;[|split]]; intros. + + simpl; unfold Genv.public_symbol; rewrite E1, E2. + destruct (Genv.find_symbol ge__recomp id) as [b'|] eqn:TFS. + exploit symbols_inject3; eauto. intros (b & FS & INJ). rewrite FS. auto. + destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. + destruct (in_dec ident_eq id (prog_public p)); simpl; auto. + exploit symbols_inject2; eauto. + intros (b' & TFS' & INJ). congruence. + + eapply symbols_inject1; eauto. + + simpl in *; unfold Genv.public_symbol in H0. + destruct (Genv.find_symbol ge id) as [b|] eqn:FS; try discriminate. + rewrite E1 in H0. + destruct (in_dec ident_eq id (prog_public p)); try discriminate. inv H1. + exploit symbols_inject2; eauto. + intros (b' & A & B); exists b'; auto. + + simpl. unfold Genv.block_is_volatile. + destruct (Genv.find_var_info ge b1) as [[c gv]|] eqn:V1. + rewrite Genv.find_var_info_iff in V1. + exploit defs_inject; eauto. intros (gd & A & B & C & D). + inv C. inv H2. + rewrite <- Genv.find_var_info_iff in A. rewrite A; auto. + destruct (Genv.find_var_info ge__recomp b2) as [[c gv]|] eqn:V2; auto. + rewrite Genv.find_var_info_iff in V2. + exploit defs_rev_inject; eauto. intros (gd & A & B & C). + inv C. + rewrite <- Genv.find_var_info_iff in A. congruence. + Qed. + +End MEMINJ. +Section Invariants. + Variable s: split. + Variable cp_main: compartment. + + Variant stackframe_rel (ge3: genv) (δ: side) (j__δ j__oppδ: meminj): stackframe -> stackframe -> stackframe -> Prop := + | stackframe_related_δ: forall cp sg b1 b2 b3 sp1 sp2 sp3 ofs1 ofs2 ofs3, + Genv.find_comp_of_block ge3 b3 = cp -> + s cp = δ -> + Val.inject j__δ (Vptr b1 ofs1) (Vptr b3 ofs3) -> + (* Val.inject j__oppδ (Vptr b2 ofs2) (Vptr b3 ofs3) -> *) + Val.inject j__δ sp1 sp3 -> + stackframe_rel ge3 δ j__δ j__oppδ + (Stackframe b1 sg sp1 ofs1) + (Stackframe b2 sg sp2 ofs2) + (Stackframe b3 sg sp3 ofs3) + | stackframe_related_opp_δ: forall cp sg b1 b2 b3 sp1 sp2 sp3 ofs1 ofs2 ofs3, + Genv.find_comp_of_block ge3 b3 = cp -> + s cp = opposite δ -> + (* Val.inject j__δ (Vptr b1 ofs1) (Vptr b3 ofs3) -> *) + Val.inject j__oppδ (Vptr b2 ofs2) (Vptr b3 ofs3) -> + Val.inject j__oppδ sp2 sp3 -> + stackframe_rel ge3 δ j__δ j__oppδ + (Stackframe b1 sg sp1 ofs1) + (Stackframe b2 sg sp2 ofs2) + (Stackframe b3 sg sp3 ofs3) + . + + Inductive stack_rel (ge3: genv) (δ: side) (j__δ j__oppδ: meminj): stack -> stack -> stack -> Prop := + | stack_rel_empty: + stack_rel ge3 δ j__δ j__oppδ nil nil nil + | stack_rel_cons: forall st1 st2 st3 f1 f2 f3, + stack_rel ge3 δ j__δ j__oppδ st1 st2 st3 -> + stackframe_rel ge3 δ j__δ j__oppδ f1 f2 f3 -> + stack_rel ge3 δ j__δ j__oppδ (f1 :: st1) (f2 :: st2) (f3 :: st3) + . + + Lemma stack_rel_comm (ge3: genv) (δ: side) (j__δ j__oppδ: meminj): + forall st1 st2 st3, + stack_rel ge3 δ j__δ j__oppδ st1 st2 st3 -> + stack_rel ge3 (opposite δ) j__oppδ j__δ st2 st1 st3. + Proof. + intros st1 st2 st3 H. + induction H. + - constructor. + - constructor; eauto. + inv H0. + + eapply stackframe_related_opp_δ; eauto. + now destruct s. + + eapply stackframe_related_δ; eauto. + Qed. + + Definition regset_rel (j: meminj) (rs rs': regset): Prop := + forall r, Val.inject j (rs r) (rs' r). + + (* idea: we maintain a single injection that is only defined on the elements of δ. +This injection is going to be trivially preserved, because from elements of δ one cannot +obtain elements of (opposite δ) from it. + +Then, at crossing points we will rely on globals only containing scalars to reconstruct +a bigger injection using mem_inj_disjoint_union. This injection will satisfy +meminj_preserves_globals which will allow us to prove preservation of events. + *) + Definition same_domain (s: split) (ge: genv) (j: meminj) (δ: side) (m: mem): Prop := + forall b, (j b <> None <-> ((s, m) |= b ∈ δ) \/ exists fd, Genv.find_def ge b = Some (Gfun fd)). + + Definition mem_delta_zero (j: meminj): Prop := + forall loc loc' delta, j loc = Some (loc', delta) -> delta = 0. + + Record mem_rel (ge1 ge2: genv) (j: meminj) (δ: side) (m1 m2: mem) := + { (* Uncomment as needed *) + same_dom: same_domain s ge1 j δ m1; + + partial_mem_inject: Mem.inject j m1 m2; + + delta_zero: mem_delta_zero j; + + (* pres_globals: meminj_preserves_globals ge1 j; *) + ple_nextblock1: Ple (Senv.nextblock ge1) (Mem.nextblock m1); + ple_nextblock2: Ple (Senv.nextblock ge2) (Mem.nextblock m2); + + (* Functions *) + (* funct_preserved1: forall b fd, Genv.find_funct_ptr ge1 b = Some fd -> j b = Some (b, 0); *) + (* funct_preserved2: forall b1 b2 fd, Genv.find_funct_ptr ge2 b2 = Some fd -> j b1 = Some (b2, 0) -> b1 = b2; *) + (* Find def valid *) + find_def_valid1: forall b gd, Genv.find_def ge1 b = Some gd -> Mem.valid_block m1 b; + find_def_valid2: forall b gd, Genv.find_def ge2 b = Some gd -> Mem.valid_block m2 b; + + (* Functions perm *) + find_def_perm1: forall b fd, Genv.find_def ge1 b = Some (Gfun fd) -> forall ofs, not (Mem.perm m1 b ofs Max Readable); + find_def_perm2: forall b fd, Genv.find_def ge2 b = Some (Gfun fd) -> forall ofs, not (Mem.perm m2 b ofs Max Readable); + + same_high_half: forall id ofs, + Val.inject j (high_half ge1 id ofs) (high_half ge2 id ofs) + }. + + Inductive strong_equivalence (ge ge': genv) (j: meminj) (δ: side): state -> state -> Prop := + | strong_equivalence_State: forall st st' rs rs' m m' cp cp', + Genv.find_comp_in_genv ge (rs PC) = cp -> + s cp = δ -> + regset_rel j rs rs' -> + mem_rel ge ge' j δ m m' -> + strong_equivalence ge ge' j δ (State st rs m cp') (State st' rs' m' cp') + | strong_equivalence_ReturnState: forall st st' rs rs' m m' rec_cp, + (* careful, the current comp in a returnstate is given by [rec_cp] *) + s rec_cp = δ -> + regset_rel j rs rs' -> + mem_rel ge ge' j δ m m' -> + strong_equivalence ge ge' j δ (ReturnState st rs m rec_cp) (ReturnState st' rs' m' rec_cp) + . + + Inductive weak_equivalence (ge ge': genv) (j: meminj) (δ: side): state -> state -> Prop := + | weak_equivalence_State: forall st st' rs rs' m m' cp cp', + Genv.find_comp_in_genv ge (rs PC) = cp -> + Genv.find_comp_in_genv ge' (rs' PC) = cp -> + s cp = opposite δ -> + mem_rel ge ge' j δ m m' -> + weak_equivalence ge ge' j δ (State st rs m cp') (State st' rs' m' cp') + | weak_equivalence_ReturnState: forall st st' rs rs' m m' rec_cp, + (* careful, the current comp in a returnstate is given by [callee_comp] *) + s rec_cp = opposite δ -> + mem_rel ge ge' j δ m m' -> + weak_equivalence ge ge' j δ (ReturnState st rs m rec_cp) (ReturnState st' rs' m' rec_cp) + | weak_equivalence_State_ReturnState: forall st st' rs rs' m m' cp, + Genv.find_comp_in_genv ge (rs PC) = cp -> + s cp = opposite δ -> + mem_rel ge ge' j δ m m' -> + weak_equivalence ge ge' j δ (State st rs m cp) (ReturnState st' rs' m' cp) + | weak_equivalence_ReturnState_State: forall st st' rs rs' m m' rec_cp, + (* careful, the current comp in a returnstate is given by [callee_comp] *) + s rec_cp = opposite δ -> + Genv.find_comp_in_genv ge' (rs' PC) = rec_cp -> + mem_rel ge ge' j δ m m' -> + weak_equivalence ge ge' j δ (ReturnState st rs m rec_cp) (State st' rs' m' rec_cp) + . + + Lemma weak_equivalence_inv1 (ge ge': genv) (j: meminj) (δ: side) (s1 s3: state) : + weak_equivalence ge ge' j δ s1 s3 -> + exists st1 rs1 m1, + match s3 with + | State st3 rs3 m3 _ + | ReturnState st3 rs3 m3 _ => mem_rel ge ge' j δ m1 m3 + end /\ + s1 = match s1 with + | State _ _ _ cp => State st1 rs1 m1 cp + | ReturnState _ _ _ cp => ReturnState st1 rs1 m1 cp + end. + Proof. + intros weak_s1_s3. + inv weak_s1_s3; eauto. + Qed. + + Lemma weak_equivalence_inv (ge ge': genv) (j: meminj) (δ: side) (s1 s3: state) : + weak_equivalence ge ge' j δ s1 s3 -> + exists st1 st3 rs1 rs3 m1 m3, + mem_rel ge ge' j δ m1 m3 /\ + s1 = match s1 with + | State _ _ _ cp => State st1 rs1 m1 cp + | ReturnState _ _ _ cp => ReturnState st1 rs1 m1 cp + end /\ + s3 = match s3 with + | State _ _ _ cp => State st3 rs3 m3 cp + | ReturnState _ _ _ cp => ReturnState st3 rs3 m3 cp + end. + Proof. + intros weak_s1_s3. + inv weak_s1_s3; do 6 eexists; eauto. + Qed. + + + Definition def_on_addressable (ge: genv) (j: meminj) (δ: side) := + forall id b cp, + Genv.find_symbol ge id = Some b -> + s cp = δ -> + (Genv.find_comp_of_block ge b = cp \/ + exists fd, Genv.find_def ge b = Some (Gfun fd)) -> + exists b' delta, j b = Some (b', delta). + + Lemma def_on_addressable_incr: + forall ge j j' δ, + def_on_addressable ge j δ -> + inject_incr j j' -> + def_on_addressable ge j' δ. + Proof. + intros ge j j' δ addr incr. + intros ? ? ? ? ? ?. exploit addr; eauto. + intros (? & ? & G). apply incr in G. eauto. + Qed. + + Definition agrees_with (j1 j2: meminj) := + forall b b' b'' delta' delta'', + j1 b = Some (b', delta') -> + j2 b = Some (b'', delta'') -> + b' = b'' /\ delta' = delta''. + + Lemma agrees_with_incr1: + forall j j' b1 jref, + agrees_with j jref -> + j' b1 = None -> + (forall b : block, b <> b1 -> j' b = j b) -> + agrees_with j' jref. + Proof. + intros j j' b1 jref agr isnone diff. + intros ? ? ? ? ? ? ?. exploit agr; eauto. + rewrite diff in H; eauto. + intros ?; congruence. + Qed. + + Lemma agrees_with_incr2: + forall j j' b1 jref, + agrees_with j jref -> + jref b1 = None -> + (forall b : block, b <> b1 -> j' b = j b) -> + agrees_with j' jref. + Proof. + intros j j' b1 jref agr isnone diff. + intros ? ? ? ? ? ? ?. exploit agr; eauto. + rewrite diff in H; eauto. + intros ?; congruence. + Qed. + +End Invariants. + + +Arguments opposite /. + +Lemma store_preserves_weak: + forall s ge1 ge3 j ch cp b ofs v m1 m1' m3, + Mem.store ch m1 b ofs v cp = Some m1' -> + mem_rel s ge1 ge3 j (opposite (s cp)) m1 m3 -> + mem_rel s ge1 ge3 j (opposite (s cp)) m1' m3. +Proof. + intros s ge1 ge3 j ch cp b ofs v m1 m1' m3 exec m1_m3. + assert (j b = None). + { pose proof (same_dom _ _ _ _ _ m1 m3 m1_m3 b) as dom. + exploit Mem.store_valid_access_3; eauto. intros (_ & access_block & _). + simpl in access_block, dom, m1_m3. + rewrite access_block in dom. + destruct (j b) eqn:C; auto. + assert (H: Some p <> None) by congruence. + apply dom in H. + destruct H as [H | (id & H)]. + destruct (s cp); try congruence. + Local Transparent Mem.store. + unfold Mem.store in exec. + destruct Mem.valid_access_dec as [[e _] | n]; try congruence. + eapply Mem.range_perm_max in e. + assert (sz: ofs <= ofs < ofs + size_chunk ch) by now (destruct ch; simpl; lia). + specialize (e ofs sz). + exploit find_def_perm1; eauto. + eapply Mem.perm_implies; eauto; try constructor. + now auto. } + constructor. + - intros b'; apply same_dom in m1_m3; specialize (m1_m3 b'). + simpl in *. erewrite Mem.store_block_compartment; eauto. + - eapply Mem.store_unmapped_inject; eauto using partial_mem_inject. + - eapply delta_zero; eauto. + - erewrite Mem.nextblock_store; eauto using ple_nextblock1. + - eapply ple_nextblock2; eauto. + - intros. eapply Mem.store_valid_block_1; eauto using find_def_valid1. + - intros. eapply find_def_valid2; eauto. + - intros. eapply find_def_perm1 with (b := b0) in m1_m3; eauto. + intros n. apply m1_m3. eapply Mem.perm_store_2; eauto. + - intros. eapply find_def_perm2 with (b := b0) in m1_m3; eauto. + - intros. eapply same_high_half; eauto. +Qed. + +Lemma exec_store_preserves_weak: + forall s ge1 ge3 j cp ch m1 m1' m3 rs1 rs1' rs ra ofs, + exec_store ge1 ch rs1 m1 rs ra ofs cp = Next rs1' m1' -> + mem_rel s ge1 ge3 j (opposite (s cp)) m1 m3 -> + mem_rel s ge1 ge3 j (opposite (s cp)) m1' m3. +Proof. + intros s ge1 ge3 j cp ch m1 m1' m3 rs1 rs1' rs ra ofs exec m1_m3. + unfold exec_store in exec. + destruct Mem.storev eqn:m1_m1'; try congruence; inv exec. + destruct (rs1 ra); simpl in *; try congruence. + now eapply store_preserves_weak; eauto. +Qed. + +Lemma alloc_preserves_weak: + forall s δ W1 (_: list_norepet (prog_defs_names W1)) W3 j cp lo hi m1 m1' b1 m3, + Mem.alloc m1 cp lo hi = (m1', b1) -> + agrees_with j (init_meminj W1 W3) -> + def_on_addressable s (Genv.globalenv W1) j δ -> + mem_rel s (Genv.globalenv W1) (Genv.globalenv W3) j (opposite (s cp)) m1 m3 -> + exists j', + agrees_with j' (init_meminj W1 W3) /\ + def_on_addressable s (Genv.globalenv W1) j' δ /\ + mem_rel s (Genv.globalenv W1) (Genv.globalenv W3) j' (opposite (s cp)) m1' m3 /\ inject_incr j j'. +Proof. + intros s δ W1 norepet1 W3 j cp lo hi m1 m1' b1 m3 exec agr addr m1_m3. + exploit Mem.alloc_left_unmapped_inject; eauto using partial_mem_inject. + intros (j' & m1'_m3 & incr & j'_b1 & same_inj). + exists j'. split; [| split; [| split]]; auto. + now eapply agrees_with_incr1; eauto. + now eapply def_on_addressable_incr; eauto. + (* { assert (G: forall s δ p1 p2 j j', *) + (* meminj_preserves_globals s δ p1 p2 j -> *) + (* (forall (b: block) gd, Genv.find_def (Genv.globalenv p1) b = Some gd -> j' b = j b) -> *) + (* (forall (b b': block) delta gd, Genv.find_def (Genv.globalenv p2) b' = Some gd -> *) + (* j' b = Some (b', delta) -> *) + (* j b = Some (b', delta)) -> *) + (* inject_incr j j' -> *) + (* meminj_preserves_globals s δ p1 p2 j'). *) + (* { clear. *) + (* intros s δ p1 p2 j j' [A B C D E] rewr1 rewr2 incr. *) + (* constructor. *) + (* - intros. exploit B; eauto. intros (? & ? & ?). *) + (* exploit incr; eauto. intros ?; split; congruence. *) + (* - intros. exploit B; eauto. intros (? & ? & ?). *) + (* exploit incr; eauto. *) + (* - intros. exploit C; eauto. intros (? & ? & ?). *) + (* exploit incr; eauto. *) + (* - intros. erewrite rewr1 in H; eauto. *) + (* - intros. eapply rewr2 in H; eauto. } *) + (* eapply G; eauto. *) + (* - clear G. *) + (* intros. eapply same_inj. *) + (* eapply find_def_valid1 in m1_m3; eauto. unfold Mem.valid_block in m1_m3. *) + (* eapply Mem.alloc_result in exec; subst. intros N; subst b; exploit Plt_strict; eauto. *) + (* - clear G. *) + (* intros. rewrite <- same_inj; eauto. *) + (* eapply find_def_valid2 in m1_m3; eauto. unfold Mem.valid_block in m1_m3. *) + (* eapply Mem.alloc_result in exec; subst. intros N; subst b. *) + (* assert (b' = Mem.nextblock m3) by congruence. subst b'. *) + (* now exploit Plt_strict; eauto. } *) + (* split; auto. *) + constructor. + - intros b; apply same_dom in m1_m3; specialize (m1_m3 b). + simpl in *. + erewrite Mem.alloc_block_compartment; eauto. + destruct eq_block; try congruence; [| rewrite same_inj; auto]. + subst b1. rewrite j'_b1. + assert (H: j b = None). + { destruct (j b) as [[]|] eqn:?; auto. + exploit incr; eauto. congruence. } + rewrite H in m1_m3. + destruct (s cp); simpl in *; intuition congruence. + - auto. + - intros b b' delta. + destruct (eq_block b b1); try congruence. + rewrite same_inj; eauto. + eapply delta_zero; eauto. + - apply ple_nextblock1 in m1_m3. erewrite Mem.nextblock_alloc; eauto using ple_nextblock1. + eapply Ple_trans; eauto using Ple_succ. + - eapply ple_nextblock2; eauto. + - intros. eapply Mem.valid_block_alloc; eauto using find_def_valid1. + - intros. eapply find_def_valid2; eauto. + - intros. + pose proof (ple_nextblock1 _ _ _ _ _ m1 m3 m1_m3) as ple. + eapply find_def_perm1 with (b := b) in m1_m3; eauto. + intros n. apply m1_m3. + eapply Mem.perm_alloc_4; eauto. + eapply Genv.find_def_find_symbol_inversion in H as [id H]; eauto. + exploit (Senv.find_symbol_below (Genv.globalenv W1)); eauto. intros ?. + exploit Mem.alloc_result; eauto. intros ->. + intros ->. eapply Plt_strict. + eapply Plt_Ple_trans; eauto. + - intros. eapply find_def_perm2; eauto. + - intros id ofs. eapply val_inject_incr; eauto using same_high_half. +Qed. + +Lemma extcall_preserves_mem_rel_same_side: + forall s ge1 ge3 j j' m1 m1' m3 m3' ef vres vres' t vargs vargs' δ, + Mem.unchanged_on (loc_unmapped j) m1 m1' -> + inject_incr j j' -> + inject_separated j j' m1 m3 -> + (forall b : block, + (Mem.valid_block m1 b -> False) -> + Mem.valid_block m1' b -> + exists b' : block, + j' b = Some (b', 0) /\ Mem.block_compartment m1' b = Some (comp_of ef)) -> + s (comp_of ef) = δ -> + mem_rel s ge1 ge3 j δ m1 m3 -> + Mem.inject j' m1' m3' -> + external_call ef ge1 vargs m1 t vres m1' -> + external_call ef ge3 vargs' m3 t vres' m3' -> + mem_rel s ge1 ge3 j' δ m1' m3'. +Proof. + intros s ge1 ge3 j j' m1 m1' m3 m3' ef vres vres' t vargs vargs' δ + unchanged inj_incr inj_sep comp_new comp_ef m1_m3 inj_m1'_m3' extcall1 extcall3. + constructor. + - (* same domain *) + intros b. apply same_dom in m1_m3. specialize (m1_m3 b). + destruct (j b) as [[] |] eqn:j_b. + + apply inj_incr in j_b. + split; try congruence. + intros _. destruct m1_m3 as [side_b _]. + exploit side_b; try congruence. + simpl. destruct (Mem.block_compartment m1 b) eqn:?; try contradiction. intros ?. + pose proof (ec_can_access_block (external_call_spec _) _ _ _ _ _ _ b (Some c) extcall1) as G. + simpl in G. rewrite G; auto. + intros [? | ?]; try contradiction. right; auto. + + destruct m1_m3 as [C1 C2]. + simpl in C1, C2; simpl. + split. + * destruct (j' b) as [[] |] eqn:j'_b; try congruence; intros _. + exploit inj_sep; eauto. + intros [H _]. + assert (Mem.valid_block m1' b). + { pose proof (Mem.mi_freeblocks _ _ _ inj_m1'_m3' b) as G. + apply Classical_Prop.NNPP. + intros ?. exploit G; eauto. congruence. } + exploit comp_new; eauto. intros [? [? ->]]. + auto. + * clear C1. + destruct (Mem.block_compartment m1 b) as [cp |] eqn:cp_b. + { destruct (side_eq (s cp) δ) eqn:?; [exploit C2; eauto|]. + assert (Mem.valid_block m1 b). + { unfold Mem.valid_block. + pose proof (Mem.nextblock_compartments m1 b) as G. + apply proj1 in G. apply Classical_Prop.NNPP. + intros H. apply G in H. + now unfold Mem.block_compartment in cp_b; congruence. } + apply Mem.unchanged_on_own with (b := b) (cp := Some cp) in unchanged; auto. + simpl in unchanged. + rewrite unchanged in cp_b. rewrite cp_b. intros A; specialize (C2 A); congruence. } + (* clear C2. *) + destruct (Mem.block_compartment m1' b) as [cp |] eqn:cp_b'; + [| intros A; specialize (C2 A); congruence]. + intros [H | H]. + -- assert (Mem.valid_block m1' b). + { unfold Mem.valid_block. + pose proof (Mem.nextblock_compartments m1' b) as G. + apply proj1 in G. apply Classical_Prop.NNPP. + intros X. apply G in X. + now unfold Mem.block_compartment in cp_b'; congruence. } + assert (~ Mem.valid_block m1 b). + { unfold Mem.valid_block. + pose proof (Mem.nextblock_compartments m1 b) as G. + apply G. auto. } + exploit comp_new; eauto. + intros [? [? ?]]. congruence. + -- now specialize (C2 (or_intror H)). + - (* injection *) + assumption. + - (* Delta zero *) + intros b b' delta j'_b. + apply delta_zero in m1_m3; eauto. + destruct (j b) as [[] |] eqn:j_b. + + exploit m1_m3; eauto. intros ->. exploit inj_incr; eauto. intros. congruence. + + exploit inj_sep; eauto. + intros [? ?]. + assert (Mem.valid_block m1' b). + { pose proof (Mem.mi_freeblocks _ _ _ inj_m1'_m3' b) as G. + apply Classical_Prop.NNPP. + intros ?. exploit G; eauto. congruence. } + exploit comp_new; eauto. intros [? [? ?]]; congruence. + - (* Ple nextblock 1 *) + eapply Ple_trans. eapply ple_nextblock1; eauto. eapply external_call_nextblock; eauto. + - (* Ple nextblock 2 *) + eapply Ple_trans. eapply ple_nextblock2; eauto. eapply external_call_nextblock; eauto. + - (* find_def valid 1 *) + intros. + eapply external_call_valid_block; eauto. + eapply find_def_valid1; eauto. + - (* find_def valid 2 *) + intros. + eapply external_call_valid_block; eauto. + eapply find_def_valid2; eauto. + - intros. intros n. eapply external_call_max_perm in n; eauto. + exploit find_def_perm1; eauto. + eapply find_def_valid1; eauto. + - intros. intros n. eapply external_call_max_perm in n; eauto. + exploit find_def_perm2; eauto. + eapply find_def_valid2; eauto. + - (* same high half *) + intros. eapply same_high_half in m1_m3; eauto. +Qed. + +Lemma extcall_preserves_mem_rel_opp_side1: forall s ge1 ge3 j δ m1 m1' m3 ef vargs t vres, + s (comp_of ef) = opposite δ -> + mem_rel s ge1 ge3 j δ m1 m3 -> + external_call ef ge1 vargs m1 t vres m1' -> + mem_rel s ge1 ge3 j δ m1' m3. +Proof. + intros s ge1 ge3 j δ m1 m1' m3 ef vargs t vres side_ef m1_m3 extcall. + constructor. + - (* same domain *) + intros b. apply same_dom in m1_m3. specialize (m1_m3 b). + destruct (j b) as [[] |] eqn:j_b. + + split; try congruence. + intros _. destruct m1_m3 as [side_b _]. + exploit side_b; try congruence. + simpl. destruct (Mem.block_compartment m1 b) eqn:?; try contradiction. intros ?. + pose proof (ec_can_access_block (external_call_spec _) _ _ _ _ _ _ b (Some c) extcall) as G. + simpl in G. rewrite G; auto. + admit. + + destruct m1_m3 as [C1 C2]. + simpl in C1, C2; simpl. + split. + * congruence. + * admit. + - (* injection *) + exploit ec_mem_outside_compartment; eauto using external_call_spec. + intros unchanged. exploit partial_mem_inject; eauto. + apply same_dom in m1_m3. rename m1_m3 into dom_j_m1. + intros m1_m3. + constructor. + + apply Mem.mi_inj in m1_m3 as mi_inj_m1_m3. + constructor. + * intros b1 b2 delta ofs k p j_b1 perm1. + assert (loc_not_in_compartment (comp_of ef) m1 b1 ofs). + { unfold loc_not_in_compartment. + assert (G: j b1 <> None) by congruence. + apply dom_j_m1 in G. simpl in G. + destruct (Mem.block_compartment m1 b1) eqn:?; try congruence. + fold (Mem.can_access_block m1 b1 (Some c)) in Heqo. + exploit Mem.can_access_block_inj; eauto. + simpl. intros ?. admit. } + eapply Mem.mi_perm; eauto. + eapply Mem.perm_unchanged_on_2; eauto. + eapply Mem.valid_block_inject_1; eauto. + * intros b1 b2 delta cp j_b1 b1_cp. + exploit Mem.can_access_block_inj; eauto. + rewrite Mem.unchanged_on_own; eauto. + eapply Mem.valid_block_inject_1; eauto. + * intros b1 b2 delta chunk ofs p j_b1 range_perm. + eapply Mem.mi_align; eauto. + admit. + * admit. + + intros b not_valid_m1. + eapply Mem.mi_freeblocks; eauto. intros ?. + exploit ec_valid_block; eauto using external_call_spec. + + intros b b' delta j_b. + eapply Mem.mi_mappedblocks; eauto. + + intros b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 b1_b2 j_b1 j_b2 perm_b1 perm_b2. + exploit Mem.mi_no_overlap; eauto. + eapply Mem.perm_unchanged_on_2; eauto. admit. admit. + eapply Mem.perm_unchanged_on_2; eauto. admit. admit. + + intros b b' delta ofs j_b [perm | perm]. + * eapply Mem.mi_representable; eauto. admit. + * eapply Mem.mi_representable; eauto. admit. + + admit. + - (* Delta zero *) + intros b b' delta j'_b. + apply delta_zero in m1_m3; eauto. + - (* Ple nextblock 1 *) + eapply Ple_trans. eapply ple_nextblock1; eauto. eapply external_call_nextblock; eauto. + - (* Ple nextblock 2 *) + eapply ple_nextblock2; eauto. + - (* find_def valid 1 *) + intros. eapply external_call_valid_block; eauto. + eapply find_def_valid1; eauto. + - (* find_def valid 2 *) + eapply find_def_valid2; eauto. + - (* find def perm 1 *) + intros. intros n. eapply external_call_max_perm in n; eauto. + exploit find_def_perm1; eauto. + eapply find_def_valid1; eauto. + - (* find def perm 2 *) + eapply find_def_perm2; eauto. + - (* same high half *) + intros. eapply same_high_half in m1_m3; eauto. +Admitted. + +Lemma extcall_preserves_mem_rel_opp_side2: forall s ge1 ge3 j δ m1 m3 m3' ef vargs t vres, + s (comp_of ef) = opposite δ -> + mem_rel s ge1 ge3 j δ m1 m3 -> + external_call ef ge3 vargs m3 t vres m3' -> + mem_rel s ge1 ge3 j δ m1 m3'. +Proof. + intros s ge1 ge3 j δ m1 m3 m3' ef vargs t vres side_ef m1_m3 extcall. + constructor. + - (* same dom *) + eapply same_dom in m1_m3; eauto. + - (* injection *) + exploit ec_mem_outside_compartment; eauto using external_call_spec. + intros unchanged. exploit partial_mem_inject; eauto. + apply same_dom in m1_m3. rename m1_m3 into dom_j_m1. + intros m1_m3. + constructor. + + apply Mem.mi_inj in m1_m3 as mi_inj_m1_m3. + constructor. + * intros b1 b2 delta ofs k p j_b1 perm1. + eapply Mem.perm_unchanged_on; eauto. + { unfold loc_not_in_compartment. + assert (G: j b1 <> None) by congruence. + apply dom_j_m1 in G. simpl in G. + destruct G as [G | G]. + destruct (Mem.block_compartment m1 b1) eqn:?; try congruence. + fold (Mem.can_access_block m1 b1 (Some c)) in Heqo. + exploit Mem.can_access_block_inj; eauto. + simpl. intros ->. + destruct δ; simpl in *; congruence. + admit. + } + eapply Mem.mi_perm; eauto. + * intros b1 b2 delta cp j_b1 b1_cp. + rewrite <- Mem.unchanged_on_own; eauto. + { exploit Mem.can_access_block_inj; eauto. } + eapply Mem.valid_block_inject_2; eauto. + * intros b1 b2 delta chunk ofs p j_b1 range_perm. + eapply Mem.mi_align; eauto. + * intros b1 ofs b2 delta j_b1 perm. + erewrite Mem.unchanged_on_contents with (m_after := m3') (m_before := m3); eauto using Mem.mi_memval. + { unfold loc_not_in_compartment. + assert (G: j b1 <> None) by congruence. + apply dom_j_m1 in G. simpl in G. + destruct (Mem.block_compartment m1 b1) eqn:?; try congruence. + fold (Mem.can_access_block m1 b1 (Some c)) in Heqo. + exploit Mem.can_access_block_inj; eauto. + simpl. intros ->. admit. admit. } + eapply Mem.mi_perm; eauto. + + intros b not_valid_m1. + now eapply Mem.mi_freeblocks; eauto. + + intros b b' delta j_b. + exploit ec_valid_block; eauto using external_call_spec. + eapply Mem.mi_mappedblocks; eauto. + + intros b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 b1_b2 j_b1 j_b2 perm_b1 perm_b2. + eapply Mem.mi_no_overlap; eauto. + + intros b b' delta ofs j_b [perm | perm]. + * eapply Mem.mi_representable; eauto. + * eapply Mem.mi_representable; eauto. + + intros b1 ofs b2 delta k p j_b1 perm. + exploit Mem.mi_perm_inv; eauto. + exploit Mem.perm_unchanged_on_2; eauto. + { unfold loc_not_in_compartment. + assert (G: j b1 <> None) by congruence. + apply dom_j_m1 in G. simpl in G. + destruct (Mem.block_compartment m1 b1) eqn:?; try congruence. + fold (Mem.can_access_block m1 b1 (Some c)) in Heqo. + exploit Mem.can_access_block_inj; eauto using Mem.mi_inj. + simpl. intros ->. admit. admit. } + eapply Mem.valid_block_inject_2; eauto. + - (* Delta zero *) + intros b b' delta j'_b. + apply delta_zero in m1_m3; eauto. + - (* Ple nextblock 1 *) + eapply ple_nextblock1; eauto. + - (* Ple nextblock 2 *) + eapply Ple_trans. eapply ple_nextblock2; eauto. eapply external_call_nextblock; eauto. + - (* find_def valid 1 *) + intros. eapply find_def_valid1; eauto. + - (* find_def valid 2 *) + intros. eapply external_call_valid_block; eauto. + eapply find_def_valid2; eauto. + - (* find_def perm 1 *) + intros. eapply find_def_perm1; eauto. + - (* find_def valid 2 *) + intros. intros n. eapply external_call_max_perm in n; eauto. + exploit find_def_perm2; eauto. + eapply find_def_valid2; eauto. + - (* same high half *) + intros. eapply same_high_half in m1_m3; eauto. +Admitted. + +(** Useful simplification tactic *) +(** Taken from Asmgenproof1.v *) + +Ltac Simplif := + ((rewrite Asmgenproof0.nextinstr_inv by eauto with asmgen) + || (rewrite Asmgenproof0.nextinstr_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite Asmgenproof0.nextinstr_pc) + || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +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. + +(* Some tactics *) +Ltac simpl_nextinstr_PC r := + destruct (Pregmap.elt_eq r PC); + [subst r; Simpl; eapply Val.offset_ptr_inject; eauto| + Simpl]. + +Lemma ptrofs_of_int_zero: + Ptrofs.of_int Int.zero = Ptrofs.zero. +Proof. + Local Transparent Ptrofs.repr Int.repr. + simpl. + Local Opaque Ptrofs.repr Int.repr. + reflexivity. +Qed. + +Lemma lt_xx_false: forall x, + Int.lt x x = false. +Proof. + intros. unfold Int.lt. apply zlt_false. lia. +Qed. + +Lemma ltu_xx_false: forall x, + Int.ltu x x = false. +Proof. + intros. unfold Int.ltu. apply zlt_false. lia. +Qed. + +Lemma lt64_xx_false: forall x, + Int64.lt x x = false. +Proof. + intros. unfold Int64.lt. apply zlt_false. lia. +Qed. + +Lemma ltu64_xx_false: forall x, + Int64.ltu x x = false. +Proof. + intros. unfold Int64.ltu. apply zlt_false. lia. +Qed. + +(* Comparisons *) + +(* TODO: rename variables *) +Lemma cmpu_bool_preserved: forall s ge ge' j δ m1' m3 v1 v2 v1' v2' op b, + mem_rel s ge ge' j δ m1' m3 -> + Val.inject j v1 v1' -> + Val.inject j v2 v2' -> + Val.cmpu_bool (Mem.valid_pointer m1') op v1 v2 = Some b -> + Val.cmpu_bool (Mem.valid_pointer m3) op v1' v2' = Some b. +Proof. + intros until b. intros m1_m3 inj1 inj2. + inv inj1; simpl; inv inj2; simpl; destruct Archi.ptr64; simpl; auto; try congruence. + - destruct Int.eq; simpl; try congruence. destruct Mem.valid_pointer eqn:valid; simpl; try congruence. + eapply Mem.valid_pointer_inject_val in valid; eauto using partial_mem_inject; rewrite valid; simpl; auto. + clear valid. destruct Mem.valid_pointer eqn:valid'; simpl; try congruence. + assert (delta = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid'; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid'. rewrite valid'. + now rewrite orb_true_r. + - destruct Int.eq; simpl; try congruence. destruct Mem.valid_pointer eqn:valid; simpl; try congruence. + eapply Mem.valid_pointer_inject_val in valid; eauto using partial_mem_inject; rewrite valid; simpl; auto. + clear valid. destruct Mem.valid_pointer eqn:valid'; simpl; try congruence. + assert (delta = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid'; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid'. rewrite valid'. + now rewrite orb_true_r. + - destruct eq_block; subst; simpl in *; try congruence. + + assert (b3 = b2) by congruence; subst; simpl. + assert (delta = delta0) by congruence; subst; simpl. + destruct eq_block; try congruence. + destruct Mem.valid_pointer eqn:valid; simpl; try congruence. + eapply Mem.valid_pointer_inject_val in valid; eauto using partial_mem_inject; rewrite valid; simpl; auto. + clear valid. + destruct Mem.valid_pointer eqn:valid'; simpl; try congruence. + assert (delta0 = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid'; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid'. rewrite valid'. rewrite Ptrofs.add_zero; auto. + clear valid'. + destruct Mem.valid_pointer eqn:valid''; simpl; try congruence. + assert (delta0 = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid''; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid''. rewrite valid''. rewrite Ptrofs.add_zero; auto. + now rewrite orb_true_r. + clear valid. + destruct Mem.valid_pointer eqn:valid'; simpl; try congruence. + assert (delta0 = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid'; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid'. rewrite valid'. rewrite Ptrofs.add_zero; auto. + rewrite orb_true_r. simpl. + clear valid'. + destruct Mem.valid_pointer eqn:valid''; simpl; try congruence. + eapply Mem.valid_pointer_inject in valid''; eauto using partial_mem_inject. + rewrite Z.add_0_r in valid''. rewrite valid''. now auto. + clear valid''. + destruct Mem.valid_pointer eqn:valid'''; simpl; try congruence. + eapply Mem.valid_pointer_inject in valid'''; eauto using partial_mem_inject. + rewrite Z.add_0_r in valid'''. rewrite valid'''. + now rewrite orb_true_r. + + destruct eq_block; subst; simpl in *. + * destruct Mem.valid_pointer eqn:valid; simpl; try congruence. + destruct (Mem.valid_pointer m1' b0) eqn:valid'; simpl; try congruence. + assert (delta = 0) by (eapply delta_zero; eauto); subst. + assert (delta0 = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.mi_no_overlap with (f := j) in n; [| now eapply partial_mem_inject; eauto]. + specialize (n H H0 (Mem.perm_cur_max _ _ _ _ ((proj1 (Mem.valid_pointer_nonempty_perm _ _ _)) valid)) + (Mem.perm_cur_max _ _ _ _ ((proj1 (Mem.valid_pointer_nonempty_perm _ _ _)) valid'))); + rewrite !Z.add_0_r in n. + destruct n; [contradiction |]. + eapply Mem.valid_pointer_inject_val in valid; eauto using partial_mem_inject; rewrite valid; simpl; auto. + eapply Mem.valid_pointer_inject_val in valid'; eauto using partial_mem_inject; rewrite valid'; simpl; auto. + destruct op; simpl; try congruence. + intros. inv H2. rewrite !Ptrofs.add_zero. unfold Ptrofs.eq. destruct zeq; auto; congruence. + intros. inv H2. rewrite !Ptrofs.add_zero. unfold Ptrofs.eq. destruct zeq; auto; congruence. + * destruct Mem.valid_pointer eqn:valid; simpl; try congruence. + eapply Mem.valid_pointer_inject_val in valid; eauto using partial_mem_inject; rewrite valid; simpl; auto. + clear valid. + destruct Mem.valid_pointer eqn:valid'; simpl; try congruence. + assert (delta = 0) by (eapply delta_zero; eauto); subst. + assert (delta0 = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid'; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid'. rewrite valid'. auto. +Qed. + + +Lemma cmpu_inject: + forall s ge ge' j δ op m1 m3 v1 v1' v2 v2', + mem_rel s ge ge' j δ m1 m3 -> + Val.inject j v1 v1' -> + Val.inject j v2 v2' -> + Val.inject j (Val.cmpu (Mem.valid_pointer m1) op v1 v2) + (Val.cmpu (Mem.valid_pointer m3) op v1' v2'). +Proof. + intros s ge ge' j δ op m1 m3 v1 v1' v2 v2' m1_m3 v1_v1' v2_v2'. + unfold Val.cmpu. + destruct (Val.cmpu_bool) eqn:eq_cmpu. + - eapply cmpu_bool_preserved in eq_cmpu; eauto. rewrite eq_cmpu; now eapply Cminorgenproof.val_inject_val_of_optbool. + - auto. +Qed. + +(* TODO: this is the same proof as [cmpu_bool_preserved] above, but with [Int64] substituted for [Int] *) +Lemma cmplu_bool_preserved: forall s ge ge' j δ m1' m3 v1 v2 v1' v2' op b, + mem_rel s ge ge' j δ m1' m3 -> + Val.inject j v1 v1' -> + Val.inject j v2 v2' -> + Val.cmplu_bool (Mem.valid_pointer m1') op v1 v2 = Some b -> + Val.cmplu_bool (Mem.valid_pointer m3) op v1' v2' = Some b. +Proof. + intros until b. intros m1_m3 inj1 inj2. + inv inj1; simpl; inv inj2; simpl; destruct Archi.ptr64; simpl; auto; try congruence. + - destruct Int64.eq; simpl; try congruence. destruct Mem.valid_pointer eqn:valid; simpl; try congruence. + eapply Mem.valid_pointer_inject_val in valid; eauto using partial_mem_inject; rewrite valid; simpl; auto. + clear valid. destruct Mem.valid_pointer eqn:valid'; simpl; try congruence. + assert (delta = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid'; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid'. rewrite valid'. + now rewrite orb_true_r. + - destruct Int64.eq; simpl; try congruence. destruct Mem.valid_pointer eqn:valid; simpl; try congruence. + eapply Mem.valid_pointer_inject_val in valid; eauto using partial_mem_inject; rewrite valid; simpl; auto. + clear valid. destruct Mem.valid_pointer eqn:valid'; simpl; try congruence. + assert (delta = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid'; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid'. rewrite valid'. + now rewrite orb_true_r. + - destruct eq_block; subst; simpl in *; try congruence. + + assert (b3 = b2) by congruence; subst; simpl. + assert (delta = delta0) by congruence; subst; simpl. + destruct eq_block; try congruence. + destruct Mem.valid_pointer eqn:valid; simpl; try congruence. + eapply Mem.valid_pointer_inject_val in valid; eauto using partial_mem_inject; rewrite valid; simpl; auto. + clear valid. + destruct Mem.valid_pointer eqn:valid'; simpl; try congruence. + assert (delta0 = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid'; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid'. rewrite valid'. rewrite Ptrofs.add_zero; auto. + clear valid'. + destruct Mem.valid_pointer eqn:valid''; simpl; try congruence. + assert (delta0 = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid''; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid''. rewrite valid''. rewrite Ptrofs.add_zero; auto. + now rewrite orb_true_r. + clear valid. + destruct Mem.valid_pointer eqn:valid'; simpl; try congruence. + assert (delta0 = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid'; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid'. rewrite valid'. rewrite Ptrofs.add_zero; auto. + rewrite orb_true_r. simpl. + clear valid'. + destruct Mem.valid_pointer eqn:valid''; simpl; try congruence. + eapply Mem.valid_pointer_inject in valid''; eauto using partial_mem_inject. + rewrite Z.add_0_r in valid''. rewrite valid''. now auto. + clear valid''. + destruct Mem.valid_pointer eqn:valid'''; simpl; try congruence. + eapply Mem.valid_pointer_inject in valid'''; eauto using partial_mem_inject. + rewrite Z.add_0_r in valid'''. rewrite valid'''. + now rewrite orb_true_r. + + destruct eq_block; subst; simpl in *. + * destruct Mem.valid_pointer eqn:valid; simpl; try congruence. + destruct (Mem.valid_pointer m1' b0) eqn:valid'; simpl; try congruence. + assert (delta = 0) by (eapply delta_zero; eauto); subst. + assert (delta0 = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.mi_no_overlap with (f := j) in n; [| now eapply partial_mem_inject; eauto]. + specialize (n H H0 (Mem.perm_cur_max _ _ _ _ ((proj1 (Mem.valid_pointer_nonempty_perm _ _ _)) valid)) + (Mem.perm_cur_max _ _ _ _ ((proj1 (Mem.valid_pointer_nonempty_perm _ _ _)) valid'))); + rewrite !Z.add_0_r in n. + destruct n; [contradiction |]. + eapply Mem.valid_pointer_inject_val in valid; eauto using partial_mem_inject; rewrite valid; simpl; auto. + eapply Mem.valid_pointer_inject_val in valid'; eauto using partial_mem_inject; rewrite valid'; simpl; auto. + destruct op; simpl; try congruence. + intros. inv H2. rewrite !Ptrofs.add_zero. unfold Ptrofs.eq. destruct zeq; auto; congruence. + intros. inv H2. rewrite !Ptrofs.add_zero. unfold Ptrofs.eq. destruct zeq; auto; congruence. + * destruct Mem.valid_pointer eqn:valid; simpl; try congruence. + eapply Mem.valid_pointer_inject_val in valid; eauto using partial_mem_inject; rewrite valid; simpl; auto. + clear valid. + destruct Mem.valid_pointer eqn:valid'; simpl; try congruence. + assert (delta = 0) by (eapply delta_zero; eauto); subst. + assert (delta0 = 0) by (eapply delta_zero; eauto); subst. + eapply Mem.valid_pointer_inject in valid'; eauto using partial_mem_inject. + rewrite Ptrofs.add_zero in *. rewrite Z.add_0_r in valid'. rewrite valid'. auto. +Qed. + +Lemma cmplu_inject: + forall s ge ge' j δ op m1 m3 v1 v1' v2 v2', + mem_rel s ge ge' j δ m1 m3 -> + Val.inject j v1 v1' -> + Val.inject j v2 v2' -> + Val.inject j (Val.maketotal (Val.cmplu (Mem.valid_pointer m1) op v1 v2)) + (Val.maketotal (Val.cmplu (Mem.valid_pointer m3) op v1' v2')). +Proof. + intros s ge ge' j δ op m1 m3 v1 v1' v2 v2' m1_m3 v1_v1' v2_v2'. + unfold Val.cmplu. + destruct (Val.cmplu_bool) eqn:eq_cmplu. + - eapply cmplu_bool_preserved in eq_cmplu; eauto. rewrite eq_cmplu. + simpl. now eapply Cop.val_inject_of_bool. + - auto. +Qed. + + +Hint Resolve cmpu_inject cmplu_inject : solve_inject. +Hint Resolve Cop.val_inject_of_bool: solve_inject. + +Section Lemmas. + + Context (s: split) (W1 W2 W3: Asm.program) (δ: side). + + (* Hypothesis match_W1_W3: match_prog s δ W1 W3. *) + (* Hypothesis match_W2_W3: match_prog s (opposite δ) W2 W3. *) + + (* Notation cp_main := (comp_of_main W1). *) + + Hypothesis norepet1: list_norepet (prog_defs_names W1). + Hypothesis norepet2: list_norepet (prog_defs_names W2). + Hypothesis norepet3: list_norepet (prog_defs_names W3). + + (* Context (ge1 ge2: genv). *) + Notation ge1 := (Genv.globalenv W1). + Notation ge2 := (Genv.globalenv W2). + Notation ge3 := (Genv.globalenv W3). + + + Lemma alloc_preserves_rel1: + forall cp j__δ j__oppδ m1 m1' m2 m3 lo hi b1 rs1 rs3, + s |= cp ∈ δ -> + (* meminj_preserves_globals s δ W1 W3 j__δ -> *) + agrees_with j__δ (init_meminj W1 W3) -> + def_on_addressable s ge1 j__δ δ -> + mem_rel s ge1 ge3 j__δ δ m1 m3 -> + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3 -> + regset_rel j__δ rs1 rs3 -> + Mem.alloc m1 cp lo hi = (m1', b1) -> + exists j__δ' m3' b3, Mem.alloc m3 cp lo hi = (m3', b3) /\ + (* meminj_preserves_globals s δ W1 W3 j__δ' /\ *) + agrees_with j__δ' (init_meminj W1 W3) /\ + def_on_addressable s ge1 j__δ' δ /\ + mem_rel s ge1 ge3 j__δ' δ m1' m3' /\ + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3' /\ + regset_rel j__δ' rs1 rs3 /\ + j__δ' b1 = Some (b3, 0) /\ + inject_incr j__δ j__δ'. + Proof. + intros cp j__δ j__oppδ m1 m1' m2 m3 lo hi b1 rs1 rs3 side_cp agr addr m1_m3 m2_m3 rs1_rs3 alloc1. + exploit (Mem.alloc_parallel_inject j__δ m1); eauto using partial_mem_inject, Z.le_refl. + intros [j' [m3' [b3 [? [? [? [? diff]]]]]]]. + exists j', m3', b3. + split; [| split; [| split; [| split; [| split; [| split; [| split]]]]]]; + [assumption | eapply agrees_with_incr2; eauto | eapply def_on_addressable_incr; eauto | | | intros ?; eauto using val_inject_incr | assumption | assumption]. + { destruct (init_meminj W1 W3 b1) as [[] |] eqn:?; auto. + exploit init_meminj_invert; eauto. intros [-> [id [? ?]]]. + apply Mem.alloc_result in alloc1; subst. + + pose proof (ple_nextblock1 _ _ _ _ _ _ _ m1_m3). + exploit (Senv.find_symbol_below ge1); eauto. intros ?. + pose proof (Plt_Ple_trans _ _ _ H6 H5). + now exploit Plt_strict; eauto. } + + (* { assert (G: forall s δ p1 p2 j j', *) + (* meminj_preserves_globals s δ p1 p2 j -> *) + (* (forall (b: block) gd, Genv.find_def (Genv.globalenv p1) b = Some gd -> j' b = j b) -> *) + (* (forall (b b': block) delta gd, Genv.find_def (Genv.globalenv p2) b' = Some gd -> *) + (* j' b = Some (b', delta) -> *) + (* j b = Some (b', delta)) -> *) + (* inject_incr j j' -> *) + (* meminj_preserves_globals s δ p1 p2 j'). *) + (* { clear. *) + (* intros s δ p1 p2 j j' [A B C D E] rewr1 rewr2 incr. *) + (* constructor. *) + (* - intros. exploit B; eauto. intros (? & ? & ?). *) + (* exploit incr; eauto. intros ?; split; congruence. *) + (* - intros. exploit B; eauto. intros (? & ? & ?). *) + (* exploit incr; eauto. *) + (* - intros. exploit C; eauto. intros (? & ? & ?). *) + (* exploit incr; eauto. *) + (* - intros. erewrite rewr1 in H; eauto. *) + (* - intros. eapply rewr2 in H; eauto. } *) + (* eapply G; eauto. *) + (* - clear G. *) + (* intros. eapply diff. *) + (* eapply find_def_valid1 in m1_m3; eauto. unfold Mem.valid_block in m1_m3. *) + (* eapply Mem.alloc_result in alloc1; subst. intros N; subst b; exploit Plt_strict; eauto. *) + (* - clear G. *) + (* intros. rewrite <- diff; eauto. *) + (* eapply find_def_valid2 in m1_m3; eauto. unfold Mem.valid_block in m1_m3. *) + (* eapply Mem.alloc_result in H; subst. intros N; subst b. *) + (* assert (b' = Mem.nextblock m3) by congruence. subst b'. *) + (* now exploit Plt_strict; eauto. } *) + { clear dependent j__oppδ. + constructor. + - intros b. destruct (Pos.eq_dec b b1); subst. + + split; [| congruence]. + intros _. apply Mem.owned_new_block in alloc1. simpl in alloc1. left; simpl; now rewrite alloc1. + + rewrite (diff _ n). + eapply same_dom in m1_m3. specialize (m1_m3 b). + eapply Mem.alloc_block_compartment with (b' := b) in alloc1. + simpl. rewrite alloc1. rewrite peq_false; eauto. + - assumption. + - intros b b' delta. + destruct (Pos.eq_dec b b1); subst. + + congruence. + + rewrite (diff _ n). + intros G. exploit delta_zero; eauto. + - erewrite Mem.nextblock_alloc; eauto using Ple_trans, Ple_succ, ple_nextblock1. + - erewrite Mem.nextblock_alloc; eauto using Ple_trans, Ple_succ, ple_nextblock2. + - intros. exploit find_def_valid1; eauto. eapply Mem.valid_block_alloc; eauto. + - intros. exploit find_def_valid2; eauto. eapply Mem.valid_block_alloc; eauto. + - intros. + pose proof (ple_nextblock1 _ _ _ _ _ m1 m3 m1_m3) as ple. + eapply find_def_perm1 with (b := b) in m1_m3; eauto. + intros n. apply m1_m3. + eapply Mem.perm_alloc_4; eauto. + eapply Genv.find_def_find_symbol_inversion in H3 as [id H3]; eauto. + exploit (Senv.find_symbol_below (Genv.globalenv W1)); eauto. intros ?. + exploit (Mem.alloc_result m1); eauto. intros ->. + intros ->. eapply Plt_strict. + eapply Plt_Ple_trans; eauto. + - intros. + pose proof (ple_nextblock2 _ _ _ _ _ m1 m3 m1_m3) as ple. + eapply find_def_perm2 with (b := b) in m1_m3; eauto. + intros n. apply m1_m3. + eapply Mem.perm_alloc_4; eauto. + eapply Genv.find_def_find_symbol_inversion in H3 as [id H3]; eauto. + exploit (Senv.find_symbol_below (Genv.globalenv W3)); eauto. intros ?. + exploit (Mem.alloc_result m3); eauto. intros -> ->. + eapply Plt_strict. eapply Plt_Ple_trans; eauto. + - intros id ofs. + exploit same_high_half; eauto. } + { clear dependent j__δ. + destruct m2_m3. + constructor; eauto. + - eapply Mem.alloc_right_inject; eauto using partial_mem_inject. + - erewrite Mem.nextblock_alloc; eauto using Ple_trans, Ple_succ, ple_nextblock1. + - intros. eapply Mem.valid_block_alloc; eauto. + - intros. intros n. + eapply Mem.perm_alloc_4 in n; eauto. + eapply find_def_perm4; eauto. + intros ->. + exploit (Mem.alloc_result m3); eauto. intros ->. + eapply Genv.find_def_find_symbol_inversion in H1 as [id H1]; eauto. + exploit (Senv.find_symbol_below (Genv.globalenv W3)); eauto. intros ?. + eapply Plt_strict. eapply Plt_Ple_trans; eauto. } + Qed. + + Lemma alloc_preserves_rel2: + forall cp j__δ j__oppδ m1 m1' m2 m3 lo hi b1 rs1 rs3, + s |= cp ∈ opposite δ -> + agrees_with j__δ (init_meminj W1 W3) -> + def_on_addressable s ge1 j__δ δ -> + mem_rel s ge1 ge3 j__δ δ m1 m3 -> + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3 -> + regset_rel j__δ rs1 rs3 -> + Mem.alloc m1 cp lo hi = (m1', b1) -> + exists j__δ' m3' b3, Mem.alloc m3 cp lo hi = (m3', b3) /\ + agrees_with j__δ' (init_meminj W1 W3) /\ + def_on_addressable s ge1 j__δ' δ /\ + mem_rel s ge1 ge3 j__δ' δ m1' m3' /\ + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3' /\ + regset_rel j__δ' rs1 rs3 /\ + inject_incr j__δ j__δ'. + Proof. + intros cp j__δ j__oppδ m1 m1' m2 m3 lo hi b1 rs1 rs3 side_cp agr addr m1_m3 m2_m3 rs1_rs3 alloc1. + exploit (Mem.alloc_parallel_inject j__δ m1); eauto using partial_mem_inject, Z.le_refl. + intros [_ [m3' [b3 [alloc3 [_ [_ [_ _]]]]]]]. + exploit (Mem.alloc_left_unmapped_inject j__δ m1); eauto using partial_mem_inject. + intros [j' [inj [incr [isnone diff]]]]. + exploit Mem.alloc_right_inject; eauto. intros inj'. + exists j', m3', b3. split; [| split; [| split; [| split; [| split; [| split]]]]]; + [assumption | eapply agrees_with_incr1; eauto | eapply def_on_addressable_incr; eauto | | | intros ?; eauto using val_inject_incr | assumption]. + (* { assert (G: forall s δ p1 p2 j j', *) + (* meminj_preserves_globals s δ p1 p2 j -> *) + (* (forall (b: block) gd, Genv.find_def (Genv.globalenv p1) b = Some gd -> j' b = j b) -> *) + (* (forall (b b': block) delta gd, Genv.find_def (Genv.globalenv p2) b' = Some gd -> *) + (* j' b = Some (b', delta) -> *) + (* j b = Some (b', delta)) -> *) + (* inject_incr j j' -> *) + (* meminj_preserves_globals s δ p1 p2 j'). *) + (* { clear. *) + (* intros s δ p1 p2 j j' [A B C D E] rewr1 rewr2 incr. *) + (* constructor. *) + (* - intros. exploit B; eauto. intros (? & ? & ?). *) + (* exploit incr; eauto. intros ?; split; congruence. *) + (* - intros. exploit B; eauto. intros (? & ? & ?). *) + (* exploit incr; eauto. *) + (* - intros. exploit C; eauto. intros (? & ? & ?). *) + (* exploit incr; eauto. *) + (* - intros. erewrite rewr1 in H; eauto. *) + (* - intros. eapply rewr2 in H; eauto. } *) + (* eapply G; eauto. *) + (* - clear G. *) + (* intros. eapply diff. *) + (* eapply find_def_valid1 in m1_m3; eauto. unfold Mem.valid_block in m1_m3. *) + (* eapply Mem.alloc_result in alloc1; subst. intros N; subst b; exploit Plt_strict; eauto. *) + (* - clear G. *) + (* intros. rewrite <- diff; eauto. *) + (* eapply find_def_valid2 in m1_m3; eauto. unfold Mem.valid_block in m1_m3. *) + (* eapply Mem.alloc_result in alloc3; subst. intros N; subst b. *) + (* assert (b' = Mem.nextblock m3) by congruence. subst b'. *) + (* now exploit Plt_strict; eauto. } *) + { clear dependent j__oppδ. + constructor; auto. + - intros b. destruct (Pos.eq_dec b b1); subst. + + split; [congruence |]. + intros ?. apply Mem.owned_new_block in alloc1. simpl in *. rewrite alloc1 in H. + apply same_dom in m1_m3. specialize (m1_m3 b1). + destruct m1_m3 as [_ m1_m3]. + destruct H. + * now destruct δ; congruence. + * specialize (m1_m3 (or_intror H)). + assert (exists b1' delta, j__δ b1 = Some (b1', delta)) as [b1' [? G]] + by now (destruct (j__δ b1) as [[]|]; try congruence; eauto). + apply incr in G. congruence. + + rewrite (diff _ n). + eapply same_dom in m1_m3. specialize (m1_m3 b). + eapply Mem.alloc_block_compartment with (b' := b) in alloc1. + simpl. rewrite alloc1. rewrite peq_false; eauto. + - intros b b' delta. + destruct (Pos.eq_dec b b1); subst. + + congruence. + + rewrite (diff _ n). + intros G. exploit delta_zero; eauto. + - erewrite Mem.nextblock_alloc; eauto using Ple_trans, Ple_succ, ple_nextblock1. + - erewrite Mem.nextblock_alloc; eauto using Ple_trans, Ple_succ, ple_nextblock2. + - intros. exploit find_def_valid1; eauto. eapply Mem.valid_block_alloc. eauto. + - intros. exploit find_def_valid2; eauto. eapply Mem.valid_block_alloc. eauto. + - intros. intros n. eapply find_def_perm1; eauto. + eapply Mem.perm_alloc_4; eauto. + intros ->. + exploit (Mem.alloc_result m1); eauto. intros ->. + eapply Genv.find_def_find_symbol_inversion in H as [id H]; eauto. + exploit (Senv.find_symbol_below (Genv.globalenv W1)); eauto. intros ?. + eapply Plt_strict. eapply Plt_Ple_trans; eauto using ple_nextblock1. + - intros. intros n. eapply find_def_perm2; eauto. + eapply Mem.perm_alloc_4; eauto. + intros ->. + exploit (Mem.alloc_result m3); eauto. intros ->. + eapply Genv.find_def_find_symbol_inversion in H as [id H]; eauto. + exploit (Senv.find_symbol_below (Genv.globalenv W3)); eauto. intros ?. + eapply Plt_strict. eapply Plt_Ple_trans; eauto using ple_nextblock2. + - intros id ofs. + exploit same_high_half; eauto. + } + { clear dependent j__δ. + destruct m2_m3. + constructor; eauto. + - eapply Mem.alloc_right_inject; eauto using partial_mem_inject. + - erewrite Mem.nextblock_alloc; eauto using Ple_trans, Ple_succ, ple_nextblock1. + - intros. eapply Mem.valid_block_alloc; eauto. + - intros. intros n. eapply find_def_perm4; eauto. + eapply Mem.perm_alloc_4; eauto. + intros ->. + exploit (Mem.alloc_result m3); eauto. intros ->. + eapply Genv.find_def_find_symbol_inversion in H as [id H]; eauto. + exploit (Senv.find_symbol_below (Genv.globalenv W3)); eauto. intros ?. + eapply Plt_strict. eapply Plt_Ple_trans; eauto using ple_nextblock2. } + Qed. + + Lemma alloc_preserves_rel: + forall cp j__δ j__oppδ m1 m1' m2 m3 lo hi b1 rs1 rs3, + (* meminj_preserves_globals s δ W1 W3 j__δ -> *) + agrees_with j__δ (init_meminj W1 W3) -> + def_on_addressable s ge1 j__δ δ -> + mem_rel s ge1 ge3 j__δ δ m1 m3 -> + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3 -> + regset_rel j__δ rs1 rs3 -> + Mem.alloc m1 cp lo hi = (m1', b1) -> + exists j__δ' m3' b3, Mem.alloc m3 cp lo hi = (m3', b3) /\ + (* meminj_preserves_globals s δ W1 W3 j__δ' /\ *) + agrees_with j__δ' (init_meminj W1 W3) /\ + def_on_addressable s ge1 j__δ' δ /\ + mem_rel s ge1 ge3 j__δ' δ m1' m3' /\ + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3' /\ + regset_rel j__δ' rs1 rs3 /\ + (s |= cp ∈ δ -> j__δ' b1 = Some (b3, 0)) /\ + inject_incr j__δ j__δ'. + Proof. + intros. + destruct (side_eq (s cp) δ) as [s_cp | s_cp]. + - exploit alloc_preserves_rel1; eauto. now simpl. + intros [? [? [? [? [? [? [? [? [? [? ?]]]]]]]]]]. + eexists; eexists; eexists; repeat (split; eauto). + - exploit alloc_preserves_rel2; eauto. now simpl; destruct (s cp); destruct δ. + intros [? [? [? [? [? [? [? [? [? ?]]]]]]]]]. + eexists; eexists; eexists; repeat (split; eauto). simpl; congruence. + Qed. + + + Lemma free_preserves_rel: + forall cp j__δ j__oppδ m1 m1' m2 m3 lo hi b1 b3, + j__δ b1 = Some (b3, 0) -> (* we are necessarily in the δ case *) + mem_rel s ge1 ge3 j__δ δ m1 m3 -> + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3 -> + Mem.free m1 b1 lo hi cp = Some m1' -> + exists m3', Mem.free m3 b3 lo hi cp = Some m3' /\ + mem_rel s ge1 ge3 j__δ δ m1' m3' /\ + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3'. + Proof. + intros cp j__δ j__oppδ m1 m1' m2 m3 lo hi b1 b3 ptr_inj m1_m3 m2_m3 free1. + exploit (Mem.free_parallel_inject j__δ m1); eauto using partial_mem_inject. + intros [m3' [free3 m1'_m3']]. + rewrite 2!Z.add_0_r in free3. + exists m3'; split; [| split]; [assumption | |]. + { clear dependent j__oppδ. + constructor. + - intros b. apply same_dom in m1_m3. + specialize (m1_m3 b). + simpl in *. apply Mem.free_result in free1. unfold Mem.unchecked_free in free1. + destruct (zle hi lo); now subst. + - assumption. + - intros b b' delta. + intros G. exploit delta_zero; eauto. + - erewrite Mem.nextblock_free; eauto using Ple_trans, Ple_succ, ple_nextblock1. + - erewrite Mem.nextblock_free; eauto using Ple_trans, Ple_succ, ple_nextblock2. + - intros. exploit find_def_valid1; eauto. eapply Mem.valid_block_free_1; eauto. + - intros. exploit find_def_valid2; eauto. eapply Mem.valid_block_free_1; eauto. + - intros. intros n. + eapply find_def_perm1; eauto. + eapply Mem.perm_free_3; eauto. + - intros. intros n. + eapply find_def_perm2; eauto. + eapply Mem.perm_free_3; eauto. + - intros id ofs. + exploit same_high_half; eauto. } + { destruct m2_m3. + constructor; auto. + - eapply Mem.free_right_inject; eauto. + intros. + apply Mem.mi_inj in partial_mem_inject0. + eapply Mem.mi_own with (cp := (Mem.block_compartment m2 b0)) in partial_mem_inject0; eauto; + [| now destruct Mem.block_compartment eqn:?]; eauto. + specialize (same_dom0 b0). + assert (X: j__oppδ b0 <> None) by congruence. + apply same_dom0 in X. simpl in *. + apply same_dom in m1_m3 as G. + specialize (G b1). + assert (Y: j__δ b1 <> None) by congruence. + apply G in Y. simpl in *. clear G. + apply partial_mem_inject in m1_m3. + apply Mem.mi_inj in m1_m3. + eapply Mem.mi_own with (cp := (Mem.block_compartment m1 b1)) in m1_m3; eauto; + [| now destruct (Mem.block_compartment m1 b1) eqn:?]; eauto. + unfold Mem.can_access_block in *. + destruct X as [X | X]; destruct Y as [Y | Y]. + admit. admit. admit. admit. + - erewrite Mem.nextblock_free; eauto using Ple_trans, Ple_succ, ple_nextblock1. + - intros. eapply Mem.valid_block_free_1; eauto. + - intros. intros n. + eapply find_def_perm4; eauto. + eapply Mem.perm_free_3; eauto. } + Admitted. + + Lemma store_preserves_rel: + forall cp (j__δ j__oppδ: meminj) m1 m1' m2 m3 ch ofs v1 v3 b1 b3, + j__δ b1 = Some (b3, 0) -> (* we are necessarily in the δ case *) + mem_rel s ge1 ge3 j__δ δ m1 m3 -> + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3 -> + Val.inject j__δ v1 v3 -> + Mem.store ch m1 b1 ofs v1 cp = Some m1' -> + exists m3', Mem.store ch m3 b3 ofs v3 cp = Some m3' /\ + mem_rel s ge1 ge3 j__δ δ m1' m3' /\ + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3'. + Proof. + intros cp j__δ j__oppδ m1 m1' m2 m3 ch ofs v1 v3 b1 b3 ptr_inj m1_m3 m2_m3 val_inj store1. + exploit (Mem.store_mapped_inject j__δ); eauto using partial_mem_inject. + intros [m3' [store3 ?]]. + rewrite Z.add_0_r in store3. + exists m3'; split; [| split]; [assumption | |]. + { clear dependent j__oppδ. + constructor. + - intros b. apply same_dom in m1_m3. + specialize (m1_m3 b). simpl in *. + eapply Mem.store_block_compartment in store1. now rewrite store1. + - assumption. + - now eapply delta_zero; eauto. + - erewrite Mem.nextblock_store; eauto using Ple_trans, Ple_succ, ple_nextblock1. + - erewrite Mem.nextblock_store; eauto using Ple_trans, Ple_succ, ple_nextblock2. + - intros. exploit find_def_valid1; eauto. eapply Mem.store_valid_block_1; eauto. + - intros. exploit find_def_valid2; eauto. eapply Mem.store_valid_block_1; eauto. + - intros; intros n. exploit find_def_perm1; eauto. + eapply Mem.perm_store_2; eauto. + - intros; intros n. exploit find_def_perm2; eauto. + eapply Mem.perm_store_2; eauto. + - intros id ofs0. + exploit same_high_half; eauto. } + { destruct m2_m3. + constructor; eauto. + - eapply Mem.store_outside_inject; eauto. + intros. + apply Mem.mi_inj in partial_mem_inject0. + eapply Mem.mi_own with (cp := (Mem.block_compartment m2 b')) in partial_mem_inject0; eauto; + [| now destruct Mem.block_compartment eqn:?]; eauto. + specialize (same_dom0 b'). + assert (X: j__oppδ b' <> None) by congruence. + apply same_dom0 in X. simpl in *. + apply same_dom in m1_m3 as G. + specialize (G b1). + assert (Y: j__δ b1 <> None) by congruence. + apply G in Y. simpl in *. clear G. + apply partial_mem_inject in m1_m3. + apply Mem.mi_inj in m1_m3. + eapply Mem.mi_own with (cp := (Mem.block_compartment m1 b1)) in m1_m3; eauto; + [| now destruct (Mem.block_compartment m1 b1) eqn:?]; eauto. + unfold Mem.can_access_block in *. + destruct (Mem.block_compartment m2 b'); destruct (Mem.block_compartment m1 b1); try congruence. + admit. admit. admit. admit. + (* destruct δ; simpl in *; congruence. *) + - erewrite Mem.nextblock_store; eauto using Ple_trans, Ple_succ, ple_nextblock1. + - intros. exploit find_def_valid2; eauto. eapply Mem.store_valid_block_1; eauto. + - intros; intros n. exploit find_def_perm2; eauto. + eapply Mem.perm_store_2; eauto. } + Admitted. + + Lemma regset_rel_inject: forall j rs1 rs3 rd v v', + regset_rel j rs1 rs3 -> + Val.inject j v v' -> + regset_rel j (rs1 # rd <- v) (rs3 # rd <- v'). + Proof. + intros. + intros r. + destruct (Pregmap.elt_eq r rd); now try subst r; Simpl. + Qed. + + Lemma inject_incr_stack_rel1: + forall j1 j1' j2 st1 st2 st3, + inject_incr j1 j1' -> + stack_rel s ge3 δ j1 j2 st1 st2 st3 -> + stack_rel s ge3 δ j1' j2 st1 st2 st3. + Proof. + intros * incr st_rel. + induction st_rel. + - constructor; eauto. + - constructor; eauto. + inv H. + + econstructor; eauto. + + eapply stackframe_related_opp_δ; eauto. + Qed. + + Lemma inject_incr_stack_rel2: + forall j1 j2 j2' st1 st2 st3, + inject_incr j2 j2' -> + stack_rel s ge3 δ j1 j2 st1 st2 st3 -> + stack_rel s ge3 δ j1 j2' st1 st2 st3. + Proof. + intros * incr st_rel. + induction st_rel. + - constructor; eauto. + - constructor; eauto. + inv H. + + econstructor; eauto. + + eapply stackframe_related_opp_δ; eauto. + Qed. + + Lemma find_funct_ptr_preserved: + forall j__δ b b' fd, + meminj_preserves_globals s δ W1 W3 j__δ -> + j__δ b = Some (b', 0) -> + Genv.find_funct_ptr ge1 b = Some fd -> + exists fd', + Genv.find_funct_ptr ge3 b' = Some fd' /\ + match_fundef fd fd' /\ + (forall id : ident, Genv.find_symbol ge1 id = Some b -> kept_genv s ge1 δ id = true -> fd = fd'). + Proof. + intros j b b' fd inj_pres inj_b_b' find_b_fd. + (* exploit init_meminj_preserves_globals; eauto. *) + (* intros inj_pres. *) + unfold Genv.find_funct_ptr in *. + destruct (Genv.find_def ge1 b) as [[fd' |] |] eqn:find_def_b; try discriminate. + assert (fd' = fd) by congruence; subst fd'; clear find_b_fd. + + exploit defs_inject; eauto. intros [gd' [find_def_b' [_ [match_fd_gd' left_implies_eq]]]]. + assert (exists fd', gd' = Gfun fd' /\ match_fundef fd fd') as [fd' [gd'_fd' match_fd_fd']]. + { inv match_fd_gd'; match goal with | H: match_fundef _ _ |- _ => inv H end. + - eexists; split; [reflexivity | constructor]. + - eexists; split; [reflexivity | constructor]. } + subst gd'. + + rewrite find_def_b'. eexists; split; [| split]; auto. + intros; exploit left_implies_eq; eauto. congruence. + Qed. + + (* Definition agrees_with (j1 j2: meminj) := *) + (* forall b b' delta', *) + (* j2 b = Some (b', delta') -> *) + (* j1 b = Some (b', delta'). *) + + (* Lemma agrees_with_inject: forall j j' v v', *) + (* agrees_with j j' -> *) + (* Val.inject j' v v' -> *) + (* Val.inject j v v'. *) + (* Proof. *) + (* intros j j' v v' H inj. unfold agrees_with in H. *) + (* inv inj; try now constructor. *) + (* eapply H in H0. econstructor; eauto. *) + (* Qed. *) + + Lemma find_def_preserved: + forall j__δ b b' gd, + meminj_preserves_globals s δ W1 W3 j__δ -> + j__δ b = Some (b', 0) -> + Genv.find_def ge1 b = Some gd -> + exists gd', + Genv.find_def ge3 b' = Some gd' /\ + match_globdef gd gd' /\ + (forall id : ident, Genv.find_symbol ge1 id = Some b -> kept_genv s ge1 δ id = true -> gd' = gd). + Proof. + intros j__δ b b' gd inj_pres inj_b_b' find_b_gd. + exploit defs_inject; eauto. intros [gd' [find_def_b' [_ [match_fd_gd' left_implies_eq]]]]. + eauto. + Qed. + + Lemma def_on_addressable_init: + match_prog s δ W1 W3 -> + def_on_addressable s ge1 (init_meminj W1 W3) δ. + Proof. + unfold def_on_addressable. + intros match_W1_W3. intros. + unfold init_meminj. + apply Genv.find_invert_symbol in H; rewrite H. + apply Genv.invert_find_symbol in H. + exploit transform_find_symbol_1; eauto. + intros (? & ->). eauto. + Qed. + + Lemma agrees_with_init_meminj_find_def_preserved: + forall j b b' delta gd, + match_prog s δ W1 W3 -> + agrees_with j (init_meminj W1 W3) -> + j b = Some (b', delta) -> + Genv.find_def ge1 b = Some gd -> + exists gd', + Genv.find_def ge3 b' = Some gd' /\ + match_globdef gd gd' /\ + (forall id : ident, Genv.find_symbol ge1 id = Some b -> kept_genv s ge1 δ id = true -> gd' = gd). + Proof. + intros j b b' delta gd match_W1_W3 agr j_b find_b. + exploit init_meminj_preserves_globals; eauto. intros inj_pres. + eapply find_def_preserved; eauto. + assert (exists b', init_meminj W1 W3 b = Some (b', 0)) as [b'' init_meminj_b]. + { unfold init_meminj. + exploit Genv.find_def_find_symbol_inversion; eauto. + intros (id & A). apply Genv.find_invert_symbol in A as B. rewrite B. + destruct (kept_prog s W1 δ id) eqn:?. + - exploit match_prog_def; eauto. + assert (C: (prog_defmap W1) ! id = Some gd). + { apply Genv.find_def_symbol; eauto. } + rewrite C. intros D. + apply Genv.find_def_symbol in D as [b'' [D E]]; eauto. + rewrite D. eauto. + - exploit match_prog_notdef; eauto. + assert (C: (prog_defmap W1) ! id = Some gd). + { apply Genv.find_def_symbol; eauto. } + rewrite C. intros D. + inversion D as [| ? ? matchgd u E]; subst. symmetry in E. + apply Genv.find_def_symbol in E as [b'' [E F]]; eauto. + rewrite E. eauto. } + exploit agr; eauto. now intros []; congruence. + Qed. + + Lemma find_comp_of_block_preserved: + forall j__δ b b' delta + (inj_pres: meminj_preserves_globals s δ W1 W3 j__δ) + (delta_zero: mem_delta_zero j__δ), + j__δ b = Some (b', delta) -> + Genv.find_comp_of_block ge1 b = Genv.find_comp_of_block ge3 b'. + Proof. + intros j b b' delta inj_pres delta_zero j_b. + exploit delta_zero; eauto; intros ->. + unfold Genv.find_comp_of_block. + destruct (Genv.find_def _ b) as [gd |] eqn:?. + - exploit find_def_preserved; eauto. + intros (gd' & -> & H & ?). + destruct H as [? ? H | ? ? H]; now inv H. + - destruct (Genv.find_def _ b') as [gd |] eqn:?; [| reflexivity]. + exploit defs_rev_inject; eauto. intros (gd' & ? & ?); congruence. + Qed. + + + Lemma agrees_with_init_meminj_find_comp_of_block_preserved: + forall j b b' delta cp, + match_prog s δ W1 W3 -> + agrees_with j (init_meminj W1 W3) -> + j b = Some (b', delta) -> + Genv.find_comp_of_block ge1 b = Some cp -> + Genv.find_comp_of_block ge3 b' = Some cp. + Proof. + intros j b b' delta cp match_W1_W3 agr j_b comp_b. + unfold Genv.find_comp_of_block in *. + destruct (Genv.find_def _ b) as [gd |] eqn:?. + - exploit agrees_with_init_meminj_find_def_preserved; eauto. + intros (gd' & -> & H & ?). + destruct H as [? ? H | ? ? H]; now inv H. + - congruence. + Qed. + + Lemma find_comp_preserved: + forall j__δ v v' + (inj_pres: meminj_preserves_globals s δ W1 W3 j__δ) + (delta_zero: mem_delta_zero j__δ), + v <> Vundef -> + Val.inject j__δ v v' -> + Genv.find_comp ge1 v = Genv.find_comp ge3 v'. + Proof. + intros j v v' inj_pres delta_zero nundef H. + inv H; simpl; auto; try congruence. + exploit find_comp_of_block_preserved; eauto. + Qed. + + Lemma agrees_with_init_meminj_find_comp_preserved: + forall j v v' cp, + match_prog s δ W1 W3 -> + agrees_with j (init_meminj W1 W3) -> + v <> Vundef -> + Val.inject j v v' -> + Genv.find_comp ge1 v = Some cp -> + Genv.find_comp ge3 v' = Some cp. + Proof. + intros j v v' cp match_W1_W3 agr j_v v_not_undef comp_v. + inv v_not_undef; simpl; auto; try congruence. + eapply agrees_with_init_meminj_find_comp_of_block_preserved; eauto. + Qed. + +End Lemmas. + +Ltac eexists_and_split := + fun k => + match goal with + | m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => + exists j; eexists; eexists; split; [| split; [| split; [| split; [| split; [| split]]]]]; eauto; + k j rs1 rs3 rs1_rs3 m1 m3 m1_m3 + end. + +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 eqn:?; subst; simpl in * + + | _: context [low_half] |- _ => + unfold low_half in *; simpl in * + (* rewrite same_low_half1 in * *) + + + | H: Mem.alloc ?m1 ?cp ?lo1 ?hi1 = (?m1', ?b1), + m1_m3: mem_rel _ _ _ ?j__δ ?δ ?m1 ?m3, + m2_m3: mem_rel _ _ _ ?j__oppδ (opposite ?δ) ?m2 ?m3, + agr: agrees_with ?j__δ (init_meminj _ _), + addr: def_on_addressable _ _ ?j__δ ?δ, + rs1_rs3: regset_rel _ _ _ |- _ => + (* inj_pres : meminj_preserves_globals _ ?δ _ _ ?j__δ |- _ => *) + idtac "alloc case"; + let j__δ' := fresh "j__δ" in + let m3' := fresh "m3" in + let b3 := fresh "b3" in + let alloc3 := fresh "alloc3" in + let agr' := fresh "agr" in + let addr' := fresh "addr" in + (* let inj_pres' := fresh "inj_pres" in *) + let m1'_m3' := fresh "m1'_m3'" in + let m2_m3' := fresh "m2_m3'" in + let proj := fresh "proj" in + let incr := fresh "incr" in + eapply (alloc_preserves_rel _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ agr addr m1_m3 m2_m3 rs1_rs3) in H as + [j__δ' [m3' [b3 [alloc3 [agr' [addr' [m1'_m3' [m2_m3' [? [proj incr]]]]]]]]]]; + idtac "done with alloc"; + clear m1_m3 rs1_rs3 m2_m3 agr addr + | H: ?s ?cp = ?δ -> _, + side_cp: ?s ?cp = ?δ |- _ => + specialize (H side_cp) + | H: ?x = ?x -> _ |- _ => + specialize (H eq_refl) + + | H: Mem.store ?ch ?m1 ?b1 ?ofs (?rs1 ?r) ?cp = Some ?m1', + m1_m3: mem_rel _ _ _ ?j__δ ?δ ?m1 ?m3, + m2_m3: mem_rel _ _ _ ?j__oppδ (opposite ?δ) ?m2 ?m3, + ptr_inj: ?j__δ ?b1 = Some (?b3, 0), + rs1_rs3: regset_rel ?j__δ ?rs1 ?rs3 |- _ => + idtac "store case"; + let m3' := fresh "m3" in + eapply (store_preserves_rel _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ptr_inj m1_m3 m2_m3 (rs1_rs3 r)) in H as + [m3' [? [? ?]]]; + idtac "done with store"; + clear m1_m3 m2_m3 + + | H: Mem.free ?m1 ?b1 ?lo ?hi ?cp = Some ?m1', + m1_m3: mem_rel _ _ _ ?j__δ ?δ ?m1 ?m3, + m2_m3: mem_rel _ _ _ ?j__oppδ (opposite ?δ) ?m2 ?m3, + ptr_inj: ?j__δ ?b1 = Some (?b3, 0) |- _ => + (* rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => *) + idtac "free case"; + let m3' := fresh "m3" in + eapply (free_preserves_rel _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ptr_inj m1_m3 m2_m3) in H as + [m3' [? [? ?]]]; + idtac "done with free"; + clear m1_m3 + + | H: Mem.load ?ch ?m1 ?b1 ?ofs ?cp = Some ?v1, + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + ptr_inj: ?j ?b1 = Some (?b3, 0) |- _ => + idtac "load case"; + let v3 := fresh "v3" in + let load3 := fresh "load3" in + destruct (Mem.load_inject _ _ _ _ _ _ _ _ _ _ (partial_mem_inject _ _ _ _ _ _ _ m1_m3) H ptr_inj) as + [v3 [load3 ?]]; + rewrite Z.add_0_r in load3; + idtac "done with load"; + clear H + + | H: Val.cmpu_bool (Mem.valid_pointer ?m1) ?op (?rs1 ?r) (?rs1 ?r') = Some ?b, + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => + (* idtac "Val.cmpu_bool case 0"; *) + eapply cmpu_bool_preserved with (m3 := m3) in H; eauto using rs1_rs3; + try rewrite H in *; + (* idtac "done with Val.cmpu_bool 0"; *) + try congruence + + | H: Val.cmpu_bool (Mem.valid_pointer ?m1) ?op (Vint ?x) (?rs1 ?r') = Some ?b, + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => + (* idtac "Val.cmpu_bool case 1"; *) + eapply cmpu_bool_preserved with (m3 := m3) (v1' := Vint x) in H; eauto using rs1_rs3; + try rewrite H in *; + (* idtac "done with Val.cmpu_bool 1"; *) + try congruence + + | H: Val.cmpu_bool (Mem.valid_pointer ?m1) ?op (?rs1 ?r) (Vint ?x) = Some ?b, + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => + (* idtac "Val.cmpu_bool case 2"; *) + eapply cmpu_bool_preserved with (m3 := m3) (v2' := Vint x) in H; eauto using rs1_rs3; + try rewrite H in *; + (* idtac "done with Val.cmpu_bool 2"; *) + try congruence + + | H: Val.cmpu_bool (Mem.valid_pointer ?m1) ?op (Vint ?x) (Vint ?y) = Some ?b, + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => + (* idtac "Val.cmpu_bool case 3"; *) + eapply cmpu_bool_preserved with (m3 := m3) (v1' := Vint x) (v2' := Vint y) in H; eauto using rs1_rs3; + try rewrite H in *; + (* idtac "done with Val.cmpu_bool 3"; *) + try congruence + + | H: Val.cmplu_bool (Mem.valid_pointer ?m1) ?op (?rs1 ?r) (?rs1 ?r') = Some ?b, + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => + (* idtac "Val.cmplu_bool case 0"; *) + eapply cmplu_bool_preserved with (m3 := m3) in H; eauto using rs1_rs3; + try rewrite H in *; + (* idtac "done with Val.cmplu_bool 0"; *) + try congruence + + | H: Val.cmplu_bool (Mem.valid_pointer ?m1) ?op (Vlong ?x) (?rs1 ?r') = Some ?b, + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => + (* idtac "Val.cmplu_bool case 1"; *) + eapply cmplu_bool_preserved with (m3 := m3) (v1' := Vlong x) in H; eauto using rs1_rs3; + try rewrite H in *; + (* idtac "done with Val.cmplu_bool 1"; *) + try congruence + + | H: Val.cmplu_bool (Mem.valid_pointer ?m1) ?op (?rs1 ?r) (Vlong ?x) = Some ?b, + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => + (* idtac "Val.cmplu_bool case 2"; *) + eapply cmplu_bool_preserved with (m3 := m3) (v2' := Vlong x) in H; eauto using rs1_rs3; + try rewrite H in *; + (* idtac "done with Val.cmplu_bool 2"; *) + try congruence + + | H: Val.cmplu_bool (Mem.valid_pointer ?m1) ?op (Vlong ?x) (Vlong ?y) = Some ?b, + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => + (* idtac "Val.cmplu_bool case 3"; *) + eapply cmplu_bool_preserved with (m3 := m3) (v1' := Vlong x) (v2' := Vlong y) in H; eauto using rs1_rs3; + try rewrite H in *; + (* idtac "done with Val.cmplu_bool 3"; *) + try congruence + + | H: Val.cmp_bool ?op (?rs1 ?r) (?rs1 ?r') = Some ?b, + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3, + rs1_rs3: regset_rel ?j ?rs1 ?rs3 |- _ => + (* idtac "Val.cmp_bool case"; *) + eapply Val.cmp_bool_inject in H; eauto using rs1_rs3; + try rewrite H in *; + (* idtac "done with Val.cmp_bool"; *) + try congruence + + | d: Z |- _ => + match goal with + | H: ?j _ = Some (_, d) , + m1_m3: mem_rel _ _ _ ?j _ ?m1 ?m3 |- _ => + let G := fresh "G" in + pose proof (delta_zero _ _ _ _ _ _ _ m1_m3 _ _ _ H) as G; + subst d + end + + + | |- 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 *) + | rs1_rs3: regset_rel ?j ?rs1 ?rs3, + _: context [match ?rs1 ?i with | _ => _ end] |- _ => + let H := fresh "rs1_rs3" in + assert (H := rs1_rs3 i); + destruct (rs1 i); inv H; try congruence; simpl in *; eauto + + | rs1_rs3: regset_rel ?j ?rs1 ?rs3, + _: context [Val.offset_ptr (?rs1 ?i) _] |- _ => + let H := fresh "rs1_rs3" in + assert (H := rs1_rs3 i); + destruct (rs1 i); inv H; 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: Int.lt ?x ?x = true |- _ => rewrite lt_xx_false in H + | H: Int64.lt ?x ?x = true |- _ => rewrite lt64_xx_false in H + | H: Int.ltu ?x ?x = true |- _ => rewrite ltu_xx_false in H + | H: Int64.ltu ?x ?x = true |- _ => rewrite ltu64_xx_false 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 + (* | H: (let (_) := ?x in _) = 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 _] => + setoid_rewrite H; simpl + | H: ?x = _ |- context [match ?x with | _ => _ end] => + setoid_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. + +Ltac solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3:= + repeat (Simpl; + match goal with + | |- regset_rel j (nextinstr _) (nextinstr _) => unfold nextinstr + | |- regset_rel j (_ # _ <- _) (_ # _ <- _) => eapply regset_rel_inject + | |- regset_rel j rs1 rs3 => assumption + + | |- stack_rel _ _ _ _ _ _ _ _ => eauto using inject_incr_stack_rel1, inject_incr_stack_rel2, inject_incr_refl + + | _: ?x |- ?x => assumption + + | d: Z |- _ => + match goal with + | H: j _ = Some (_, d) |- _ => + let G := fresh "G" in + pose proof (delta_zero _ _ _ _ _ _ _ m1_m3 _ _ _ H) as G; + subst d + end + + + | |- Ptrofs.add (Ptrofs.add ?ofs1 ?delta) ?imm = Ptrofs.add (Ptrofs.add ?ofs1 ?imm) ?delta => + now rewrite (Ptrofs.add_assoc ofs1 delta imm), (Ptrofs.add_commut delta imm), <- Ptrofs.add_assoc + + | |- context [_ ### ?rs] => + let i := fresh "i" in destruct rs as [| i]; simpl in * + | |- context [_ ## ?rs] => + let i := fresh "i" in destruct rs as [| i]; simpl in * + + | |- context [Ptrofs.sub (Ptrofs.add _ _) _] => rewrite Ptrofs.sub_add_l; simpl; auto + | |- context [Ptrofs.repr 0] => replace (Ptrofs.repr 0) with Ptrofs.zero by reflexivity; auto + | |- context [Ptrofs.add _ Ptrofs.zero] => rewrite Ptrofs.add_zero; auto + | |- context [Ptrofs.sub _ Ptrofs.zero] => rewrite Ptrofs.sub_zero_l; auto + + + + | |- Val.inject _ _ _ => eauto using Ptrofs.add_zero with solve_inject + end). + + +Section Theorems. + + Context (s: split) (W1 W2 W3: Asm.program) (δ: side). + + Hypothesis match_W1_W3: match_prog s δ W1 W3. + Hypothesis match_W2_W3: match_prog s (opposite δ) W2 W3. + + Notation cp_main := (comp_of_main W1). + + Hypothesis norepet1: list_norepet (prog_defs_names W1). + Hypothesis norepet2: list_norepet (prog_defs_names W2). + + Notation ge1 := (Genv.globalenv W1). + Notation ge2 := (Genv.globalenv W2). + Notation ge3 := (Genv.globalenv W3). + + Local Opaque Val.add Val.addl Val.sub Val.subl + Val.mul Val.mulhs Val.mulhu Val.mull Val.mullhs Val.mullhu + Val.and Val.or Val.xor Val.andl Val.orl Val.xorl + Val.shl Val.shru Val.shr Val.shll Val.shrlu Val.shrl + Val.cmp Val.cmpl Val.cmpf Val.cmpfs + Val.cmpu Val.cmplu + Val.divs Val.divu Val.divls Val.divlu + Val.mods Val.modu Val.modls Val.modlu + Val.negfs Val.negf Val.absfs Val.absf + Val.addfs Val.addf Val.subfs Val.subf Val.mulfs Val.mulf + Val.divfs Val.divf. + + Local Arguments comp_of /. + + (* Hypothesis first_instr1: *) + (* forall b f i, *) + (* s (comp_of f) = δ -> *) + (* Genv.find_def ge1 b = Some (Gfun (Internal f)) -> *) + (* find_instr (Ptrofs.unsigned Ptrofs.zero) (fn_code f) = Some i -> *) + (* match i with *) + (* | Pallocframe _ _ => True *) + (* | _ => False *) + (* end. *) + + (* Hypothesis first_instr2: *) + (* forall b f i, *) + (* s (comp_of f) = opposite δ -> *) + (* Genv.find_def ge1 b = Some (Gfun (Internal f)) -> *) + (* find_instr (Ptrofs.unsigned Ptrofs.zero) (fn_code f) = Some i -> *) + (* match i with *) + (* | Pallocframe _ _ => True *) + (* | _ => False *) + (* end. *) + + (* Calls *) + Lemma allowed_call_preserved: + forall j__δ cp v v' + (inj_pres: meminj_preserves_globals s δ W1 W3 j__δ) + (delta_zero: mem_delta_zero j__δ), + v <> Vundef -> + Val.inject j__δ v v' -> + Genv.allowed_call ge1 cp v -> + Genv.allowed_call ge3 cp v'. + Proof. + intros * inj_pres delta_zero nundef H allowed. + exploit find_comp_preserved; eauto. + intros same_comp. + destruct allowed as [eq_comp | cross_call]. + - left; congruence. + - right. + inv H; auto; try congruence. + exploit delta_zero; eauto; intros ->; rewrite Ptrofs.add_zero in *. + clear nundef. + destruct cross_call as [id [cp' [inv_symb ?]]]. + exists id, cp'. split. + + apply Genv.invert_find_symbol in inv_symb. + apply Genv.find_invert_symbol. + exploit symbols_inject1; eauto; intros []; auto. + + replace (Genv.genv_policy ge3) with (prog_pol W3) by (symmetry; apply Genv.genv_pol_add_globals). + replace (Genv.genv_policy ge1) with (prog_pol W1) in * by (symmetry; apply Genv.genv_pol_add_globals). + rewrite (match_prog_pol _ _ _ _ match_W1_W3), <- same_comp. + destruct H as [? ?]. split; auto. + unfold Genv.find_funct, Genv.find_funct_ptr in *. + intros fd; specialize (H fd). + destruct (Ptrofs.eq_dec ofs1 Ptrofs.zero); try congruence. + destruct (Genv.find_def ge3 b2) as [[] |] eqn:?; try congruence. + exploit defs_rev_inject; eauto. + intros [? [? [? ?]]]. + rewrite H2 in H. inv H4. simpl. intros G. inv G. + inv H7; auto. specialize (H eq_refl). auto. + Qed. + + Lemma update_stack_call_preserved_internal: + forall j__δ sg rs1 rs3 st1 st1' st3 cp + (delta_zero: mem_delta_zero j__δ), + agrees_with j__δ (init_meminj W1 W3) -> + (rs1 PC <> Vundef) -> + Genv.find_comp ge1 (rs1 PC) = Some cp -> + regset_rel j__δ rs1 rs3 -> + update_stack_call ge1 st1 sg cp rs1 = Some st1' -> + st1' = st1 /\ + update_stack_call ge3 st3 sg cp rs3 = Some st3. + Proof. + intros * delta_zero agr nundef samecomp rs1_rs3. + unfold update_stack_call. + rewrite samecomp, Pos.eqb_refl. + intros R; inv R. + split; eauto. + exploit (agrees_with_init_meminj_find_comp_preserved s W1 W3); eauto. + intros ->. rewrite Pos.eqb_refl; eauto. + Qed. + + Lemma call_arguments_preserved: + forall j__δ m1 m3 rs1 rs3, + mem_rel s ge1 ge3 j__δ δ m1 m3 -> + regset_rel j__δ rs1 rs3 -> + forall sig args, call_arguments rs1 m1 sig args -> + exists args', Val.inject_list j__δ args args' + /\ call_arguments rs3 m3 sig args'. + Proof. + intros * m1_m3 rs1_rs3 sig args H. + unfold call_arguments in H. + unfold call_arguments. + induction H. + - exists nil. split; auto. constructor. + - assert (exists b1', Val.inject j__δ b1 b1' /\ call_arg_pair rs3 m3 a1 b1'). + { inv H. + - inv H1. + + specialize (rs1_rs3 (preg_of r)). + exists (rs3 (preg_of r)). split; eauto. constructor; constructor. + + exploit Mem.loadv_inject; eauto using partial_mem_inject. + eapply Val.offset_ptr_inject. eapply rs1_rs3. + intros [b1' [? ?]]. + exists b1'; split. eauto. constructor. econstructor; eauto. + - inv H1; inv H2. + + pose proof (rs1_rs3 (preg_of r)). + pose proof (rs1_rs3 (preg_of r0)). + eexists; split; [eapply Val.longofwords_inject; eauto |]. + constructor; constructor; eauto. + + pose proof (rs1_rs3 (preg_of r)). + exploit Mem.loadv_inject; eauto using partial_mem_inject. + eapply Val.offset_ptr_inject. eapply rs1_rs3. + intros [b1' [? ?]]. + eexists; split; [eapply Val.longofwords_inject; eauto |]. + constructor; econstructor; eauto. + + pose proof (rs1_rs3 (preg_of r)). + exploit Mem.loadv_inject; eauto using partial_mem_inject. + eapply Val.offset_ptr_inject. eapply rs1_rs3. + intros [b1' [? ?]]. + eexists; split; [eapply Val.longofwords_inject; eauto |]. + constructor; econstructor; eauto. + + exploit Mem.loadv_inject; eauto using partial_mem_inject. + eapply Val.offset_ptr_inject. eapply rs1_rs3. clear H1. + exploit Mem.loadv_inject; eauto using partial_mem_inject. + eapply Val.offset_ptr_inject. eapply rs1_rs3. + intros [b1' [? ?]]. + intros [b0' [? ?]]. + eexists; split; [eapply Val.longofwords_inject; eauto |]. + constructor; econstructor; eauto. } + destruct IHlist_forall2 as [? [? ?]]. + destruct H1 as [? [? ?]]. + eexists (cons _ _); split. + + constructor; eassumption. + + constructor; eauto. + Qed. + + Lemma call_trace_preserved: + forall j__δ cp cp' v v' args args' sig t + (* (inj_pres: meminj_preserves_globals s δ W1 W3 j__δ) *) + (agr: agrees_with j__δ (init_meminj W1 W3)) + (delta_zero: mem_delta_zero j__δ), + Val.inject j__δ v v' -> + Val.inject_list j__δ args args' -> + (Genv.type_of_call cp cp' = Genv.CrossCompartmentCall -> Forall not_ptr args) -> + call_trace ge1 cp cp' v args (sig_args sig) t -> + call_trace ge3 cp cp' v' args' (sig_args sig) t. + Proof. + intros j__δ cp cp' v v' args args' sig t (* inj_pres *) agr delta_zero inj_v inj_args NPTR EV. + inv EV. + - constructor; auto. + - specialize (NPTR H). + inv inj_v; eauto. + econstructor; eauto. apply Genv.find_invert_symbol. + apply Genv.invert_find_symbol in H1. + eapply (symbols_inject2 _ _ W1 W3 (init_meminj W1 W3)) in H1; + eauto using init_meminj_preserves_globals. + destruct H1 as [? [? ?]]; eauto. + exploit agr; eauto. intros []; subst; eauto. + (* eapply Genv.invert_find_symbol; eauto. *) + remember (sig_args sig) as tys. + clear -inj_args NPTR H2. + revert args args' tys vl inj_args NPTR H2. + induction args;intros args' tys vl inj_args NPTR Hmatch. + + inv inj_args; inv Hmatch; constructor. + + inv inj_args; inv Hmatch; inv NPTR. + constructor; eauto. + inv H1; inv H5; try contradiction; econstructor; eauto. + Qed. + + (* Returns *) + Lemma update_stack_return_preserved_internal: + forall j__δ rs1 rs3 st1 st1' st3 cp + (agr: agrees_with j__δ (init_meminj W1 W3)) + (delta_zero: mem_delta_zero j__δ), + (rs1 PC <> Vundef) -> + Genv.find_comp ge1 (rs1 PC) = Some cp -> + regset_rel j__δ rs1 rs3 -> + update_stack_return ge1 st1 cp rs1 = Some st1' -> + st1' = st1 /\ + update_stack_return ge3 st3 cp rs3 = Some st3. + Proof. + intros * agr delta_zero nundef samecomp rs1_rs3 (* st_rel *). + unfold update_stack_return. + rewrite samecomp, Pos.eqb_refl. + intros R; inv R. + split; eauto. + exploit (agrees_with_init_meminj_find_comp_preserved s W1 W3); eauto. + intros ->. rewrite Pos.eqb_refl. reflexivity. + Qed. + + (* State inversion *) + Lemma strong_equiv_state_internal_inv: + forall j__δ st1 rs1 m1 s3 b ofs f i, + (* meminj_preserves_globals s δ W1 W3 j__δ -> *) + agrees_with j__δ (init_meminj W1 W3) -> + strong_equivalence s ge1 ge3 j__δ δ (State st1 rs1 m1) s3 -> + rs1 PC = Vptr b ofs -> + Genv.find_def ge1 b = Some (Gfun (Internal f)) -> + find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i -> + exists st3 rs3 m3 b' f', + s3 = State st3 rs3 m3 /\ + rs3 PC = Vptr b' ofs /\ + Genv.find_def ge3 b' = Some (Gfun (Internal f')) /\ + (match_fundef (Internal f) (Internal f') /\ + (forall id : ident, Genv.find_symbol ge1 id = Some b -> kept_genv s ge1 δ id = true -> f = f')) /\ + mem_rel s ge1 ge3 j__δ δ m1 m3 /\ + regset_rel j__δ rs1 rs3 /\ + s (comp_of f) = δ. + Proof. + intros * inj_pres equiv eq_pc find_fun find_ins (* inj_b_b' *). + assert (exists b', j__δ b = Some (b', 0)) as [b' inj_b_b']. + { inv equiv. + specialize (H5 PC). inv H5; try congruence. + exploit delta_zero; eauto; intros ->; rewrite Ptrofs.add_zero in *. + exists b2. congruence. } + exploit (agrees_with_init_meminj_find_def_preserved s W1 W3); eauto. + intros [fd' [find_fun' [match_f_f' left_implies_eq]]]. + assert (exists f', fd' = (Gfun (Internal f'))) as [f' ?] by + now inversion match_f_f' as [? ? H | ? ? H]; inv H; eauto. + subst fd'. + inv match_f_f'; inv equiv. + eexists; eexists; eexists; eexists; eexists; split; eauto. + pose proof (H6 PC) as inj. + rewrite eq_pc in *; simpl in *. inv inj. + assert (b' = b2) by congruence; subst b2; + assert (delta = 0) by congruence; subst delta. + rewrite Ptrofs.add_zero. split; auto. + rewrite find_fun'. + repeat (split; auto). + - intros; exploit left_implies_eq; eauto; congruence. + - unfold Genv.find_comp_of_block in H3; rewrite find_fun in H3. + now inv H3. + Qed. + + Lemma strong_equiv_state_external_inv: + forall j__δ st1 rs1 m1 s3 b ofs f, + agrees_with j__δ (init_meminj W1 W3) -> + (* meminj_preserves_globals s δ W1 W3 j__δ -> *) + strong_equivalence s ge1 ge3 j__δ δ (State st1 rs1 m1) s3 -> + rs1 PC = Vptr b ofs -> + Genv.find_def ge1 b = Some (Gfun (External f)) -> + exists st3 rs3 m3 b', + s3 = State st3 rs3 m3 /\ + rs3 PC = Vptr b' ofs /\ + Genv.find_def ge3 b' = Some (Gfun (External f)) /\ + mem_rel s ge1 ge3 j__δ δ m1 m3 /\ + regset_rel j__δ rs1 rs3 /\ + s (comp_of f) = δ. + Proof. + intros * inj_pres equiv eq_pc find_fun (* inj_b_b' *). + assert (exists b', j__δ b = Some (b', 0)) as [b' inj_b_b']. + { inv equiv. + specialize (H5 PC). inv H5; try congruence. + exploit delta_zero; eauto; intros ->; rewrite Ptrofs.add_zero in *. + exists b2. congruence. } + exploit (agrees_with_init_meminj_find_def_preserved s W1 W3); eauto. + intros [fd' [find_fun' [match_f_f' left_implies_eq]]]. + inv equiv; inv match_f_f'. inv H0. + eexists; eexists; eexists; eexists; split; eauto. + pose proof (H5 PC) as inj. + rewrite eq_pc in *; simpl in *. inv inj. + assert (b' = b2) by congruence; subst b2; + assert (delta = 0) by congruence; subst delta. + rewrite Ptrofs.add_zero. split; auto. + repeat (split; auto). + unfold Genv.find_comp_of_block in H2. rewrite find_fun in H2. now inv H2. + Qed. + + Lemma strong_equiv_returnstate_inv: + forall j__δ st1 rs1 m1 s3 rec_cp, + (* agrees_with j__δ (init_meminj W1 W3) -> *) + (* meminj_preserves_globals s δ W1 W3 j__δ -> *) + strong_equivalence s ge1 ge3 j__δ δ (ReturnState st1 rs1 m1 rec_cp) s3 -> + exists st3 rs3 m3, + s3 = ReturnState st3 rs3 m3 rec_cp /\ + mem_rel s ge1 ge3 j__δ δ m1 m3 /\ + regset_rel j__δ rs1 rs3. + Proof. + intros * equiv. + inv equiv. + eexists; eexists; eexists; split; eauto. + Qed. + + (* Builtins and external calls arguments *) + Lemma eval_builtin_arg_inject: + forall (rs: regset) cp m j__δ rs' m' a v + (eval: eval_builtin_arg ge1 rs cp (rs X2) m a v) + (agr: agrees_with j__δ (init_meminj W1 W3)) + (* (inj_pres: meminj_preserves_globals s δ W1 W3 j__δ) *) + (m_m': mem_rel s ge1 ge3 j__δ δ m m') + (delta_zero: mem_delta_zero j__δ), + regset_rel j__δ rs rs' -> + Mem.inject j__δ m m' -> + exists v', + eval_builtin_arg ge3 rs' cp (rs' X2) m' a v' + /\ Val.inject j__δ v v'. + Proof. + induction 1; intros AGR MREL DZ RS MI. + - exists rs'#x; split; auto. constructor. + - econstructor; eauto with barg. + - econstructor; eauto with barg. + - econstructor; eauto with barg. + - econstructor; eauto with barg. + - specialize (RS X2); destruct (rs X2); inv RS; simpl in H; try congruence. + exploit DZ; eauto; intros ->. + rewrite Ptrofs.add_zero in *. + exploit Mem.load_inject; eauto. + intros (v' & A & B). exists v'; split; auto with barg. + rewrite Z.add_0_r in A. + econstructor. simpl; eauto. + - econstructor; split; eauto with barg. + eapply Val.offset_ptr_inject. now apply RS. + - assert (Val.inject j__δ (Senv.symbol_address ge1 id ofs) (Senv.symbol_address ge3 id ofs)). + { unfold Senv.symbol_address in *; simpl; unfold Genv.symbol_address in *. + destruct (Genv.find_symbol ge1 id) as [b|] eqn:FS; auto. + simpl in H. + Local Transparent Mem.load. + unfold Mem.load in H. Local Opaque Mem.load. + destruct (Mem.valid_access_dec) as [e | n]; try congruence. + unfold Mem.valid_access in e. + destruct e as [_ [e ?]]. simpl in e. + admit. + (* exploit symbols_inject2; eauto. intros (b' & A & B). rewrite A. *) + (* econstructor; eauto. rewrite Ptrofs.add_zero; auto. } *) + } + exploit Mem.loadv_inject; eauto. intros (v' & A & B). + exists v'; split; auto with barg. + (* econstructor. simpl; eauto. *) + - econstructor; split; eauto with barg. subst res. + unfold Genv.symbol_address; simpl; unfold Genv.symbol_address. + admit. + (* destruct (Genv.find_symbol ge1 id) as [b|] eqn:FS; auto. *) + (* exploit symbols_inject2; eauto. intros (b' & A & B). rewrite A. *) + (* destruct (Genv.find_comp_of_block ge1 b) eqn:FB; auto. *) + (* erewrite <- (find_comp_of_block_preserved s W1 W3); eauto. rewrite FB. *) + (* destruct (cp =? c)%positive; auto. *) + (* econstructor; eauto. now rewrite Ptrofs.add_zero. *) + (* destruct (Genv.find_def ge1 b) as [[] |] eqn:?; auto. *) + (* exploit defs_inject; eauto. *) + (* intros ([] & ? & _ & ? & ?). rewrite H. *) + (* econstructor; eauto. now rewrite Ptrofs.add_zero. *) + (* inv H0. *) + - destruct IHeval1 as (v1' & A1 & B1); eauto using in_or_app. + destruct IHeval2 as (v2' & A2 & B2); eauto using in_or_app. + exists (Val.longofwords v1' v2'); split; auto with barg. + apply Val.longofwords_inject; auto. + - destruct IHeval1 as (v1' & A1 & B1); eauto using in_or_app. + destruct IHeval2 as (v2' & A2 & B2); eauto using in_or_app. + econstructor; split; eauto with barg. + destruct Archi.ptr64; auto using Val.add_inject, Val.addl_inject. + Admitted. + + Lemma eval_builtin_args_inject: + forall (rs: regset) cp m j__δ rs' m' al vl + (eval: eval_builtin_args ge1 rs cp (rs X2) m al vl) + (* (inj_pres: meminj_preserves_globals s δ W1 W3 j__δ) *) + (agr: agrees_with j__δ (init_meminj W1 W3)) + (m_m': mem_rel s ge1 ge3 j__δ δ m m') + (delta_zero: mem_delta_zero j__δ), + regset_rel j__δ rs rs' -> + Mem.inject j__δ m m' -> + (* (forall id, In id (globals_of_builtin_args al) -> kept id) -> *) + exists vl', + eval_builtin_args ge3 rs' cp (rs' X2) m' al vl' + /\ Val.inject_list j__δ vl vl'. + Proof. + induction 1; intros. + - exists (@nil val); split; constructor. + - exploit eval_builtin_arg_inject; eauto using in_or_app. intros (v1' & A & B). + destruct IHeval as (vl' & C & D); eauto using in_or_app. + exists (v1' :: vl'); split; constructor; auto. + Qed. + + Lemma extcall_arguments_preserved: + forall j__δ δ m1 m3 rs1 rs3, + mem_rel s ge1 ge3 j__δ δ m1 m3 -> + regset_rel j__δ rs1 rs3 -> + forall sig args, extcall_arguments rs1 m1 sig args -> + exists args', Val.inject_list j__δ args args' + /\ extcall_arguments rs3 m3 sig args'. + Proof. + intros * m1_m3 rs1_rs3 sig args H. + unfold extcall_arguments in H. + unfold extcall_arguments. + induction H. + - exists nil. split; auto. constructor. + - assert (exists b1', Val.inject j__δ b1 b1' /\ extcall_arg_pair rs3 m3 a1 b1'). + { inv H. + - inv H1. + + specialize (rs1_rs3 (preg_of r)). + exists (rs3 (preg_of r)). split; eauto. constructor; constructor. + + exploit Mem.loadv_inject; eauto using partial_mem_inject. + eapply Val.offset_ptr_inject. eapply rs1_rs3. + intros [b1' [? ?]]. + exists b1'; split. eauto. constructor. econstructor; eauto. + - inv H1; inv H2. + + pose proof (rs1_rs3 (preg_of r)). + pose proof (rs1_rs3 (preg_of r0)). + eexists; split; [eapply Val.longofwords_inject; eauto |]. + constructor; constructor; eauto. + + pose proof (rs1_rs3 (preg_of r)). + exploit Mem.loadv_inject; eauto using partial_mem_inject. + eapply Val.offset_ptr_inject. eapply rs1_rs3. + intros [b1' [? ?]]. + eexists; split; [eapply Val.longofwords_inject; eauto |]. + constructor; econstructor; eauto. + + pose proof (rs1_rs3 (preg_of r)). + exploit Mem.loadv_inject; eauto using partial_mem_inject. + eapply Val.offset_ptr_inject. eapply rs1_rs3. + intros [b1' [? ?]]. + eexists; split; [eapply Val.longofwords_inject; eauto |]. + constructor; econstructor; eauto. + + exploit Mem.loadv_inject; eauto using partial_mem_inject. + eapply Val.offset_ptr_inject. eapply rs1_rs3. clear H1. + exploit Mem.loadv_inject; eauto using partial_mem_inject. + eapply Val.offset_ptr_inject. eapply rs1_rs3. + intros [b1' [? ?]]. + intros [b0' [? ?]]. + eexists; split; [eapply Val.longofwords_inject; eauto |]. + constructor; econstructor; eauto. } + destruct IHlist_forall2 as [? [? ?]]. + destruct H1 as [? [? ?]]. + eexists (cons _ _); split. + + constructor; eassumption. + + constructor; eauto. + Qed. + + Lemma exec_instr_preserved: + forall j__δ j__oppδ f i rs1 rs1' rs3 m1 m1' m2 m3 st1 st2 st3, + s |= has_comp_function f ∈ δ -> + agrees_with j__δ (init_meminj W1 W3) -> + def_on_addressable s ge1 j__δ δ -> + mem_rel s ge1 ge3 j__δ δ m1 m3 -> + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3 -> + regset_rel j__δ rs1 rs3 -> + stack_rel s ge3 δ j__δ j__oppδ st1 st2 st3 -> + exec_instr ge1 f i rs1 m1 (has_comp_function f) = Next rs1' m1' -> + exists j__δ' rs3' m3', + exec_instr ge3 f i rs3 m3 (has_comp_function f) = Next rs3' m3' /\ + agrees_with j__δ' (init_meminj W1 W3) /\ + def_on_addressable s ge1 j__δ' δ /\ + mem_rel s ge1 ge3 j__δ' δ m1' m3' /\ + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3' /\ + regset_rel j__δ' rs1' rs3' /\ + stack_rel s ge3 δ j__δ' j__oppδ st1 st2 st3. + Proof. + intros until st3. + intros side_cp inj_pres addressable m1_m3 m2_m3 rs1_rs3 st1_st3 exec. + + Local Opaque Val.cmpu_bool Val.cmplu_bool. + (* Local Opaque low_half high_half. *) + Local Opaque opposite. + + destruct i; inv exec; simpl in *; + try now (simpl_before_exists; (eexists_and_split + ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => + (simpl; try reflexivity; try eassumption; + solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity)))). + - (eexists_and_split + ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => + (simpl; try reflexivity; try eassumption; + solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity))). + destruct (Genv.symbol_address ge1 symb Ptrofs.zero) eqn:FS; eauto. + exploit (symbol_address_inject s δ W1 W3 (init_meminj W1 W3) symb Ptrofs.zero); + eauto using init_meminj_preserves_globals. + rewrite FS. intros H. inv H. + erewrite <- (find_comp_of_block_preserved s W1 W3); + eauto using init_meminj_preserves_globals. + destruct (Genv.find_comp_of_block ge1 b) eqn:?; eauto. + destruct (has_comp_function f =? c)%positive eqn:?; eauto. + econstructor; eauto. + { assert (exists b1 delta', j__δ b = Some (b1, delta')) as (b1 & delta' & ?). + { unfold Genv.symbol_address in FS. + destruct (Genv.find_symbol ge1 symb) eqn:?; eauto; try congruence. + inv FS. + exploit addressable; eauto. left; eauto. rewrite Heqo. + apply Pos.eqb_eq in Heqb0. simpl in *; congruence. } + specialize (inj_pres b b1 b2 delta' delta H H3) as [? ?]; subst; eauto. } + destruct (Genv.find_def ge1 b) as [[] |] eqn:?; eauto. + exploit defs_inject; eauto using init_meminj_preserves_globals. + intros ([] & ? & _ & ? & ?). rewrite H. + econstructor; eauto. + { assert (exists b1 delta', j__δ b = Some (b1, delta')) as (b1 & delta' & ?). + { unfold Genv.symbol_address in FS. + destruct (Genv.find_symbol ge1 symb) eqn:?; eauto; try congruence. + inv FS. + exploit addressable; eauto. } + specialize (inj_pres b b1 b2 delta' delta H4 H3) as [? ?]; subst; eauto. } + inv H0. + intros ????. exploit init_meminj_invert; eauto. intros []; eauto. + - (eexists_and_split + ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => + (simpl; try reflexivity; try eassumption; + solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity))). + destruct (Genv.symbol_address ge1 symb Ptrofs.zero) eqn:FS; eauto. + exploit (symbol_address_inject s δ W1 W3 (init_meminj W1 W3) symb Ptrofs.zero); + eauto using init_meminj_preserves_globals. + rewrite FS. intros H. inv H. + erewrite <- (find_comp_of_block_preserved s W1 W3); + eauto using init_meminj_preserves_globals. + destruct (Genv.find_comp_of_block ge1 b) eqn:?; eauto. + destruct (has_comp_function f =? c)%positive eqn:?; eauto. + econstructor; eauto. + { assert (exists b1 delta', j__δ b = Some (b1, delta')) as (b1 & delta' & ?). + { unfold Genv.symbol_address in FS. + destruct (Genv.find_symbol ge1 symb) eqn:?; eauto; try congruence. + inv FS. + exploit addressable; eauto. left; eauto. rewrite Heqo. + apply Pos.eqb_eq in Heqb0. simpl in *; congruence. } + specialize (inj_pres b b1 b2 delta' delta H H3) as [? ?]; subst; eauto. } + destruct (Genv.find_def ge1 b) as [[] |] eqn:?; eauto. + exploit defs_inject; eauto using init_meminj_preserves_globals. + intros ([] & ? & _ & ? & ?). rewrite H. + econstructor; eauto. + { assert (exists b1 delta', j__δ b = Some (b1, delta')) as (b1 & delta' & ?). + { unfold Genv.symbol_address in FS. + destruct (Genv.find_symbol ge1 symb) eqn:?; eauto; try congruence. + inv FS. + exploit addressable; eauto. } + specialize (inj_pres b b1 b2 delta' delta H4 H3) as [? ?]; subst; eauto. } + inv H0. + intros ????. exploit init_meminj_invert; eauto. intros []; eauto. + (* - (* Not sure why this one breaks *) *) + (* simpl_before_exists. *) + (* (eexists_and_split *) + (* ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => *) + (* (simpl; try reflexivity; try eassumption; *) + (* solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity))). *) + (* assert (m4 = m5) by congruence; subst; eauto. *) + (* assert (m4 = m5) by congruence; subst; eauto. *) + (* congruence. *) + - (eexists_and_split + ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => + (simpl; try reflexivity; try eassumption; + solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity))). + destruct (Genv.symbol_address ge1 id ofs) eqn:FS; eauto. + exploit (symbol_address_inject s δ W1 W3 (init_meminj W1 W3) id ofs); + eauto using init_meminj_preserves_globals. + rewrite FS. intros H. inv H. + erewrite <- (find_comp_of_block_preserved s W1 W3); + eauto using init_meminj_preserves_globals. + destruct (Genv.find_comp_of_block ge1 b) eqn:?; eauto. + destruct (has_comp_function f =? c)%positive eqn:?; eauto. + econstructor; eauto. + { assert (exists b1 delta', j__δ b = Some (b1, delta')) as (b1 & delta' & ?). + { unfold Genv.symbol_address in FS. + destruct (Genv.find_symbol ge1 id) eqn:?; eauto; try congruence. + inv FS. + exploit addressable; eauto. left; eauto. rewrite Heqo. + apply Pos.eqb_eq in Heqb0. simpl in *; congruence. } + specialize (inj_pres b b1 b2 delta' delta H H3) as [? ?]; subst; eauto. } + destruct (Genv.find_def ge1 b) as [[] |] eqn:?; eauto. + exploit defs_inject; eauto using init_meminj_preserves_globals. + intros ([] & ? & _ & ? & ?). rewrite H. + econstructor; eauto. + { assert (exists b1 delta', j__δ b = Some (b1, delta')) as (b1 & delta' & ?). + { unfold Genv.symbol_address in FS. + destruct (Genv.find_symbol ge1 id) eqn:?; eauto; try congruence. + inv FS. + exploit addressable; eauto. } + specialize (inj_pres b b1 b2 delta' delta H4 H3) as [? ?]; subst; eauto. } + inv H0. + intros ????. exploit init_meminj_invert; eauto. intros []; eauto. + - (eexists_and_split + ltac:(fun j rs1 rs3 rs1_rs3 m1 m3 m1_m3 => + (simpl; try reflexivity; try eassumption; + solve_simple_regset_rel j rs1 rs3 rs1_rs3 m1 m3 m1_m3; try reflexivity))). + replace (high_half ge1 id ofs) with (Genv.symbol_address ge1 id ofs). + replace (high_half ge3 id ofs) with (Genv.symbol_address ge3 id ofs). + destruct (Genv.symbol_address ge1 id ofs) eqn:FS; eauto. + exploit (symbol_address_inject s δ W1 W3 (init_meminj W1 W3) id ofs); + eauto using init_meminj_preserves_globals. + rewrite FS. intros H. inv H. + erewrite <- (find_comp_of_block_preserved s W1 W3); + eauto using init_meminj_preserves_globals. + destruct (Genv.find_comp_of_block ge1 b) eqn:?; eauto. + destruct (has_comp_function f =? c)%positive eqn:?; eauto. + econstructor; eauto. + { assert (exists b1 delta', j__δ b = Some (b1, delta')) as (b1 & delta' & ?). + { unfold Genv.symbol_address in FS. + destruct (Genv.find_symbol ge1 id) eqn:?; eauto; try congruence. + inv FS. + exploit addressable; eauto. left; eauto. rewrite Heqo. + apply Pos.eqb_eq in Heqb0. simpl in *; congruence. } + specialize (inj_pres b b1 b2 delta' delta H H3) as [? ?]; subst; eauto. } + destruct (Genv.find_def ge1 b) as [[] |] eqn:?; eauto. + exploit defs_inject; eauto using init_meminj_preserves_globals. + intros ([] & ? & _ & ? & ?). rewrite H. + econstructor; eauto. + { assert (exists b1 delta', j__δ b = Some (b1, delta')) as (b1 & delta' & ?). + { unfold Genv.symbol_address in FS. + destruct (Genv.find_symbol ge1 id) eqn:?; eauto; try congruence. + inv FS. + exploit addressable; eauto. } + specialize (inj_pres b b1 b2 delta' delta H4 H3) as [? ?]; subst; eauto. } + inv H0. + intros ????. exploit init_meminj_invert; eauto. intros []; eauto. + reflexivity. reflexivity. + Unshelve. + all: try assumption. + all: now eapply match_prog_unique; eauto. + Qed. + + + Lemma exec_instr_preserves_weak: + forall j__δ j__oppδ f i rs2 rs2' m2 m2' m3 st1 st2 st3, + s (has_comp_function f) = δ -> + exec_instr ge2 f i rs2 m2 (has_comp_function f) = Next rs2' m2' -> + agrees_with j__oppδ (init_meminj W2 W3) -> + def_on_addressable s ge2 j__oppδ (opposite δ) -> + (* meminj_preserves_globals s (opposite δ) W2 W3 j__oppδ -> *) + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3 -> + stack_rel s ge3 δ j__δ j__oppδ st1 st2 st3 -> + exists j__oppδ', + agrees_with j__oppδ' (init_meminj W2 W3) /\ + def_on_addressable s ge2 j__oppδ' (opposite δ) /\ + mem_rel s ge2 ge3 j__oppδ' (opposite δ) m2' m3 /\ + stack_rel s ge3 δ j__δ j__oppδ' st1 st2 st3. + Proof. + intros j__δ j__oppδ f i rs2 rs2' m2 m2' m3 st1 st2 st3 side_f exec agr addr (* inj_pres *) m2_m3 st_rel. + destruct i; inv exec; simpl in *; + try (now simpl_before_exists; eauto); + try (now exploit exec_store_preserves_weak; eauto). + - (* alloc + store *) + simpl_before_exists. + exploit alloc_preserves_weak; eauto. + intros [j' [? [? [? ?]]]]. + exploit store_preserves_weak; eauto. + intros ?. exists j'; split; [| split]; eauto using inject_incr_stack_rel2. + (* now eapply def_on_addressable_incr; eauto. *) + - (* free *) + simpl_before_exists. + exists j__oppδ; split; [| split; [| split]]; auto. + constructor. + + intros b'. apply same_dom in m2_m3. + specialize (m2_m3 b'). + simpl in *. erewrite Mem.free_result with (m2 := m2'); eauto. unfold Mem.unchecked_free in *. + destruct (zle sz 0); now subst. + + eapply Mem.free_left_inject; eauto using partial_mem_inject. + + eapply delta_zero; eauto. + + erewrite Mem.nextblock_free; eauto using ple_nextblock1. + + eapply ple_nextblock2; eauto. + + intros. eapply Mem.valid_block_free_1; eauto using find_def_valid1. + + intros. eapply find_def_valid2; eauto. + + intros. intros n. + eapply find_def_perm1; eauto. + eapply Mem.perm_free_3; eauto. + + intros. eapply find_def_perm2; eauto. + + intros. eapply same_high_half; eauto. + Qed. + + (* External calls preserved *) + Lemma external_call_inject_left: + forall ef vargs m1 t vres m2 j__δ j__oppδ m1' vargs' m3 rs1 rs3 st1 st2 st3, + s (comp_of ef) = δ -> + meminj_preserves_globals s δ W1 W3 j__δ -> + (* agrees_with j__δ (init_meminj W1 W3) -> *) + external_call ef ge1 vargs m1 t vres m1' -> + Val.inject_list j__δ vargs vargs' -> + + mem_rel s ge1 ge3 j__δ δ m1 m3 -> + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3 -> + regset_rel j__δ rs1 rs3 -> + stack_rel s ge3 δ j__δ j__oppδ st1 st2 st3 -> + + exists j__δ', exists vres', exists m3', + external_call ef ge3 vargs' m3 t vres' m3' + /\ Val.inject j__δ' vres vres' + /\ Mem.unchanged_on (loc_unmapped j__δ) m1 m1' + /\ Mem.unchanged_on (loc_out_of_reach j__δ m1) m3 m3' + /\ inject_incr j__δ j__δ' + /\ inject_separated j__δ j__δ' m1 m3 /\ + (* agrees_with j__δ' (init_meminj W1 W3) /\ *) + meminj_preserves_globals s δ W1 W3 j__δ' /\ + mem_rel s ge1 ge3 j__δ' δ m1' m3' /\ + mem_rel s ge2 ge3 j__oppδ (opposite δ) m2 m3' /\ + regset_rel j__δ' rs1 rs3 /\ + stack_rel s ge3 δ j__δ' j__oppδ st1 st2 st3. + Proof. + intros * s_ef inj_pres extcall1 inj_args m1_m3 m2_m3 rs1_rs3 st_rel. + (* assert (exists j, meminj_preserves_globals s δ W1 W3 j /\ *) + (* agrees_with j__δ j /\ *) + (* Mem.inject j m1 m3 /\ *) + (* Val.inject_list j vargs vargs') as [j [? [? [? ?]]]]. *) + (* { exists (fun b => match init_meminj W1 W3 b with *) + (* | Some p => Some p *) + (* | None => j__δ b *) + (* end). *) + (* pose proof (init_meminj_preserves_globals s δ W1 W3 match_W1_W3) as X. *) + (* split; [| split; [| split]]. *) + (* - constructor. *) + (* + intros. destruct (init_meminj W1 W3 b) as [[] |] eqn:G; try congruence. *) + (* inv H. exploit symbols_inject1; eauto. *) + (* unfold init_meminj in G. *) + (* exploit (transform_find_symbol_1 s δ W1 W3); eauto. intros [? ?]. *) + (* apply Genv.find_invert_symbol in H0. rewrite H0 in G. *) + (* rewrite H1 in G. congruence. *) + (* + intros. exploit symbols_inject2; eauto. *) + (* intros [? [-> ->]]. eauto. *) + (* + intros. exploit symbols_inject3; eauto. *) + (* intros [? [A B]]. eexists; rewrite A, B; eauto. *) + (* + intros. destruct (init_meminj W1 W3 b) as [[] |] eqn:G; try congruence. *) + (* inv H. exploit defs_inject; eauto. *) + (* exploit Genv.find_def_find_symbol_inversion; eauto. intros [? ?]. *) + (* exploit (transform_find_symbol_1 s δ W1 W3); eauto. intros [? ?]. *) + (* apply Genv.find_invert_symbol in H1. *) + (* unfold init_meminj in G. rewrite H1, H2 in G. congruence. *) + (* + intros. destruct (init_meminj W1 W3 b) as [[] |] eqn:G; try congruence. *) + (* inv H. exploit defs_rev_inject; eauto. *) + (* admit. *) + (* - intros ??????. *) + (* destruct (init_meminj W1 W3 b) as [[] |] eqn:?; try congruence. *) + (* intros ?. inv H0. eapply inj_pres; eauto. *) + (* intros. rewrite H0 in H. inv H. eauto. *) + (* - admit. *) + (* - admit. } *) + exploit external_call_mem_inject_gen; + eauto using globals_symbols_inject, partial_mem_inject. + intros + (j__δ' & vres' & m3' & extcall3 & inj_res & inj_mem & unchanged1 & unchanged2 & incr & inj_sep & comp_new). + + (* exists (fun b => match Genv.find_comp_of_block ge1 b with *) + (* | Some cp => if side_eq (s cp) δ then *) + (* j__δ' b *) + (* else match Genv.find_def ge1 b with *) + (* | Some (Gfun _) => j__δ' b *) + (* | _ => None *) + (* end *) + (* | None => j__δ' b *) + (* end). *) + eexists; eexists; eexists; intuition eauto. + - assert (meminj_preserves_globals s δ W1 W3 j__δ -> + mem_rel s ge1 ge3 j__δ δ m1 m3 -> + inject_incr j__δ j__δ' -> + inject_separated j__δ j__δ' m1 m3 -> + meminj_preserves_globals s δ W1 W3 j__δ'). + { clear. intros m1_m3 inj_pres incr inj_sep. + constructor. + - (* symbols_inject1 *) + intros. + exploit symbols_inject2; eauto. + intros [? [? ?]]. eapply symbols_inject1; eauto. + erewrite (incr b) in *; eauto. congruence. + - (* symbols_inject2 *) + intros. + exploit symbols_inject2; eauto. + intros [? [? ?]]. + now erewrite (incr b) in *; eauto. + - (* symbols_inject3 *) + intros. + exploit symbols_inject3; eauto. + intros [? [? ?]]. eexists. + erewrite (incr x) in *; eauto. + - (* defs_inject *) + intros. exploit defs_inject; eauto. + destruct (j__δ b) as [[] |] eqn:j_b; [erewrite (incr b) in *; eauto |]. + exfalso. + exploit inj_sep; eauto. exploit find_def_valid1; eauto. intros ? [? ?]; congruence. + - (* defs_rev_inject *) + intros. exploit defs_rev_inject; eauto. + destruct (j__δ b) as [[] |] eqn:j_b; [erewrite (incr b) in *; eauto |]. + exfalso. + exploit inj_sep; eauto. exploit find_def_valid2; eauto. intros ? [? ?]; congruence. } + eauto. + - exploit extcall_preserves_mem_rel_same_side; eauto. + - exploit extcall_preserves_mem_rel_opp_side2; eauto. + now destruct δ. + - intros x. exploit val_inject_incr; eauto. + - exploit inject_incr_stack_rel1; eauto. + Qed. + + (* Lemmas about correct register invalidation *) + Lemma regset_rel_return_from_builtin: + forall j rs1 rs2 vres vres' ef res + (RES_NOT_PC : exists reg : builtin_res mreg, res = map_builtin_res preg_of reg), + regset_rel j rs1 rs2 -> + Val.inject j vres vres' -> + regset_rel j + (nextinstr (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs1 # X1 <- Vundef) # X31 <- Vundef))) + (nextinstr (set_res res vres' (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs2 # X1 <- Vundef) # X31 <- Vundef))). + Proof. + intros j rs1 rs2 vres vres' ef res RES_NOT_PC H res_inj. + apply regset_rel_inject; auto. + - assert (H': regset_rel j + (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs1 # X1 <- Vundef) # X31 <- Vundef) + (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs2 # X1 <- Vundef) # X31 <- Vundef)). + { remember (map preg_of (destroyed_by_builtin ef)) as pregs eqn:X. clear X. + assert (rel: regset_rel j ((rs1 # X1 <- Vundef) # X31 <- Vundef) ((rs2 # X1 <- Vundef) # X31 <- Vundef)). + { do 2 (apply regset_rel_inject; auto). } + remember ((rs2 # X1 <- Vundef) # X31 <- Vundef) as regs'. + remember ((rs1 # X1 <- Vundef) # X31 <- Vundef) as regs. + clear -rel. + revert regs regs' rel. + induction pregs. + - now auto. + - intros. simpl. apply IHpregs. apply regset_rel_inject; auto. } + remember (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs1 # X1 <- Vundef) # X31 <- Vundef) + as regs1 eqn:X; clear X. + remember (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs2 # X1 <- Vundef) # X31 <- Vundef) + as regs2 eqn:X; clear X. + clear -res_inj H'. + revert regs1 regs2 vres vres' res_inj H'. + induction res; intros. + + simpl; apply regset_rel_inject; auto. + + simpl; auto. + + simpl; auto. apply IHres2; auto using Val.loword_inject. + eapply IHres1; auto using Val.hiword_inject. + - destruct RES_NOT_PC as [reg ?]; subst res. + assert (H': Asmgenproof0.preg_notin PC (destroyed_by_builtin ef)). + { Local Transparent destroyed_by_builtin. + unfold destroyed_by_builtin. + destruct ef; simpl; auto. + - destruct orb; simpl; intuition. + destruct orb; simpl; intuition. + - intuition. + - induction clobbers. + + simpl; auto. + + simpl. destruct register_by_name; auto. + simpl; intuition. + destruct (destroyed_by_clobber clobbers); [| split]; now destruct m. + Local Opaque destroyed_by_builtin. } + rewrite 2!Asmgenproof0.set_res_other; auto. + rewrite 2!Asmgenproof0.undef_regs_other_2; auto. + Simpl. apply Val.offset_ptr_inject. now apply H. + Qed. + + Lemma regset_rel_return_from_external: + forall j rs1 rs2 ef res1 res2, + regset_rel j rs1 rs2 -> + Val.inject j res1 res2 -> + regset_rel j ((set_pair (loc_external_result (ef_sig ef)) res1 (undef_caller_save_regs rs1)) # PC <- (rs1 X1)) + ((set_pair (loc_external_result (ef_sig ef)) res2 (undef_caller_save_regs rs2)) # PC <- (rs2 X1)). + Proof. + intros j rs1 rs2 ef res1 res2 H H0. + eapply regset_rel_inject; eauto. + destruct (loc_external_result (ef_sig ef)). + - eapply regset_rel_inject; eauto. + { unfold undef_caller_save_regs. + intros x. destruct orb; auto. } + - eapply regset_rel_inject; eauto using Val.loword_inject. + eapply regset_rel_inject; eauto using Val.hiword_inject. + { unfold undef_caller_save_regs. + intros x. destruct orb; auto. } + Qed. + + + Notation comp_of1 := (@comp_of _ (has_comp_state W1)). + Notation comp_of2 := (@comp_of _ (has_comp_state W2)). + Notation comp_of3 := (@comp_of _ (has_comp_state W3)). + + Definition stack_of_state (s: state) := + match s with + | State st _ _ | ReturnState st _ _ _ => st + end. + + + Lemma find_def_find_symbol: forall b gd, + Genv.find_def ge1 b = Some gd -> + exists id, Genv.find_symbol ge1 id = Some b. + Proof. + intros. + exploit Genv.find_def_find_symbol_inversion; eauto. + Qed. + + Lemma find_funct_ptr_find_symbol: forall b fd, + Genv.find_funct_ptr ge1 b = Some fd -> + exists id, Genv.find_symbol ge1 id = Some b. + Proof. + intros * H. unfold Genv.find_funct_ptr in H. + destruct (Genv.find_def ge1 b) as [[fd' |]|] eqn:?; try congruence. + assert (fd' = fd) by congruence; subst fd'; clear H. + exploit find_def_find_symbol; eauto. + Qed. + + + Lemma nextinstr_pc_return_builtin_value: + forall rs res vres ef + (RES_NOT_PC : exists reg : builtin_res mreg, res = map_builtin_res preg_of reg), + nextinstr (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs # X1 <- Vundef) # X31 <- Vundef)) PC = + Val.offset_ptr (rs PC) Ptrofs.one. + Proof. + intros rs res vres ef RES_NOT_PC. + destruct RES_NOT_PC as [reg ?]; subst res. + Simpl. + rewrite Asmgenproof0.set_res_other; eauto. + assert (H': Asmgenproof0.preg_notin PC (destroyed_by_builtin ef)). + { Local Transparent destroyed_by_builtin. + unfold destroyed_by_builtin. + destruct ef; simpl; auto. + - destruct orb; simpl; intuition. + destruct orb; simpl; intuition. + - intuition. + - induction clobbers. + + simpl; auto. + + simpl. destruct register_by_name; auto. + simpl; intuition. + destruct (destroyed_by_clobber clobbers); [| split]; now destruct m. + Local Opaque destroyed_by_builtin. } + rewrite Asmgenproof0.undef_regs_other_2; eauto. + Qed. + + Lemma regset_rel_invalidate_call: forall j rs1' rs3' sig, + regset_rel j rs1' rs3' -> + regset_rel j (invalidate_call rs1' sig) (invalidate_call rs3' sig). + Proof. + intros ? ? ? ? H. + intros r. specialize (H r). + unfold invalidate_call. + destruct orb; auto. + Qed. + + Lemma regset_rel_invalidate_cross_call: forall j rs1' rs3' cp cp', + regset_rel j rs1' rs3' -> + regset_rel j (invalidate_cross_call rs1' cp cp') (invalidate_cross_call rs3' cp cp'). + Proof. + intros ? ? ? ? ? H. + intros r. specialize (H r). + unfold invalidate_cross_call. + destruct (Genv.type_of_call cp cp'); auto. + destruct orb; auto. + Qed. + + Lemma regset_rel_invalidate_return: forall j rs1' rs3' sig, + regset_rel j rs1' rs3' -> + regset_rel j (invalidate_return rs1' sig) (invalidate_return rs3' sig). + Proof. + intros ? ? ? ? H. + intros r. specialize (H r). + unfold invalidate_return. + destruct orb; auto. + Qed. + + Lemma regset_rel_invalidate_cross_return: forall j rs1' rs3' cp cp', + regset_rel j rs1' rs3' -> + regset_rel j (invalidate_cross_return rs1' cp cp') (invalidate_cross_return rs3' cp cp'). + Proof. + intros ? ? ? ? ? H. + intros r. specialize (H r). + unfold invalidate_cross_return. + destruct (Genv.type_of_call cp cp'); auto. + destruct orb; auto. + Qed. + + (* Some simulation diagrams *) + Lemma step_E0_strong: forall (s1 s1': state), + Step (semantics W1) s1 E0 s1' -> + forall (s2 s3: state) j__δ j__oppδ, + agrees_with j__δ (init_meminj W1 W3) -> + def_on_addressable s ge1 j__δ δ -> + stack_rel s ge3 δ j__δ j__oppδ (stack_of_state s1) (stack_of_state s2) (stack_of_state s3) -> + strong_equivalence s ge1 ge3 j__δ δ s1 s3 -> + weak_equivalence s ge2 ge3 j__oppδ (opposite δ) s2 s3 -> + exists (s3': state) j__δ', + Plus (semantics W3) s3 E0 s3' /\ + agrees_with j__δ' (init_meminj W1 W3) /\ + def_on_addressable s ge1 j__δ' δ /\ + stack_rel s ge3 δ j__δ' j__oppδ (stack_of_state s1') (stack_of_state s2) (stack_of_state s3') /\ + strong_equivalence s ge1 ge3 j__δ' δ s1' s3' /\ + weak_equivalence s ge2 ge3 j__oppδ (opposite δ) s2 s3'. + Proof. + (* simpl. *) + intros s1 s1' H s2 s3 j__δ j__oppδ agr addr st_rel strong_s1_s3 weak_s2_s3. + exploit step_E0_same_cp; eauto. intros same_comp. + simpl in H. + inv H; simpl in same_comp. + - exploit strong_equiv_state_internal_inv; eauto. + intros (st3 & rs3 & m3 & b3 & f' & ? & eq_pc' & find_funct & [match_f_f' left_implies_eq] & m1_m3 & rs1_rs3 & side_f); + subst s3. + exploit find_def_find_symbol; eauto. intros [id find_id]. + exploit left_implies_eq; eauto. + { unfold kept_genv. rewrite find_id. + destruct (Genv.find_def ge1 b) as [[f''|]|] eqn:R; try congruence. + assert (f'' = Internal f) by congruence; subst f''. unfold Genv.find_def in R; rewrite R. + now simpl in *; rewrite side_f; destruct δ. } + intros <-. + + exploit weak_equivalence_inv1; eauto. intros (st2 & rs2 & m2 & m2_m3 & A). + exploit exec_instr_preserved; simpl; eauto. + intros (j__δ' & rs3' & m3' & exec_instr' & agr' & addr' & m1_m3' & m2_m3' & rs1_rs3' & st_rel'). + + assert (exists b', rs3' PC = Vptr b' ofs') as [b3' rs3'_PC]. + { pose proof (rs1_rs3' PC) as inj_pc; rewrite NEXTPC in *; inv inj_pc. + assert (delta = 0) by now eapply (delta_zero s ge1 ge3); eauto. subst delta. rewrite Ptrofs.add_zero in *. + eauto. } + + exists (State st3 rs3' m3'), j__δ'; split; [| split; [| split; [| split; [| split]]]]. + + econstructor; [| now eapply star_refl | now traceEq]. + econstructor; eauto. + specialize (rs1_rs3' PC) as inj_pc. rewrite NEXTPC, rs3'_PC in inj_pc. + exploit (agrees_with_init_meminj_find_comp_of_block_preserved s W1 W3); eauto. + inv inj_pc; try congruence. exploit (delta_zero s ge1 ge3); eauto; intros ->. + now rewrite Ptrofs.add_zero in *; eauto. + + eauto. + + eauto. + + eauto. + + econstructor; eauto. + * simpl; rewrite NEXTPC; simpl in *; rewrite <- ALLOWED. auto. + + inv weak_s2_s3; inv A; econstructor; eauto. + * erewrite <- (agrees_with_init_meminj_find_comp_preserved _ W1 W3 _ _ j__δ'); + eauto; try congruence. + rewrite <- same_comp. + assert (exists cp, Genv.find_comp ge1 (rs PC) = Some cp) as [cp' G]. + { rewrite H0; simpl. + unfold Genv.find_comp_of_block. + rewrite H1. eauto. } + eapply (agrees_with_init_meminj_find_comp_preserved _ W1 W3 _ _ j__δ (rs PC)) + in G as G'; eauto. + assert (cp = cp') by congruence; now subst. + congruence. + * erewrite <- (agrees_with_init_meminj_find_comp_preserved _ W1 W3 _ _ j__δ'); + eauto; try congruence. + rewrite <- same_comp. + assert (exists cp, Genv.find_comp ge1 (rs PC) = Some cp) as [cp' G]. + { rewrite H0; simpl. + unfold Genv.find_comp_of_block. + rewrite H1. eauto. } + eapply (agrees_with_init_meminj_find_comp_preserved _ W1 W3 _ _ j__δ (rs PC)) + in G as G'; eauto. + assert (rec_cp = cp') by congruence; now subst. + congruence. + + - exploit strong_equiv_state_internal_inv; eauto. + intros (st3 & rs3 & m3 & b3 & f' & ? & eq_pc' & find_funct & [match_f_f' left_implies_eq] & m1_m3 & rs1_rs3 & side_f); + subst s3. + exploit find_def_find_symbol; eauto. intros [id find_id]. + exploit left_implies_eq; eauto. + { unfold kept_genv. rewrite find_id. + destruct (Genv.find_def ge1 b) as [[f''|]|] eqn:R; try congruence. + assert (f'' = Internal f) by congruence; subst f''. unfold Genv.find_def in R; rewrite R. + now simpl in *; rewrite side_f; destruct δ. } + intros <-. + exploit weak_equivalence_inv1; eauto. intros (st2 & rs2 & m2 & m2_m3 & A). + exploit exec_instr_preserved; simpl; eauto. + intros (j__δ' & rs3' & m3' & exec_instr' & agr' & addr' & m1_m3' & m2_m3' & rs1_rs3' & st_rel'). + + assert (exists b', rs3' PC = Vptr b' Ptrofs.zero) as [b3' rs3'_PC]. + { pose proof (rs1_rs3' PC) as inj_pc; rewrite NEXTPC in *; inv inj_pc. + assert (delta = 0) by now eapply (delta_zero s ge1 ge3); eauto. subst delta. rewrite Ptrofs.add_zero in *. + eauto. } + assert (Genv.find_comp ge1 (rs' PC) = Some (comp_of f)). + { rewrite invalidate_cross_call_PC, + invalidate_call_PC in same_comp. rewrite <- same_comp, H0; simpl. + erewrite Genv.find_def_find_comp_of_block; eauto. reflexivity. } + eapply update_stack_call_preserved_internal with (j__δ := j__δ') (st3 := st3) in STUPD as [? STUPD]; eauto using delta_zero; try congruence. + subst st'. + exploit call_arguments_preserved; eauto. + intros [args' [inj_args call_args']]. + + exists (State st3 (invalidate_call rs3' sig) m3'), j__δ'; + split; [| split; [| split; [| split; [| split]]]]. + + econstructor; [| now eapply star_refl | now traceEq]. + eapply exec_step_internal_call; eauto. + * eapply allowed_call_preserved with (v := Vptr b' Ptrofs.zero) + (j__δ := init_meminj W1 W3); + eauto using delta_zero, init_meminj_preserves_globals. + { intros ????. exploit init_meminj_invert; eauto. intros []; eauto. } + congruence. + + assert (exists b delta, init_meminj W1 W3 b' = Some (b, delta)) as [? [? ?]]. + { unfold init_meminj. + unfold Genv.find_comp_of_block in NEXTCOMP. + destruct (Genv.find_def ge1 b') eqn:G; try congruence. + exploit find_def_find_symbol; eauto. + intros [? G']. apply Genv.find_invert_symbol in G'. rewrite G'. + apply Genv.invert_find_symbol in G'. + exploit (transform_find_symbol_1 s δ W1 W3); eauto. + intros [? G'']. rewrite G''. + exploit Genv.find_def_find_symbol_inversion; eauto. + { now destruct match_W1_W3. } } + + specialize (rs1_rs3' PC) as inj_pc. rewrite NEXTPC, rs3'_PC in inj_pc. + inv inj_pc; try congruence. exploit (delta_zero s ge1 ge3); eauto; intros ->. + exploit agr'; eauto. intros [? ?]. subst. + econstructor; eauto. + + * rewrite <- H, NEXTPC; simpl. + specialize (rs1_rs3' PC); inv rs1_rs3'; try congruence. + assert (b1 = b') by congruence; subst. + assert (b2 = b3') by congruence; subst. + simpl. + (* assert (exists cp, Genv.find_comp_of_block ge1 b' = Some cp) as [cp G]. *) + (* { rewrite NEXTCOMP. eauto. } *) + exploit (agrees_with_init_meminj_find_comp_of_block_preserved s W1 W3); eauto. + intros ->. rewrite NEXTCOMP. auto. + * intros. + exploit Genv.type_of_call_same_cp; eauto. contradiction. + * intros ?. + exploit Genv.type_of_call_same_cp; eauto. contradiction. + * intros ?. + exploit Genv.type_of_call_same_cp; eauto. contradiction. + * constructor; eauto. + now apply Genv.type_of_call_same_cp. + * unfold invalidate_cross_call. + unfold Genv.type_of_call. + rewrite Pos.eqb_refl. reflexivity. + + eauto. + + eauto. + + eauto. + + econstructor; eauto using regset_rel_invalidate_call. + rewrite invalidate_cross_call_PC, invalidate_call_PC; eauto. + unfold invalidate_cross_call. + replace cp' with (has_comp_function f). + unfold Genv.type_of_call; rewrite Pos.eqb_refl; eauto using regset_rel_invalidate_call. + rewrite NEXTPC in H. simpl in H. rewrite NEXTCOMP in H. now inv H. + + inv weak_s2_s3; inv A; econstructor; eauto. + * rewrite invalidate_cross_call_PC, invalidate_call_PC in *. + erewrite <- (agrees_with_init_meminj_find_comp_preserved _ W1 W3 _ _ j__δ'); + eauto; try congruence. + rewrite <- same_comp. + assert (exists cp, Genv.find_comp ge1 (rs PC) = Some cp) as [cp'' G]. + { rewrite H0; simpl. + unfold Genv.find_comp_of_block. + rewrite H1. eauto. } + eapply (agrees_with_init_meminj_find_comp_preserved _ W1 W3 _ _ j__δ (rs PC)) + in G as G'; eauto. + assert (cp = cp'') by congruence; now subst. + congruence. + * rewrite invalidate_cross_call_PC, invalidate_call_PC in *. + erewrite <- (agrees_with_init_meminj_find_comp_preserved _ W1 W3 _ _ j__δ'); + eauto; try congruence. + rewrite <- same_comp. + assert (exists cp, Genv.find_comp ge1 (rs PC) = Some cp) as [cp'' G]. + { rewrite H0; simpl. + unfold Genv.find_comp_of_block. + rewrite H1. eauto. } + eapply (agrees_with_init_meminj_find_comp_preserved _ W1 W3 _ _ j__δ (rs PC)) + in G as G'; eauto. + assert (rec_cp = cp'') by congruence; now subst. + congruence. + + (** [State] to [ReturnState] *) + - exploit strong_equiv_state_internal_inv; eauto. + intros (st3 & rs3 & m3 & b3 & f' & ? & eq_pc' & find_funct & [match_f_f' left_implies_eq] & m1_m3 & rs1_rs3 & side_f); + subst s3. + exploit find_def_find_symbol; eauto. intros [id find_id]. + exploit left_implies_eq; eauto. + { unfold kept_genv. rewrite find_id. + unfold Genv.find_funct_ptr in H1. destruct (Genv.find_def ge1 b) as [[f''|]|] eqn:R; try congruence. + assert (f'' = Internal f) by congruence; subst f''. unfold Genv.find_def in R; rewrite R. + now simpl in *; rewrite side_f; destruct δ. } + intros <-. + + exploit weak_equivalence_inv1; eauto. intros (st2 & rs2 & m2 & m2_m3 & A). + exploit exec_instr_preserved; simpl; eauto. + intros (j__δ' & rs3' & m3' & exec_instr' & agr' & addr' & m1_m3' & m2_m3' & rs1_rs3' & st_rel'). + + + + exists (ReturnState st3 rs3' m3' (comp_of f)), j__δ'; split; [| split; [| split; [| split; [| split]]]]. + + econstructor; [| now eapply star_refl | now traceEq]. + eapply exec_step_internal_return; eauto. + + eauto. + + eauto. + + eauto. + + econstructor; eauto. + + inv weak_s2_s3; inv A. + * econstructor; eauto. + rewrite H7, <- H9. + assert (H: Genv.find_comp ge1 (rs PC) = Some (comp_of f)) by eauto. + eapply (agrees_with_init_meminj_find_comp_preserved s W1 W3 _ _ j__δ) in H; eauto. + congruence. + now destruct (s (comp_of f)). + * assert (rec_cp = comp_of f). + { + assert (H: Genv.find_comp ge1 (rs PC) = Some (comp_of f)) by eauto. + eapply (agrees_with_init_meminj_find_comp_preserved s W1 W3 _ _ j__δ) in H; eauto. + congruence. congruence. } + subst rec_cp. + econstructor; eauto. + + (** [ReturnState] to [State] *) + - exploit strong_equiv_returnstate_inv; eauto. + intros (st3 & rs3 & m3 & ? & m1_m3 & rs1_rs3); subst. + + (* inv weak_s2_s3. *) + rewrite invalidate_cross_return_PC, invalidate_return_PC in same_comp. + symmetry in same_comp. + + eapply update_stack_return_preserved_internal with (st3 := st3) in STUPD as [? STUPD]; + eauto using delta_zero; try congruence. + subst st'. + simpl in st_rel. + assert (same_sg: sig_of_call st = sig_of_call st3) by (inv st_rel; [reflexivity | inv H4; auto]). + + assert (res_inj: Val.inject j__δ (return_value rs (sig_of_call st)) (return_value rs3 (sig_of_call st3))). + { simpl in st_rel. + rewrite <- same_sg. + unfold return_value. + destruct (loc_result (sig_of_call st)). + - now apply rs1_rs3. + - apply Val.longofwords_inject; now apply rs1_rs3. } + + rewrite NEXTCOMP in same_comp; inv same_comp. + + exists (State st3 (invalidate_cross_return (invalidate_return rs3 (sig_of_call st3)) rec_cp rec_cp) m3), j__δ; split; [| split; [| split; [| split; [| split]]]]. + + econstructor; [| now eapply star_refl | now traceEq]. + eapply exec_step_return; eauto. + * pose proof (rs1_rs3 PC) as inj_pc; inv inj_pc; try congruence. + unfold Vnullptr; destruct Archi.ptr64; congruence. + * pose proof (rs1_rs3 PC) as inj_pc; inv inj_pc; try congruence. + * simpl. + exploit (agrees_with_init_meminj_find_comp_preserved s W1 W3); eauto. + * congruence. + * congruence. + * intros; exploit Genv.type_of_call_same_cp; eauto; contradiction. + * intros; exploit Genv.type_of_call_same_cp; eauto; contradiction. + * eapply return_trace_inj; eauto. rewrite <- same_sg. eauto. + + eauto. + + eauto. + + eauto. + + econstructor; try rewrite same_sg; eauto using regset_rel_invalidate_return. + rewrite invalidate_cross_return_PC, invalidate_return_PC; eauto. + now inv strong_s1_s3. + intros ?. rewrite invalidate_cross_return_int. + rewrite invalidate_cross_return_int. + exploit regset_rel_invalidate_return; eauto. + + inv weak_s2_s3; econstructor; eauto. + rewrite invalidate_cross_return_PC, invalidate_return_PC; eauto. + exploit (agrees_with_init_meminj_find_comp_preserved s W1 W3); eauto. + rewrite invalidate_cross_return_PC, invalidate_return_PC; eauto. + exploit (agrees_with_init_meminj_find_comp_preserved s W1 W3); eauto. + + (** Builtin *) + (* - exploit strong_equiv_state_internal_inv; eauto. *) + (* intros (st3 & rs3 & m3 & b3 & f' & ? & eq_pc' & find_funct & [match_f_f' left_implies_eq] & m1_m3 & rs1_rs3 & side_f); *) + (* subst s3. *) + (* exploit find_def_find_symbol; eauto. intros [id find_id]. *) + (* exploit left_implies_eq; eauto. *) + (* { unfold kept_genv. rewrite find_id. *) + (* unfold Genv.find_funct_ptr in H1. destruct (Genv.find_def ge1 b) as [[f''|]|] eqn:R; try congruence. *) + (* assert (f'' = Internal f) by congruence; subst f''. unfold Genv.find_def in R; rewrite R. *) + (* now simpl in *; rewrite side_f; destruct δ. } *) + (* intros <-. *) + + (* exploit weak_equivalence_inv1; eauto. intros (st2 & rs2 & m2 & m2_m3 & A). *) + + (* exploit eval_builtin_args_inject; eauto using delta_zero, partial_mem_inject. *) + (* intros (vl' & eval_args' & inj_args'). *) + (* assert (exists j, *) + (* meminj_preserves_globals s δ W1 W3 j /\ *) + (* Val.inject_list j vargs vl' /\ *) + (* mem_rel s ge1 ge3 j δ m m3 /\ *) + (* regset_rel j rs rs3 /\ *) + (* stack_rel s ge3 δ j j__oppδ st st2 st3) as *) + (* (j & ? & ? & ? & ? & ?). *) + (* { admit. } *) + (* exploit external_call_inject_left; eauto using partial_mem_inject. *) + (* rewrite ALLOWED; auto. *) + (* intros (j__δ' & vres' & m3' & extcall' & inj_res & unchanged1 & unchanged2 & incr & sep & inj_pres' & m'_m3' & m2_m3' & rs_rs3' & st_rel'). *) + + (* assert (exists j', *) + (* agrees_with j' (init_meminj W1 W3) /\ *) + (* def_on_addressable s ge1 j' δ /\ *) + (* Val.inject_list j' vargs vl' /\ *) + (* Val.inject j' vres vres' /\ *) + (* mem_rel s ge1 ge3 j' δ m m3 /\ *) + (* regset_rel j' rs rs3 /\ *) + (* stack_rel s ge3 δ j' j__oppδ st st2 st3) as *) + (* (j' & ? & ? & ? & ? & ? & ? & ?). *) + (* { admit. } *) + + (* eexists; exists j'; split; [| split; [| split; [| split; [| split]]]]. *) + (* + econstructor; [| now eapply star_refl | now traceEq]. *) + (* eapply exec_step_builtin; eauto. *) + (* { destruct ef; simpl in *; auto. *) + (* - unfold visible_fo in *. destruct ECC as [ECC1 ECC2]. *) + (* admit. *) + (* - admit. *) + (* - admit. *) + (* - admit. *) + (* - admit. *) + (* - admit. } *) + (* + eauto. *) + (* + eauto. *) + (* + simpl. destruct s2; inv A; eauto. *) + (* (* eapply inject_incr_stack_rel1; eauto. *) *) + (* + econstructor; eauto. *) + (* * simpl. rewrite <- same_comp. rewrite H0; simpl. *) + (* erewrite Genv.find_def_find_comp_of_block; eauto. reflexivity. *) + (* * eapply regset_rel_return_from_builtin; eauto. *) + + (* + inv weak_s2_s3; inv A; econstructor; eauto. *) + (* * exploit regset_rel_return_from_builtin; eauto. intros ?. *) + (* erewrite <- (find_comp_preserved _ W1 W3); eauto using delta_zero. *) + (* rewrite <- same_comp. *) + (* erewrite (find_comp_preserved _ W1 W3); eauto using delta_zero. *) + (* congruence. *) + (* rewrite nextinstr_pc_return_builtin_value, H0; eauto. simpl; congruence. *) + (* * exploit regset_rel_return_from_builtin; eauto. intros ?. *) + (* erewrite <- (find_comp_preserved _ W1 W3); eauto using delta_zero. *) + (* rewrite <- same_comp. *) + (* erewrite (find_comp_preserved _ W1 W3); eauto using delta_zero. *) + (* congruence. *) + (* rewrite nextinstr_pc_return_builtin_value, H0; eauto. simpl; congruence. *) + + (** External call *) + (* - exploit strong_equiv_state_external_inv; eauto. *) + (* intros (st3 & rs3 & m3 & b3 & ? & eq_pc' & find_funct & m1_m3 & rs1_rs3 & side_ef); *) + (* subst s3. *) + (* exploit find_def_find_symbol; eauto. intros [id find_id]. *) + + (* exploit weak_equivalence_inv1; eauto. intros (st2 & rs2 & m2 & m2_m3 & A). *) + + (* exploit extcall_arguments_preserved; eauto. *) + (* intros (args' & inj_args & extcall_args'). *) + + (* exploit external_call_inject_left; eauto using partial_mem_inject. *) + (* intros (j__δ' & vres' & m3' & extcall' & inj_res & unchanged1 & unchanged2 & incr & sep & inj_pres' & m'_m3' & m2_m3' & rs_rs3' & st_rel'). *) + (* eexists; exists j__δ'; split; [| split; [| split; [| split]]]. *) + (* + econstructor; [| now eapply star_refl | now traceEq]. *) + (* eapply exec_step_external; eauto. *) + (* (* rewrite eq_pc'; simpl; unfold Genv.find_comp; simpl; rewrite find_funct; destruct Ptrofs.eq_dec; try congruence. *) *) + (* (* eapply stack_rel_same_callee in st_rel as [R ?]. rewrite <- R, (match_prog_comp_of_main _ _ _ _ match_W1_W3); simpl. *) *) + (* (* rewrite <- REC_CURCOMP, H0; simpl; unfold Genv.find_comp; simpl; rewrite H1. now destruct Ptrofs.eq_dec; try congruence. *) *) + (* + eauto. *) + (* + simpl. eapply inject_incr_stack_rel1; eauto. *) + (* + econstructor; eauto. *) + (* (* * simpl. rewrite <- same_comp. rewrite H0; simpl; unfold Genv.find_comp; simpl; rewrite H1. destruct Ptrofs.eq_dec; try congruence; auto. *) *) + (* * eapply regset_rel_return_from_external; eauto. *) + (* + inv weak_s2_s3; inv A. *) + (* * econstructor; eauto. *) + (* rewrite H6, <- H8. *) + (* erewrite <- (find_comp_preserved _ W1 W3); eauto using delta_zero. *) + (* congruence. *) + (* now destruct (s (comp_of ef)). *) + (* * assert (rec_cp = comp_of ef). *) + (* { erewrite <- (find_comp_preserved _ W1 W3) in H8; eauto using delta_zero. *) + (* rewrite H0 in H8; simpl in H8; erewrite Genv.find_def_find_comp_of_block in H8; *) + (* eauto. *) + (* inv H8. reflexivity. congruence. } *) + (* subst rec_cp. *) + (* econstructor; eauto. *) + Unshelve. + all: exact norepet1. + Qed. + + Lemma step_E0_weak: forall (s2 s2': state), + Step (semantics W2) s2 E0 s2' -> + forall (s1 s3: state) j__δ j__oppδ, + agrees_with j__δ (init_meminj W1 W3) -> + agrees_with j__oppδ (init_meminj W2 W3) -> + def_on_addressable s ge1 j__δ δ -> + def_on_addressable s ge2 j__oppδ (opposite δ) -> + (* meminj_preserves_globals s δ W1 W3 j__δ -> *) + (* meminj_preserves_globals s (opposite δ) W2 W3 j__oppδ -> *) + stack_rel s ge3 δ j__δ j__oppδ (stack_of_state s1) (stack_of_state s2) (stack_of_state s3) -> + strong_equivalence s ge1 ge3 j__δ δ s1 s3 -> + weak_equivalence s ge2 ge3 j__oppδ (opposite δ) s2 s3 -> + exists j__oppδ', + agrees_with j__oppδ' (init_meminj W2 W3) /\ + def_on_addressable s ge2 j__oppδ' (opposite δ) /\ + (* meminj_preserves_globals s (opposite δ) W2 W3 j__oppδ' /\ *) + stack_rel s ge3 δ j__δ j__oppδ' (stack_of_state s1) (stack_of_state s2') (stack_of_state s3) /\ + strong_equivalence s ge1 ge3 j__δ δ s1 s3 /\ + weak_equivalence s ge2 ge3 j__oppδ' (opposite δ) s2' s3. + Proof. + intros s2 s2' H s1 s3 j__left j__right inj_pres1 inj_pres2 addr1 addr2 st_rel strong_s1_s3 weak_s2_s3. + exploit step_E0_same_cp; eauto. intros same_comp. + simpl in H. + inv H; simpl in same_comp. + + - exploit weak_equivalence_inv; eauto. + intros (st2 & st3 & rs2 & rs3 & m2 & m3 & m2_m3 & A & B). + inv A. + + assert (f_left: s (has_comp_function f) = δ). + { inv weak_s2_s3; inv B. + - rewrite H0 in H8; simpl in H8; + erewrite Genv.find_def_find_comp_of_block in H8; eauto. + inv H8. + now destruct δ. + - rewrite H0 in H8; simpl in H8; + erewrite Genv.find_def_find_comp_of_block in H8; eauto. + inv H8. + now destruct δ. } + exploit exec_instr_preserves_weak; eauto. + intros (j__oppδ' & agr' & addr' & m'_m3 & st_rel'). + eexists. + repeat (split; eauto). + inv weak_s2_s3; inv B; + econstructor; eauto; now (simpl; rewrite <- same_comp). + + - exploit weak_equivalence_inv; eauto. + intros (st2 & st3 & rs2 & rs3 & m2 & m3 & m2_m3 & A & B). + inv A. + + assert (f_left: s (has_comp_function f) = δ). + { inv weak_s2_s3; inv B. + - rewrite H0 in H7; simpl in H7; + erewrite Genv.find_def_find_comp_of_block in H7; eauto. + inv H7. + now destruct δ. + - rewrite H0 in H7; simpl in H7; + erewrite Genv.find_def_find_comp_of_block in H7; eauto. + inv H7. + now destruct δ. } + exploit exec_instr_preserves_weak; eauto. + intros (j__right' & agr' & addr' & m'_m3 & st_rel'). + assert (st' = st2); [| subst st']. + { unfold update_stack_call in STUPD. + assert (same_comp': Some (comp_of f) = Genv.find_comp ge2 (rs' PC)). + { inv EV; auto. unfold Genv.type_of_call in *. + destruct (Pos.eqb_spec (comp_of f) cp'); simpl; eauto. + simpl in e. rewrite e. now rewrite NEXTPC; simpl. contradiction. } + simpl in same_comp'. + rewrite <- same_comp', Pos.eqb_refl in STUPD. + now inv STUPD. } + eexists. + repeat (split; eauto). + inv weak_s2_s3; inv B; econstructor; eauto; now (simpl; rewrite <- same_comp). + + - exploit weak_equivalence_inv; eauto. + intros (st2 & st3 & rs2 & rs3 & m2 & m3 & m2_m3 & A & B). + inv A. + + exploit exec_instr_preserves_weak; eauto. + { inv weak_s2_s3; inv B. + - rewrite H0 in H7; simpl in H7; + erewrite Genv.find_def_find_comp_of_block in H7; eauto. + inv H7. + now destruct δ. + - rewrite H0 in H7; simpl in H7; + erewrite Genv.find_def_find_comp_of_block in H7; eauto. + inv H7. + now destruct δ. } + intros (j__right' & agr' & addr' & m'_m3 & st_rel'). + + eexists. + repeat (split; eauto). + inv weak_s2_s3; inv B. + + rewrite H7 in same_comp; inv same_comp; auto. + constructor; eauto. + + rewrite H7 in same_comp; inv same_comp; auto. + constructor; eauto. + + - exploit weak_equivalence_inv; eauto. + intros (st2 & st3 & rs2 & rs3 & m2 & m3 & m2_m3 & A & B). + inv A. + + rewrite invalidate_cross_return_PC in same_comp. + rewrite invalidate_return_PC in same_comp; rewrite NEXTCOMP in same_comp; inv same_comp. + + assert (st' = st2); [| subst st']. + { unfold update_stack_return in STUPD. + rewrite NEXTCOMP, Pos.eqb_refl in STUPD. now inv STUPD. } + exists j__right. + repeat (split; eauto). + inv weak_s2_s3; inv B; + econstructor; eauto. + rewrite invalidate_cross_return_PC, invalidate_return_PC. auto. + rewrite invalidate_cross_return_PC, invalidate_return_PC. auto. + + (* - exploit weak_equivalence_inv; eauto. *) + (* intros (st2 & st3 & rs2 & rs3 & m2 & m3 & m2_m3 & A & B). *) + (* inv A. simpl. *) + (* exploit extcall_preserves_mem_rel_opp_side1; eauto. *) + (* { inv weak_s2_s3. *) + (* - rewrite H0 in H7; simpl in H7; *) + (* erewrite Genv.find_def_find_comp_of_block in H7; eauto. *) + (* inv H7. simpl in ALLOWED. rewrite <- ALLOWED in H10. *) + (* now destruct δ. *) + (* - rewrite H0 in H7; simpl in H7; *) + (* erewrite Genv.find_def_find_comp_of_block in H7; eauto. *) + (* inv H7. simpl in H9, ALLOWED. rewrite <- ALLOWED in H9. *) + (* now destruct δ. } *) + (* intros m'_m3'. *) + + (* eexists; do 3 (split; eauto). *) + (* inv weak_s2_s3; inv B; (econstructor; eauto); *) + (* rewrite <- same_comp; auto. *) + + (* - exploit weak_equivalence_inv; eauto. intros (st2 & st3 & rs2 & rs3 & m2 & m3 & m2_m3 & A & B). *) + (* inv A. simpl in *. *) + (* exploit extcall_preserves_mem_rel_opp_side1; eauto. *) + (* { inv weak_s2_s3; inv B. *) + (* - rewrite H0 in H6; simpl in H6; *) + (* erewrite Genv.find_def_find_comp_of_block in H6; eauto. *) + (* inv H6. *) + (* now destruct δ. *) + (* - rewrite H0 in H6; simpl in H6; *) + (* erewrite Genv.find_def_find_comp_of_block in H6; eauto. *) + (* inv H6. *) + (* now destruct δ. } *) + (* intros m'_m3'. *) + + (* eexists; do 3 (split; eauto). *) + (* inv weak_s2_s3; inv B. *) + (* + rewrite H6 in same_comp; inv same_comp; auto. econstructor; eauto. *) + (* + rewrite H6 in same_comp; inv same_comp; auto. econstructor; eauto. *) + Qed. + + Lemma step_t: forall (s1 s1': state) (s2 s2': state) e, + Step (semantics W1) s1 (e :: nil) s1' -> + Step (semantics W2) s2 (e :: nil) s2' -> + forall (s3: state) j__δ j__oppδ, + agrees_with j__δ (init_meminj W1 W3) -> + agrees_with j__oppδ (init_meminj W2 W3) -> + def_on_addressable s ge1 j__δ δ -> + def_on_addressable s ge2 j__oppδ (opposite δ) -> + (* meminj_preserves_globals s δ W1 W3 j__δ -> *) + (* meminj_preserves_globals s (opposite δ) W2 W3 j__oppδ -> *) + stack_rel s ge3 δ j__δ j__oppδ (stack_of_state s1) (stack_of_state s2) (stack_of_state s3) -> + strong_equivalence s ge1 ge3 j__δ δ s1 s3 -> + weak_equivalence s ge2 ge3 j__oppδ (opposite δ) s2 s3 -> + exists s3' j__δ' j__oppδ', + Plus (semantics W3) s3 (e :: nil) s3' /\ + agrees_with j__δ' (init_meminj W1 W3) /\ + agrees_with j__oppδ' (init_meminj W2 W3) /\ + def_on_addressable s ge1 j__δ' δ /\ + def_on_addressable s ge2 j__oppδ' (opposite δ) /\ + (* meminj_preserves_globals s δ W1 W3 j__δ' /\ *) + (* meminj_preserves_globals s (opposite δ) W2 W3 j__oppδ' /\ *) + stack_rel s ge3 δ j__δ' j__oppδ' (stack_of_state s1') (stack_of_state s2') (stack_of_state s3') /\ + ((strong_equivalence s ge1 ge3 j__δ' δ s1' s3' /\ + weak_equivalence s ge2 ge3 j__oppδ' (opposite δ) s2' s3') \/ + (weak_equivalence s ge1 ge3 j__δ' δ s1' s3' /\ + strong_equivalence s ge2 ge3 j__oppδ' (opposite δ) s2' s3')). + Proof. + intros s1 s1' s2 s2' e step1 step2 s3 j__δ j__oppδ agr1 agr2 addr1 addr2 + (* inj_pres_δ inj_pres_opp_δ *) + st_rel strong_s1_s3 weak_s2_s3. + simpl in step1, step2. + + inv step1; inv step2; + try now (do 2 match goal with + | H: call_trace _ _ _ _ _ _ (?e :: nil) |- _ => inv H + | H: return_trace _ _ _ _ _ (?e :: nil) |- _ => inv H + | H: external_call _ _ _ _ (?e :: nil) _ _ |- _ => eapply ec_no_crossing in H; + eauto using external_call_spec + end); try contradiction. + (* Should get 6 cases *) + + - (* Call *) + exploit strong_equiv_state_internal_inv; eauto. + intros (st3 & rs3 & m3 & b3 & f' & ? & eq_pc' & find_funct & [match_f_f' left_implies_eq] & m1_m3 & rs1_rs3 & side_f); + subst s3. + exploit find_def_find_symbol; eauto. intros [id find_id]. + exploit left_implies_eq; eauto. + { unfold kept_genv. rewrite find_id. + unfold Genv.find_funct_ptr in H0. destruct (Genv.find_def ge1 b) as [[f''|]|] eqn:R; try congruence. + assert (f'' = Internal f) by congruence; subst f''. unfold Genv.find_def in R; rewrite R. + now simpl in *; rewrite side_f; destruct δ. } + intros <-. + + exploit weak_equivalence_inv1; eauto. intros (st2 & rs2 & m2 & m2_m3 & A). injection A; intros -> -> ->; clear A. + exploit exec_instr_preserved; simpl; eauto. + intros (j__δ' & rs3' & m3' & exec_instr' & agr' & addr' & m1_m3' & m2_m3' & rs1_rs3' & st_rel'). + assert (side_f0: s (has_comp_function f0) = δ). + { clear -side_f EV EV0. + inv EV; inv EV0. simpl; congruence. } + exploit exec_instr_preserves_weak; simpl; [exact side_f0 | | | | | | ]; eauto. + intros (j__oppδ' & agr2' & addr2' & m'0_m3' & st_rel''). + + assert (exists b', rs3' PC = Vptr b' Ptrofs.zero) as [b3' rs3'_PC]. + { pose proof (rs1_rs3' PC) as inj_pc; rewrite NEXTPC in *; inv inj_pc. + assert (delta = 0) by now eapply (delta_zero s ge1 ge3); eauto. subst delta. rewrite Ptrofs.add_zero in *. + eauto. } + + exploit call_arguments_preserved; eauto. + intros [args' [inj_args call_args']]. + + assert (diff_comp: comp_of f <> cp'). + { clear -EV. + inv EV; eauto. + intros neg; rewrite neg in H0. now apply Genv.type_of_call_same_cp in H0. } + + exploit (exec_instr_call_pc ge1 f i); eauto. + exploit (exec_instr_call_pc ge2 f0 i0); eauto. + exploit (exec_instr_call_pc ge3 f i); eauto. + rewrite eq_pc', H4, H; simpl. + intros rs3'_X1 rs'0_X1 rs'_X1. + + assert (st' = Stackframe b sig (rs' X2) (Ptrofs.add ofs Ptrofs.one) + :: st). + { clear -rs'_X1 STUPD NEXTPC NEXTCOMP diff_comp. + unfold update_stack_call in STUPD. rewrite NEXTPC in STUPD; simpl in STUPD; rewrite NEXTCOMP in STUPD. + apply Pos.eqb_neq in diff_comp; simpl in diff_comp; rewrite diff_comp in STUPD. + rewrite rs'_X1 in STUPD. congruence. } + + assert (Genv.find_comp ge3 (rs3' PC) = Some cp') as NEXTCOMP'. + { exploit (agrees_with_init_meminj_find_comp_preserved s W1 W3); eauto. + rewrite NEXTPC; congruence. + rewrite NEXTPC; eauto. } + + assert (cp'0 = cp') as ->. + { clear -EV EV0. + inv EV; inv EV0. congruence. } + + + assert (diff_comp': comp_of f0 <> cp'). + { clear -EV0. + inv EV0; eauto. + intros neg; rewrite neg in H0. now apply Genv.type_of_call_same_cp in H0. } + + assert (st'0 = Stackframe b0 sig0 (rs'0 X2) (Ptrofs.add ofs0 Ptrofs.one) + :: st2). + { clear -rs'0_X1 STUPD0 diff_comp' NEXTPC0 NEXTCOMP0. + unfold update_stack_call in STUPD0. + rewrite NEXTPC0 in STUPD0; simpl in STUPD0; rewrite NEXTCOMP0 in STUPD0. + apply Pos.eqb_neq in diff_comp'; simpl in diff_comp'; rewrite diff_comp' in STUPD0. + rewrite rs'0_X1 in STUPD0. congruence. } + + assert (inj1: Val.inject j__δ' (Vptr b (Ptrofs.add ofs Ptrofs.one)) (Vptr b3 (Ptrofs.add ofs Ptrofs.one))). + { specialize (rs1_rs3' X1). rewrite rs'_X1, rs3'_X1 in rs1_rs3'. + auto. } + + assert (same_sig: sig = sig0). + { exploit CALLSIG; eauto. + { clear -EV. inv EV; auto. } + intros [fd [Hfd ->]]. + exploit CALLSIG0; eauto. + { clear -EV0. inv EV0; auto. } + intros [fd0 [Hfd0 ->]]. + (* clear -STUPD STUPD0. *) + clear -match_W1_W3 match_W2_W3 EV EV0 Hfd Hfd0 agr' agr2'. + inv EV; inv EV0. inv H1; inv H12. + apply Genv.invert_find_symbol in H2. + apply Genv.invert_find_symbol in H13. + eapply (symbols_inject2 _ _ _ _ (init_meminj W1 W3)) in H2 as [b3 [X Y]]; + eauto using init_meminj_preserves_globals. + eapply (symbols_inject2 _ _ _ _ (init_meminj W2 W3)) in H13 as [b3' [X' Y']]; + eauto using init_meminj_preserves_globals. + (* apply (symbols_inject2 _ _ _ _ _ inj_pres_opp_δ) in H13 as [b3' [X' Y']]. *) + assert (b3' = b3) by congruence; subst b3'. + (* rewrite Genv.find_funct_ptr_iff in Hfd, Hfd0. *) + eapply (defs_inject _ _ _ _ (init_meminj W1 W3)) in Hfd as [gd [find_gd [_ [match_gd ?]]]]; + eauto using init_meminj_preserves_globals. + eapply (defs_inject _ _ _ _ (init_meminj W2 W3)) in Hfd0 as [gd0 [find_gd0 [_ [match_gd0 ?]]]]; + eauto using init_meminj_preserves_globals. + assert (gd0 = gd) by congruence; subst gd0. + inv match_gd; inv match_gd0. inv H4; inv H7; auto. } + subst sig0. + + + exists (State (Stackframe b3 sig (rs3' X2) (Ptrofs.add ofs Ptrofs.one) :: st3) + (invalidate_cross_call (invalidate_call rs3' sig) (comp_of f) cp') m3'), + j__δ', j__oppδ'; split; [| split; [| split; [| split; [| split; [| split]]]]]; try assumption. + + econstructor; [| now eapply star_refl | now traceEq]. + eapply exec_step_internal_call; eauto. + * eapply allowed_call_preserved with + (j__δ := init_meminj W1 W3) + (v := Vptr b' Ptrofs.zero); eauto using delta_zero, init_meminj_preserves_globals. + { intros ????. exploit init_meminj_invert; eauto. intros []; eauto. } + congruence. + + assert (exists b delta, init_meminj W1 W3 b' = Some (b, delta)) as [? [? ?]]. + { unfold init_meminj. + unfold Genv.find_comp_of_block in NEXTCOMP. + destruct (Genv.find_def ge1 b') eqn:G; try congruence. + exploit find_def_find_symbol; eauto. + intros [? G']. apply Genv.find_invert_symbol in G'. rewrite G'. + apply Genv.invert_find_symbol in G'. + exploit (transform_find_symbol_1 s δ W1 W3); eauto. + intros [? G'']. rewrite G''. + exploit Genv.find_def_find_symbol_inversion; eauto. + { now destruct match_W1_W3. } } + + specialize (rs1_rs3' PC) as inj_pc. rewrite NEXTPC, rs3'_PC in inj_pc. + inv inj_pc; try congruence. exploit (delta_zero s ge1 ge3); eauto; intros ->. + exploit agr'; eauto. intros [? ?]. subst. + econstructor; eauto. + * rewrite rs3'_PC in NEXTCOMP'; now simpl in NEXTCOMP'; eauto. + * unfold update_stack_call. + rewrite NEXTCOMP'. + apply Pos.eqb_neq in diff_comp; rewrite diff_comp. + rewrite rs3'_X1. reflexivity. + * intros. + specialize (rs1_rs3' PC). rewrite rs3'_PC, NEXTPC in rs1_rs3'. + exploit CALLSIG; eauto. + (* { clear -EV. inv EV; auto. } *) + intros [fd [Hfd ->]]. + (* apply Genv.find_funct_ptr_iff in Hfd. *) + inv rs1_rs3'. + eapply (defs_inject _ _ _ _ (init_meminj W1 W3)) in Hfd + as [gd [find_gd [_ [match_gd ?]]]]; eauto using init_meminj_preserves_globals. + inv match_gd. + inv H12; eexists; split; eauto. + + assert (exists b delta, init_meminj W1 W3 b' = Some (b, delta)) as [? [? ?]]. + { unfold init_meminj. + unfold Genv.find_comp_of_block in NEXTCOMP. + destruct (Genv.find_def ge1 b') eqn:G; try congruence. + exploit find_def_find_symbol; eauto. + intros [? G']. apply Genv.find_invert_symbol in G'. rewrite G'. + apply Genv.invert_find_symbol in G'. + exploit (transform_find_symbol_1 s (s (comp_of f)) W1 W3); eauto. + intros [? G'']. rewrite G''. + exploit Genv.find_def_find_symbol_inversion; eauto. + { now destruct match_W1_W3. } } + exploit agr'; eauto. intros []; subst; eauto. + * intros ?. + exploit Val.inject_list_not_ptr; eauto. + * intros G. specialize (CHECKPUB G). + (* clear -CHECKPUB. *) + unfold public_first_order in *. + intros. + exploit (symbols_inject3 s δ W1 W3 (init_meminj W1 W3)); + eauto using init_meminj_preserves_globals. + eapply FIND. intros [bid [findid init]]. + specialize (CHECKPUB id0 bid ofs1 findid). + clear -CHECKPUB FIND bid findid init READABLE. + assert (Mem.perm m bid ofs1 Cur Readable) by admit. + specialize (CHECKPUB H). + admit. + * specialize (rs1_rs3' PC); rewrite rs3'_PC, NEXTPC in rs1_rs3'. + (* TODO: factorize *) + eapply call_trace_preserved with + (v := Vptr b' Ptrofs.zero); eauto using delta_zero. + + subst; simpl in *. econstructor; eauto. + econstructor; auto. + erewrite Genv.find_def_find_comp_of_block; eauto. + reflexivity. + + destruct (side_eq (s cp') δ) as [e1 | n1]. + * left; split. + -- econstructor; eauto. + rewrite invalidate_cross_call_PC, invalidate_call_PC, NEXTPC; simpl; auto. + eauto using regset_rel_invalidate_cross_call, regset_rel_invalidate_call. + -- econstructor; eauto. + rewrite invalidate_cross_call_PC, invalidate_call_PC, NEXTPC0; simpl; eauto. + rewrite invalidate_cross_call_PC, invalidate_call_PC; simpl; eauto. + now destruct δ. + * right; split. + -- econstructor; eauto. + rewrite invalidate_cross_call_PC, invalidate_call_PC, NEXTPC. eauto. + rewrite invalidate_cross_call_PC, invalidate_call_PC. eauto. + destruct δ, (s cp'); now auto. + -- econstructor; eauto; + [rewrite invalidate_cross_call_PC, invalidate_call_PC, NEXTPC0; eauto + | destruct δ, (s cp'); now eauto |]. + assert (forall rs rs' j__oppδ' m1 m3 sig args cp cp', + Val.inject j__oppδ' (rs PC) (rs' PC) -> + (* Val.inject j__oppδ' (rs X1) (rs' X1) -> *) + (* Val.inject j__oppδ' (rs X2) (rs' X2) -> *) + cp <> cp' -> + call_arguments rs m1 sig args -> + call_arguments rs' m3 sig args -> + regset_rel j__oppδ' (invalidate_cross_call (invalidate_call rs sig) cp cp') + (invalidate_cross_call (invalidate_call rs' sig) cp cp')). + { clear. + unfold invalidate_cross_call, invalidate_call. + + intros * inj_pc diff call1 call2 r. + unfold Genv.type_of_call. + eapply Pos.eqb_neq in diff. rewrite diff. + destruct (preg_eq r X1); [subst; simpl; auto|]. + destruct (preg_eq r X2); [subst; simpl; auto|]. + destruct (preg_eq r PC); [subst; simpl; auto|]. + destruct in_dec; simpl; auto. + unfold LTL.parameters_mregs in *. + unfold call_arguments in *. + clear n1 n n0. + revert args call1 call2 r i. clear. + remember (loc_parameters sig) as ls. clear Heqls. + Local Opaque all_mregs. + induction ls. + - simpl. now auto. + - intros [| arg args] H1 H2 r H; try now inv H1. + inv H1. inv H2. + specialize (IHls args H7 H8 r). + simpl in H. admit. } + simpl. + assert (has_comp_function f0 = has_comp_function f) as -> by admit. + eapply H11. + admit. (* because PC points to same function *) + simpl in side_f; auto. + (* admit. (* RA: because the caller was the same, they point to the *) + (* same function and as such must be related *) *) + (* admit. (* SP: *) *) + eapply ARGS0. admit. + + - (* Return *) + exploit strong_equiv_returnstate_inv; eauto. + intros (st3 & rs3 & m3 & ? & m_m3 & rs_rs3); subst s3. + exploit weak_equivalence_inv; eauto; simpl. + intros (? & ? & ? & ? & ? & ? & m1_m3 & A & B); + injection A; injection B; intros <- <- <- <- <- <-; clear A B. + + assert (diff_comp1: rec_cp <> cp'). + { clear -EV. + inv EV. + now intros H; rewrite H in *; exploit Genv.type_of_call_same_cp; eauto. } + assert (exists frame1, st = frame1 :: st') as [frame1 ->]. + { unfold update_stack_return in STUPD. + rewrite NEXTCOMP in STUPD. + apply Pos.eqb_neq in diff_comp1; simpl in diff_comp1; rewrite diff_comp1 in STUPD. + destruct st as [|frame1 st1]; try congruence. inv STUPD. eauto. } + + assert (cp'0 = cp') as ->. + { clear -EV EV0. + inv EV; inv EV0. congruence. } + + assert (rec_cp0 = rec_cp) as ->. + { clear -EV EV0. + inv EV; inv EV0. congruence. } + + assert (exists frame2, st0 = frame2 :: st'0) as [frame2 ->]. + { unfold update_stack_return in STUPD0. + rewrite NEXTCOMP0 in STUPD0. + apply Pos.eqb_neq in diff_comp1; rewrite diff_comp1 in STUPD0. + destruct st0 as [|frame2 st2]; try congruence. inv STUPD0. eauto. } + + assert (exists frame3 st3', st3 = frame3 :: st3' /\ + stackframe_rel s ge3 δ j__δ j__oppδ frame1 frame2 frame3 /\ + stack_rel s ge3 δ j__δ j__oppδ st' st'0 st3') + as [frame3 [st3' [-> [frame_rel st_rel']]]] by now inv st_rel; eauto. + + assert (update_stack_return ge3 (frame3 :: st3') + rec_cp rs3 = + Some st3'). + { unfold update_stack_return. + eapply (agrees_with_init_meminj_find_comp_preserved s W1 W3 _ _ _ (rs PC)) in NEXTCOMP; + eauto. + rewrite NEXTCOMP. + apply Pos.eqb_neq in diff_comp1; rewrite diff_comp1. reflexivity. } + + assert (rs3 PC <> Vnullptr). + { clear -H H0 rs_rs3. specialize (rs_rs3 PC). + unfold Vnullptr in *; destruct Archi.ptr64; inv rs_rs3; congruence. } + + assert (rs3 PC <> Vundef). + { clear -H H0 rs_rs3. specialize (rs_rs3 PC). + unfold Vnullptr in *; destruct Archi.ptr64; inv rs_rs3; congruence. } + assert (rec_cp <> cp' -> rs3 PC = asm_parent_ra (frame3 :: st3')). + { inv frame_rel; simpl; eauto. + intros. exploit PC_RA; eauto. + simpl. specialize (rs_rs3 PC). intros G; rewrite G in rs_rs3; inv rs_rs3. + rewrite H12. admit. (* use H3 *) + intros. exploit PC_RA0; eauto. + admit. } + + assert (rec_cp <> cp' -> rs3 X2 = asm_parent_sp (frame3 :: st3')). + { admit. } + + assert (inj_res: Val.inject j__δ (return_value rs (sig_of_call (frame3 :: st3'))) + (return_value rs3 (sig_of_call (frame3 :: st3')))). { + unfold return_value. + destruct (loc_result (sig_of_call (frame3 :: st3'))). + - specialize (rs_rs3 (preg_of r)); eauto. + - pose proof (rs_rs3 (preg_of rhi)) as X; + pose proof (rs_rs3 (preg_of rlo)) as Y. + now eapply Val.longofwords_inject. } + assert (NO_CROSS_PTR': + Genv.type_of_call cp' rec_cp = Genv.CrossCompartmentCall -> + not_ptr (return_value rs3 (sig_of_call (frame3 :: st3')))). + { intros ?. exploit NO_CROSS_PTR; eauto. + assert (sig_of_call (frame1 :: st') = sig_of_call (frame3 :: st3')) as ->. + { inv frame_rel; auto. } + clear -inj_res. simpl in *. + inv inj_res; eauto; try intuition congruence. + contradiction. } + assert (EV3: return_trace ge3 cp' rec_cp + (return_value rs3 (sig_of_call (frame3 :: st3'))) (sig_res (sig_of_call (frame3 :: st3'))) + (e :: nil)). + { + eapply return_trace_inj; eauto. + assert (sig_of_call (frame1 :: st') = sig_of_call (frame3 :: st3')) as <-. + { inv frame_rel; auto. } eauto. + assert (sig_of_call (frame1 :: st') = sig_of_call (frame3 :: st3')) as <-. + { inv frame_rel; auto. } eauto. } + + assert (Genv.find_comp ge3 (rs3 PC) = Some cp'). + { + eapply (agrees_with_init_meminj_find_comp_preserved s W1 W3 _ _ _ (rs PC)) in NEXTCOMP; + eauto. } + exists (State st3' (invalidate_cross_return (invalidate_return rs3 (sig_of_call (frame3 :: st3'))) cp' rec_cp) m3); exists j__δ, j__oppδ; split; [| split; [| split; [| split; [| split; [| split]]]]]. + + econstructor; [| now eapply star_refl | now traceEq]. + econstructor; eauto. + admit. + + eauto. + + eauto. + + eauto. + + eauto. + + eauto. + + (* simpl in *. *) + destruct (side_eq (s cp') δ) as [e1 | n1]. + * left; split. + -- econstructor; eauto. + rewrite invalidate_cross_return_PC, invalidate_return_PC. eauto. + eapply regset_rel_invalidate_cross_return; eauto. + assert (sig_of_call (frame1 :: st') = sig_of_call (frame3 :: st3')) as <-. + { inv frame_rel; auto. } + eapply regset_rel_invalidate_return; eauto. + -- econstructor; eauto. + rewrite invalidate_cross_return_PC, invalidate_return_PC. eauto. + rewrite invalidate_cross_return_PC, invalidate_return_PC. eauto. + now destruct δ. + * right; split. + -- econstructor; eauto. + rewrite invalidate_cross_return_PC, invalidate_return_PC. eauto. + rewrite invalidate_cross_return_PC, invalidate_return_PC. eauto. + now destruct δ, (s cp'). + -- econstructor; eauto. + rewrite invalidate_cross_return_PC, invalidate_return_PC. eauto. + now destruct δ, (s cp'). + eapply regset_rel_invalidate_cross_return; eauto. + assert (sig_of_call (frame2 :: st'0) = sig_of_call (frame3 :: st3')) as <-. + { inv frame_rel; auto. } + eapply regset_rel_invalidate_return; eauto. + admit. + + (* - (* Builtin *) *) + (* exploit strong_equiv_state_internal_inv; eauto. *) + (* intros (st3 & rs3 & m3 & b3 & f' & ? & eq_pc' & find_funct & [match_f_f' left_implies_eq] & m1_m3 & rs1_rs3 & side_f); *) + (* subst s3. *) + (* exploit find_def_find_symbol; eauto. intros [id find_id]. *) + (* exploit left_implies_eq; eauto. *) + (* { unfold kept_genv. rewrite find_id. *) + (* unfold Genv.find_funct_ptr in H0. destruct (Genv.find_def ge1 b) as [[f''|]|] eqn:R; try congruence. *) + (* assert (f'' = Internal f) by congruence; subst f''. unfold Genv.find_def in R; rewrite R. *) + (* now simpl in *; rewrite side_f in *; destruct δ. } *) + (* intros <-. *) + + (* exploit weak_equivalence_inv1; eauto. intros (st2 & rs2 & m2 & m2_m3 & A). *) + (* injection A; intros -> -> ->. *) + + (* exploit eval_builtin_args_inject; eauto using delta_zero, partial_mem_inject. *) + (* intros (vl' & eval_args' & inj_args'). *) + (* exploit external_call_inject_left; eauto using partial_mem_inject. *) + (* rewrite ALLOWED; auto. *) + (* intros (j__δ' & vres' & m3' & extcall' & inj_res & unchanged1 & unchanged2 & incr & sep & inj_pres' & m'_m3' & m2_m3' & rs_rs3' & st_rel'). *) + + (* exploit extcall_preserves_mem_rel_opp_side1; eauto. *) + (* { inv weak_s2_s3; eauto. *) + (* rewrite H4 in H14. simpl in H14. *) + (* erewrite Genv.find_def_find_comp_of_block in H14; eauto. inv H14. *) + (* rewrite ALLOWED0. now auto. } *) + (* intros m'0_m3'. *) + + (* eexists; exists j__δ', j__oppδ; split; [| split; [| split; [| split]]]. *) + (* + econstructor; [| now eapply star_refl | now traceEq]. *) + (* eapply exec_step_builtin; eauto. *) + (* + eauto. *) + (* + eauto. *) + (* + simpl. eapply inject_incr_stack_rel1; eauto. *) + (* + left; split. *) + (* * econstructor; eauto. *) + (* -- simpl. *) + (* assert (R: nextinstr (set_res res vres *) + (* (undef_regs (map preg_of (destroyed_by_builtin ef)) *) + (* (rs # X1 <- Vundef) # X31 <- Vundef)) PC = *) + (* Val.offset_ptr (rs PC) Ptrofs.one). *) + (* { clear -RES_NOT_PC. *) + (* destruct RES_NOT_PC as [reg ?]; subst res. *) + (* Simpl. *) + (* rewrite Asmgenproof0.set_res_other; eauto. *) + (* assert (H': Asmgenproof0.preg_notin PC (destroyed_by_builtin ef)). *) + (* { Local Transparent destroyed_by_builtin. *) + (* unfold destroyed_by_builtin. *) + (* destruct ef; simpl; auto. *) + (* - destruct orb; simpl; intuition. *) + (* destruct orb; simpl; intuition. *) + (* - intuition. *) + (* - induction clobbers. *) + (* + simpl; auto. *) + (* + simpl. destruct register_by_name; auto. *) + (* simpl; intuition. *) + (* destruct (destroyed_by_clobber clobbers); [| split]; now destruct m. *) + (* Local Opaque destroyed_by_builtin. } *) + (* rewrite Asmgenproof0.undef_regs_other_2; eauto. } *) + (* rewrite R. *) + (* rewrite H; simpl. *) + (* erewrite Genv.find_def_find_comp_of_block; eauto. reflexivity. *) + (* -- eapply regset_rel_return_from_builtin; eauto. *) + (* * inv weak_s2_s3; inv A; econstructor; eauto. *) + (* -- simpl. *) + (* assert (R: nextinstr (set_res res0 vres0 *) + (* (undef_regs (map preg_of (destroyed_by_builtin ef0)) *) + (* (rs2 # X1 <- Vundef) # X31 <- Vundef)) PC = *) + (* Val.offset_ptr (rs2 PC) Ptrofs.one). *) + (* { clear -RES_NOT_PC0. *) + (* destruct RES_NOT_PC0 as [reg ?]; subst res0. *) + (* Simpl. *) + (* rewrite Asmgenproof0.set_res_other; eauto. *) + (* assert (H': Asmgenproof0.preg_notin PC (destroyed_by_builtin ef0)). *) + (* { Local Transparent destroyed_by_builtin. *) + (* unfold destroyed_by_builtin. *) + (* destruct ef0; simpl; auto. *) + (* - destruct orb; simpl; intuition. *) + (* destruct orb; simpl; intuition. *) + (* - intuition. *) + (* - induction clobbers. *) + (* + simpl; auto. *) + (* + simpl. destruct register_by_name; auto. *) + (* simpl; intuition. *) + (* destruct (destroyed_by_clobber clobbers); [| split]; now destruct m. *) + (* Local Opaque destroyed_by_builtin. } *) + (* rewrite Asmgenproof0.undef_regs_other_2; eauto. } *) + (* rewrite R. *) + (* rewrite H4 in *; simpl in *. now auto. *) + (* -- simpl. *) + (* assert (R: nextinstr (set_res res vres' *) + (* (undef_regs (map preg_of (destroyed_by_builtin ef)) *) + (* (rs3 # X1 <- Vundef) # X31 <- Vundef)) PC = *) + (* Val.offset_ptr (rs3 PC) Ptrofs.one). *) + (* { clear -RES_NOT_PC. *) + (* destruct RES_NOT_PC as [reg ?]; subst res. *) + (* Simpl. *) + (* rewrite Asmgenproof0.set_res_other; eauto. *) + (* assert (H': Asmgenproof0.preg_notin PC (destroyed_by_builtin ef)). *) + (* { Local Transparent destroyed_by_builtin. *) + (* unfold destroyed_by_builtin. *) + (* destruct ef; simpl; auto. *) + (* - destruct orb; simpl; intuition. *) + (* destruct orb; simpl; intuition. *) + (* - intuition. *) + (* - induction clobbers. *) + (* + simpl; auto. *) + (* + simpl. destruct register_by_name; auto. *) + (* simpl; intuition. *) + (* destruct (destroyed_by_clobber clobbers); [| split]; now destruct m. *) + (* Local Opaque destroyed_by_builtin. } *) + (* rewrite Asmgenproof0.undef_regs_other_2; eauto. } *) + (* rewrite R. *) + (* rewrite eq_pc' in *; simpl in *; now auto. *) + + (* - (* builtin / external call *) *) + (* exploit strong_equiv_state_internal_inv; eauto. *) + (* intros (st3 & rs3 & m3 & b3 & f' & ? & eq_pc' & find_funct & [match_f_f' left_implies_eq] & m1_m3 & rs1_rs3 & side_f); *) + (* subst s3. *) + (* exploit find_def_find_symbol; eauto. intros [id find_id]. *) + (* exploit left_implies_eq; eauto. *) + (* { unfold kept_genv. rewrite find_id. *) + (* unfold Genv.find_funct_ptr in H0. destruct (Genv.find_def ge1 b) as [[f''|]|] eqn:R; try congruence. *) + (* assert (f'' = Internal f) by congruence; subst f''. unfold Genv.find_def in R; rewrite R. *) + (* now simpl in *; rewrite side_f in *; destruct δ. } *) + (* intros <-. *) + + (* exploit weak_equivalence_inv1; eauto. intros (st2 & rs2 & m2 & m2_m3 & A). *) + (* injection A; intros -> -> ->. *) + + (* exploit eval_builtin_args_inject; eauto using delta_zero, partial_mem_inject. *) + (* intros (vl' & eval_args' & inj_args'). *) + (* exploit external_call_inject_left; eauto using partial_mem_inject. *) + (* rewrite ALLOWED; auto. *) + (* intros (j__δ' & vres' & m3' & extcall' & inj_res & unchanged1 & unchanged2 & incr & sep & inj_pres' & m'_m3' & m2_m3' & rs_rs3' & st_rel'). *) + + (* exploit extcall_preserves_mem_rel_opp_side1; eauto. *) + (* { inv weak_s2_s3; eauto. *) + (* rewrite H4 in H13. simpl in H13. *) + (* erewrite Genv.find_def_find_comp_of_block in H13; eauto. inv H13. *) + (* now auto. } *) + (* intros m'0_m3'. *) + + (* eexists; exists j__δ', j__oppδ; split; [| split; [| split; [| split]]]. *) + (* + econstructor; [| now eapply star_refl | now traceEq]. *) + (* eapply exec_step_builtin; eauto. *) + (* + eauto. *) + (* + eauto. *) + (* + simpl. eapply inject_incr_stack_rel1; eauto. *) + (* + left; split. *) + (* * econstructor; eauto. *) + (* -- simpl. *) + (* assert (R: nextinstr (set_res res vres *) + (* (undef_regs (map preg_of (destroyed_by_builtin ef)) *) + (* (rs # X1 <- Vundef) # X31 <- Vundef)) PC = *) + (* Val.offset_ptr (rs PC) Ptrofs.one). *) + (* { clear -RES_NOT_PC. *) + (* destruct RES_NOT_PC as [reg ?]; subst res. *) + (* Simpl. *) + (* rewrite Asmgenproof0.set_res_other; eauto. *) + (* assert (H': Asmgenproof0.preg_notin PC (destroyed_by_builtin ef)). *) + (* { Local Transparent destroyed_by_builtin. *) + (* unfold destroyed_by_builtin. *) + (* destruct ef; simpl; auto. *) + (* - destruct orb; simpl; intuition. *) + (* destruct orb; simpl; intuition. *) + (* - intuition. *) + (* - induction clobbers. *) + (* + simpl; auto. *) + (* + simpl. destruct register_by_name; auto. *) + (* simpl; intuition. *) + (* destruct (destroyed_by_clobber clobbers); [| split]; now destruct m. *) + (* Local Opaque destroyed_by_builtin. } *) + (* rewrite Asmgenproof0.undef_regs_other_2; eauto. } *) + (* rewrite R. *) + (* rewrite H; simpl. *) + (* erewrite Genv.find_def_find_comp_of_block; eauto. reflexivity. *) + (* -- eapply regset_rel_return_from_builtin; eauto. *) + (* * inv weak_s2_s3; inv A; econstructor; eauto. *) + (* -- simpl. *) + (* rewrite H4 in H13; simpl in H13. *) + (* erewrite Genv.find_def_find_comp_of_block in H13; eauto. inv H13; auto. *) + (* -- simpl. *) + (* assert (R: nextinstr (set_res res vres' *) + (* (undef_regs (map preg_of (destroyed_by_builtin ef)) *) + (* (rs3 # X1 <- Vundef) # X31 <- Vundef)) PC = *) + (* Val.offset_ptr (rs3 PC) Ptrofs.one). *) + (* { clear -RES_NOT_PC. *) + (* destruct RES_NOT_PC as [reg ?]; subst res. *) + (* Simpl. *) + (* rewrite Asmgenproof0.set_res_other; eauto. *) + (* assert (H': Asmgenproof0.preg_notin PC (destroyed_by_builtin ef)). *) + (* { Local Transparent destroyed_by_builtin. *) + (* unfold destroyed_by_builtin. *) + (* destruct ef; simpl; auto. *) + (* - destruct orb; simpl; intuition. *) + (* destruct orb; simpl; intuition. *) + (* - intuition. *) + (* - induction clobbers. *) + (* + simpl; auto. *) + (* + simpl. destruct register_by_name; auto. *) + (* simpl; intuition. *) + (* destruct (destroyed_by_clobber clobbers); [| split]; now destruct m. *) + (* Local Opaque destroyed_by_builtin. } *) + (* rewrite Asmgenproof0.undef_regs_other_2; eauto. } *) + (* rewrite R. *) + (* rewrite eq_pc' in *; simpl in *. *) + (* rewrite H15. *) + (* rewrite H4 in H13; simpl in H13. *) + (* erewrite Genv.find_def_find_comp_of_block in H13; eauto. inv H13; auto. *) + + (* - (* external_call / builtin *) *) + (* exploit strong_equiv_state_external_inv; eauto. *) + (* intros (st3 & rs3 & m3 & b3 & ? & eq_pc' & find_funct & m1_m3 & rs1_rs3 & side_ef); *) + (* subst s3. *) + (* exploit find_def_find_symbol; eauto. intros [id find_id]. *) + + (* exploit weak_equivalence_inv1; eauto. intros (st2 & rs2 & m2 & m2_m3 & A). *) + (* injection A; intros <- <- <-. *) + + (* exploit extcall_arguments_preserved; eauto. *) + (* intros (args' & inj_args & extcall_args'). *) + + + (* exploit (extcall_preserves_mem_rel_opp_side1 s ge2 ge3 j__oppδ (opposite δ) *) + (* m0 m'0 m3); eauto. *) + (* { rewrite ALLOWED. inv weak_s2_s3; simpl in *. *) + (* rewrite H3 in H13. simpl in H13. *) + (* erewrite Genv.find_def_find_comp_of_block in H13; eauto. inv H13. *) + (* now auto. } *) + (* intros m'0_m3. *) + + (* exploit external_call_inject_left; eauto using partial_mem_inject. *) + (* intros (j__δ' & vres' & m3' & extcall' & inj_res & unchanged1 & unchanged2 & incr & sep & inj_pres' & m'_m3' & m2_m3' & rs_rs3' & st_rel'). *) + + (* eexists; exists j__δ', j__oppδ; split; [| split; [| split; [| split]]]. *) + (* + econstructor; [| now eapply star_refl | now traceEq]. *) + (* eapply exec_step_external; eauto. *) + (* + eauto. *) + (* + eauto. *) + (* + simpl. eapply inject_incr_stack_rel1; eauto. *) + (* + left; split. *) + (* * econstructor; eauto. *) + (* eapply regset_rel_return_from_external; eauto. *) + (* * inv weak_s2_s3; inv A; econstructor; eauto. *) + (* -- assert (R: nextinstr (set_res res0 vres *) + (* (undef_regs (map preg_of (destroyed_by_builtin ef0)) *) + (* (rs0 # X1 <- Vundef) # X31 <- Vundef)) PC = *) + (* Val.offset_ptr (rs0 PC) Ptrofs.one). *) + (* { clear -RES_NOT_PC. *) + (* destruct RES_NOT_PC as [reg ?]; subst res0. *) + (* Simpl. *) + (* rewrite Asmgenproof0.set_res_other; eauto. *) + (* assert (H': Asmgenproof0.preg_notin PC (destroyed_by_builtin ef0)). *) + (* { Local Transparent destroyed_by_builtin. *) + (* unfold destroyed_by_builtin. *) + (* destruct ef0; simpl; auto. *) + (* - destruct orb; simpl; intuition. *) + (* destruct orb; simpl; intuition. *) + (* - intuition. *) + (* - induction clobbers. *) + (* + simpl; auto. *) + (* + simpl. destruct register_by_name; auto. *) + (* simpl; intuition. *) + (* destruct (destroyed_by_clobber clobbers); [| split]; now destruct m. *) + (* Local Opaque destroyed_by_builtin. } *) + (* rewrite Asmgenproof0.undef_regs_other_2; eauto. } *) + (* simpl. rewrite R. *) + (* rewrite H3 in *; simpl in *. *) + (* rewrite eq_pc' in *; simpl in *. *) + (* erewrite Genv.find_def_find_comp_of_block in H15; eauto. *) + (* rewrite H13; auto. *) + (* -- now destruct (s (comp_of ef)). *) + + (* - (* External call *) *) + (* exploit strong_equiv_state_external_inv; eauto. *) + (* intros (st3 & rs3 & m3 & b3 & ? & eq_pc' & find_funct & m1_m3 & rs1_rs3 & side_ef); *) + (* subst s3. *) + (* exploit find_def_find_symbol; eauto. intros [id find_id]. *) + + (* exploit weak_equivalence_inv1; eauto. intros (st2 & rs2 & m2 & m2_m3 & A). *) + (* injection A; intros <- <- <-. *) + + (* exploit extcall_arguments_preserved; eauto. *) + (* intros (args' & inj_args & extcall_args'). *) + + + (* exploit (extcall_preserves_mem_rel_opp_side1 s ge2 ge3 j__oppδ (opposite δ) *) + (* m0 m'0 m3); eauto. *) + (* { inv weak_s2_s3; simpl in *. *) + (* rewrite H3 in H12; simpl in H12. *) + (* erewrite Genv.find_def_find_comp_of_block in H12; eauto. inv H12. *) + (* now auto. } *) + (* intros m'0_m3. *) + + (* exploit external_call_inject_left; eauto using partial_mem_inject. *) + (* intros (j__δ' & vres' & m3' & extcall' & inj_res & unchanged1 & unchanged2 & incr & sep & inj_pres' & m'_m3' & m2_m3' & rs_rs3' & st_rel'). *) + + (* remember ((set_pair (loc_external_result (ef_sig ef)) vres' (undef_caller_save_regs rs3)) # PC <- (rs3 X1)) as rs3'. *) + (* exists (ReturnState st3 rs3' m3' (comp_of ef)). *) + (* exists j__δ', j__oppδ; split; [| split; [| split; [| split]]]. *) + (* + econstructor; [| now eapply star_refl | now traceEq]. *) + (* eapply exec_step_external; eauto. *) + (* + eauto. *) + (* + eauto. *) + (* + simpl. eapply inject_incr_stack_rel1; eauto. *) + (* + left; split. *) + (* * econstructor; eauto. subst rs3'. *) + (* eapply regset_rel_return_from_external; eauto. *) + (* * inv weak_s2_s3; inv A. *) + (* assert (comp_of ef = comp_of ef0) as R. *) + (* { *) + (* rewrite H3 in H12; simpl in H12. *) + (* erewrite Genv.find_def_find_comp_of_block in H12; eauto. *) + (* rewrite eq_pc' in H14; simpl in H14. *) + (* erewrite Genv.find_def_find_comp_of_block in H14; eauto. inv H12; inv H14. auto. } *) + (* rewrite R in *. *) + (* econstructor; eauto. now destruct (s (comp_of ef0)). *) + + Unshelve. + all: eauto. + Admitted. + +End Theorems. + + + +Section Simulation. + Context (c1 c2 p1 p2: Asm.program). + Variable s: split. + + Context (W1 W2 W3: Asm.program). + Hypothesis c1_p1: link p1 c1 = Some W1. + Hypothesis c2_p2: link p2 c2 = Some W2. + Hypothesis c2_p1: link p1 c2 = Some W3. + + Hypothesis match_W1_W3: match_prog s Left W1 W3. + Hypothesis match_W2_W3: match_prog s Right W2 W3. + + Notation cp_main := (comp_of_main W1). + + Hypothesis norepet1: list_norepet (prog_defs_names W1). + Hypothesis norepet2: list_norepet (prog_defs_names W2). + + Notation ge1 := (Genv.globalenv W1). + Notation ge2 := (Genv.globalenv W2). + Notation ge3 := (Genv.globalenv W3). + + + Hypothesis same_low_half1: low_half ge1 = low_half ge3. + Hypothesis same_low_half2: low_half ge2 = low_half ge3. + + Let single_L1 := sd_traces (semantics_determinate W1). + Let single_L2 := sd_traces (semantics_determinate W2). + Let single_L3 := sd_traces (semantics_determinate W3). + + Notation comp_of1 := (@comp_of _ (has_comp_state W1)). + Notation comp_of2 := (@comp_of _ (has_comp_state W2)). + Notation comp_of3 := (@comp_of _ (has_comp_state W3)). + + Lemma simulation: + @threeway_simulation (semantics W1) (semantics W2) (semantics W3) single_L1 single_L2 single_L3. + Proof. + apply threeway_simulation_diagram + with (metadata := (meminj * meminj)%type) + (common_equivalence := fun '(j__left, j__right) s1 s2 s3 => + stack_rel s ge3 Left j__left j__right + (stack_of_state s1) (stack_of_state s2) (stack_of_state s3)) + (strong_equivalence1 := fun '(j__left, j__right) s1 s3 => + agrees_with j__left (init_meminj W1 W3) /\ + def_on_addressable s ge1 j__left Left /\ + strong_equivalence s ge1 ge3 j__left Left s1 s3) + (strong_equivalence2 := fun '(j__left, j__right) s2 s3 => + agrees_with j__right (init_meminj W2 W3) /\ + def_on_addressable s ge2 j__right Right /\ + strong_equivalence s ge2 ge3 j__right Right s2 s3) + (weak_equivalence1 := fun '(j__left, j__right) s1 s3 => + agrees_with j__left (init_meminj W1 W3) /\ + def_on_addressable s ge1 j__left Left /\ + weak_equivalence s ge1 ge3 j__left Left s1 s3) + (weak_equivalence2 := fun '(j__left, j__right) s2 s3 => + agrees_with j__right (init_meminj W2 W3) /\ + def_on_addressable s ge2 j__right Right /\ + weak_equivalence s ge2 ge3 j__right Right s2 s3). + + + - exploit (globals_symbols_inject s Left W1 W3); + eauto using init_meminj_preserves_globals. + exploit (globals_symbols_inject s Right W2 W3); + eauto using init_meminj_preserves_globals. + intros [? _] [? ]. eauto. + - exploit (globals_symbols_inject s Left W1 W3); + eauto using init_meminj_preserves_globals. + exploit (globals_symbols_inject s Right W2 W3); + eauto using init_meminj_preserves_globals. + intros [? _] [? ]. eauto. + - intros s1 ini1 s2 ini2. + assert (exists m3, + Genv.init_mem W3 = Some m3) as [? ?]. + { inv ini1; inv ini2; subst ge ge0. + unfold Genv.init_mem in *. clear -H H0 match_W1_W3 match_W2_W3. + revert m0 H m1 H0. admit. + } + + eexists; eexists (init_meminj W1 W3, init_meminj W2 W3). split. + + econstructor; eauto. + + inv ini1; inv ini2. + destruct (comp_of_main W1) as [cp |] eqn:ini_comp; [| admit]. + destruct (s cp) eqn:ini_side. + * eapply match_states_left; simpl; eauto. + -- now constructor. + -- split; eauto. + econstructor; eauto. congruence. congruence. + split; eauto. + eapply def_on_addressable_init; eauto. + { econstructor. + - admit. + - eauto. + - subst rs0. intros ?. admit. + - admit. } + -- split; eauto. + econstructor; eauto. congruence. congruence. + split; eauto. + eapply def_on_addressable_init; eauto. + { econstructor. + - admit. + - admit. + - eauto. + - admit. } + * eapply match_states_right; simpl; eauto. + -- now constructor. + -- split; eauto. + econstructor; eauto. congruence. congruence. + split; eauto. + eapply def_on_addressable_init; eauto. + { econstructor. + - admit. + - admit. + - eauto. + - admit. } + -- split; eauto. + econstructor; eauto. congruence. congruence. + split; eauto. + eapply def_on_addressable_init; eauto. + { econstructor. + - admit. + - eauto. + - admit. + - admit. } + - intros s1 s1' H s2 s3 [j__left j__right] (? & ? & ?) (? & ? & ?) ?. + exploit (step_E0_strong s W1 W2 W3 Left); eauto. + intros (s3' & j__left' & ? & ? & ? & ? & ? & ?). + exists s3'; eexists (j__left', j__right); split; [assumption |]. + split; [| split]; [| | assumption]; eauto. + - intros s1 s1' H s2 s3 [j__left j__right] (? & ? & ?) (? & ? & ?) ?. + exploit (step_E0_strong s W2 W1 W3 (opposite Left)); eauto using stack_rel_comm. + intros (s3' & j__right' & ? & ? & ? & S & ? & ?). + exists s3'; eexists (j__left, j__right'); split; [assumption |]. + split; [| split]; eauto. + eapply stack_rel_comm in S; eauto. + - intros s1 s1' H s2 s3 (j__left & j__right) (? & ? & ?) (? & ? & ?) ?. + exploit (step_E0_weak s W2 W1 W3 (opposite Left)); eauto using stack_rel_comm. + intros (j__left' & ? & ? & S & ? & ?). + exists (j__left', j__right). + split. split; [| split]; eauto. + split. split; [| split]; eauto. + apply stack_rel_comm in S; simpl in S; eauto. + - intros s1 s1' H s2 s3 (j__left & j__right) (? & ? & ?) (? & ? & ?) ?. + exploit (step_E0_weak s W1 W2 W3 Left); eauto using stack_rel_comm. + intros (j__right' & ? & ? & S & ? & ?). + exists (j__left, j__right'). + split. split; [| split]; eauto. + split. split; [| split]; eauto. + eauto. + - intros s1 e s1' H s2 s2' H0 s3 (j__left & j__right) H1. + destruct H1 as [[? ?] ? ? ? ? [? [? ?]] [? [? ?]] + | [? ?] ? ? ? ? [? [? ?]] [? [? ?]]]. + + exploit (step_t s W1 W2 W3 Left); eauto. + intros (s3' & j__left' & j__right' & ? & ? & ? & ? & ? & ? & X). + exists s3'; exists (j__left', j__right'); split; eauto. + destruct X as [[? ?] | [? ?]]; [left; eauto | right; eauto]. + + exploit (step_t s W2 W1 W3 (opposite Left)); eauto using stack_rel_comm. + intros (s3' & j__right' & j__left' & ? & ? & ? & ? & ? & S & X). + eapply stack_rel_comm in S; simpl in S. + exists s3'; exists (j__left', j__right'); split; eauto. + destruct X as [[? ?] | [? ?]]; [right; eauto | left; eauto]. + Admitted. + + +End Simulation. From 164f4342de7e1fce0f61c31448d57ca4fb8848de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Thu, 18 Jan 2024 16:38:01 +0100 Subject: [PATCH 69/83] [Backtranslation] Uncomment proofs --- security/BtInfoAsm.v | 3772 ++++++++++++++++++++-------------------- security/MemoryDelta.v | 218 ++- 2 files changed, 2077 insertions(+), 1913 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 076deecff1..c2b0973e3a 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -25,27 +25,27 @@ Section AUX. 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. *) + Lemma extcall_cases + ef ge cp m args + (ECC: external_call_conds ef ge m args) + tr rv m' + (ECALL: external_call ef ge cp args m tr rv m') + : + (external_call_unknowns ef ge m args) \/ + (external_call_known_observables ef ge cp m args tr rv m') \/ + (external_call_known_silents ef ge cp 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. @@ -212,6 +212,12 @@ Section IR. eapply has_comp_fundef. eapply has_comp_function. Qed. + Definition funsig fd := + match fd with + | Internal f => Asm.fn_sig f + | External ef => ef_sig ef + end. + Variant ir_step (ge: Asm.genv) : ir_state -> (ident * bundle_event) -> ir_state -> Prop := | ir_step_cross_call_internal cur m1 ik @@ -228,7 +234,7 @@ Section IR. (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) *) + (PUB: public_first_order ge m2) id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) : @@ -241,7 +247,7 @@ Section IR. sg fd_cur (FINDFD: Genv.find_funct_ptr ge cur = Some (fd_cur)) (* in Asm, stack has the sig *) - (* (SIG: sg = Asm.funsig fd_cur) *) + (SIG: sg = funsig fd_cur) (NPTR: crossing_comp ge cp_next cp_cur -> not_ptr vretv) (NEXTCP: cp_next = Genv.find_comp_in_genv ge (Vptr next Ptrofs.zero)) f_next @@ -251,7 +257,7 @@ Section IR. (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) *) + (PUB: public_first_order ge m2) id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) : @@ -269,8 +275,8 @@ Section IR. (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') vargs vretv (EC: external_call ef ge cp_cur 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 = [])) *) + (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ + (external_call_known_observables ef ge cp_cur m1' vargs tr vretv m2 /\ d = [])) (ARGS: evargs = vals_to_eventvals ge vargs) id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) @@ -285,8 +291,8 @@ Section IR. (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') vargs vretv (EC: external_call ef ge cp_cur 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 = [])) *) + (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ + (external_call_known_observables ef ge cp_cur m1' vargs tr vretv m2 /\ d = [])) (ARGS: evargs = vals_to_eventvals ge vargs) id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) @@ -420,17 +426,17 @@ Section MEASURE. End MEASURE. -(* Section CONDS. *) +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_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (forall ofs, ~ Mem.perm m b ofs Max Freeable). -(* Definition public_rev_perm ge m1 m2 := *) -(* forall b, match meminj_public ge b with *) -(* | Some (b', del) => forall ofs k p, Mem.perm m2 b' (ofs + del) k p -> Mem.perm m1 b ofs k p *) -(* | None => True *) -(* end. *) + Definition public_rev_perm ge m1 m2 := + forall b, match meminj_public ge b with + | Some (b', del) => forall ofs k p, Mem.perm m2 b' (ofs + del) k p -> Mem.perm m1 b ofs k p + | None => True + end. -(* End CONDS. *) +End CONDS. Section FROMASM. @@ -511,257 +517,257 @@ Section FROMASM. end); simpl. - (* Lemma public_not_freeable_free_inj_none *) - (* ge m *) - (* (NFREE: public_not_freeable ge m) *) - (* b lo hi cp m' *) - (* (FREE: Mem.free m b lo hi cp = Some m') *) - (* (BOUND: (lo < hi)%Z) *) - (* : *) - (* meminj_public ge b = None. *) - (* Proof. *) - (* destruct (meminj_public ge b) eqn:INJPUB; auto. exfalso. *) - (* eapply Mem.free_range_perm in FREE. unfold Mem.range_perm in FREE. *) - (* eapply NFREE. erewrite INJPUB. congruence. eapply Mem.perm_cur_max; apply FREE. *) - (* instantiate (1:=lo). lia. *) - (* Qed. *) + Lemma public_not_freeable_free_inj_none + ge m + (NFREE: public_not_freeable ge m) + b lo hi cp m' + (FREE: Mem.free m b lo hi cp = Some m') + (BOUND: (lo < hi)%Z) + : + meminj_public ge b = None. + Proof. + destruct (meminj_public ge b) eqn:INJPUB; auto. exfalso. + eapply Mem.free_range_perm in FREE. unfold Mem.range_perm in FREE. + eapply NFREE. erewrite INJPUB. congruence. eapply Mem.perm_cur_max; apply FREE. + instantiate (1:=lo). lia. + Qed. - (* Lemma public_not_freeable_store *) - (* ge m1 *) - (* (NFREE: public_not_freeable ge m1) *) - (* chunk b ofs v cp m2 *) - (* (STORE: Mem.store chunk m1 b ofs v cp = Some m2) *) - (* : *) - (* public_not_freeable ge m2. *) - (* Proof. *) - (* unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). *) - (* apply NFREE; eapply Mem.perm_store_2; eauto. *) - (* Qed. *) + Lemma public_not_freeable_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_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_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_free + ge m1 + (NFREE: public_not_freeable ge m1) + b lo hi cp m2 + (STORE: Mem.free m1 b lo hi cp = Some m2) + : + public_not_freeable ge m2. + Proof. + unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). + apply NFREE. eapply Mem.perm_free_3; eauto. + Qed. - (* Lemma public_not_freeable_exec_instr *) - (* (ge: genv) f i rs m cp rs' m' *) - (* (NFREE: public_not_freeable ge m) *) - (* (NALLOC: meminj_not_alloc (meminj_public ge) m) *) - (* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) - (* : *) - (* public_not_freeable ge m'. *) - (* Proof. *) - (* destruct i; simpl in EXEC. *) - (* all: try (inv EXEC; eauto). *) - (* all: simpl_before_exists; eauto. *) - (* all: try *) - (* (match goal with *) - (* | H: context [Mem.alloc] |- _ => idtac *) - (* | H: context [Mem.free] |- _ => idtac *) - (* | H: Mem.store ?ch ?m ?b ?ofs ?v ?cp = _ |- _ => *) - (* eapply public_not_freeable_store; eauto *) - (* end). *) - (* { eapply public_not_freeable_store. eapply public_not_freeable_alloc; eauto. eauto. } *) - (* { eapply public_not_freeable_free; eauto. } *) - (* Qed. *) + Lemma public_not_freeable_exec_instr + (ge: genv) f i rs m cp rs' m' + (NFREE: public_not_freeable ge m) + (NALLOC: meminj_not_alloc (meminj_public ge) m) + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + : + public_not_freeable ge m'. + Proof. + destruct i; simpl in EXEC. + all: try (inv EXEC; eauto). + all: simpl_before_exists; eauto. + all: try + (match goal with + | H: context [Mem.alloc] |- _ => idtac + | H: context [Mem.free] |- _ => idtac + | H: Mem.store ?ch ?m ?b ?ofs ?v ?cp = _ |- _ => + eapply public_not_freeable_store; eauto + end). + { eapply public_not_freeable_store. eapply public_not_freeable_alloc; eauto. eauto. } + { eapply public_not_freeable_free; eauto. } + Qed. - (* Lemma public_rev_perm_store *) - (* ge m1 m' *) - (* (PRP: public_rev_perm ge m1 m') *) - (* chunk b ofs v cp m2 *) - (* (STORE: Mem.store chunk m1 b ofs v cp = Some m2) *) - (* : *) - (* public_rev_perm ge m2 m'. *) - (* Proof. *) - (* unfold public_rev_perm in *; intros. specialize (PRP b0). des_ifs. intros. *) - (* exploit PRP; eauto. intros. eapply Mem.perm_store_1; eauto. *) - (* Qed. *) + Lemma public_rev_perm_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_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_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_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 public_rev_perm_exec_instr + (ge: genv) f i rs m cp rs' m' + (NFREE: public_not_freeable ge m) + m0 + (PRP: public_rev_perm ge m m0) + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + : + public_rev_perm ge m' m0. + Proof. + destruct i; simpl in EXEC. + all: try (inv EXEC; eauto). + all: simpl_before_exists; eauto. + all: try + (match goal with + | H: context [Mem.alloc] |- _ => idtac + | H: context [Mem.free] |- _ => idtac + | H: Mem.store ?ch ?m ?b ?ofs ?v ?cp = _ |- _ => + eapply public_rev_perm_store; eauto + end). + { eapply public_rev_perm_store. eapply public_rev_perm_alloc; eauto. eauto. } + { eapply public_rev_perm_free; eauto. } + Qed. -(* Lemma meminj_not_alloc_delta *) -(* j m0 *) -(* (NALLOC: meminj_not_alloc j m0) *) -(* d m1 *) -(* (APPD: mem_delta_apply d (Some m0) = Some m1) *) -(* : *) -(* meminj_not_alloc j m1. *) -(* Proof. *) -(* revert m0 NALLOC m1 APPD. induction d; intros. *) -(* { simpl in *. inv APPD. auto. } *) -(* rewrite mem_delta_apply_cons in APPD. destruct a. *) -(* - destruct d0 as (((ch & ptr) & v) & cp). ss. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. *) -(* unfold meminj_not_alloc in *. intros. eapply NALLOC. destruct ptr; ss. erewrite Mem.nextblock_store in H; eauto. *) -(* - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. *) -(* unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_store in H; eauto. *) -(* - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. *) -(* unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_storebytes in H; eauto. *) -(* - destruct d0 as ((cp & lo) & hi). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. *) -(* unfold meminj_not_alloc in *. intros. eapply NALLOC. destruct (Mem.alloc m0 cp lo hi) eqn:MA. simpl in *. inv MEM. erewrite Mem.nextblock_alloc in H; eauto. lia. *) -(* - destruct d0 as (((b & lo) & hi) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. *) -(* unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_free in H; eauto. *) -(* Qed. *) - -(* Lemma exec_instr_is_return *) -(* ge f i rs m cp rs' m' *) -(* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) -(* (ISRET: is_return i = true) *) -(* : *) -(* (exists v, rs' = (rs # PC <- v)) /\ (m' = m). *) -(* Proof. destruct i; simpl in *; clarify. split; eauto. Qed. *) - -(* Lemma exec_instr_is_call *) -(* ge f i rs m cp rs' m' *) -(* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) -(* sig *) -(* (ISRET: sig_call i = Some sig) *) -(* : *) -(* (rs' X1 = Val.offset_ptr rs#PC Ptrofs.one) /\ (m' = m). *) -(* Proof. destruct i; simpl in *; clarify. Qed. *) - -(* Lemma mem_delta_exec_instr *) -(* (ge: genv) f i rs m cp rs' m' *) -(* (NFREE: public_not_freeable ge m) *) -(* (EXEC: exec_instr ge f i rs m cp = Next rs' m') *) -(* m0 d *) -(* (DELTA0: mem_delta_inj_wf cp (meminj_public ge) d) *) -(* (DELTA1: mem_delta_apply d (Some m0) = Some m) *) -(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) -(* : *) -(* exists d', (mem_delta_inj_wf cp (meminj_public ge) d') /\ (mem_delta_apply d' (Some m0) = Some m'). *) -(* Proof. *) -(* destruct i; simpl in EXEC. *) -(* all: try (inv EXEC; eauto). *) -(* all: simpl_before_exists; eauto. *) -(* all: try *) -(* (match goal with *) -(* | H: context [Mem.alloc] |- _ => idtac *) -(* | H: context [Mem.free] |- _ => idtac *) -(* | H: Mem.store ?ch ?m ?b (Ptrofs.unsigned ?ofs) ?v ?cp = _ |- _ => *) -(* exists (d ++ [mem_delta_kind_storev (ch, Vptr b ofs, v, cp)]); split *) -(* end; *) -(* [apply Forall_app; split; [auto | constructor; ss; auto] *) -(* | rewrite mem_delta_apply_app; (match goal with | H: mem_delta_apply _ _ = Some _ |- _ => rewrite H end; simpl; auto) ]). *) -(* { match goal with *) -(* | _: Mem.alloc _ ?cp1 ?lo ?hi = _, _: Mem.store ?ch _ ?b ?ofs ?v ?cp2 = _ |- _ => *) -(* exists (d ++ ([mem_delta_kind_alloc (cp1, lo, hi)] ++ [mem_delta_kind_store (ch, b, ofs, v, cp2)])) *) -(* end. *) -(* split. *) -(* - apply Forall_app; split; auto. apply Forall_app; split; constructor; simpl; auto. *) -(* hexploit meminj_not_alloc_delta. eauto. eapply DELTA1. intros NALLOC2. apply NALLOC2. *) -(* exploit Mem.alloc_result; eauto. lia. *) -(* - rewrite mem_delta_apply_app. rewrite DELTA1. rewrite mem_delta_apply_app. simpl. rewrite Heqp. simpl. auto. *) -(* } *) -(* { destruct (Z.leb_spec sz 0); cycle 1. *) -(* { match goal with *) -(* | _: Mem.free _ ?b ?lo ?hi ?cp = _ |- _ => *) -(* exists (d ++ [mem_delta_kind_free (b, lo, hi, cp)]) *) -(* end. *) -(* split. *) -(* - apply Forall_app; split; auto. constructor; auto. simpl. destruct (meminj_public ge b) eqn:INJPUB; auto. exfalso. *) -(* eapply Mem.free_range_perm in Heqo0. unfold Mem.range_perm in Heqo0. eapply NFREE. erewrite INJPUB. congruence. eapply Mem.perm_cur_max; apply Heqo0. instantiate (1:=0%Z). lia. *) -(* - rewrite mem_delta_apply_app. rewrite DELTA1. simpl. auto. *) -(* } *) -(* { apply Mem.free_result in Heqo0. unfold Mem.unchecked_free in Heqo0. unfold zle in Heqo0. des_ifs. eexists; eauto. } *) -(* } *) -(* Qed. *) + Lemma meminj_not_alloc_delta + j m0 + (NALLOC: meminj_not_alloc j m0) + d m1 + (APPD: mem_delta_apply d (Some m0) = Some m1) + : + meminj_not_alloc j m1. + Proof. + revert m0 NALLOC m1 APPD. induction d; intros. + { simpl in *. inv APPD. auto. } + rewrite mem_delta_apply_cons in APPD. destruct a. + - destruct d0 as (((ch & ptr) & v) & cp). ss. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. + unfold meminj_not_alloc in *. intros. eapply NALLOC. destruct ptr; ss. erewrite Mem.nextblock_store in H; eauto. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. + unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_store in H; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. + unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_storebytes in H; eauto. + - destruct d0 as ((cp & lo) & hi). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. + unfold meminj_not_alloc in *. intros. eapply NALLOC. destruct (Mem.alloc m0 cp lo hi) eqn:MA. simpl in *. inv MEM. erewrite Mem.nextblock_alloc in H; eauto. lia. + - destruct d0 as (((b & lo) & hi) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. + unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_free in H; eauto. + Qed. + + Lemma exec_instr_is_return + ge f i rs m cp rs' m' + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + (ISRET: is_return i = true) + : + (exists v, rs' = (rs # PC <- v)) /\ (m' = m). + Proof. destruct i; simpl in *; clarify. split; eauto. Qed. + + Lemma exec_instr_is_call + ge f i rs m cp rs' m' + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + sig + (ISRET: sig_call i = Some sig) + : + (rs' X1 = Val.offset_ptr rs#PC Ptrofs.one) /\ (m' = m). + Proof. destruct i; simpl in *; clarify. Qed. + + Lemma mem_delta_exec_instr + (ge: genv) f i rs m cp rs' m' + (NFREE: public_not_freeable ge m) + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + m0 d + (DELTA0: mem_delta_inj_wf cp (meminj_public ge) d) + (DELTA1: mem_delta_apply d (Some m0) = Some m) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + : + exists d', (mem_delta_inj_wf cp (meminj_public ge) d') /\ (mem_delta_apply d' (Some m0) = Some m'). + Proof. + destruct i; simpl in EXEC. + all: try (inv EXEC; eauto). + all: simpl_before_exists; eauto. + all: try + (match goal with + | H: context [Mem.alloc] |- _ => idtac + | H: context [Mem.free] |- _ => idtac + | H: Mem.store ?ch ?m ?b (Ptrofs.unsigned ?ofs) ?v ?cp = _ |- _ => + exists (d ++ [mem_delta_kind_storev (ch, Vptr b ofs, v, cp)]); split + end; + [apply Forall_app; split; [auto | constructor; ss; auto] + | rewrite mem_delta_apply_app; (match goal with | H: mem_delta_apply _ _ = Some _ |- _ => rewrite H end; simpl; auto) ]). + { match goal with + | _: Mem.alloc _ ?cp1 ?lo ?hi = _, _: Mem.store ?ch _ ?b ?ofs ?v ?cp2 = _ |- _ => + exists (d ++ ([mem_delta_kind_alloc (cp1, lo, hi)] ++ [mem_delta_kind_store (ch, b, ofs, v, cp2)])) + end. + split. + - apply Forall_app; split; auto. apply Forall_app; split; constructor; simpl; auto. + hexploit meminj_not_alloc_delta. eauto. eapply DELTA1. intros NALLOC2. apply NALLOC2. + exploit Mem.alloc_result; eauto. lia. + - rewrite mem_delta_apply_app. rewrite DELTA1. rewrite mem_delta_apply_app. simpl. rewrite Heqp. simpl. auto. + } + { destruct (Z.leb_spec sz 0); cycle 1. + { match goal with + | _: Mem.free _ ?b ?lo ?hi ?cp = _ |- _ => + exists (d ++ [mem_delta_kind_free (b, lo, hi, cp)]) + end. + split. + - apply Forall_app; split; auto. constructor; auto. simpl. destruct (meminj_public ge b) eqn:INJPUB; auto. exfalso. + eapply Mem.free_range_perm in Heqo0. unfold Mem.range_perm in Heqo0. eapply NFREE. erewrite INJPUB. congruence. eapply Mem.perm_cur_max; apply Heqo0. instantiate (1:=0%Z). lia. + - rewrite mem_delta_apply_app. rewrite DELTA1. simpl. auto. + } + { apply Mem.free_result in Heqo0. unfold Mem.unchecked_free in Heqo0. unfold zle in Heqo0. des_ifs. eexists; eauto. } + } + Qed. End FROMASM. @@ -811,11 +817,11 @@ Section INVS. Definition wf_ir_conts (ge: Asm.genv) (ik: ir_conts) := Forall (wf_ir_cont ge) ik. - (* Definition match_cur_stack_sig (cur: block) (ge: Asm.genv) (sk: stack) := *) - (* match Genv.find_funct_ptr ge cur with *) - (* | Some fd => Asm.funsig fd = sig_of_call sk *) - (* | _ => False *) - (* end. *) + Definition match_cur_stack_sig (cur: block) (ge: Asm.genv) (sk: stack) := + match Genv.find_funct_ptr ge cur with + | Some fd => funsig fd = sig_of_call sk + | _ => False + end. Definition match_cur_regset (cur: block) (ge: Asm.genv) (rs: regset) := Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = Genv.find_comp_in_genv ge (rs PC). @@ -828,7 +834,7 @@ Section INVS. next ik_tl b sg v ofs sk_tl (COMP: Genv.find_comp_in_genv ge (Vptr next Ptrofs.zero) = Genv.find_comp_in_genv ge (Vptr b Ptrofs.zero)) - (* (SIG: match_cur_stack_sig 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 sg v ofs :: sk_tl). @@ -836,15 +842,15 @@ Section INVS. Definition match_mem (ge: Senv.t) cp (k: meminj) (d: mem_delta) (m_a0 m_i m_a1: mem): Prop := let j := meminj_public ge in (Mem.inject k m_a0 m_i) /\ (inject_incr j k) /\ - (meminj_not_alloc j m_a0) /\ (* (public_not_freeable ge m_a1) /\ *) - (mem_delta_inj_wf cp j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1). - (* (public_rev_perm ge m_a1 m_i). *) + (meminj_not_alloc j m_a0) /\ (public_not_freeable ge m_a1) /\ + (mem_delta_inj_wf cp j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1) /\ + (public_rev_perm ge m_a1 m_i). Definition match_state (ge: Asm.genv) (k: meminj) (m_a0: mem) (d: mem_delta) (ast: Asm.state) (ist: ir_state): Prop := match ast, ist with | State sk rs m_a _, Some (cur, m_i, ik) => (wf_ir_cur ge cur) /\ (wf_ir_conts ge ik) /\ - (* (match_cur_stack_sig cur ge sk) *) (* /\ *)(match_cur_regset cur ge rs) /\ + (match_cur_stack_sig cur ge sk) /\ (match_cur_regset cur ge rs) /\ (match_stack ge ik sk) /\ (match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) | _, _ => False end. @@ -852,1569 +858,1631 @@ Section INVS. End INVS. -(* Section PROOF. *) - -(* Import ListNotations. *) - -(* Ltac end_case := do 2 eexists; split; [|constructor 1]; auto. *) - -(* Lemma asm_step_current_pc *) -(* cpm ge st rs m t s' *) -(* (STEP: step_fix cpm ge (State st rs m) t s') *) -(* : *) -(* exists b ofs, rs PC = Vptr b ofs. *) -(* Proof. destruct (rs PC) eqn:NEXTPC. 1,2,3,4,5: inv STEP; rewrite NEXTPC in H2; inv H2. eauto. Qed. *) - -(* Lemma asm_step_some_fundef *) -(* cpm ge st rs m t s' *) -(* (STEP: step_fix cpm ge (State st rs m) t s') *) -(* b ofs *) -(* (NEXTPC: rs PC = Vptr b ofs) *) -(* : *) -(* exists fd, Genv.find_funct_ptr ge b = Some fd. *) -(* Proof. destruct (Genv.find_funct_ptr ge b) eqn:CASE; eauto. exfalso. inv STEP; rewrite NEXTPC in H2; inv H2; rewrite CASE in H3; inv H3. Qed. *) - -(* Lemma asm_to_ir_compose *) -(* ge ist0 t t1 t2 *) -(* (ISTARS: exists btr1 ist1, *) -(* (unbundle_trace btr1 = t1 /\ istar ir_step ge ist0 btr1 ist1) *) -(* /\ exists btr2 ist2, *) -(* (unbundle_trace btr2 = t2 /\ istar ir_step ge ist1 btr2 ist2)) *) -(* (TR: t = t1 ** t2) *) -(* : *) -(* exists (btr : bundle_trace) (ist' : ir_state), *) -(* unbundle_trace btr = t /\ istar ir_step ge ist0 btr ist'. *) -(* Proof. *) -(* subst. destruct ISTARS as (btr1 & ist1 & (UTR1 & ISTAR1) & btr2 & ist2 & (UTR2 & ISTAR2)). *) -(* exists (btr1 ++ btr2). exists ist2. split; auto. *) -(* { rewrite unbundle_trace_app. rewrite UTR1, UTR2. auto. } *) -(* { eapply istar_trans; eauto. } *) -(* Qed. *) - - -(* Lemma visible_fo_meminj_fo *) -(* (ge: Senv.t) m tys args *) -(* (VFO: visible_fo ge m tys args) *) -(* : *) -(* meminj_first_order (meminj_public ge) m. *) -(* Proof. *) -(* destruct VFO as [PFO _]. ii. unfold public_first_order in PFO. unfold meminj_public in H. des_ifs. *) -(* exploit PFO; eauto. apply Senv.invert_find_symbol. auto. *) -(* Qed. *) - -(* Lemma external_call_unknowns_fo *) -(* ef (ge: Senv.t) m args *) -(* (ECC: external_call_unknowns ef ge m args) *) -(* : *) -(* meminj_first_order (meminj_public ge) m. *) -(* Proof. *) -(* unfold external_call_unknowns in ECC. des_ifs; eapply visible_fo_meminj_fo; eauto. *) -(* Qed. *) - -(* Lemma symbols_inject_meminj_public *) -(* F V (ge: Genv.t F V) *) -(* : *) -(* symbols_inject (meminj_public ge) ge ge. *) -(* Proof. *) -(* unfold symbols_inject. splits; intros; unfold meminj_public in *; auto. *) -(* - des_ifs. *) -(* - erewrite Senv.find_invert_symbol; eauto. rewrite H. eauto. *) -(* - des_ifs. *) -(* Qed. *) - -(* Lemma visible_fo_val_inject_list *) -(* (ge: Senv.t) m tys args *) -(* (VFO: visible_fo ge m tys args) *) -(* : *) -(* Val.inject_list (meminj_public ge) args args. *) -(* Proof. *) -(* destruct VFO as [PFO VP]. induction VP; ss. econs; eauto. clear dependent l. clear dependent l'. inv H; auto. *) -(* destruct H0 as [id [INV PUB]]. *) -(* econs. unfold meminj_public. rewrite INV. rewrite PUB. eauto. rewrite Ptrofs.add_zero. auto. *) -(* Qed. *) - -(* Lemma external_call_unknowns_val_inject_list *) -(* ef (ge: Senv.t) m args *) -(* (ECC: external_call_unknowns ef ge m args) *) -(* : *) -(* Val.inject_list (meminj_public ge) args args. *) -(* Proof. *) -(* unfold external_call_unknowns in ECC. des_ifs; eapply visible_fo_val_inject_list; eauto. *) -(* Qed. *) - -(* Lemma public_rev_perm_delta_apply_inj *) -(* d ge m m_i m_i' cp *) -(* (PRP: public_rev_perm ge m m_i) *) -(* (APPD: mem_delta_apply_wf ge cp d (Some m_i) = Some m_i') *) -(* : *) -(* public_rev_perm ge m m_i'. *) -(* Proof. *) -(* revert_until d. induction d; intros. *) -(* { unfold mem_delta_apply_wf in APPD. ss. clarify. } *) -(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs; clarify; eauto. *) -(* exploit mem_delta_apply_wf_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. *) -(* eapply IHd; clear IHd. 2: eauto. *) -(* unfold public_rev_perm in *. intros. specialize (PRP b). des_ifs. intros. *) -(* eapply PRP. unfold wf_mem_delta_kind_b in Heq. des_ifs. ss. unfold mem_delta_apply_storev in STORE. des_ifs. *) -(* destruct v0; ss. eapply Mem.perm_store_2; eauto. *) -(* Qed. *) - -(* Lemma mem_perm_any_to_nonempty *) -(* m b ofs k p *) -(* (PERM: Mem.perm m b ofs k p) *) -(* : *) -(* Mem.perm m b ofs k Nonempty. *) -(* Proof. *) -(* unfold Mem.perm in *. remember ((Mem.mem_access m) !! b ofs k) as k'. clear - PERM. destruct k'; ss. destruct p; ss; try constructor. *) -(* Qed. *) - -(* Lemma loc_first_order_memval_inject_preserves *) -(* (ge: Senv.t) m m' b ofs *) -(* (LFO: loc_first_order m b ofs) *) -(* (MVINJ: memval_inject (meminj_public ge) (ZMap.get ofs (Mem.mem_contents m) !! b) (ZMap.get ofs (Mem.mem_contents m') !! b)) *) -(* : *) -(* loc_first_order m' b ofs. *) -(* Proof. *) -(* unfold loc_first_order in *. remember (ZMap.get ofs (Mem.mem_contents m) !! b) as mv1. remember (ZMap.get ofs (Mem.mem_contents m') !! b) as mv2. *) -(* clear - LFO MVINJ. inv MVINJ; ss. *) -(* Qed. *) - -(* Lemma visible_fo_mem_inj *) -(* (ge: Senv.t) m tys args *) -(* (VFO: visible_fo ge m tys args) *) -(* m' *) -(* (MEMINJ: Mem.inject (meminj_public ge) m m') *) -(* (PRP: public_rev_perm ge m m') *) -(* : *) -(* visible_fo ge m' tys args. *) -(* Proof. *) -(* destruct VFO as [PFO VP]. split; auto. clear VP. clear - PFO MEMINJ PRP. *) -(* unfold public_first_order in *. intros. specialize (PRP b). unfold meminj_public in PRP. *) -(* exploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV, PUBLIC in PRP. *) -(* specialize (PRP ofs). rewrite Z.add_0_r in PRP. exploit PFO; eauto. intros LFO. *) -(* inv MEMINJ. inv mi_inj. exploit mi_memval. *) -(* { unfold meminj_public. rewrite INV, PUBLIC. eauto. } *) -(* { eauto. } *) -(* intros MVINJ. clear - LFO MVINJ. rewrite Z.add_0_r in MVINJ. eapply loc_first_order_memval_inject_preserves; eauto. *) -(* Qed. *) - -(* Lemma external_call_unknowns_mem_inj *) -(* (ge: Senv.t) m ef args *) -(* (ECC: external_call_unknowns ef ge m args) *) -(* m' *) -(* (MEMINJ: Mem.inject (meminj_public ge) m m') *) -(* (PRP: public_rev_perm ge m m') *) -(* : *) -(* external_call_unknowns ef ge m' args. *) -(* Proof. *) -(* unfold external_call_unknowns in *. des_ifs; eapply visible_fo_mem_inj; eauto. *) -(* Qed. *) - -(* Lemma match_mem_external_call_establish1 *) -(* (ge: genv) cp k d m_a0 m_i m *) -(* (MEM: match_mem ge cp k d m_a0 m_i m) *) -(* ef args t res m' *) -(* (EXTCALL: external_call ef ge args m t res m') *) -(* (ECC: external_call_unknowns ef ge m args) *) -(* : *) -(* exists m1 m2 res', *) -(* (mem_delta_apply_wf ge cp d (Some m_i) = Some m1) /\ *) -(* (external_call ef ge args m1 t res' m2) /\ *) -(* (external_call_unknowns ef ge m1 args) /\ *) -(* (exists k2, match_mem ge cp k2 [] m' m2 m' /\ Val.inject k2 res res') *) -(* . *) -(* Proof. *) -(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* (* reestablish meminj *) *) -(* exploit mem_delta_apply_establish_inject; eauto. *) -(* (* { apply meminj_public_strict. } *) *) -(* { eapply external_call_unknowns_fo. eauto. } *) -(* intros (m_i' & APPD' & MEMINJ'). *) -(* hexploit ec_mem_inject. eapply external_call_spec. 2: eapply EXTCALL. all: eauto. *) -(* (* hexploit external_call_mem_inject. 2: eapply EXTCALL. all: eauto. *) *) -(* { instantiate (1:=ge). apply symbols_inject_meminj_public. } *) -(* { instantiate (1:=args). eapply external_call_unknowns_val_inject_list; eauto. } *) -(* intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). *) -(* assert (MM': match_mem ge cp f' [] m' m_i'' m'). *) -(* { unfold match_mem. simpl. *) -(* assert (PNF: public_not_freeable ge m'). *) -(* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. *) -(* clear - EXTCALL MEM3 NALLOC. unfold public_not_freeable in *. intros. *) -(* specialize (MEM3 _ H). intros CC. apply (MEM3 ofs); clear MEM3. *) -(* eapply external_call_max_perm; eauto. unfold Mem.valid_block. *) -(* unfold meminj_not_alloc in NALLOC. unfold Plt. *) -(* destruct (Pos.ltb_spec b (Mem.nextblock m)); auto. *) -(* specialize (NALLOC _ H0). congruence. *) -(* } *) -(* pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. *) -(* assert (MNA: meminj_not_alloc (meminj_public ge) m'). *) -(* { clear - EXTCALL NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) -(* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b EXTCALL). *) -(* destruct (Pos.leb_spec (Mem.nextblock m) b); auto. *) -(* unfold Mem.valid_block in H0. apply H0 in H1. exfalso. unfold Plt in H1. lia. *) -(* } *) -(* splits; auto. *) -(* { constructor. } *) -(* { hexploit public_rev_perm_delta_apply_inj; eauto. intros PRP2. clear - MEM3 PRP2 EXTCALL EXTCALL' PNF NALLOC MEMINJ' MEMINJ'' INCRINJ'. *) -(* unfold public_rev_perm in *. intros. specialize (PRP2 b). des_ifs. intros. *) -(* hexploit Mem.perm_inject_inv. eapply MEMINJ''. eapply INCRINJ'. eapply Heq. eauto. intros [PERM | PERM]; auto. *) -(* pose proof Heq as PUB. unfold meminj_public in PUB. des_ifs. *) -(* assert (VB: Mem.valid_block m b0). *) -(* { unfold meminj_not_alloc in NALLOC. unfold Mem.valid_block. destruct (Pos.ltb_spec b0 (Mem.nextblock m)); auto. exfalso. *) -(* exploit NALLOC; eauto. intros. clarify. *) -(* } *) -(* exfalso. apply PERM. eapply external_call_public_not_freeable; eauto. *) -(* { eapply PRP2. eapply external_call_max_perm. eauto. *) -(* { eapply Mem.valid_block_inject_2; eauto. } *) -(* eapply Mem.perm_max. eapply mem_perm_any_to_nonempty. eauto. *) -(* } *) -(* { unfold public_not_freeable in MEM3. eapply MEM3. rewrite Heq. congruence. } *) -(* } *) -(* } *) -(* exists m_i', m_i'', vres'. splits; eauto. *) -(* { assert (PRP: public_rev_perm ge m m_i'). *) -(* { eapply public_rev_perm_delta_apply_inj; eauto. } *) -(* clear - ECC MEMINJ' PRP. eapply external_call_unknowns_mem_inj; eauto. *) -(* } *) -(* Qed. *) - - -(* Lemma asm_to_ir_returnstate_nccc_internal *) -(* cpm (ge: genv) n n0 *) -(* (LT: (n0 < n)%nat) *) -(* (IH: forall y : nat, *) -(* (y < n)%nat -> *) -(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) -(* wf_ge ge -> *) -(* wf_asm ge ast -> *) -(* star_measure (step_fix cpm) ge y ast tr ast' -> *) -(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) -(* match_state ge k m_a0 d ast ist -> *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) -(* (WFGE: wf_ge ge) *) -(* cur ik *) -(* (WFIR0 : wf_ir_cur ge cur) *) -(* (WFIR1 : wf_ir_conts ge ik) *) -(* st (rs: regset) *) -(* (WFASM1: wf_stack ge st) *) -(* (MTST0 : match_cur_stack_sig cur ge st) *) -(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) -(* (MTST2 : match_stack ge ik st) *) -(* k d m_a0 m_i m_a *) -(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) -(* t' ast' *) -(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) -(* t'' ast'' *) -(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) -(* (NCCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) <> Genv.CrossCompartmentCall) *) -(* b1 ofs1 *) -(* (NEXTPC: rs PC = Vptr b1 ofs1) *) -(* f *) -(* (NEXTF : Genv.find_funct_ptr ge b1 = Some (Internal f)) *) -(* : *) -(* exists (btr : bundle_trace) (ist' : ir_state), *) -(* unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) -(* Proof. *) -(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* (** step --- ReturnState *) *) -(* inv STEP. inv EV; simpl in *. *) -(* 2:{ rewrite H in NCCC. congruence with NCCC. } *) -(* (** return is nccc *) *) -(* clear H. pose proof STAR as STAR0. inv STAR. *) -(* (* end case *) *) -(* { end_case. } *) -(* (* has next step - internal -> done*) *) -(* rename H into STEP, H0 into STAR. *) -(* (** next is internal *) *) -(* exploit IH; clear IH. 4: eapply STAR0. lia. all: auto. *) -(* { simpl. split. *) -(* - unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. *) -(* - unfold wf_regset in *. rewrite NEXTPC, NEXTF. auto. *) -(* } *) -(* { instantiate (4:=k). instantiate (3:=m_a0). instantiate (2:=d). instantiate (1:=Some (cur, m_i, ik)). *) -(* assert (st' = st). *) -(* { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) -(* subst st'. simpl. split; auto. split; auto. split; auto. split. *) -(* { unfold match_cur_regset in *. rewrite CURCOMP. unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. auto. } *) -(* split; auto. *) -(* { unfold match_mem. splits; auto. } *) -(* } *) -(* intros (btr & ist' & UTR & ISTAR'). *) -(* exists btr, ist'. split; auto. *) -(* Qed. *) - -(* Lemma match_mem_external_call_establish2 *) -(* ge cp k d m_a0 m_i m *) -(* (MEM: match_mem ge cp k d m_a0 m_i m) *) -(* ef args t res m' *) -(* (EXTCALL: external_call ef ge args m t res m') *) -(* (ECKO: external_call_known_observables ef ge m args t res m') *) -(* : *) -(* (external_call ef ge args m_i t res m_i) /\ *) -(* (external_call_known_observables ef ge m_i args t res m_i) /\ *) -(* (match_mem ge cp k d m_a0 m_i m') *) -(* . *) -(* Proof. *) -(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* unfold external_call_known_observables in ECKO. *) -(* des_ifs; simpl in *. *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. *) -(* 1,2: econs; econs; eauto. unfold match_mem. splits; auto. *) -(* } *) -(* { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. *) -(* 1,2: econs; econs; eauto. unfold match_mem. splits; auto. *) -(* } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. esplits; eauto. *) -(* 1,2: econs; eauto. unfold match_mem. splits; auto. *) -(* } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. esplits; eauto. *) -(* 1,2: econs; eauto. unfold match_mem. splits; auto. *) -(* } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) -(* Qed. *) - -(* Lemma match_mem_external_call_establish *) -(* (ge: genv) cp k d m_a0 m_i m *) -(* (MEM: match_mem ge cp k d m_a0 m_i m) *) -(* ef args t res m' *) -(* (EXTCALL: external_call ef ge args m t res m') *) -(* (ECC: external_call_unknowns ef ge m args \/ external_call_known_observables ef ge m args t res m') *) -(* : *) -(* exists d' m1 m2 res', *) -(* (mem_delta_apply_wf ge cp d' (Some m_i) = Some m1) /\ *) -(* (external_call ef ge args m1 t res' m2) /\ *) -(* ((external_call_unknowns ef ge m1 args) \/ (external_call_known_observables ef ge m1 args t res' m2 /\ d' = [])) /\ *) -(* (exists k2 d2 m_a02, match_mem ge cp k2 d2 m_a02 m2 m' /\ (Val.inject k2 res res' \/ (res = res'))) *) -(* . *) -(* Proof. *) -(* destruct ECC as [ECC | ECC]. *) -(* - exploit match_mem_external_call_establish1; eauto. intros. des. esplits; eauto. *) -(* - exploit match_mem_external_call_establish2; eauto. intros. des. esplits; eauto. ss. *) -(* Qed. *) - -(* Lemma asm_to_ir_step_external *) -(* cpm (ge: genv) *) -(* (WFGE: wf_ge ge) *) -(* cur ik *) -(* (WFIR0 : wf_ir_cur ge cur) *) -(* (WFIR1 : wf_ir_conts ge ik) *) -(* st (rs: regset) *) -(* (WFASM1: wf_stack ge st) *) -(* (MTST0 : match_cur_stack_sig cur ge st) *) -(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) -(* (MTST2 : match_stack ge ik st) *) -(* k d m_a0 m_i m_a *) -(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) -(* t ast' *) -(* (STEP: step_fix cpm ge (State st rs m_a) t ast') *) -(* b1 ofs1 *) -(* (NEXTPC: rs PC = Vptr b1 ofs1) *) -(* ef *) -(* (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) *) -(* n t' ast'' *) -(* (STAR: star_measure (step_fix cpm) ge n ast' t' ast'') *) -(* : *) -(* exists (btr : bundle_trace) k' d' m_a0' m_i' m_a', *) -(* (unbundle_trace btr = t) /\ *) -(* (istar ir_step ge (Some (cur, m_i, ik)) btr (Some (cur, m_i', ik))) /\ *) -(* (match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m_a') /\ *) -(* (exists res, star_measure (step_fix cpm) ge n *) -(* (ReturnState st (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) # PC <- (rs X1) m_a') t' ast''). *) -(* Proof. *) -(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). *) -(* { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. *) -(* des_ifs. eapply wf_ge_block_to_id; eauto. *) -(* } *) -(* des. rename H into IDCUR. *) -(* (* take a step *) *) -(* inv STEP. *) -(* (* invalid *) *) -(* 1,2,3,4: rewrite NEXTPC in H2; inv H2; rewrite NEXTF in H3; inv H3. *) -(* rewrite NEXTPC in H2; inv H2; rewrite NEXTF in H3; inv H3. *) -(* exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF). *) -(* exploit wf_ge_block_to_id; eauto. intros (ef_id & INVSYMB). *) -(* exploit Genv.invert_find_symbol. eapply INVSYMB. intros FINDSYMB. clear TEMP. *) -(* exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. *) - -(* - (* extcall is unknown *) *) -(* exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. *) -(* intros. des. *) -(* exists ([(id_cur, Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (d))]). *) -(* do 5 eexists. splits; simpl. 3: eapply x3. apply app_nil_r. *) -(* 2:{ exists res. auto. } *) -(* econstructor 2. 2: econstructor 1. 2: eauto. *) -(* eapply ir_step_intra_call_external; eauto. *) -(* { unfold Genv.type_of_call in *. rewrite CURCOMP, <- REC_CURCOMP. rewrite NEXTPC. simpl. *) -(* unfold Genv.find_comp. setoid_rewrite NEXTF. rewrite Pos.eqb_refl. auto. *) -(* } *) - -(* - (* extcall is known and observable *) *) -(* rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_observables in ECKO. *) -(* des_ifs; simpl in *. *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) -(* exists ([(id_cur, Bundle_call [Event_vload chunk id ofs ev] ef_id [EVptr_global id ofs] {| sig_args := [Tptr]; sig_res := rettype_of_chunk chunk; sig_cc := cc_default |} ([]))]). *) -(* exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. *) -(* econstructor 2. 2: econstructor 1. 2: auto. *) -(* eapply ir_step_intra_call_external. all: eauto. *) -(* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) -(* { ss. } *) -(* { simpl. econstructor. econstructor 1; eauto. } *) -(* { simpl. right. split; auto. econs; eauto. econs. econs; eauto. } *) -(* { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } *) -(* splits; auto. *) -(* } *) -(* { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. *) -(* exists ([(id_cur, Bundle_call [Event_vstore chunk id ofs ev] ef_id [EVptr_global id ofs; ev] {| sig_args := [Tptr; type_of_chunk chunk]; sig_res := Tvoid; sig_cc := cc_default |} ([]))]). *) -(* exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. *) -(* econstructor 2. 2: econstructor 1. 2: auto. *) -(* eapply ir_step_intra_call_external. all: eauto. *) -(* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) -(* { ss. } *) -(* { instantiate (2:=[Vptr b0 ofs; Val.load_result chunk v]). *) -(* simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. *) -(* } *) -(* { simpl. right. split; auto. *) -(* splits; ss; auto. econs; eauto. econs; eauto. rewrite val_load_result_idem. auto. des. *) -(* unfold load_whole_chunk in *. rewrite val_load_result_idem. auto. *) -(* } *) -(* { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. *) -(* f_equal. erewrite eventval_match_val_to_eventval; eauto. *) -(* } *) -(* splits; auto. *) -(* } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. *) -(* exists ([(id_cur, Bundle_call [Event_annot text args0] ef_id (vals_to_eventvals ge args) {| sig_args := targs; sig_res := Tvoid; sig_cc := cc_default |} ([]))]). *) -(* exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. *) -(* econstructor 2. 2: econstructor 1. 2: auto. *) -(* eapply ir_step_intra_call_external. all: eauto. *) -(* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) -(* { ss. } *) -(* { simpl. econstructor. auto. } *) -(* { simpl. right. split; auto. econs; eauto. econs. auto. } *) -(* splits; auto. *) -(* } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. *) -(* exists ([(id_cur, Bundle_call [Event_annot text [arg]] ef_id [val_to_eventval ge res] {| sig_args := [targ]; sig_res := targ; sig_cc := cc_default |} ([]))]). *) -(* exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. *) -(* econstructor 2. 2: econstructor 1. 2: auto. *) -(* eapply ir_step_intra_call_external. all: eauto. *) -(* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) -(* { ss. } *) -(* { simpl. econstructor. eauto. } *) -(* { simpl. right. split; auto. econs; eauto. econs. auto. } *) -(* { simpl. auto. } *) -(* splits; auto. *) -(* } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) - -(* - (* extcall is known and silent *) *) -(* rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_silents in ECKS. *) -(* des_ifs; ss; clarify. *) -(* { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. *) -(* exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. *) -(* } *) -(* { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. *) -(* exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. *) -(* } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) -(* exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. *) -(* } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) -(* exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs, v, cp)]), m_a0, m_i, m'. simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. *) -(* { eapply public_not_freeable_store; eauto. } *) -(* { setoid_rewrite Forall_app. split; auto. econs; auto. ss. *) -(* rewrite CURCOMP. rewrite <- REC_CURCOMP. rewrite NEXTPC. ss. unfold Genv.find_comp. setoid_rewrite NEXTF. ss. *) -(* } *) -(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) -(* { eapply public_rev_perm_store; eauto. } *) -(* } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) -(* exists [], k, (d ++ [mem_delta_kind_alloc (cp, (- size_chunk Mptr), (Ptrofs.unsigned sz)); mem_delta_kind_store (Mptr, b0, (- size_chunk Mptr), (Vptrofs sz), cp)]), m_a0, m_i, m'. *) -(* simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. *) -(* { eapply public_not_freeable_store. 2: eauto. eapply public_not_freeable_alloc. *) -(* 3: eauto. all: auto. *) -(* eapply meminj_not_alloc_delta; eauto. *) -(* } *) -(* { setoid_rewrite Forall_app. split; auto. econs; auto. *) -(* { simpl. auto. } *) -(* econs; auto. simpl. hexploit Mem.alloc_result; eauto. hexploit meminj_not_alloc_delta; eauto. *) -(* intros. apply H1. lia. *) -(* } *) -(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. rewrite H. simpl. auto. } *) -(* { eapply public_rev_perm_store. 2: eauto. eapply public_rev_perm_alloc. *) -(* 2: eauto. all: auto. *) -(* } *) -(* } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) -(* - exists [], k, (d ++ [mem_delta_kind_free (b0, (Ptrofs.unsigned lo - size_chunk Mptr)%Z, (Ptrofs.unsigned lo + Ptrofs.unsigned sz)%Z, cp)]), m_a0, m_i, m'. *) -(* simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. *) -(* { eapply public_not_freeable_free; eauto. } *) -(* { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. *) -(* eapply public_not_freeable_free_inj_none; eauto. *) -(* { unfold size_chunk. unfold Mptr. des_ifs; lia. } *) -(* } *) -(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) -(* { eapply public_rev_perm_free; eauto. } *) -(* - exists [], k, d, m_a0, m_i, m'. *) -(* simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. *) -(* } *) -(* { destruct ECKS as [_ [OBS NPUB]]. inv EXTCALL. *) -(* exists [], k, (d ++ [mem_delta_kind_bytes (bdst, (Ptrofs.unsigned odst), bytes, cp)]), m_a0, m_i, m'. *) -(* simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. *) -(* { eapply public_not_freeable_bytes; eauto. } *) -(* { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. *) -(* clear - NPUB. simpl in NPUB. unfold meminj_public. des_ifs. exfalso. apply NPUB. *) -(* exists i. auto. *) -(* } *) -(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) -(* { eapply public_rev_perm_bytes; eauto. } *) -(* } *) - -(* { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) -(* exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. *) -(* } *) - -(* Qed. *) - -(* Lemma asm_to_ir_builtin *) -(* (ge: genv) *) -(* m_a0 *) -(* (WFGE: wf_ge ge) *) -(* rs m st *) -(* (WFASM: wf_asm ge (State st rs m)) *) -(* cur m_i ik k d *) -(* (MTST: match_state ge k m_a0 d (State st rs m) (Some (cur, m_i, ik))) *) -(* t1 ef vres m' b ofs f vargs *) -(* (CURPC: rs PC = Vptr b ofs) *) -(* (CURF: Genv.find_funct_ptr ge b = Some (Internal f)) *) -(* (EXTCALL: external_call ef ge vargs m t1 vres m') *) -(* (ALLOWED: comp_of ef = comp_of f) *) -(* (ECC: external_call_conds ef ge m vargs) *) -(* : *) -(* exists (btr : bundle_trace) k' d' m_a0' m_i', *) -(* (unbundle_trace btr = t1) /\ *) -(* (istar ir_step ge (Some (cur, m_i, ik)) btr (Some (cur, m_i', ik))) /\ *) -(* (match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m'). *) -(* Proof. *) -(* ss. destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). *) -(* destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* destruct WFASM as [WFASM0 WFASM1]. *) -(* assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). *) -(* { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. *) -(* des_ifs. eapply wf_ge_block_to_id; eauto. *) -(* } *) -(* des. rename H into IDCUR. *) -(* exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. *) - -(* - (* extcall is unknown *) *) -(* exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. *) -(* intros. des. *) -(* exists ([(id_cur, Bundle_builtin t1 ef (vals_to_eventvals ge vargs) d)]). *) -(* do 4 eexists. splits; simpl. 3: eapply x3. apply app_nil_r. *) -(* econstructor 2. 2: econstructor 1. 2: eauto. *) -(* eapply ir_step_builtin; eauto. *) -(* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) -(* setoid_rewrite CURF. ss. *) -(* } *) - -(* - (* extcall is known and observable *) *) -(* unfold external_call_known_observables in ECKO. *) -(* des_ifs; simpl in *. *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) -(* exists ([(id_cur, Bundle_builtin [Event_vload chunk id ofs0 ev] (EF_vload cp chunk) [EVptr_global id ofs0] [])]). *) -(* exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. *) -(* econstructor 2. 2: econstructor 1. 2: auto. *) -(* eapply ir_step_builtin. all: eauto. *) -(* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) -(* setoid_rewrite CURF. ss. *) -(* } *) -(* { ss. } *) -(* { simpl. econstructor. econstructor 1; eauto. } *) -(* { simpl. right. split; auto. econs; eauto. econs. econs; eauto. } *) -(* { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } *) -(* splits; auto. *) -(* } *) -(* { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. *) -(* exists ([(id_cur, Bundle_builtin [Event_vstore chunk id ofs0 ev] (EF_vstore cp chunk) [EVptr_global id ofs0; ev] [])]). *) -(* exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. *) -(* econstructor 2. 2: econstructor 1. 2: auto. *) -(* eapply ir_step_builtin. all: eauto. *) -(* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) -(* setoid_rewrite CURF. ss. *) -(* } *) -(* { ss. } *) -(* { instantiate (2:=[Vptr b0 ofs0; Val.load_result chunk v]). *) -(* simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. *) -(* } *) -(* { simpl. right. split; auto. splits; eauto. econs. econs; eauto. rewrite val_load_result_idem. auto. *) -(* unfold load_whole_chunk in *. rewrite val_load_result_idem. auto. *) -(* } *) -(* { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. *) -(* f_equal. erewrite eventval_match_val_to_eventval; eauto. *) -(* } *) -(* splits; auto. *) -(* } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. *) -(* exists ([(id_cur, Bundle_builtin [Event_annot text args] (EF_annot cp kind text targs) (vals_to_eventvals ge vargs) [])]). *) -(* exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. *) -(* econstructor 2. 2: econstructor 1. 2: auto. *) -(* eapply ir_step_builtin. all: eauto. *) -(* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) -(* setoid_rewrite CURF. ss. *) -(* } *) -(* { ss. } *) -(* { simpl. econstructor. auto. } *) -(* { simpl. right. split; auto. econs; eauto. econs. auto. } *) -(* splits; auto. *) -(* } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. *) -(* exists ([(id_cur, Bundle_builtin [Event_annot text [arg]] (EF_annot_val cp kind text targ) [val_to_eventval ge vres] [])]). *) -(* exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. *) -(* econstructor 2. 2: econstructor 1. 2: auto. *) -(* eapply ir_step_builtin. all: eauto. *) -(* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) -(* setoid_rewrite CURF. ss. *) -(* } *) -(* { ss. } *) -(* { simpl. econstructor. eauto. } *) -(* { simpl. right. split; auto. econs; eauto. econs. auto. } *) -(* { simpl. auto. } *) -(* splits; auto. *) -(* } *) -(* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) - -(* - (* extcall is known and silent *) *) -(* unfold external_call_known_silents in ECKS. des_ifs; ss; clarify. *) -(* { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. *) -(* exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. *) -(* } *) -(* { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. *) -(* exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. *) -(* } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) -(* exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. *) -(* } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. *) -(* exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs0, v, cp)]), m_a0, m_i. simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. *) -(* { eapply public_not_freeable_store; eauto. } *) -(* { setoid_rewrite Forall_app. split; auto. econs; auto. ss. *) -(* rewrite MTST1. rewrite CURPC. ss. unfold Genv.find_comp. setoid_rewrite CURF. auto. *) -(* } *) -(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) -(* { eapply public_rev_perm_store; eauto. } *) -(* } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) -(* exists [], k, (d ++ [mem_delta_kind_alloc (cp, (- size_chunk Mptr), (Ptrofs.unsigned sz)); mem_delta_kind_store (Mptr, b0, (- size_chunk Mptr), (Vptrofs sz), cp)]), m_a0, m_i. *) -(* simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. *) -(* { eapply public_not_freeable_store. 2: eauto. eapply public_not_freeable_alloc. *) -(* 3: eauto. all: auto. *) -(* eapply meminj_not_alloc_delta; eauto. *) -(* } *) -(* { setoid_rewrite Forall_app. split; auto. econs; auto. *) -(* { simpl. auto. } *) -(* econs; auto. simpl. hexploit Mem.alloc_result; eauto. hexploit meminj_not_alloc_delta; eauto. *) -(* intros. apply H1. lia. *) -(* } *) -(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. rewrite H. simpl. auto. } *) -(* { eapply public_rev_perm_store. 2: eauto. eapply public_rev_perm_alloc. *) -(* 2: eauto. all: auto. *) -(* } *) -(* } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) -(* - exists [], k, (d ++ [mem_delta_kind_free (b0, (Ptrofs.unsigned lo - size_chunk Mptr)%Z, (Ptrofs.unsigned lo + Ptrofs.unsigned sz)%Z, cp)]), m_a0, m_i. *) -(* simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. *) -(* { eapply public_not_freeable_free; eauto. } *) -(* { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. *) -(* eapply public_not_freeable_free_inj_none; eauto. *) -(* { unfold size_chunk. unfold Mptr. des_ifs; lia. } *) -(* } *) -(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) -(* { eapply public_rev_perm_free; eauto. } *) -(* - exists [], k, d, m_a0, m_i. *) -(* simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. *) -(* } *) -(* { destruct ECKS as [_ [OBS NPUB]]. inv EXTCALL. *) -(* exists [], k, (d ++ [mem_delta_kind_bytes (bdst, (Ptrofs.unsigned odst), bytes, cp)]), m_a0, m_i. *) -(* simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. *) -(* { eapply public_not_freeable_bytes; eauto. } *) -(* { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. *) -(* clear - NPUB. simpl in NPUB. unfold meminj_public. des_ifs. exfalso. apply NPUB. *) -(* exists i. auto. *) -(* } *) -(* { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } *) -(* { eapply public_rev_perm_bytes; eauto. } *) -(* } *) - -(* { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } *) -(* { destruct ECKS as [_ OBS]. inv EXTCALL. *) -(* exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. *) -(* } *) - -(* Qed. *) - - -(* Lemma asm_to_ir_returnstate_undef_nccc_external *) -(* cpm (ge: genv) n n0 *) -(* (LT: (n0 < n)%nat) *) -(* (IH: forall y : nat, *) -(* (y < n)%nat -> *) -(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) -(* wf_ge ge -> *) -(* wf_asm ge ast -> *) -(* star_measure (step_fix cpm) ge y ast tr ast' -> *) -(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) -(* match_state ge k m_a0 d ast ist -> *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) -(* (WFGE: wf_ge ge) *) -(* cur ik *) -(* (WFIR0 : wf_ir_cur ge cur) *) -(* (WFIR1 : wf_ir_conts ge ik) *) -(* st (rs: regset) *) -(* (WFASM1: wf_stack ge st) *) -(* (MTST0 : match_cur_stack_sig cur ge st) *) -(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) -(* (MTST2 : match_stack ge ik st) *) -(* k d m_a0 m_i m_a *) -(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) -(* (RSX: rs X1 = Vundef) *) -(* t' ast' *) -(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) -(* t'' ast'' *) -(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) -(* (NCCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) <> Genv.CrossCompartmentCall) *) -(* b1 ofs1 *) -(* (NEXTPC: rs PC = Vptr b1 ofs1) *) -(* ef *) -(* (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) *) -(* : *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) -(* Proof. *) -(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* (** step --- ReturnState *) *) -(* inv STEP. inv EV; simpl in *. *) -(* 2:{ rewrite H in NCCC. congruence with NCCC. } *) -(* (** return is nccc *) *) -(* clear H. pose proof STAR as STAR0. inv STAR. *) -(* (* end case *) *) -(* { end_case. } *) -(* (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) *) -(* (* take a step *) *) -(* rename H into STEP, H0 into STAR. *) - -(* assert (st' = st). *) -(* { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) -(* subst st'. *) -(* exploit asm_to_ir_step_external. *) -(* 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. *) -(* all: eauto. *) -(* { rr; splits; eauto. } *) -(* clear STEP STAR. *) -(* intros (btr1 & k' & d' & m_a0' & m_i' & m_a' & UTR1 & ISTAR1 & MM' & (res & STAR)). *) -(* eapply asm_to_ir_compose. 2: eauto. do 2 eexists. split; eauto. clear btr1 UTR1 ISTAR1. *) - -(* assert (STUCK: (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) *) -(* # PC <- (rs X1) PC = Vundef). *) -(* { rewrite Pregmap.gss. auto. } *) -(* inv STAR. *) -(* (* end case *) *) -(* { exists []. eexists. split; auto. econstructor 1. } *) -(* (* now at Returnstate *) *) -(* inv H; simpl in *. rewrite Pregmap.gss in *. inv H0. *) -(* (* end case *) *) -(* { inv EV. *) -(* (* return is NCCC - silent *) *) -(* { exists []. simpl. eexists. split; auto. econstructor 1. } *) -(* (* return is CCC - return event *) *) -(* { unfold Genv.type_of_call in H. des_ifs. unfold update_stack_return in STUPD0. *) -(* clear H. rewrite Pregmap.gss in *. *) -(* rewrite Pos.eqb_sym in Heq. rewrite Heq in STUPD0. des_ifs. *) -(* pose proof Heq as NEQ. eapply Pos.eqb_neq in NEQ. specialize (PC_RA0 NEQ). *) -(* (* stuck --- return PC is Vundef *) *) -(* rewrite STUCK in PC_RA0. clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. *) -(* } *) -(* } *) -(* (* stuck case *) *) -(* inv H; simpl in *; rewrite Pregmap.gss in *; rewrite STUCK in H5; inv H5. *) -(* Qed. *) - -(* Lemma asm_to_ir_returnstate_ccc *) -(* cpm (ge: genv) n n0 *) -(* (LT: (n0 < n)%nat) *) -(* (IH: forall y : nat, *) -(* (y < n)%nat -> *) -(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) -(* wf_ge ge -> *) -(* wf_asm ge ast -> *) -(* star_measure (step_fix cpm) ge y ast tr ast' -> *) -(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) -(* match_state ge k m_a0 d ast ist -> *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) -(* (WFGE: wf_ge ge) *) -(* cur ik *) -(* (WFIR0 : wf_ir_cur ge cur) *) -(* (WFIR1 : wf_ir_conts ge ik) *) -(* st (rs: regset) *) -(* (WFASM1: wf_stack ge st) *) -(* (MTST0 : match_cur_stack_sig cur ge st) *) -(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) -(* (MTST2 : match_stack ge ik st) *) -(* k d m_a0 m_i m_a *) -(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) -(* t' ast' *) -(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) -(* t'' ast'' *) -(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) -(* (CCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) = Genv.CrossCompartmentCall) *) -(* : *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) -(* Proof. *) -(* assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). *) -(* { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. *) -(* des_ifs. eapply wf_ge_block_to_id; eauto. *) -(* } *) -(* des. rename H into IDCUR. *) -(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* (** step --- ReturnState *) *) -(* inv STEP. inv EV; simpl in *. *) -(* { rewrite CCC in H. congruence with H. } *) -(* clear H. specialize (CHECKPUB CCC). *) -(* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) -(* unfold Genv.type_of_call in CCC. des_ifs. clear CCC. unfold update_stack_return in STUPD. *) -(* rewrite Pos.eqb_sym in Heq. rewrite Heq in STUPD. des_ifs. *) -(* pose proof Heq as NEQ. eapply Pos.eqb_neq in NEQ. specialize (PC_RA NEQ). *) -(* destruct s as [b3 cp3 sig3 rv3 ptr3]. simpl in *. *) -(* inv WFASM1. simpl in *. des_ifs. clear H2. inv MTST2. *) -(* hexploit mem_delta_apply_establish_inject. eapply MEM0. 1,2,3,4: eauto. *) -(* { clear - CHECKPUB. ii. unfold public_first_order in CHECKPUB. unfold meminj_public in H. des_ifs. *) -(* eapply CHECKPUB; eauto. apply Senv.invert_find_symbol; auto. *) -(* } *) -(* intros (m_i' & APPD & MEMINJ). *) -(* exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. *) -(* { simpl. split; auto. unfold wf_regset. rewrite PC_RA. rewrite Heq0. auto. } *) -(* { instantiate (4:=(meminj_public ge)). instantiate (3:=m_a). instantiate (2:=[]). *) -(* instantiate (1:=Some (next, m_i', ik_tl)). simpl. splits; auto. *) -(* { inv WFIR1. simpl in *. auto. } *) -(* { inv WFIR1. auto. } *) -(* { unfold match_cur_regset. rewrite COMP. rewrite PC_RA. auto. } *) -(* { rr; splits; auto. eapply meminj_not_alloc_delta; eauto. ss. eapply public_rev_perm_delta_apply_inj; eauto. *) -(* } *) -(* } *) -(* intros (btr & ist' & UTR & ISTAR'). *) -(* exists ((id_cur, Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs PC)) (Genv.find_comp ge (Vptr cur Ptrofs.zero)) res] res d) :: btr), ist'. *) -(* simpl. rewrite UTR. split; auto. *) -(* econstructor 2. 2: eapply ISTAR'. 2: auto. *) -(* inv WFIR1. simpl in *. des_ifs. clear H2. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. *) -(* eapply ir_step_cross_return_internal. 6: eapply Heq1. all: eauto. *) -(* { rewrite COMP. rewrite PC_RA. simpl. auto. } *) -(* { constructor; auto. *) -(* { unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. } *) -(* { replace (funsig (Internal f2)) with sig3; auto. unfold match_cur_stack_sig in MTST0. des_ifs. } *) -(* } *) -(* { hexploit public_rev_perm_delta_apply_inj. eauto. eapply APPD. intros REVP. clear - MEMINJ CHECKPUB REVP. *) -(* unfold public_first_order in *. i. *) -(* exploit Senv.find_invert_symbol; eauto. intros INV. *) -(* assert (PERM: Mem.perm m_a b ofs Cur Readable). *) -(* { specialize (REVP b). unfold meminj_public in REVP. rewrite INV, PUBLIC in REVP. apply REVP. rewrite Z.add_0_r. auto. } *) -(* eapply loc_first_order_memval_inject_preserves. eapply CHECKPUB; eauto. *) -(* instantiate (1:=ge). inv MEMINJ. inv mi_inj. replace ofs with (ofs + 0)%Z at 2 by lia. eapply mi_memval; auto. *) -(* unfold meminj_public. rewrite INV, PUBLIC. auto. *) -(* } *) -(* Qed. *) - -(* Lemma asm_to_ir_returnstate_undef *) -(* cpm (ge: genv) n n0 *) -(* (LT: (n0 < n)%nat) *) -(* (IH: forall y : nat, *) -(* (y < n)%nat -> *) -(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) -(* wf_ge ge -> *) -(* wf_asm ge ast -> *) -(* star_measure (step_fix cpm) ge y ast tr ast' -> *) -(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) -(* match_state ge k m_a0 d ast ist -> *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) -(* (WFGE: wf_ge ge) *) -(* cur ik *) -(* (WFIR0 : wf_ir_cur ge cur) *) -(* (WFIR1 : wf_ir_conts ge ik) *) -(* st (rs: regset) *) -(* (WFASM1: wf_stack ge st) *) -(* (MTST0 : match_cur_stack_sig cur ge st) *) -(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) -(* (MTST2 : match_stack ge ik st) *) -(* k d m_a0 m_i m_a *) -(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) -(* (RSX: rs X1 = Vundef) *) -(* t' ast' *) -(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) -(* t'' ast'' *) -(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) -(* : *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) -(* Proof. *) -(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* (** step --- ReturnState *) *) -(* pose proof STEP as STEP0. inv STEP. inv EV; simpl in *. *) -(* (** return is nccc *) *) -(* { rename H into NCCC. pose proof STAR as STAR0. inv STAR. *) -(* (* end case *) *) -(* { end_case. } *) -(* (* has next step - if internal, done; if external, ub by RSX *) *) -(* rename H into STEP, H0 into STAR. exploit asm_step_current_pc. eapply STEP. intros (b1 & ofs1 & NEXTPC). *) -(* exploit asm_step_some_fundef. eapply STEP. eapply NEXTPC. intros (fd & NEXTF). *) -(* destruct fd. *) -(* (** next is internal *) *) -(* { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. *) -(* 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. *) -(* } *) -(* (** next is external --- undef *) *) -(* { exploit asm_to_ir_returnstate_undef_nccc_external. 2: eapply IH. *) -(* 12: eapply STAR0. 11: eapply STEP0. all: eauto. rr; splits; eauto. *) -(* } *) -(* } *) -(* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) -(* { exploit asm_to_ir_returnstate_ccc. 2: eapply IH. *) -(* 11: eapply STAR. 10: eapply STEP0. all: eauto. rr; splits; eauto. *) -(* } *) -(* Qed. *) - -(* Lemma asm_to_ir_returnstate_nccc_external *) -(* cpm (ge: genv) n n0 *) -(* (LT: (n0 < n)%nat) *) -(* (IH: forall y : nat, *) -(* (y < n)%nat -> *) -(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) -(* wf_ge ge -> *) -(* wf_asm ge ast -> *) -(* star_measure (step_fix cpm) ge y ast tr ast' -> *) -(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) -(* match_state ge k m_a0 d ast ist -> *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) -(* (WFGE: wf_ge ge) *) -(* cur ik *) -(* (WFIR0 : wf_ir_cur ge cur) *) -(* (WFIR1 : wf_ir_conts ge ik) *) -(* st (rs: regset) *) -(* (WFASM1: wf_stack ge st) *) -(* (MTST0 : match_cur_stack_sig cur ge st) *) -(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) -(* (MTST2 : match_stack ge ik st) *) -(* k d m_a0 m_i m_a *) -(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) -(* t' ast' *) -(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) -(* t'' ast'' *) -(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) -(* (NCCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) <> Genv.CrossCompartmentCall) *) -(* b1 ofs1 *) -(* (NEXTPC: rs PC = Vptr b1 ofs1) *) -(* ef *) -(* (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) *) -(* : *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) -(* Proof. *) -(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* (** step --- ReturnState *) *) -(* inv STEP. inv EV; simpl in *. *) -(* 2:{ rewrite H in NCCC. congruence with NCCC. } *) -(* (** return is nccc *) *) -(* clear H. pose proof STAR as STAR0. inv STAR. *) -(* (* end case *) *) -(* { end_case. } *) -(* (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) *) -(* (* take a step *) *) -(* rename H into STEP, H0 into STAR. *) - -(* assert (st' = st). *) -(* { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) -(* subst st'. *) -(* exploit asm_to_ir_step_external. *) -(* 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. *) -(* all: eauto. *) -(* { rr; splits; eauto. } *) -(* clear STEP STAR. *) -(* intros (btr1 & k' & d' & m_a0' & m_i' & m_a' & UTR1 & ISTAR1 & MM' & (res & STAR)). *) -(* eapply asm_to_ir_compose. 2: eauto. do 2 eexists. split; eauto. clear btr1 UTR1 ISTAR1. *) - -(* inv STAR. *) -(* (* end case *) *) -(* { exists []. eexists. split; auto. econstructor 1. } *) -(* (* now at Returnstate *) *) -(* eapply asm_to_ir_returnstate_undef. 2: eapply IH. 12: eapply H0. 11: eapply H. *) -(* all: eauto. lia. *) -(* { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } *) -(* Qed. *) - -(* Lemma asm_to_ir_returnstate *) -(* cpm (ge: genv) n n0 *) -(* (LT: (n0 < n)%nat) *) -(* (IH: forall y : nat, *) -(* (y < n)%nat -> *) -(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) -(* wf_ge ge -> *) -(* wf_asm ge ast -> *) -(* star_measure (step_fix cpm) ge y ast tr ast' -> *) -(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) -(* match_state ge k m_a0 d ast ist -> *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) -(* (WFGE: wf_ge ge) *) -(* cur ik *) -(* (WFIR0 : wf_ir_cur ge cur) *) -(* (WFIR1 : wf_ir_conts ge ik) *) -(* st (rs: regset) *) -(* (WFASM1: wf_stack ge st) *) -(* (MTST0 : match_cur_stack_sig cur ge st) *) -(* (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) *) -(* (MTST2 : match_stack ge ik st) *) -(* k d m_a0 m_i m_a *) -(* (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) *) -(* t' ast' *) -(* (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') *) -(* t'' ast'' *) -(* (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') *) -(* : *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. *) -(* Proof. *) -(* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* (** step --- ReturnState *) *) -(* pose proof STEP as STEP0. inv STEP. inv EV; simpl in *. *) -(* (** return is nccc *) *) -(* { rename H into NCCC. pose proof STAR as STAR0. inv STAR. *) -(* (* end case *) *) -(* { end_case. } *) -(* (* has next step - if internal, done; if external, one external step and X1 = undef *) *) -(* rename H into STEP, H0 into STAR. exploit asm_step_current_pc. eapply STEP. intros (b1 & ofs1 & NEXTPC). *) -(* exploit asm_step_some_fundef. eapply STEP. eapply NEXTPC. intros (fd & NEXTF). *) -(* destruct fd. *) -(* (** next is internal *) *) -(* { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. *) -(* 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. *) -(* } *) -(* (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) *) -(* { exploit asm_to_ir_returnstate_nccc_external. 2: eapply IH. *) -(* 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. *) -(* } *) -(* } *) -(* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) -(* { exploit asm_to_ir_returnstate_ccc. 2: eapply IH. *) -(* 11: eapply STAR. 10: eapply STEP0. all: eauto. rr; splits; eauto. *) -(* } *) -(* Qed. *) - -(* Lemma asm_to_ir_nccc_internal *) -(* cpm ge n n' *) -(* (LT: (n < n')%nat) *) -(* (IH: forall y : nat, *) -(* (y < n')%nat -> *) -(* forall (m_a0 : mem) (ast ast' : state) (tr : trace), *) -(* wf_ge ge -> *) -(* wf_asm ge ast -> *) -(* star_measure (step_fix cpm) ge y ast tr ast' -> *) -(* forall (ist : ir_state) (k : meminj) (d : mem_delta), *) -(* match_state ge k m_a0 d ast ist -> *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') *) -(* m_a0 ast' *) -(* (WFGE: wf_ge ge) *) -(* rs m st *) -(* (WFASM: wf_asm ge (State st rs m)) *) -(* ist k d *) -(* (MTST: match_state ge k m_a0 d (State st rs m) ist) *) -(* t2 rs' m' *) -(* (STAR: star_measure (step_fix cpm) ge n (State st rs' m') t2 ast') *) -(* b ofs f i b' ofs' *) -(* (H0: rs PC = Vptr b ofs) *) -(* (H1: Genv.find_funct_ptr ge b = Some (Internal f)) *) -(* (H2: find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i) *) -(* (H3: exec_instr ge f i rs m (comp_of f) = Next rs' m') *) -(* (NEXTPC: rs' PC = Vptr b' ofs') *) -(* (ALLOWED: comp_of f = Genv.find_comp_ignore_offset ge (Vptr b' ofs')) *) -(* : *) -(* exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t2 /\ istar ir_step ge ist btr ist'. *) -(* Proof. *) -(* destruct (Genv.find_funct_ptr ge b') eqn:NEXTF. *) -(* (* no next function *) *) -(* 2:{ move STAR after NEXTF. inv STAR. *) -(* (* end case *) *) -(* { end_case. } *) -(* (* take a step *) *) -(* { inv H. *) -(* (* invalid *) *) -(* all: exfalso; rewrite NEXTPC in H8; inv H8; rewrite NEXTF in H9; inv H9. *) -(* } *) -(* } *) -(* unfold match_state in MTST. destruct ist as [[[cur m_i] ik] |]. *) -(* 2:{ inv MTST. } *) -(* destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* exploit mem_delta_exec_instr. eapply MEM3. eapply H3. *) -(* { replace (comp_of f) with (Genv.find_comp ge (Vptr cur Ptrofs.zero)). eapply MEM4. *) -(* rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. auto. *) -(* } *) -(* eapply MEM5. auto. intros (d' & MEM4' & MEM5'). *) -(* destruct f0. *) - -(* (** has next function --- internal *) *) -(* { assert (WFASM': wf_asm ge (State st rs' m')). *) -(* { clear IH. unfold wf_asm in *. destruct WFASM as [WFASM0 WFASM1]. split; [auto|]. *) -(* unfold wf_regset in *. rewrite H0, H1 in WFASM1. rewrite NEXTPC, NEXTF. auto. *) -(* } *) -(* assert (MTST': match_state ge k m_a0 d' (State st rs' m') (Some (cur, m_i, ik))). *) -(* { clear IH. split. auto. split. auto. split. auto. split. *) -(* { unfold match_cur_regset in *. rewrite NEXTPC. rewrite <- ALLOWED. rewrite MTST1. *) -(* unfold Genv.find_comp_ignore_offset. rewrite H0. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. *) -(* rewrite H1. auto. *) -(* } *) -(* split. auto. *) -(* { unfold match_mem. splits; auto. *) -(* eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. *) -(* { replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. *) -(* rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. auto. *) -(* } *) -(* eapply public_rev_perm_exec_instr. 3: eapply H3. all: auto. *) -(* } *) -(* } *) -(* exploit IH. 4: eapply STAR. 3: apply WFASM'. 3: eapply MTST'. all: auto. *) -(* } *) - -(* (** has next function --- external *) *) -(* { move STAR after NEXTF. inv STAR. *) -(* (* end case *) *) -(* { end_case. } *) -(* (* take a step *) *) -(* destruct WFASM as [WFASM0 WFASM1]. *) -(* exploit asm_to_ir_step_external. 12: eapply H4. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply H. all: eauto. *) -(* { inv H. *) -(* 1,2,3,4: rewrite NEXTPC in H8; inv H8; rewrite NEXTF in H9; inv H9. *) -(* rewrite <- REC_CURCOMP. rewrite H8. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H8; inv H8. rewrite <- ALLOWED. *) -(* unfold Genv.find_comp. setoid_rewrite H1. auto. *) -(* } *) -(* { instantiate (4:=k). instantiate (3:=d'). unfold match_mem. splits; eauto. *) -(* eapply public_not_freeable_exec_instr; eauto. eapply meminj_not_alloc_delta; eauto. *) -(* { replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. *) -(* rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. auto. *) -(* } *) -(* eapply public_rev_perm_exec_instr; eauto. *) -(* } *) -(* intros (btr' & k' & d'0 & m_a0' & m_i' & m_a' & UTR' & ISTAR' & MM' & (res' & STAR')). *) -(* eapply asm_to_ir_compose. 2: eauto. *) -(* exists btr'. eexists. split. *) -(* { split; auto. eapply ISTAR'. } *) -(* clear btr' UTR' ISTAR'. rename H into STEP0, H4 into STAR0. *) -(* inv STAR'. *) -(* { end_case. } *) -(* exploit asm_to_ir_returnstate_undef. 2: eapply IH. 12: eapply H4. 11: eapply H. 9: eapply MM'. all: eauto. *) -(* { lia. } *) -(* { inv STEP0. *) -(* 1,2,3,4: rewrite NEXTPC in H8; inv H8; rewrite NEXTF in H9; inv H9. *) -(* rewrite <- REC_CURCOMP. rewrite H8. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H8; inv H8. rewrite <- ALLOWED. *) -(* unfold Genv.find_comp. setoid_rewrite H1. auto. *) -(* } *) -(* { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } *) -(* } *) -(* Qed. *) - -(* Lemma asm_to_ir_ccc_external1 *) -(* ge rs cur *) -(* (MTST1 : match_cur_regset cur ge rs) *) -(* rs' e b ofs f args *) -(* (H0 : rs PC = Vptr b ofs) *) -(* (H1 : Genv.find_funct_ptr ge b = Some (Internal f)) *) -(* ofs0 b0 *) -(* (ALLOWED : Genv.allowed_call ge (comp_of f) (Vptr b0 Ptrofs.zero)) *) -(* (NEXTPC : rs' PC = Vptr b0 ofs0) *) -(* (TYPEC : Genv.type_of_call ge (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) = Genv.CrossCompartmentCall) *) -(* (NO_CROSS_PTR : Forall not_ptr args) *) -(* (CALLSIG : Genv.find_funct_ptr ge b0 = Some (External e)) *) -(* vl i0 *) -(* (H3 : Genv.invert_symbol ge b0 = Some i0) *) -(* (H4 : eventval_list_match ge vl (sig_args (ef_sig e)) args) *) -(* : *) -(* exists cp cp' sg, *) -(* (cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) /\ *) -(* (Genv.find_symbol ge i0 = Some b0) /\ *) -(* (Genv.find_funct ge (Vptr b0 Ptrofs.zero) = Some (External e)) /\ *) -(* (cp' = comp_of e) /\ *) -(* (Genv.allowed_call ge cp (Vptr b0 Ptrofs.zero)) /\ *) -(* (crossing_comp ge cp cp' -> Forall not_ptr args) /\ *) -(* (sg = ef_sig e) /\ *) -(* (call_trace_cross ge cp cp' b0 args (sig_args sg) [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl). *) -(* Proof. *) -(* assert (EQC : Genv.find_comp ge (Vptr b Ptrofs.zero) = comp_of f). *) -(* { unfold Genv.find_comp. setoid_rewrite H1. auto. } *) -(* assert (EQC2 : Genv.find_comp ge (Vptr b0 Ptrofs.zero) = comp_of e). *) -(* { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } *) -(* do 3 eexists. *) -(* ss. splits; auto. *) -(* - eapply Genv.invert_find_symbol; auto. *) -(* - replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. *) -(* - econs; auto. *) -(* + unfold Genv.type_of_call. *) -(* replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. *) -(* replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. *) -(* + replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. *) -(* replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. *) -(* Qed. *) - -(* Lemma arguments_same *) -(* rs m sig args1 args2 *) -(* (CARGS: call_arguments rs m sig args1) *) -(* (EARGS: extcall_arguments rs m sig args2) *) -(* : *) -(* args1 = args2. *) -(* Proof. *) -(* unfold call_arguments in CARGS. unfold extcall_arguments in EARGS. *) -(* unfold Conventions.loc_parameters in CARGS. remember (Conventions1.loc_arguments sig) as clas. clear dependent sig. *) -(* move args1 after rs. revert_until args1. induction args1; ss; intros. *) -(* { inv CARGS. symmetry in H0. apply map_eq_nil in H0. subst. inv EARGS. auto. } *) -(* inv CARGS. symmetry in H. apply map_eq_cons in H. des; clarify. *) -(* inv EARGS. f_equal. *) -(* 2:{ eapply IHargs1; eauto. } *) -(* clear - H2 H1. inv H1; ss. *) -(* - inv H2. inv H. *) -(* + ss. inv H1; auto. *) -(* + inv H1; auto. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H2, H5. rewrite H2 in H5. inv H5. auto. *) -(* - inv H2. inv H. *) -(* + inv H0. *) -(* * inv H4. inv H6. auto. *) -(* * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H1, H4. rewrite H1 in H4. inv H4. auto. *) -(* + inv H0. *) -(* * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H2, H5. rewrite H2 in H5. inv H5. auto. *) -(* * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H1, H2, H5, H7. rewrite H2 in H7. rewrite H1 in H5. clarify. *) -(* Qed. *) - - -(* (* If main is External, treat it as a different case - *) -(* the trace can start with Event_syscall, without a preceding Event_call *) *) -(* Theorem asm_to_ir *) -(* cpm (ge: genv) m_a0 *) -(* ast ast' tr *) -(* (WFGE: wf_ge ge) *) -(* (WFASM: wf_asm ge ast) *) -(* (STAR: star (Asm.step_fix cpm) ge ast tr ast') *) -(* ist k d *) -(* (MTST: match_state ge k m_a0 d ast ist) *) -(* : *) -(* exists btr ist', (unbundle_trace btr = tr) /\ (istar (ir_step) ge ist btr ist'). *) -(* Proof. *) -(* apply measure_star in STAR. destruct STAR as (n & STAR). *) -(* move n before ge. revert m_a0 ast ast' tr WFGE WFASM STAR ist k d MTST. *) -(* pattern n. apply (well_founded_induction Nat.lt_wf_0). intros n1 IH. intros. *) -(* inv STAR; subst. *) -(* (* end case *) *) -(* { end_case. } *) -(* rename H0 into STAR. inv H; simpl. *) - -(* - (** internal *) *) -(* eapply asm_to_ir_nccc_internal; eauto. *) - -(* - (** internal_call *) *) -(* assert (EQC: (Genv.find_comp_ignore_offset ge (Vptr b Ptrofs.zero)) = (comp_of f)). *) -(* { ss. unfold Genv.find_comp. setoid_rewrite H1. auto. } *) -(* destruct (Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs'))) eqn:TYPEC. *) -(* (* case nccc: same as the previous *) *) -(* { assert (st' = st). *) -(* { unfold Genv.type_of_call in TYPEC. des_ifs. unfold update_stack_call in STUPD. rewrite EQC in STUPD. rewrite NEXTPC, Heq in STUPD. inv STUPD. auto. } *) -(* subst. *) -(* exploit asm_to_ir_nccc_internal. 2: eapply IH. 5: eapply STAR. all: eauto. rewrite <- EQC; auto. *) -(* { unfold Genv.type_of_call in TYPEC. des_ifs. rewrite Pos.eqb_eq in Heq. auto. } *) -(* intros RES. inv EV. simpl. apply RES. rewrite TYPEC in H. inv H. *) -(* } *) - -(* (* case ccc *) *) -(* { destruct ist as [[[cur m_i] ik] |]; ss. *) -(* destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). *) -(* destruct WFASM as [WFASM0 WFASM1]. *) -(* specialize (CALLSIG eq_refl). des. *) -(* exploit exec_instr_is_call; eauto. clear H2 H3 H4. intros (RSX & MEM). subst m'. *) -(* assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). *) -(* { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. *) -(* des_ifs. eapply wf_ge_block_to_id; eauto. *) -(* } *) -(* des. rename H into IDCUR. *) -(* destruct fd. *) -(* (* calling internal function *) *) -(* { inv EV. *) -(* { rewrite TYPEC in H. clarify. } *) -(* clear H. clarify. unfold update_stack_call in STUPD. des_ifs. *) -(* { unfold Genv.type_of_call in TYPEC. rewrite NEXTPC in Heq. rewrite <- EQC in TYPEC. ss. rewrite Heq in TYPEC. inv TYPEC. } *) -(* ss. eapply asm_to_ir_compose. *) -(* 2:{ instantiate (2:=[Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl]). simpl. eauto. } *) -(* assert (EQC2: (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) = comp_of f0). *) -(* { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } *) -(* specialize (CHECKPUB eq_refl). *) -(* pose proof MTST3 as MEM. destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) -(* hexploit mem_delta_apply_establish_inject. eapply MEM0. 1,2,3,4: eauto. *) -(* { clear - CHECKPUB. ii. unfold public_first_order in CHECKPUB. unfold meminj_public in H. des_ifs. *) -(* eapply CHECKPUB; eauto. apply Senv.invert_find_symbol; auto. *) -(* } *) -(* intros (m_i' & APPD & MEMINJ). *) -(* exists ([(id_cur, Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (fn_sig f0) d)]). eexists. split. *) -(* { simpl. split; auto. econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_cross_call_internal. *) -(* 7: eauto. 6: intros; eapply NO_CROSS_PTR; auto. 3: setoid_rewrite CALLSIG; auto. 3,4: eauto. *) -(* { rewrite MTST1. rewrite <- EQC, H0. simpl. auto. } *) -(* { apply Genv.invert_find_symbol; auto. } *) -(* { econs; auto. } *) -(* { replace (comp_of f) with (Genv.find_comp ge (Vptr cur Ptrofs.zero)). eapply APPD. rewrite MTST1. rewrite H0. ss. } *) -(* { hexploit public_rev_perm_delta_apply_inj. eauto. eapply APPD. intros REVP. clear - MEMINJ CHECKPUB REVP. *) -(* unfold public_first_order in *. i. *) -(* exploit Senv.find_invert_symbol; eauto. intros INV. *) -(* assert (PERM: Mem.perm m b ofs Cur Readable). *) -(* { specialize (REVP b). unfold meminj_public in REVP. rewrite INV, PUBLIC in REVP. apply REVP. rewrite Z.add_0_r. auto. } *) -(* eapply loc_first_order_memval_inject_preserves. eapply CHECKPUB; eauto. *) -(* instantiate (1:=ge). inv MEMINJ. inv mi_inj. replace ofs with (ofs + 0)%Z at 2 by lia. eapply mi_memval; auto. *) -(* unfold meminj_public. rewrite INV, PUBLIC. auto. *) -(* } *) -(* auto. *) -(* } *) -(* rewrite H0 in RSX. simpl in RSX. inv RSX. *) -(* eapply IH. 4: eapply STAR. all: auto. *) -(* { ss. split. *) -(* - econs; auto. ss. rewrite H1. auto. *) -(* - unfold wf_regset. rewrite NEXTPC. rewrite CALLSIG. auto. *) -(* } *) -(* unfold match_state. splits; eauto. *) -(* - unfold wf_ir_cur. rewrite CALLSIG. auto. *) -(* - econs; eauto. *) -(* - unfold match_cur_stack_sig. rewrite CALLSIG. ss. *) -(* - unfold match_cur_regset. rewrite NEXTPC. ss. *) -(* - econs; eauto. rewrite MTST1. rewrite H0. ss. *) -(* - instantiate (3:=(meminj_public ge)). instantiate (2:=[]). instantiate (1:=m). *) -(* rr; splits; auto. eapply meminj_not_alloc_delta; eauto. ss. eapply public_rev_perm_delta_apply_inj; eauto. *) -(* } *) -(* (* calling external function *) *) -(* { assert (EQC2: (Genv.find_comp ge (Vptr b' Ptrofs.zero)) = comp_of e). *) -(* { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } *) -(* inv EV. *) -(* { rewrite TYPEC in H. clarify. } *) -(* clear H. clarify. unfold update_stack_call in STUPD. des_ifs. *) -(* { unfold Genv.type_of_call in TYPEC. rewrite NEXTPC in Heq. rewrite <- EQC in TYPEC. ss. rewrite Heq in TYPEC. inv TYPEC. } *) -(* pose proof STAR as STAR0. move STAR after H4. *) -(* exploit asm_to_ir_ccc_external1. eapply MTST1. eapply H0. eapply H1. eapply ALLOWED. eapply NEXTPC. all: auto. eapply CALLSIG. eapply H3. eapply H4. *) -(* intros (cp & cp' & sg & FACT1 & FACT2 & FACT3 & FACT4 & FACT5 & FACT6 & FACT7 & FACT8). subst. *) -(* inv STAR; ss. *) -(* (* subcase 1 *) *) -(* { exists ([(id_cur, Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (ef_sig e) [])]). eexists. ss. split; auto. *) -(* econs 2. 2: econs 1. 2: eauto. eapply ir_step_cross_call_external1. *) -(* 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply FACT3. 2: eapply FACT2. all: eauto. *) -(* } *) -(* rename H into STEP, H2 into STAR, TYPEC into CCC, CALLSIG into NEXTF. inv STEP. *) -(* 1,2,3,4: rewrite NEXTPC in H6; inv H6; rewrite NEXTF in H7; inv H7. *) -(* rewrite NEXTPC in H6; inv H6. rewrite NEXTF in H7; inv H7. ss. clear REC_CURCOMP. rename H8 into EXTCALL, H11 into EXTARGS. *) -(* assert (NEQCP: comp_of f <> comp_of ef). *) -(* { rewrite <- EQC2. clear - CCC. intros CC. unfold Genv.type_of_call in CCC. rewrite CC in CCC. rewrite Pos.eqb_refl in CCC. inv CCC. } *) -(* exploit extcall_cases. eapply ECC. eapply EXTCALL. clear ECC. rewrite <- or_assoc. intros [ECC | ECC]. *) -(* 2:{ exfalso. clear - NEXTF NEQCP ALLOWED ECC. destruct ALLOWED as [A | A]. *) -(* { rewrite A in NEQCP. unfold Genv.find_comp in NEQCP. setoid_rewrite NEXTF in NEQCP. auto. } *) -(* unfold Genv.allowed_cross_call in A. destruct A as (i & cp' & INV & OK & _). unfold Genv.find_funct_ptr in NEXTF. specialize (OK _ NEXTF). *) -(* destruct ef; ss; clarify. des_ifs. des_ifs. *) -(* { destruct ECC as [ECC1 ECC2]. subst. inv ECC1. } *) -(* { destruct ECC as [ECC1 ECC2]. subst. inv ECC1. } *) -(* } *) -(* exploit arguments_same; eauto. intros EQ. subst args0. *) -(* exploit match_mem_external_call_establish; eauto. intros. *) -(* destruct x0 as (d' & m1 & m2 & res' & EFACT1 & EFACT2 & EFACT3 & (k2 & d2 & m_a02 & MM)). *) -(* inv STAR. *) -(* (* subcase 2 *) *) -(* { exists ([(id_cur, Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1) i0 vl (ef_sig ef) (d'))]). eexists. split; auto. *) -(* econs 2. 2: econs 1. 2: eauto. eapply ir_step_cross_call_external2. *) -(* 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply FACT3. 2: eapply FACT2. all: eauto. *) -(* erewrite eventval_list_match_vals_to_eventvals; eauto. *) -(* } *) -(* rename H into STEP, H2 into STAR. inv STEP. ss. rewrite Pregmap.gss in *. destruct MM as [MM VAL]. *) -(* (* subcase 3 *) *) -(* pose proof WFIR0 as CUR. unfold wf_ir_cur in CUR. des_ifs. clear CUR. rename Heq1 into CUR. *) -(* unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. des_ifs. *) -(* { exfalso. rewrite Heq0, RSX, H0 in Heq1. ss. rewrite Pos.eqb_sym, Heq in Heq1. congruence with Heq1. } *) -(* clear PC_RA. inv EV. *) -(* { exfalso. apply H. rewrite Heq0, RSX, H0. ss. unfold Genv.type_of_call. rewrite Heq. auto. } *) -(* assert (RES: (return_value (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) (ef_sig ef)) = res). *) -(* { exploit NO_CROSS_PTR0; auto. clear. intros NPTR. *) -(* unfold return_value, loc_external_result in *. remember (Conventions1.loc_result (ef_sig ef)) as rpmr. *) -(* unfold Conventions1.loc_result in Heqrpmr. des_ifs. *) -(* ss. rewrite ! (Pregmap.gso (j:=PC)) in *; ss. rewrite ! Pregmap.gss in *. rewrite Pregmap.gso, Pregmap.gss in *; ss. *) -(* unfold Val.longofwords, Val.hiword, Val.loword in *. des_ifs. *) -(* rewrite Int64.ofwords_recompose. auto. *) -(* } *) -(* eapply asm_to_ir_compose. *) -(* 2:{ instantiate (1:=t3). rewrite app_comm_cons. setoid_rewrite app_assoc. eauto. } *) -(* exists ([(id_cur, Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1 ++ [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0]) i0 vl (ef_sig ef) (d'))]). eexists. split. *) -(* { split; auto. *) -(* { ss. rewrite app_nil_r. auto. } *) -(* econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_cross_call_external3. *) -(* 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply NEXTF. 2: eapply FACT2. all: eauto. *) -(* { erewrite eventval_list_match_vals_to_eventvals; eauto. } *) -(* { intros. exploit NO_CROSS_PTR0; auto. rewrite RES. clear - VAL. intros. destruct VAL as [VAL | VAL]. *) -(* - pose proof Val.inject_list_not_ptr. specialize (H k2 [res] [res']). exploit H. econs; eauto. econs; eauto. intros. inv x1. auto. *) -(* - subst; auto. *) -(* } *) -(* { econs; eauto. *) -(* - setoid_rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. clear - NEQCP. *) -(* unfold Genv.type_of_call. rewrite <- Pos.eqb_neq in NEQCP. setoid_rewrite NEQCP. auto. *) -(* - instantiate (1:=res0). rewrite RES in H2, NO_CROSS_PTR0. exploit NO_CROSS_PTR0; auto. intros NPTR. *) -(* clear - H2 NPTR VAL. destruct VAL as [VAL | VAL]; subst; auto. remember (proj_rettype (sig_res (ef_sig ef))) as ty. clear dependent ef. *) -(* inv VAL; ss; eauto. *) -(* - f_equal. f_equal. rewrite Heq0, RSX. rewrite MTST1, H0. ss. rewrite NEXTPC. ss. *) -(* } *) -(* } *) -(* rewrite H0 in RSX. ss. inv RSX. eapply IH. 4: eapply STAR. all: auto. *) -(* { ss. splits; auto. unfold wf_regset in *. rewrite Pregmap.gss. rewrite Heq0. rewrite H1. auto. } *) -(* { ss. splits; auto. *) -(* - unfold match_cur_regset in *. rewrite Pregmap.gss. rewrite Heq0. rewrite MTST1. rewrite H0. ss. *) -(* - eauto. *) -(* } *) -(* } *) -(* } *) - -(* - (** internal_return *) *) -(* destruct ist as [[[cur m_i] ik] |]; ss. *) -(* destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). *) -(* destruct WFASM as [WFASM0 WFASM1]. *) -(* inv STAR. *) -(* { end_case. } *) -(* rename H into STEP, H5 into STAR. *) -(* exploit exec_instr_is_return. eapply H3. auto. intros ((v & NEXTPC) & TEMP). subst m'. *) -(* eapply asm_to_ir_returnstate. 2: eapply IH. 11: eapply STAR. 10: eapply STEP. *) -(* all: eauto. *) -(* { rewrite <- REC_CURCOMP. apply MTST1. } *) - -(* - (** return *) *) -(* exfalso. unfold wf_asm in WFASM. contradiction WFASM. *) - -(* - (** builtin *) *) -(* destruct ist as [[[cur m_i] ik] |]; ss. *) -(* exploit asm_to_ir_builtin; eauto. *) -(* destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). *) -(* clear dependent k. clear dependent d. clear dependent m_a0. *) -(* intros (btr1 & k & d & m_a & m_i' & UTR1 & ISTAR1 & MEM). *) -(* eapply asm_to_ir_compose. 2: eauto. exists btr1. eexists. split. *) -(* { split; eauto. } *) -(* clear dependent btr1. clear dependent m_i. rename m_i' into m_i. *) -(* destruct WFASM as [WFASM0 WFASM1]. *) -(* remember (nextinstr (set_res (map_builtin_res preg_of res) vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs # X1 <- Vundef) # X31 <- Vundef))) as rs'. *) -(* assert (NEXTPC: rs' PC = Val.offset_ptr (rs PC) Ptrofs.one). *) -(* { subst rs'. clear. unfold nextinstr. simpl. *) -(* rewrite Pregmap.gss. f_equal. rewrite ! Asmgenproof0.set_res_other; ss. *) -(* rewrite Asmgenproof0.undef_regs_other_2. *) -(* rewrite Pregmap.gso. rewrite Pregmap.gso. all: ss; auto. *) -(* rewrite Asmgenproof0.preg_notin_charact. intros. destruct mr; ss. *) -(* } *) -(* eapply IH. 4: eapply STAR. all: auto. *) -(* { simpl. split; auto. unfold wf_regset in *. rewrite NEXTPC, H0. simpl. rewrite H1. auto. } *) -(* { simpl. splits. 6: eapply MEM. all: auto. unfold match_cur_regset in *. *) -(* rewrite NEXTPC, H0. ss. rewrite MTST1, H0. ss. *) -(* } *) - -(* - (** external *) *) -(* exfalso. destruct WFASM as [WFASM0 WFASM1]. unfold wf_regset in WFASM1. *) -(* rewrite H0 in WFASM1. rewrite H1 in WFASM1. contradiction WFASM1. *) - -(* Qed. *) - -(* End PROOF. *) - -(* Section INIT. *) - -(* Definition wf_program {F V} (p: AST.program F V) := list_norepet (prog_defs_names p). *) - -(* Lemma wf_program_wf_ge *) -(* F V (p: AST.program F V) *) -(* (WFP: wf_program p) *) -(* : *) -(* wf_ge (Genv.globalenv p). *) -(* Proof. unfold wf_ge; eauto. Qed. *) - -(* Definition wf_main (p: Asm.program) := *) -(* exists b, (Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b) /\ *) -(* (exists f, Genv.find_funct_ptr (Genv.globalenv p) b = Some (Internal f)). *) - -(* Definition wf_main_sig (p: Asm.program) := *) -(* forall b f, (Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b) -> *) -(* (Genv.find_funct_ptr (Genv.globalenv p) b = Some (Internal f)) -> *) -(* fn_sig f = signature_main. *) - -(* Lemma wf_asm_initial_state *) -(* p ast *) -(* (WFMAIN: wf_main p) *) -(* (INIT: initial_state p ast) *) -(* : *) -(* wf_asm (Genv.globalenv p) ast. *) -(* Proof. *) -(* unfold wf_main in WFMAIN. des. inv INIT. unfold wf_asm. split. *) -(* { unfold initial_stack. ss. } *) -(* { unfold wf_regset. subst rs0. rewrite Pregmap.gso; ss. rewrite Pregmap.gso; ss. rewrite Pregmap.gss. *) -(* (* unfold fundef in *. *) *) -(* unfold Genv.symbol_address. subst ge. rewrite WFMAIN, WFMAIN0. auto. *) -(* } *) -(* Qed. *) - -(* Variant ir_initial_state (p: Asm.program): ir_state -> Prop := *) -(* | ir_initial_state_intro: forall cur m0, *) -(* let ge := Genv.globalenv p in *) -(* Genv.find_symbol ge (prog_main p) = Some cur -> *) -(* (exists f, Genv.find_funct_ptr ge cur = Some (Internal f)) -> *) -(* Genv.init_mem p = Some m0 -> *) -(* ir_initial_state p (Some (cur, m0, [])). *) - -(* Lemma ir_has_initial_state *) -(* p ast *) -(* (WFMAIN: wf_main p) *) -(* (INIT: Asm.initial_state p ast) *) -(* : *) -(* exists ist, ir_initial_state p ist. *) -(* Proof. *) -(* unfold wf_main in WFMAIN. des. inv INIT. *) -(* exists (Some (b, m0, [])). econs; eauto. *) -(* Qed. *) - -(* Lemma match_state_initial_state *) -(* p ast ist *) -(* (WFMAINSIG: wf_main_sig p) *) -(* (INITA: Asm.initial_state p ast) *) -(* (INITI: ir_initial_state p ist) *) -(* ge *) -(* (GE: ge = Genv.globalenv p) *) -(* : *) -(* exists m0 j, (Genv.init_mem p = Some m0) /\ (match_state ge j m0 [] ast ist). *) -(* Proof. *) -(* inv INITA. inv INITI. des. specialize (WFMAINSIG _ _ H0 H1). *) -(* clarify. exists m0, (Mem.flat_inj (Mem.nextblock m0)). esplits; eauto. unfold match_state. subst ge. splits. *) -(* - unfold wf_ir_cur. rewrite H1. auto. *) -(* - econs. *) -(* - unfold match_cur_stack_sig. rewrite H1. ss. *) -(* - unfold match_cur_regset. subst rs0. rewrite Pregmap.gso; ss. rewrite Pregmap.gso; ss. rewrite Pregmap.gss. *) -(* unfold Genv.symbol_address. subst ge0. rewrite H0. ss. *) -(* - econs. *) -(* - unfold match_mem. *) -(* assert (MNA: meminj_not_alloc (meminj_public (Genv.globalenv p)) m0). *) -(* { unfold meminj_not_alloc. intros. unfold meminj_public. des_ifs. exfalso. apply Senv.invert_find_symbol in Heq. exploit Genv.find_symbol_not_fresh. eauto. *) -(* eapply Heq. intros CC. unfold Mem.valid_block in CC. unfold Plt in CC. lia. *) -(* } *) -(* splits; ss; auto. *) -(* + eapply Genv.initmem_inject; eauto. *) -(* + ii. unfold meminj_public in H. unfold Mem.flat_inj. des_ifs. exfalso. *) -(* apply n; clear n. unfold Plt. destruct (Pos.ltb_spec b' (Mem.nextblock m0)); auto. *) -(* exfalso. specialize (MNA _ H). unfold meminj_public in MNA. rewrite Heq, Heq0 in MNA. clarify. *) -(* + ii. unfold meminj_public in H. des_ifs. clear - Heq Heq0 H3 H2. exploit Senv.invert_find_symbol; eauto. intros FIND. rename H2 into INITM, H3 into FREE. clear - INITM FREE FIND. *) -(* eapply Genv.find_symbol_find_def_inversion in FIND. des. destruct g. *) -(* * exploit Genv.init_mem_characterization_2; eauto. *) -(* { unfold Genv.find_funct_ptr. rewrite FIND. eauto. } *) -(* intros [CUR CC]. exploit CC. eapply FREE. intros. des; clarify. *) -(* * exploit Genv.init_mem_characterization; eauto. *) -(* { unfold Genv.find_var_info. rewrite FIND. eauto. } *) -(* intros [_ [CC [_ _]]]. exploit CC. eapply FREE. intros. des. clear - x1. unfold Genv.perm_globvar in x1. des_ifs; inv x1. *) -(* + ii. unfold meminj_public. des_ifs. intros. rewrite Z.add_0_r in H. auto. *) -(* Qed. *) - -(* End INIT. *) +Section PROOF. + + Import ListNotations. + + Ltac end_case := do 2 eexists; split; [|constructor 1]; auto. + + Lemma asm_step_current_pc + ge st rs m cp t s' + (STEP: Asm.step ge (State st rs m cp) 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 H3; inv H3. eauto. Qed. + + Lemma asm_step_some_fundef + cpm ge st rs m t s' + (STEP: step ge (State st rs m cpm) 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 H3; inv H3; rewrite CASE in H4; inv H4. Qed. + + Lemma asm_to_ir_compose + ge ist0 t t1 t2 + (ISTARS: exists btr1 ist1, + (unbundle_trace btr1 = t1 /\ istar ir_step ge ist0 btr1 ist1) + /\ exists btr2 ist2, + (unbundle_trace btr2 = t2 /\ istar ir_step ge ist1 btr2 ist2)) + (TR: t = t1 ** t2) + : + exists (btr : bundle_trace) (ist' : ir_state), + unbundle_trace btr = t /\ istar ir_step ge ist0 btr ist'. + Proof. + subst. destruct ISTARS as (btr1 & ist1 & (UTR1 & ISTAR1) & btr2 & ist2 & (UTR2 & ISTAR2)). + exists (btr1 ++ btr2). exists ist2. split; auto. + { rewrite unbundle_trace_app. rewrite UTR1, UTR2. auto. } + { eapply istar_trans; eauto. } + Qed. + + + Lemma visible_fo_meminj_fo + (ge: Senv.t) m tys args + (VFO: visible_fo ge m tys args) + : + meminj_first_order (meminj_public ge) m. + Proof. + destruct VFO as [PFO _]. ii. unfold public_first_order in PFO. unfold meminj_public in H. des_ifs. + exploit PFO; eauto. apply Senv.invert_find_symbol. auto. + Qed. + + Lemma external_call_unknowns_fo + ef (ge: Senv.t) m args + (ECC: external_call_unknowns ef ge m args) + : + meminj_first_order (meminj_public ge) m. + Proof. + unfold external_call_unknowns in ECC. des_ifs; eapply visible_fo_meminj_fo; eauto. + Qed. + + (* TODO: I think we need to parametrize [meminj_public] with a compartment *) + Lemma symbols_inject_meminj_public + F V (ge: Genv.t F V) cp + : + symbols_inject (meminj_public ge) ge ge cp. + Proof. + unfold symbols_inject. splits; intros; unfold meminj_public in *; auto. + - des_ifs. + - erewrite Senv.find_invert_symbol; eauto. rewrite H. eauto. + - des_ifs. + Qed. + + Lemma visible_fo_val_inject_list + (ge: Senv.t) m tys args + (VFO: visible_fo ge m tys args) + : + Val.inject_list (meminj_public ge) args args. + Proof. + destruct VFO as [PFO VP]. induction VP; ss. econs; eauto. clear dependent l. clear dependent l'. inv H; auto. + destruct H0 as [id [INV PUB]]. + econs. unfold meminj_public. rewrite INV. rewrite PUB. eauto. rewrite Ptrofs.add_zero. auto. + Qed. + + Lemma external_call_unknowns_val_inject_list + ef (ge: Senv.t) m args + (ECC: external_call_unknowns ef ge m args) + : + Val.inject_list (meminj_public ge) args args. + Proof. + unfold external_call_unknowns in ECC. des_ifs; eapply visible_fo_val_inject_list; eauto. + Qed. + + Lemma public_rev_perm_delta_apply_inj + d ge m m_i m_i' cp + (PRP: public_rev_perm ge m m_i) + (APPD: mem_delta_apply_wf ge cp d (Some m_i) = Some m_i') + : + public_rev_perm ge m m_i'. + Proof. + revert_until d. induction d; intros. + { unfold mem_delta_apply_wf in APPD. ss. clarify. } + rewrite mem_delta_apply_wf_cons in APPD. des_ifs; clarify; eauto. + exploit mem_delta_apply_wf_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. + eapply IHd; clear IHd. 2: eauto. + unfold public_rev_perm in *. intros. specialize (PRP b). des_ifs. intros. + eapply PRP. unfold wf_mem_delta_kind_b in Heq. des_ifs. ss. unfold mem_delta_apply_storev in STORE. des_ifs. + destruct v0; ss. eapply Mem.perm_store_2; eauto. + Qed. + + Lemma mem_perm_any_to_nonempty + m b ofs k p + (PERM: Mem.perm m b ofs k p) + : + Mem.perm m b ofs k Nonempty. + Proof. + unfold Mem.perm in *. remember ((Mem.mem_access m) !! b ofs k) as k'. clear - PERM. destruct k'; ss. destruct p; ss; try constructor. + Qed. + + Lemma loc_first_order_memval_inject_preserves + (ge: Senv.t) m m' b ofs + (LFO: loc_first_order m b ofs) + (MVINJ: memval_inject (meminj_public ge) (ZMap.get ofs (Mem.mem_contents m) !! b) (ZMap.get ofs (Mem.mem_contents m') !! b)) + : + loc_first_order m' b ofs. + Proof. + unfold loc_first_order in *. remember (ZMap.get ofs (Mem.mem_contents m) !! b) as mv1. remember (ZMap.get ofs (Mem.mem_contents m') !! b) as mv2. + clear - LFO MVINJ. inv MVINJ; ss. + Qed. + + Lemma visible_fo_mem_inj + (ge: Senv.t) m tys args + (VFO: visible_fo ge m tys args) + m' + (MEMINJ: Mem.inject (meminj_public ge) m m') + (PRP: public_rev_perm ge m m') + : + visible_fo ge m' tys args. + Proof. + destruct VFO as [PFO VP]. split; auto. clear VP. clear - PFO MEMINJ PRP. + unfold public_first_order in *. intros. specialize (PRP b). unfold meminj_public in PRP. + exploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV, PUBLIC in PRP. + specialize (PRP ofs). rewrite Z.add_0_r in PRP. exploit PFO; eauto. intros LFO. + inv MEMINJ. inv mi_inj. exploit mi_memval. + { unfold meminj_public. rewrite INV, PUBLIC. eauto. } + { eauto. } + intros MVINJ. clear - LFO MVINJ. rewrite Z.add_0_r in MVINJ. eapply loc_first_order_memval_inject_preserves; eauto. + Qed. + + Lemma external_call_unknowns_mem_inj + (ge: Senv.t) m ef args + (ECC: external_call_unknowns ef ge m args) + m' + (MEMINJ: Mem.inject (meminj_public ge) m m') + (PRP: public_rev_perm ge m m') + : + external_call_unknowns ef ge m' args. + Proof. + unfold external_call_unknowns in *. des_ifs; eapply visible_fo_mem_inj; eauto. + Qed. + + Lemma match_mem_external_call_establish1 + (ge: genv) cp k d m_a0 m_i m + (MEM: match_mem ge cp k d m_a0 m_i m) + ef args t res m' + (EXTCALL: external_call ef ge cp args m t res m') + (ECC: external_call_unknowns ef ge m args) + : + exists m1 m2 res', + (mem_delta_apply_wf ge cp d (Some m_i) = Some m1) /\ + (external_call ef ge cp args m1 t res' m2) /\ + (external_call_unknowns ef ge m1 args) /\ + (exists k2, match_mem ge cp k2 [] m' m2 m' /\ Val.inject k2 res res') + . + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (* reestablish meminj *) + exploit mem_delta_apply_establish_inject; eauto. + (* { apply meminj_public_strict. } *) + { eapply external_call_unknowns_fo. eauto. } + intros (m_i' & APPD' & MEMINJ'). + hexploit ec_mem_inject. eapply external_call_spec. 2: eapply EXTCALL. all: eauto. + (* hexploit external_call_mem_inject. 2: eapply EXTCALL. all: eauto. *) + { instantiate (1:=ge). apply symbols_inject_meminj_public. } + { instantiate (1:=args). eapply external_call_unknowns_val_inject_list; eauto. } + intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). + assert (MM': match_mem ge cp f' [] m' m_i'' m'). + { unfold match_mem. simpl. + assert (PNF: public_not_freeable ge m'). + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. + clear - EXTCALL MEM3 NALLOC. unfold public_not_freeable in *. intros. + specialize (MEM3 _ H). intros CC. apply (MEM3 ofs); clear MEM3. + eapply external_call_max_perm; eauto. unfold Mem.valid_block. + unfold meminj_not_alloc in NALLOC. unfold Plt. + destruct (Pos.ltb_spec b (Mem.nextblock m)); auto. + specialize (NALLOC _ H0). congruence. + } + pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. + assert (MNA: meminj_not_alloc (meminj_public ge) m'). + { clear - EXTCALL NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. + pose proof (@external_call_valid_block _ _ _ _ _ _ _ _ b EXTCALL). + destruct (Pos.leb_spec (Mem.nextblock m) b); auto. + unfold Mem.valid_block in H0. apply H0 in H1. exfalso. unfold Plt in H1. lia. + } + splits; auto. + { constructor. } + { hexploit public_rev_perm_delta_apply_inj; eauto. intros PRP2. clear - MEM3 PRP2 EXTCALL EXTCALL' PNF NALLOC MEMINJ' MEMINJ'' INCRINJ'. + unfold public_rev_perm in *. intros. specialize (PRP2 b). des_ifs. intros. + hexploit Mem.perm_inject_inv. eapply MEMINJ''. eapply INCRINJ'. eapply Heq. eauto. intros [PERM | PERM]; auto. + pose proof Heq as PUB. unfold meminj_public in PUB. des_ifs. + assert (VB: Mem.valid_block m b0). + { unfold meminj_not_alloc in NALLOC. unfold Mem.valid_block. destruct (Pos.ltb_spec b0 (Mem.nextblock m)); auto. exfalso. + exploit NALLOC; eauto. intros. clarify. + } + exfalso. apply PERM. + admit. + (* eapply external_call_public_not_freeable; eauto. *) + (* { eapply PRP2. eapply external_call_max_perm. eauto. *) + (* { eapply Mem.valid_block_inject_2; eauto. } *) + (* eapply Mem.perm_max. eapply mem_perm_any_to_nonempty. eauto. *) + (* } *) + (* { unfold public_not_freeable in MEM3. eapply MEM3. rewrite Heq. congruence. } *) + } + } + exists m_i', m_i'', vres'. splits; eauto. + { assert (PRP: public_rev_perm ge m m_i'). + { eapply public_rev_perm_delta_apply_inj; eauto. } + clear - ECC MEMINJ' PRP. eapply external_call_unknowns_mem_inj; eauto. + } + Admitted. + + + Lemma asm_to_ir_returnstate_nccc_internal + (ge: genv) cur_comp 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 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_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + t' ast' + (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') + t'' ast'' + (STAR: star_measure (step) ge n0 ast' t'' ast'') + (NCCC: Genv.type_of_call (Genv.find_comp_in_genv ge (rs PC)) cur_comp <> Genv.CrossCompartmentCall) + b1 ofs1 + (NEXTPC: rs PC = Vptr b1 ofs1) + f + (NEXTF : Genv.find_funct_ptr ge b1 = Some (Internal f)) + : + exists (btr : bundle_trace) (ist' : ir_state), + unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + inv STEP. inv EV; simpl in *. + 2:{ rewrite H in NCCC. congruence with NCCC. } + (** return is nccc *) + clear H. pose proof STAR as STAR0. inv STAR. + (* end case *) + { end_case. } + (* has next step - internal -> done*) + rename H into STEP, H0 into STAR. + (** next is internal *) + exploit IH; clear IH. 4: eapply STAR0. lia. all: auto. + { simpl. split. + - unfold Genv.type_of_call in NCCC. + unfold update_stack_return in STUPD. + admit. + (* destruct (flowsto_dec); try congruence. *) + (* 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. + admit. } + (* 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 *. + admit. } + (* rewrite CURCOMP. unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. auto. } *) + split; auto. + { unfold match_mem. splits; auto. } + } + intros (btr & ist' & UTR & ISTAR'). + exists btr, ist'. split; auto. + Admitted. + + Lemma match_mem_external_call_establish2 + ge cp k d m_a0 m_i m + (MEM: match_mem ge cp k d m_a0 m_i m) + ef args t res m' + (EXTCALL: external_call ef ge cp args m t res m') + (ECKO: external_call_known_observables ef ge cp m args t res m') + : + (external_call ef ge cp args m_i t res m_i) /\ + (external_call_known_observables ef ge cp m_i args t res m_i) /\ + (match_mem ge cp k d m_a0 m_i m') + . + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + unfold external_call_known_observables in ECKO. + des_ifs; simpl in *. + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. + 1,2: econs; econs; eauto. unfold match_mem. splits; auto. + } + { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. + 1,2: econs; econs; eauto. unfold match_mem. splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL. esplits; eauto. + 1,2: econs; eauto. unfold match_mem. splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. esplits; eauto. + 1,2: econs; eauto. unfold match_mem. splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + Qed. + + Lemma match_mem_external_call_establish + (ge: genv) cp k d m_a0 m_i m + (MEM: match_mem ge cp k d m_a0 m_i m) + ef args t res m' + (EXTCALL: external_call ef ge cp args m t res m') + (ECC: external_call_unknowns ef ge m args \/ external_call_known_observables ef ge cp m args t res m') + : + exists d' m1 m2 res', + (mem_delta_apply_wf ge cp d' (Some m_i) = Some m1) /\ + (external_call ef ge cp args m1 t res' m2) /\ + ((external_call_unknowns ef ge m1 args) \/ (external_call_known_observables ef ge cp m1 args t res' m2 /\ d' = [])) /\ + (exists k2 d2 m_a02, match_mem ge cp k2 d2 m_a02 m2 m' /\ (Val.inject k2 res res' \/ (res = res'))) + . + Proof. + destruct ECC as [ECC | ECC]. + - exploit match_mem_external_call_establish1; eauto. intros. des. esplits; eauto. + - exploit match_mem_external_call_establish2; eauto. intros. des. esplits; eauto. ss. + Qed. + + Lemma asm_to_ir_step_external + (ge: genv) cur_comp + (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_in_genv ge (Vptr cur Ptrofs.zero) = (* callee_comp cpm st *) cur_comp) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + t ast' + (STEP: step ge (State st rs m_a cur_comp) t ast') + b1 ofs1 + (NEXTPC: rs PC = Vptr b1 ofs1) + ef + (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) + n t' ast'' + (STAR: star_measure step ge n ast' t' ast'') + : + exists (btr : bundle_trace) k' d' m_a0' m_i' m_a', + (unbundle_trace btr = t) /\ + (istar ir_step ge (Some (cur, m_i, ik)) btr (Some (cur, m_i', ik))) /\ + (match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m_a') /\ + (exists res, star_measure step ge n + (ReturnState st + (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) # PC <- (rs X1) m_a' bottom) t' ast''). + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). + { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. + des_ifs. eapply wf_ge_block_to_id; eauto. + } + des. rename H into IDCUR. + (* take a step *) + inv STEP. + (* invalid *) + 1,2,3,4: rewrite NEXTPC in H3; inv H3; rewrite NEXTF in H4; inv H4. + rewrite NEXTPC in H3; inv H3; rewrite NEXTF in H4; inv H4. + exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF). + exploit wf_ge_block_to_id; eauto. intros (ef_id & INVSYMB). + exploit Genv.invert_find_symbol. eapply INVSYMB. intros FINDSYMB. clear TEMP. + exploit extcall_cases. + admit. (* ?? *) + eauto. + (* previous script *)(* eapply ECC. eauto. clear ECC. *) + intros [ECU | [ECKO | ECKS]]. + + - (* extcall is unknown *) + exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. + intros. des. + exists ([(id_cur, Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (d))]). + do 5 eexists. splits; simpl. 3: eapply x3. apply app_nil_r. + 2:{ exists res. auto. } + econstructor 2. 2: econstructor 1. 2: eauto. + eapply ir_step_intra_call_external; eauto. + (* exact x0. *) (* this one should work trivially *) + admit. + admit. (* idem *) + (* { unfold Genv.type_of_call in *. rewrite CURCOMP, <- REC_CURCOMP. rewrite NEXTPC. simpl. *) + (* unfold Genv.find_comp. setoid_rewrite NEXTF. rewrite Pos.eqb_refl. auto. *) + (* } *) + + - (* extcall is known and observable *) + rename H7 into EXTCALL, H8 into EXTARGS. unfold external_call_known_observables in ECKO. + des_ifs; simpl in *. + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([(id_cur, Bundle_call [Event_vload chunk id ofs ev] ef_id [EVptr_global id ofs] {| sig_args := [Tptr]; sig_res := rettype_of_chunk chunk; sig_cc := cc_default |} ([]))]). + exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_intra_call_external. all: eauto. + (* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) + { ss. } + { simpl. econstructor. econstructor 1; eauto. unfold Senv.find_comp. simpl. + admit. (* wrong typeclass instance *) + (* exact H2. *) + } + { simpl. right. split; auto. econs; eauto. econs. econs; eauto. admit. (* same problem *)} + { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } + splits; auto. + } + { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([(id_cur, Bundle_call [Event_vstore chunk id ofs ev] ef_id [EVptr_global id ofs; ev] {| sig_args := [Tptr; type_of_chunk chunk]; sig_res := Tvoid; sig_cc := cc_default |} ([]))]). + exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_intra_call_external. all: eauto. + (* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) + { ss. } + { instantiate (2:=[Vptr b0 ofs; Val.load_result chunk v]). + simpl. econstructor. econstructor 1; eauto. + admit. (* idem*) + rewrite val_load_result_idem. auto. + } + { simpl. right. split; auto. + splits; ss; auto. econs; eauto. econs; eauto. + admit. (* idem *) + rewrite val_load_result_idem. auto. des. + unfold load_whole_chunk in *. rewrite val_load_result_idem. auto. + } + { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. + f_equal. erewrite eventval_match_val_to_eventval; eauto. + } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. + exists ([(id_cur, Bundle_call [Event_annot text args0] ef_id (vals_to_eventvals ge args) {| sig_args := targs; sig_res := Tvoid; sig_cc := cc_default |} ([]))]). + exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_intra_call_external. all: eauto. + (* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) + { ss. } + { simpl. econstructor. auto. admit. (* idem *) } + { simpl. right. split; auto. econs; eauto. econs. auto. admit. (* idem *) } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. + exists ([(id_cur, Bundle_call [Event_annot text [arg]] ef_id [val_to_eventval ge res] {| sig_args := [targ]; sig_res := targ; sig_cc := cc_default |} ([]))]). + exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_intra_call_external. all: eauto. + (* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) + { ss. } + { simpl. econstructor. auto. eauto. admit. (* idem *) } + { simpl. right. split; auto. econs; eauto. econs. auto. admit. (* idem *) } + { simpl. auto. } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + + - (* extcall is known and silent *) + rename H7 into EXTCALL, H8 into EXTARGS. unfold external_call_known_silents in ECKS. + des_ifs; ss; clarify. + { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. + exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. + } + { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. + exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. + } + { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. + } + { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs, v, (Genv.find_comp_of_block ge cur))]), m_a0, m_i, m'. simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + { eapply public_not_freeable_store; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. ss. } + { rewrite 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 ((Genv.find_comp_of_block ge cur), (- size_chunk Mptr), (Ptrofs.unsigned sz)); mem_delta_kind_store (Mptr, b0, (- size_chunk Mptr), (Vptrofs sz), (Genv.find_comp_of_block ge cur))]), m_a0, m_i, m'. + simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + { eapply public_not_freeable_store. 2: eauto. eapply public_not_freeable_alloc. + 3: eauto. all: auto. + eapply meminj_not_alloc_delta; eauto. + } + { setoid_rewrite Forall_app. split; auto. econs; auto. + { simpl. auto. } + econs; auto. simpl. hexploit Mem.alloc_result; eauto. hexploit meminj_not_alloc_delta; eauto. + intros. apply H1. lia. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. rewrite H. simpl. auto. } + { eapply public_rev_perm_store. 2: eauto. eapply public_rev_perm_alloc. + 2: eauto. all: auto. + } + } + { destruct ECKS as [_ OBS]. inv EXTCALL. + - exists [], k, (d ++ [mem_delta_kind_free (b0, (Ptrofs.unsigned lo - size_chunk Mptr)%Z, (Ptrofs.unsigned lo + Ptrofs.unsigned sz)%Z, Genv.find_comp_of_block ge cur)]), m_a0, m_i, m'. + simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + { eapply public_not_freeable_free; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. + eapply public_not_freeable_free_inj_none; eauto. + { unfold size_chunk. unfold Mptr. des_ifs; lia. } + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_free; eauto. } + - exists [], k, d, m_a0, m_i, m'. + simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + } + { destruct ECKS as [_ [OBS NPUB]]. inv EXTCALL. + exists [], k, (d ++ [mem_delta_kind_bytes (bdst, (Ptrofs.unsigned odst), bytes, Genv.find_comp_of_block ge cur)]), m_a0, m_i, m'. + simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + { eapply public_not_freeable_bytes; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. + clear - NPUB. simpl in NPUB. unfold meminj_public. des_ifs. exfalso. apply NPUB. + exists i. auto. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_bytes; eauto. } + } + + { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKS as [_ OBS]. inv EXTCALL. + exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. + } + + Admitted. + + Lemma asm_to_ir_builtin + (ge: genv) + m_a0 + (WFGE: wf_ge ge) + rs m st cur + (WFASM: wf_asm ge (State st rs m (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)))) + m_i ik k d + (MTST: match_state ge k m_a0 d (State st rs m (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero))) (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 (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) vargs m t1 vres m') + (* (ALLOWED: comp_of ef = comp_of f) *) + (ECC: external_call_conds ef ge m vargs) + : + exists (btr : bundle_trace) k' d' m_a0' m_i', + (unbundle_trace btr = t1) /\ + (istar ir_step ge (Some (cur, m_i, ik)) btr (Some (cur, m_i', ik))) /\ + (match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m'). + Proof. + ss. destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). + destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + destruct WFASM as [WFASM0 WFASM1]. + assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). + { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. + des_ifs. eapply wf_ge_block_to_id; eauto. + } + des. rename H into IDCUR. + exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. + + - (* extcall is unknown *) + exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. + intros. des. + exists ([(id_cur, Bundle_builtin t1 ef (vals_to_eventvals ge vargs) d)]). + do 4 eexists. splits; simpl. 3: eapply x3. apply app_nil_r. + econstructor 2. 2: econstructor 1. 2: eauto. + eapply ir_step_builtin; eauto. + { simpl in *. + admit. (* same problem *) } + { simpl in *. admit. (* same *) } + + - (* extcall is known and observable *) + unfold external_call_known_observables in ECKO. + des_ifs; simpl in *. + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([(id_cur, Bundle_builtin [Event_vload chunk id ofs0 ev] (EF_vload 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. + { ss. } + { simpl. econstructor. econstructor 1; eauto. admit. } + { simpl. right. split; auto. econs; eauto. econs. econs; eauto. admit. } + { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } + splits; auto. + } + { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([(id_cur, Bundle_builtin [Event_vstore chunk id ofs0 ev] (EF_vstore chunk) [EVptr_global id ofs0; ev] [])]). + exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_builtin. all: eauto. + (* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) + (* setoid_rewrite CURF. ss. *) + (* } *) + { ss. } + { instantiate (2:=[Vptr b0 ofs0; Val.load_result chunk v]). + simpl. econstructor. econstructor 1; eauto. admit. rewrite val_load_result_idem. auto. + } + { simpl. right. split; auto. splits; eauto. econs. econs; eauto. admit. rewrite val_load_result_idem. auto. + unfold load_whole_chunk in *. rewrite val_load_result_idem. auto. + } + { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. + f_equal. erewrite eventval_match_val_to_eventval; eauto. + } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. + exists ([(id_cur, Bundle_builtin [Event_annot text args] (EF_annot kind text targs) (vals_to_eventvals ge vargs) [])]). + exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_builtin. all: eauto. + (* { rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) + (* setoid_rewrite CURF. ss. *) + (* } *) + { ss. } + { simpl. econstructor. auto. admit. } + { simpl. right. split; auto. econs; eauto. econs. auto. admit. } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. + exists ([(id_cur, Bundle_builtin [Event_annot text [arg]] (EF_annot_val kind text targ) [val_to_eventval ge vres] [])]). + exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_builtin. all: eauto. + (* { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. *) + (* setoid_rewrite CURF. ss. *) + (* } *) + { ss. } + { simpl. econstructor. eauto. admit. } + { simpl. right. split; auto. econs; eauto. econs. auto. admit. } + { simpl. auto. } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + + - (* extcall is known and silent *) + unfold external_call_known_silents in ECKS. des_ifs; ss; clarify. + { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. + exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. + } + { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. + exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. + } + { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. + } + { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs0, v, Genv.find_comp_of_block ge cur)]), m_a0, m_i. simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + { eapply public_not_freeable_store; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. ss. + (* rewrite MTST1. rewrite CURPC. ss. unfold Genv.find_comp. setoid_rewrite CURF. auto. *) + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_store; eauto. } + } + { destruct ECKS as [_ OBS]. inv EXTCALL. + exists [], k, (d ++ [mem_delta_kind_alloc (Genv.find_comp_of_block ge cur, (- size_chunk Mptr), (Ptrofs.unsigned sz)); mem_delta_kind_store (Mptr, b0, (- size_chunk Mptr), (Vptrofs sz), Genv.find_comp_of_block ge cur)]), m_a0, m_i. + simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + { eapply public_not_freeable_store. 2: eauto. eapply public_not_freeable_alloc. + 3: eauto. all: auto. + eapply meminj_not_alloc_delta; eauto. + } + { setoid_rewrite Forall_app. split; auto. econs; auto. + { simpl. auto. } + econs; auto. simpl. hexploit Mem.alloc_result; eauto. hexploit meminj_not_alloc_delta; eauto. + intros. apply H1. lia. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. rewrite H. simpl. auto. } + { eapply public_rev_perm_store. 2: eauto. eapply public_rev_perm_alloc. + 2: eauto. all: auto. + } + } + { destruct ECKS as [_ OBS]. inv EXTCALL. + - exists [], k, (d ++ [mem_delta_kind_free (b0, (Ptrofs.unsigned lo - size_chunk Mptr)%Z, (Ptrofs.unsigned lo + Ptrofs.unsigned sz)%Z, Genv.find_comp_of_block ge cur)]), m_a0, m_i. + simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + { eapply public_not_freeable_free; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. + eapply public_not_freeable_free_inj_none; eauto. + { unfold size_chunk. unfold Mptr. des_ifs; lia. } + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_free; eauto. } + - exists [], k, d, m_a0, m_i. + simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + } + { destruct ECKS as [_ [OBS NPUB]]. inv EXTCALL. + exists [], k, (d ++ [mem_delta_kind_bytes (bdst, (Ptrofs.unsigned odst), bytes, Genv.find_comp_of_block ge cur)]), m_a0, m_i. + simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + { eapply public_not_freeable_bytes; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. + clear - NPUB. simpl in NPUB. unfold meminj_public. des_ifs. exfalso. apply NPUB. + exists i. auto. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_bytes; eauto. } + } + + { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKS as [_ OBS]. inv EXTCALL. + exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. + } + + Admitted. + + + Lemma asm_to_ir_returnstate_undef_nccc_external + (ge: genv) cur_comp 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 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_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + (RSX: rs X1 = Vundef) + t' ast' + (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') + t'' ast'' + (STAR: star_measure step ge n0 ast' t'' ast'') + (NCCC: Genv.type_of_call (Genv.find_comp_in_genv ge (rs PC)) cur_comp <> Genv.CrossCompartmentCall) + b1 ofs1 + (NEXTPC: rs PC = Vptr b1 ofs1) + ef + (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + inv STEP. inv EV; simpl in *. + 2:{ rewrite H in NCCC. congruence with NCCC. } + (** return is nccc *) + clear H. pose proof STAR as STAR0. inv STAR. + (* end case *) + { end_case. } + (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) + (* take a step *) + rename H into STEP, H0 into STAR. + + assert (st' = st). + { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. + admit. } + (* 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. + admit. + { rr; splits; eauto. } + clear STEP STAR. + intros (btr1 & k' & d' & m_a0' & m_i' & m_a' & UTR1 & ISTAR1 & MM' & (res & STAR)). + eapply asm_to_ir_compose. 2: eauto. do 2 eexists. split; eauto. clear btr1 UTR1 ISTAR1. + + assert (STUCK: (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) + # PC <- (rs X1) PC = Vundef). + { rewrite Pregmap.gss. auto. } + inv STAR. + (* end case *) + { exists []. eexists. split; auto. econstructor 1. } + (* now at Returnstate *) + inv H; simpl in *. rewrite Pregmap.gss in *. inv H0. + (* end case *) + { inv EV. + (* return is NCCC - silent *) + { exists []. simpl. eexists. split; auto. econstructor 1. } + (* return is CCC - return event *) + { unfold Genv.type_of_call in H. des_ifs. unfold update_stack_return in STUPD0. + clear H. rewrite Pregmap.gss in *. + admit. + (* 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 H6; inv H6. + Admitted. + + Lemma asm_to_ir_returnstate_ccc + (ge: genv) cur_comp 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 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_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + t' ast' + (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') + t'' ast'' + (STAR: star_measure step ge n0 ast' t'' ast'') + (CCC: Genv.type_of_call (Genv.find_comp_in_genv ge (rs PC)) cur_comp = Genv.CrossCompartmentCall) + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). + { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. + des_ifs. eapply wf_ge_block_to_id; eauto. + } + des. rename H into IDCUR. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + inv STEP. inv EV; simpl in *. + { rewrite CCC in H. congruence with H. } + (* TODO: add CHECKPUB to sem *) + (* clear H. specialize (CHECKPUB CCC). *) + (* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) + (* unfold Genv.type_of_call in CCC. des_ifs. clear CCC. unfold update_stack_return in STUPD. *) + (* rewrite Pos.eqb_sym in Heq. rewrite Heq in STUPD. des_ifs. *) + (* pose proof Heq as NEQ. eapply Pos.eqb_neq in NEQ. specialize (PC_RA NEQ). *) + (* destruct s as [b3 cp3 sig3 rv3 ptr3]. simpl in *. *) + (* inv WFASM1. simpl in *. des_ifs. clear H2. inv MTST2. *) + (* hexploit mem_delta_apply_establish_inject. eapply MEM0. 1,2,3,4: eauto. *) + (* { clear - CHECKPUB. ii. unfold public_first_order in CHECKPUB. unfold meminj_public in H. des_ifs. *) + (* eapply CHECKPUB; eauto. apply Senv.invert_find_symbol; auto. *) + (* } *) + (* intros (m_i' & APPD & MEMINJ). *) + (* exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. *) + (* { simpl. split; auto. unfold wf_regset. rewrite PC_RA. rewrite Heq0. auto. } *) + (* { instantiate (4:=(meminj_public ge)). instantiate (3:=m_a). instantiate (2:=[]). *) + (* instantiate (1:=Some (next, m_i', ik_tl)). simpl. splits; auto. *) + (* { inv WFIR1. simpl in *. auto. } *) + (* { inv WFIR1. auto. } *) + (* { unfold match_cur_regset. rewrite COMP. rewrite PC_RA. auto. } *) + (* { rr; splits; auto. eapply meminj_not_alloc_delta; eauto. ss. eapply public_rev_perm_delta_apply_inj; eauto. *) + (* } *) + (* } *) + (* intros (btr & ist' & UTR & ISTAR'). *) + (* exists ((id_cur, Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs PC)) (Genv.find_comp ge (Vptr cur Ptrofs.zero)) res] res d) :: btr), ist'. *) + (* simpl. rewrite UTR. split; auto. *) + (* econstructor 2. 2: eapply ISTAR'. 2: auto. *) + (* inv WFIR1. simpl in *. des_ifs. clear H2. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. *) + (* eapply ir_step_cross_return_internal. 6: eapply Heq1. all: eauto. *) + (* { rewrite COMP. rewrite PC_RA. simpl. auto. } *) + (* { constructor; auto. *) + (* { unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. } *) + (* { replace (funsig (Internal f2)) with sig3; auto. unfold match_cur_stack_sig in MTST0. des_ifs. } *) + (* } *) + (* { hexploit public_rev_perm_delta_apply_inj. eauto. eapply APPD. intros REVP. clear - MEMINJ CHECKPUB REVP. *) + (* unfold public_first_order in *. i. *) + (* exploit Senv.find_invert_symbol; eauto. intros INV. *) + (* assert (PERM: Mem.perm m_a b ofs Cur Readable). *) + (* { specialize (REVP b). unfold meminj_public in REVP. rewrite INV, PUBLIC in REVP. apply REVP. rewrite Z.add_0_r. auto. } *) + (* eapply loc_first_order_memval_inject_preserves. eapply CHECKPUB; eauto. *) + (* instantiate (1:=ge). inv MEMINJ. inv mi_inj. replace ofs with (ofs + 0)%Z at 2 by lia. eapply mi_memval; auto. *) + (* unfold meminj_public. rewrite INV, PUBLIC. auto. *) + (* } *) + Admitted. + + Lemma asm_to_ir_returnstate_undef + (ge: genv) cur_comp 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 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_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + (RSX: rs X1 = Vundef) + t' ast' + (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') + t'' ast'' + (STAR: star_measure step ge n0 ast' t'' ast'') + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + pose proof STEP as STEP0. inv STEP. inv EV; simpl in *. + (** return is nccc *) + { rename H into NCCC. pose proof STAR as STAR0. inv STAR. + (* end case *) + { end_case. } + (* has next step - if internal, done; if external, ub by RSX *) + rename H into STEP, H0 into STAR. exploit asm_step_current_pc. eapply STEP. intros (b1 & ofs1 & NEXTPC). + exploit asm_step_some_fundef. eapply STEP. eapply NEXTPC. intros (fd & NEXTF). + destruct fd. + (** next is internal *) + { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. + 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. + } + (** next is external --- undef *) + { exploit asm_to_ir_returnstate_undef_nccc_external. 2: eapply IH. + 12: eapply STAR0. 11: eapply STEP0. all: eauto. rr; splits; eauto. + } + } + (** return is ccc --- next is poped from the stack, which is internal, so done *) + { exploit asm_to_ir_returnstate_ccc. 2: eapply IH. + 11: eapply STAR. 10: eapply STEP0. all: eauto. rr; splits; eauto. + } + Qed. + + Lemma asm_to_ir_returnstate_nccc_external + (ge: genv) cur_comp 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 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_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + t' ast' + (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') + t'' ast'' + (STAR: star_measure step ge n0 ast' t'' ast'') + (NCCC: Genv.type_of_call (Genv.find_comp_in_genv ge (rs PC)) cur_comp <> Genv.CrossCompartmentCall) + b1 ofs1 + (NEXTPC: rs PC = Vptr b1 ofs1) + ef + (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + inv STEP. inv EV; simpl in *. + 2:{ rewrite H in NCCC. congruence with NCCC. } + (** return is nccc *) + clear H. pose proof STAR as STAR0. inv STAR. + (* end case *) + { end_case. } + (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) + (* take a step *) + rename H into STEP, H0 into STAR. + + assert (st' = st). + { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. + admit. } + (* 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. + admit. + { rr; splits; eauto. } + clear STEP STAR. + intros (btr1 & k' & d' & m_a0' & m_i' & m_a' & UTR1 & ISTAR1 & MM' & (res & STAR)). + eapply asm_to_ir_compose. 2: eauto. do 2 eexists. split; eauto. clear btr1 UTR1 ISTAR1. + + inv STAR. + (* end case *) + { exists []. eexists. split; auto. econstructor 1. } + (* now at Returnstate *) + eapply asm_to_ir_returnstate_undef. 2: eapply IH. 12: eapply H0. 11: eapply H. + all: eauto. lia. admit. + { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } + Admitted. + + Lemma asm_to_ir_returnstate + (ge: genv) cur_comp 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 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_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + t' ast' + (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') + t'' ast'' + (STAR: star_measure step ge n0 ast' t'' ast'') + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + pose proof STEP as STEP0. inv STEP. inv EV; simpl in *. + (** return is nccc *) + { rename H into NCCC. pose proof STAR as STAR0. inv STAR. + (* end case *) + { end_case. } + (* has next step - if internal, done; if external, one external step and X1 = undef *) + rename H into STEP, H0 into STAR. exploit asm_step_current_pc. eapply STEP. intros (b1 & ofs1 & NEXTPC). + exploit asm_step_some_fundef. eapply STEP. eapply NEXTPC. intros (fd & NEXTF). + destruct fd. + (** next is internal *) + { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. + 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. + } + (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) + { exploit asm_to_ir_returnstate_nccc_external. 2: eapply IH. + 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. + } + } + (** return is ccc --- next is poped from the stack, which is internal, so done *) + { exploit asm_to_ir_returnstate_ccc. 2: eapply IH. + 11: eapply STAR. 10: eapply STEP0. all: eauto. rr; splits; eauto. + } + Qed. + + Lemma asm_to_ir_nccc_internal + ge cur_comp 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 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 cur_comp)) + ist k d + (MTST: match_state ge k m_a0 d (State st rs m cur_comp) ist) + t2 rs' m' + (STAR: star_measure step ge n (State st rs' m' cur_comp) 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_in_genv 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 H9; inv H9; rewrite NEXTF in H10; inv H10. + } + } + unfold match_state in MTST. destruct ist as [[[cur m_i] ik] |]. + 2:{ inv MTST. } + destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + exploit mem_delta_exec_instr. eapply MEM3. eapply H3. + { replace (comp_of f) with (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)). eapply MEM4. + rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp_in_genv. + admit. } + eapply MEM5. auto. intros (d' & MEM4' & MEM5'). + destruct f0. + + (** has next function --- internal *) + { assert (WFASM': wf_asm ge (State st rs' m' cur_comp)). + { 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' cur_comp) (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_in_genv. rewrite H0. + admit. + (* unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. *) + (* rewrite H1. auto. *) + } + split. auto. + { unfold match_mem. splits; auto. + eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. + { replace (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. + rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp_in_genv. + admit. + (* setoid_rewrite H1. auto. *) + } + eapply public_rev_perm_exec_instr. 3: eapply H3. all: auto. + } + } + exploit IH. 4: eapply STAR. 3: apply WFASM'. 3: eapply MTST'. all: auto. + } + + (** has next function --- external *) + { move STAR after NEXTF. inv STAR. + (* end case *) + { end_case. } + (* take a step *) + destruct WFASM as [WFASM0 WFASM1]. + exploit asm_to_ir_step_external. 12: eapply H4. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply H. all: eauto. + { inv H. + 1,2,3,4: rewrite NEXTPC in H9; inv H9; rewrite NEXTF in H10; inv H10. + (* rewrite <- REC_CURCOMP. *) + (* rewrite H9. *) + rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H9; inv H9. + admit. + (* rewrite <- ALLOWED. *) + (* unfold Genv.find_comp. setoid_rewrite H1. auto. *) + } + { instantiate (4:=k). instantiate (3:=d'). unfold match_mem. splits; eauto. + eapply public_not_freeable_exec_instr; eauto. eapply meminj_not_alloc_delta; eauto. + { replace (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. + rewrite MTST1. rewrite H0. ss. + admit. + (* unfold Genv.find_comp. setoid_rewrite H1. auto. *) + } + eapply public_rev_perm_exec_instr; eauto. + } + intros (btr' & k' & d'0 & m_a0' & m_i' & m_a' & UTR' & ISTAR' & MM' & (res' & STAR')). + eapply asm_to_ir_compose. 2: eauto. + exists btr'. eexists. split. + { split; auto. eapply ISTAR'. } + clear btr' UTR' ISTAR'. rename H into STEP0, H4 into STAR0. + inv STAR'. + { end_case. } + exploit asm_to_ir_returnstate_undef. 2: eapply IH. 12: eapply H4. 11: eapply H. 9: eapply MM'. all: eauto. + { lia. } + { inv STEP0. + 1,2,3,4: rewrite NEXTPC in H9; inv H9; rewrite NEXTF in H10; inv H10. + (* rewrite <- REC_CURCOMP. *) + (* rewrite H9. *) + rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H9; inv H9. + (* rewrite <- ALLOWED. *) + admit. + (* unfold Genv.find_comp. setoid_rewrite H1. auto. *) + } + { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } + } + Admitted. + + (* Admitted: doesn't apply anymore, AFAIK! *) + (* 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 (comp_of f) (Genv.find_comp_in_genv 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_in_genv 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_in_genv ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl). *) + (* Proof. *) + (* assert (EQC : Genv.find_comp ge (Vptr b Ptrofs.zero) = comp_of f). *) + (* { unfold Genv.find_comp. setoid_rewrite H1. auto. } *) + (* assert (EQC2 : Genv.find_comp ge (Vptr b0 Ptrofs.zero) = comp_of e). *) + (* { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } *) + (* do 3 eexists. *) + (* ss. splits; auto. *) + (* - eapply Genv.invert_find_symbol; auto. *) + (* - replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. *) + (* - econs; auto. *) + (* + unfold Genv.type_of_call. *) + (* replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. *) + (* replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. *) + (* + replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. *) + (* replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. *) + (* Qed. *) + + Lemma arguments_same + rs m sig args1 args2 + (CARGS: call_arguments rs m sig args1) + (EARGS: extcall_arguments rs m sig args2) + : + args1 = args2. + Proof. + unfold call_arguments in CARGS. unfold extcall_arguments in EARGS. + unfold Conventions.loc_parameters in CARGS. remember (Conventions1.loc_arguments sig) as clas. clear dependent sig. + move args1 after rs. revert_until args1. induction args1; ss; intros. + { inv CARGS. symmetry in H0. apply map_eq_nil in H0. subst. inv EARGS. auto. } + inv CARGS. symmetry in H. apply map_eq_cons in H. des; clarify. + inv EARGS. f_equal. + 2:{ eapply IHargs1; eauto. } + clear - H2 H1. inv H1; ss. + - inv H2. inv H. + + ss. inv H1; auto. + + inv H1; auto. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H2, H5. rewrite H2 in H5. inv H5. auto. + - inv H2. inv H. + + inv H0. + * inv H4. inv H6. auto. + * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H1, H4. rewrite H1 in H4. inv H4. auto. + + inv H0. + * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H2, H5. rewrite H2 in H5. inv H5. auto. + * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H1, H2, H5, H7. rewrite H2 in H7. rewrite H1 in H5. clarify. + Qed. + + + (* If main is External, treat it as a different case - *) +(* the trace can start with Event_syscall, without a preceding Event_call *) + Theorem asm_to_ir + (ge: genv) m_a0 + ast ast' tr + (WFGE: wf_ge ge) + (WFASM: wf_asm ge ast) + (STAR: star step ge ast tr ast') + ist k d + (MTST: match_state ge k m_a0 d ast ist) + : + exists btr ist', (unbundle_trace btr = tr) /\ (istar (ir_step) ge ist btr ist'). + Proof. + apply measure_star in STAR. destruct STAR as (n & STAR). + move n before ge. revert m_a0 ast ast' tr WFGE WFASM STAR ist k d MTST. + pattern n. apply (well_founded_induction Nat.lt_wf_0). intros n1 IH. intros. + inv STAR; subst. + (* end case *) + { end_case. } + rename H0 into STAR. inv H; simpl. + + - (** internal *) + eapply asm_to_ir_nccc_internal; eauto. + (* NOTE: not the right [cp]? *) admit. + + - (** internal_call *) + assert (EQC: (Genv.find_comp_in_genv ge (Vptr b Ptrofs.zero)) = (comp_of f)). + { ss. unfold Genv.find_comp_in_genv. + admit. } + (* setoid_rewrite H1. auto. } *) + destruct (Genv.type_of_call (comp_of f) (Genv.find_comp_in_genv 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. + admit. } + (* 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. + admit. } + (* rewrite Pos.eqb_eq in Heq. auto. } *) + intros RES. inv EV. simpl. apply RES. + simpl in *. rewrite TYPEC in H. inv H. + } + + (* case ccc *) + { destruct ist as [[[cur m_i] ik] |]; ss. + destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). + destruct WFASM as [WFASM0 WFASM1]. + (* specialize (CALLSIG eq_refl). des. *) + exploit exec_instr_is_call; eauto. clear H2 H3 H4. intros (RSX & MEM). subst m'. + assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). + { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. + des_ifs. eapply wf_ge_block_to_id; eauto. + } + des. rename H into IDCUR. + (* destruct fd. *) + (* calling internal function *) + { admit. } + (* { inv EV. *) + (* { rewrite TYPEC in H. clarify. } *) + (* clear H. clarify. unfold update_stack_call in STUPD. des_ifs. *) + (* { unfold Genv.type_of_call in TYPEC. rewrite NEXTPC in Heq. rewrite <- EQC in TYPEC. ss. rewrite Heq in TYPEC. inv TYPEC. } *) + (* ss. eapply asm_to_ir_compose. *) + (* 2:{ instantiate (2:=[Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl]). simpl. eauto. } *) + (* assert (EQC2: (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) = comp_of f0). *) + (* { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } *) + (* specialize (CHECKPUB eq_refl). *) + (* pose proof MTST3 as MEM. destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). *) + (* hexploit mem_delta_apply_establish_inject. eapply MEM0. 1,2,3,4: eauto. *) + (* { clear - CHECKPUB. ii. unfold public_first_order in CHECKPUB. unfold meminj_public in H. des_ifs. *) + (* eapply CHECKPUB; eauto. apply Senv.invert_find_symbol; auto. *) + (* } *) + (* intros (m_i' & APPD & MEMINJ). *) + (* exists ([(id_cur, Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (fn_sig f0) d)]). eexists. split. *) + (* { simpl. split; auto. econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_cross_call_internal. *) + (* 7: eauto. 6: intros; eapply NO_CROSS_PTR; auto. 3: setoid_rewrite CALLSIG; auto. 3,4: eauto. *) + (* { rewrite MTST1. rewrite <- EQC, H0. simpl. auto. } *) + (* { apply Genv.invert_find_symbol; auto. } *) + (* { econs; auto. } *) + (* { replace (comp_of f) with (Genv.find_comp ge (Vptr cur Ptrofs.zero)). eapply APPD. rewrite MTST1. rewrite H0. ss. } *) + (* { hexploit public_rev_perm_delta_apply_inj. eauto. eapply APPD. intros REVP. clear - MEMINJ CHECKPUB REVP. *) + (* unfold public_first_order in *. i. *) + (* exploit Senv.find_invert_symbol; eauto. intros INV. *) + (* assert (PERM: Mem.perm m b ofs Cur Readable). *) + (* { specialize (REVP b). unfold meminj_public in REVP. rewrite INV, PUBLIC in REVP. apply REVP. rewrite Z.add_0_r. auto. } *) + (* eapply loc_first_order_memval_inject_preserves. eapply CHECKPUB; eauto. *) + (* instantiate (1:=ge). inv MEMINJ. inv mi_inj. replace ofs with (ofs + 0)%Z at 2 by lia. eapply mi_memval; auto. *) + (* unfold meminj_public. rewrite INV, PUBLIC. auto. *) + (* } *) + (* auto. *) + (* } *) + (* rewrite H0 in RSX. simpl in RSX. inv RSX. *) + (* eapply IH. 4: eapply STAR. all: auto. *) + (* { ss. split. *) + (* - econs; auto. ss. rewrite H1. auto. *) + (* - unfold wf_regset. rewrite NEXTPC. rewrite CALLSIG. auto. *) + (* } *) + (* unfold match_state. splits; eauto. *) + (* - unfold wf_ir_cur. rewrite CALLSIG. auto. *) + (* - econs; eauto. *) + (* - unfold match_cur_stack_sig. rewrite CALLSIG. ss. *) + (* - unfold match_cur_regset. rewrite NEXTPC. ss. *) + (* - econs; eauto. rewrite MTST1. rewrite H0. ss. *) + (* - instantiate (3:=(meminj_public ge)). instantiate (2:=[]). instantiate (1:=m). *) + (* rr; splits; auto. eapply meminj_not_alloc_delta; eauto. ss. eapply public_rev_perm_delta_apply_inj; eauto. *) + (* } *) + + (* calling external function *) + (* { assert (EQC2: (Genv.find_comp ge (Vptr b' Ptrofs.zero)) = comp_of e). *) + (* { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } *) + (* inv EV. *) + (* { rewrite TYPEC in H. clarify. } *) + (* clear H. clarify. unfold update_stack_call in STUPD. des_ifs. *) + (* { unfold Genv.type_of_call in TYPEC. rewrite NEXTPC in Heq. rewrite <- EQC in TYPEC. ss. rewrite Heq in TYPEC. inv TYPEC. } *) + (* pose proof STAR as STAR0. move STAR after H4. *) + (* exploit asm_to_ir_ccc_external1. eapply MTST1. eapply H0. eapply H1. eapply ALLOWED. eapply NEXTPC. all: auto. eapply CALLSIG. eapply H3. eapply H4. *) + (* intros (cp & cp' & sg & FACT1 & FACT2 & FACT3 & FACT4 & FACT5 & FACT6 & FACT7 & FACT8). subst. *) + (* inv STAR; ss. *) + (* (* subcase 1 *) *) + (* { exists ([(id_cur, Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (ef_sig e) [])]). eexists. ss. split; auto. *) + (* econs 2. 2: econs 1. 2: eauto. eapply ir_step_cross_call_external1. *) + (* 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply FACT3. 2: eapply FACT2. all: eauto. *) + (* } *) + (* rename H into STEP, H2 into STAR, TYPEC into CCC, CALLSIG into NEXTF. inv STEP. *) + (* 1,2,3,4: rewrite NEXTPC in H6; inv H6; rewrite NEXTF in H7; inv H7. *) + (* rewrite NEXTPC in H6; inv H6. rewrite NEXTF in H7; inv H7. ss. clear REC_CURCOMP. rename H8 into EXTCALL, H11 into EXTARGS. *) + (* assert (NEQCP: comp_of f <> comp_of ef). *) + (* { rewrite <- EQC2. clear - CCC. intros CC. unfold Genv.type_of_call in CCC. rewrite CC in CCC. rewrite Pos.eqb_refl in CCC. inv CCC. } *) + (* exploit extcall_cases. eapply ECC. eapply EXTCALL. clear ECC. rewrite <- or_assoc. intros [ECC | ECC]. *) + (* 2:{ exfalso. clear - NEXTF NEQCP ALLOWED ECC. destruct ALLOWED as [A | A]. *) + (* { rewrite A in NEQCP. unfold Genv.find_comp in NEQCP. setoid_rewrite NEXTF in NEQCP. auto. } *) + (* unfold Genv.allowed_cross_call in A. destruct A as (i & cp' & INV & OK & _). unfold Genv.find_funct_ptr in NEXTF. specialize (OK _ NEXTF). *) + (* destruct ef; ss; clarify. des_ifs. des_ifs. *) + (* { destruct ECC as [ECC1 ECC2]. subst. inv ECC1. } *) + (* { destruct ECC as [ECC1 ECC2]. subst. inv ECC1. } *) + (* } *) + (* exploit arguments_same; eauto. intros EQ. subst args0. *) + (* exploit match_mem_external_call_establish; eauto. intros. *) + (* destruct x0 as (d' & m1 & m2 & res' & EFACT1 & EFACT2 & EFACT3 & (k2 & d2 & m_a02 & MM)). *) + (* inv STAR. *) + (* (* subcase 2 *) *) + (* { exists ([(id_cur, Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1) i0 vl (ef_sig ef) (d'))]). eexists. split; auto. *) + (* econs 2. 2: econs 1. 2: eauto. eapply ir_step_cross_call_external2. *) + (* 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply FACT3. 2: eapply FACT2. all: eauto. *) + (* erewrite eventval_list_match_vals_to_eventvals; eauto. *) + (* } *) + (* rename H into STEP, H2 into STAR. inv STEP. ss. rewrite Pregmap.gss in *. destruct MM as [MM VAL]. *) + (* (* subcase 3 *) *) + (* pose proof WFIR0 as CUR. unfold wf_ir_cur in CUR. des_ifs. clear CUR. rename Heq1 into CUR. *) + (* unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. des_ifs. *) + (* { exfalso. rewrite Heq0, RSX, H0 in Heq1. ss. rewrite Pos.eqb_sym, Heq in Heq1. congruence with Heq1. } *) + (* clear PC_RA. inv EV. *) + (* { exfalso. apply H. rewrite Heq0, RSX, H0. ss. unfold Genv.type_of_call. rewrite Heq. auto. } *) + (* assert (RES: (return_value (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) (ef_sig ef)) = res). *) + (* { exploit NO_CROSS_PTR0; auto. clear. intros NPTR. *) + (* unfold return_value, loc_external_result in *. remember (Conventions1.loc_result (ef_sig ef)) as rpmr. *) + (* unfold Conventions1.loc_result in Heqrpmr. des_ifs. *) + (* ss. rewrite ! (Pregmap.gso (j:=PC)) in *; ss. rewrite ! Pregmap.gss in *. rewrite Pregmap.gso, Pregmap.gss in *; ss. *) + (* unfold Val.longofwords, Val.hiword, Val.loword in *. des_ifs. *) + (* rewrite Int64.ofwords_recompose. auto. *) + (* } *) + (* eapply asm_to_ir_compose. *) + (* 2:{ instantiate (1:=t3). rewrite app_comm_cons. setoid_rewrite app_assoc. eauto. } *) + (* exists ([(id_cur, Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1 ++ [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0]) i0 vl (ef_sig ef) (d'))]). eexists. split. *) + (* { split; auto. *) + (* { ss. rewrite app_nil_r. auto. } *) + (* econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_cross_call_external3. *) + (* 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply NEXTF. 2: eapply FACT2. all: eauto. *) + (* { erewrite eventval_list_match_vals_to_eventvals; eauto. } *) + (* { intros. exploit NO_CROSS_PTR0; auto. rewrite RES. clear - VAL. intros. destruct VAL as [VAL | VAL]. *) + (* - pose proof Val.inject_list_not_ptr. specialize (H k2 [res] [res']). exploit H. econs; eauto. econs; eauto. intros. inv x1. auto. *) + (* - subst; auto. *) + (* } *) + (* { econs; eauto. *) + (* - setoid_rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. clear - NEQCP. *) + (* unfold Genv.type_of_call. rewrite <- Pos.eqb_neq in NEQCP. setoid_rewrite NEQCP. auto. *) + (* - instantiate (1:=res0). rewrite RES in H2, NO_CROSS_PTR0. exploit NO_CROSS_PTR0; auto. intros NPTR. *) + (* clear - H2 NPTR VAL. destruct VAL as [VAL | VAL]; subst; auto. remember (proj_rettype (sig_res (ef_sig ef))) as ty. clear dependent ef. *) + (* inv VAL; ss; eauto. *) + (* - f_equal. f_equal. rewrite Heq0, RSX. rewrite MTST1, H0. ss. rewrite NEXTPC. ss. *) + (* } *) + (* } *) + (* rewrite H0 in RSX. ss. inv RSX. eapply IH. 4: eapply STAR. all: auto. *) + (* { ss. splits; auto. unfold wf_regset in *. rewrite Pregmap.gss. rewrite Heq0. rewrite H1. auto. } *) + (* { ss. splits; auto. *) + (* - unfold match_cur_regset in *. rewrite Pregmap.gss. rewrite Heq0. rewrite MTST1. rewrite H0. ss. *) + (* - eauto. *) + (* } *) + (* } *) + } + + - (** internal_return *) + destruct ist as [[[cur m_i] ik] |]; ss. + destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). + destruct WFASM as [WFASM0 WFASM1]. + inv STAR. + { end_case. } + rename H into STEP, H5 into STAR. + exploit exec_instr_is_return. eapply H3. auto. intros ((v & NEXTPC) & TEMP). subst m'. + eapply asm_to_ir_returnstate. 2: eapply IH. 11: eapply STAR. 10: eapply STEP. + all: eauto. + admit. + (* { rewrite <- REC_CURCOMP. apply MTST1. } *) + + - (** return *) + exfalso. unfold wf_asm in WFASM. contradiction WFASM. + + - (** builtin *) + destruct ist as [[[cur m_i] ik] |]; ss. + exploit asm_to_ir_builtin; eauto. + admit. admit. + destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). + clear dependent k. clear dependent d. clear dependent m_a0. + intros (btr1 & k & d & m_a & m_i' & UTR1 & ISTAR1 & MEM). + eapply asm_to_ir_compose. 2: eauto. exists btr1. eexists. split. + { split; eauto. } + clear dependent btr1. clear dependent m_i. rename m_i' into m_i. + destruct WFASM as [WFASM0 WFASM1]. + (* remember (nextinstr (set_res (map_builtin_res preg_of res) vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs # X1 <- Vundef) # X31 <- Vundef))) as rs'. *) + (* assert (NEXTPC: rs' PC = Val.offset_ptr (rs PC) Ptrofs.one). *) + (* { subst rs'. clear. unfold nextinstr. simpl. *) + (* rewrite Pregmap.gss. f_equal. rewrite ! Asmgenproof0.set_res_other; ss. *) + (* rewrite Asmgenproof0.undef_regs_other_2. *) + (* rewrite Pregmap.gso. rewrite Pregmap.gso. all: ss; auto. *) + (* rewrite Asmgenproof0.preg_notin_charact. intros. destruct mr; ss. *) + (* } *) + (* eapply IH. 4: eapply STAR. all: auto. *) + (* { simpl. split; auto. unfold wf_regset in *. rewrite NEXTPC, H0. simpl. rewrite H1. auto. } *) + (* { simpl. splits. 6: eapply MEM. all: auto. unfold match_cur_regset in *. *) + (* rewrite NEXTPC, H0. ss. rewrite MTST1, H0. ss. *) + (* } *) + admit. + + - (** external *) + exfalso. destruct WFASM as [WFASM0 WFASM1]. unfold wf_regset in WFASM1. + rewrite H0 in WFASM1. rewrite H1 in WFASM1. contradiction WFASM1. + + Admitted. + +End PROOF. + +Section INIT. + + Definition wf_program {F V} {CF: has_comp F} (p: AST.program F V) := list_norepet (prog_defs_names p). + + Lemma wf_program_wf_ge + F V {CF: has_comp F} (p: AST.program F V) + (WFP: wf_program p) + : + wf_ge (Genv.globalenv p). + Proof. unfold wf_ge; eauto. + exists p; do 2 (split; eauto). + admit. + Admitted. + + Definition wf_main (p: Asm.program) := + exists b, (Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b) /\ + (exists f, Genv.find_funct_ptr (Genv.globalenv p) b = Some (Internal f)). + + Definition wf_main_sig (p: Asm.program) := + forall b f, (Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b) -> + (Genv.find_funct_ptr (Genv.globalenv p) b = Some (Internal f)) -> + fn_sig f = signature_main. + + Lemma wf_asm_initial_state + p ast + (WFMAIN: wf_main p) + (INIT: initial_state p ast) + : + wf_asm (Genv.globalenv p) ast. + Proof. + unfold wf_main in WFMAIN. des. inv INIT. unfold wf_asm. split. + { unfold initial_stack. ss. } + { unfold wf_regset. subst rs0. rewrite Pregmap.gso; ss. rewrite Pregmap.gso; ss. rewrite Pregmap.gss. + (* unfold fundef in *. *) + unfold Genv.symbol_address. subst ge. rewrite WFMAIN, WFMAIN0. auto. + } + Qed. + + Variant ir_initial_state (p: Asm.program): ir_state -> Prop := + | ir_initial_state_intro: forall cur m0, + let ge := Genv.globalenv p in + Genv.find_symbol ge (prog_main p) = Some cur -> + (exists f, Genv.find_funct_ptr ge cur = Some (Internal f)) -> + Genv.init_mem p = Some m0 -> + ir_initial_state p (Some (cur, m0, [])). + + Lemma ir_has_initial_state + p ast + (WFMAIN: wf_main p) + (INIT: Asm.initial_state p ast) + : + exists ist, ir_initial_state p ist. + Proof. + unfold wf_main in WFMAIN. des. inv INIT. + exists (Some (b, m0, [])). econs; eauto. + Qed. + + Lemma match_state_initial_state + p ast ist + (WFMAINSIG: wf_main_sig p) + (INITA: Asm.initial_state p ast) + (INITI: ir_initial_state p ist) + ge + (GE: ge = Genv.globalenv p) + : + exists m0 j, (Genv.init_mem p = Some m0) /\ (match_state ge j m0 [] ast ist). + Proof. + inv INITA. inv INITI. des. specialize (WFMAINSIG _ _ H0 H1). + clarify. exists m0, (Mem.flat_inj (Mem.nextblock m0)). esplits; eauto. unfold match_state. subst ge. splits. + - unfold wf_ir_cur. rewrite H1. auto. + - econs. + - unfold match_cur_stack_sig. rewrite H1. ss. + - unfold match_cur_regset. subst rs0. rewrite Pregmap.gso; ss. rewrite Pregmap.gso; ss. rewrite Pregmap.gss. + unfold Genv.symbol_address. subst ge0. rewrite H0. ss. + - econs. + - unfold match_mem. + assert (MNA: meminj_not_alloc (meminj_public (Genv.globalenv p)) m0). + { unfold meminj_not_alloc. intros. unfold meminj_public. des_ifs. exfalso. apply Senv.invert_find_symbol in Heq. exploit Genv.find_symbol_not_fresh. eauto. + eapply Heq. intros CC. unfold Mem.valid_block in CC. unfold Plt in CC. lia. + } + splits; ss; auto. + + eapply Genv.initmem_inject; eauto. + + ii. unfold meminj_public in H. unfold Mem.flat_inj. des_ifs. exfalso. + apply n; clear n. unfold Plt. destruct (Pos.ltb_spec b' (Mem.nextblock m0)); auto. + exfalso. specialize (MNA _ H). unfold meminj_public in MNA. rewrite Heq, Heq0 in MNA. clarify. + + ii. unfold meminj_public in H. des_ifs. clear - Heq Heq0 H3 H2. exploit Senv.invert_find_symbol; eauto. intros FIND. rename H2 into INITM, H3 into FREE. clear - INITM FREE FIND. + eapply Genv.find_symbol_find_def_inversion in FIND. des. destruct g. + * exploit Genv.init_mem_characterization_2; eauto. + { unfold Genv.find_funct_ptr. rewrite FIND. eauto. } + intros [CUR CC]. exploit CC. eapply FREE. intros. des; clarify. + * exploit Genv.init_mem_characterization; eauto. + { unfold Genv.find_var_info. rewrite FIND. eauto. } + intros [_ [CC [_ _]]]. exploit CC. eapply FREE. intros. des. clear - x1. unfold Genv.perm_globvar in x1. des_ifs; inv x1. + + ii. unfold meminj_public. des_ifs. intros. rewrite Z.add_0_r in H. auto. + Qed. + +End INIT. diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index 786b570085..bf8f8760a5 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -737,8 +737,113 @@ Section PROOFS. 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. *) + Section VISIBLE. + + (* Memory location has only sequence of bytes *) + Definition loc_first_order (m: mem) (b: block) (ofs: Z) : Prop := + match (ZMap.get ofs (Mem.mem_contents m) !! b) with + | Byte _ => True + | _ => False + end. + + (* Public symbols are visible outside the compilation unit, + so when interacting via external calls, limit them to first-order (if Readable). *) + Definition public_first_order (ge: Senv.t) (m: mem) := + forall id b ofs + (PUBLIC: Senv.public_symbol ge id = true) + (FIND: Senv.find_symbol ge id = Some b) + (READABLE: Mem.perm m b ofs Cur Readable), + loc_first_order m b ofs. + + Definition block_public (ge: Senv.t) (b: block): Prop := + exists id, Senv.invert_symbol ge b = Some id /\ Senv.public_symbol ge id = true. + + Variant val_public (ge: Senv.t) : typ -> val -> Prop := + | val_public_int: forall i, val_public ge Tint (Vint i) + | val_public_long: forall i, val_public ge Tlong (Vlong i) + | val_public_float: forall f, val_public ge Tfloat (Vfloat f) + | val_public_single: forall f, val_public ge Tsingle (Vsingle f) + | val_public_ptr: forall b ofs, block_public ge b -> val_public ge Tptr (Vptr b ofs). + + Definition vals_public (ge: Senv.t) (ts: list typ) (vs: list val): Prop := + Forall2 (val_public ge) ts vs. + + Definition visible_fo (ge: Senv.t) (m: mem) (tys: list typ) (args: list val): Prop := + public_first_order ge m /\ vals_public ge tys args. + + Definition EF_memcpy_dest_not_pub (ge: Senv.t) (args: list val) := + match args with + | (Vptr bdst _) :: tl => ~ (block_public ge bdst) + | _ => True + end. + + Definition load_whole_chunk (ch: memory_chunk) (v: val) := Val.load_result ch v = v. + + Definition EF_vstore_load_whole_chunk (ch: memory_chunk) (args: list val) := + match args with + | _ :: v :: nil => load_whole_chunk ch v + | _ => True + end. + + Definition external_call_conds + (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) : Prop := + match ef with + | EF_external name sg => visible_fo ge m (sig_args sg) args + | EF_builtin name sg | EF_runtime name sg => + match Builtins.lookup_builtin_function name sg with + | None => visible_fo ge m (sig_args sg) args + | _ => True + end + | EF_inline_asm txt sg clb => visible_fo ge m (sig_args sg) args + | EF_memcpy sz al => EF_memcpy_dest_not_pub ge args + | EF_vstore ch => EF_vstore_load_whole_chunk ch args + | _ => True + end. + + Definition external_call_unknowns + (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) : Prop := + match ef with + | EF_external name sg => visible_fo ge m (sig_args sg) args + | EF_builtin name sg | EF_runtime name sg => + match Builtins.lookup_builtin_function name sg with + | None => visible_fo ge m (sig_args sg) args + | _ => False + end + | EF_inline_asm txt sg clb => visible_fo ge m (sig_args sg) args + | _ => False + end. + + Definition external_call_known_observables + (ef: external_function) (ge: Senv.t) (cp: compartment) (m: mem) (args: list val) tr rv m' : Prop := + match ef with + | EF_external name sg => False + | EF_builtin name sg | EF_runtime name sg => False + | EF_inline_asm txt sg clb => False + | EF_vstore ch => + (external_call ef ge cp args m tr rv m') /\ (tr <> E0) /\ (EF_vstore_load_whole_chunk ch args) + | _ => (external_call ef ge cp args m tr rv m') /\ (tr <> E0) + end. + + Definition external_call_known_silents + (ef: external_function) (ge: Senv.t) (cp: compartment) (m: mem) (args: list val) tr rv m': Prop := + match ef with + | EF_external name sg => False + | EF_builtin name sg | EF_runtime name sg => + match Builtins.lookup_builtin_function name sg with + | None => False + | _ => True + end + | EF_inline_asm txt sg clb => False + | EF_memcpy sz al => + (external_call ef ge cp args m E0 rv m') /\ (tr = E0) /\ (EF_memcpy_dest_not_pub ge args) + | _ => (external_call ef ge cp args m E0 rv m') /\ (tr = E0) + end. + + + +End VISIBLE. + 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. @@ -747,25 +852,24 @@ Section PROOFS. 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) *) + (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. *) + unfold loc_first_order in FO. ss. exploit Mem.store_mem_contents; eauto. intros CNT. - (* rewrite CNT in FO. *) + rewrite CNT in FO. remember (Ptrofs.unsigned i) as ofs0. - (* rewrite PMap.gss in FO. *) - remember ((Mem.mem_contents m) !! b) as mcv. clear - mcv (* FO *) CHG. + 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 - IN. + clear - FO IN. destruct ch; destruct v; ss; des; clarify. 1,2: des_ifs; ss; des; clarify. - all: admit. (* very bad break? *) - Admitted. + Qed. Lemma list_forall_filter A (P: A -> Prop) l B @@ -791,11 +895,11 @@ Section PROOFS. (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) *) + (FO: loc_first_order m1' b ofs) : ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. Proof. - revert WF CHG m1 m1' m2 m2' APPD1 APPD2 PERM1 PERM2 (* FO *). induction d; intros. + revert WF CHG m1 m1' m2 m2' APPD1 APPD2 PERM1 PERM2 FO. induction d; intros. { inv CHG. } rewrite mem_delta_apply_cons in APPD1. rewrite mem_delta_apply_wf_cons in APPD2. inv WF. rename H1 into WF1, H2 into WF2. inv CHG. (* not chagned by the head *) @@ -850,8 +954,8 @@ Section PROOFS. { eapply Mem.perm_store_1; eauto. } intros H. rewrite H. ss. - (* assert (FO2: loc_first_order mi1 b ofs). *) - (* { unfold loc_first_order in *. rewrite <- H. auto. } *) + 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. destruct (cp_eq_dec cp cp); try contradiction. @@ -1026,20 +1130,18 @@ Section PROOFS. eapply Mem.perm_free_3; eauto. eapply IHd. erewrite Mem.nextblock_free; eauto. Qed. - (* Lemma loc_first_order_always_memval_inject *) - (* m b ofs *) - (* (FO: loc_first_order m b ofs) *) - (* j v *) - (* (VINJ: memval_inject j (ZMap.get ofs (Mem.mem_contents m) !! b) v) *) - (* : *) - (* forall k, memval_inject k (ZMap.get ofs (Mem.mem_contents m) !! b) v. *) - (* Proof. *) - (* (* unfold loc_first_order in FO. *) *) - (* destruct (ZMap.get ofs (Mem.mem_contents m) !! b) eqn:MV; try contradiction. *) - (* inv VINJ. intros. constructor. *) - (* inv VINJ. intros. constructor. *) - (* inv VINJ. intros. constructor. *) - (* Qed. *) + Lemma loc_first_order_always_memval_inject + m b ofs + (FO: loc_first_order m b ofs) + j v + (VINJ: memval_inject j (ZMap.get ofs (Mem.mem_contents m) !! b) v) + : + forall k, memval_inject k (ZMap.get ofs (Mem.mem_contents m) !! b) v. + Proof. + unfold loc_first_order in FO. + destruct (ZMap.get ofs (Mem.mem_contents m) !! b) eqn:MV; try contradiction. + inv VINJ. intros. constructor. + Qed. Lemma mem_delta_apply_establish_inject (ge: Senv.t) (k: meminj) m0 m0' @@ -1050,7 +1152,7 @@ Section PROOFS. (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) *) + (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. @@ -1067,25 +1169,23 @@ Section PROOFS. - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. { inv INJ. inv mi_inj. specialize (mi_memval _ _ _ _ (INCR _ _ _ INJPUB) PERM0). - (* eapply loc_first_order_always_memval_inject; eauto. *) - (* exploit FO. *) - (* erewrite INJPUB. *) - (* congruence. eauto. unfold loc_first_order; intros. *) + 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. - admit. admit. admit. - (* erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. *) + erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. } { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } - (* { exploit FO; eauto. rewrite INJPUB. congruence. } *) + { 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. *) + 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. - admit. admit. - Admitted. + Qed. Import Mem. @@ -1101,7 +1201,7 @@ Section PROOFS. (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) *) + (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. @@ -1124,22 +1224,20 @@ Section PROOFS. - 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). - admit. - (* 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 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. } *) + { 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. *) + 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. - admit. admit. - Admitted. + Qed. Lemma mem_delta_apply_establish_inject_preprocess_gen (ge: Senv.t) (k: meminj) m0 m0' @@ -1155,14 +1253,14 @@ Section PROOFS. (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'). + ((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. *) + 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). @@ -1177,21 +1275,19 @@ Section PROOFS. - 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). - admit. - (* 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 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. } *) + { 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. *) + 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. - admit. admit. - Admitted. + Qed. End PROOFS. From 3d6903d7713a240355ee3306fd25c18d798b59ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Thu, 18 Jan 2024 18:08:02 +0100 Subject: [PATCH 70/83] [common] Fix dependent proof with Arthur Co-authored-by: Arthur Azevedo de Amorim --- common/AST.v | 48 ++++++++++++++++++++++++------------------------ 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/common/AST.v b/common/AST.v index 82b9d4b94b..a1c9e69554 100644 --- a/common/AST.v +++ b/common/AST.v @@ -886,12 +886,13 @@ Fixpoint transf_globdefs (l: list (ident * globdef A V)) : res (list (ident * gl end end. -Lemma agr_comps_transf_partial: forall {pol defs defs'}, +Lemma agr_comps_transf_partial: forall {pol defs}, agr_comps pol defs -> - transf_globdefs defs = OK defs' -> - agr_comps pol defs'. + forall defs', + transf_globdefs defs = OK defs' -> + agr_comps pol defs'. Proof. - unfold agr_comps; intros pol defs defs' [H G] def_trans. + unfold agr_comps; intros pol defs [H G] defs' def_trans. split. { clear G. revert defs' def_trans. induction H. @@ -938,27 +939,19 @@ Proof. exists gd0; split; [right |]; eauto. } Qed. -Record defs_with_proof (p: program A V) := - { gl: res (list (ident * globdef B W)); - proof: forall l, gl = OK l -> agr_comps (prog_pol p) l }. - -Program Definition truc (p: program A V): (defs_with_proof p) := - {| gl := transf_globdefs p.(prog_defs); |}. -Next Obligation. - eapply agr_comps_transf_partial; eauto using prog_agr_comps. -Qed. - -Program Definition transform_partial_program2 (p: program A V) : res (program B W) := - match transf_globdefs p.(prog_defs) with +Definition transform_partial_program2 (p: program A V) : res (program B W) := + match transf_globdefs p.(prog_defs) as x + return (transf_globdefs p.(prog_defs) = x -> + res (program B W)) with | OK gl' => - OK (mkprogram gl' + fun e => OK (mkprogram gl' p.(prog_public) p.(prog_main) p.(prog_pol) p.(prog_pol_pub) - (agr_comps_transf_partial p.(prog_agr_comps) _)) - | Error err => Error err - end. + (agr_comps_transf_partial p.(prog_agr_comps) e)) + | Error err => fun e => Error err + end eq_refl. End TRANSF_PROGRAM_GEN. @@ -1000,10 +993,17 @@ Proof. - destruct g; simpl; rewrite IHl; simpl. auto. destruct v; auto. } specialize (EQ (prog_defs p)). - clear -EQ. - Require Import ssreflect. - move: eq_refl. intros e. -Admitted. + generalize (agr_comps_transf_partial + (fun (_ : ident) (f : A) => OK (transf_fun f)) + (fun (_ : ident) (v : V) => OK v) + (prog_agr_comps p)). + rewrite EQ. intros a. + unfold transform_program. + replace (agr_comps_transf (prog_agr_comps p)) with + (a (map (transform_program_globdef transf_fun) (prog_defs p)) eq_refl). + reflexivity. + apply Classical_Prop.proof_irrelevance. +Qed. (** * External functions *) From 167b68edf9be49147e561b2c10bd411a18e577ca Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Fri, 19 Jan 2024 12:32:39 +0100 Subject: [PATCH 71/83] Support vstore and vload as external functions --- test/backtranslation/Export.ml | 12 +++++++++++- test/backtranslation/Gen.ml | 13 ++++++++++--- test/backtranslation/Stats.ml | 12 ++++++------ 3 files changed, 27 insertions(+), 10 deletions(-) diff --git a/test/backtranslation/Export.ml b/test/backtranslation/Export.ml index b0b012ff85..eeb179b04d 100644 --- a/test/backtranslation/Export.ml +++ b/test/backtranslation/Export.ml @@ -51,6 +51,14 @@ let fix_annotations code = |> Str.global_replace regex_annot_val_with_args "__builtin_ais_annot(\"\\1\", \\2);" |> Str.global_replace regex_annot_val_no_args "__builtin_ais_annot(\"\\1\");" +let fix_vstore code = + let regex = Str.regexp "builtin volatile store [^(]+(\\([^,]+\\), \\([^)]+\\));" in + Str.global_replace regex "*(\\1) = \\2;" code + +let fix_vload code = + let regex = Str.regexp "builtin volatile load [^(]+(\\([^)]+\\));" in + Str.global_replace regex "*(\\1);" code + let c_light_prog prog file_name = let vars_before_funcs (_, def1) (_, def2) = let open AST in @@ -72,6 +80,8 @@ let c_light_prog prog file_name = |> fix_floating_point_literals |> fix_missing_derefs |> fix_syntax_of_builtins - |> fix_annotations in + |> fix_annotations + |> fix_vstore + |> fix_vload in Out_channel.with_open_text (file_name ^ ".raw") (fun c -> output_string c raw_code); Out_channel.with_open_text file_name (fun c -> output_string c code) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index 5862711b45..5d95d28388 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -239,8 +239,8 @@ let external_function ctx = (1, ef_external ctx); (1, ef_builtin ctx); (1, ef_runtime ctx); - (* (1, ef_vload ctx); *) - (* (1, ef_vstore ctx); *) + (1, ef_vload ctx); + (1, ef_vstore ctx); (* (1, ef_malloc ctx); *) (* (1, ef_free ctx); *) (* (1, ef_memcpy ctx); *) @@ -315,7 +315,14 @@ let bundle_builtin ctx rand_state = let func = external_function ctx rand_state in let () = Stats.register_external_function func in let sign = AST.ef_sig func in - let args = args_for_sig sign rand_state in + let args = match func with + | AST.EF_vload _ | AST.EF_vstore _ -> + let xs = args_for_sig sign rand_state in + let vars = List.filter_map (fun (_, v, _, is_const, _) -> if is_const then None else Some v) (Gen_ctx.var_list ctx) in + let x = Events.EVptr_global (Camlcoq.P.of_int (oneofl vars rand_state), (Camlcoq.Z.of_sint 0)) in + x :: List.tl xs + | _ -> args_for_sig sign rand_state + in let mdelta = [] in BtInfoAsm.Bundle_builtin (subtrace, func, args, mdelta) diff --git a/test/backtranslation/Stats.ml b/test/backtranslation/Stats.ml index 9cec00eefe..b8cc5633f2 100644 --- a/test/backtranslation/Stats.ml +++ b/test/backtranslation/Stats.ml @@ -117,14 +117,14 @@ let print_ef_stats out_channel = Printf.fprintf out_channel " EF_runtime: %d\n" !ef_runtime; Printf.fprintf out_channel " EF_vload: %d\n" !ef_vload; Printf.fprintf out_channel " EF_vstore: %d\n" !ef_vstore; - Printf.fprintf out_channel " EF_malloc: %d\n" !ef_malloc; - Printf.fprintf out_channel " EF_free: %d\n" !ef_free; - Printf.fprintf out_channel " EF_memcpy: %d\n" !ef_memcpy; + Printf.fprintf out_channel " EF_malloc*: %d\n" !ef_malloc; + Printf.fprintf out_channel " EF_free*: %d\n" !ef_free; + Printf.fprintf out_channel " EF_memcpy*: %d\n" !ef_memcpy; Printf.fprintf out_channel " EF_annot: %d\n" !ef_annot; Printf.fprintf out_channel " EF_annot_val: %d\n" !ef_annot_val; - Printf.fprintf out_channel " EF_inline_asm: %d\n" !ef_inline_asm; - Printf.fprintf out_channel " EF_debug: %d\n" !ef_debug; - Printf.fprintf out_channel "\n\nNote: the entries marked with * are ignored (or trivial) in the backtranslation.\n" + Printf.fprintf out_channel " EF_inline_asm*: %d\n" !ef_inline_asm; + Printf.fprintf out_channel " EF_debug*: %d\n" !ef_debug; + Printf.fprintf out_channel "\n\nNote: the entries marked with * are not generated.\n" let print_stats out_channel = print_trace_stats out_channel; From 0269bd7fb83c18c745847416060f5020194aefe2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Fri, 19 Jan 2024 14:15:46 +0100 Subject: [PATCH 72/83] [common] Fix proofs in linking --- backend/Selectionproof.v | 1 + cfrontend/Cshmgenproof.v | 1 + cfrontend/Ctypes.v | 6 +- cfrontend/SimplExprproof.v | 1 + cfrontend/SimplLocalsproof.v | 3 +- common/Linking.v | 217 +++++++++++++++-------------------- 6 files changed, 100 insertions(+), 129 deletions(-) diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 5918f1c570..fe923aafcd 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -1691,6 +1691,7 @@ Global Instance TransfSelectionLink : TransfLink match_prog. Proof. red; intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. + exact comp_match_fundef. intros. elim H3. intros hf [A1 B1]. elim H4; intros hf' [A2 B2]. Local Transparent Linker_fundef. simpl in *. destruct f1, f2; simpl in *; monadInv B1; monadInv B2; simpl. diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 1f007c963d..5e8561214e 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -2106,6 +2106,7 @@ Local Transparent Ctypes.Linker_program. (prog_comp_env_eq p2) EQ) as (env & P & Q). intros E. eapply Linking.link_match_program; eauto. +- exact comp_match_fundef. - intros. Local Transparent Linker_fundef Linking.Linker_fundef. inv H3; inv H4; simpl in H2. diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index 7517e64af9..a08e127f22 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -1933,6 +1933,7 @@ Section LINK_MATCH_PROGRAM_GEN. Context {F G: Type}. Context {CF: has_comp F} {CG: has_comp G}. Variable match_fundef: program F -> fundef F -> fundef G -> Prop. +Context {comp_match_fundef: has_comp_match match_fundef}. Hypothesis link_match_fundef: forall ctx1 ctx2 f1 tf1 f2 tf2 f, @@ -1985,6 +1986,8 @@ Section LINK_MATCH_PROGRAM. Context {F G: Type}. Context {CF: has_comp F} {CG: has_comp G}. Variable match_fundef: fundef F -> fundef G -> Prop. +Context {comp_match_fundef: has_comp_match (fun (_ : AST.program (fundef F) type) f g => match_fundef f g)}. + Hypothesis link_match_fundef: forall f1 tf1 f2 tf2 f, @@ -2008,7 +2011,8 @@ Local Transparent Linker_program. assert (A: exists tpp, link (program_of_program tp1) (program_of_program tp2) = Some tpp /\ Linking.match_program (fun ctx f tf => match_fundef f tf) eq pp tpp). - { eapply Linking.link_match_program. + { eapply Linking.link_match_program. + - exact comp_match_fundef. - intros. exploit link_match_fundef; eauto. intros (tf & A & B). exists tf; auto. - intros. Local Transparent Linker_types. diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index 09b5867802..91643cadbc 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -2610,6 +2610,7 @@ End PRESERVATION. Global Instance TransfSimplExprLink : TransfLink match_prog. Proof. red; intros. eapply Ctypes.link_match_program_gen; eauto. +- eapply comp_tr_fundef. - intros. Local Transparent Linker_fundef. simpl in *; unfold link_fundef in *. inv H3; inv H4; try discriminate. diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index 01e14a6ee0..71523b4666 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -2530,7 +2530,8 @@ End PRESERVATION. Global Instance TransfSimplLocalsLink : TransfLink match_prog. Proof. - red; intros. eapply Ctypes.link_match_program; eauto. + red; intros. eapply Ctypes.link_match_program; eauto. + eapply has_comp_transl_partial_match. eapply comp_transf_fundef. intros. Local Transparent Linker_fundef. simpl in *; unfold link_fundef in *. diff --git a/common/Linking.v b/common/Linking.v index 71897e89fc..8ffb2955e7 100644 --- a/common/Linking.v +++ b/common/Linking.v @@ -393,102 +393,6 @@ Lemma prog_agr_comps_link: Proof. Admitted. - -(* Definition link_pol (pol1 pol2: Policy.t): Policy.t := *) -(* let comb := *) -(* PTree.combine link_pol_comp pol1.(Policy.policy_comps) pol2.(Policy.policy_comps) in *) -(* {| Policy.policy_comps := comb; *) -(* Policy.policy_export := pol1.(Policy.policy_export); *) -(* Policy.policy_import := pol1.(Policy.policy_import); *) -(* |}. *) - - -(* Lemma prog_agr_comps_link: *) -(* PTree_Properties.for_all p1.(prog_pol).(Policy.policy_comps) link_pol_check = true -> *) -(* agr_comps (link_pol p1.(prog_pol) p2.(prog_pol)) *) -(* (PTree.elements (PTree.combine link_prog_merge dm1 dm2)). *) -(* Proof. *) -(* intros H. *) -(* rewrite PTree_Properties.for_all_correct in H. *) -(* unfold agr_comps. *) -(* split. *) -(* { *) -(* apply Forall_forall. *) -(* intros [id gd] found_in. *) -(* simpl. exploit PTree.elements_complete; eauto. *) -(* intros G. *) -(* rewrite PTree.gcombine in G; [| reflexivity]. *) -(* unfold link_prog_merge in G. *) -(* rewrite PTree.gcombine; [| reflexivity]. *) -(* destruct (dm1 ! id) eqn:dm1_id. *) -(* - unfold link_pol_check in H. *) -(* pose proof p1.(prog_agr_comps) as [R S]. *) -(* rewrite Forall_forall in R. apply in_prog_defmap in dm1_id. *) -(* specialize (R (id, g) dm1_id). simpl in R. *) -(* specialize (H id (comp_of g) (R)). *) -(* rewrite R in *. *) -(* destruct (dm2 ! id) eqn:dm2_id. *) -(* + pose proof p2.(prog_agr_comps) as [R' S']. *) -(* rewrite Forall_forall in R'. apply in_prog_defmap in dm2_id. *) -(* specialize (R' (id, g0) dm2_id). simpl in R'. *) -(* eapply Linker_def_comp with (V := V) in CLF. *) -(* specialize (CLF _ _ _ G). *) -(* rewrite R'; simpl. *) -(* intuition. *) -(* * destruct (cp_eq_dec); try congruence. *) -(* * destruct (cp_eq_dec); try congruence. *) -(* destruct (cp_eq_dec); try congruence. *) -(* * destruct (cp_eq_dec); try congruence. *) -(* destruct (cp_eq_dec); try congruence. *) -(* destruct (cp_eq_dec); try congruence. *) -(* + inv G. simpl. *) -(* pose proof p2.(prog_agr_comps) as [_ S']. *) -(* destruct ((Policy.policy_comps (prog_pol p2))! id) eqn:EQ. *) -(* * specialize (S' _ _ EQ) as [gd' [? ?]]. subst. *) -(* assert (C: In id (prog_defs_names p2)). *) -(* { unfold prog_defs_names. eapply in_map with (f := fst) in H0; eauto. } *) -(* exploit prog_defmap_dom; eauto. *) -(* intros [? C']. unfold dm2 in *. congruence. *) -(* * reflexivity. *) -(* - pose proof p2.(prog_agr_comps) as [R' S']. *) -(* rewrite Forall_forall in R'. apply in_prog_defmap in G as dm2_id. *) -(* specialize (R' (id, gd) dm2_id). simpl in R'. *) -(* rewrite R'. *) -(* pose proof p1.(prog_agr_comps) as [_ S]. *) -(* destruct ((Policy.policy_comps (prog_pol p1))! id) eqn:EQ. *) -(* + specialize (S _ _ EQ) as [gd' [? ?]]. subst. *) -(* assert (C: In id (prog_defs_names p1)). *) -(* { unfold prog_defs_names. eapply in_map with (f := fst) in H0; eauto. } *) -(* exploit prog_defmap_dom; eauto. *) -(* intros [? C']. unfold dm1 in *. congruence. *) -(* + reflexivity. *) -(* } *) -(* { *) -(* intros id cp G. *) -(* simpl in *. *) -(* rewrite PTree.gcombine in G; eauto. *) -(* unfold link_pol_comp in G. *) - -(* pose proof p1.(prog_agr_comps) as [R S]. *) -(* pose proof p2.(prog_agr_comps) as [R' S']. *) -(* destruct ((Policy.policy_comps (prog_pol p1)) ! id) eqn:EQ. *) -(* - destruct ((Policy.policy_comps (prog_pol p2)) ! id) eqn:EQ'. *) -(* + specialize (S _ _ EQ) as [gd1 [in1 ?]]; specialize (S' _ _ EQ') as [gd2 [in2 ?]]; subst. *) - - -(* - pose proof p2.(prog_agr_comps) as [R' S']. *) -(* specialize (S' _ _ G) as [gd [? ?]]; subst. *) -(* eexists. split; [|reflexivity]. *) -(* eapply PTree.elements_correct. *) -(* rewrite PTree.gcombine; eauto. unfold link_prog_merge. *) -(* pose proof p1.(prog_agr_comps) as [R S]. *) -(* assert (dm1_id: dm1 ! id = None). *) -(* { destruct (dm1 ! id) eqn:EQ'; try congruence. exfalso. *) -(* rewrite Forall_forall in R. admit. } *) -(* admit. *) -(* } *) -(* Admitted. *) - Definition link_prog := if ident_eq p1.(prog_main) p2.(prog_main) && PTree_Properties.for_all dm1 link_prog_check then @@ -751,33 +655,37 @@ Theorem match_transform_partial_program2: (forall i v tv, transf_var i v = OK tv -> match_varinfo v tv) -> match_program_gen match_fundef match_varinfo ctx p tp. Proof. - unfold transform_partial_program2; intros. -Admitted. -(* dependent types issue *) -(* monadInv H. *) -(* red; simpl; split; auto. *) -(* revert x EQ. generalize (prog_defs p). *) -(* induction l as [ | [i g] l]; simpl; intros. *) -(* - monadInv EQ. constructor. *) -(* - destruct g as [f|v]. *) -(* + destruct (transf_fun i f) as [tf|?] eqn:TF; monadInv EQ. *) -(* constructor; auto. split; simpl; auto. econstructor. apply linkorder_refl. eauto. *) -(* + destruct (transf_globvar transf_var i v) as [tv|?] eqn:TV; monadInv EQ. *) -(* constructor; auto. split; simpl; auto. constructor. *) -(* monadInv TV. destruct v; simpl; constructor. eauto. *) -(* - split; auto. split; auto. *) -(* destruct (prog_pol p); simpl; auto. *) -(* unfold update_policy; simpl; auto. *) -(* unfold Policy.eqb; rewrite !andb_true_iff; repeat split; simpl; auto. *) -(* + rewrite PTree.beq_correct. intros id. *) -(* unfold update_list_comps. admit. *) -(* + rewrite PTree.beq_correct. *) -(* intros y. destruct (policy_export ! y); auto. *) -(* destruct (Policy.list_id_eq l l); auto. *) -(* + rewrite PTree.beq_correct. *) -(* intros y. destruct (policy_import ! y); auto. *) -(* destruct (Policy.list_cpt_id_eq l l); auto. *) -(* Admitted. *) + unfold transform_partial_program2; intros. revert H. + generalize (agr_comps_transf_partial transf_fun transf_var (prog_agr_comps p)). + intros a H. + destruct transf_globdefs eqn:EQ; try congruence. + inv H. + red; simpl; split; auto. + clear a. + revert l EQ. generalize (prog_defs p). + induction l as [ | [i g] l]; simpl; intros. +- monadInv EQ. constructor. +- destruct g as [f|v]. ++ destruct (transf_fun i f) as [tf|?] eqn:TF; monadInv EQ. + constructor; auto. split; simpl; auto. econstructor. apply linkorder_refl. eauto. ++ destruct (transf_globvar transf_var i v) as [tv|?] eqn:TV; monadInv EQ. + constructor; auto. split; simpl; auto. constructor. + monadInv TV. destruct v; simpl; constructor. eauto. +- split; auto. split; auto. + destruct (prog_pol p); simpl; auto. + unfold update_policy; simpl; auto. + unfold Policy.eqb; rewrite !andb_true_iff; repeat split; simpl; auto. + + rewrite PTree.beq_correct. intros id. + unfold update_list_comps. + destruct (policy_comps ! id); auto. + destruct cp_eq_dec; auto. + + rewrite PTree.beq_correct. + intros y. destruct (policy_export ! y); auto. + destruct (Policy.list_id_eq l0 l0); auto. + + rewrite PTree.beq_correct. + intros y. destruct (policy_import ! y); auto. + destruct (Policy.list_cpt_id_eq l0 l0); auto. +Qed. Theorem match_transform_partial_program_contextual: forall {A B V: Type} {CA: has_comp A} {CB: has_comp B} {LA: Linker A} {LV: Linker V} @@ -843,6 +751,7 @@ Section LINK_MATCH_PROGRAM. Context {C F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LC: Linker C} {LF1: Linker F1} {LF2: Linker F2} {LV1: Linker V1} {LV2: Linker V2}. Variable match_fundef: C -> F1 -> F2 -> Prop. +Context {has_comp_match_fundef: has_comp_match match_fundef}. Variable match_varinfo: V1 -> V2 -> Prop. Local Transparent Linker_vardef Linker_def Linker_prog. @@ -950,10 +859,56 @@ Proof. + rewrite R; simpl. split; try congruence. unfold Policy.eqb. rewrite !andb_true_iff. unfold CompTree.beq. simpl. - admit. - (* unfold Policy.eqb in D1. *) - (* rewrite andb_true_iff in D1. unfold CompTree.beq in D1. simpl in D1. auto. *) -Admitted. + clear yes. unfold Policy.eqb in D1. rewrite !andb_true_iff in D1. + destruct D1 as [[? ?] ?]. + split; [split |]; auto. + unfold link_pol_comp. + rewrite PTree.beq_correct. intros x. + assert (G: forall A B (f: A -> B) (t: PTree.t A), map (fun '(id, x) => (id, f x)) (PTree.elements t) = + PTree.elements (PTree.map1 f t)). + { clear. + intros. + unfold PTree.elements. generalize 1%positive. + assert (H: map (fun '(id, x) => (id, f x)) nil = (nil: list (positive * B))) by reflexivity. + revert H. + generalize (nil: list (positive * B)). + generalize (nil: list (positive * A)). + induction t using PTree.tree_ind. + - intros; auto. + - intros l0 l1 EQ p. + destruct l; simpl in *; auto. + + destruct o; simpl in *; auto. + * destruct r; simpl in *; try rewrite EQ; auto. + erewrite IHt0; auto. + * destruct r; simpl in *; auto. + + destruct o; simpl in *; auto. + * destruct r; simpl in *; auto. + now erewrite IHt; eauto; simpl; rewrite EQ. + now erewrite IHt; eauto; simpl; erewrite IHt0. + * destruct r; simpl in *; auto. + } + rewrite !G. + rewrite !PTree_Properties.of_list_elements. + rewrite !PTree.gmap1. + unfold option_map. + assert (option_rel (match_globdef match_fundef match_varinfo ctx) + (PTree.combine link_prog_merge (prog_defmap p1) (prog_defmap p2)) ! x + (PTree.combine link_prog_merge (prog_defmap tp1) (prog_defmap tp2)) ! x). + { + rewrite ! PTree.gcombine by auto. + generalize (match_program_defmap _ _ _ _ _ H0 x) (match_program_defmap _ _ _ _ _ H1 x). + clear R. intros R1 R2; inv R1; inv R2; unfold link_prog_merge. +* constructor. +* constructor. apply match_globdef_linkorder with ctx2; auto. +* constructor. apply match_globdef_linkorder with ctx1; auto. +* exploit Q; eauto. intros (X & Y & gd & Z). + exploit link_match_globdef. eexact H2. eexact H3. eauto. eauto. eauto. + intros (tg & TL & MG). rewrite Z, TL. constructor; auto. } + inv H7; auto. inv H10; auto. + apply has_comp_match_fundef in H11. simpl; rewrite H11. + now destruct cp_eq_dec. + inv H7; simpl; now destruct cp_eq_dec. +Qed. End LINK_MATCH_PROGRAM. @@ -1005,6 +960,8 @@ Global Instance TransfPartialContextualLink Proof. red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. +- intros ? ? ? ?. eapply has_comp_transl_partial_match; eauto. + eapply comp_transf_partial_fundef. eauto. - intros. eapply link_transf_partial_fundef; eauto. - intros; subst. exists v; auto. Qed. @@ -1021,6 +978,8 @@ Global Instance TransfPartialLink Proof. red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. +- intros ? ? ? ?. eapply has_comp_transl_partial_match; eauto. + eapply comp_transf_partial_fundef. eauto. - intros. eapply link_transf_partial_fundef; eauto. - intros; subst. exists v; auto. Qed. @@ -1038,6 +997,8 @@ Global Instance TransfTotallContextualLink Proof. red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. +- intros ? ? ? ?. eapply has_comp_transl_match; eauto. + eapply comp_transf_fundef. eauto. - intros. subst. destruct f1, f2; simpl in *. + discriminate. + destruct e; try easy. @@ -1062,6 +1023,8 @@ Global Instance TransfTotalLink Proof. red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. +- intros ? ? ? ?. eapply has_comp_transl_match; eauto. + eapply comp_transf_fundef. eauto. - intros. subst. destruct f1, f2; simpl in *. + discriminate. + destruct e; try easy. From 2e6904f801ff8c72a4e122f532ce1d6ea4976d05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Sun, 21 Jan 2024 22:26:10 +0100 Subject: [PATCH 73/83] [Backtranslation] Fix some proofs, readd one axiom about external calls (do not free non freeable blocks) --- common/AST.v | 90 ++++++++++++++++---------------------------- common/Events.v | 34 ++++++++++++++++- common/Linking.v | 49 +++++++++++++++--------- security/BtInfoAsm.v | 56 +++++++++++---------------- 4 files changed, 117 insertions(+), 112 deletions(-) diff --git a/common/AST.v b/common/AST.v index a1c9e69554..9859b80c10 100644 --- a/common/AST.v +++ b/common/AST.v @@ -703,10 +703,11 @@ Instance has_comp_globdef F V {CF: has_comp F} : has_comp (globdef F V) := Definition agr_comps {F V: Type} {CF: has_comp F} (pol: Policy.t) (defs: list (ident * globdef F V)): Prop := Forall (fun idg => pol.(Policy.policy_comps) ! (fst idg) = Some (comp_of (snd idg))) - defs /\ - forall (id: ident) (cp: compartment), - pol.(Policy.policy_comps) ! id = Some cp -> - exists gd, In (id, gd) defs /\ cp = comp_of gd. + defs. + (* /\ *) + (* forall (id: ident) (cp: compartment), *) + (* pol.(Policy.policy_comps) ! id = Some cp -> *) + (* exists gd, In (id, gd) defs /\ cp = comp_of gd. *) Record program (F V: Type) {CF: has_comp F} : Type := mkprogram { prog_defs: list (ident * globdef F V); @@ -792,7 +793,13 @@ Definition update_policy (pol: Policy.t) (defs: list (ident * globdef B W)): Pol Lemma agr_update_policy (pol: Policy.t) (defs: list (ident * globdef B W)): agr_comps (update_policy pol defs) defs. Proof. - unfold agr_comps; simpl; split. + unfold agr_comps. + rewrite Forall_forall. + induction defs. + - intros x H; inv H. + - intros [id gd] H. inv H. + + simpl. admit. + + simpl. admit. Admitted. End TRANSF_POL. @@ -814,20 +821,14 @@ Lemma agr_comps_transf: forall {pol defs}, agr_comps pol defs -> agr_comps pol (List.map transform_program_globdef defs). Proof. - unfold agr_comps; intros pol defs [H G]. - split. - - clear G. induction H. + unfold agr_comps; intros pol defs H. + - induction H. + now simpl. + simpl; constructor. * destruct x as [id [fd | vd]]; simpl in *. -- now rewrite comp_transf. -- assumption. * assumption. - - clear H. - intros id cp H. - specialize (G id cp H) as [gd [R S]]; subst cp. - eapply in_map with (f := transform_program_globdef) in R. - destruct gd; simpl; eauto. Qed. Definition transform_program (p: program A V) : program B V := @@ -892,51 +893,24 @@ Lemma agr_comps_transf_partial: forall {pol defs}, transf_globdefs defs = OK defs' -> agr_comps pol defs'. Proof. - unfold agr_comps; intros pol defs [H G] defs' def_trans. - split. - { clear G. revert defs' def_trans. - induction H. - - now intros defs' H; simpl in H; inv H. - - intros defs' defs'_OK. - destruct x as [id [fd | vd]] eqn:?; simpl in *. - + destruct transf_fun eqn:?; try congruence; simpl in *. - monadInv defs'_OK. - simpl; constructor. - * simpl. - apply has_comp_transl_partial_match_contextual with (g := fun id => id) in Cf. - now rewrite Cf in H; eauto. - * now eauto. - + destruct transf_globvar eqn:?; try congruence; simpl in *. - monadInv defs'_OK. - simpl; constructor. - * now monadInv Heqr; eauto. - * now eauto. } - { clear H. - intros id cp H. - specialize (G id cp H) as [gd [R S]]; subst cp. - clear -R def_trans Cf. - revert defs' def_trans. - induction defs. - - inv R. - - intros defs' def_trans. inv R. - + destruct gd; simpl in *; eauto. - * destruct transf_fun eqn:transf_id_f; try congruence. - monadInv def_trans. - exists (Gfun b); split; [left |]; eauto. - now rewrite Cf; eauto. - * destruct transf_globvar eqn:transf_id_v; try congruence. - monadInv def_trans. - exists (Gvar g); split; [left |]; eauto. - monadInv transf_id_v; auto. - + destruct a as [? []]; simpl in def_trans. - * destruct transf_fun eqn:transf_id_f; try congruence. - monadInv def_trans. - exploit IHdefs; eauto. intros [gd0 [? ?]]. - exists gd0; split; [right |]; eauto. - * destruct transf_globvar eqn:transf_id_v; try congruence. - monadInv def_trans. - exploit IHdefs; eauto. intros [gd0 [? ?]]. - exists gd0; split; [right |]; eauto. } + unfold agr_comps; intros pol defs H defs' def_trans. + revert defs' def_trans. + induction H. + - now intros defs' H; simpl in H; inv H. + - intros defs' defs'_OK. + destruct x as [id [fd | vd]] eqn:?; simpl in *. + + destruct transf_fun eqn:?; try congruence; simpl in *. + monadInv defs'_OK. + simpl; constructor. + * simpl. + apply has_comp_transl_partial_match_contextual with (g := fun id => id) in Cf. + now rewrite Cf in H; eauto. + * now eauto. + + destruct transf_globvar eqn:?; try congruence; simpl in *. + monadInv defs'_OK. + simpl; constructor. + * now monadInv Heqr; eauto. + * now eauto. Qed. Definition transform_partial_program2 (p: program A V) : res (program B W) := diff --git a/common/Events.v b/common/Events.v index e74dc56199..2ee5a9dabe 100644 --- a/common/Events.v +++ b/common/Events.v @@ -848,7 +848,16 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : | Event_call _ _ _ _ :: _ | Event_return _ _ _ :: _ => False | _ => True - end + end; + +(** 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 cp 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; }. (** ** Semantics of volatile loads *) @@ -981,6 +990,8 @@ Proof. split. constructor. intuition congruence. (* no cross *) - inv H; inv H0; simpl; auto. +(* not freeable *) +- inv H; eauto. Qed. (** ** Semantics of volatile stores *) @@ -1157,6 +1168,8 @@ Proof. split. constructor. intuition congruence. (* no cross *) - inv H; inv H0; simpl; auto. +(* not freeable *) +- inv H. inv H5; auto. eauto with mem. Qed. (** ** Semantics of dynamic memory allocation (malloc) *) @@ -1257,6 +1270,8 @@ Proof. split. constructor. intuition congruence. (* no cross *) - inv H; inv H0; simpl; auto. +(* not freeable *) +- inv H. eapply Mem.perm_store_1; eauto. eapply Mem.perm_alloc_1; eauto. Qed. (** ** Semantics of dynamic memory deallocation (free) *) @@ -1376,6 +1391,13 @@ Proof. + split. constructor. intuition auto. (* no cross *) - inv H; simpl; auto. +(* 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. Qed. (** ** Semantics of [memcpy] operations. *) @@ -1517,6 +1539,8 @@ Proof. intros; inv H; inv H0. split. constructor. intros; split; congruence. (* no cross *) - intros; inv H; simpl; auto. +(* not freeable *) +- intros. inv H. eapply Mem.perm_storebytes_1; eauto. Qed. (** ** Semantics of annotations. *) @@ -1575,6 +1599,8 @@ Proof. split. constructor. auto. (* no cross *) - inv H; simpl; auto. +(* not freeable *) +- inv H; auto. Qed. Inductive extcall_annot_val_sem (text: string) (targ: typ) (ge: Senv.t) (cp: compartment): @@ -1629,6 +1655,8 @@ Proof. split. constructor. auto. (* no cross *) - inv H; simpl; auto. +(* not freeable *) +- inv H; auto. Qed. Inductive extcall_debug_sem (ge: Senv.t) (cp: compartment): @@ -1677,6 +1705,8 @@ Proof. split. constructor. auto. (* no cross *) - inv H; simpl; auto. +(* not freeable *) +- inv H; auto. Qed. (** ** Semantics of known built-in functions. *) @@ -1744,6 +1774,8 @@ Proof. split. constructor. intuition congruence. (* no cross *) - inv H; simpl; auto. +(* not freeable *) +- inv H; auto. Qed. (** ** Semantics of external functions. *) diff --git a/common/Linking.v b/common/Linking.v index 8ffb2955e7..b3afca5e5f 100644 --- a/common/Linking.v +++ b/common/Linking.v @@ -356,24 +356,8 @@ Lemma link_prog_subproof : Policy.eqb p1.(prog_pol) p2.(prog_pol) = true -> Policy.in_pub p1.(prog_pol) (p1.(prog_public) ++ p2.(prog_public)). Proof. -Admitted. -(* Definition link_pol_comp (oc1 oc2: option compartment) := *) -(* match oc1, oc2 with *) -(* | None, oc2 => oc2 *) -(* | oc1, None => oc1 *) -(* | Some c1, Some c2 => *) -(* if cp_eq_dec c1 bottom then Some c2 *) -(* else if cp_eq_dec c2 bottom then Some c1 *) -(* else if cp_eq_dec c1 c2 then Some c1 *) -(* else None *) -(* end. *) - -(* Definition link_pol_check (x: ident) (c1: compartment) := *) -(* match link_pol_comp (Some c1) p2.(prog_pol).(Policy.policy_comps)!x with *) -(* | Some _ => true *) -(* | None => false *) -(* end. *) +Admitted. Definition link_pol_comp: PTree.t compartment := let defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2) in @@ -391,7 +375,36 @@ Lemma prog_agr_comps_link: agr_comps (link_pol p1.(prog_pol) p2.(prog_pol)) (PTree.elements (PTree.combine link_prog_merge dm1 dm2)). Proof. - Admitted. + unfold agr_comps. + unfold link_pol. simpl. + unfold link_pol_comp. + rewrite Forall_forall. + pose proof (PTree.elements_keys_norepet (PTree.combine link_prog_merge dm1 dm2)) as H. revert H. + generalize (PTree.elements (PTree.combine link_prog_merge dm1 dm2)). + intros l. + assert (H: forall id gd, In (id, gd) l -> In (id, comp_of gd) (map (fun '(id, a) => (id, comp_of a)) l)). + { intros. + pose proof (@in_map (positive * globdef F V) _ (fun '(id, gd) => (id, comp_of gd))) as G. + specialize (G l (id, gd)). eauto. } + intros NO. + assert (H': list_norepet (map fst (map (fun '(id, a) => (id, comp_of a)) l))). + { rewrite map_map. + replace (fun x : positive * globdef F V => fst (let '(id, a) := x in (id, comp_of a))) with + (fst : positive * globdef F V -> positive). eauto. + eapply FunctionalExtensionality.functional_extensionality. + intros []; auto. } + revert H' H NO. + generalize (map (fun '(id, a) => (id, comp_of a)) l). + induction l. + - intros l' NO IN H x G; inv G. + - intros l' NO IN H [id gd] G; inversion H as [|? ? A B C]; subst. simpl in *. + destruct a as [id' gd']; simpl in *. + destruct G as [G | G]. + + inv G. + erewrite PTree_Properties.of_list_norepet; eauto. + + exploit IN; eauto. + exploit IHl; eauto. +Qed. Definition link_prog := if ident_eq p1.(prog_main) p2.(prog_main) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index c2b0973e3a..0cde5a8833 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -207,10 +207,10 @@ Section IR. Definition ir_state := option (block * mem * ir_conts)%type. - Instance has_comp_fundef: has_comp Asm.fundef. - Proof. - eapply has_comp_fundef. eapply has_comp_function. - Qed. + (* Instance has_comp_fundef: has_comp Asm.fundef. *) + (* Proof. *) + (* eapply has_comp_fundef. eapply has_comp_function. *) + (* Qed. *) Definition funsig fd := match fd with @@ -1271,12 +1271,6 @@ Section PROOF. 2:{ exists res. auto. } econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_intra_call_external; eauto. - (* exact x0. *) (* this one should work trivially *) - admit. - admit. (* idem *) - (* { unfold Genv.type_of_call in *. rewrite CURCOMP, <- REC_CURCOMP. rewrite NEXTPC. simpl. *) - (* unfold Genv.find_comp. setoid_rewrite NEXTF. rewrite Pos.eqb_refl. auto. *) - (* } *) - (* extcall is known and observable *) rename H7 into EXTCALL, H8 into EXTARGS. unfold external_call_known_observables in ECKO. @@ -1288,11 +1282,8 @@ Section PROOF. eapply ir_step_intra_call_external. all: eauto. (* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) { ss. } - { simpl. econstructor. econstructor 1; eauto. unfold Senv.find_comp. simpl. - admit. (* wrong typeclass instance *) - (* exact H2. *) - } - { simpl. right. split; auto. econs; eauto. econs. econs; eauto. admit. (* same problem *)} + { 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. } @@ -1305,12 +1296,10 @@ Section PROOF. { ss. } { instantiate (2:=[Vptr b0 ofs; Val.load_result chunk v]). simpl. econstructor. econstructor 1; eauto. - admit. (* idem*) rewrite val_load_result_idem. auto. } { simpl. right. split; auto. splits; ss; auto. econs; eauto. econs; eauto. - admit. (* idem *) rewrite val_load_result_idem. auto. des. unfold load_whole_chunk in *. rewrite val_load_result_idem. auto. } @@ -1329,8 +1318,8 @@ Section PROOF. eapply ir_step_intra_call_external. all: eauto. (* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) { ss. } - { simpl. econstructor. auto. admit. (* idem *) } - { simpl. right. split; auto. econs; eauto. econs. auto. admit. (* idem *) } + { simpl. econstructor. auto. auto. } + { simpl. right. split; auto. econs; eauto. econs. auto. auto. } splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. @@ -1338,10 +1327,9 @@ Section PROOF. exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. econstructor 2. 2: econstructor 1. 2: auto. eapply ir_step_intra_call_external. all: eauto. - (* { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } *) { ss. } - { simpl. econstructor. auto. eauto. admit. (* idem *) } - { simpl. right. split; auto. econs; eauto. econs. auto. admit. (* idem *) } + { simpl. econstructor. auto. eauto. auto. } + { simpl. right. split; auto. econs; eauto. econs. auto. auto. } { simpl. auto. } splits; auto. } @@ -1453,9 +1441,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. - { simpl in *. - admit. (* same problem *) } - { simpl in *. admit. (* same *) } - (* extcall is known and observable *) unfold external_call_known_observables in ECKO. @@ -1466,8 +1451,8 @@ Section PROOF. econstructor 2. 2: econstructor 1. 2: auto. eapply ir_step_builtin. all: eauto. { ss. } - { simpl. econstructor. econstructor 1; eauto. admit. } - { simpl. right. split; auto. econs; eauto. econs. econs; eauto. admit. } + { 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. } @@ -1481,9 +1466,11 @@ Section PROOF. (* } *) { ss. } { instantiate (2:=[Vptr b0 ofs0; Val.load_result chunk v]). - simpl. econstructor. econstructor 1; eauto. admit. rewrite val_load_result_idem. auto. + simpl. econstructor. econstructor 1; eauto. + rewrite val_load_result_idem. auto. } - { simpl. right. split; auto. splits; eauto. econs. econs; eauto. admit. 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. @@ -1503,8 +1490,8 @@ Section PROOF. (* setoid_rewrite CURF. ss. *) (* } *) { ss. } - { simpl. econstructor. auto. admit. } - { simpl. right. split; auto. econs; eauto. econs. auto. admit. } + { simpl. econstructor. auto. auto. } + { simpl. right. split; auto. econs; eauto. econs. auto. auto. } splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. @@ -1516,8 +1503,8 @@ Section PROOF. (* setoid_rewrite CURF. ss. *) (* } *) { ss. } - { simpl. econstructor. eauto. admit. } - { simpl. right. split; auto. econs; eauto. econs. auto. admit. } + { simpl. econstructor. eauto. auto. } + { simpl. right. split; auto. econs; eauto. econs. auto. auto. } { simpl. auto. } splits; auto. } @@ -1590,8 +1577,7 @@ Section PROOF. { destruct ECKS as [_ OBS]. inv EXTCALL. exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. } - - Admitted. + Qed. Lemma asm_to_ir_returnstate_undef_nccc_external From 6051560df4b3001f92a9eae694666ce1d0864c09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 22 Jan 2024 12:11:19 +0100 Subject: [PATCH 74/83] [Backtranslation] WIP fixing backtranslation --- riscV/Asm.v | 8 +- riscV/Asmgenproof.v | 653 ++---- security/Backtranslation.v | 97 +- security/BacktranslationAux.v | 4033 +++++++++++++++++---------------- security/BtInfoAsm.v | 116 +- security/BtInfoAsmBound.v | 134 +- security/MemoryDelta.v | 4 +- 7 files changed, 2443 insertions(+), 2602 deletions(-) diff --git a/riscV/Asm.v b/riscV/Asm.v index 831174a4f8..4751a4c1ac 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1222,7 +1222,7 @@ Definition update_stack_call (s: stack) (sg: signature) (cp: compartment) rs' := let ra' := rs' # RA in let sp' := rs' # SP in let cp' := Genv.find_comp_in_genv ge pc' in - if cp_eq_dec cp' cp then + if flowsto_dec cp' cp then (* If we are in the same compartment as previously recorded, we don't update the stack *) Some s @@ -1239,7 +1239,7 @@ Definition update_stack_call (s: stack) (sg: signature) (cp: compartment) rs' := Definition update_stack_return (s: stack) (cp: compartment) rs' := let pc' := rs' # PC in let cp' := Genv.find_comp_in_genv ge pc' in - if cp_eq_dec cp cp' then + if flowsto_dec cp cp' then (* If we are in the same compartment as previously recorded, we don't update the stack *) Some s @@ -1334,8 +1334,8 @@ Inductive step: state -> trace -> state -> Prop := forall (NEXTCOMP: Genv.find_comp_in_genv 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 (PC_RA: rec_cp ⊈ cp' -> rs PC = asm_parent_ra st), + forall (RESTORE_SP: rec_cp ⊈ cp' -> rs SP = asm_parent_sp 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'), diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index ba620e9ef7..45b3c3e255 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -511,23 +511,24 @@ Definition val_of_stackframe (f: Mach.stackframe) := | Mach.Stackframe b _ _ ofs _ => Vptr b ofs end. -Inductive match_stacks cp : list Mach.stackframe -> stack -> Prop := -| match_stacks_nil: +Inductive match_stacks: compartment -> list Mach.stackframe -> stack -> Prop := +| match_stacks_nil: forall cp, match_stacks cp nil nil | match_stacks_intra_compartment: (* Intra-compartment calls create a new frame in the source, but not the target *) - forall s s' f, + forall cp cp' s s' f, match_stacks cp s s' -> Mach.call_comp ge (f :: s) = cp -> (* meaning, we are staying in the same compartment *) - match_stacks cp (f :: s) s' + cp' ⊆ cp -> + match_stacks cp' (f :: s) s' | match_stacks_cross_compartment: (* Cross-compartment calls create a new frame in both the source and the target *) - forall cp' s s' f f', + forall cp cp' s s' f f', match_stacks cp' s s' -> Mach.call_comp ge (f :: s) = cp' -> call_comp tge (f' :: s') = cp' -> - cp <> cp' -> + cp ⊈ cp' -> match_stackframe f f' -> match_stacks cp (f :: s) (f' :: s') . @@ -874,7 +875,7 @@ Local Transparent destroyed_by_op. instantiate (1 := (rs0 # PC <- (rs0 x0)) # X1 <- (Val.offset_ptr (rs0 PC) Ptrofs.one)). simpl. eapply agree_exten. eapply agree_undef_regs; eauto. intros. Simpl. intros [args' [ARGS' LDARGS]]. - destruct (cp_eq_dec (comp_of tf') (comp_of tf)) eqn:Heq. + destruct (flowsto_dec (comp_of tf') (comp_of tf)) eqn:Heq. * left; econstructor; split. apply plus_one. rewrite comp_transf_function. @@ -892,187 +893,34 @@ Local Transparent destroyed_by_op. rewrite H7; simpl. unfold tge. rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - rewrite e; destruct (cp_eq_dec (comp_of tf) (comp_of tf)); try now auto. + rewrite Heq; try now auto. auto. - rewrite e, Genv.type_of_call_same_cp; now auto. - (* Not a cross-compartment call *) - (* { destruct (cp_eq_dec (comp_of tf) (comp_of tf)); try now auto. } *) - (* pose proof (flowsto_refl (comp_of tf)); try now auto. } *) + simpl; rewrite Heq; now auto. { rewrite <- comp_transf_function; eauto. rewrite <- (comp_transl_partial _ TTRANSF); eauto. eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } eauto. - (* replace (comp_of f) with (comp_of tf'). *) - (* replace (comp_of f) with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) rewrite comp_transf_function; eauto. econstructor; eauto. econstructor; eauto. eapply agree_sp_def; eauto. - (* { rewrite find_comp_translated. unfold tge. *) - (* unfold Genv.find_comp_in_genv. simpl. *) - (* exploit functions_transl; eauto. intros G. *) - (* rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ G). *) - (* rewrite comp_transf_function; simpl; eauto. } *) { Simpl. change (comp_of (Internal tf)) with (comp_of tf) in Heq. rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). - apply match_stacks_intra_compartment; trivial. - replace (comp_of fd) with (comp_of f). auto. - { rewrite comp_transf_function; eauto. - unfold transf_fundef, transf_partial_fundef in TTRANSF. - destruct fd. - - monadInv TTRANSF. simpl in *. - rewrite comp_transf_function. rewrite e; eauto. - eauto. - - inv TTRANSF. simpl in *. auto. } - unfold Mach.call_comp. simpl. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). + eapply match_stacks_intra_compartment; trivial. + simpl; eauto. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND); auto. + (* replace (comp_of fd) with (comp_of f). auto. *) { simpl. - rewrite comp_transf_function; eauto. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND); auto. unfold transf_fundef, transf_partial_fundef in TTRANSF. destruct fd. - monadInv TTRANSF. simpl in *. - rewrite comp_transf_function. rewrite e; eauto. - eauto. - - inv TTRANSF. simpl in *. auto. } + rewrite !comp_transf_function; eauto. + - inv TTRANSF. simpl in *. auto with comps. } } simpl. eapply agree_exten; eauto. intros. Simpl. Simpl. rewrite <- H2. auto. - (* simpl. *) - (* now rewrite e, comp_transf_function. *) - * destruct (flowsto_dec (comp_of tf') (comp_of tf)) eqn:?. - -- left; econstructor; split. - rewrite comp_transf_function. - apply plus_one. eapply exec_step_internal_call. - rewrite <- H2; simpl; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - simpl; eauto. - Simpl; eauto. - rewrite <- (comp_transl_partial _ H4). - eapply allowed_call_translated; eauto. - simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - unfold update_stack_call. Simpl. - rewrite H7; simpl. - simpl. - unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - rewrite <- H2. simpl. rewrite Heq. - reflexivity. - eauto. - { simpl. - intros. - rewrite <- (comp_transl_partial _ H4) in H8. - rewrite <- (comp_transl_partial _ TTRANSF) in H8. - specialize (NO_CROSS_PTR H8). - now eapply Val.lessdef_list_not_ptr; eauto. } - { simpl. rewrite <- comp_transf_function; eauto. - rewrite <- (comp_transl_partial _ TTRANSF). - eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } - eauto. - (* replace (comp_of f) *) - (* with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) - rewrite comp_transf_function; eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - (* TODO: clean *) - { eapply match_stacks_cross_compartment. exact STACKS'. - - unfold Mach.call_comp. simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). - - simpl. - rewrite <- find_comp_of_block_translated. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). - - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). - simpl. - rewrite comp_transf_function; eauto. - unfold transf_fundef, transf_partial_fundef in TTRANSF. - destruct fd. - + monadInv TTRANSF. simpl in *. - rewrite comp_transf_function; eauto. - + inv TTRANSF. simpl in *. auto. - - erewrite agree_sp; eauto. - constructor. - } - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. - (* simpl. *) - (* now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). *) - -- left; econstructor; split. - rewrite comp_transf_function; eauto. - apply plus_one. eapply exec_step_internal_call. - rewrite <- H2; simpl; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - simpl; eauto. - Simpl; eauto. - rewrite <- (comp_transl_partial _ H4). - eapply allowed_call_translated; eauto. - simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - unfold update_stack_call. Simpl. - rewrite H7; simpl. - simpl. - unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - rewrite <- H2. simpl. rewrite Heq. - reflexivity. - eauto. - { simpl. - intros. - rewrite <- (comp_transl_partial _ H4) in H8. - rewrite <- (comp_transl_partial _ TTRANSF) in H8. - specialize (NO_CROSS_PTR H8). - now eapply Val.lessdef_list_not_ptr; eauto. } - { simpl. rewrite <- comp_transf_function; eauto. - rewrite <- (comp_transl_partial _ TTRANSF). - eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } - (* replace (comp_of f) *) - (* with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) - rewrite comp_transf_function; eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - (* { rewrite find_comp_translated. unfold tge. *) - (* unfold Genv.find_comp_in_genv. simpl. *) - (* exploit functions_transl; eauto. intros G. *) - (* rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ G). *) - (* rewrite comp_transf_function; simpl; eauto. } *) - (* TODO: clean *) - { eapply match_stacks_cross_compartment. exact STACKS'. - - unfold Mach.call_comp. simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). - - simpl. - rewrite <- find_comp_of_block_translated. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). - (* - rewrite (comp_transl_partial _ TTRANSF). *) - (* rewrite (comp_transl_partial _ H4). *) - (* intros contra. now rewrite contra, Pos.eqb_refl in Heq. *) - - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). - simpl. - rewrite comp_transf_function; eauto. - unfold transf_fundef, transf_partial_fundef in TTRANSF. - destruct fd. - + monadInv TTRANSF. simpl in *. - rewrite comp_transf_function; eauto. - + inv TTRANSF. simpl in *. auto. - - erewrite agree_sp; eauto. - constructor. - } - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. - (* simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). *) -+ (* Direct call *) - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - exploit (call_arguments_match (Mach.undef_regs destroyed_at_function_entry rs)); eauto. - instantiate (1 := (rs0 # PC <- (Genv.symbol_address tge fid Ptrofs.zero)) # X1 <- (Val.offset_ptr (rs0 PC) Ptrofs.one)). - simpl. eapply agree_exten. eapply agree_undef_regs; eauto. intros. Simpl. - intros [args' [ARGS' LDARGS]]. - destruct (cp_eq_dec (comp_of tf') (comp_of tf)) eqn:Heq. * left; econstructor; split. rewrite comp_transf_function; eauto. apply plus_one. eapply exec_step_internal_call. @@ -1082,215 +930,187 @@ Local Transparent destroyed_by_op. simpl; eauto. simpl; eauto. Simpl; eauto. - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. - rewrite <- (comp_transl_partial _ H4). - eapply allowed_call_translated; eauto. - simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - unfold update_stack_call. Simpl. - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. - simpl. - simpl; unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - unfold comp_of in *; simpl in *. unfold comp_of in *. now rewrite Heq. - eauto. - (* Not a cross-compartment call *) - rewrite e, Genv.type_of_call_same_cp; now auto. - (* { unfold Genv.type_of_call; simpl in *. *) - (* unfold comp_of. unfold comp_of in Heq. now setoid_rewrite Heq. } *) - { simpl. rewrite <- comp_transf_function; eauto. - rewrite <- (comp_transl_partial _ TTRANSF). - eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } - (* replace (comp_of f) with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) - rewrite comp_transf_function; eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - (* { rewrite find_comp_translated. unfold tge. *) - (* unfold Genv.find_comp_in_genv. simpl. *) - (* exploit functions_transl; eauto. intros G. *) - (* rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ G). *) - (* rewrite comp_transf_function; simpl; eauto. } *) - { Simpl. - change (comp_of (Internal tf)) with (comp_of tf) in Heq. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). - apply match_stacks_intra_compartment; trivial. - replace (comp_of fd) with (comp_of f). auto. - { rewrite comp_transf_function; eauto. - unfold transf_fundef, transf_partial_fundef in TTRANSF. - destruct fd. - - monadInv TTRANSF. simpl in *. - rewrite comp_transf_function. rewrite e; eauto. - eauto. - - inv TTRANSF. simpl in *. auto. } - unfold Mach.call_comp. simpl. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). - { simpl. + rewrite <- (comp_transl_partial _ H4). + eapply allowed_call_translated; eauto. + simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + unfold update_stack_call. Simpl. + rewrite H7; simpl. + simpl. + unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + rewrite <- H2. simpl. rewrite Heq. + reflexivity. + eauto. + { simpl. + intros. + rewrite <- (comp_transl_partial _ H4) in H8. + rewrite <- (comp_transl_partial _ TTRANSF) in H8. + specialize (NO_CROSS_PTR H8). + now eapply Val.lessdef_list_not_ptr; eauto. } + { simpl. rewrite <- comp_transf_function; eauto. + rewrite <- (comp_transl_partial _ TTRANSF). + eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } + rewrite comp_transf_function; eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + { eapply match_stacks_cross_compartment. exact STACKS'. + - unfold Mach.call_comp. simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). + - simpl. + rewrite <- find_comp_of_block_translated. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). + - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). + simpl. + rewrite comp_transf_function; eauto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + + monadInv TTRANSF. simpl in *. rewrite comp_transf_function; eauto. - unfold transf_fundef, transf_partial_fundef in TTRANSF. - destruct fd. - - monadInv TTRANSF. simpl in *. - rewrite comp_transf_function. rewrite e; eauto. - eauto. - - inv TTRANSF. simpl in *. auto. } - } - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. - Simpl. rewrite <- H2. auto. - (* simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). *) - * destruct (flowsto_dec (comp_of tf') (comp_of tf)) eqn:?. - -- left; econstructor; split. - rewrite comp_transf_function; eauto. - apply plus_one. eapply exec_step_internal_call. - rewrite <- H2; simpl; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - simpl; eauto. - Simpl; eauto. - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. - rewrite <- (comp_transl_partial _ H4). - eapply allowed_call_translated; eauto. - simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - unfold update_stack_call. Simpl. - (* rewrite H7; simpl. *) - (* simpl. *) - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. simpl. - unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - rewrite <- H2. simpl. rewrite Heq. - reflexivity. - eauto. - { simpl. - intros. - rewrite <- (comp_transl_partial _ H4) in H5. - rewrite <- (comp_transl_partial _ TTRANSF) in H5. - specialize (NO_CROSS_PTR H5). - now eapply Val.lessdef_list_not_ptr; eauto. } - { simpl. rewrite <- comp_transf_function; eauto. - rewrite <- (comp_transl_partial _ TTRANSF). - eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } - (* replace (comp_of f) *) - (* with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) - rewrite comp_transf_function; eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - (* TODO: clean *) - { eapply match_stacks_cross_compartment. exact STACKS'. - - unfold Mach.call_comp. simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). - - simpl. - rewrite <- find_comp_of_block_translated. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). - - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). - simpl. - rewrite comp_transf_function; eauto. - unfold transf_fundef, transf_partial_fundef in TTRANSF. - destruct fd. - + monadInv TTRANSF. simpl in *. - rewrite comp_transf_function; eauto. - + inv TTRANSF. simpl in *. auto. - - erewrite agree_sp; eauto. - constructor. - } - simpl. eapply agree_exten; eauto. intros. Simpl. - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. simpl. - Simpl. rewrite <- H2. auto. - (* simpl. *) - (* now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). *) - -- left; econstructor; split. - rewrite comp_transf_function; eauto. - apply plus_one. eapply exec_step_internal_call. - rewrite <- H2; simpl; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - simpl; eauto. - Simpl; eauto. - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. - rewrite <- (comp_transl_partial _ H4). - eapply allowed_call_translated; eauto. - simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - unfold update_stack_call. Simpl. - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. simpl. - unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). - rewrite <- H2. simpl. rewrite Heq. - reflexivity. - eauto. - { simpl. - intros. - rewrite <- (comp_transl_partial _ H4) in H5. - rewrite <- (comp_transl_partial _ TTRANSF) in H5. - specialize (NO_CROSS_PTR H5). - now eapply Val.lessdef_list_not_ptr; eauto. } - { simpl. rewrite <- comp_transf_function; eauto. - rewrite <- (comp_transl_partial _ TTRANSF). - eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } - (* replace (comp_of f) *) - (* with (Genv.find_comp_in_genv ge (Vptr fb (Ptrofs.add ofs Ptrofs.one))). *) - rewrite comp_transf_function; eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - (* { rewrite find_comp_translated. unfold tge. *) - (* unfold Genv.find_comp_in_genv. simpl. *) - (* exploit functions_transl; eauto. intros G. *) - (* rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ G). *) - (* rewrite comp_transf_function; simpl; eauto. } *) - (* TODO: clean *) - { eapply match_stacks_cross_compartment. exact STACKS'. - - unfold Mach.call_comp. simpl. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). - - simpl. - rewrite <- find_comp_of_block_translated. - now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). - (* - rewrite (comp_transl_partial _ TTRANSF). *) - (* rewrite (comp_transl_partial _ H4). *) - (* intros contra. now rewrite contra, Pos.eqb_refl in Heq. *) - - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). - simpl. - rewrite comp_transf_function; eauto. - unfold transf_fundef, transf_partial_fundef in TTRANSF. - destruct fd. - + monadInv TTRANSF. simpl in *. - rewrite comp_transf_function; eauto. - + inv TTRANSF. simpl in *. auto. - - erewrite agree_sp; eauto. - constructor. - } - simpl. eapply agree_exten; eauto. intros. Simpl. - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. simpl. - Simpl. rewrite <- H2. auto. - (* simpl. now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). *) - -- (* Mtailcall *) - assert (f0 = f) by congruence. subst f0. - inversion AT; subst. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. - intros [parent' [A B]]. - destruct ros as [rf|fid]; simpl in H; monadInv H7. -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Ptrofs.zero). - exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. - exploit make_epilogue_correct; eauto using (comp_transl_partial _ H6). - intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - now rewrite <- H4; simpl; erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. + + inv TTRANSF. simpl in *. auto. + - erewrite agree_sp; eauto. + constructor. + } + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. + + (* Direct call *) + generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). + econstructor; eauto. + exploit return_address_offset_correct; eauto. intros; subst ra. + exploit (call_arguments_match (Mach.undef_regs destroyed_at_function_entry rs)); eauto. + instantiate (1 := (rs0 # PC <- (Genv.symbol_address tge fid Ptrofs.zero)) # X1 <- (Val.offset_ptr (rs0 PC) Ptrofs.one)). + simpl. eapply agree_exten. eapply agree_undef_regs; eauto. intros. Simpl. + intros [args' [ARGS' LDARGS]]. + destruct (flowsto_dec (comp_of tf') (comp_of tf)) eqn:Heq. + * left; econstructor; split. + rewrite comp_transf_function; eauto. + apply plus_one. eapply exec_step_internal_call. + rewrite <- H2; simpl; eauto. + eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; eauto. + simpl; eauto. + Simpl; eauto. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. + rewrite <- (comp_transl_partial _ H4). + eapply allowed_call_translated; eauto. + simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + unfold update_stack_call. Simpl. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. + simpl. + simpl; unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + unfold comp_of in *; simpl in *. unfold comp_of in *. now rewrite Heq. + eauto. + (* Not a cross-compartment call *) + simpl; rewrite Heq; now auto. + { simpl. rewrite <- comp_transf_function; eauto. + rewrite <- (comp_transl_partial _ TTRANSF). + eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } rewrite comp_transf_function; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + { Simpl. + change (comp_of (Internal tf)) with (comp_of tf) in Heq. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). + eapply match_stacks_intra_compartment; trivial. + simpl; eauto. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND); auto. + (* replace (comp_of fd) with (comp_of f). auto. *) + { simpl. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND); auto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + - monadInv TTRANSF. simpl in *. + rewrite !comp_transf_function; eauto. + - inv TTRANSF. simpl in *. auto with comps. } + } + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. + Simpl. rewrite <- H2. auto. + * left; econstructor; split. + rewrite comp_transf_function; eauto. + apply plus_one. eapply exec_step_internal_call. + rewrite <- H2; simpl; eauto. + eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; eauto. + simpl; eauto. + Simpl; eauto. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. + rewrite <- (comp_transl_partial _ H4). + eapply allowed_call_translated; eauto. + simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + unfold update_stack_call. Simpl. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. simpl. + unfold tge; rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ TFIND). + rewrite <- H2. simpl. rewrite Heq. reflexivity. - simpl. reflexivity. eauto. eauto. - Simpl; eauto. + eauto. + { simpl. + intros. + rewrite <- (comp_transl_partial _ H4) in H5. + rewrite <- (comp_transl_partial _ TTRANSF) in H5. + specialize (NO_CROSS_PTR H5). + now eapply Val.lessdef_list_not_ptr; eauto. } + { simpl. rewrite <- comp_transf_function; eauto. + rewrite <- (comp_transl_partial _ TTRANSF). + eapply call_trace_lessdef; eauto using senv_preserved, symbols_preserved. } + rewrite comp_transf_function; eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + { eapply match_stacks_cross_compartment. exact STACKS'. + - unfold Mach.call_comp. simpl. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ FIND). + - simpl. + rewrite <- find_comp_of_block_translated. + now rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). + - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ CALLED). + simpl. + rewrite comp_transf_function; eauto. + unfold transf_fundef, transf_partial_fundef in TTRANSF. + destruct fd. + + monadInv TTRANSF. simpl in *. + rewrite comp_transf_function; eauto. + + inv TTRANSF. simpl in *. auto. + - erewrite agree_sp; eauto. + constructor. + } + simpl. eapply agree_exten; eauto. intros. Simpl. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. simpl. + Simpl. rewrite <- H2. auto. + + - (* Mtailcall *) + assert (f0 = f) by congruence. subst f0. + inversion AT; subst. + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. + intros [parent' [A B]]. + destruct ros as [rf|fid]; simpl in H; monadInv H7. + + (* Indirect call *) + assert (rs rf = Vptr f' Ptrofs.zero). + destruct (rs rf); try discriminate. + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). + exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. + exploit make_epilogue_correct; eauto using (comp_transl_partial _ H6). + intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + now rewrite <- H4; simpl; erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. + rewrite comp_transf_function; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + reflexivity. + simpl. reflexivity. eauto. eauto. + Simpl; eauto. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). eauto. rewrite <- (comp_transl_partial _ H6). now rewrite <- find_comp_of_block_translated, NEXTCOMP. @@ -1300,21 +1120,21 @@ Local Transparent destroyed_by_op. econstructor; eauto. apply agree_set_other; auto with asmgen. Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. -+ (* Direct call *) - exploit make_epilogue_correct; eauto using (comp_transl_partial _ H6). - intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - rewrite comp_transf_function; eauto. - eapply plus_right'. eapply exec_straight_exec; eauto. - rewrite <- comp_transf_function; eauto. - now rewrite <- H4; simpl; erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - reflexivity. - simpl. reflexivity. eauto. eauto. - Simpl; eauto. + + (* Direct call *) + exploit make_epilogue_correct; eauto using (comp_transl_partial _ H6). + intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + rewrite comp_transf_function; eauto. + eapply plus_right'. eapply exec_straight_exec; eauto. + rewrite <- comp_transf_function; eauto. + now rewrite <- H4; simpl; erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + reflexivity. + simpl. reflexivity. eauto. eauto. + Simpl; eauto. unfold Genv.symbol_address. now rewrite symbols_preserved, H. rewrite <- (comp_transl_partial _ H6). simpl. now rewrite <- find_comp_of_block_translated. @@ -1545,21 +1365,22 @@ Local Transparent destroyed_at_function_entry. rewrite <- find_comp_of_block_translated. rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3). change (comp_of (Internal f0)) with (comp_of f0). - destruct (cp_eq_dec cp (comp_of f0)) eqn:e. - - subst cp. - (* apply Pos.eqb_eq in e. subst cp. *) - eexists; split; auto. + destruct (flowsto_dec cp (comp_of f0)) eqn:e. + - eexists; split; auto. inv STACKS'; auto. - unfold Mach.call_comp in *; simpl in *. + { simpl in H1. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in H1; auto. + } + { unfold Mach.call_comp in *; simpl in *. rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in H4. simpl in *. - inv H10. - rewrite find_comp_of_block_translated in H5. congruence. + inv H11. + rewrite find_comp_of_block_translated in H9. congruence. } - inv STACKS'; auto. + unfold Mach.call_comp in *. simpl in *. - clear e. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in n. simpl in n. - congruence. + rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in H9. + now auto. + + unfold Mach.call_comp in *. simpl in *. rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in H1. eauto. } @@ -1579,30 +1400,36 @@ Local Transparent destroyed_at_function_entry. { rewrite ATPC. simpl. intros diff. inv STACKS'; auto. - - simpl in diff. erewrite Genv.find_funct_ptr_find_comp_of_block in diff; eauto. now simpl in diff. - - inv H10. reflexivity. } - { intros diff. + - simpl in *. + erewrite Genv.find_funct_ptr_find_comp_of_block in H9; eauto. now auto. + - inv H11. reflexivity. } + { + intros diff. inv STACKS'; auto. - - simpl in diff. erewrite Genv.find_funct_ptr_find_comp_of_block in diff; eauto. now simpl in diff. - - inv H10. eapply agree_sp; eauto. } + - simpl in *. + erewrite Genv.find_funct_ptr_find_comp_of_block in H9; eauto. now auto. + - inv H11. eapply agree_sp; eauto. } + { intros TYPE. inv STACKS'; auto. - - simpl in *. erewrite Genv.find_funct_ptr_find_comp_of_block in TYPE; eauto. simpl in TYPE. - pose proof (flowsto_refl (comp_of f0)); now destruct (flowsto_dec (comp_of f0) (comp_of f0)). + - simpl in *. + erewrite Genv.find_funct_ptr_find_comp_of_block in H9; eauto. simpl in H9. + now destruct (flowsto_dec cp (comp_of f0)). - simpl in *. erewrite Genv.find_funct_ptr_find_comp_of_block in NO_CROSS_PTR; eauto. simpl in *. specialize (NO_CROSS_PTR TYPE). - inv H10. + inv H11. (* TODO: factorize into a lemma Val.lessdef_not_ptr *) inv LD; auto. now rewrite <- H0 in NO_CROSS_PTR. } { inv STACKS'; auto. - simpl in *. - rewrite (Genv.find_funct_ptr_find_comp_of_block _ _ H3) in *. simpl in *. assert (t = E0). - { inv EV; auto. rewrite Genv.type_of_call_same_cp in H; now auto. } + { inv EV; auto. simpl in H. + now destruct flowsto_dec. } subst. - constructor. - rewrite Genv.type_of_call_same_cp; now auto. - - simpl in *. inv H10. + constructor. simpl. + erewrite Genv.find_funct_ptr_find_comp_of_block in H9; eauto. simpl in H9. + now destruct (flowsto_dec cp (comp_of f0)). + - simpl in *. inv H11. erewrite Genv.find_funct_ptr_find_comp_of_block in EV; eauto. eapply return_trace_lessdef with (ge := ge) (v := Mach.return_value rs sg); eauto using senv_preserved. } diff --git a/security/Backtranslation.v b/security/Backtranslation.v index d12e19a966..5efa1b1d77 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -10,7 +10,6 @@ Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. Require Import Ctypes Clight. - Ltac simpl_expr := repeat (match goal with | |- eval_expr _ _ _ _ _ _ _ => econstructor @@ -71,7 +70,7 @@ Section SWITCH. (* 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. *) + (* destruct (Mem.valid_access_store mMint64 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. *) @@ -185,13 +184,13 @@ Section CONV. Variable ge: Senv.t. - (* Definition not_in_env (e: env) id := e ! id = None. *) + 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 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 @@ -371,12 +370,12 @@ Section CONV. | 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. *) + 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 @@ -602,40 +601,40 @@ Section AUX. 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. *) + 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 c61fccd59b..657ccce208 100644 --- a/security/BacktranslationAux.v +++ b/security/BacktranslationAux.v @@ -12,2011 +12,2028 @@ Require Import Backtranslation. -(* Section CODEPROOFS. *) - -(* Lemma ptr_of_id_ofs_eval *) -(* (ge: genv) id ofs e b cp le m *) -(* (GE1: wf_env ge e) *) -(* (GE2: Senv.find_symbol ge id = Some b) *) -(* : *) -(* eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). *) -(* Proof. *) -(* specialize (GE1 id). rewrite GE2 in GE1. *) -(* unfold ptr_of_id_ofs. destruct (Archi.ptr64) eqn:ARCH. *) -(* - eapply eval_Ebinop. eapply eval_Eaddrof. eapply eval_Evar_global; eauto. *) -(* simpl_expr. *) -(* simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. *) -(* rewrite Ptrofs.of_int64_to_int64; auto. *) -(* - eapply eval_Ebinop. eapply eval_Eaddrof. eapply eval_Evar_global; eauto. *) -(* simpl_expr. *) -(* simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. *) -(* erewrite Ptrofs.agree32_of_ints_eq; auto. apply Ptrofs.agree32_to_int; auto. *) -(* Qed. *) - -(* Lemma code_mem_delta_cons *) -(* (ge: Senv.t) cp k d sn *) -(* : *) -(* code_mem_delta ge cp (k :: d) sn = *) -(* Ssequence (code_mem_delta_kind ge cp k) (code_mem_delta ge cp d sn). *) -(* Proof. unfold code_mem_delta. ss. Qed. *) - -(* Lemma code_mem_delta_app *) -(* (ge: Senv.t) cp d1 d2 sn *) -(* : *) -(* code_mem_delta ge cp (d1 ++ d2) sn = (code_mem_delta ge cp d1 (code_mem_delta ge cp d2 sn)). *) -(* Proof. *) -(* revert sn d2. induction d1; intros; ss. *) -(* rewrite ! code_mem_delta_cons. erewrite IHd1. auto. *) -(* Qed. *) - -(* Lemma type_of_chunk_val_to_expr *) -(* (ge: Senv.t) ch ty v e *) -(* (WF: wf_chunk_val_b ch v) *) -(* (CT: chunk_to_type ch = Some ty) *) -(* (CVE: chunk_val_to_expr ge ch v = Some e) *) -(* : *) -(* typeof e = ty. *) -(* Proof. unfold chunk_val_to_expr in CVE. rewrite CT in CVE. des_ifs. Qed. *) - -(* Definition val_is_int (v: val) := (match v with | Vint _ => True | _ => False end). *) -(* Definition val_is_not_int (v: val) := (match v with | Vint _ => False | _ => True end). *) - -(* Lemma val_cases v: (val_is_int v) \/ (val_is_not_int v). *) -(* Proof. destruct v; ss; auto. Qed. *) - -(* Lemma sem_cast_chunk_val *) -(* (ge: Senv.t) m ch ty v e *) -(* (WF: wf_chunk_val_b ch v) *) -(* (CT: chunk_to_type ch = Some ty) *) -(* (CVE: chunk_val_to_expr ge ch v = Some e) *) -(* (NINT: val_is_not_int v) *) -(* : *) -(* Cop.sem_cast v (typeof e) ty m = Some v. *) -(* Proof. *) -(* erewrite type_of_chunk_val_to_expr; eauto. apply Cop.cast_val_casted. clear - WF CT NINT. *) -(* unfold wf_chunk_val_b, wf_chunk_val_b in WF. des_ifs; ss; inv CT; econs. *) -(* Qed. *) - -(* Definition cast_chunk_int (ch: memory_chunk) (i: int): val := *) -(* match ch with *) -(* | Mint8signed => Vint (Int.sign_ext 8 i) *) -(* | Mint8unsigned => Vint (Int.zero_ext 8 i) *) -(* | Mint16signed => Vint (Int.sign_ext 16 i) *) -(* | Mint16unsigned => Vint (Int.zero_ext 16 i) *) -(* | Mint32 => Vint i *) -(* | _ => Vundef *) -(* end. *) - -(* Lemma chunk_val_to_expr_eval *) -(* (ge: genv) ch v exp e cp le m *) -(* (EXP: chunk_val_to_expr ge ch v = Some exp) *) -(* (WF: wf_chunk_val_b ch v) *) -(* : *) -(* eval_expr ge e cp le m exp v. *) -(* Proof. unfold chunk_val_to_expr in EXP. des_ifs; ss; econs. Qed. *) - -(* Lemma wf_chunk_val_chunk_to_type *) -(* ch v *) -(* (WF: wf_chunk_val_b ch v) *) -(* : *) -(* exists ty, chunk_to_type ch = Some ty. *) -(* Proof. unfold wf_chunk_val_b in WF. des_ifs; ss; eauto. Qed. *) - -(* Lemma wf_chunk_val_chunk_val_to_expr *) -(* (ge: Senv.t) ch v *) -(* (WF: wf_chunk_val_b ch v) *) -(* : *) -(* exists ve, chunk_val_to_expr ge ch v = Some ve. *) -(* Proof. *) -(* unfold chunk_val_to_expr. exploit wf_chunk_val_chunk_to_type; eauto. *) -(* intros (ty & TY). rewrite TY. unfold wf_chunk_val_b in WF. des_ifs; ss; eauto. *) -(* Qed. *) - -(* Lemma code_mem_delta_storev_correct *) -(* (ge: genv) f k e le m m' *) -(* d *) -(* (WFE: wf_env ge e) *) -(* (STORE: mem_delta_apply_storev (Some m) d = Some m') *) -(* (WF: wf_mem_delta_storev_b ge (comp_of f) d) *) -(* : *) -(* step1 ge (State f (code_mem_delta_storev ge (comp_of f) d) k e le m) *) -(* E0 (State f Sskip k e le m'). *) -(* Proof. *) -(* unfold wf_mem_delta_storev_b in WF. des_ifs. rename m0 into ch, i into ofs. ss. *) -(* exploit wf_chunk_val_chunk_to_type; eauto. intros (ty & TY). *) -(* exploit wf_chunk_val_chunk_val_to_expr; eauto. intros (ve & EXPR). *) -(* rewrite H, Heq, TY, EXPR. *) -(* destruct (val_cases v) as [INT | NINT]. *) -(* { unfold val_is_int in INT. des_ifs. clear INT. eapply step_assign. *) -(* - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval; auto. *) -(* eapply Genv.invert_find_symbol; eauto. *) -(* - instantiate (1:=Vint i). eapply chunk_val_to_expr_eval; eauto. *) -(* - instantiate (1:=cast_chunk_int ch i). erewrite type_of_chunk_val_to_expr; eauto. *) -(* unfold chunk_to_type in TY. destruct ch; ss; inv TY. *) -(* + unfold Cop.sem_cast. ss. des_ifs. *) -(* + unfold Cop.sem_cast. ss. des_ifs. *) -(* + unfold Cop.sem_cast. ss. des_ifs. *) -(* + unfold Cop.sem_cast. ss. des_ifs. *) -(* + unfold Cop.sem_cast. ss. des_ifs. *) -(* - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. *) -(* rewrite <- STORE. apply Pos.eqb_eq in WF. subst c. destruct ch; ss. *) -(* + rewrite Mem.store_int8_sign_ext. auto. *) -(* + rewrite Mem.store_int8_zero_ext. auto. *) -(* + rewrite Mem.store_int16_sign_ext. auto. *) -(* + rewrite Mem.store_int16_zero_ext. auto. *) -(* } *) -(* { rewrite WF, H0. ss. eapply step_assign. *) -(* - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval; auto. *) -(* eapply Genv.invert_find_symbol; eauto. *) -(* - instantiate (1:=v). eapply chunk_val_to_expr_eval; eauto. *) -(* - ss. eapply sem_cast_chunk_val; eauto. *) -(* - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. *) -(* apply Pos.eqb_eq in WF. clarify. *) -(* } *) -(* Qed. *) - -(* Lemma wf_mem_delta_storev_false_is_skip *) -(* (ge: Senv.t) cp d *) -(* (NWF: wf_mem_delta_storev_b ge cp d = false) *) -(* : *) -(* code_mem_delta_storev ge cp d = Sskip. *) -(* Proof. destruct d as [[[ch ptr] v] cp0]. ss. des_ifs. Qed. *) - -(* Lemma code_mem_delta_correct *) -(* (ge: genv) *) -(* f k e le m m' *) -(* d snext *) -(* (WFE: wf_env ge e) *) -(* (APPD: mem_delta_apply_wf ge (comp_of f) d (Some m) = Some m') *) -(* : *) -(* (star step1 ge (State f (code_mem_delta ge (comp_of f) d snext) k e le m) *) -(* E0 (State f snext k e le m')). *) -(* Proof. *) -(* revert m m' snext APPD. induction d; intros. *) -(* { unfold mem_delta_apply_wf in APPD. ss. inv APPD. unfold code_mem_delta. ss. econs 1. } *) -(* rewrite mem_delta_apply_wf_cons in APPD. rewrite code_mem_delta_cons. *) -(* des_ifs. *) -(* - exploit mem_delta_apply_wf_some; eauto. intros (mi & APPD0). rewrite APPD0 in APPD. *) -(* destruct a; ss. econs 2. *) -(* { eapply step_seq. } *) -(* econs 2. *) -(* { eapply code_mem_delta_storev_correct; eauto. } *) -(* take_step. eapply IHd; eauto. eauto. auto. *) -(* - destruct a; ss. *) -(* rewrite wf_mem_delta_storev_false_is_skip; auto. *) -(* all: take_step; take_step; eapply IHd; eauto. *) -(* Qed. *) - -(* Lemma code_bundle_trace_spec *) -(* (ge: genv) cp cnt tr *) -(* f e le m k *) -(* : *) -(* star step1 ge *) -(* (State f (code_bundle_trace ge cp cnt tr) k e le m) *) -(* E0 *) -(* (State f (switch_bundle_events ge cnt cp tr) *) -(* (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge cnt cp tr)) Sskip k) *) -(* e le m). *) -(* Proof. *) -(* econs 2. *) -(* { unfold code_bundle_trace, Swhile. eapply step_loop. } *) -(* econs 2. *) -(* { eapply step_seq. } *) -(* econs 2. *) -(* { eapply step_ifthenelse. simpl_expr. ss. } *) -(* rewrite Int.eq_false; ss. econs 2. *) -(* { eapply step_skip_seq. } *) -(* econs 1. all: eauto. *) -(* Qed. *) - -(* End CODEPROOFS. *) - - -(* Section GENV. *) - -(* Definition symbs_public (ge1 ge2: Senv.t) := (forall id : ident, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id). *) -(* Definition symbs_find (ge1 ge2: Senv.t) := forall id b, Senv.find_symbol ge1 id = Some b -> Senv.find_symbol ge2 id = Some b. *) -(* Definition symbs_volatile (ge1 ge2: Senv.t) := forall b, Senv.block_is_volatile ge2 b = Senv.block_is_volatile ge1 b. *) - -(* Definition match_symbs (ge1 ge2: Senv.t) := symbs_public ge1 ge2 /\ symbs_find ge1 ge2 /\ symbs_volatile ge1 ge2. *) - -(* Lemma match_symbs_meminj_public *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* : *) -(* meminj_public ge1 = meminj_public ge2. *) -(* Proof. *) -(* destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). unfold meminj_public. extensionalities b. des_ifs. *) -(* - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. *) -(* apply Senv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. *) -(* - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. *) -(* apply Senv.find_invert_symbol in x0. clarify. *) -(* - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. *) -(* apply Senv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. *) -(* - exfalso. rewrite MSYMB1 in Heq1. apply Senv.public_symbol_exists in Heq1. des. *) -(* exploit MSYMB2; eauto. intros. apply Senv.invert_find_symbol in Heq0. clarify. *) -(* apply Senv.find_invert_symbol in Heq1. clarify. *) -(* Qed. *) - -(* Lemma match_symbs_wf_mem_delta_storev *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp0 d *) -(* : *) -(* wf_mem_delta_storev_b ge1 cp0 d = wf_mem_delta_storev_b ge2 cp0 d. *) -(* Proof. *) -(* destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). *) -(* destruct d as [[[ch ptr] v] cp]. ss. des_ifs. *) -(* - do 2 f_equal. apply Senv.invert_find_symbol, MSYMB2, Senv.find_invert_symbol in Heq. clarify. *) -(* - exfalso. apply Senv.invert_find_symbol, MSYMB2, Senv.find_invert_symbol in Heq. clarify. *) -(* - destruct (Senv.public_symbol ge2 i0) eqn:PUB; ss. *) -(* exfalso. rewrite MSYMB1 in PUB. apply Senv.public_symbol_exists in PUB. des. *) -(* exploit MSYMB2; eauto. intros. apply Senv.invert_find_symbol in Heq0. clarify. *) -(* apply Senv.find_invert_symbol in PUB. clarify. *) -(* Qed. *) - -(* Lemma match_symbs_wf_mem_delta_kind *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp *) -(* : *) -(* wf_mem_delta_kind_b ge1 cp = wf_mem_delta_kind_b ge2 cp. *) -(* Proof. unfold wf_mem_delta_kind_b. extensionalities d. des_ifs. apply match_symbs_wf_mem_delta_storev; auto. Qed. *) - -(* Lemma match_symbs_get_wf_mem_delta *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp d *) -(* : *) -(* get_wf_mem_delta ge1 cp d = get_wf_mem_delta ge2 cp d. *) -(* Proof. unfold get_wf_mem_delta. erewrite match_symbs_wf_mem_delta_kind; eauto. Qed. *) - -(* Lemma match_symbs_mem_delta_apply_wf *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp d m *) -(* : *) -(* mem_delta_apply_wf ge1 cp d m = mem_delta_apply_wf ge2 cp d m. *) -(* Proof. unfold mem_delta_apply_wf. erewrite match_symbs_get_wf_mem_delta; eauto. Qed. *) - -(* Lemma match_symbs_code_mem_delta_kind *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp *) -(* : *) -(* code_mem_delta_kind ge1 cp = code_mem_delta_kind ge2 cp. *) -(* Proof. *) -(* extensionalities k. unfold code_mem_delta_kind. des_ifs. *) -(* destruct d as [[[ch ptr] v] cp0]. ss. destruct ptr; ss. *) -(* destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). *) -(* destruct (Senv.invert_symbol ge1 b) eqn:INV1. *) -(* { exploit Senv.invert_find_symbol; eauto. intros FIND1. *) -(* exploit MSYMB2; eauto. intros FIND2. exploit Senv.find_invert_symbol; eauto. intros INV2. *) -(* rewrite INV2. destruct (chunk_to_type ch) eqn:CHTY; auto. *) -(* des_ifs. *) -(* - apply andb_prop in Heq0, Heq2. des. apply andb_prop in Heq0, Heq2. des. *) -(* assert (chunk_val_to_expr ge2 ch v = chunk_val_to_expr ge1 ch v). *) -(* { unfold chunk_val_to_expr. rewrite CHTY. clear - Heq6. *) -(* unfold wf_chunk_val_b in Heq6. des_ifs. *) -(* } *) -(* rewrite Heq, Heq1 in H. clarify. *) -(* - exfalso. apply andb_prop in Heq0. des. apply andb_prop in Heq0. des. *) -(* clarify. rewrite ! andb_true_r in Heq2. rewrite MSYMB1 in Heq2. clarify. *) -(* - exfalso. apply andb_prop in Heq0. des. apply andb_prop in Heq0. des. *) -(* apply (wf_chunk_val_chunk_val_to_expr (ge2)) in Heq3; eauto. des; clarify. *) -(* - exfalso. apply andb_prop in Heq2. des. apply andb_prop in Heq2. des. *) -(* clarify. rewrite ! andb_true_r in Heq0. rewrite MSYMB1 in Heq2; clarify. *) -(* - exfalso. apply andb_prop in Heq1. des. apply andb_prop in Heq1. des. *) -(* apply (wf_chunk_val_chunk_val_to_expr (ge1)) in Heq3; eauto. des; clarify. *) -(* } *) -(* { des_ifs. *) -(* exfalso. apply andb_prop in Heq2. des. apply andb_prop in Heq2. des. *) -(* rewrite MSYMB1 in Heq2. eapply Senv.public_symbol_exists in Heq2. des. *) -(* exploit MSYMB2. eapply Heq2. intros FIND4. eapply Senv.invert_find_symbol in Heq. clarify. *) -(* exploit Senv.find_invert_symbol. apply Heq2. intros INV3. clarify. *) -(* } *) -(* Qed. *) - -(* Lemma match_symbs_code_mem_delta *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp d s *) -(* : *) -(* code_mem_delta ge1 cp d s = code_mem_delta ge2 cp d s. *) -(* Proof. unfold code_mem_delta. erewrite match_symbs_code_mem_delta_kind; eauto. Qed. *) - -(* Lemma match_symbs_code_bundle_call *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp tr id evargs sg d *) -(* : *) -(* code_bundle_call ge1 cp tr id evargs sg d = code_bundle_call ge2 cp tr id evargs sg d. *) -(* Proof. unfold code_bundle_call. erewrite match_symbs_code_mem_delta; eauto. Qed. *) - -(* Lemma match_symbs_code_bundle_return *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp tr evr d *) -(* : *) -(* code_bundle_return ge1 cp tr evr d = code_bundle_return ge2 cp tr evr d. *) -(* Proof. unfold code_bundle_return. erewrite match_symbs_code_mem_delta; eauto. Qed. *) - -(* Lemma match_symbs_code_bundle_builtin *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp tr ef evargs d *) -(* : *) -(* code_bundle_builtin ge1 cp tr ef evargs d = code_bundle_builtin ge2 cp tr ef evargs d. *) -(* Proof. unfold code_bundle_builtin. erewrite match_symbs_code_mem_delta; eauto. Qed. *) - -(* Lemma match_symbs_code_bundle_events *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp *) -(* : *) -(* code_bundle_event ge1 cp = code_bundle_event ge2 cp. *) -(* Proof. *) -(* extensionalities be. unfold code_bundle_event. des_ifs. *) -(* eapply match_symbs_code_bundle_call; auto. eapply match_symbs_code_bundle_return; auto. eapply match_symbs_code_bundle_builtin; auto. *) -(* Qed. *) - -(* Lemma match_symbs_switch_bundle_events *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp cnt tr *) -(* : *) -(* switch_bundle_events ge1 cnt cp tr = switch_bundle_events ge2 cnt cp tr. *) -(* Proof. unfold switch_bundle_events. erewrite match_symbs_code_bundle_events; eauto. Qed. *) - -(* Lemma match_symbs_code_bundle_trace *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* cp cnt tr *) -(* : *) -(* code_bundle_trace ge1 cp cnt tr = code_bundle_trace ge2 cp cnt tr. *) -(* Proof. unfold code_bundle_trace. erewrite match_symbs_switch_bundle_events; eauto. Qed. *) - - -(* Lemma match_symbs_symbols_inject *) -(* ge1 ge2 *) -(* (MSYMB: match_symbs ge1 ge2) *) -(* : *) -(* symbols_inject (meminj_public ge1) ge1 ge2. *) -(* Proof. *) -(* destruct MSYMB as (MS0 & MS1 & MS2). unfold symbols_inject. splits; auto. *) -(* - i. unfold meminj_public in H. des_ifs. split; auto. *) -(* - i. exists b1. split; auto. unfold meminj_public. apply Senv.find_invert_symbol in H0. *) -(* rewrite H0. rewrite H. auto. *) -(* - i. unfold meminj_public in H. des_ifs. *) -(* Qed. *) - -(* End GENV. *) - - -(* Section PROOF. *) - -(* Lemma filter_filter *) -(* A (l: list A) (p q: A -> bool) *) -(* : *) -(* filter q (filter p l) = filter (fun a => (p a) && (q a)) l. *) -(* Proof. *) -(* induction l; ss. des_ifs; ss; clarify. *) -(* f_equal. auto. *) -(* Qed. *) - -(* Lemma get_wf_mem_delta_idem *) -(* ge cp d *) -(* : *) -(* get_wf_mem_delta ge cp (get_wf_mem_delta ge cp d) = get_wf_mem_delta ge cp d. *) -(* Proof. unfold get_wf_mem_delta. rewrite filter_filter. f_equal. extensionalities k. apply andb_diag. Qed. *) - -(* Lemma mem_delta_apply_wf_get_wf_mem_delta *) -(* ge cp d m *) -(* : *) -(* mem_delta_apply_wf ge cp d m = mem_delta_apply_wf ge cp (get_wf_mem_delta ge cp d) m. *) -(* Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_idem. auto. Qed. *) - -(* Lemma wf_mem_delta_kind_is_wf *) -(* ge cp k *) -(* (WF: wf_mem_delta_kind_b ge cp k) *) -(* : *) -(* mem_delta_kind_inj_wf cp (meminj_public ge) k. *) -(* Proof. unfold wf_mem_delta_kind_b in WF. des_ifs. unfold wf_mem_delta_storev_b in WF. ss. des_ifs. apply Pos.eqb_eq in WF. auto. Qed. *) - -(* Lemma get_wf_mem_delta_is_wf *) -(* cp ge d *) -(* : *) -(* mem_delta_inj_wf cp (meminj_public ge) (get_wf_mem_delta ge cp d). *) -(* Proof. induction d; ss. des_ifs. econs; auto. apply wf_mem_delta_kind_is_wf; auto. Qed. *) - -(* Lemma mem_delta_apply_establish_inject2 *) -(* (ge: Senv.t) k m0 m0' *) -(* (INJ: Mem.inject k m0 m0') *) -(* (INCR: inject_incr (meminj_public ge) k) *) -(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) -(* d cp m1 *) -(* (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) *) -(* (FO: public_first_order ge m1) *) -(* : *) -(* exists m1', mem_delta_apply_wf ge cp d (Some m0') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. *) -(* Proof. *) -(* unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. eapply mem_delta_apply_establish_inject; eauto. *) -(* apply get_wf_mem_delta_is_wf. *) -(* unfold public_first_order in FO. ii. unfold meminj_public in H. des_ifs. apply Senv.invert_find_symbol in Heq. *) -(* eapply FO; eauto. *) -(* Qed. *) - -(* Lemma mem_delta_apply_establish_inject_preprocess_gen *) -(* (ge: Senv.t) (k: meminj) m0 m0' *) -(* (INJ: Mem.inject k m0 m0') *) -(* pch pb pofs pv pcp m0'' *) -(* (PRE: Mem.store pch m0' pb pofs pv pcp = Some m0'') *) -(* (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) *) -(* (INCR: inject_incr (meminj_public ge) k) *) -(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) -(* d cp m1 *) -(* (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) *) -(* : *) -(* exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ *) -(* (meminj_first_order (meminj_public ge) m1 -> Mem.inject (meminj_public ge) m1 m1'). *) -(* Proof. *) -(* unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. *) -(* eapply mem_delta_apply_establish_inject_preprocess_gen; eauto. *) -(* apply get_wf_mem_delta_is_wf. *) -(* Qed. *) - -(* Lemma mem_delta_apply_establish_inject_preprocess2 *) -(* (ge: Senv.t) (k: meminj) m0 m0' *) -(* (INJ: Mem.inject k m0 m0') *) -(* pch pb pofs pv pcp m0'' *) -(* (PRE: Mem.store pch m0' pb pofs pv pcp = Some m0'') *) -(* (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) *) -(* (INCR: inject_incr (meminj_public ge) k) *) -(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) -(* d cp m1 *) -(* (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) *) -(* (FO: public_first_order ge m1) *) -(* : *) -(* exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. *) -(* Proof. *) -(* hexploit mem_delta_apply_establish_inject_preprocess_gen; eauto. i. des. *) -(* esplits; eauto. apply H0. ii. unfold meminj_public in H1. des_ifs. *) -(* eapply FO; eauto. apply Senv.invert_find_symbol; auto. *) -(* Qed. *) - -(* End PROOF. *) - - - -(* Section DEFINITIONS. *) - -(* Definition meminj_same_block (j : meminj) := *) -(* forall b1 b2 del, j b1 = Some (b2, del) -> b1 = b2. *) - -(* Definition not_global_blks (ge: Senv.t) (ebs: list block) := *) -(* Forall (fun b => Senv.invert_symbol ge b = None) ebs. *) - -(* Definition blocks_of_env2 ge e : list block := (map (fun x => fst (fst x)) (blocks_of_env ge e)). *) - -(* Definition not_inj_blks (j: meminj) (ebs: list block) := *) -(* Forall (fun b => j b = None) ebs. *) - -(* Lemma not_global_is_not_inj_bloks *) -(* ge l *) -(* (NGB: not_global_blks ge l) *) -(* : *) -(* not_inj_blks (meminj_public ge) l. *) -(* Proof. induction NGB. ss. econs; eauto. unfold meminj_public. des_ifs. Qed. *) - -(* Definition eq_policy (ge1: Asm.genv) (ge2: genv) := *) -(* Genv.genv_policy ge1 = Genv.genv_policy ge2. *) - -(* End DEFINITIONS. *) - - - -(* Section PROOF. *) - -(* (* Properties *) *) -(* Lemma eventval_match_transl *) -(* (ge: Senv.t) *) -(* ev ty v *) -(* (EM: eventval_match ge ev ty v) *) -(* : *) -(* eventval_match ge ev (typ_of_type (typ_to_type ty)) (eventval_to_val ge ev). *) -(* Proof. *) -(* inversion EM; subst; simpl; try constructor. *) -(* setoid_rewrite H0. unfold Tptr in *. destruct Archi.ptr64; auto. *) -(* Qed. *) - -(* Lemma eventval_match_eventval_to_val *) -(* (ge: Senv.t) *) -(* ev ty v *) -(* (EM: eventval_match ge ev ty v) *) -(* : *) -(* eventval_to_val ge ev = v. *) -(* Proof. inversion EM; subst; simpl; auto. setoid_rewrite H0. auto. Qed. *) - -(* Lemma eventval_list_match_transl *) -(* (ge: Senv.t) *) -(* evs tys vs *) -(* (EM: eventval_list_match ge evs tys vs) *) -(* : *) -(* eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs). *) -(* Proof. induction EM; simpl. constructor. constructor; auto. eapply eventval_match_transl; eauto. Qed. *) - -(* Lemma eventval_list_match_transl_val *) -(* (ge: Senv.t) *) -(* evs tys vs *) -(* (EM: eventval_list_match ge evs tys vs) *) -(* : *) -(* eventval_list_match ge evs tys (list_eventval_to_list_val ge evs). *) -(* Proof. induction EM; simpl. constructor. constructor; auto. erewrite eventval_match_eventval_to_val; eauto. Qed. *) - -(* Lemma typ_type_typ *) -(* (ge: Senv.t) *) -(* ev ty v *) -(* (EM: eventval_match ge ev ty v) *) -(* : *) -(* typ_of_type (typ_to_type ty) = ty. *) -(* Proof. inversion EM; simpl; auto. subst. unfold Tptr. destruct Archi.ptr64; simpl; auto. Qed. *) - -(* Lemma eventval_to_expr_val_eval *) -(* (ge: genv) en cp temp m ev ty v *) -(* (WFENV: wf_env ge en) *) -(* (EM: eventval_match ge ev ty v) *) -(* (* (WFGE: wf_eventval_ge ge ev) *) *) -(* : *) -(* eval_expr ge en cp temp m (eventval_to_expr ev) (eventval_to_val ge ev). *) -(* Proof. destruct ev; simpl in *; try constructor. inv EM. setoid_rewrite H4. eapply ptr_of_id_ofs_eval; auto. Qed. *) - -(* Lemma sem_cast_eventval_match *) -(* (ge: Senv.t) v ty vv m *) -(* (EM: eventval_match ge v (typ_of_type (typ_to_type ty)) vv) *) -(* : *) -(* Cop.sem_cast vv (typeof (eventval_to_expr v)) (typ_to_type ty) m = Some vv. *) -(* Proof. *) -(* destruct ty; simpl in *; inversion EM; subst; simpl in *; simpl_expr. *) -(* all: try rewrite ptr_of_id_ofs_typeof; simpl. *) -(* all: try (cbn; auto). *) -(* all: unfold Tptr in *; destruct Archi.ptr64 eqn:ARCH; try congruence. *) -(* { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } *) -(* { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } *) -(* { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } *) -(* { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } *) -(* Qed. *) - -(* Lemma list_eventval_to_expr_val_eval *) -(* (ge: genv) en cp temp m evs tys *) -(* (* (WFENV: Forall (wf_eventval_env en) evs) *) *) -(* (WFENV: wf_env ge en) *) -(* (EMS: eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs)) *) -(* : *) -(* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) (list_eventval_to_list_val ge evs). *) -(* Proof. *) -(* revert en cp temp m WFENV. *) -(* match goal with | [H: eventval_list_match _ _ ?t ?v |- _] => remember t as tys2; remember v as vs2 end. *) -(* revert tys Heqtys2 Heqvs2. induction EMS; intros; subst; simpl in *. *) -(* { destruct tys; simpl in *. constructor. congruence. } *) -(* inversion Heqvs2; clear Heqvs2; subst; simpl in *. *) -(* destruct tys; simpl in Heqtys2. congruence with Heqtys2. *) -(* inversion Heqtys2; clear Heqtys2; subst; simpl in *. *) -(* econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. *) -(* (* eapply eventval_match_wf_eventval_ge; eauto. *) *) -(* eapply sem_cast_eventval_match; eauto. *) -(* Qed. *) - -(* Lemma eventval_match_eventval_to_type *) -(* (ge: Senv.t) *) -(* ev ty v *) -(* (EM: eventval_match ge ev ty v) *) -(* : *) -(* eventval_match ge ev (typ_of_type (eventval_to_type ev)) v. *) -(* Proof. inversion EM; subst; simpl; auto. Qed. *) - -(* Lemma list_eventval_match_eventval_to_type *) -(* (ge: Senv.t) *) -(* evs tys vs *) -(* (ESM: eventval_list_match ge evs tys vs) *) -(* : *) -(* eventval_list_match ge evs (typlist_of_typelist (list_eventval_to_typelist evs)) vs. *) -(* Proof. induction ESM; simpl. constructor. constructor; auto. eapply eventval_match_eventval_to_type; eauto. Qed. *) - -(* Lemma val_load_result_idem *) -(* ch v *) -(* : *) -(* Val.load_result ch (Val.load_result ch v) = Val.load_result ch v. *) -(* Proof. *) -(* destruct ch, v; simpl; auto. *) -(* 5,6,7: destruct Archi.ptr64; simpl; auto. *) -(* 1,3: rewrite Int.sign_ext_idem; auto. *) -(* 3,4: rewrite Int.zero_ext_idem; auto. *) -(* all: lia. *) -(* Qed. *) - -(* Lemma val_load_result_aux *) -(* F V (ge: Genv.t F V) *) -(* ev ch v *) -(* (EM: eventval_match ge ev (type_of_chunk ch) (Val.load_result ch v)) *) -(* : *) -(* eventval_match ge ev (type_of_chunk ch) (Val.load_result ch (eventval_to_val ge ev)). *) -(* Proof. *) -(* inversion EM; subst; simpl in *; auto. *) -(* 1,2,3,4: rewrite H1, H2; rewrite val_load_result_idem; auto. *) -(* rewrite H3, H. rewrite H0. rewrite val_load_result_idem. auto. *) -(* Qed. *) - -(* Lemma eventval_match_proj_rettype *) -(* (ge: Senv.t) *) -(* ev ty v *) -(* (EM: eventval_match ge ev ty v) *) -(* : *) -(* eventval_match ge ev (proj_rettype (rettype_of_type (typ_to_type ty))) v. *) -(* Proof. *) -(* inversion EM; subst; simpl; try constructor. *) -(* unfold Tptr in *. destruct Archi.ptr64; simpl; auto. *) -(* Qed. *) - -(* (* Lemma sem_cast_eventval *) *) -(* (* (ge: cgenv) v m *) *) -(* (* (WFEV: wf_eventval_ge ge v) *) *) -(* (* : *) *) -(* (* Cop.sem_cast (eventval_to_val ge v) (typeof (eventval_to_expr v)) (eventval_to_type v) m = Some (eventval_to_val ge v). *) *) -(* (* Proof. rewrite typeof_eventval_to_expr_type. destruct v; simpl in *; simpl_expr. destruct WFEV. rewrite H. simpl_expr. Qed. *) *) - -(* (* Lemma list_eventval_to_expr_val_eval2 *) *) -(* (* (ge: genv) en cp temp m evs *) *) -(* (* (WFENV: Forall (wf_eventval_env en) evs) *) *) -(* (* (WFGE: Forall (wf_eventval_ge ge) evs) *) *) -(* (* : *) *) -(* (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_eventval_to_typelist evs) (list_eventval_to_list_val ge evs). *) *) -(* (* Proof. *) *) -(* (* move evs at top. revert ge en cp temp m WFENV WFGE. induction evs; intros; simpl in *. *) *) -(* (* constructor. *) *) -(* (* inversion WFENV; clear WFENV; subst. inversion WFGE; clear WFGE; subst. *) *) -(* (* econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. *) *) -(* (* apply sem_cast_eventval; auto. *) *) -(* (* Qed. *) *) - -(* Lemma eventval_match_sem_cast *) -(* (* F V (ge: Genv.t F V) *) *) -(* (ge: genv) *) -(* m ev ty v *) -(* (EM: eventval_match ge ev ty v) *) -(* : *) -(* (* Cop.sem_cast (eventval_to_val ge ev) (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some (eventval_to_val ge ev). *) *) -(* Cop.sem_cast v (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some v. *) -(* Proof. *) -(* inversion EM; subst; simpl; try constructor. all: simpl_expr. *) -(* rewrite ptr_of_id_ofs_typeof. unfold Tptr. unfold Cop.sem_cast. destruct Archi.ptr64 eqn:ARCH; simpl. *) -(* - rewrite ARCH; auto. *) -(* - rewrite ARCH; auto. *) -(* Qed. *) - -(* (* Lemma list_eventval_to_expr_val_eval_typs *) *) -(* (* (ge: genv) en cp temp m evs tys vs *) *) -(* (* (WFENV: Forall (wf_eventval_env en) evs) *) *) -(* (* (EMS: eventval_list_match ge evs tys vs) *) *) -(* (* : *) *) -(* (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) vs. *) *) -(* (* Proof. *) *) -(* (* revert en cp temp m WFENV. *) *) -(* (* induction EMS; intros; subst; simpl in *. constructor. *) *) -(* (* inversion WFENV; clear WFENV; subst. *) *) -(* (* econstructor; eauto. 2: eapply eventval_match_sem_cast; eauto. *) *) -(* (* exploit eventval_match_eventval_to_val. eauto. intros. rewrite <- H0. eapply eventval_to_expr_val_eval; auto. *) *) -(* (* eapply eventval_match_wf_eventval_ge; eauto. *) *) -(* (* Qed. *) *) - -(* Lemma sem_cast_ptr *) -(* b ofs m *) -(* : *) -(* Cop.sem_cast (Vptr b ofs) (Tpointer Tvoid noattr) (typ_to_type Tptr) m = Some (Vptr b ofs). *) -(* Proof. *) -(* unfold Tptr. destruct Archi.ptr64 eqn:ARCH; unfold Cop.sem_cast; simpl; rewrite ARCH; auto. *) -(* Qed. *) - -(* Lemma sem_cast_proj_rettype *) -(* (ge: genv) evres rty res m *) -(* (EVM: eventval_match ge evres (proj_rettype rty) res) *) -(* : *) -(* Cop.sem_cast (eventval_to_val ge evres) *) -(* (typeof (eventval_to_expr evres)) *) -(* (rettype_to_type rty) m *) -(* = Some (eventval_to_val ge evres). *) -(* Proof. *) -(* destruct rty; simpl in *. *) -(* { eapply eventval_match_sem_cast. eauto. erewrite eventval_match_eventval_to_val; eauto. } *) -(* { inv EVM; simpl; simpl_expr. *) -(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) -(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) -(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) -(* } *) -(* { inv EVM; simpl; simpl_expr. *) -(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) -(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) -(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) -(* } *) -(* { inv EVM; simpl; simpl_expr. *) -(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) -(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) -(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) -(* } *) -(* { inv EVM; simpl; simpl_expr. *) -(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) -(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) -(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) -(* } *) -(* { inv EVM; simpl; simpl_expr. *) -(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) -(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) -(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) -(* } *) -(* Qed. *) - -(* Lemma type_of_params_eq *) -(* params ts *) -(* (PARSIGS : list_typ_to_list_type ts = map snd params) *) -(* : *) -(* type_of_params params = list_typ_to_typelist ts. *) -(* Proof. *) -(* revert params PARSIGS. induction ts; ii; ss. *) -(* { destruct params; ss. } *) -(* destruct params; ss. destruct p; ss. clarify. f_equal. auto. *) -(* Qed. *) - -(* Lemma match_senv_eventval_match *) -(* (ge0 ge1: Senv.t) *) -(* (MS: match_symbs ge0 ge1) *) -(* ev ty v *) -(* (EM: eventval_match ge0 ev ty v) *) -(* : *) -(* eventval_match ge1 ev ty v. *) -(* Proof. destruct MS as (MS0 & MS1 & MS2). inv EM; try econs; auto. rewrite MS0. auto. Qed. *) - -(* Lemma match_senv_eventval_list_match *) -(* (ge0 ge1: Senv.t) *) -(* (MS: match_symbs ge0 ge1) *) -(* evs tys vs *) -(* (EM: eventval_list_match ge0 evs tys vs) *) -(* : *) -(* eventval_list_match ge1 evs tys vs. *) -(* Proof. induction EM; ss. econs; auto. econs; auto. eapply match_senv_eventval_match; eauto. Qed. *) - -(* Lemma unbundle_trace_app *) -(* tr1 tr2 *) -(* : *) -(* unbundle_trace (tr1 ++ tr2) = (unbundle_trace tr1) ++ (unbundle_trace tr2). *) -(* Proof. induction tr1; ss. rewrite <- app_assoc. f_equal. auto. Qed. *) - -(* Lemma allowed_call_gen_function *) -(* cp (ge_i: Asm.genv) (ge_c: genv) next cnt params tr f_i f_c *) -(* (GE: symbs_find ge_i ge_c) *) -(* (GEPOL: eq_policy ge_i ge_c) *) -(* (GEN: f_c = gen_function ge_i cnt params tr f_i) *) -(* (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) *) -(* (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.Internal f_i)) *) -(* (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = Some (Internal f_c)) *) -(* : *) -(* Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). *) -(* Proof. *) -(* unfold Genv.allowed_call in *. des; [left | right]. *) -(* - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. *) -(* - subst. unfold Genv.allowed_cross_call in *. des. *) -(* unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. *) -(* specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. *) -(* { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. *) -(* apply GE. auto. *) -(* } *) -(* { i. rewrite FINDF_C in H. clarify. } *) -(* { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. *) -(* rewrite <- ALLOW1. ss. *) -(* } *) -(* Qed. *) - -(* Lemma allowed_call_gen_function_external *) -(* cp (ge_i: Asm.genv) (ge_c: genv) next ef *) -(* (GE: symbs_find ge_i ge_c) *) -(* (GEPOL: eq_policy ge_i ge_c) *) -(* (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) *) -(* (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.External ef)) *) -(* (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = *) -(* Some (External ef *) -(* (list_typ_to_typelist (sig_args (ef_sig ef))) *) -(* (rettype_to_type (sig_res (ef_sig ef))) *) -(* (sig_cc (ef_sig ef)))) *) -(* : *) -(* Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). *) -(* Proof. *) -(* unfold Genv.allowed_call in *. des; [left | right]. *) -(* - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. *) -(* - unfold Genv.allowed_cross_call in *. des. *) -(* unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. *) -(* specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. *) -(* { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. *) -(* apply GE. auto. *) -(* } *) -(* { i. rewrite FINDF_C in H. clarify. } *) -(* { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. *) -(* rewrite <- ALLOW1. ss. *) -(* } *) -(* Qed. *) - -(* Lemma eventval_list_match_list_eventval_to_list_val *) -(* (ge: Senv.t) evargs tys vargs *) -(* (EVMS: eventval_list_match ge evargs tys vargs) *) -(* : *) -(* list_eventval_to_list_val ge evargs = vargs. *) -(* Proof. *) -(* induction EVMS; ss. f_equal; auto. *) -(* eapply eventval_match_eventval_to_val. eauto. *) -(* Qed. *) - -(* Lemma match_symbs_eventval_match *) -(* ge0 ge1 ev ty v *) -(* (MS: match_symbs ge0 ge1) *) -(* (EVM: eventval_match ge0 ev ty v) *) -(* : *) -(* eventval_match ge1 ev ty v. *) -(* Proof. *) -(* destruct MS as (MS0 & MS1 & MS2). inv EVM; econs; auto. rewrite MS0; auto. *) -(* Qed. *) - -(* Lemma match_symbs_eventval_list_match *) -(* ge0 ge1 ev ty v *) -(* (MS: match_symbs ge0 ge1) *) -(* (EVM: eventval_list_match ge0 ev ty v) *) -(* : *) -(* eventval_list_match ge1 ev ty v. *) -(* Proof. *) -(* induction EVM. econs. econs; auto. eapply match_symbs_eventval_match; eauto. *) -(* Qed. *) - -(* Lemma alloc_variables_exists *) -(* ge cp e m l *) -(* : *) -(* exists e' m', alloc_variables ge cp e m l e' m'. *) -(* Proof. *) -(* revert ge cp e m. induction l; ii. *) -(* { do 2 eexists. econs 1. } *) -(* destruct a as (id & ty). *) -(* destruct (Mem.alloc m cp 0 (sizeof ge ty)) as (m0 & b0) eqn:ALLOC. *) -(* specialize (IHl ge cp (PTree.set id (b0, ty) e) m0). des. *) -(* do 2 eexists. econs 2. eapply ALLOC. eapply IHl. *) -(* Qed. *) - -(* Lemma access_mode_typ_to_type *) -(* s *) -(* : *) -(* exists ch, access_mode (typ_to_type s) = By_value ch. *) -(* Proof. destruct s; ss; eauto. Qed. *) - -(* Lemma bind_parameters_exists *) -(* (ge: genv) cp (e: env) m params vargs *) -(* (INENV: Forall (fun '(id, ty) => *) -(* exists b, (e ! id = Some (b, ty)) /\ *) -(* (forall ch, access_mode ty = By_value ch -> *) -(* Mem.valid_access m ch b 0 Writable (Some cp))) *) -(* params) *) -(* sg *) -(* (PARSIGS: list_typ_to_list_type sg = map snd params) *) -(* evargs *) -(* (EMS: eventval_list_match ge evargs sg vargs) *) -(* : *) -(* exists m', bind_parameters ge cp e m params vargs m'. *) -(* Proof. *) -(* revert e m vargs INENV sg PARSIGS evargs EMS. induction params; ii. *) -(* { ss. inv EMS; ss. eexists. econs. } *) -(* destruct a as (id & ty). inv INENV. des. ss. *) -(* destruct sg; ss. rename t into s. clarify. inv EMS. *) -(* destruct (access_mode_typ_to_type s) as (ch & ACCM). *) -(* specialize (H0 _ ACCM). hexploit Mem.valid_access_store. apply H0. instantiate (1:=v1). *) -(* intros (m0 & STORE). *) -(* assert *) -(* (FA: Forall *) -(* (fun '(id, ty) => *) -(* exists b : block, *) -(* e ! id = Some (b, ty) /\ *) -(* (forall ch : memory_chunk, access_mode ty = By_value ch -> *) -(* Mem.valid_access m0 ch b 0 Writable (Some cp))) params). *) -(* { clear - H2 STORE. move H2 before cp. revert_until H2. induction H2; ii; ss. *) -(* econs; eauto. des_ifs. des. esplits; eauto. i. eapply Mem.store_valid_access_1; eauto. *) -(* } *) -(* hexploit IHparams. apply FA. 1,2: eauto. intros. des. exists m'. *) -(* econs; eauto. econs; eauto. *) -(* Qed. *) - -(* Lemma alloc_variables_wf_id *) -(* ge cp e m params e' m' *) -(* (EA: alloc_variables ge cp e m params e' m') *) -(* (WF: list_norepet (var_names params)) *) -(* : *) -(* forall id bt, (~ In id (var_names params)) -> (e ! id = Some bt) -> (e' ! id = Some bt). *) -(* Proof. *) -(* revert WF. induction EA; ii; ss. *) -(* apply Classical_Prop.not_or_and in H0. des. inv WF. *) -(* apply IHEA; auto. rewrite PTree.gso; auto. *) -(* Qed. *) - -(* Lemma alloc_variables_valid_access *) -(* ge cp e m params e' m' *) -(* (EA: alloc_variables ge cp e m params e' m') *) -(* : *) -(* forall b' ch' ofs' p' cp', Mem.valid_access m ch' b' ofs' p' cp' -> *) -(* Mem.valid_access m' ch' b' ofs' p' cp'. *) -(* Proof. *) -(* i. assert (WF: (b' < Mem.nextblock m)%positive). *) -(* { unfold Mem.valid_access in H. des. destruct (Unusedglob.IS.MSet.Raw.MX.lt_dec b' (Mem.nextblock m)); auto. *) -(* exfalso. unfold Mem.range_perm in H. specialize (H ofs'). *) -(* eapply (Mem.nextblock_noaccess _ _ ofs' Cur) in n. *) -(* exploit H. *) -(* { pose proof (size_chunk_pos ch'). lia. } *) -(* i. unfold Mem.perm in x0. rewrite n in x0. ss. *) -(* } *) -(* revert_until EA. induction EA; ii; ss. *) -(* apply IHEA. *) -(* { eapply Mem.valid_access_alloc_other; eauto. } *) -(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) -(* Qed. *) - -(* Lemma alloc_variables_forall *) -(* ge cp e m params e' m' *) -(* (EA: alloc_variables ge cp e m params e' m') *) -(* (WF: list_norepet (var_names params)) *) -(* : *) -(* Forall (fun '(id, ty) => *) -(* exists b, (e' ! id = Some (b, ty)) /\ *) -(* (forall ch, access_mode ty = By_value ch -> *) -(* Mem.valid_access m' ch b 0 Writable (Some cp))) params. *) -(* Proof. *) -(* revert WF. induction EA; ii; ss. *) -(* inv WF. econs; eauto. *) -(* hexploit alloc_variables_wf_id. apply EA. auto. apply H2. apply PTree.gss. *) -(* i. esplits; eauto. *) -(* i. eapply alloc_variables_valid_access. apply EA. *) -(* apply Mem.valid_access_freeable_any. eapply Mem.valid_access_alloc_same; eauto. lia. *) -(* { ss. clear - H1. destruct ty; ss; clarify. des_ifs; clarify; ss. des_ifs; clarify; ss. unfold Mptr. des_ifs. } *) -(* exists 0. ss. *) -(* Qed. *) - -(* Lemma assign_loc_valid_access *) -(* ge cp ty m b ofs bit v m' *) -(* (AL: assign_loc ge cp ty m b ofs bit v m') *) -(* ch' b' ofs' perm' cp' *) -(* (VA: Mem.valid_access m ch' b' ofs' perm' (Some cp')) *) -(* : *) -(* Mem.valid_access m' ch' b' ofs' perm' (Some cp'). *) -(* Proof. *) -(* inv AL. *) -(* - eapply Mem.store_valid_access_1; eauto. *) -(* - eapply Mem.storebytes_valid_access_1; eauto. *) -(* - inv H. eapply Mem.store_valid_access_1; eauto. *) -(* Qed. *) - -(* Lemma bind_parameters_valid_access *) -(* (ge: genv) cp (e: env) m params vargs m' *) -(* (BIND: bind_parameters ge cp e m params vargs m') *) -(* ch b ofs perm cp' *) -(* (VA: Mem.valid_access m ch b ofs perm (Some cp')) *) -(* : *) -(* Mem.valid_access m' ch b ofs perm (Some cp'). *) -(* Proof. *) -(* revert_until BIND. induction BIND; ii; ss. *) -(* apply IHBIND. eapply assign_loc_valid_access; eauto. *) -(* Qed. *) - -(* Lemma mem_delta_apply_wf_valid_access *) -(* ge cp d m m' *) -(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) -(* ch b ofs perm cp' *) -(* (VA: Mem.valid_access m ch b ofs perm cp') *) -(* : *) -(* Mem.valid_access m' ch b ofs perm cp'. *) -(* Proof. *) -(* move d before ge. revert_until d. induction d; ii. *) -(* { unfold mem_delta_apply_wf in APPD. ss; clarify. } *) -(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs. *) -(* - destruct a; ss. hexploit mem_delta_apply_wf_some; eauto. *) -(* intros (m0 & STOREV). rewrite STOREV in APPD. *) -(* eapply IHd. apply APPD. *) -(* unfold mem_delta_apply_storev in STOREV. des_ifs. *) -(* unfold Mem.storev in STOREV. des_ifs. *) -(* eapply Mem.store_valid_access_1; eauto. *) -(* - eapply IHd; eauto. *) -(* Qed. *) - -(* Lemma bind_parameters_mem_load *) -(* ge cp e m0 params vargs m1 *) -(* (BIND: bind_parameters ge cp e m0 params vargs m1) *) -(* : *) -(* forall ch b ofs cp', *) -(* (forall id b_e ty, (e ! id = Some (b_e, ty) -> b <> b_e)) -> *) -(* (Mem.load ch m1 b ofs cp' = Mem.load ch m0 b ofs cp'). *) -(* Proof. *) -(* induction BIND; ii; ss. *) -(* rewrite IHBIND; auto. *) -(* inv H0. *) -(* - eapply Mem.load_store_other. eapply H3. left. ii. clarify. specialize (H1 _ _ _ H). clarify. *) -(* - eapply Mem.load_storebytes_other. eapply H7. left. ii. clarify. specialize (H1 _ _ _ H). clarify. *) -(* Qed. *) - -(* Lemma alloc_variables_mem_load *) -(* ge cp e m params e' m' *) -(* (EA: alloc_variables ge cp e m params e' m') *) -(* : *) -(* forall ch b ofs cp', *) -(* (b < Mem.nextblock m)%positive -> *) -(* (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). *) -(* Proof. *) -(* induction EA; ii; ss. *) -(* rewrite IHEA. *) -(* { eapply Mem.load_alloc_unchanged; eauto. } *) -(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) -(* Qed. *) - -(* Lemma alloc_variables_old_blocks *) -(* ge cp e m params e' m' *) -(* (EA: alloc_variables ge cp e m params e' m') *) -(* : *) -(* forall b, (b < Mem.nextblock m)%positive -> *) -(* (forall id b' ty, e ! id = Some (b', ty) -> b <> b') -> *) -(* (forall id b' ty, e' ! id = Some (b', ty) -> b <> b'). *) -(* Proof. *) -(* induction EA; i. *) -(* { ii; clarify. specialize (H0 _ _ _ H1). clarify. } *) -(* hexploit Mem.alloc_result; eauto. intros; clarify. *) -(* eapply IHEA. 3: eapply H2. *) -(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) -(* { i. destruct (Pos.eq_dec id id1). *) -(* - clarify. rewrite PTree.gss in H3. clarify. lia. *) -(* - rewrite PTree.gso in H3; auto. eapply H1; eauto. *) -(* } *) -(* Qed. *) - -(* Lemma mem_delta_apply_wf_mem_load *) -(* ge cp d m m' *) -(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) -(* : *) -(* forall id ch b ofs cp', *) -(* Senv.invert_symbol ge b = Some id -> *) -(* Senv.public_symbol ge id = false -> *) -(* (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). *) -(* Proof. *) -(* move d before ge. revert_until d. induction d; ii. *) -(* { unfold mem_delta_apply_wf in APPD. ss. clarify. } *) -(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs. *) -(* { destruct a; ss. unfold wf_mem_delta_storev_b in Heq. des_ifs. ss. *) -(* hexploit mem_delta_apply_wf_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. *) -(* erewrite IHd. 2: eauto. 2: eauto. all: auto. *) -(* destruct (Pos.eq_dec b b0). *) -(* - clarify. *) -(* - erewrite Mem.load_store_other. 2: eauto. all: auto. *) -(* } *) -(* { eapply IHd; eauto. } *) -(* Qed. *) - -(* Lemma nat64_int64_add_one *) -(* n *) -(* (BOUND: Z.of_nat n < Int64.modulus) *) -(* : *) -(* Int64.add (nat64 n) Int64.one = nat64 (n + 1). *) -(* Proof. *) -(* unfold nat64. rewrite Nat2Z.inj_add. ss. *) -(* assert (N: Z.of_nat n = Int64.unsigned (Int64.repr (Z.of_nat n))). *) -(* { symmetry. apply Int64.unsigned_repr. split. apply Zle_0_nat. *) -(* unfold Int64.max_unsigned. lia. *) -(* } *) -(* assert (ONE: 1 = (Int64.unsigned (Int64.repr 1))). *) -(* { ss. } *) -(* rewrite N at 2. rewrite ONE. rewrite <- Int64.add_unsigned. ss. *) -(* Qed. *) - -(* Lemma mem_free_list_impl1 *) -(* blks m cp m_f *) -(* (FREE: Mem.free_list m blks cp = Some m_f) *) -(* : *) -(* Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks. *) -(* Proof. *) -(* Local Opaque Mem.can_access_block. *) -(* revert_until blks. induction blks; ii; ss. des_ifs. ss. econs. *) -(* 2:{ cut (Forall (fun '(b0, lo, hi) => Mem.range_perm m0 b0 lo hi Cur Freeable /\ Mem.can_access_block m0 b0 (Some cp)) blks); cycle 1. *) -(* { eapply IHblks; eauto. } *) -(* clear - Heq. intros FA. revert_until blks. induction blks; ii; ss. *) -(* destruct a as ((ba & loa) & hia). ss. inv FA. des; clarify. econs. *) -(* { *) -(* clear IHblks. split. *) -(* - unfold Mem.range_perm in *. ii. eapply Mem.perm_free_3. eauto. eauto. *) -(* - eapply Mem.free_can_access_block_inj_2; eauto. *) -(* } *) -(* eapply IHblks; eauto. *) -(* } *) -(* split. *) -(* - eapply Mem.free_range_perm; eauto. *) -(* - eapply Mem.free_can_access_block_1; eauto. *) -(* Local Transparent Mem.can_access_block. *) -(* Qed. *) - -(* Lemma mem_free_list_impl2 *) -(* blks m cp *) -(* (NR: list_norepet (map (fun x => fst (fst x)) blks)) *) -(* (FA: Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks) *) -(* : *) -(* exists m_f, (Mem.free_list m blks cp = Some m_f). *) -(* Proof. *) -(* Local Opaque Mem.can_access_block. *) -(* revert_until blks. induction blks; ii; ss; eauto. *) -(* inv FA. inv NR. des_ifs; des. *) -(* 2:{ exfalso. destruct (Mem.range_perm_free _ _ _ _ _ H1 H0) as (m0 & FREE). clarify. } *) -(* eapply IHblks; clear IHblks; eauto. ss. clear - H2 H3 Heq. *) -(* revert_until blks. induction blks; ii; ss. inv H2. des_ifs; ss. des. econs; eauto. *) -(* clear IHblks H4. apply Classical_Prop.not_or_and in H3. des. split. *) -(* - unfold Mem.range_perm in *. ii. hexploit Mem.perm_free_inv; eauto. ii. des; clarify. *) -(* - eapply Mem.free_can_access_block_inj_1; eauto. *) -(* Local Transparent Mem.can_access_block. *) -(* Qed. *) - -(* Lemma list_map_norepet_rev *) -(* A (l: list A) B (f: A -> B) *) -(* (NR: list_norepet (map f l)) *) -(* : *) -(* list_norepet l. *) -(* Proof. *) -(* revert NR. induction l; ii; ss. econs. inv NR. econs; eauto. *) -(* ii. apply H1; clear H1. apply in_map; auto. *) -(* Qed. *) - -(* Lemma alloc_variables_wunchanged_on *) -(* ge cp e m params e' m' *) -(* (EA: alloc_variables ge cp e m params e' m') *) -(* : *) -(* wunchanged_on (fun b _ => Mem.valid_block m b) m m'. *) -(* Proof. *) -(* induction EA. apply wunchanged_on_refl. *) -(* eapply wunchanged_on_implies in IHEA. *) -(* { eapply wunchanged_on_trans. 2: eauto. eapply alloc_wunchanged_on. eauto. } *) -(* { ii. ss. } *) -(* Qed. *) - -(* Lemma alloc_variables_exists_free_list *) -(* ge cp e m params e' m' *) -(* (EA: alloc_variables ge cp e m params e' m') *) -(* (ENV1: forall id1 id2 b1 b2 t1 t2, (id1 <> id2) -> (e ! id1 = Some (b1, t1)) -> (e ! id2 = Some (b2, t2)) -> (b1 <> b2)) *) -(* (ENV2: forall id b t, (e ! id = Some (b, t)) -> (Mem.valid_block m b)) *) -(* m_f0 *) -(* (FREE: Mem.free_list m' (blocks_of_env ge e) cp = Some m_f0) *) -(* : *) -(* exists m_f, Mem.free_list m' (blocks_of_env ge e') cp = Some m_f. *) -(* Proof. *) -(* revert_until EA. induction EA; ii; ss; eauto. *) -(* assert (exists m_f0, Mem.free_list m2 (blocks_of_env ge (PTree.set id (b1, ty) e)) cp = Some m_f0); cycle 1. *) -(* { des. eapply IHEA; clear IHEA; eauto. *) -(* - i. destruct (Pos.eqb_spec id id1); clarify. *) -(* + rewrite PTree.gss in H2. rewrite PTree.gso in H3; auto. clarify. specialize (ENV2 _ _ _ H3). *) -(* ii. clarify. apply Mem.fresh_block_alloc in H. clarify. *) -(* + destruct (Pos.eqb_spec id id2); clarify. *) -(* * rewrite PTree.gso in H2; auto. rewrite PTree.gss in H3; auto. clarify. specialize (ENV2 _ _ _ H2). *) -(* ii. clarify. apply Mem.fresh_block_alloc in H. clarify. *) -(* * rewrite PTree.gso in H2, H3; auto. hexploit ENV1. 2: eapply H2. 2: eapply H3. all: auto. *) -(* - i. destruct (Pos.eqb_spec id id0); clarify. *) -(* + rewrite PTree.gss in H1. clarify. eapply Mem.valid_new_block; eauto. *) -(* + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). eapply Mem.valid_block_alloc; eauto. *) -(* } *) -(* clear IHEA. eapply mem_free_list_impl2. *) -(* { unfold blocks_of_env. rewrite map_map. apply list_map_norepet. *) -(* { eapply list_map_norepet_rev. apply PTree.elements_keys_norepet. } *) -(* { i. unfold block_of_binding. des_ifs. ss. apply PTree.elements_complete in H0, H1. *) -(* destruct (Pos.eqb_spec id i); clarify. *) -(* - rewrite PTree.gss in H0. clarify. destruct (Pos.eqb_spec i i0); clarify. *) -(* + rewrite PTree.gss in H1; clarify. *) -(* + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). ii; clarify. *) -(* apply Mem.fresh_block_alloc in H. clarify. *) -(* - rewrite PTree.gso in H0; auto. destruct (Pos.eqb_spec id i0); clarify. *) -(* + rewrite PTree.gss in H1. clarify. specialize (ENV2 _ _ _ H0). ii; clarify. *) -(* apply Mem.fresh_block_alloc in H. clarify. *) -(* + rewrite PTree.gso in H1; auto. eapply ENV1. 2: apply H0. 2: apply H1. ii; clarify. *) -(* } *) -(* } *) -(* { apply mem_free_list_impl1 in FREE. rewrite Forall_forall in *. i. *) -(* assert ((x = (b1, 0%Z, sizeof ge ty)) \/ (In x (blocks_of_env ge e))). *) -(* { clear - H0. unfold blocks_of_env in *. apply list_in_map_inv in H0. des. *) -(* destruct x0 as (xid & xb & xt). apply PTree.elements_complete in H1. clarify. *) -(* destruct (Pos.eqb_spec id xid); clarify. *) -(* - rewrite PTree.gss in H1. clarify. left; auto. *) -(* - rewrite PTree.gso in H1; auto. right. apply in_map. apply PTree.elements_correct. auto. *) -(* } *) -(* des. *) -(* - clarify. split. *) -(* + ii. eapply perm_wunchanged_on. eapply alloc_variables_wunchanged_on; eauto. *) -(* { ss. eapply Mem.valid_new_block; eauto. } *) -(* { eapply Mem.perm_alloc_2; eauto. } *) -(* + rewrite <- wunchanged_on_own. 2: eapply alloc_variables_wunchanged_on; eauto. *) -(* eapply Mem.owned_new_block; eauto. eapply Mem.valid_new_block; eauto. *) -(* - eapply FREE. eauto. *) -(* } *) -(* Qed. *) - -(* Lemma assign_loc_wunchanged_on *) -(* ge cp ty m b ofs bit v m' *) -(* (AL: assign_loc ge cp ty m b ofs bit v m') *) -(* : *) -(* wunchanged_on (fun _ _ => True) m m'. *) -(* Proof. *) -(* inv AL. *) -(* - eapply store_wunchanged_on; eauto. *) -(* - eapply storebytes_wunchanged_on; eauto. *) -(* - inv H. eapply store_wunchanged_on; eauto. *) -(* Qed. *) - -(* Lemma bind_parameters_wunchanged_on *) -(* (ge: genv) cp (e: env) m params vargs m' *) -(* (BIND: bind_parameters ge cp e m params vargs m') *) -(* : *) -(* wunchanged_on (fun _ _ => True) m m'. *) -(* Proof. *) -(* induction BIND. apply wunchanged_on_refl. eapply wunchanged_on_trans. 2: apply IHBIND. *) -(* eapply assign_loc_wunchanged_on; eauto. *) -(* Qed. *) - -(* Lemma wunchanged_on_exists_free *) -(* m m' *) -(* (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') *) -(* b lo hi cp m_f *) -(* (FREE: Mem.free m b lo hi cp = Some m_f) *) -(* : *) -(* exists m_f', Mem.free m' b lo hi cp = Some m_f'. *) -(* Proof. *) -(* hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. *) -(* hexploit Mem.range_perm_free. *) -(* 3:{ intros (m0 & F). eexists; eapply F. } *) -(* - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. eapply Mem.perm_valid_block; eauto. *) -(* - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. *) -(* Qed. *) - -(* Lemma assign_loc_perm *) -(* ge cp ty m b ofs bit v m' *) -(* (AL: assign_loc ge cp ty m b ofs bit v m') *) -(* b' o' C P *) -(* (PERM: Mem.perm m b' o' C P) *) -(* : *) -(* Mem.perm m' b' o' C P. *) -(* Proof. *) -(* inv AL. *) -(* - eapply Mem.perm_store_1; eauto. *) -(* - eapply Mem.perm_storebytes_1; eauto. *) -(* - inv H. eapply Mem.perm_store_1; eauto. *) -(* Qed. *) - -(* Lemma assign_loc_own *) -(* ge cp ty m b ofs bit v m' *) -(* (AL: assign_loc ge cp ty m b ofs bit v m') *) -(* b' cp' *) -(* (OWN: Mem.can_access_block m b' cp') *) -(* : *) -(* Mem.can_access_block m' b' cp'. *) -(* Proof. *) -(* inv AL. *) -(* - rewrite <- Mem.store_can_access_block_inj; eauto. *) -(* - eapply Mem.storebytes_can_access_block_inj_1; eauto. *) -(* - inv H. rewrite <- Mem.store_can_access_block_inj; eauto. *) -(* Qed. *) - -(* Lemma assign_loc_exists_free *) -(* ge cp ty m b ofs bit v m' *) -(* (AL: assign_loc ge cp ty m b ofs bit v m') *) -(* b' lo hi cp' m_f *) -(* (FREE: Mem.free m b' lo hi cp' = Some m_f) *) -(* : *) -(* exists m_f, Mem.free m' b' lo hi cp' = Some m_f. *) -(* Proof. *) -(* hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. *) -(* hexploit Mem.range_perm_free. *) -(* 3:{ intros (m0 & F). eexists; eapply F. } *) -(* - unfold Mem.range_perm in *. i. eapply assign_loc_perm; eauto. *) -(* - eapply assign_loc_own; eauto. *) -(* Qed. *) - -(* Lemma wunchanged_on_free_preserves *) -(* m m' *) -(* (WU : wunchanged_on (fun (b : block) (_ : Z) => Mem.valid_block m b) m m') *) -(* b lo hi cp m1 m1' *) -(* (FREE: Mem.free m b lo hi cp = Some m1) *) -(* (FREE': Mem.free m' b lo hi cp = Some m1') *) -(* : *) -(* wunchanged_on (fun (b0 : block) (_ : Z) => Mem.valid_block m1 b0) m1 m1'. *) -(* Proof. *) -(* inv WU. econs. *) -(* - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. *) -(* - i. assert (VB: Mem.valid_block m b0). *) -(* { eapply Mem.valid_block_free_2; eauto. } *) -(* split; i. *) -(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. *) -(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) -(* hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. *) -(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. *) -(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) -(* hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. *) -(* - i. assert (VB: Mem.valid_block m b0). *) -(* { eapply Mem.valid_block_free_2; eauto. } *) -(* split; i. *) -(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) -(* eapply Mem.free_can_access_block_inj_2; eauto. *) -(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) -(* eapply Mem.free_can_access_block_inj_2; eauto. *) -(* Qed. *) - -(* Lemma wunchanged_on_exists_mem_free_list *) -(* m m' *) -(* (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') *) -(* l cp m_f *) -(* (FREE: Mem.free_list m l cp = Some m_f) *) -(* : *) -(* exists m_f', Mem.free_list m' l cp = Some m_f'. *) -(* Proof. *) -(* move l after m. revert_until l. induction l; ii; ss; eauto. des_ifs. *) -(* 2:{ exfalso. hexploit wunchanged_on_exists_free. 2: eapply Heq0. 2: auto. *) -(* 2:{ intros. des. rewrite H in Heq; clarify. } *) -(* auto. *) -(* } *) -(* hexploit IHl. 2: eapply FREE. *) -(* { instantiate (1:=m0). eapply wunchanged_on_free_preserves; eauto. } *) -(* eauto. *) -(* Qed. *) - -(* Lemma mem_free_list_wunchanged_on *) -(* x m l cp m' *) -(* (FL: Mem.free_list m l cp = Some m') *) -(* (WF: Forall (fun '(b, lo, hi) => (x <= b)%positive) l) *) -(* : *) -(* wunchanged_on (fun b _ => (b < x)%positive) m m'. *) -(* Proof. *) -(* move WF before x. revert_until WF. induction WF; i; ss. clarify. apply wunchanged_on_refl. des_ifs. *) -(* hexploit IHWF; eauto. i. eapply wunchanged_on_trans. 2: eauto. *) -(* eapply free_wunchanged_on; eauto. *) -(* i. lia. *) -(* Qed. *) - -(* Lemma wunchanged_on_free_list_preserves *) -(* m m' *) -(* (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') *) -(* l cp m_f m_f' *) -(* (FREE: Mem.free_list m l cp = Some m_f) *) -(* (FREE': Mem.free_list m' l cp = Some m_f') *) -(* : *) -(* wunchanged_on (fun b _ => Mem.valid_block m_f b) m_f m_f'. *) -(* Proof. *) -(* move l after m. revert_until l. induction l; ii; ss. clarify. *) -(* des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves; eauto. *) -(* Qed. *) - -(* Lemma mem_delta_apply_wf_wunchanged_on *) -(* ge cp d m m' *) -(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) -(* P *) -(* : *) -(* wunchanged_on P m m'. *) -(* Proof. *) -(* revert_until d. induction d; ii; ss. *) -(* { cbn in APPD. clarify. apply wunchanged_on_refl. } *) -(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs. *) -(* - hexploit mem_delta_apply_wf_some; eauto. intros (m0 & ST). rewrite ST in APPD. *) -(* specialize (IHd _ _ APPD). unfold mem_delta_apply_kind in ST. unfold mem_delta_apply_storev in ST. des_ifs. *) -(* ss. des_ifs. ss. eapply wunchanged_on_trans. eapply store_wunchanged_on. eapply ST. *) -(* eapply wunchanged_on_implies. eapply IHd. ss. *) -(* - eauto. *) -(* Unshelve. all: exact 0%nat. *) -(* Qed. *) - -(* Lemma alloc_variables_fresh_blocks *) -(* ge cp e m params e' m' *) -(* (EA: alloc_variables ge cp e m params e' m') *) -(* x *) -(* (X: (x <= Mem.nextblock m)%positive) *) -(* (FA: Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e)) *) -(* : *) -(* Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e'). *) -(* Proof. *) -(* revert_until EA. induction EA; ii; ss. specialize (IHEA x). *) -(* eapply IHEA; clear IHEA. *) -(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) -(* apply Forall_forall. rewrite Forall_forall in FA. ii. specialize (FA x0). des_ifs. *) -(* unfold blocks_of_env in H0. apply list_in_map_inv in H0. des. destruct x0 as (xid & xb & xt). *) -(* apply PTree.elements_complete in H1. destruct (Pos.eqb_spec id xid); clarify. *) -(* - rewrite PTree.gss in H1. ss. clarify. erewrite Mem.alloc_result. 2: eauto. auto. *) -(* - rewrite PTree.gso in H1; auto. apply FA. rewrite H0. unfold blocks_of_env. apply in_map. *) -(* apply PTree.elements_correct; auto. *) -(* Qed. *) - -(* Lemma alloc_variables_one_fresh_block *) -(* ge cp e m params e' m' *) -(* (EA: alloc_variables ge cp e m params e' m') *) -(* (NR: list_norepet (var_names params)) *) -(* xid xb xt *) -(* (NOT: e ! xid = None) *) -(* (GET: e' ! xid = Some (xb, xt)) *) -(* : *) -(* ~ (Mem.valid_block m xb). *) -(* Proof. *) -(* revert_until EA. induction EA; i. clarify. *) -(* inv NR. destruct (Pos.eqb_spec xid id). *) -(* { subst id. hexploit alloc_variables_wf_id. eauto. auto. eauto. apply PTree.gss. *) -(* i. rewrite GET in H0. clarify. eapply Mem.fresh_block_alloc; eauto. } *) -(* hexploit IHEA. auto. rewrite PTree.gso. eapply NOT. auto. eapply GET. i. *) -(* ii. apply H0. unfold Mem.valid_block in *. erewrite Mem.nextblock_alloc; eauto. *) -(* etransitivity. eapply H1. apply Plt_succ. *) -(* Qed. *) - -(* Lemma assign_loc_outside_mem_inject *) -(* ge cp ty m b ofs bf v m' *) -(* (AL: assign_loc ge cp ty m b ofs bf v m') *) -(* k m0 *) -(* (INJ: Mem.inject k m0 m) *) -(* (NIB: k b = None) *) -(* (MS: meminj_same_block k) *) -(* : *) -(* Mem.inject k m0 m'. *) -(* Proof. *) -(* inv AL. *) -(* - eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H1). clarify. *) -(* - eapply Mem.storebytes_outside_inject; eauto. i. specialize (MS _ _ _ H5). clarify. *) -(* - inv H. eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H). clarify. *) -(* Qed. *) - -(* Lemma bind_parameters_outside_mem_inject *) -(* ge cp e m_cur params vargs m_next *) -(* (BIND: bind_parameters ge cp e m_cur params vargs m_next) *) -(* k m *) -(* (INJ: Mem.inject k m m_cur) *) -(* (NIB: forall id b t, e ! id = Some (b, t) -> k b = None) *) -(* (MS: meminj_same_block k) *) -(* (* (NIB: not_inj_blks k (blocks_of_env2 ge e)) *) *) -(* : *) -(* Mem.inject k m m_next. *) -(* Proof. *) -(* revert_until BIND. induction BIND; ii. *) -(* { auto. } *) -(* apply IHBIND; auto. clear IHBIND. specialize (NIB _ _ _ H). *) -(* eapply assign_loc_outside_mem_inject; eauto. *) -(* Qed. *) - -(* Lemma not_inj_blks_get_env *) -(* k ge e *) -(* (NIB: not_inj_blks k (blocks_of_env2 ge e)) *) -(* : *) -(* forall id b t, e ! id = Some (b, t) -> k b = None. *) -(* Proof. *) -(* rr in NIB. unfold blocks_of_env2, blocks_of_env in NIB. rewrite map_map in NIB. *) -(* rewrite Forall_forall in NIB. i. apply PTree.elements_correct in H. *) -(* apply NIB. eapply (in_map (fun x : ident * (block * type) => fst (fst (block_of_binding ge x)))) in H. ss. *) -(* Qed. *) - -(* Lemma not_global_blks_get_env *) -(* (ge: genv) e *) -(* (NIB: not_global_blks ge (blocks_of_env2 ge e)) *) -(* : *) -(* forall id b t, e ! id = Some (b, t) -> (meminj_public ge) b = None. *) -(* Proof. eapply not_inj_blks_get_env. eapply not_global_is_not_inj_bloks. eauto. Qed. *) - -(* Lemma meminj_public_same_block *) -(* ge *) -(* : *) -(* meminj_same_block (meminj_public ge). *) -(* Proof. rr. unfold meminj_public. i. des_ifs. Qed. *) - -(* Lemma alloc_variables_mem_inject *) -(* ge cp e m params e' m' *) -(* (EA: alloc_variables ge cp e m params e' m') *) -(* k m0 *) -(* (INJ: Mem.inject k m0 m) *) -(* : *) -(* Mem.inject k m0 m'. *) -(* Proof. *) -(* revert_until EA. induction EA; ii. auto. *) -(* apply IHEA. clear IHEA. eapply Mem.alloc_right_inject; eauto. *) -(* Qed. *) - -(* Lemma mem_valid_access_wunchanged_on *) -(* m ch b ofs p cp *) -(* (MV: Mem.valid_access m ch b ofs p cp) *) -(* P m' *) -(* (WU: wunchanged_on P m m') *) -(* (SAT: forall ofs', P b ofs') *) -(* : *) -(* Mem.valid_access m' ch b ofs p cp. *) -(* Proof. *) -(* unfold Mem.valid_access in *. des. splits; auto. *) -(* - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on; eauto. *) -(* - destruct cp. 2: ss. erewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block; eauto. *) -(* Qed. *) - -(* Lemma mem_free_list_wunchanged_on_2 *) -(* l m cp m' *) -(* (FREE: Mem.free_list m l cp = Some m') *) -(* : *) -(* wunchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. *) -(* Proof. *) -(* revert_until l. induction l; ii. *) -(* { ss. clarify. apply wunchanged_on_refl. } *) -(* ss. des_ifs. eapply wunchanged_on_trans; cycle 1. *) -(* { eapply wunchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } *) -(* ss. eapply free_wunchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. *) -(* Qed. *) - -(* Lemma not_global_blks_global_not_in *) -(* (ge: genv) id b *) -(* (FIND: Genv.find_symbol ge id = Some b) *) -(* e *) -(* (NGB: not_global_blks ge (blocks_of_env2 ge e)) *) -(* : *) -(* ~ In b (map (fun x : block * Z * Z => fst (fst x)) (blocks_of_env ge e)). *) -(* Proof. *) -(* intros CONTRA. unfold not_global_blks in NGB. unfold blocks_of_env2, blocks_of_env in *. *) -(* rewrite map_map in NGB, CONTRA. rewrite Forall_forall in NGB. specialize (NGB _ CONTRA). *) -(* apply Genv.find_invert_symbol in FIND. setoid_rewrite FIND in NGB. inv NGB. *) -(* Qed. *) - -(* Lemma mem_free_list_unchanged_on *) -(* l m cp m' *) -(* (FREE: Mem.free_list m l cp = Some m') *) -(* : *) -(* Mem.unchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. *) -(* Proof. *) -(* revert_until l. induction l; ii. *) -(* { ss. clarify. apply Mem.unchanged_on_refl. } *) -(* ss. des_ifs. eapply Mem.unchanged_on_trans; cycle 1. *) -(* { eapply Mem.unchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } *) -(* ss. eapply Mem.free_unchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. *) -(* Qed. *) - -(* Lemma exists_vargs_vres *) -(* (ge1: Senv.t) (ge2: genv) *) -(* (MS: match_symbs ge1 ge2) *) -(* ef m1 vargs tr vretv m2 *) -(* (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) *) -(* e cp le m_c *) -(* (WFE: wf_env ge2 e) *) -(* : *) -(* (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) -(* (list_typ_to_typelist (sig_args (ef_sig ef))) vargs) /\ *) -(* (external_call ef ge2 vargs m_c tr vretv m_c). *) -(* Proof. *) -(* pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. *) -(* unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). *) -(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) -(* esplits. *) -(* + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. *) -(* + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. *) -(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) -(* esplits. *) -(* + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. *) -(* econs. 3: econs. *) -(* { instantiate (1:=v). destruct v; ss; try (econs; fail). *) -(* - destruct chunk; ss; inv H2; ss. *) -(* - destruct Archi.ptr64 eqn:ARCH. *) -(* + destruct chunk; ss; inv H2; ss; des_ifs. *) -(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) -(* eapply ptr_of_id_ofs_eval; eauto. *) -(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) -(* eapply ptr_of_id_ofs_eval; eauto. *) -(* + destruct chunk; ss; inv H2; ss; des_ifs. *) -(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) -(* eapply ptr_of_id_ofs_eval; eauto. *) -(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) -(* eapply ptr_of_id_ofs_eval; eauto. *) -(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) -(* eapply ptr_of_id_ofs_eval; eauto. *) -(* } *) -(* { rewrite EK1 in H2. *) -(* destruct v; ss. *) -(* - destruct chunk; ss; inv H2; ss. *) -(* - destruct chunk; ss. all: simpl_expr. inv H2. *) -(* - destruct chunk; ss. all: simpl_expr. *) -(* - destruct chunk; ss. inv H2. *) -(* - destruct chunk; ss. all: inv H2. *) -(* - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. *) -(* rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss; simpl_expr. *) -(* + unfold Cop.sem_cast. ss. rewrite Heq. auto. *) -(* + unfold Cop.sem_cast. ss. rewrite Heq. auto. *) -(* } *) -(* + econs. econs; auto. rewrite MS3; auto. rewrite EK1. *) -(* rewrite EK1 in H2. eapply match_symbs_eventval_match; eauto. *) -(* - esplits. *) -(* + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. *) -(* erewrite <- eventval_list_match_list_eventval_to_list_val. *) -(* 2:{ eapply match_senv_eventval_list_match in H; eauto. } *) -(* eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. *) -(* eapply match_senv_eventval_list_match; eauto. *) -(* + econs. eapply match_senv_eventval_list_match; eauto. *) -(* - esplits. *) -(* + econs. 3: econs. *) -(* * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. *) -(* eapply match_senv_eventval_match; eauto. *) -(* * erewrite eventval_match_val_to_eventval. 2: eapply H. *) -(* erewrite eventval_match_eventval_to_val. *) -(* 2:{ eapply match_senv_eventval_match; eauto. } *) -(* eapply eventval_match_sem_cast. eapply match_senv_eventval_match; eauto. *) -(* + econs. eapply match_senv_eventval_match; eauto. *) -(* Qed. *) - -(* Lemma eventval_list_match_eval_exprlist *) -(* (ge: genv) args targs vargs *) -(* (EMS: eventval_list_match ge args targs vargs) *) -(* e cp le m *) -(* (WF: wf_env ge e) *) -(* : *) -(* eval_exprlist ge e cp le m (list_eventval_to_list_expr args) *) -(* (list_eventval_to_typelist args) vargs. *) -(* Proof. *) -(* revert_until EMS. induction EMS; i; ss. econs. *) -(* econs; auto. *) -(* { clear dependent evl. clear tyl vl. inv H; try (simpl_expr; fail). *) -(* ss. eapply ptr_of_id_ofs_eval; auto. *) -(* } *) -(* { clear dependent evl. clear tyl vl. inv H; ss; try (simpl_expr; fail). *) -(* rewrite ptr_of_id_ofs_typeof. ss. *) -(* } *) -(* Qed. *) - -(* Lemma exists_vargs_vres_2 *) -(* (ge1: Senv.t) (ge2: genv) *) -(* (MS: match_symbs ge1 ge2) *) -(* ef m1 vargs tr vretv m2 *) -(* (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) *) -(* e cp le m_c *) -(* (WFE: wf_env ge2 e) *) -(* : *) -(* exists vargs2 vretv2, *) -(* (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) -(* (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs2) /\ *) -(* (external_call ef ge2 vargs2 m_c tr vretv2 m_c). *) -(* Proof. *) -(* pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. *) -(* unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). *) -(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) -(* esplits. *) -(* + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. *) -(* + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. *) -(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) -(* esplits. *) -(* + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. *) -(* econs. 3: econs. *) -(* { instantiate (1:=v). destruct v; ss; try (econs; fail). *) -(* - destruct chunk; ss; inv H2; ss. *) -(* - destruct Archi.ptr64 eqn:ARCH. *) -(* + destruct chunk; ss; inv H2; ss; des_ifs. *) -(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) -(* eapply ptr_of_id_ofs_eval; eauto. *) -(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) -(* eapply ptr_of_id_ofs_eval; eauto. *) -(* + destruct chunk; ss; inv H2; ss; des_ifs. *) -(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) -(* eapply ptr_of_id_ofs_eval; eauto. *) -(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) -(* eapply ptr_of_id_ofs_eval; eauto. *) -(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) -(* eapply ptr_of_id_ofs_eval; eauto. *) -(* } *) -(* { instantiate (1:=Val.load_result chunk v). rewrite EK1 in H2. rewrite EK1. *) -(* destruct v; ss. *) -(* - destruct chunk; ss; inv H2; ss. *) -(* - destruct chunk; ss. all: simpl_expr. *) -(* - destruct chunk; ss. all: simpl_expr. *) -(* - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. *) -(* rewrite ptr_of_id_ofs_typeof. simpl_expr. *) -(* } *) -(* + econs. econs; auto. rewrite MS3; auto. rewrite EK1. eapply match_symbs_eventval_match; eauto. *) -(* - esplits. *) -(* + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. *) -(* eapply eventval_list_match_eval_exprlist; eauto. *) -(* eapply match_senv_eventval_list_match; eauto. *) -(* + econs. eapply match_senv_eventval_list_match; eauto. *) -(* - esplits. *) -(* + econs. 3: econs. *) -(* * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. *) -(* eapply match_senv_eventval_match; eauto. *) -(* * inv H; ss; try (simpl_expr; fail). apply MS2 in H1. setoid_rewrite H1. *) -(* rewrite ptr_of_id_ofs_typeof. ss. *) -(* + econs. eapply match_senv_eventval_match; eauto. *) -(* Qed. *) - -(* Lemma known_obs_preserves_mem *) -(* ef ge m vargs tr vretv m' *) -(* (EK: external_call_known_observables ef ge m vargs tr vretv m') *) -(* : *) -(* m' = m. *) -(* Proof. *) -(* unfold external_call_known_observables in EK. des_ifs; des; inv EK; clarify. inv H; clarify. *) -(* Qed. *) - -(* Lemma meminj_first_order_public_first_order *) -(* ge m *) -(* (MFO: meminj_first_order (meminj_public ge) m) *) -(* : *) -(* public_first_order ge m. *) -(* Proof. *) -(* ii. apply MFO; auto. unfold meminj_public. apply Senv.find_invert_symbol in FIND. *) -(* rewrite FIND. rewrite PUBLIC. ss. *) -(* Qed. *) - -(* Lemma vals_public_eval_to_vargs *) -(* (ge: genv) ef vargs *) -(* (VP: vals_public ge (sig_args (ef_sig ef)) vargs) *) -(* e cp le m *) -(* (WFE: wf_env ge e) *) -(* : *) -(* eval_exprlist ge e cp le m *) -(* (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) *) -(* (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. *) -(* Proof. *) -(* induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. *) -(* - clear dependent l. clear dependent l'. *) -(* inv H; ss; try (simpl_expr; fail). *) -(* destruct H0 as (id & BP1 & BP2). *) -(* unfold senv_invert_symbol_total. rewrite BP1. *) -(* apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. *) -(* - clear dependent l. clear dependent l'. *) -(* inv H; ss; try (simpl_expr; fail). *) -(* destruct H0 as (id & BP1 & BP2). *) -(* unfold senv_invert_symbol_total. rewrite BP1. *) -(* rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss. *) -(* + unfold Cop.sem_cast. ss. rewrite Heq. ss. *) -(* + unfold Cop.sem_cast. ss. rewrite Heq. ss. *) -(* Qed. *) - -(* Lemma vals_public_eval_to_vargs_2 *) -(* (ge: genv) ef vargs *) -(* (VP: vals_public ge (sig_args (ef_sig ef)) vargs) *) -(* e cp le m *) -(* (WFE: wf_env ge e) *) -(* : *) -(* eval_exprlist ge e cp le m *) -(* (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) *) -(* (list_eventval_to_typelist (vals_to_eventvals ge vargs)) vargs. *) -(* Proof. *) -(* induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. *) -(* - clear dependent l. clear dependent l'. *) -(* inv H; ss; try (simpl_expr; fail). *) -(* destruct H0 as (id & BP1 & BP2). *) -(* unfold senv_invert_symbol_total. rewrite BP1. *) -(* apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. *) -(* - clear dependent l. clear dependent l'. *) -(* inv H; ss; try (simpl_expr; fail). *) -(* destruct H0 as (id & BP1 & BP2). *) -(* unfold senv_invert_symbol_total. rewrite BP1. *) -(* rewrite ptr_of_id_ofs_typeof. ss. *) -(* Qed. *) - -(* Lemma match_symbs_block_public *) -(* ge1 ge2 *) -(* (MS: match_symbs ge1 ge2) *) -(* b *) -(* (BP: block_public ge1 b) *) -(* : *) -(* block_public ge2 b. *) -(* Proof. *) -(* destruct MS as (MS1 & MS2 & MS3). destruct BP as (id & BP1 & BP2). *) -(* apply Senv.invert_find_symbol in BP1. apply MS2 in BP1. rewrite <- MS1 in BP2. *) -(* unfold block_public. esplits; eauto. apply Senv.find_invert_symbol; auto. *) -(* Qed. *) - -(* Lemma match_symbs_vals_public *) -(* ge1 ge2 *) -(* (MS: match_symbs ge1 ge2) *) -(* tys vargs *) -(* (VP: vals_public ge1 tys vargs) *) -(* : *) -(* vals_public ge2 tys vargs. *) -(* Proof. *) -(* induction VP; ss. econs; auto. clear VP IHVP. inv H; econs; auto. *) -(* eapply match_symbs_block_public; eauto. *) -(* Qed. *) - -(* Lemma match_symbs_vals_public_vals_to_eventvals *) -(* ge1 ge2 *) -(* (MS: match_symbs ge1 ge2) *) -(* tys vargs *) -(* (VP: vals_public ge1 tys vargs) *) -(* : *) -(* vals_to_eventvals ge1 vargs = vals_to_eventvals ge2 vargs. *) -(* Proof. *) -(* induction VP; ss. f_equal; auto. clear dependent l. clear dependent l'. *) -(* inv H; ss. destruct H0 as (id & BP1 & BP2). *) -(* unfold senv_invert_symbol_total at 1. des_ifs. *) -(* destruct MS as (MS0 & MS1 & MS2). *) -(* apply Senv.invert_find_symbol in Heq. apply MS1 in Heq. *) -(* unfold senv_invert_symbol_total at 1. apply Senv.find_invert_symbol in Heq. *) -(* rewrite Heq. auto. *) -(* Qed. *) - -(* Lemma match_symbs_vals_public_eval_to_vargs *) -(* ge1 (ge2: genv) *) -(* (MS: match_symbs ge1 ge2) *) -(* ef vargs *) -(* (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) *) -(* e cp le m *) -(* (WFE: wf_env ge2 e) *) -(* : *) -(* eval_exprlist ge2 e cp le m *) -(* (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) -(* (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. *) -(* Proof. *) -(* erewrite match_symbs_vals_public_vals_to_eventvals; eauto. *) -(* eapply vals_public_eval_to_vargs; auto. eapply match_symbs_vals_public; eauto. *) -(* Qed. *) - -(* Lemma match_symbs_vals_public_eval_to_vargs_2 *) -(* ge1 (ge2: genv) *) -(* (MS: match_symbs ge1 ge2) *) -(* ef vargs *) -(* (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) *) -(* e cp le m *) -(* (WFE: wf_env ge2 e) *) -(* : *) -(* eval_exprlist ge2 e cp le m *) -(* (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) -(* (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs. *) -(* Proof. *) -(* erewrite match_symbs_vals_public_vals_to_eventvals; eauto. *) -(* eapply vals_public_eval_to_vargs_2; auto. eapply match_symbs_vals_public; eauto. *) -(* Qed. *) - -(* Lemma extcall_unkowns_vals_public *) -(* ef ge m vargs *) -(* (EC: external_call_unknowns ef ge m vargs) *) -(* : *) -(* vals_public ge (sig_args (ef_sig ef)) vargs. *) -(* Proof. *) -(* unfold external_call_unknowns in EC. des_ifs; ss; auto. *) -(* all: destruct EC as (EC1 & EC2); auto. *) -(* Qed. *) - - -(* Lemma mem_unchanged_wunchanged *) -(* P m m' *) -(* (UCH: Mem.unchanged_on P m m') *) -(* : *) -(* wunchanged_on P m m'. *) -(* Proof. inv UCH. econs; eauto. Qed. *) - -(* Lemma meminj_public_not_public_not_mapped *) -(* ge cnt_cur *) -(* (NP: Senv.public_symbol ge cnt_cur = false) *) -(* cnt_cur_b *) -(* (FIND: Senv.find_symbol ge cnt_cur = Some cnt_cur_b) *) -(* : *) -(* forall b ofs, meminj_public ge b <> Some (cnt_cur_b, ofs). *) -(* Proof. *) -(* ii. unfold meminj_public in H. des_ifs. *) -(* assert (i = cnt_cur). *) -(* { eapply Senv.find_symbol_injective; eauto. apply Senv.invert_find_symbol; auto. } *) -(* subst i. rewrite NP in Heq0. ss. *) -(* Qed. *) - - -(* Lemma wunchanged_on_exists_mem_free_gen *) -(* m1 b lo hi cp m2 *) -(* (FREE: Mem.free m1 b lo hi cp = Some m2) *) -(* (P: block -> Prop) m_c *) -(* (WCH: wunchanged_on (fun b _ => P b) m1 m_c) *) -(* (NGB: P b) *) -(* : *) -(* exists m_c', Mem.free m_c b lo hi cp = Some m_c'. *) -(* Proof. *) -(* hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. *) -(* hexploit Mem.range_perm_free. *) -(* 3:{ intros (m0 & F). eexists; eapply F. } *) -(* - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. *) -(* - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. *) -(* Qed. *) - -(* Lemma wunchanged_on_exists_mem_free_2 *) -(* m1 b lo hi cp m2 *) -(* (FREE: Mem.free m1 b lo hi cp = Some m2) *) -(* ge m_c *) -(* (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) *) -(* (NGB: Senv.invert_symbol ge b = None) *) -(* : *) -(* exists m_c', Mem.free m_c b lo hi cp = Some m_c'. *) -(* Proof. eapply wunchanged_on_exists_mem_free_gen; eauto. eapply WCH. ss. Qed. *) - -(* Lemma wunchanged_on_free_preserves_gen *) -(* P m m' *) -(* (WU : wunchanged_on P m m') *) -(* b lo hi cp m1 m1' *) -(* (FREE: Mem.free m b lo hi cp = Some m1) *) -(* (FREE': Mem.free m' b lo hi cp = Some m1') *) -(* : *) -(* wunchanged_on P m1 m1'. *) -(* Proof. *) -(* inv WU. econs. *) -(* - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. *) -(* - i. assert (VB: Mem.valid_block m b0). *) -(* { eapply Mem.valid_block_free_2; eauto. } *) -(* split; i. *) -(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. *) -(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) -(* hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. *) -(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. *) -(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) -(* hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. *) -(* - i. assert (VB: Mem.valid_block m b0). *) -(* { eapply Mem.valid_block_free_2; eauto. } *) -(* split; i. *) -(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) -(* eapply Mem.free_can_access_block_inj_2; eauto. *) -(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) -(* eapply Mem.free_can_access_block_inj_2; eauto. *) -(* Qed. *) - -(* Lemma wunchanged_on_exists_mem_free_list_gen *) -(* l m1 cp m2 *) -(* (FREE: Mem.free_list m1 l cp = Some m2) *) -(* (P: block -> Prop) m_c *) -(* (WCH: wunchanged_on (fun b _ => P b) m1 m_c) *) -(* (NGB: Forall P (map (fun x => fst (fst x)) l)) *) -(* : *) -(* exists m_c', Mem.free_list m_c l cp = Some m_c'. *) -(* Proof. *) -(* revert_until l. induction l; i; ss. eauto. *) -(* destruct a as ((b & lo) & hi). ss. inv NGB. des_ifs; ss. *) -(* 2:{ exfalso. hexploit wunchanged_on_exists_mem_free_gen. 2: eapply WCH. all: eauto. *) -(* intros. des. rewrite H in Heq; clarify. *) -(* } *) -(* hexploit IHl. eapply FREE. 2: eapply H2. *) -(* { instantiate (1:=m). eapply wunchanged_on_free_preserves_gen; eauto. } *) -(* eauto. *) -(* Qed. *) - -(* Lemma wunchanged_on_exists_mem_free_list_2 *) -(* l m1 cp m2 *) -(* (FREE: Mem.free_list m1 l cp = Some m2) *) -(* ge m_c *) -(* (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) *) -(* (NGB: not_global_blks ge (map (fun x => fst (fst x)) l)) *) -(* : *) -(* exists m_c', Mem.free_list m_c l cp = Some m_c'. *) -(* Proof. eapply wunchanged_on_exists_mem_free_list_gen; eauto. ss. Qed. *) - -(* Lemma wunchanged_on_free_list_preserves_gen *) -(* P m m' *) -(* (WU: wunchanged_on P m m') *) -(* l cp m_f m_f' *) -(* (FREE: Mem.free_list m l cp = Some m_f) *) -(* (FREE': Mem.free_list m' l cp = Some m_f') *) -(* : *) -(* wunchanged_on P m_f m_f'. *) -(* Proof. *) -(* move l after m. revert_until l. induction l; ii; ss. clarify. *) -(* des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves_gen; eauto. *) -(* Qed. *) - -(* Lemma meminj_not_alloc_external_call *) -(* j m1 *) -(* (NA: meminj_not_alloc j m1) *) -(* ef ge vargs tr vretv m2 *) -(* (EC: external_call ef ge vargs m1 tr vretv m2) *) -(* : *) -(* meminj_not_alloc j m2. *) -(* Proof. *) -(* unfold meminj_not_alloc in *. i. apply NA. clear NA. *) -(* eapply external_call_nextblock in EC. etransitivity. 2: eapply H. auto. *) -(* Qed. *) - -(* Lemma public_first_order_meminj_first_order *) -(* (ge: Senv.t) m *) -(* (FO: public_first_order ge m) *) -(* : *) -(* meminj_first_order (meminj_public ge) m. *) -(* Proof. *) -(* ii. unfold meminj_public in H. des_ifs. eapply FO; eauto. *) -(* apply Senv.invert_find_symbol; auto. *) -(* Qed. *) - -(* Lemma list_length_filter_le *) -(* A P (l: list A) *) -(* : *) -(* (Datatypes.length (filter P l) <= Datatypes.length l)%nat. *) -(* Proof. *) -(* induction l; ss. des_ifs; ss; auto. rewrite <- Nat.succ_le_mono. auto. *) -(* Qed. *) - -(* End PROOF. *) +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) + (GE3: Genv.allowed_addrof ge cp id) + : + 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 Heq, TY, 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. + right; auto. + - 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. + destruct flowsto_dec; try inv WF. + apply andb_prop in Heq0 as [_ G]. + destruct flowsto_dec; try inv G. + exploit flowsto_antisym; eauto. intros ?; subst. + 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. + - apply andb_false_iff in Heq0 as [G | G]; try now inv G. + destruct cp_eq_dec; inv WF. + exfalso. pose proof (flowsto_refl (comp_of f)). now destruct flowsto_dec. } + { assert (G: flowsto_dec c (comp_of f)). + { destruct cp_eq_dec; inv WF. + pose proof (flowsto_refl (comp_of f)). now destruct flowsto_dec. } + rewrite G, H0. ss. eapply step_assign. + - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval; auto. + eapply Genv.invert_find_symbol; eauto. right; auto. + - 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. + destruct cp_eq_dec; inv 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. + apply andb_prop in Heq2 as [WF1 WF2]. + apply andb_false_iff in NWF as [NWF | NWF]; try congruence. admit. + destruct cp_eq_dec; inv NWF + Qed. + + Lemma code_mem_delta_correct + (ge: genv) + f k e le m m' + d snext + (WFE: wf_env ge e) + (APPD: mem_delta_apply_wf ge (comp_of f) d (Some m) = Some m') + : + (star step1 ge (State f (code_mem_delta ge (comp_of f) d snext) k e le m) + E0 (State f snext k e le m')). + Proof. + revert m m' snext APPD. induction d; intros. + { unfold mem_delta_apply_wf in APPD. ss. inv APPD. unfold code_mem_delta. ss. econs 1. } + rewrite mem_delta_apply_wf_cons in APPD. rewrite code_mem_delta_cons. + des_ifs. + - exploit mem_delta_apply_wf_some; eauto. intros (mi & APPD0). rewrite APPD0 in APPD. + destruct a; ss. econs 2. + { eapply step_seq. } + econs 2. + { eapply code_mem_delta_storev_correct; eauto. } + take_step. eapply IHd; eauto. eauto. auto. + - destruct a; ss. + rewrite wf_mem_delta_storev_false_is_skip; auto. + all: take_step; take_step; eapply IHd; eauto. + Qed. + + Lemma code_bundle_trace_spec + (ge: genv) cp cnt tr + f e le m k + : + star step1 ge + (State f (code_bundle_trace ge cp cnt tr) k e le m) + E0 + (State f (switch_bundle_events ge cnt cp tr) + (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge cnt cp tr)) Sskip k) + e le m). + Proof. + econs 2. + { unfold code_bundle_trace, Swhile. eapply step_loop. } + econs 2. + { eapply step_seq. } + econs 2. + { eapply step_ifthenelse. simpl_expr. ss. } + rewrite Int.eq_false; ss. econs 2. + { eapply step_skip_seq. } + econs 1. all: eauto. + Qed. + +End CODEPROOFS. + + +Section GENV. + + Definition symbs_public (ge1 ge2: Senv.t) := (forall id : ident, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id). + Definition symbs_find (ge1 ge2: Senv.t) := forall id b, Senv.find_symbol ge1 id = Some b -> Senv.find_symbol ge2 id = Some b. + Definition symbs_volatile (ge1 ge2: Senv.t) := forall b, Senv.block_is_volatile ge2 b = Senv.block_is_volatile ge1 b. + + Definition match_symbs (ge1 ge2: Senv.t) := symbs_public ge1 ge2 /\ symbs_find ge1 ge2 /\ symbs_volatile ge1 ge2. + + Lemma match_symbs_meminj_public + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + : + meminj_public ge1 = meminj_public ge2. + Proof. + destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). unfold meminj_public. extensionalities b. des_ifs. + - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. + apply Senv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. + - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. + apply Senv.find_invert_symbol in x0. clarify. + - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. + apply Senv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. + - exfalso. rewrite MSYMB1 in Heq1. apply Senv.public_symbol_exists in Heq1. des. + exploit MSYMB2; eauto. intros. apply Senv.invert_find_symbol in Heq0. clarify. + apply Senv.find_invert_symbol in Heq1. clarify. + Qed. + + Lemma match_symbs_wf_mem_delta_storev + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp0 d + : + wf_mem_delta_storev_b ge1 cp0 d = wf_mem_delta_storev_b ge2 cp0 d. + Proof. + destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). + destruct d as [[[ch ptr] v] cp]. ss. des_ifs. + - do 2 f_equal. apply Senv.invert_find_symbol, MSYMB2, Senv.find_invert_symbol in Heq. clarify. + - exfalso. apply Senv.invert_find_symbol, MSYMB2, Senv.find_invert_symbol in Heq. clarify. + - destruct (Senv.public_symbol ge2 i0) eqn:PUB; ss. + exfalso. rewrite MSYMB1 in PUB. apply Senv.public_symbol_exists in PUB. des. + exploit MSYMB2; eauto. intros. apply Senv.invert_find_symbol in Heq0. clarify. + apply Senv.find_invert_symbol in PUB. clarify. + Qed. + + Lemma match_symbs_wf_mem_delta_kind + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp + : + wf_mem_delta_kind_b ge1 cp = wf_mem_delta_kind_b ge2 cp. + Proof. unfold wf_mem_delta_kind_b. extensionalities d. des_ifs. apply match_symbs_wf_mem_delta_storev; auto. Qed. + + Lemma match_symbs_get_wf_mem_delta + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp d + : + get_wf_mem_delta ge1 cp d = get_wf_mem_delta ge2 cp d. + Proof. unfold get_wf_mem_delta. erewrite match_symbs_wf_mem_delta_kind; eauto. Qed. + + Lemma match_symbs_mem_delta_apply_wf + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp d m + : + mem_delta_apply_wf ge1 cp d m = mem_delta_apply_wf ge2 cp d m. + Proof. unfold mem_delta_apply_wf. erewrite match_symbs_get_wf_mem_delta; eauto. Qed. + + Lemma match_symbs_code_mem_delta_kind + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp + : + code_mem_delta_kind ge1 cp = code_mem_delta_kind ge2 cp. + Proof. + extensionalities k. unfold code_mem_delta_kind. des_ifs. + destruct d as [[[ch ptr] v] cp0]. ss. destruct ptr; ss. + destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). + destruct (Senv.invert_symbol ge1 b) eqn:INV1. + { exploit Senv.invert_find_symbol; eauto. intros FIND1. + exploit MSYMB2; eauto. intros FIND2. exploit Senv.find_invert_symbol; eauto. intros INV2. + rewrite INV2. destruct (chunk_to_type ch) eqn:CHTY; auto. + des_ifs. + - apply andb_prop in Heq0, Heq2. des. apply andb_prop in Heq0, Heq2. des. + assert (chunk_val_to_expr ge2 ch v = chunk_val_to_expr ge1 ch v). + { unfold chunk_val_to_expr. rewrite CHTY. clear - Heq6. + unfold wf_chunk_val_b in Heq6. des_ifs. + } + rewrite Heq, Heq1 in H. clarify. + - exfalso. apply andb_prop in Heq0. des. apply andb_prop in Heq0. des. + clarify. rewrite ! andb_true_r in Heq2. rewrite MSYMB1 in Heq2. clarify. + - exfalso. apply andb_prop in Heq0. des. apply andb_prop in Heq0. des. + apply (wf_chunk_val_chunk_val_to_expr (ge2)) in Heq3; eauto. des; clarify. + - exfalso. apply andb_prop in Heq2. des. apply andb_prop in Heq2. des. + clarify. rewrite ! andb_true_r in Heq0. rewrite MSYMB1 in Heq2; clarify. + - exfalso. apply andb_prop in Heq1. des. apply andb_prop in Heq1. des. + apply (wf_chunk_val_chunk_val_to_expr (ge1)) in Heq3; eauto. des; clarify. + } + { des_ifs. + exfalso. apply andb_prop in Heq2. des. apply andb_prop in Heq2. des. + rewrite MSYMB1 in Heq2. eapply Senv.public_symbol_exists in Heq2. des. + exploit MSYMB2. eapply Heq2. intros FIND4. eapply Senv.invert_find_symbol in Heq. clarify. + exploit Senv.find_invert_symbol. apply Heq2. intros INV3. clarify. + } + Qed. + + Lemma match_symbs_code_mem_delta + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp d s + : + code_mem_delta ge1 cp d s = code_mem_delta ge2 cp d s. + Proof. unfold code_mem_delta. erewrite match_symbs_code_mem_delta_kind; eauto. Qed. + + Lemma match_symbs_code_bundle_call + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp tr id evargs sg d + : + code_bundle_call ge1 cp tr id evargs sg d = code_bundle_call ge2 cp tr id evargs sg d. + Proof. unfold code_bundle_call. erewrite match_symbs_code_mem_delta; eauto. Qed. + + Lemma match_symbs_code_bundle_return + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp tr evr d + : + code_bundle_return ge1 cp tr evr d = code_bundle_return ge2 cp tr evr d. + Proof. unfold code_bundle_return. erewrite match_symbs_code_mem_delta; eauto. Qed. + + Lemma match_symbs_code_bundle_builtin + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp tr ef evargs d + : + code_bundle_builtin ge1 cp tr ef evargs d = code_bundle_builtin ge2 cp tr ef evargs d. + Proof. unfold code_bundle_builtin. erewrite match_symbs_code_mem_delta; eauto. Qed. + + Lemma match_symbs_code_bundle_events + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp + : + code_bundle_event ge1 cp = code_bundle_event ge2 cp. + Proof. + extensionalities be. unfold code_bundle_event. des_ifs. + eapply match_symbs_code_bundle_call; auto. eapply match_symbs_code_bundle_return; auto. eapply match_symbs_code_bundle_builtin; auto. + Qed. + + Lemma match_symbs_switch_bundle_events + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp cnt tr + : + switch_bundle_events ge1 cnt cp tr = switch_bundle_events ge2 cnt cp tr. + Proof. unfold switch_bundle_events. erewrite match_symbs_code_bundle_events; eauto. Qed. + + Lemma match_symbs_code_bundle_trace + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp cnt tr + : + code_bundle_trace ge1 cp cnt tr = code_bundle_trace ge2 cp cnt tr. + Proof. unfold code_bundle_trace. erewrite match_symbs_switch_bundle_events; eauto. Qed. + + + Lemma match_symbs_symbols_inject + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + : + symbols_inject (meminj_public ge1) ge1 ge2. + Proof. + destruct MSYMB as (MS0 & MS1 & MS2). unfold symbols_inject. splits; auto. + - i. unfold meminj_public in H. des_ifs. split; auto. + - i. exists b1. split; auto. unfold meminj_public. apply Senv.find_invert_symbol in H0. + rewrite H0. rewrite H. auto. + - i. unfold meminj_public in H. des_ifs. + Qed. + +End GENV. + + +Section PROOF. + + Lemma filter_filter + A (l: list A) (p q: A -> bool) + : + filter q (filter p l) = filter (fun a => (p a) && (q a)) l. + Proof. + induction l; ss. des_ifs; ss; clarify. + f_equal. auto. + Qed. + + Lemma get_wf_mem_delta_idem + ge cp d + : + get_wf_mem_delta ge cp (get_wf_mem_delta ge cp d) = get_wf_mem_delta ge cp d. + Proof. unfold get_wf_mem_delta. rewrite filter_filter. f_equal. extensionalities k. apply andb_diag. Qed. + + Lemma mem_delta_apply_wf_get_wf_mem_delta + ge cp d m + : + mem_delta_apply_wf ge cp d m = mem_delta_apply_wf ge cp (get_wf_mem_delta ge cp d) m. + Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_idem. auto. Qed. + + Lemma wf_mem_delta_kind_is_wf + ge cp k + (WF: wf_mem_delta_kind_b ge cp k) + : + mem_delta_kind_inj_wf cp (meminj_public ge) k. + Proof. unfold wf_mem_delta_kind_b in WF. des_ifs. unfold wf_mem_delta_storev_b in WF. ss. des_ifs. apply Pos.eqb_eq in WF. auto. Qed. + + Lemma get_wf_mem_delta_is_wf + cp ge d + : + mem_delta_inj_wf cp (meminj_public ge) (get_wf_mem_delta ge cp d). + Proof. induction d; ss. des_ifs. econs; auto. apply wf_mem_delta_kind_is_wf; auto. Qed. + + Lemma mem_delta_apply_establish_inject2 + (ge: Senv.t) k m0 m0' + (INJ: Mem.inject k m0 m0') + (INCR: inject_incr (meminj_public ge) k) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + d cp m1 + (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) + (FO: public_first_order ge m1) + : + exists m1', mem_delta_apply_wf ge cp d (Some m0') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. + Proof. + unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. eapply mem_delta_apply_establish_inject; eauto. + apply get_wf_mem_delta_is_wf. + unfold public_first_order in FO. ii. unfold meminj_public in H. des_ifs. apply Senv.invert_find_symbol in Heq. + eapply FO; eauto. + Qed. + + Lemma mem_delta_apply_establish_inject_preprocess_gen + (ge: Senv.t) (k: meminj) m0 m0' + (INJ: Mem.inject k m0 m0') + pch pb pofs pv pcp m0'' + (PRE: Mem.store pch m0' pb pofs pv pcp = Some m0'') + (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) + (INCR: inject_incr (meminj_public ge) k) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + d cp m1 + (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) + : + exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ + (meminj_first_order (meminj_public ge) m1 -> Mem.inject (meminj_public ge) m1 m1'). + Proof. + unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. + eapply mem_delta_apply_establish_inject_preprocess_gen; eauto. + apply get_wf_mem_delta_is_wf. + Qed. + + Lemma mem_delta_apply_establish_inject_preprocess2 + (ge: Senv.t) (k: meminj) m0 m0' + (INJ: Mem.inject k m0 m0') + pch pb pofs pv pcp m0'' + (PRE: Mem.store pch m0' pb pofs pv pcp = Some m0'') + (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) + (INCR: inject_incr (meminj_public ge) k) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + d cp m1 + (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) + (FO: public_first_order ge m1) + : + exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. + Proof. + hexploit mem_delta_apply_establish_inject_preprocess_gen; eauto. i. des. + esplits; eauto. apply H0. ii. unfold meminj_public in H1. des_ifs. + eapply FO; eauto. apply Senv.invert_find_symbol; auto. + Qed. + +End PROOF. + + + +Section DEFINITIONS. + + Definition meminj_same_block (j : meminj) := + forall b1 b2 del, j b1 = Some (b2, del) -> b1 = b2. + + Definition not_global_blks (ge: Senv.t) (ebs: list block) := + Forall (fun b => Senv.invert_symbol ge b = None) ebs. + + Definition blocks_of_env2 ge e : list block := (map (fun x => fst (fst x)) (blocks_of_env ge e)). + + Definition not_inj_blks (j: meminj) (ebs: list block) := + Forall (fun b => j b = None) ebs. + + Lemma not_global_is_not_inj_bloks + ge l + (NGB: not_global_blks ge l) + : + not_inj_blks (meminj_public ge) l. + Proof. induction NGB. ss. econs; eauto. unfold meminj_public. des_ifs. Qed. + + Definition eq_policy (ge1: Asm.genv) (ge2: genv) := + Genv.genv_policy ge1 = Genv.genv_policy ge2. + +End DEFINITIONS. + + + +Section PROOF. + + (* Properties *) + Lemma eventval_match_transl + (ge: Senv.t) + ev ty v + (EM: eventval_match ge ev ty v) + : + eventval_match ge ev (typ_of_type (typ_to_type ty)) (eventval_to_val ge ev). + Proof. + inversion EM; subst; simpl; try constructor. + setoid_rewrite H0. unfold Tptr in *. destruct Archi.ptr64; auto. + Qed. + + Lemma eventval_match_eventval_to_val + (ge: Senv.t) + ev ty v + (EM: eventval_match ge ev ty v) + : + eventval_to_val ge ev = v. + Proof. inversion EM; subst; simpl; auto. setoid_rewrite H0. auto. Qed. + + Lemma eventval_list_match_transl + (ge: Senv.t) + evs tys vs + (EM: eventval_list_match ge evs tys vs) + : + eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs). + Proof. induction EM; simpl. constructor. constructor; auto. eapply eventval_match_transl; eauto. Qed. + + Lemma eventval_list_match_transl_val + (ge: Senv.t) + evs tys vs + (EM: eventval_list_match ge evs tys vs) + : + eventval_list_match ge evs tys (list_eventval_to_list_val ge evs). + Proof. induction EM; simpl. constructor. constructor; auto. erewrite eventval_match_eventval_to_val; eauto. Qed. + + Lemma typ_type_typ + (ge: Senv.t) + ev ty v + (EM: eventval_match ge ev ty v) + : + typ_of_type (typ_to_type ty) = ty. + Proof. inversion EM; simpl; auto. subst. unfold Tptr. destruct Archi.ptr64; simpl; auto. Qed. + + Lemma eventval_to_expr_val_eval + (ge: genv) en cp temp m ev ty v + (WFENV: wf_env ge en) + (EM: eventval_match ge ev ty v) + (* (WFGE: wf_eventval_ge ge ev) *) + : + eval_expr ge en cp temp m (eventval_to_expr ev) (eventval_to_val ge ev). + Proof. destruct ev; simpl in *; try constructor. inv EM. setoid_rewrite H4. eapply ptr_of_id_ofs_eval; auto. Qed. + + Lemma sem_cast_eventval_match + (ge: Senv.t) v ty vv m + (EM: eventval_match ge v (typ_of_type (typ_to_type ty)) vv) + : + Cop.sem_cast vv (typeof (eventval_to_expr v)) (typ_to_type ty) m = Some vv. + Proof. + destruct ty; simpl in *; inversion EM; subst; simpl in *; simpl_expr. + all: try rewrite ptr_of_id_ofs_typeof; simpl. + all: try (cbn; auto). + all: unfold Tptr in *; destruct Archi.ptr64 eqn:ARCH; try congruence. + { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } + { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } + { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } + { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } + Qed. + + Lemma list_eventval_to_expr_val_eval + (ge: genv) en cp temp m evs tys + (* (WFENV: Forall (wf_eventval_env en) evs) *) + (WFENV: wf_env ge en) + (EMS: eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs)) + : + eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) (list_eventval_to_list_val ge evs). + Proof. + revert en cp temp m WFENV. + match goal with | [H: eventval_list_match _ _ ?t ?v |- _] => remember t as tys2; remember v as vs2 end. + revert tys Heqtys2 Heqvs2. induction EMS; intros; subst; simpl in *. + { destruct tys; simpl in *. constructor. congruence. } + inversion Heqvs2; clear Heqvs2; subst; simpl in *. + destruct tys; simpl in Heqtys2. congruence with Heqtys2. + inversion Heqtys2; clear Heqtys2; subst; simpl in *. + econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. + (* eapply eventval_match_wf_eventval_ge; eauto. *) + eapply sem_cast_eventval_match; eauto. + Qed. + + Lemma eventval_match_eventval_to_type + (ge: Senv.t) + ev ty v + (EM: eventval_match ge ev ty v) + : + eventval_match ge ev (typ_of_type (eventval_to_type ev)) v. + Proof. inversion EM; subst; simpl; auto. Qed. + + Lemma list_eventval_match_eventval_to_type + (ge: Senv.t) + evs tys vs + (ESM: eventval_list_match ge evs tys vs) + : + eventval_list_match ge evs (typlist_of_typelist (list_eventval_to_typelist evs)) vs. + Proof. induction ESM; simpl. constructor. constructor; auto. eapply eventval_match_eventval_to_type; eauto. Qed. + + Lemma val_load_result_idem + ch v + : + Val.load_result ch (Val.load_result ch v) = Val.load_result ch v. + Proof. + destruct ch, v; simpl; auto. + 5,6,7: destruct Archi.ptr64; simpl; auto. + 1,3: rewrite Int.sign_ext_idem; auto. + 3,4: rewrite Int.zero_ext_idem; auto. + all: lia. + Qed. + + Lemma val_load_result_aux + F V (ge: Genv.t F V) + ev ch v + (EM: eventval_match ge ev (type_of_chunk ch) (Val.load_result ch v)) + : + eventval_match ge ev (type_of_chunk ch) (Val.load_result ch (eventval_to_val ge ev)). + Proof. + inversion EM; subst; simpl in *; auto. + 1,2,3,4: rewrite H1, H2; rewrite val_load_result_idem; auto. + rewrite H3, H. rewrite H0. rewrite val_load_result_idem. auto. + Qed. + + Lemma eventval_match_proj_rettype + (ge: Senv.t) + ev ty v + (EM: eventval_match ge ev ty v) + : + eventval_match ge ev (proj_rettype (rettype_of_type (typ_to_type ty))) v. + Proof. + inversion EM; subst; simpl; try constructor. + unfold Tptr in *. destruct Archi.ptr64; simpl; auto. + Qed. + + (* Lemma sem_cast_eventval *) + (* (ge: cgenv) v m *) + (* (WFEV: wf_eventval_ge ge v) *) + (* : *) + (* Cop.sem_cast (eventval_to_val ge v) (typeof (eventval_to_expr v)) (eventval_to_type v) m = Some (eventval_to_val ge v). *) + (* Proof. rewrite typeof_eventval_to_expr_type. destruct v; simpl in *; simpl_expr. destruct WFEV. rewrite H. simpl_expr. Qed. *) + + (* Lemma list_eventval_to_expr_val_eval2 *) + (* (ge: genv) en cp temp m evs *) + (* (WFENV: Forall (wf_eventval_env en) evs) *) + (* (WFGE: Forall (wf_eventval_ge ge) evs) *) + (* : *) + (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_eventval_to_typelist evs) (list_eventval_to_list_val ge evs). *) + (* Proof. *) + (* move evs at top. revert ge en cp temp m WFENV WFGE. induction evs; intros; simpl in *. *) + (* constructor. *) + (* inversion WFENV; clear WFENV; subst. inversion WFGE; clear WFGE; subst. *) + (* econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. *) + (* apply sem_cast_eventval; auto. *) + (* Qed. *) + + Lemma eventval_match_sem_cast + (* F V (ge: Genv.t F V) *) + (ge: genv) + m ev ty v + (EM: eventval_match ge ev ty v) + : + (* Cop.sem_cast (eventval_to_val ge ev) (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some (eventval_to_val ge ev). *) + Cop.sem_cast v (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some v. + Proof. + inversion EM; subst; simpl; try constructor. all: simpl_expr. + rewrite ptr_of_id_ofs_typeof. unfold Tptr. unfold Cop.sem_cast. destruct Archi.ptr64 eqn:ARCH; simpl. + - rewrite ARCH; auto. + - rewrite ARCH; auto. + Qed. + + (* Lemma list_eventval_to_expr_val_eval_typs *) + (* (ge: genv) en cp temp m evs tys vs *) + (* (WFENV: Forall (wf_eventval_env en) evs) *) + (* (EMS: eventval_list_match ge evs tys vs) *) + (* : *) + (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) vs. *) + (* Proof. *) + (* revert en cp temp m WFENV. *) + (* induction EMS; intros; subst; simpl in *. constructor. *) + (* inversion WFENV; clear WFENV; subst. *) + (* econstructor; eauto. 2: eapply eventval_match_sem_cast; eauto. *) + (* exploit eventval_match_eventval_to_val. eauto. intros. rewrite <- H0. eapply eventval_to_expr_val_eval; auto. *) + (* eapply eventval_match_wf_eventval_ge; eauto. *) + (* Qed. *) + + Lemma sem_cast_ptr + b ofs m + : + Cop.sem_cast (Vptr b ofs) (Tpointer Tvoid noattr) (typ_to_type Tptr) m = Some (Vptr b ofs). + Proof. + unfold Tptr. destruct Archi.ptr64 eqn:ARCH; unfold Cop.sem_cast; simpl; rewrite ARCH; auto. + Qed. + + Lemma sem_cast_proj_rettype + (ge: genv) evres rty res m + (EVM: eventval_match ge evres (proj_rettype rty) res) + : + Cop.sem_cast (eventval_to_val ge evres) + (typeof (eventval_to_expr evres)) + (rettype_to_type rty) m + = Some (eventval_to_val ge evres). + Proof. + destruct rty; simpl in *. + { eapply eventval_match_sem_cast. eauto. erewrite eventval_match_eventval_to_val; eauto. } + { inv EVM; simpl; simpl_expr. + setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. + unfold Cop.sem_cast. simpl. rewrite ARCH. auto. + } + { inv EVM; simpl; simpl_expr. + setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. + unfold Cop.sem_cast. simpl. rewrite ARCH. auto. + } + { inv EVM; simpl; simpl_expr. + setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. + unfold Cop.sem_cast. simpl. rewrite ARCH. auto. + } + { inv EVM; simpl; simpl_expr. + setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. + unfold Cop.sem_cast. simpl. rewrite ARCH. auto. + } + { inv EVM; simpl; simpl_expr. + setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. + unfold Cop.sem_cast. simpl. rewrite ARCH. auto. + } + Qed. + + Lemma type_of_params_eq + params ts + (PARSIGS : list_typ_to_list_type ts = map snd params) + : + type_of_params params = list_typ_to_typelist ts. + Proof. + revert params PARSIGS. induction ts; ii; ss. + { destruct params; ss. } + destruct params; ss. destruct p; ss. clarify. f_equal. auto. + Qed. + + Lemma match_senv_eventval_match + (ge0 ge1: Senv.t) + (MS: match_symbs ge0 ge1) + ev ty v + (EM: eventval_match ge0 ev ty v) + : + eventval_match ge1 ev ty v. + Proof. destruct MS as (MS0 & MS1 & MS2). inv EM; try econs; auto. rewrite MS0. auto. Qed. + + Lemma match_senv_eventval_list_match + (ge0 ge1: Senv.t) + (MS: match_symbs ge0 ge1) + evs tys vs + (EM: eventval_list_match ge0 evs tys vs) + : + eventval_list_match ge1 evs tys vs. + Proof. induction EM; ss. econs; auto. econs; auto. eapply match_senv_eventval_match; eauto. Qed. + + Lemma unbundle_trace_app + tr1 tr2 + : + unbundle_trace (tr1 ++ tr2) = (unbundle_trace tr1) ++ (unbundle_trace tr2). + Proof. induction tr1; ss. rewrite <- app_assoc. f_equal. auto. Qed. + + Lemma allowed_call_gen_function + cp (ge_i: Asm.genv) (ge_c: genv) next cnt params tr f_i f_c + (GE: symbs_find ge_i ge_c) + (GEPOL: eq_policy ge_i ge_c) + (GEN: f_c = gen_function ge_i cnt params tr f_i) + (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) + (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.Internal f_i)) + (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = Some (Internal f_c)) + : + Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). + Proof. + unfold Genv.allowed_call in *. des; [left | right]. + - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. + - subst. unfold Genv.allowed_cross_call in *. des. + unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. + specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. + { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. + apply GE. auto. + } + { i. rewrite FINDF_C in H. clarify. } + { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. + rewrite <- ALLOW1. ss. + } + Qed. + + Lemma allowed_call_gen_function_external + cp (ge_i: Asm.genv) (ge_c: genv) next ef + (GE: symbs_find ge_i ge_c) + (GEPOL: eq_policy ge_i ge_c) + (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) + (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.External ef)) + (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = + Some (External ef + (list_typ_to_typelist (sig_args (ef_sig ef))) + (rettype_to_type (sig_res (ef_sig ef))) + (sig_cc (ef_sig ef)))) + : + Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). + Proof. + unfold Genv.allowed_call in *. des; [left | right]. + - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. + - unfold Genv.allowed_cross_call in *. des. + unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. + specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. + { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. + apply GE. auto. + } + { i. rewrite FINDF_C in H. clarify. } + { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. + rewrite <- ALLOW1. ss. + } + Qed. + + Lemma eventval_list_match_list_eventval_to_list_val + (ge: Senv.t) evargs tys vargs + (EVMS: eventval_list_match ge evargs tys vargs) + : + list_eventval_to_list_val ge evargs = vargs. + Proof. + induction EVMS; ss. f_equal; auto. + eapply eventval_match_eventval_to_val. eauto. + Qed. + + Lemma match_symbs_eventval_match + ge0 ge1 ev ty v + (MS: match_symbs ge0 ge1) + (EVM: eventval_match ge0 ev ty v) + : + eventval_match ge1 ev ty v. + Proof. + destruct MS as (MS0 & MS1 & MS2). inv EVM; econs; auto. rewrite MS0; auto. + Qed. + + Lemma match_symbs_eventval_list_match + ge0 ge1 ev ty v + (MS: match_symbs ge0 ge1) + (EVM: eventval_list_match ge0 ev ty v) + : + eventval_list_match ge1 ev ty v. + Proof. + induction EVM. econs. econs; auto. eapply match_symbs_eventval_match; eauto. + Qed. + + Lemma alloc_variables_exists + ge cp e m l + : + exists e' m', alloc_variables ge cp e m l e' m'. + Proof. + revert ge cp e m. induction l; ii. + { do 2 eexists. econs 1. } + destruct a as (id & ty). + destruct (Mem.alloc m cp 0 (sizeof ge ty)) as (m0 & b0) eqn:ALLOC. + specialize (IHl ge cp (PTree.set id (b0, ty) e) m0). des. + do 2 eexists. econs 2. eapply ALLOC. eapply IHl. + Qed. + + Lemma access_mode_typ_to_type + s + : + exists ch, access_mode (typ_to_type s) = By_value ch. + Proof. destruct s; ss; eauto. Qed. + + Lemma bind_parameters_exists + (ge: genv) cp (e: env) m params vargs + (INENV: Forall (fun '(id, ty) => + exists b, (e ! id = Some (b, ty)) /\ + (forall ch, access_mode ty = By_value ch -> + Mem.valid_access m ch b 0 Writable (Some cp))) + params) + sg + (PARSIGS: list_typ_to_list_type sg = map snd params) + evargs + (EMS: eventval_list_match ge evargs sg vargs) + : + exists m', bind_parameters ge cp e m params vargs m'. + Proof. + revert e m vargs INENV sg PARSIGS evargs EMS. induction params; ii. + { ss. inv EMS; ss. eexists. econs. } + destruct a as (id & ty). inv INENV. des. ss. + destruct sg; ss. rename t into s. clarify. inv EMS. + destruct (access_mode_typ_to_type s) as (ch & ACCM). + specialize (H0 _ ACCM). hexploit Mem.valid_access_store. apply H0. instantiate (1:=v1). + intros (m0 & STORE). + assert + (FA: Forall + (fun '(id, ty) => + exists b : block, + e ! id = Some (b, ty) /\ + (forall ch : memory_chunk, access_mode ty = By_value ch -> + Mem.valid_access m0 ch b 0 Writable (Some cp))) params). + { clear - H2 STORE. move H2 before cp. revert_until H2. induction H2; ii; ss. + econs; eauto. des_ifs. des. esplits; eauto. i. eapply Mem.store_valid_access_1; eauto. + } + hexploit IHparams. apply FA. 1,2: eauto. intros. des. exists m'. + econs; eauto. econs; eauto. + Qed. + + Lemma alloc_variables_wf_id + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + (WF: list_norepet (var_names params)) + : + forall id bt, (~ In id (var_names params)) -> (e ! id = Some bt) -> (e' ! id = Some bt). + Proof. + revert WF. induction EA; ii; ss. + apply Classical_Prop.not_or_and in H0. des. inv WF. + apply IHEA; auto. rewrite PTree.gso; auto. + Qed. + + Lemma alloc_variables_valid_access + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + : + forall b' ch' ofs' p' cp', Mem.valid_access m ch' b' ofs' p' cp' -> + Mem.valid_access m' ch' b' ofs' p' cp'. + Proof. + i. assert (WF: (b' < Mem.nextblock m)%positive). + { unfold Mem.valid_access in H. des. destruct (Unusedglob.IS.MSet.Raw.MX.lt_dec b' (Mem.nextblock m)); auto. + exfalso. unfold Mem.range_perm in H. specialize (H ofs'). + eapply (Mem.nextblock_noaccess _ _ ofs' Cur) in n. + exploit H. + { pose proof (size_chunk_pos ch'). lia. } + i. unfold Mem.perm in x0. rewrite n in x0. ss. + } + revert_until EA. induction EA; ii; ss. + apply IHEA. + { eapply Mem.valid_access_alloc_other; eauto. } + { erewrite Mem.nextblock_alloc; eauto. lia. } + Qed. + + Lemma alloc_variables_forall + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + (WF: list_norepet (var_names params)) + : + Forall (fun '(id, ty) => + exists b, (e' ! id = Some (b, ty)) /\ + (forall ch, access_mode ty = By_value ch -> + Mem.valid_access m' ch b 0 Writable (Some cp))) params. + Proof. + revert WF. induction EA; ii; ss. + inv WF. econs; eauto. + hexploit alloc_variables_wf_id. apply EA. auto. apply H2. apply PTree.gss. + i. esplits; eauto. + i. eapply alloc_variables_valid_access. apply EA. + apply Mem.valid_access_freeable_any. eapply Mem.valid_access_alloc_same; eauto. lia. + { ss. clear - H1. destruct ty; ss; clarify. des_ifs; clarify; ss. des_ifs; clarify; ss. unfold Mptr. des_ifs. } + exists 0. ss. + Qed. + + Lemma assign_loc_valid_access + ge cp ty m b ofs bit v m' + (AL: assign_loc ge cp ty m b ofs bit v m') + ch' b' ofs' perm' cp' + (VA: Mem.valid_access m ch' b' ofs' perm' (Some cp')) + : + Mem.valid_access m' ch' b' ofs' perm' (Some cp'). + Proof. + inv AL. + - eapply Mem.store_valid_access_1; eauto. + - eapply Mem.storebytes_valid_access_1; eauto. + - inv H. eapply Mem.store_valid_access_1; eauto. + Qed. + + Lemma bind_parameters_valid_access + (ge: genv) cp (e: env) m params vargs m' + (BIND: bind_parameters ge cp e m params vargs m') + ch b ofs perm cp' + (VA: Mem.valid_access m ch b ofs perm (Some cp')) + : + Mem.valid_access m' ch b ofs perm (Some cp'). + Proof. + revert_until BIND. induction BIND; ii; ss. + apply IHBIND. eapply assign_loc_valid_access; eauto. + Qed. + + Lemma mem_delta_apply_wf_valid_access + ge cp d m m' + (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') + ch b ofs perm cp' + (VA: Mem.valid_access m ch b ofs perm cp') + : + Mem.valid_access m' ch b ofs perm cp'. + Proof. + move d before ge. revert_until d. induction d; ii. + { unfold mem_delta_apply_wf in APPD. ss; clarify. } + rewrite mem_delta_apply_wf_cons in APPD. des_ifs. + - destruct a; ss. hexploit mem_delta_apply_wf_some; eauto. + intros (m0 & STOREV). rewrite STOREV in APPD. + eapply IHd. apply APPD. + unfold mem_delta_apply_storev in STOREV. des_ifs. + unfold Mem.storev in STOREV. des_ifs. + eapply Mem.store_valid_access_1; eauto. + - eapply IHd; eauto. + Qed. + + Lemma bind_parameters_mem_load + ge cp e m0 params vargs m1 + (BIND: bind_parameters ge cp e m0 params vargs m1) + : + forall ch b ofs cp', + (forall id b_e ty, (e ! id = Some (b_e, ty) -> b <> b_e)) -> + (Mem.load ch m1 b ofs cp' = Mem.load ch m0 b ofs cp'). + Proof. + induction BIND; ii; ss. + rewrite IHBIND; auto. + inv H0. + - eapply Mem.load_store_other. eapply H3. left. ii. clarify. specialize (H1 _ _ _ H). clarify. + - eapply Mem.load_storebytes_other. eapply H7. left. ii. clarify. specialize (H1 _ _ _ H). clarify. + Qed. + + Lemma alloc_variables_mem_load + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + : + forall ch b ofs cp', + (b < Mem.nextblock m)%positive -> + (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). + Proof. + induction EA; ii; ss. + rewrite IHEA. + { eapply Mem.load_alloc_unchanged; eauto. } + { erewrite Mem.nextblock_alloc; eauto. lia. } + Qed. + + Lemma alloc_variables_old_blocks + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + : + forall b, (b < Mem.nextblock m)%positive -> + (forall id b' ty, e ! id = Some (b', ty) -> b <> b') -> + (forall id b' ty, e' ! id = Some (b', ty) -> b <> b'). + Proof. + induction EA; i. + { ii; clarify. specialize (H0 _ _ _ H1). clarify. } + hexploit Mem.alloc_result; eauto. intros; clarify. + eapply IHEA. 3: eapply H2. + { erewrite Mem.nextblock_alloc; eauto. lia. } + { i. destruct (Pos.eq_dec id id1). + - clarify. rewrite PTree.gss in H3. clarify. lia. + - rewrite PTree.gso in H3; auto. eapply H1; eauto. + } + Qed. + + Lemma mem_delta_apply_wf_mem_load + ge cp d m m' + (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') + : + forall id ch b ofs cp', + Senv.invert_symbol ge b = Some id -> + Senv.public_symbol ge id = false -> + (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). + Proof. + move d before ge. revert_until d. induction d; ii. + { unfold mem_delta_apply_wf in APPD. ss. clarify. } + rewrite mem_delta_apply_wf_cons in APPD. des_ifs. + { destruct a; ss. unfold wf_mem_delta_storev_b in Heq. des_ifs. ss. + hexploit mem_delta_apply_wf_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. + erewrite IHd. 2: eauto. 2: eauto. all: auto. + destruct (Pos.eq_dec b b0). + - clarify. + - erewrite Mem.load_store_other. 2: eauto. all: auto. + } + { eapply IHd; eauto. } + Qed. + + Lemma nat64_int64_add_one + n + (BOUND: Z.of_nat n < Int64.modulus) + : + Int64.add (nat64 n) Int64.one = nat64 (n + 1). + Proof. + unfold nat64. rewrite Nat2Z.inj_add. ss. + assert (N: Z.of_nat n = Int64.unsigned (Int64.repr (Z.of_nat n))). + { symmetry. apply Int64.unsigned_repr. split. apply Zle_0_nat. + unfold Int64.max_unsigned. lia. + } + assert (ONE: 1 = (Int64.unsigned (Int64.repr 1))). + { ss. } + rewrite N at 2. rewrite ONE. rewrite <- Int64.add_unsigned. ss. + Qed. + + Lemma mem_free_list_impl1 + blks m cp m_f + (FREE: Mem.free_list m blks cp = Some m_f) + : + Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks. + Proof. + Local Opaque Mem.can_access_block. + revert_until blks. induction blks; ii; ss. des_ifs. ss. econs. + 2:{ cut (Forall (fun '(b0, lo, hi) => Mem.range_perm m0 b0 lo hi Cur Freeable /\ Mem.can_access_block m0 b0 (Some cp)) blks); cycle 1. + { eapply IHblks; eauto. } + clear - Heq. intros FA. revert_until blks. induction blks; ii; ss. + destruct a as ((ba & loa) & hia). ss. inv FA. des; clarify. econs. + { + clear IHblks. split. + - unfold Mem.range_perm in *. ii. eapply Mem.perm_free_3. eauto. eauto. + - eapply Mem.free_can_access_block_inj_2; eauto. + } + eapply IHblks; eauto. + } + split. + - eapply Mem.free_range_perm; eauto. + - eapply Mem.free_can_access_block_1; eauto. + Local Transparent Mem.can_access_block. + Qed. + + Lemma mem_free_list_impl2 + blks m cp + (NR: list_norepet (map (fun x => fst (fst x)) blks)) + (FA: Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks) + : + exists m_f, (Mem.free_list m blks cp = Some m_f). + Proof. + Local Opaque Mem.can_access_block. + revert_until blks. induction blks; ii; ss; eauto. + inv FA. inv NR. des_ifs; des. + 2:{ exfalso. destruct (Mem.range_perm_free _ _ _ _ _ H1 H0) as (m0 & FREE). clarify. } + eapply IHblks; clear IHblks; eauto. ss. clear - H2 H3 Heq. + revert_until blks. induction blks; ii; ss. inv H2. des_ifs; ss. des. econs; eauto. + clear IHblks H4. apply Classical_Prop.not_or_and in H3. des. split. + - unfold Mem.range_perm in *. ii. hexploit Mem.perm_free_inv; eauto. ii. des; clarify. + - eapply Mem.free_can_access_block_inj_1; eauto. + Local Transparent Mem.can_access_block. + Qed. + + Lemma list_map_norepet_rev + A (l: list A) B (f: A -> B) + (NR: list_norepet (map f l)) + : + list_norepet l. + Proof. + revert NR. induction l; ii; ss. econs. inv NR. econs; eauto. + ii. apply H1; clear H1. apply in_map; auto. + Qed. + + Lemma alloc_variables_wunchanged_on + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + : + wunchanged_on (fun b _ => Mem.valid_block m b) m m'. + Proof. + induction EA. apply wunchanged_on_refl. + eapply wunchanged_on_implies in IHEA. + { eapply wunchanged_on_trans. 2: eauto. eapply alloc_wunchanged_on. eauto. } + { ii. ss. } + Qed. + + Lemma alloc_variables_exists_free_list + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + (ENV1: forall id1 id2 b1 b2 t1 t2, (id1 <> id2) -> (e ! id1 = Some (b1, t1)) -> (e ! id2 = Some (b2, t2)) -> (b1 <> b2)) + (ENV2: forall id b t, (e ! id = Some (b, t)) -> (Mem.valid_block m b)) + m_f0 + (FREE: Mem.free_list m' (blocks_of_env ge e) cp = Some m_f0) + : + exists m_f, Mem.free_list m' (blocks_of_env ge e') cp = Some m_f. + Proof. + revert_until EA. induction EA; ii; ss; eauto. + assert (exists m_f0, Mem.free_list m2 (blocks_of_env ge (PTree.set id (b1, ty) e)) cp = Some m_f0); cycle 1. + { des. eapply IHEA; clear IHEA; eauto. + - i. destruct (Pos.eqb_spec id id1); clarify. + + rewrite PTree.gss in H2. rewrite PTree.gso in H3; auto. clarify. specialize (ENV2 _ _ _ H3). + ii. clarify. apply Mem.fresh_block_alloc in H. clarify. + + destruct (Pos.eqb_spec id id2); clarify. + * rewrite PTree.gso in H2; auto. rewrite PTree.gss in H3; auto. clarify. specialize (ENV2 _ _ _ H2). + ii. clarify. apply Mem.fresh_block_alloc in H. clarify. + * rewrite PTree.gso in H2, H3; auto. hexploit ENV1. 2: eapply H2. 2: eapply H3. all: auto. + - i. destruct (Pos.eqb_spec id id0); clarify. + + rewrite PTree.gss in H1. clarify. eapply Mem.valid_new_block; eauto. + + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). eapply Mem.valid_block_alloc; eauto. + } + clear IHEA. eapply mem_free_list_impl2. + { unfold blocks_of_env. rewrite map_map. apply list_map_norepet. + { eapply list_map_norepet_rev. apply PTree.elements_keys_norepet. } + { i. unfold block_of_binding. des_ifs. ss. apply PTree.elements_complete in H0, H1. + destruct (Pos.eqb_spec id i); clarify. + - rewrite PTree.gss in H0. clarify. destruct (Pos.eqb_spec i i0); clarify. + + rewrite PTree.gss in H1; clarify. + + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). ii; clarify. + apply Mem.fresh_block_alloc in H. clarify. + - rewrite PTree.gso in H0; auto. destruct (Pos.eqb_spec id i0); clarify. + + rewrite PTree.gss in H1. clarify. specialize (ENV2 _ _ _ H0). ii; clarify. + apply Mem.fresh_block_alloc in H. clarify. + + rewrite PTree.gso in H1; auto. eapply ENV1. 2: apply H0. 2: apply H1. ii; clarify. + } + } + { apply mem_free_list_impl1 in FREE. rewrite Forall_forall in *. i. + assert ((x = (b1, 0%Z, sizeof ge ty)) \/ (In x (blocks_of_env ge e))). + { clear - H0. unfold blocks_of_env in *. apply list_in_map_inv in H0. des. + destruct x0 as (xid & xb & xt). apply PTree.elements_complete in H1. clarify. + destruct (Pos.eqb_spec id xid); clarify. + - rewrite PTree.gss in H1. clarify. left; auto. + - rewrite PTree.gso in H1; auto. right. apply in_map. apply PTree.elements_correct. auto. + } + des. + - clarify. split. + + ii. eapply perm_wunchanged_on. eapply alloc_variables_wunchanged_on; eauto. + { ss. eapply Mem.valid_new_block; eauto. } + { eapply Mem.perm_alloc_2; eauto. } + + rewrite <- wunchanged_on_own. 2: eapply alloc_variables_wunchanged_on; eauto. + eapply Mem.owned_new_block; eauto. eapply Mem.valid_new_block; eauto. + - eapply FREE. eauto. + } + Qed. + + Lemma assign_loc_wunchanged_on + ge cp ty m b ofs bit v m' + (AL: assign_loc ge cp ty m b ofs bit v m') + : + wunchanged_on (fun _ _ => True) m m'. + Proof. + inv AL. + - eapply store_wunchanged_on; eauto. + - eapply storebytes_wunchanged_on; eauto. + - inv H. eapply store_wunchanged_on; eauto. + Qed. + + Lemma bind_parameters_wunchanged_on + (ge: genv) cp (e: env) m params vargs m' + (BIND: bind_parameters ge cp e m params vargs m') + : + wunchanged_on (fun _ _ => True) m m'. + Proof. + induction BIND. apply wunchanged_on_refl. eapply wunchanged_on_trans. 2: apply IHBIND. + eapply assign_loc_wunchanged_on; eauto. + Qed. + + Lemma wunchanged_on_exists_free + m m' + (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') + b lo hi cp m_f + (FREE: Mem.free m b lo hi cp = Some m_f) + : + exists m_f', Mem.free m' b lo hi cp = Some m_f'. + Proof. + hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. + hexploit Mem.range_perm_free. + 3:{ intros (m0 & F). eexists; eapply F. } + - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. eapply Mem.perm_valid_block; eauto. + - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. + Qed. + + Lemma assign_loc_perm + ge cp ty m b ofs bit v m' + (AL: assign_loc ge cp ty m b ofs bit v m') + b' o' C P + (PERM: Mem.perm m b' o' C P) + : + Mem.perm m' b' o' C P. + Proof. + inv AL. + - eapply Mem.perm_store_1; eauto. + - eapply Mem.perm_storebytes_1; eauto. + - inv H. eapply Mem.perm_store_1; eauto. + Qed. + + Lemma assign_loc_own + ge cp ty m b ofs bit v m' + (AL: assign_loc ge cp ty m b ofs bit v m') + b' cp' + (OWN: Mem.can_access_block m b' cp') + : + Mem.can_access_block m' b' cp'. + Proof. + inv AL. + - rewrite <- Mem.store_can_access_block_inj; eauto. + - eapply Mem.storebytes_can_access_block_inj_1; eauto. + - inv H. rewrite <- Mem.store_can_access_block_inj; eauto. + Qed. + + Lemma assign_loc_exists_free + ge cp ty m b ofs bit v m' + (AL: assign_loc ge cp ty m b ofs bit v m') + b' lo hi cp' m_f + (FREE: Mem.free m b' lo hi cp' = Some m_f) + : + exists m_f, Mem.free m' b' lo hi cp' = Some m_f. + Proof. + hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. + hexploit Mem.range_perm_free. + 3:{ intros (m0 & F). eexists; eapply F. } + - unfold Mem.range_perm in *. i. eapply assign_loc_perm; eauto. + - eapply assign_loc_own; eauto. + Qed. + + Lemma wunchanged_on_free_preserves + m m' + (WU : wunchanged_on (fun (b : block) (_ : Z) => Mem.valid_block m b) m m') + b lo hi cp m1 m1' + (FREE: Mem.free m b lo hi cp = Some m1) + (FREE': Mem.free m' b lo hi cp = Some m1') + : + wunchanged_on (fun (b0 : block) (_ : Z) => Mem.valid_block m1 b0) m1 m1'. + Proof. + inv WU. econs. + - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. + - i. assert (VB: Mem.valid_block m b0). + { eapply Mem.valid_block_free_2; eauto. } + split; i. + + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. + eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. + hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. + + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. + eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. + hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. + - i. assert (VB: Mem.valid_block m b0). + { eapply Mem.valid_block_free_2; eauto. } + split; i. + + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. + eapply Mem.free_can_access_block_inj_2; eauto. + + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. + eapply Mem.free_can_access_block_inj_2; eauto. + Qed. + + Lemma wunchanged_on_exists_mem_free_list + m m' + (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') + l cp m_f + (FREE: Mem.free_list m l cp = Some m_f) + : + exists m_f', Mem.free_list m' l cp = Some m_f'. + Proof. + move l after m. revert_until l. induction l; ii; ss; eauto. des_ifs. + 2:{ exfalso. hexploit wunchanged_on_exists_free. 2: eapply Heq0. 2: auto. + 2:{ intros. des. rewrite H in Heq; clarify. } + auto. + } + hexploit IHl. 2: eapply FREE. + { instantiate (1:=m0). eapply wunchanged_on_free_preserves; eauto. } + eauto. + Qed. + + Lemma mem_free_list_wunchanged_on + x m l cp m' + (FL: Mem.free_list m l cp = Some m') + (WF: Forall (fun '(b, lo, hi) => (x <= b)%positive) l) + : + wunchanged_on (fun b _ => (b < x)%positive) m m'. + Proof. + move WF before x. revert_until WF. induction WF; i; ss. clarify. apply wunchanged_on_refl. des_ifs. + hexploit IHWF; eauto. i. eapply wunchanged_on_trans. 2: eauto. + eapply free_wunchanged_on; eauto. + i. lia. + Qed. + + Lemma wunchanged_on_free_list_preserves + m m' + (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') + l cp m_f m_f' + (FREE: Mem.free_list m l cp = Some m_f) + (FREE': Mem.free_list m' l cp = Some m_f') + : + wunchanged_on (fun b _ => Mem.valid_block m_f b) m_f m_f'. + Proof. + move l after m. revert_until l. induction l; ii; ss. clarify. + des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves; eauto. + Qed. + + Lemma mem_delta_apply_wf_wunchanged_on + ge cp d m m' + (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') + P + : + wunchanged_on P m m'. + Proof. + revert_until d. induction d; ii; ss. + { cbn in APPD. clarify. apply wunchanged_on_refl. } + rewrite mem_delta_apply_wf_cons in APPD. des_ifs. + - hexploit mem_delta_apply_wf_some; eauto. intros (m0 & ST). rewrite ST in APPD. + specialize (IHd _ _ APPD). unfold mem_delta_apply_kind in ST. unfold mem_delta_apply_storev in ST. des_ifs. + ss. des_ifs. ss. eapply wunchanged_on_trans. eapply store_wunchanged_on. eapply ST. + eapply wunchanged_on_implies. eapply IHd. ss. + - eauto. + Unshelve. all: exact 0%nat. + Qed. + + Lemma alloc_variables_fresh_blocks + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + x + (X: (x <= Mem.nextblock m)%positive) + (FA: Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e)) + : + Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e'). + Proof. + revert_until EA. induction EA; ii; ss. specialize (IHEA x). + eapply IHEA; clear IHEA. + { erewrite Mem.nextblock_alloc; eauto. lia. } + apply Forall_forall. rewrite Forall_forall in FA. ii. specialize (FA x0). des_ifs. + unfold blocks_of_env in H0. apply list_in_map_inv in H0. des. destruct x0 as (xid & xb & xt). + apply PTree.elements_complete in H1. destruct (Pos.eqb_spec id xid); clarify. + - rewrite PTree.gss in H1. ss. clarify. erewrite Mem.alloc_result. 2: eauto. auto. + - rewrite PTree.gso in H1; auto. apply FA. rewrite H0. unfold blocks_of_env. apply in_map. + apply PTree.elements_correct; auto. + Qed. + + Lemma alloc_variables_one_fresh_block + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + (NR: list_norepet (var_names params)) + xid xb xt + (NOT: e ! xid = None) + (GET: e' ! xid = Some (xb, xt)) + : + ~ (Mem.valid_block m xb). + Proof. + revert_until EA. induction EA; i. clarify. + inv NR. destruct (Pos.eqb_spec xid id). + { subst id. hexploit alloc_variables_wf_id. eauto. auto. eauto. apply PTree.gss. + i. rewrite GET in H0. clarify. eapply Mem.fresh_block_alloc; eauto. } + hexploit IHEA. auto. rewrite PTree.gso. eapply NOT. auto. eapply GET. i. + ii. apply H0. unfold Mem.valid_block in *. erewrite Mem.nextblock_alloc; eauto. + etransitivity. eapply H1. apply Plt_succ. + Qed. + + Lemma assign_loc_outside_mem_inject + ge cp ty m b ofs bf v m' + (AL: assign_loc ge cp ty m b ofs bf v m') + k m0 + (INJ: Mem.inject k m0 m) + (NIB: k b = None) + (MS: meminj_same_block k) + : + Mem.inject k m0 m'. + Proof. + inv AL. + - eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H1). clarify. + - eapply Mem.storebytes_outside_inject; eauto. i. specialize (MS _ _ _ H5). clarify. + - inv H. eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H). clarify. + Qed. + + Lemma bind_parameters_outside_mem_inject + ge cp e m_cur params vargs m_next + (BIND: bind_parameters ge cp e m_cur params vargs m_next) + k m + (INJ: Mem.inject k m m_cur) + (NIB: forall id b t, e ! id = Some (b, t) -> k b = None) + (MS: meminj_same_block k) + (* (NIB: not_inj_blks k (blocks_of_env2 ge e)) *) + : + Mem.inject k m m_next. + Proof. + revert_until BIND. induction BIND; ii. + { auto. } + apply IHBIND; auto. clear IHBIND. specialize (NIB _ _ _ H). + eapply assign_loc_outside_mem_inject; eauto. + Qed. + + Lemma not_inj_blks_get_env + k ge e + (NIB: not_inj_blks k (blocks_of_env2 ge e)) + : + forall id b t, e ! id = Some (b, t) -> k b = None. + Proof. + rr in NIB. unfold blocks_of_env2, blocks_of_env in NIB. rewrite map_map in NIB. + rewrite Forall_forall in NIB. i. apply PTree.elements_correct in H. + apply NIB. eapply (in_map (fun x : ident * (block * type) => fst (fst (block_of_binding ge x)))) in H. ss. + Qed. + + Lemma not_global_blks_get_env + (ge: genv) e + (NIB: not_global_blks ge (blocks_of_env2 ge e)) + : + forall id b t, e ! id = Some (b, t) -> (meminj_public ge) b = None. + Proof. eapply not_inj_blks_get_env. eapply not_global_is_not_inj_bloks. eauto. Qed. + + Lemma meminj_public_same_block + ge + : + meminj_same_block (meminj_public ge). + Proof. rr. unfold meminj_public. i. des_ifs. Qed. + + Lemma alloc_variables_mem_inject + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + k m0 + (INJ: Mem.inject k m0 m) + : + Mem.inject k m0 m'. + Proof. + revert_until EA. induction EA; ii. auto. + apply IHEA. clear IHEA. eapply Mem.alloc_right_inject; eauto. + Qed. + + Lemma mem_valid_access_wunchanged_on + m ch b ofs p cp + (MV: Mem.valid_access m ch b ofs p cp) + P m' + (WU: wunchanged_on P m m') + (SAT: forall ofs', P b ofs') + : + Mem.valid_access m' ch b ofs p cp. + Proof. + unfold Mem.valid_access in *. des. splits; auto. + - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on; eauto. + - destruct cp. 2: ss. erewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block; eauto. + Qed. + + Lemma mem_free_list_wunchanged_on_2 + l m cp m' + (FREE: Mem.free_list m l cp = Some m') + : + wunchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. + Proof. + revert_until l. induction l; ii. + { ss. clarify. apply wunchanged_on_refl. } + ss. des_ifs. eapply wunchanged_on_trans; cycle 1. + { eapply wunchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } + ss. eapply free_wunchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. + Qed. + + Lemma not_global_blks_global_not_in + (ge: genv) id b + (FIND: Genv.find_symbol ge id = Some b) + e + (NGB: not_global_blks ge (blocks_of_env2 ge e)) + : + ~ In b (map (fun x : block * Z * Z => fst (fst x)) (blocks_of_env ge e)). + Proof. + intros CONTRA. unfold not_global_blks in NGB. unfold blocks_of_env2, blocks_of_env in *. + rewrite map_map in NGB, CONTRA. rewrite Forall_forall in NGB. specialize (NGB _ CONTRA). + apply Genv.find_invert_symbol in FIND. setoid_rewrite FIND in NGB. inv NGB. + Qed. + + Lemma mem_free_list_unchanged_on + l m cp m' + (FREE: Mem.free_list m l cp = Some m') + : + Mem.unchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. + Proof. + revert_until l. induction l; ii. + { ss. clarify. apply Mem.unchanged_on_refl. } + ss. des_ifs. eapply Mem.unchanged_on_trans; cycle 1. + { eapply Mem.unchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } + ss. eapply Mem.free_unchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. + Qed. + + Lemma exists_vargs_vres + (ge1: Senv.t) (ge2: genv) + (MS: match_symbs ge1 ge2) + ef m1 vargs tr vretv m2 + (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) + e cp le m_c + (WFE: wf_env ge2 e) + : + (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) + (list_typ_to_typelist (sig_args (ef_sig ef))) vargs) /\ + (external_call ef ge2 vargs m_c tr vretv m_c). + Proof. + pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. + unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). + - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. + esplits. + + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. + + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. + - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. + esplits. + + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. + econs. 3: econs. + { instantiate (1:=v). destruct v; ss; try (econs; fail). + - destruct chunk; ss; inv H2; ss. + - destruct Archi.ptr64 eqn:ARCH. + + destruct chunk; ss; inv H2; ss; des_ifs. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + + destruct chunk; ss; inv H2; ss; des_ifs. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + } + { rewrite EK1 in H2. + destruct v; ss. + - destruct chunk; ss; inv H2; ss. + - destruct chunk; ss. all: simpl_expr. inv H2. + - destruct chunk; ss. all: simpl_expr. + - destruct chunk; ss. inv H2. + - destruct chunk; ss. all: inv H2. + - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. + rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss; simpl_expr. + + unfold Cop.sem_cast. ss. rewrite Heq. auto. + + unfold Cop.sem_cast. ss. rewrite Heq. auto. + } + + econs. econs; auto. rewrite MS3; auto. rewrite EK1. + rewrite EK1 in H2. eapply match_symbs_eventval_match; eauto. + - esplits. + + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. + erewrite <- eventval_list_match_list_eventval_to_list_val. + 2:{ eapply match_senv_eventval_list_match in H; eauto. } + eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. + eapply match_senv_eventval_list_match; eauto. + + econs. eapply match_senv_eventval_list_match; eauto. + - esplits. + + econs. 3: econs. + * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. + eapply match_senv_eventval_match; eauto. + * erewrite eventval_match_val_to_eventval. 2: eapply H. + erewrite eventval_match_eventval_to_val. + 2:{ eapply match_senv_eventval_match; eauto. } + eapply eventval_match_sem_cast. eapply match_senv_eventval_match; eauto. + + econs. eapply match_senv_eventval_match; eauto. + Qed. + + Lemma eventval_list_match_eval_exprlist + (ge: genv) args targs vargs + (EMS: eventval_list_match ge args targs vargs) + e cp le m + (WF: wf_env ge e) + : + eval_exprlist ge e cp le m (list_eventval_to_list_expr args) + (list_eventval_to_typelist args) vargs. + Proof. + revert_until EMS. induction EMS; i; ss. econs. + econs; auto. + { clear dependent evl. clear tyl vl. inv H; try (simpl_expr; fail). + ss. eapply ptr_of_id_ofs_eval; auto. + } + { clear dependent evl. clear tyl vl. inv H; ss; try (simpl_expr; fail). + rewrite ptr_of_id_ofs_typeof. ss. + } + Qed. + + Lemma exists_vargs_vres_2 + (ge1: Senv.t) (ge2: genv) + (MS: match_symbs ge1 ge2) + ef m1 vargs tr vretv m2 + (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) + e cp le m_c + (WFE: wf_env ge2 e) + : + exists vargs2 vretv2, + (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) + (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs2) /\ + (external_call ef ge2 vargs2 m_c tr vretv2 m_c). + Proof. + pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. + unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). + - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. + esplits. + + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. + + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. + - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. + esplits. + + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. + econs. 3: econs. + { instantiate (1:=v). destruct v; ss; try (econs; fail). + - destruct chunk; ss; inv H2; ss. + - destruct Archi.ptr64 eqn:ARCH. + + destruct chunk; ss; inv H2; ss; des_ifs. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + + destruct chunk; ss; inv H2; ss; des_ifs. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + } + { instantiate (1:=Val.load_result chunk v). rewrite EK1 in H2. rewrite EK1. + destruct v; ss. + - destruct chunk; ss; inv H2; ss. + - destruct chunk; ss. all: simpl_expr. + - destruct chunk; ss. all: simpl_expr. + - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. + rewrite ptr_of_id_ofs_typeof. simpl_expr. + } + + econs. econs; auto. rewrite MS3; auto. rewrite EK1. eapply match_symbs_eventval_match; eauto. + - esplits. + + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. + eapply eventval_list_match_eval_exprlist; eauto. + eapply match_senv_eventval_list_match; eauto. + + econs. eapply match_senv_eventval_list_match; eauto. + - esplits. + + econs. 3: econs. + * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. + eapply match_senv_eventval_match; eauto. + * inv H; ss; try (simpl_expr; fail). apply MS2 in H1. setoid_rewrite H1. + rewrite ptr_of_id_ofs_typeof. ss. + + econs. eapply match_senv_eventval_match; eauto. + Qed. + + Lemma known_obs_preserves_mem + ef ge m vargs tr vretv m' + (EK: external_call_known_observables ef ge m vargs tr vretv m') + : + m' = m. + Proof. + unfold external_call_known_observables in EK. des_ifs; des; inv EK; clarify. inv H; clarify. + Qed. + + Lemma meminj_first_order_public_first_order + ge m + (MFO: meminj_first_order (meminj_public ge) m) + : + public_first_order ge m. + Proof. + ii. apply MFO; auto. unfold meminj_public. apply Senv.find_invert_symbol in FIND. + rewrite FIND. rewrite PUBLIC. ss. + Qed. + + Lemma vals_public_eval_to_vargs + (ge: genv) ef vargs + (VP: vals_public ge (sig_args (ef_sig ef)) vargs) + e cp le m + (WFE: wf_env ge e) + : + eval_exprlist ge e cp le m + (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) + (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. + Proof. + induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. + - clear dependent l. clear dependent l'. + inv H; ss; try (simpl_expr; fail). + destruct H0 as (id & BP1 & BP2). + unfold senv_invert_symbol_total. rewrite BP1. + apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. + - clear dependent l. clear dependent l'. + inv H; ss; try (simpl_expr; fail). + destruct H0 as (id & BP1 & BP2). + unfold senv_invert_symbol_total. rewrite BP1. + rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss. + + unfold Cop.sem_cast. ss. rewrite Heq. ss. + + unfold Cop.sem_cast. ss. rewrite Heq. ss. + Qed. + + Lemma vals_public_eval_to_vargs_2 + (ge: genv) ef vargs + (VP: vals_public ge (sig_args (ef_sig ef)) vargs) + e cp le m + (WFE: wf_env ge e) + : + eval_exprlist ge e cp le m + (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) + (list_eventval_to_typelist (vals_to_eventvals ge vargs)) vargs. + Proof. + induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. + - clear dependent l. clear dependent l'. + inv H; ss; try (simpl_expr; fail). + destruct H0 as (id & BP1 & BP2). + unfold senv_invert_symbol_total. rewrite BP1. + apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. + - clear dependent l. clear dependent l'. + inv H; ss; try (simpl_expr; fail). + destruct H0 as (id & BP1 & BP2). + unfold senv_invert_symbol_total. rewrite BP1. + rewrite ptr_of_id_ofs_typeof. ss. + Qed. + + Lemma match_symbs_block_public + ge1 ge2 + (MS: match_symbs ge1 ge2) + b + (BP: block_public ge1 b) + : + block_public ge2 b. + Proof. + destruct MS as (MS1 & MS2 & MS3). destruct BP as (id & BP1 & BP2). + apply Senv.invert_find_symbol in BP1. apply MS2 in BP1. rewrite <- MS1 in BP2. + unfold block_public. esplits; eauto. apply Senv.find_invert_symbol; auto. + Qed. + + Lemma match_symbs_vals_public + ge1 ge2 + (MS: match_symbs ge1 ge2) + tys vargs + (VP: vals_public ge1 tys vargs) + : + vals_public ge2 tys vargs. + Proof. + induction VP; ss. econs; auto. clear VP IHVP. inv H; econs; auto. + eapply match_symbs_block_public; eauto. + Qed. + + Lemma match_symbs_vals_public_vals_to_eventvals + ge1 ge2 + (MS: match_symbs ge1 ge2) + tys vargs + (VP: vals_public ge1 tys vargs) + : + vals_to_eventvals ge1 vargs = vals_to_eventvals ge2 vargs. + Proof. + induction VP; ss. f_equal; auto. clear dependent l. clear dependent l'. + inv H; ss. destruct H0 as (id & BP1 & BP2). + unfold senv_invert_symbol_total at 1. des_ifs. + destruct MS as (MS0 & MS1 & MS2). + apply Senv.invert_find_symbol in Heq. apply MS1 in Heq. + unfold senv_invert_symbol_total at 1. apply Senv.find_invert_symbol in Heq. + rewrite Heq. auto. + Qed. + + Lemma match_symbs_vals_public_eval_to_vargs + ge1 (ge2: genv) + (MS: match_symbs ge1 ge2) + ef vargs + (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) + e cp le m + (WFE: wf_env ge2 e) + : + eval_exprlist ge2 e cp le m + (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) + (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. + Proof. + erewrite match_symbs_vals_public_vals_to_eventvals; eauto. + eapply vals_public_eval_to_vargs; auto. eapply match_symbs_vals_public; eauto. + Qed. + + Lemma match_symbs_vals_public_eval_to_vargs_2 + ge1 (ge2: genv) + (MS: match_symbs ge1 ge2) + ef vargs + (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) + e cp le m + (WFE: wf_env ge2 e) + : + eval_exprlist ge2 e cp le m + (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) + (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs. + Proof. + erewrite match_symbs_vals_public_vals_to_eventvals; eauto. + eapply vals_public_eval_to_vargs_2; auto. eapply match_symbs_vals_public; eauto. + Qed. + + Lemma extcall_unkowns_vals_public + ef ge m vargs + (EC: external_call_unknowns ef ge m vargs) + : + vals_public ge (sig_args (ef_sig ef)) vargs. + Proof. + unfold external_call_unknowns in EC. des_ifs; ss; auto. + all: destruct EC as (EC1 & EC2); auto. + Qed. + + + Lemma mem_unchanged_wunchanged + P m m' + (UCH: Mem.unchanged_on P m m') + : + wunchanged_on P m m'. + Proof. inv UCH. econs; eauto. Qed. + + Lemma meminj_public_not_public_not_mapped + ge cnt_cur + (NP: Senv.public_symbol ge cnt_cur = false) + cnt_cur_b + (FIND: Senv.find_symbol ge cnt_cur = Some cnt_cur_b) + : + forall b ofs, meminj_public ge b <> Some (cnt_cur_b, ofs). + Proof. + ii. unfold meminj_public in H. des_ifs. + assert (i = cnt_cur). + { eapply Senv.find_symbol_injective; eauto. apply Senv.invert_find_symbol; auto. } + subst i. rewrite NP in Heq0. ss. + Qed. + + + Lemma wunchanged_on_exists_mem_free_gen + m1 b lo hi cp m2 + (FREE: Mem.free m1 b lo hi cp = Some m2) + (P: block -> Prop) m_c + (WCH: wunchanged_on (fun b _ => P b) m1 m_c) + (NGB: P b) + : + exists m_c', Mem.free m_c b lo hi cp = Some m_c'. + Proof. + hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. + hexploit Mem.range_perm_free. + 3:{ intros (m0 & F). eexists; eapply F. } + - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. + - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. + Qed. + + Lemma wunchanged_on_exists_mem_free_2 + m1 b lo hi cp m2 + (FREE: Mem.free m1 b lo hi cp = Some m2) + ge m_c + (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) + (NGB: Senv.invert_symbol ge b = None) + : + exists m_c', Mem.free m_c b lo hi cp = Some m_c'. + Proof. eapply wunchanged_on_exists_mem_free_gen; eauto. eapply WCH. ss. Qed. + + Lemma wunchanged_on_free_preserves_gen + P m m' + (WU : wunchanged_on P m m') + b lo hi cp m1 m1' + (FREE: Mem.free m b lo hi cp = Some m1) + (FREE': Mem.free m' b lo hi cp = Some m1') + : + wunchanged_on P m1 m1'. + Proof. + inv WU. econs. + - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. + - i. assert (VB: Mem.valid_block m b0). + { eapply Mem.valid_block_free_2; eauto. } + split; i. + + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. + eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. + hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. + + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. + eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. + hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. + - i. assert (VB: Mem.valid_block m b0). + { eapply Mem.valid_block_free_2; eauto. } + split; i. + + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. + eapply Mem.free_can_access_block_inj_2; eauto. + + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. + eapply Mem.free_can_access_block_inj_2; eauto. + Qed. + + Lemma wunchanged_on_exists_mem_free_list_gen + l m1 cp m2 + (FREE: Mem.free_list m1 l cp = Some m2) + (P: block -> Prop) m_c + (WCH: wunchanged_on (fun b _ => P b) m1 m_c) + (NGB: Forall P (map (fun x => fst (fst x)) l)) + : + exists m_c', Mem.free_list m_c l cp = Some m_c'. + Proof. + revert_until l. induction l; i; ss. eauto. + destruct a as ((b & lo) & hi). ss. inv NGB. des_ifs; ss. + 2:{ exfalso. hexploit wunchanged_on_exists_mem_free_gen. 2: eapply WCH. all: eauto. + intros. des. rewrite H in Heq; clarify. + } + hexploit IHl. eapply FREE. 2: eapply H2. + { instantiate (1:=m). eapply wunchanged_on_free_preserves_gen; eauto. } + eauto. + Qed. + + Lemma wunchanged_on_exists_mem_free_list_2 + l m1 cp m2 + (FREE: Mem.free_list m1 l cp = Some m2) + ge m_c + (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) + (NGB: not_global_blks ge (map (fun x => fst (fst x)) l)) + : + exists m_c', Mem.free_list m_c l cp = Some m_c'. + Proof. eapply wunchanged_on_exists_mem_free_list_gen; eauto. ss. Qed. + + Lemma wunchanged_on_free_list_preserves_gen + P m m' + (WU: wunchanged_on P m m') + l cp m_f m_f' + (FREE: Mem.free_list m l cp = Some m_f) + (FREE': Mem.free_list m' l cp = Some m_f') + : + wunchanged_on P m_f m_f'. + Proof. + move l after m. revert_until l. induction l; ii; ss. clarify. + des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves_gen; eauto. + Qed. + + Lemma meminj_not_alloc_external_call + j m1 + (NA: meminj_not_alloc j m1) + ef ge vargs tr vretv m2 + (EC: external_call ef ge vargs m1 tr vretv m2) + : + meminj_not_alloc j m2. + Proof. + unfold meminj_not_alloc in *. i. apply NA. clear NA. + eapply external_call_nextblock in EC. etransitivity. 2: eapply H. auto. + Qed. + + Lemma public_first_order_meminj_first_order + (ge: Senv.t) m + (FO: public_first_order ge m) + : + meminj_first_order (meminj_public ge) m. + Proof. + ii. unfold meminj_public in H. des_ifs. eapply FO; eauto. + apply Senv.invert_find_symbol; auto. + Qed. + + Lemma list_length_filter_le + A P (l: list A) + : + (Datatypes.length (filter P l) <= Datatypes.length l)%nat. + Proof. + induction l; ss. des_ifs; ss; auto. rewrite <- Nat.succ_le_mono. auto. + Qed. + +End PROOF. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 0cde5a8833..25cff665ca 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -824,7 +824,7 @@ Section INVS. end. Definition match_cur_regset (cur: block) (ge: Asm.genv) (rs: regset) := - Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = Genv.find_comp_in_genv ge (rs PC). + Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) ⊆ Genv.find_comp_in_genv ge (rs PC). Inductive match_stack (ge: Asm.genv): ir_conts -> stack -> Prop := | match_stack_nil @@ -1072,13 +1072,12 @@ Section PROOF. exploit NALLOC; eauto. intros. clarify. } exfalso. apply PERM. - admit. - (* 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. } *) + eapply (ec_public_not_freeable (external_call_spec ef cp)); 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. @@ -1086,7 +1085,7 @@ Section PROOF. { eapply public_rev_perm_delta_apply_inj; eauto. } clear - ECC MEMINJ' PRP. eapply external_call_unknowns_mem_inj; eauto. } - Admitted. + Qed. Lemma asm_to_ir_returnstate_nccc_internal @@ -1140,26 +1139,25 @@ Section PROOF. { simpl. split. - unfold Genv.type_of_call in NCCC. unfold update_stack_return in STUPD. - admit. - (* destruct (flowsto_dec); try congruence. *) - (* rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. *) + destruct flowsto_dec; try congruence. - 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)). + { 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. - admit. } - (* rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) + destruct flowsto_dec; try congruence. } subst st'. simpl. split; auto. split; auto. split; auto. split. { unfold match_cur_regset in *. - admit. } - (* rewrite CURCOMP. unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. auto. } *) + unfold Genv.type_of_call in NCCC. + unfold update_stack_return in STUPD. + des_ifs. } split; auto. { unfold match_mem. splits; auto. } } intros (btr & ist' & UTR & ISTAR'). exists btr, ist'. split; auto. - Admitted. + Qed. Lemma match_mem_external_call_establish2 ge cp k d m_a0 m_i m @@ -1261,6 +1259,7 @@ Section PROOF. admit. (* ?? *) eauto. (* previous script *)(* eapply ECC. eauto. clear ECC. *) + intros [ECU | [ECKO | ECKS]]. - (* extcall is unknown *) @@ -1401,7 +1400,6 @@ Section PROOF. { destruct ECKS as [_ OBS]. inv EXTCALL. exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. } - Admitted. Lemma asm_to_ir_builtin @@ -1630,8 +1628,7 @@ Section PROOF. assert (st' = st). { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. - admit. } - (* rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) + destruct flowsto_dec; try congruence. } subst st'. exploit asm_to_ir_step_external. 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. @@ -1655,14 +1652,8 @@ Section PROOF. (* 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 *. - admit. - (* 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. *) - } + { unfold Genv.type_of_call in H. des_ifs. + exfalso; apply n0; auto with comps. } } (* stuck case *) inv H; simpl in *; rewrite Pregmap.gss in *; rewrite STUCK in H6; inv H6. @@ -1859,13 +1850,16 @@ Section PROOF. assert (st' = st). { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. - admit. } - (* rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) + des_ifs. } subst st'. exploit asm_to_ir_step_external. 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. all: eauto. - admit. + { des_ifs. rewrite NEXTPC in f. rewrite NEXTPC. + simpl in *. + eapply Genv.find_funct_ptr_find_comp_of_block with (fd := External ef) in NEXTF; eauto. + rewrite NEXTF in f. setoid_rewrite NEXTF. + destruct (Genv.find_comp_of_block ge cur); try inv f; auto. } { rr; splits; eauto. } clear STEP STAR. intros (btr1 & k' & d' & m_a0' & m_i' & m_a' & UTR1 & ISTAR1 & MM' & (res & STAR)). @@ -1876,9 +1870,15 @@ Section PROOF. { 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. admit. + all: eauto. lia. + { des_ifs. + rewrite NEXTPC in f. simpl in f. + eapply Genv.find_funct_ptr_find_comp_of_block with (fd := External ef) in NEXTF; eauto. + rewrite NEXTF in f. simpl in f. + simpl. + destruct (Genv.find_comp_of_block ge cur); try inv f; auto. } { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } - Admitted. + Qed. Lemma asm_to_ir_returnstate (ge: genv) cur_comp n n0 @@ -1982,8 +1982,9 @@ Section PROOF. destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). exploit mem_delta_exec_instr. eapply MEM3. eapply H3. { replace (comp_of f) with (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)). eapply MEM4. - rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp_in_genv. admit. } + (* rewrite MTST1. rewrite H0. ss. *) + (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. reflexivity. } *) eapply MEM5. auto. intros (d' & MEM4' & MEM5'). destruct f0. @@ -1994,20 +1995,18 @@ Section PROOF. } assert (MTST': match_state ge k m_a0 d' (State st rs' m' cur_comp) (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_in_genv. rewrite H0. - admit. - (* unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. *) - (* rewrite H1. auto. *) - } + { unfold match_cur_regset in *. rewrite NEXTPC. rewrite <- ALLOWED. + admit. } + (* rewrite MTST1. *) + (* unfold Genv.find_comp_in_genv. rewrite H0. ss. *) + (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. reflexivity. } *) 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_in_genv ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. - rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp_in_genv. - admit. - (* setoid_rewrite H1. auto. *) - } + admit. } + (* rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp_in_genv. *) + (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. reflexivity. } *) eapply public_rev_perm_exec_instr. 3: eapply H3. all: auto. } } @@ -2025,18 +2024,16 @@ Section PROOF. 1,2,3,4: rewrite NEXTPC in H9; inv H9; rewrite NEXTF in H10; inv H10. (* rewrite <- REC_CURCOMP. *) (* rewrite H9. *) - rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H9; inv H9. - admit. - (* rewrite <- ALLOWED. *) - (* unfold Genv.find_comp. setoid_rewrite H1. auto. *) - } + admit. } + (* rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H9; inv H9. *) + (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. *) + (* admit. } *) { 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_in_genv ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. - rewrite MTST1. rewrite H0. ss. - admit. - (* unfold Genv.find_comp. setoid_rewrite H1. auto. *) - } + admit. } + (* rewrite MTST1. rewrite H0. ss. *) + (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. reflexivity. } *) eapply public_rev_perm_exec_instr; eauto. } intros (btr' & k' & d'0 & m_a0' & m_i' & m_a' & UTR' & ISTAR' & MM' & (res' & STAR')). @@ -2052,11 +2049,10 @@ Section PROOF. 1,2,3,4: rewrite NEXTPC in H9; inv H9; rewrite NEXTF in H10; inv H10. (* rewrite <- REC_CURCOMP. *) (* rewrite H9. *) - rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H9; inv H9. - (* rewrite <- ALLOWED. *) - admit. - (* unfold Genv.find_comp. setoid_rewrite H1. auto. *) - } + admit. } + (* rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H9; inv H9. *) + (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. *) + (* simpl; rewrite ALLOWED. admit. } *) { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } } Admitted. @@ -2448,7 +2444,7 @@ Section INIT. - 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. + unfold Genv.symbol_address. subst ge0. rewrite H0. ss. auto with comps. - econs. - unfold match_mem. assert (MNA: meminj_not_alloc (meminj_public (Genv.globalenv p)) m0). diff --git a/security/BtInfoAsmBound.v b/security/BtInfoAsmBound.v index 12b2327213..bdbf03dd1a 100644 --- a/security/BtInfoAsmBound.v +++ b/security/BtInfoAsmBound.v @@ -13,70 +13,70 @@ 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. *) +Section AXIOM. + + Definition extcall_observable (sem: extcall_sem) (cp: compartment) (sg: signature): Prop := + forall ge vargs m1 t vres m2, + sem ge cp vargs m1 t vres m2 -> t <> E0. + + Definition external_functions_observable := + forall id cp sg, extcall_observable (external_functions_sem id sg) cp sg. + + Definition inline_assembly_observable := + forall cp id sg, extcall_observable (inline_assembly_sem id sg) cp 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 cp vargs m1 tr vretv m2 + (EC: external_call ef ge cp vargs m1 tr vretv m2) + (ECCASES : external_call_unknowns ef ge m1 vargs \/ + external_call_known_observables ef ge cp m1 vargs tr vretv m2) + : + (1 <= length tr)%nat. + Proof. + des. + - unfold external_functions_observable in EFO. unfold extcall_observable in EFO. + unfold inline_assembly_observable in IAO. unfold extcall_observable in IAO. + cut (tr <> E0). + { i. destruct tr; ss. lia. } + destruct ef; ss; eauto. + + unfold builtin_or_external_sem in EC. des_ifs; ss; eauto. + + unfold builtin_or_external_sem in EC. des_ifs; ss; eauto. + - destruct ef; ss; des; clarify; try (inv EC; ss). + + destruct tr; ss. lia. + + destruct tr; ss. lia. + Qed. + + Lemma bundle_trace_bounded + ge ist ist' btr + (ISTAR: istar (ir_step) ge ist btr ist') + : + (length btr <= length (unbundle_trace btr))%nat. + Proof. + induction ISTAR. ss. subst. ss. + apply Nat.succ_le_mono in IHISTAR. etransitivity. eauto. clear IHISTAR. + rewrite app_length. cut (1 <= length (unbundle ev))%nat. lia. + unfold unbundle. + inv H; ss. + - inv TR; ss. + - inv TR; ss. + - eapply external_call_observable_length; eauto. des; auto. + - eapply external_call_observable_length; eauto. des; auto. + (* - inv TR; ss. *) + (* - inv TR1; ss. lia. *) + (* - inv TR1; ss. lia. *) + Qed. + +End BOUND. diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index bf8f8760a5..85c3d3b8a2 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -336,7 +336,9 @@ Section WFDELTA. 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) && (cp_eq_dec cp0 cp) + | Some id => (Senv.public_symbol ge id) && + (wf_chunk_val_b ch v) && + cp_eq_dec cp0 cp | _ => false end | _ => false From 184f10df631d4aa589f8bfe9e573a932b9005845 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Tue, 23 Jan 2024 11:57:33 +0100 Subject: [PATCH 75/83] [Backtranslation] Progress integrating backtranslation proof --- security/Backtranslation.v | 42 ++++++------ security/BacktranslationAux.v | 68 ++++++++++--------- security/BtInfoAsm.v | 24 +++---- security/MemoryDelta.v | 121 ++++++++++++++++++---------------- 4 files changed, 136 insertions(+), 119 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 5efa1b1d77..ea68ea0e48 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -403,7 +403,7 @@ Section CODE. Variable ge: Senv.t. - Definition code_mem_delta_storev cp0 (d: mem_delta_storev): statement := + Definition code_mem_delta_storev (d: mem_delta_storev): statement := let '(ch, ptr, v, cp) := d in match ptr with | Vptr b ofs => @@ -411,7 +411,7 @@ Section CODE. | 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) && (flowsto_dec cp cp0)) (* TODO: check direction *) + if (Senv.public_symbol ge id) (* TODO: check direction *) then Sassign (Ederef (expr_of_addr id ofs) ty) ve else Sskip | _, _ => Sskip @@ -421,40 +421,40 @@ Section CODE. | _ => Sskip end. - Definition code_mem_delta_kind cp (d: mem_delta_kind): statement := + Definition code_mem_delta_kind (d: mem_delta_kind): statement := match d with - | mem_delta_kind_storev dd => code_mem_delta_storev cp dd + | mem_delta_kind_storev dd => code_mem_delta_storev 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_mem_delta (d: mem_delta) (snext: statement): statement := + fold_right Ssequence snext (map (code_mem_delta_kind) d). - Definition code_bundle_call cp (tr: trace) (id: ident) (evargs: list eventval) (sg: signature) (d: mem_delta): statement := + Definition code_bundle_call (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)). + code_mem_delta 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_return (tr: trace) (evr: eventval) (d: mem_delta): statement := + code_mem_delta 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_builtin (tr: trace) (ef: external_function) (evargs: list eventval) (d: mem_delta): statement := + code_mem_delta d (Sbuiltin None ef (list_eventval_to_typelist evargs) (list_eventval_to_list_expr evargs)). - Definition code_bundle_event cp (be: bundle_event): statement := + Definition code_bundle_event (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 + | Bundle_call tr id evargs sg d => code_bundle_call tr id evargs sg d + | Bundle_return tr evr d => code_bundle_return tr evr d + | Bundle_builtin tr ef evargs d => code_bundle_builtin 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). + Definition switch_bundle_events cnt (tr: bundle_trace) := + switch cnt (map (fun ib => code_bundle_event (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). + Definition code_bundle_trace (cnt: ident) (tr: bundle_trace): statement := + Swhile one_expr (switch_bundle_events cnt tr). End CODE. @@ -473,7 +473,7 @@ Section GEN. params [] [] - (code_bundle_trace ge cp cnt tr). + (code_bundle_trace ge cnt tr). Definition gen_fundef (ge: Senv.t) (cnt: ident) params (tr: bundle_trace) (a_fd: Asm.fundef): Clight.fundef := match a_fd with diff --git a/security/BacktranslationAux.v b/security/BacktranslationAux.v index 657ccce208..c9a7c9d28b 100644 --- a/security/BacktranslationAux.v +++ b/security/BacktranslationAux.v @@ -35,16 +35,16 @@ Section CODEPROOFS. Qed. Lemma code_mem_delta_cons - (ge: Senv.t) cp k d sn + (ge: Senv.t) 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). + code_mem_delta ge (k :: d) sn = + Ssequence (code_mem_delta_kind ge k) (code_mem_delta ge d sn). Proof. unfold code_mem_delta. ss. Qed. Lemma code_mem_delta_app - (ge: Senv.t) cp d1 d2 sn + (ge: Senv.t) d1 d2 sn : - code_mem_delta ge cp (d1 ++ d2) sn = (code_mem_delta ge cp d1 (code_mem_delta ge cp d2 sn)). + code_mem_delta ge (d1 ++ d2) sn = (code_mem_delta ge d1 (code_mem_delta ge d2 sn)). Proof. revert sn d2. induction d1; intros; ss. rewrite ! code_mem_delta_cons. erewrite IHd1. auto. @@ -118,9 +118,9 @@ Section CODEPROOFS. 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) + (WF: wf_mem_delta_storev_b ge d) : - step1 ge (State f (code_mem_delta_storev ge (comp_of f) d) k e le m) + step1 ge (State f (code_mem_delta_storev ge 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. @@ -143,30 +143,30 @@ Section CODEPROOFS. + unfold Cop.sem_cast. ss. des_ifs. - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. rewrite <- STORE. - destruct flowsto_dec; try inv WF. - apply andb_prop in Heq0 as [_ G]. - destruct flowsto_dec; try inv G. - exploit flowsto_antisym; eauto. intros ?; subst. - 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. - - apply andb_false_iff in Heq0 as [G | G]; try now inv G. - destruct cp_eq_dec; inv WF. - exfalso. pose proof (flowsto_refl (comp_of f)). now destruct flowsto_dec. } - { assert (G: flowsto_dec c (comp_of f)). - { destruct cp_eq_dec; inv WF. - pose proof (flowsto_refl (comp_of f)). now destruct flowsto_dec. } - rewrite G, H0. ss. eapply step_assign. + admit. + (* 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. *) + } + (* - apply andb_false_iff in Heq0 as [G | G]; try now inv G. *) + (* destruct cp_eq_dec; inv WF. *) + (* exfalso. pose proof (flowsto_refl (comp_of f)). now destruct flowsto_dec. } *) + { + (* assert (G: flowsto_dec c (comp_of f)). *) + (* { destruct cp_eq_dec; inv WF. *) + (* pose proof (flowsto_refl (comp_of f)). now destruct flowsto_dec. } *) + 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. right; auto. - 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. - destruct cp_eq_dec; inv WF. clarify. + admit. + (* destruct cp_eq_dec; inv WF. clarify. *) } - Qed. + Admitted. Lemma wf_mem_delta_storev_false_is_skip (ge: Senv.t) cp d @@ -174,10 +174,8 @@ Section CODEPROOFS. : code_mem_delta_storev ge cp d = Sskip. Proof. destruct d as [[[ch ptr] v] cp0]. ss. des_ifs. - apply andb_prop in Heq2 as [WF1 WF2]. - apply andb_false_iff in NWF as [NWF | NWF]; try congruence. admit. - destruct cp_eq_dec; inv NWF - Qed. + admit. + Admitted. Lemma code_mem_delta_correct (ge: genv) @@ -311,10 +309,16 @@ Section GENV. 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. + - 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. + { unfold chunk_val_to_expr. rewrite CHTY. + des_ifs. + - admit. + - congruence. + (* 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. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 25cff665ca..731a27c452 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -233,7 +233,7 @@ Section IR. (SIG: sg = Asm.fn_sig f_next) (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) d m2 - (DELTA: mem_delta_apply_wf ge cp d (Some m1) = Some m2) + (DELTA: mem_delta_apply_wf ge d (Some m1) = Some m2) (PUB: public_first_order ge m2) id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) @@ -256,7 +256,7 @@ Section IR. (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) + (DELTA: mem_delta_apply_wf ge d (Some m1) = Some m2) (PUB: public_first_order ge m2) id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) @@ -272,7 +272,7 @@ Section IR. (FINDF: Genv.find_funct ge (Vptr b_ext Ptrofs.zero) = Some (AST.External ef)) (SIG: sg = ef_sig ef) d m1' - (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') + (MEM: mem_delta_apply_wf ge d (Some m1) = Some m1') vargs vretv (EC: external_call ef ge cp_cur vargs m1' tr vretv m2) (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ @@ -288,7 +288,7 @@ Section IR. cp_cur (CURCP: cp_cur = Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) d m1' - (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') + (MEM: mem_delta_apply_wf ge d (Some m1) = Some m1') vargs vretv (EC: external_call ef ge cp_cur vargs m1' tr vretv m2) (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ @@ -727,11 +727,11 @@ Section FROMASM. (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) + (DELTA0: mem_delta_inj_wf ge (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'). + exists d', (mem_delta_inj_wf ge (meminj_public ge) d') /\ (mem_delta_apply d' (Some m0) = Some m'). Proof. destruct i; simpl in EXEC. all: try (inv EXEC; eauto). @@ -745,6 +745,8 @@ Section FROMASM. 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) ]). + all: try (match goal with + | |- _ /\ _ => admit end). { 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)])) @@ -767,7 +769,7 @@ Section FROMASM. } { apply Mem.free_result in Heqo0. unfold Mem.unchecked_free in Heqo0. unfold zle in Heqo0. des_ifs. eexists; eauto. } } - Qed. + Admitted. End FROMASM. @@ -951,9 +953,9 @@ Section PROOF. Qed. Lemma public_rev_perm_delta_apply_inj - d ge m m_i m_i' cp + d ge m m_i m_i' (PRP: public_rev_perm ge m m_i) - (APPD: mem_delta_apply_wf ge cp d (Some m_i) = Some m_i') + (APPD: mem_delta_apply_wf ge d (Some m_i) = Some m_i') : public_rev_perm ge m m_i'. Proof. @@ -1026,7 +1028,7 @@ Section PROOF. (ECC: external_call_unknowns ef ge m args) : exists m1 m2 res', - (mem_delta_apply_wf ge cp d (Some m_i) = Some m1) /\ + (mem_delta_apply_wf ge d (Some m_i) = Some m1) /\ (external_call ef ge cp args m1 t res' m2) /\ (external_call_unknowns ef ge m1 args) /\ (exists k2, match_mem ge cp k2 [] m' m2 m' /\ Val.inject k2 res res') @@ -1200,7 +1202,7 @@ Section PROOF. (ECC: external_call_unknowns ef ge m args \/ external_call_known_observables ef ge cp m args t res m') : exists d' m1 m2 res', - (mem_delta_apply_wf ge cp d' (Some m_i) = Some m1) /\ + (mem_delta_apply_wf ge d' (Some m_i) = Some m1) /\ (external_call ef ge cp args m1 t res' m2) /\ ((external_call_unknowns ef ge m1 args) \/ (external_call_known_observables ef ge cp m1 args t res' m2 /\ d' = [])) /\ (exists k2 d2 m_a02, match_mem ge cp k2 d2 m_a02 m2 m' /\ (Val.inject k2 res res' \/ (res = res'))) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index 85c3d3b8a2..a0dac02973 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -297,6 +297,8 @@ End MEMDELTA. Section WFDELTA. (** only wf delta is applied for back transltation *) + Context {F V: Type} {CF: has_comp F}. + (* Refer to encode_val *) Definition wf_chunk_val_b (ch: memory_chunk) (v: val) := match v with @@ -332,64 +334,66 @@ Section WFDELTA. | Vptr _ _ => false end. - Definition wf_mem_delta_storev_b (ge: Senv.t) (cp0: compartment) (d: mem_delta_storev) := + Definition wf_mem_delta_storev_b (ge: Genv.t F V) (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) && - cp_eq_dec cp0 cp + (flowsto_dec (Genv.find_comp_in_genv ge v) (Genv.find_comp_of_ident ge id)) && + (flowsto_dec (Genv.find_comp_of_ident ge id) 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 wf_mem_delta_kind_b (ge: Genv.t F V) (d: mem_delta_kind) := + match d with | mem_delta_kind_storev dd => wf_mem_delta_storev_b ge dd | _ => false end. - Definition get_wf_mem_delta (ge: Senv.t) cp0 (d: mem_delta): mem_delta := - filter (wf_mem_delta_kind_b ge cp0) d. + Definition get_wf_mem_delta (ge: Genv.t F V) (d: mem_delta): mem_delta := + filter (wf_mem_delta_kind_b ge) d. Lemma get_wf_mem_delta_cons - ge cp0 d k + ge d k : - get_wf_mem_delta ge cp0 (k :: d) = - if (wf_mem_delta_kind_b ge cp0 k) then k :: (get_wf_mem_delta ge cp0 d) else (get_wf_mem_delta ge cp0 d). + get_wf_mem_delta ge (k :: d) = + if (wf_mem_delta_kind_b ge k) then k :: (get_wf_mem_delta ge d) else (get_wf_mem_delta ge d). Proof. ss. Qed. + Lemma get_wf_mem_delta_app - ge cp0 d0 d1 + ge d0 d1 : - get_wf_mem_delta ge cp0 (d0 ++ d1) = (get_wf_mem_delta ge cp0 d0) ++ (get_wf_mem_delta ge cp0 d1). + get_wf_mem_delta ge (d0 ++ d1) = (get_wf_mem_delta ge d0) ++ (get_wf_mem_delta ge d1). Proof. apply filter_app. Qed. - Definition mem_delta_apply_wf ge cp0 (d: mem_delta) (om0: option mem): option mem := - mem_delta_apply (get_wf_mem_delta ge cp0 d) om0. + Definition mem_delta_apply_wf ge (d: mem_delta) (om0: option mem): option mem := + mem_delta_apply (get_wf_mem_delta ge d) om0. Lemma mem_delta_apply_wf_cons - ge cp0 d m0 k + ge d m0 k : - mem_delta_apply_wf ge cp0 (k :: d) m0 = - if (wf_mem_delta_kind_b ge cp0 k) then mem_delta_apply_wf ge cp0 d (mem_delta_apply_kind k m0) else mem_delta_apply_wf ge cp0 d m0. + mem_delta_apply_wf ge (k :: d) m0 = + if (wf_mem_delta_kind_b ge k) then mem_delta_apply_wf ge d (mem_delta_apply_kind k m0) else mem_delta_apply_wf ge d m0. Proof. unfold mem_delta_apply_wf at 1. rewrite get_wf_mem_delta_cons. des_ifs. Qed. Lemma mem_delta_apply_wf_app - ge cp0 d0 d1 m0 + ge d0 d1 m0 : - mem_delta_apply_wf ge cp0 (d0 ++ d1) m0 = - mem_delta_apply_wf ge cp0 d1 (mem_delta_apply_wf ge cp0 d0 m0). + mem_delta_apply_wf ge (d0 ++ d1) m0 = + mem_delta_apply_wf ge d1 (mem_delta_apply_wf ge 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 + ge d : - mem_delta_apply_wf ge cp0 d None = None. + mem_delta_apply_wf ge d None = None. Proof. unfold mem_delta_apply_wf. apply mem_delta_apply_none. Qed. Lemma mem_delta_apply_wf_some - ge cp0 d m0 m1 - (APPD: mem_delta_apply_wf ge cp0 d m0 = Some m1) + ge d m0 m1 + (APPD: mem_delta_apply_wf ge d m0 = Some m1) : exists m, m0 = Some m. Proof. unfold mem_delta_apply_wf in APPD. exploit mem_delta_apply_some; eauto. Qed. @@ -399,6 +403,8 @@ End WFDELTA. Section PROPS. + Context {F V: Type} {CF: has_comp F}. + (** Delta and location relations *) Let mcps := PTree.t compartment. @@ -534,10 +540,10 @@ Section PROPS. Qed. Lemma mem_delta_wf_unchanged_on - ge cp d m m' - (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') + (ge: Genv.t F V) d m m' + (APPD: mem_delta_apply_wf ge 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'. + Mem.unchanged_on (fun b ofs => mem_delta_unchanged (get_wf_mem_delta ge d) b ofs) m m'. Proof. eapply mem_delta_unchanged_on; eauto. Qed. Lemma get_from_setN_same_upto_ofs @@ -726,18 +732,21 @@ End PROPS. Section PROOFS. (** Props for proofs *) - Definition mem_delta_kind_inj_wf (cp0: compartment) (j: meminj): mem_delta_kind -> Prop := + Context {F V: Type} {CF: has_comp F}. + + Definition mem_delta_kind_inj_wf (ge: Genv.t F V) (j: meminj): mem_delta_kind -> Prop := fun data => match data with - | mem_delta_kind_storev (ch, ptr, v, cp) => cp = cp0 + | mem_delta_kind_storev (ch, ptr, v, cp) => (Genv.find_comp_in_genv ge v ⊆ Genv.find_comp_in_genv ge ptr) /\ + (Genv.find_comp_in_genv ge ptr ⊆ cp) | 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 mem_delta_inj_wf ge (j: meminj): mem_delta -> Prop := + fun d => Forall (fun data => mem_delta_kind_inj_wf ge j data) d. Section VISIBLE. @@ -881,20 +890,20 @@ End VISIBLE. Proof. induction FA; ss. des_ifs. econs; eauto. Qed. Lemma mem_delta_unchanged_implies_wf_unchanged - ge cp d b ofs + (ge: Genv.t F V) d b ofs (UNCHG: mem_delta_unchanged d b ofs) : - mem_delta_unchanged (get_wf_mem_delta ge cp d) b ofs. + mem_delta_unchanged (get_wf_mem_delta ge d) b ofs. Proof. eapply list_forall_filter; eauto. Qed. Lemma mem_delta_changed_only_by_storev - ge cp d b ofs - (WF: mem_delta_inj_wf cp (meminj_public ge) d) + (ge: Genv.t F V) d b ofs + (WF: mem_delta_inj_wf ge (meminj_public ge) d) (INJ: (meminj_public ge) b <> None) (CHG: mem_delta_changed d b ofs) m1 m1' m2 m2' (APPD1: mem_delta_apply d (Some m1) = Some m1') - (APPD2: mem_delta_apply_wf ge cp d (Some m2) = Some m2') + (APPD2: mem_delta_apply_wf ge 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) @@ -950,7 +959,7 @@ End VISIBLE. 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. + des. rename H into INV, H0 into PUB. simpl in INV, 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. } @@ -960,10 +969,9 @@ End VISIBLE. { 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. - destruct (cp_eq_dec cp cp); try contradiction. - ss. - (* rewrite Pos.eqb_refl in APPD2. *) - des_ifs. + unfold Genv.find_comp_of_ident in APPD2. + apply Genv.invert_find_symbol in INV. rewrite INV in APPD2. + do 2 destruct (flowsto_dec); try congruence. simpl in APPD2. 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. } @@ -1079,13 +1087,13 @@ End VISIBLE. Qed. Lemma mem_delta_apply_preserves_winject - ge cp0 m0 m0' + (ge: Genv.t F V) m0 m0' (WINJ0: winject (meminj_public ge) m0 m0') (d: mem_delta) m1 (APPD: mem_delta_apply d (Some m0) = Some m1) : - exists m1', (mem_delta_apply_wf ge cp0 d (Some m0') = Some m1') /\ (winject (meminj_public ge) m1 m1'). + exists m1', (mem_delta_apply_wf ge d (Some m0') = Some m1') /\ (winject (meminj_public ge) m1 m1'). Proof. revert m0 m0' WINJ0 m1 APPD. induction d; intros. { inv APPD. exists m0'. ss. } @@ -1095,6 +1103,8 @@ End VISIBLE. * 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. + simpl in *. rewrite Heq2 in Heq0; inv Heq0. rewrite Heq1 in Heq; now simpl in Heq. + simpl in *. rewrite Heq1 in Heq0; inv Heq0. + 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. @@ -1146,17 +1156,17 @@ End VISIBLE. Qed. Lemma mem_delta_apply_establish_inject - (ge: Senv.t) (k: meminj) m0 m0' + (ge: Genv.t F V) (k: meminj) m0 m0' (INJ: Mem.inject k m0 m0') (INCR: inject_incr (meminj_public ge) k) (NALLOC: meminj_not_alloc (meminj_public ge) m0) - (d: mem_delta) cp - (DWF: mem_delta_inj_wf cp (meminj_public ge) d) + (d: mem_delta) + (DWF: mem_delta_inj_wf ge (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'). + exists m1', (mem_delta_apply_wf ge d (Some m0') = Some m1') /\ (Mem.inject (meminj_public ge) m1 m1'). Proof. exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. exploit mem_delta_apply_preserves_winject; eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. @@ -1180,7 +1190,8 @@ End VISIBLE. } { 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. + - 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. @@ -1192,20 +1203,20 @@ End VISIBLE. Import Mem. Lemma mem_delta_apply_establish_inject_preprocess - (ge: Senv.t) (k: meminj) m0 m0' + (ge: Genv.t F V) (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) + (d: mem_delta) + (DWF: mem_delta_inj_wf ge (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'). + exists m1', (mem_delta_apply_wf ge 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. @@ -1242,19 +1253,19 @@ End VISIBLE. Qed. Lemma mem_delta_apply_establish_inject_preprocess_gen - (ge: Senv.t) (k: meminj) m0 m0' + (ge: Genv.t F V) (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) + (d: mem_delta) + (DWF: mem_delta_inj_wf ge (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') /\ + exists m1', (mem_delta_apply_wf ge 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. From 132733e25afd7eedd21f4a368792bf87a0f4998f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Tue, 23 Jan 2024 23:40:15 +0100 Subject: [PATCH 76/83] [Backtranslation] Checkpoint --- security/Backtranslation.v | 15 +- security/BacktranslationAux.v | 250 +++++++++++++++++++--------------- security/BtInfoAsm.v | 68 ++++----- security/MemoryDelta.v | 7 +- 4 files changed, 179 insertions(+), 161 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index ea68ea0e48..e471742818 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -400,18 +400,19 @@ End CONV. Section CODE. (** converting *informative* trace to code **) + Context {F V: Type} {CF: has_comp F}. - Variable ge: Senv.t. + Variable ge: Genv.t F V. Definition code_mem_delta_storev (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 + match Genv.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) (* TODO: check direction *) + if (Genv.public_symbol ge id) && (flowsto_dec (Genv.find_comp_of_ident ge id) cp) (* TODO: check direction *) then Sassign (Ederef (expr_of_addr id ofs) ty) ve else Sskip | _, _ => Sskip @@ -462,7 +463,7 @@ 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 := + Definition gen_function (ge: Asm.genv) (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 @@ -475,7 +476,7 @@ Section GEN. [] (code_bundle_trace ge cnt tr). - Definition gen_fundef (ge: Senv.t) (cnt: ident) params (tr: bundle_trace) (a_fd: Asm.fundef): Clight.fundef := + Definition gen_fundef (ge: Asm.genv) (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 => @@ -539,7 +540,7 @@ Section GEN. PTree_Properties.of_list params'. - Definition gen_progdef (ge: Senv.t) (tr: bundle_trace) a_gd (ocnt: option (ident * globdef Clight.fundef type)) (oparams: option (list (ident * type))): globdef Clight.fundef type := + Definition gen_progdef (ge: Asm.genv) (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 @@ -547,7 +548,7 @@ Section GEN. 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) := + Definition gen_prog_defs (a_ge: Asm.genv) 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 diff --git a/security/BacktranslationAux.v b/security/BacktranslationAux.v index c9a7c9d28b..b30ce30cd5 100644 --- a/security/BacktranslationAux.v +++ b/security/BacktranslationAux.v @@ -35,14 +35,14 @@ Section CODEPROOFS. Qed. Lemma code_mem_delta_cons - (ge: Senv.t) k d sn + (ge: genv) k d sn : code_mem_delta ge (k :: d) sn = Ssequence (code_mem_delta_kind ge k) (code_mem_delta ge d sn). Proof. unfold code_mem_delta. ss. Qed. Lemma code_mem_delta_app - (ge: Senv.t) d1 d2 sn + (ge: genv) d1 d2 sn : code_mem_delta ge (d1 ++ d2) sn = (code_mem_delta ge d1 (code_mem_delta ge d2 sn)). Proof. @@ -51,7 +51,7 @@ Section CODEPROOFS. Qed. Lemma type_of_chunk_val_to_expr - (ge: Senv.t) ch ty v e + (ge: genv) 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) @@ -66,7 +66,7 @@ Section CODEPROOFS. Proof. destruct v; ss; auto. Qed. Lemma sem_cast_chunk_val - (ge: Senv.t) m ch ty v e + (ge: genv) 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) @@ -150,9 +150,6 @@ Section CODEPROOFS. (* + rewrite Mem.store_int16_sign_ext. auto. *) (* + rewrite Mem.store_int16_zero_ext. auto. *) } - (* - apply andb_false_iff in Heq0 as [G | G]; try now inv G. *) - (* destruct cp_eq_dec; inv WF. *) - (* exfalso. pose proof (flowsto_refl (comp_of f)). now destruct flowsto_dec. } *) { (* assert (G: flowsto_dec c (comp_of f)). *) (* { destruct cp_eq_dec; inv WF. *) @@ -169,10 +166,10 @@ Section CODEPROOFS. Admitted. Lemma wf_mem_delta_storev_false_is_skip - (ge: Senv.t) cp d - (NWF: wf_mem_delta_storev_b ge cp d = false) + (ge: genv) d + (NWF: wf_mem_delta_storev_b ge d = false) : - code_mem_delta_storev ge cp d = Sskip. + code_mem_delta_storev ge d = Sskip. Proof. destruct d as [[[ch ptr] v] cp0]. ss. des_ifs. admit. Admitted. @@ -182,9 +179,9 @@ Section CODEPROOFS. 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') + (APPD: mem_delta_apply_wf ge d (Some m) = Some m') : - (star step1 ge (State f (code_mem_delta ge (comp_of f) d snext) k e le m) + (star step1 ge (State f (code_mem_delta ge d snext) k e le m) E0 (State f snext k e le m')). Proof. revert m m' snext APPD. induction d; intros. @@ -203,14 +200,14 @@ Section CODEPROOFS. Qed. Lemma code_bundle_trace_spec - (ge: genv) cp cnt tr + (ge: genv) cnt tr f e le m k : star step1 ge - (State f (code_bundle_trace ge cp cnt tr) k e le m) + (State f (code_bundle_trace ge 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) + (State f (switch_bundle_events ge cnt tr) + (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge cnt tr)) Sskip k) e le m). Proof. econs 2. @@ -229,153 +226,173 @@ 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 symbs_public (ge1: Asm.genv) (ge2: genv):= + (forall id : ident, Genv.public_symbol ge2 id = Genv.public_symbol ge1 id). + Definition symbs_find (ge1: Asm.genv) (ge2: genv):= + forall id b, Genv.find_symbol ge1 id = Some b -> Genv.find_symbol ge2 id = Some b. + Definition symbs_volatile (ge1: Asm.genv) (ge2: genv):= + forall b, Genv.block_is_volatile ge2 b = Genv.block_is_volatile ge1 b. + Definition symbs_comp (ge1: Asm.genv) (ge2: genv):= + forall id, Genv.find_comp_of_ident ge2 id = Genv.find_comp_of_ident ge1 id. - Definition match_symbs (ge1 ge2: Senv.t) := symbs_public ge1 ge2 /\ symbs_find ge1 ge2 /\ symbs_volatile ge1 ge2. + Definition match_symbs (ge1: Asm.genv) (ge2: genv):= + symbs_public ge1 ge2 /\ symbs_find ge1 ge2 /\ + symbs_volatile ge1 ge2 /\ symbs_comp ge1 ge2. Lemma match_symbs_meminj_public - ge1 ge2 + (ge1: Asm.genv) (ge2: genv) (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. + destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3 & MSYMB4). unfold meminj_public. extensionalities b. + simpl. des_ifs. + - exfalso. apply Genv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. + apply Genv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. + - exfalso. apply Genv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. + apply Genv.find_invert_symbol in x0. clarify. + - exfalso. apply Genv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. + apply Genv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. + - exfalso. rewrite MSYMB1 in Heq1. apply Genv.public_symbol_exists in Heq1. des. + exploit MSYMB2; eauto. intros. apply Genv.invert_find_symbol in Heq0. clarify. + apply Genv.find_invert_symbol in Heq1. clarify. Qed. Lemma match_symbs_wf_mem_delta_storev - ge1 ge2 + (ge1: Asm.genv) (ge2: genv) (MSYMB: match_symbs ge1 ge2) - cp0 d + d : - wf_mem_delta_storev_b ge1 cp0 d = wf_mem_delta_storev_b ge2 cp0 d. + wf_mem_delta_storev_b ge1 d = wf_mem_delta_storev_b ge2 d. Proof. - destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). + destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3 & MSYMB4). + unfold symbs_public, symbs_find, symbs_volatile, symbs_comp in *. simpl in *. 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. + - do 2 f_equal. + apply Genv.invert_find_symbol, MSYMB2, Genv.find_invert_symbol in Heq. clarify. + apply Genv.invert_find_symbol, MSYMB2, Genv.find_invert_symbol in Heq. clarify. + now rewrite MSYMB4. + - exfalso. apply Genv.invert_find_symbol, MSYMB2, Genv.find_invert_symbol in Heq. clarify. + - destruct (Genv.public_symbol ge2 i0) eqn:PUB; ss. + exfalso. rewrite MSYMB1 in PUB. apply Genv.public_symbol_exists in PUB. des. + exploit MSYMB2; eauto. intros. apply Genv.invert_find_symbol in Heq0. clarify. + apply Genv.find_invert_symbol in PUB. clarify. Qed. Lemma match_symbs_wf_mem_delta_kind - ge1 ge2 + (ge1: Asm.genv) (ge2: genv) (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. + wf_mem_delta_kind_b ge1 = wf_mem_delta_kind_b ge2. + 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 + d : - get_wf_mem_delta ge1 cp d = get_wf_mem_delta ge2 cp d. + get_wf_mem_delta ge1 d = get_wf_mem_delta ge2 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 + d m : - mem_delta_apply_wf ge1 cp d m = mem_delta_apply_wf ge2 cp d m. + mem_delta_apply_wf ge1 d m = mem_delta_apply_wf ge2 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. + code_mem_delta_kind ge1 = code_mem_delta_kind ge2 . 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. + destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3 & MSYMB4). + destruct (Genv.invert_symbol ge1 b) eqn:INV1. + { exploit Genv.invert_find_symbol; eauto. intros FIND1. + exploit MSYMB2; eauto. intros FIND2. exploit Genv.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. - des_ifs. - - admit. - - congruence. - (* clear - Heq6. *) - (* unfold wf_chunk_val_b in Heq6. *) + { unfold chunk_val_to_expr in *. + unfold chunk_val_to_expr. rewrite CHTY in *. simpl in *. des_ifs. + - apply Genv.invert_find_symbol in Heq5, Heq1. + apply MSYMB2 in Heq1. + apply Genv.find_invert_symbol in Heq5, Heq1. congruence. } 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. + - exfalso. apply andb_prop in Heq0. des. + apply andb_false_iff in Heq2 as [G | G]. + + rewrite MSYMB1 in G. clarify. + + rewrite MSYMB4 in G. clarify. + - exfalso. apply andb_prop in Heq0. des. + assert (chunk_val_to_expr ge2 ch v = chunk_val_to_expr ge1 ch v). + { unfold chunk_val_to_expr in *. + unfold chunk_val_to_expr. rewrite CHTY in *. simpl in *. + des_ifs. + apply Genv.invert_find_symbol in Heq4. + apply MSYMB2 in Heq4. + apply Genv.find_invert_symbol in Heq4. congruence. } + congruence. + - exfalso. apply andb_prop in Heq2. des. + apply andb_false_iff in Heq0 as [G | G]. + + rewrite <- MSYMB1 in G. clarify. + + rewrite <- MSYMB4 in G. clarify. + - admit. } { 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. + exfalso. apply andb_prop in Heq2. des. + rewrite MSYMB1 in Heq2. eapply Genv.public_symbol_exists in Heq2. des. + exploit MSYMB2. eapply Heq2. intros FIND4. eapply Genv.invert_find_symbol in Heq. clarify. + exploit Genv.find_invert_symbol. apply Heq2. intros INV3. clarify. } - Qed. + Admitted. Lemma match_symbs_code_mem_delta ge1 ge2 (MSYMB: match_symbs ge1 ge2) - cp d s + d s : - code_mem_delta ge1 cp d s = code_mem_delta ge2 cp d s. + code_mem_delta ge1 d s = code_mem_delta ge2 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 + 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. + code_bundle_call ge1 tr id evargs sg d = code_bundle_call ge2 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 + tr evr d : - code_bundle_return ge1 cp tr evr d = code_bundle_return ge2 cp tr evr d. + code_bundle_return ge1 tr evr d = code_bundle_return ge2 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 + tr ef evargs d : - code_bundle_builtin ge1 cp tr ef evargs d = code_bundle_builtin ge2 cp tr ef evargs d. + code_bundle_builtin ge1 tr ef evargs d = code_bundle_builtin ge2 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. + code_bundle_event ge1 = code_bundle_event ge2. 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. @@ -384,38 +401,44 @@ Section GENV. Lemma match_symbs_switch_bundle_events ge1 ge2 (MSYMB: match_symbs ge1 ge2) - cp cnt tr + cnt tr : - switch_bundle_events ge1 cnt cp tr = switch_bundle_events ge2 cnt cp tr. + switch_bundle_events ge1 cnt tr = switch_bundle_events ge2 cnt 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 + cnt tr : - code_bundle_trace ge1 cp cnt tr = code_bundle_trace ge2 cp cnt tr. + code_bundle_trace ge1 cnt tr = code_bundle_trace ge2 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) + cp : - symbols_inject (meminj_public ge1) ge1 ge2. + symbols_inject (meminj_public ge1) ge1 ge2 cp. Proof. - destruct MSYMB as (MS0 & MS1 & MS2). unfold symbols_inject. splits; auto. + destruct MSYMB as (MS0 & MS1 & MS2 & MS3). unfold symbols_inject. + simpl. 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. + - i. exists b1. split; auto. unfold meminj_public. apply Genv.find_invert_symbol in H0. + simpl. rewrite H0. rewrite H. auto. - i. unfold meminj_public in H. des_ifs. - Qed. + - admit. + Admitted. End GENV. Section PROOF. + Context {F V: Type} {CF: has_comp F}. + Lemma filter_filter A (l: list A) (p q: A -> bool) : @@ -426,40 +449,45 @@ Section PROOF. Qed. Lemma get_wf_mem_delta_idem - ge cp d + (ge: Genv.t F V) d : - get_wf_mem_delta ge cp (get_wf_mem_delta ge cp d) = get_wf_mem_delta ge cp d. + get_wf_mem_delta ge (get_wf_mem_delta ge d) = get_wf_mem_delta ge 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 + (ge: Genv.t F V) d m : - mem_delta_apply_wf ge cp d m = mem_delta_apply_wf ge cp (get_wf_mem_delta ge cp d) m. + mem_delta_apply_wf ge d m = mem_delta_apply_wf ge (get_wf_mem_delta ge 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) + (ge: Genv.t F V) k + (WF: wf_mem_delta_kind_b ge 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. + mem_delta_kind_inj_wf ge (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. simpl in *. + unfold Genv.find_comp_of_ident in WF. apply Genv.invert_find_symbol in Heq. + rewrite Heq in WF. + now destruct flowsto_dec. + Qed. Lemma get_wf_mem_delta_is_wf - cp ge d + (ge: Genv.t F V) d : - mem_delta_inj_wf cp (meminj_public ge) (get_wf_mem_delta ge cp d). + mem_delta_inj_wf ge (meminj_public ge) (get_wf_mem_delta ge 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' + (ge: Genv.t F V) 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) + d m1 + (APPD: mem_delta_apply_wf ge 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 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. @@ -476,9 +504,9 @@ Section PROOF. (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) + (APPD: mem_delta_apply_wf ge d (Some m0) = Some m1) : - exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ + exists m1', mem_delta_apply_wf ge 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. @@ -495,10 +523,10 @@ Section PROOF. (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) + (APPD: mem_delta_apply_wf ge 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 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. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 731a27c452..c91af73d6c 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -745,8 +745,9 @@ Section FROMASM. 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) ]). + all: try (match goal with - | |- _ /\ _ => admit end). + | |- _ ⊆ _ => admit end). { 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)])) @@ -841,11 +842,11 @@ Section INVS. : match_stack ge (ir_cont next :: ik_tl) (Stackframe b sg v ofs :: sk_tl). - Definition match_mem (ge: Senv.t) cp (k: meminj) (d: mem_delta) (m_a0 m_i m_a1: mem): Prop := + Definition match_mem (ge: Asm.genv) (k: meminj) (d: mem_delta) (m_a0 m_i m_a1: mem): Prop := let j := meminj_public ge in (Mem.inject k m_a0 m_i) /\ (inject_incr j k) /\ (meminj_not_alloc j m_a0) /\ (public_not_freeable ge m_a1) /\ - (mem_delta_inj_wf cp j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1) /\ + (mem_delta_inj_wf ge 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 := @@ -853,7 +854,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 (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + (match_stack ge ik sk) /\ (match_mem ge k d m_a0 m_i m_a) | _, _ => False end. @@ -953,7 +954,7 @@ Section PROOF. Qed. Lemma public_rev_perm_delta_apply_inj - d ge m m_i m_i' + d (ge: genv) m m_i m_i' (PRP: public_rev_perm ge m m_i) (APPD: mem_delta_apply_wf ge d (Some m_i) = Some m_i') : @@ -1022,7 +1023,7 @@ Section PROOF. Lemma match_mem_external_call_establish1 (ge: genv) cp k d m_a0 m_i m - (MEM: match_mem ge cp k d m_a0 m_i m) + (MEM: match_mem ge k d m_a0 m_i m) ef args t res m' (EXTCALL: external_call ef ge cp args m t res m') (ECC: external_call_unknowns ef ge m args) @@ -1031,7 +1032,7 @@ Section PROOF. (mem_delta_apply_wf ge d (Some m_i) = Some m1) /\ (external_call ef ge cp args m1 t res' m2) /\ (external_call_unknowns ef ge m1 args) /\ - (exists k2, match_mem ge cp k2 [] m' m2 m' /\ Val.inject k2 res res') + (exists k2, match_mem ge k2 [] m' m2 m' /\ Val.inject k2 res res') . Proof. destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). @@ -1045,7 +1046,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 cp f' [] m' m_i'' m'). + assert (MM': match_mem ge 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. @@ -1112,7 +1113,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (MTST2 : match_stack ge ik st) k d m_a0 m_i m_a - (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + (MEM: match_mem ge k d m_a0 m_i m_a) t' ast' (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') t'' ast'' @@ -1163,14 +1164,14 @@ Section PROOF. Lemma match_mem_external_call_establish2 ge cp k d m_a0 m_i m - (MEM: match_mem ge cp k d m_a0 m_i m) + (MEM: match_mem ge k d m_a0 m_i m) ef args t res m' (EXTCALL: external_call ef ge cp args m t res m') (ECKO: external_call_known_observables ef ge cp m args t res m') : (external_call ef ge cp args m_i t res m_i) /\ (external_call_known_observables ef ge cp m_i args t res m_i) /\ - (match_mem ge cp k d m_a0 m_i m') + (match_mem ge k d m_a0 m_i m') . Proof. destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). @@ -1196,7 +1197,7 @@ Section PROOF. Lemma match_mem_external_call_establish (ge: genv) cp k d m_a0 m_i m - (MEM: match_mem ge cp k d m_a0 m_i m) + (MEM: match_mem ge k d m_a0 m_i m) ef args t res m' (EXTCALL: external_call ef ge cp args m t res m') (ECC: external_call_unknowns ef ge m args \/ external_call_known_observables ef ge cp m args t res m') @@ -1205,7 +1206,7 @@ Section PROOF. (mem_delta_apply_wf ge d' (Some m_i) = Some m1) /\ (external_call ef ge cp args m1 t res' m2) /\ ((external_call_unknowns ef ge m1 args) \/ (external_call_known_observables ef ge cp m1 args t res' m2 /\ d' = [])) /\ - (exists k2 d2 m_a02, match_mem ge cp k2 d2 m_a02 m2 m' /\ (Val.inject k2 res res' \/ (res = res'))) + (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]. @@ -1225,7 +1226,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = (* callee_comp cpm st *) cur_comp) (MTST2 : match_stack ge ik st) k d m_a0 m_i m_a - (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + (MEM: match_mem ge k d m_a0 m_i m_a) t ast' (STEP: step ge (State st rs m_a cur_comp) t ast') b1 ofs1 @@ -1238,7 +1239,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 (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m_a') /\ + (match_mem ge k' d' m_a0' m_i' m_a') /\ (exists res, star_measure step ge n (ReturnState st (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) # PC <- (rs X1) m_a' bottom) t' ast''). @@ -1351,7 +1352,7 @@ Section PROOF. { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs, v, (Genv.find_comp_of_block ge cur))]), m_a0, m_i, m'. simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. { eapply public_not_freeable_store; eauto. } - { setoid_rewrite Forall_app. split; auto. econs; auto. ss. } + { setoid_rewrite Forall_app. split; auto. econs; auto. ss. admit. } { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } { eapply public_rev_perm_store; eauto. } } @@ -1422,7 +1423,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 (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m'). + (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 & MEM6). @@ -1525,7 +1526,7 @@ Section PROOF. exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs0, v, Genv.find_comp_of_block ge cur)]), m_a0, m_i. simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. { eapply public_not_freeable_store; eauto. } { setoid_rewrite Forall_app. split; auto. econs; auto. ss. - (* rewrite MTST1. rewrite CURPC. ss. unfold Genv.find_comp. setoid_rewrite CURF. auto. *) + admit. } { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } { eapply public_rev_perm_store; eauto. } @@ -1577,7 +1578,7 @@ Section PROOF. { destruct ECKS as [_ OBS]. inv EXTCALL. exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. } - Qed. + Admitted. Lemma asm_to_ir_returnstate_undef_nccc_external @@ -1602,7 +1603,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (MTST2 : match_stack ge ik st) k d m_a0 m_i m_a - (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) 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 ge (ReturnState st rs m_a cur_comp) t' ast') @@ -1683,7 +1684,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (MTST2 : match_stack ge ik st) k d m_a0 m_i m_a - (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + (MEM: match_mem ge k d m_a0 m_i m_a) t' ast' (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') t'' ast'' @@ -1768,7 +1769,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (MTST2 : match_stack ge ik st) k d m_a0 m_i m_a - (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) 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 ge (ReturnState st rs m_a cur_comp) t' ast') @@ -1825,7 +1826,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (MTST2 : match_stack ge ik st) k d m_a0 m_i m_a - (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + (MEM: match_mem ge k d m_a0 m_i m_a) t' ast' (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') t'' ast'' @@ -1904,7 +1905,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (MTST2 : match_stack ge ik st) k d m_a0 m_i m_a - (MEM: match_mem ge (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + (MEM: match_mem ge k d m_a0 m_i m_a) t' ast' (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') t'' ast'' @@ -1983,10 +1984,7 @@ Section PROOF. 2:{ inv MTST. } destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). exploit mem_delta_exec_instr. eapply MEM3. eapply H3. - { replace (comp_of f) with (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)). eapply MEM4. - admit. } - (* rewrite MTST1. rewrite H0. ss. *) - (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. reflexivity. } *) + { eapply MEM4. } eapply MEM5. auto. intros (d' & MEM4' & MEM5'). destruct f0. @@ -1998,17 +1996,13 @@ Section PROOF. assert (MTST': match_state ge k m_a0 d' (State st rs' m' cur_comp) (Some (cur, m_i, ik))). { clear IH. split. auto. split. auto. split. auto. split. { unfold match_cur_regset in *. rewrite NEXTPC. rewrite <- ALLOWED. - admit. } (* rewrite MTST1. *) - (* unfold Genv.find_comp_in_genv. rewrite H0. ss. *) - (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. reflexivity. } *) + unfold Genv.find_comp_in_genv. ss. + rewrite H0 in MTST1. ss. + rewrite Genv.find_funct_ptr_find_comp_of_block with (b := b) (fd := Internal f) in MTST1; eauto. } 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_in_genv ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. - admit. } - (* rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp_in_genv. *) - (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. reflexivity. } *) eapply public_rev_perm_exec_instr. 3: eapply H3. all: auto. } } @@ -2032,10 +2026,6 @@ Section PROOF. (* admit. } *) { 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_in_genv ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. - admit. } - (* rewrite MTST1. rewrite H0. ss. *) - (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. reflexivity. } *) eapply public_rev_perm_exec_instr; eauto. } intros (btr' & k' & d'0 & m_a0' & m_i' & m_a' & UTR' & ISTAR' & MM' & (res' & STAR')). diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index a0dac02973..31544efde6 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -340,7 +340,7 @@ Section WFDELTA. | Vptr b ofs => match Senv.invert_symbol ge b with | Some id => (Senv.public_symbol ge id) && (wf_chunk_val_b ch v) && - (flowsto_dec (Genv.find_comp_in_genv ge v) (Genv.find_comp_of_ident ge id)) && + (* (flowsto_dec (Genv.find_comp_in_genv ge v) (Genv.find_comp_of_ident ge id)) && *) (flowsto_dec (Genv.find_comp_of_ident ge id) cp) | _ => false end @@ -737,8 +737,7 @@ Section PROOFS. Definition mem_delta_kind_inj_wf (ge: Genv.t F V) (j: meminj): mem_delta_kind -> Prop := fun data => match data with - | mem_delta_kind_storev (ch, ptr, v, cp) => (Genv.find_comp_in_genv ge v ⊆ Genv.find_comp_in_genv ge ptr) /\ - (Genv.find_comp_in_genv ge ptr ⊆ cp) + | mem_delta_kind_storev (ch, ptr, v, cp) => (Genv.find_comp_in_genv ge ptr ⊆ cp) | 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 @@ -971,7 +970,7 @@ End VISIBLE. intros WFCV. rewrite WFCV in APPD2. unfold Genv.find_comp_of_ident in APPD2. apply Genv.invert_find_symbol in INV. rewrite INV in APPD2. - do 2 destruct (flowsto_dec); try congruence. simpl in APPD2. + do 1 destruct (flowsto_dec); try congruence. simpl in APPD2. 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. } From 2b0c34d6018165fb7c156e8f4689a9b7a2bf2bfe Mon Sep 17 00:00:00 2001 From: Sven Argo Date: Thu, 25 Jan 2024 09:52:31 +0100 Subject: [PATCH 77/83] Add results02.txt from second and improved long run on server --- test/backtranslation/results02.txt | 45 ++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) create mode 100644 test/backtranslation/results02.txt diff --git a/test/backtranslation/results02.txt b/test/backtranslation/results02.txt new file mode 100644 index 0000000000..43e64639b7 --- /dev/null +++ b/test/backtranslation/results02.txt @@ -0,0 +1,45 @@ +************* +* Test Mode * +************* +Root seed = 1037749238 + + +100000/100000 passed +0/100000 failed +Traces: + Min length: 0 + Max length: 880 + Calls: 16340276 + Returns: 16340276 + Builtins: 7010957 +ASM Programs: + Min compartments: 1 + Max compartments: 24 + Min global vars: 2 + Max global vars: 202 +Memory Deltas: + Total: 514626139 + Min length: 0 + Max length: 99 + StoreV: 514626139 + Store*: 0 + Bytes*: 0 + Alloc*: 0 + Free*: 0 +External Functions: + Total: 7010957 + EF_external: 1001449 + EF_builtin: 1003659 + EF_runtime: 1001243 + EF_vload: 1000487 + EF_vstore: 1001938 + EF_malloc*: 0 + EF_free*: 0 + EF_memcpy*: 0 + EF_annot: 1001981 + EF_annot_val: 1000200 + EF_inline_asm*: 0 + EF_debug*: 0 + + +Note: the entries marked with * are not generated. From 189773ee9f24a4f1a076c53c1f7d2eeabe86814a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Sun, 28 Jan 2024 12:02:15 +0100 Subject: [PATCH 78/83] Cleanup --- common/Events.v | 19 +- common/Globalenvs.v | 17 + security/Backtranslation.v | 152 +- security/BacktranslationAux.v | 4065 ++++++++++++++++----------------- security/BtInfoAsm.v | 182 +- security/BtInfoAsmBound.v | 134 +- security/MemoryDelta.v | 122 +- 7 files changed, 2338 insertions(+), 2353 deletions(-) diff --git a/common/Events.v b/common/Events.v index 2ee5a9dabe..b056570c69 100644 --- a/common/Events.v +++ b/common/Events.v @@ -858,6 +858,7 @@ Record extcall_properties (sem: extcall_sem) (cp: compartment) (sg: signature) : 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; + }. (** ** Semantics of volatile loads *) @@ -1154,7 +1155,8 @@ Proof. (* mem inject *) - inv H0. inv H2. inv H7. inv H8. inversion H5; subst. exploit volatile_store_inject; eauto. intros [m2' [A [B [C D]]]]. - exists f; exists Vundef; exists m2'; intuition. constructor; auto. red; intros; congruence. + exists f; exists Vundef; exists m2'; intuition. constructor; auto. + red; intros; congruence. (* trace length *) - inv H; inv H0; simpl; lia. (* receptive *) @@ -1603,6 +1605,7 @@ Proof. - inv H; auto. Qed. + Inductive extcall_annot_val_sem (text: string) (targ: typ) (ge: Senv.t) (cp: compartment): list val -> mem -> trace -> val -> mem -> Prop := | extcall_annot_val_sem_intro: forall varg m arg, @@ -1817,6 +1820,7 @@ Proof. - apply external_functions_properties. Qed. + (** Combining the semantics given above for the various kinds of external calls, we define the predicate [external_call] that relates: - the external function being invoked @@ -1844,6 +1848,19 @@ Definition external_call (ef: external_function): extcall_sem := | EF_debug kind txt targs => extcall_debug_sem end. +Definition has_fo (ef: external_function) := + match ef with + | EF_external _ _ | EF_builtin _ _ | EF_runtime _ _ | EF_inline_asm _ _ _ => True + | _ => False + end. + +(** External calls fail if public symbols are not first order *) +Axiom ec_public_first_order: forall (ef: external_function), + has_fo ef -> + forall (ge: Senv.t) cp vargs m1 t vres m2, + external_call ef ge cp vargs m1 t vres m2 -> + Senv.public_first_order ge m1 cp. + Ltac external_call_caller_independent := intros ????????? CALL; inv CALL; diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 66dc86711a..2078e84eac 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -135,6 +135,23 @@ Definition equiv (se1 se2: t) : Prop := /\ (forall b, block_is_volatile se2 b = block_is_volatile se1 b) /\ (forall id, find_comp se2 id = find_comp se1 id). + (* Memory location has only sequence of bytes *) + Definition loc_first_order (m: mem) (b: block) (ofs: Z) : Prop := + match (ZMap.get ofs (Mem.mem_contents m) !! b) with + | Byte _ => True + | _ => False + end. + + (* Public symbols are visible outside the compilation unit, + so when interacting via external calls, limit them to first-order (if Readable). *) + Definition public_first_order (ge: t) (m: mem) (cp: compartment) := + forall id b ofs + (PUBLIC: public_symbol ge id = true) + (FIND: find_symbol ge id = Some b) + (COMP: find_comp ge id = cp) + (READABLE: Mem.perm m b ofs Cur Readable), + loc_first_order m b ofs. + End Senv. Module Genv. diff --git a/security/Backtranslation.v b/security/Backtranslation.v index e471742818..d12e19a966 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -10,6 +10,7 @@ Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. Require Import Ctypes Clight. + Ltac simpl_expr := repeat (match goal with | |- eval_expr _ _ _ _ _ _ _ => econstructor @@ -70,7 +71,7 @@ Section SWITCH. (* intros; subst cp. *) (* destruct (Int64.eq n (Int64.repr n')) eqn:eq_n_n'. *) (* - simpl. *) - (* destruct (Mem.valid_access_store mMint64 b 0%Z (comp_of f) (Vlong (Int64.add n Int64.one))) as [m' m_m']; try assumption. *) + (* 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. *) @@ -184,13 +185,13 @@ Section CONV. Variable ge: Senv.t. - Definition not_in_env (e: env) id := e ! id = None. + (* 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 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 @@ -370,12 +371,12 @@ Section CONV. | 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. + (* 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 @@ -400,19 +401,18 @@ End CONV. Section CODE. (** converting *informative* trace to code **) - Context {F V: Type} {CF: has_comp F}. - Variable ge: Genv.t F V. + Variable ge: Senv.t. - Definition code_mem_delta_storev (d: mem_delta_storev): 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 Genv.invert_symbol ge b with + 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 (Genv.public_symbol ge id) && (flowsto_dec (Genv.find_comp_of_ident ge id) cp) (* TODO: check direction *) + if ((Senv.public_symbol ge id) && (flowsto_dec cp cp0)) (* TODO: check direction *) then Sassign (Ederef (expr_of_addr id ofs) ty) ve else Sskip | _, _ => Sskip @@ -422,40 +422,40 @@ Section CODE. | _ => Sskip end. - Definition code_mem_delta_kind (d: mem_delta_kind): statement := + Definition code_mem_delta_kind cp (d: mem_delta_kind): statement := match d with - | mem_delta_kind_storev dd => code_mem_delta_storev dd + | mem_delta_kind_storev dd => code_mem_delta_storev cp dd | _ => Sskip end. - Definition code_mem_delta (d: mem_delta) (snext: statement): statement := - fold_right Ssequence snext (map (code_mem_delta_kind) d). + 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 (tr: trace) (id: ident) (evargs: list eventval) (sg: signature) (d: mem_delta): statement := + 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 d (Scall None (Evar id (Tfunction tys.(dargs) tys.(dret) tys.(dcc))) (list_eventval_to_list_expr evargs)). + 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 (tr: trace) (evr: eventval) (d: mem_delta): statement := - code_mem_delta d (Sreturn (Some (eventval_to_expr evr))). + 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 (tr: trace) (ef: external_function) (evargs: list eventval) (d: mem_delta): statement := - code_mem_delta d (Sbuiltin None ef (list_eventval_to_typelist evargs) (list_eventval_to_list_expr evargs)). + 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 (be: bundle_event): statement := + Definition code_bundle_event cp (be: bundle_event): statement := match be with - | Bundle_call tr id evargs sg d => code_bundle_call tr id evargs sg d - | Bundle_return tr evr d => code_bundle_return tr evr d - | Bundle_builtin tr ef evargs d => code_bundle_builtin tr ef evargs d + | 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 (tr: bundle_trace) := - switch cnt (map (fun ib => code_bundle_event (snd ib)) tr) (Sreturn None). + 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 (cnt: ident) (tr: bundle_trace): statement := - Swhile one_expr (switch_bundle_events cnt tr). + Definition code_bundle_trace cp (cnt: ident) (tr: bundle_trace): statement := + Swhile one_expr (switch_bundle_events cnt cp tr). End CODE. @@ -463,7 +463,7 @@ Section GEN. Definition list_typ_to_list_type (ts: list typ): list type := map typ_to_type ts. - Definition gen_function (ge: Asm.genv) (cnt: ident) (params: list (ident * type)) (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 tret := rettype_to_type a_sg.(sig_res) in let cc := a_sg.(sig_cc) in @@ -474,9 +474,9 @@ Section GEN. params [] [] - (code_bundle_trace ge cnt tr). + (code_bundle_trace ge cp cnt tr). - Definition gen_fundef (ge: Asm.genv) (cnt: ident) params (tr: bundle_trace) (a_fd: Asm.fundef): Clight.fundef := + 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 => @@ -540,7 +540,7 @@ Section GEN. PTree_Properties.of_list params'. - Definition gen_progdef (ge: Asm.genv) (tr: bundle_trace) a_gd (ocnt: option (ident * globdef Clight.fundef type)) (oparams: option (list (ident * type))): 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 @@ -548,7 +548,7 @@ Section GEN. 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: Asm.genv) tr (gds: list (ident * globdef Asm.fundef unit)): list (ident * globdef Clight.fundef type) := + 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 @@ -602,40 +602,40 @@ Section AUX. 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. + (* 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 b30ce30cd5..c61fccd59b 100644 --- a/security/BacktranslationAux.v +++ b/security/BacktranslationAux.v @@ -12,2060 +12,2011 @@ 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) - (GE3: Genv.allowed_addrof ge cp id) - : - 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: genv) k d sn - : - code_mem_delta ge (k :: d) sn = - Ssequence (code_mem_delta_kind ge k) (code_mem_delta ge d sn). - Proof. unfold code_mem_delta. ss. Qed. - - Lemma code_mem_delta_app - (ge: genv) d1 d2 sn - : - code_mem_delta ge (d1 ++ d2) sn = (code_mem_delta ge d1 (code_mem_delta ge 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: genv) 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: genv) 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 d) - : - step1 ge (State f (code_mem_delta_storev ge 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 Heq, TY, 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. - right; auto. - - 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. - admit. - (* 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. *) - } - { - (* assert (G: flowsto_dec c (comp_of f)). *) - (* { destruct cp_eq_dec; inv WF. *) - (* pose proof (flowsto_refl (comp_of f)). now destruct flowsto_dec. } *) - 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. right; auto. - - 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. - (* destruct cp_eq_dec; inv WF. clarify. *) - } - Admitted. - - Lemma wf_mem_delta_storev_false_is_skip - (ge: genv) d - (NWF: wf_mem_delta_storev_b ge d = false) - : - code_mem_delta_storev ge d = Sskip. - Proof. destruct d as [[[ch ptr] v] cp0]. ss. des_ifs. - admit. - Admitted. - - 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 d (Some m) = Some m') - : - (star step1 ge (State f (code_mem_delta ge 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) cnt tr - f e le m k - : - star step1 ge - (State f (code_bundle_trace ge cnt tr) k e le m) - E0 - (State f (switch_bundle_events ge cnt tr) - (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge cnt 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: Asm.genv) (ge2: genv):= - (forall id : ident, Genv.public_symbol ge2 id = Genv.public_symbol ge1 id). - Definition symbs_find (ge1: Asm.genv) (ge2: genv):= - forall id b, Genv.find_symbol ge1 id = Some b -> Genv.find_symbol ge2 id = Some b. - Definition symbs_volatile (ge1: Asm.genv) (ge2: genv):= - forall b, Genv.block_is_volatile ge2 b = Genv.block_is_volatile ge1 b. - Definition symbs_comp (ge1: Asm.genv) (ge2: genv):= - forall id, Genv.find_comp_of_ident ge2 id = Genv.find_comp_of_ident ge1 id. - - Definition match_symbs (ge1: Asm.genv) (ge2: genv):= - symbs_public ge1 ge2 /\ symbs_find ge1 ge2 /\ - symbs_volatile ge1 ge2 /\ symbs_comp ge1 ge2. - - Lemma match_symbs_meminj_public - (ge1: Asm.genv) (ge2: genv) - (MSYMB: match_symbs ge1 ge2) - : - meminj_public ge1 = meminj_public ge2. - Proof. - destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3 & MSYMB4). unfold meminj_public. extensionalities b. - simpl. des_ifs. - - exfalso. apply Genv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. - apply Genv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. - - exfalso. apply Genv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. - apply Genv.find_invert_symbol in x0. clarify. - - exfalso. apply Genv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. - apply Genv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. - - exfalso. rewrite MSYMB1 in Heq1. apply Genv.public_symbol_exists in Heq1. des. - exploit MSYMB2; eauto. intros. apply Genv.invert_find_symbol in Heq0. clarify. - apply Genv.find_invert_symbol in Heq1. clarify. - Qed. - - Lemma match_symbs_wf_mem_delta_storev - (ge1: Asm.genv) (ge2: genv) - (MSYMB: match_symbs ge1 ge2) - d - : - wf_mem_delta_storev_b ge1 d = wf_mem_delta_storev_b ge2 d. - Proof. - destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3 & MSYMB4). - unfold symbs_public, symbs_find, symbs_volatile, symbs_comp in *. simpl in *. - destruct d as [[[ch ptr] v] cp]. ss. des_ifs. - - do 2 f_equal. - apply Genv.invert_find_symbol, MSYMB2, Genv.find_invert_symbol in Heq. clarify. - apply Genv.invert_find_symbol, MSYMB2, Genv.find_invert_symbol in Heq. clarify. - now rewrite MSYMB4. - - exfalso. apply Genv.invert_find_symbol, MSYMB2, Genv.find_invert_symbol in Heq. clarify. - - destruct (Genv.public_symbol ge2 i0) eqn:PUB; ss. - exfalso. rewrite MSYMB1 in PUB. apply Genv.public_symbol_exists in PUB. des. - exploit MSYMB2; eauto. intros. apply Genv.invert_find_symbol in Heq0. clarify. - apply Genv.find_invert_symbol in PUB. clarify. - Qed. - - Lemma match_symbs_wf_mem_delta_kind - (ge1: Asm.genv) (ge2: genv) - (MSYMB: match_symbs ge1 ge2) - : - wf_mem_delta_kind_b ge1 = wf_mem_delta_kind_b ge2. - 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) - d - : - get_wf_mem_delta ge1 d = get_wf_mem_delta ge2 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) - d m - : - mem_delta_apply_wf ge1 d m = mem_delta_apply_wf ge2 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) - - : - code_mem_delta_kind ge1 = code_mem_delta_kind ge2 . - 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 & MSYMB4). - destruct (Genv.invert_symbol ge1 b) eqn:INV1. - { exploit Genv.invert_find_symbol; eauto. intros FIND1. - exploit MSYMB2; eauto. intros FIND2. exploit Genv.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. - assert (chunk_val_to_expr ge2 ch v = chunk_val_to_expr ge1 ch v). - { unfold chunk_val_to_expr in *. - unfold chunk_val_to_expr. rewrite CHTY in *. simpl in *. - des_ifs. - - apply Genv.invert_find_symbol in Heq5, Heq1. - apply MSYMB2 in Heq1. - apply Genv.find_invert_symbol in Heq5, Heq1. congruence. - } - rewrite Heq, Heq1 in H. clarify. - - exfalso. apply andb_prop in Heq0. des. - apply andb_false_iff in Heq2 as [G | G]. - + rewrite MSYMB1 in G. clarify. - + rewrite MSYMB4 in G. clarify. - - exfalso. apply andb_prop in Heq0. des. - assert (chunk_val_to_expr ge2 ch v = chunk_val_to_expr ge1 ch v). - { unfold chunk_val_to_expr in *. - unfold chunk_val_to_expr. rewrite CHTY in *. simpl in *. - des_ifs. - apply Genv.invert_find_symbol in Heq4. - apply MSYMB2 in Heq4. - apply Genv.find_invert_symbol in Heq4. congruence. } - congruence. - - exfalso. apply andb_prop in Heq2. des. - apply andb_false_iff in Heq0 as [G | G]. - + rewrite <- MSYMB1 in G. clarify. - + rewrite <- MSYMB4 in G. clarify. - - admit. - } - { des_ifs. - exfalso. apply andb_prop in Heq2. des. - rewrite MSYMB1 in Heq2. eapply Genv.public_symbol_exists in Heq2. des. - exploit MSYMB2. eapply Heq2. intros FIND4. eapply Genv.invert_find_symbol in Heq. clarify. - exploit Genv.find_invert_symbol. apply Heq2. intros INV3. clarify. - } - Admitted. - - Lemma match_symbs_code_mem_delta - ge1 ge2 - (MSYMB: match_symbs ge1 ge2) - d s - : - code_mem_delta ge1 d s = code_mem_delta ge2 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) - tr id evargs sg d - : - code_bundle_call ge1 tr id evargs sg d = code_bundle_call ge2 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) - tr evr d - : - code_bundle_return ge1 tr evr d = code_bundle_return ge2 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) - tr ef evargs d - : - code_bundle_builtin ge1 tr ef evargs d = code_bundle_builtin ge2 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) - - : - code_bundle_event ge1 = code_bundle_event ge2. - 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) - cnt tr - : - switch_bundle_events ge1 cnt tr = switch_bundle_events ge2 cnt 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) - cnt tr - : - code_bundle_trace ge1 cnt tr = code_bundle_trace ge2 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) - cp - : - symbols_inject (meminj_public ge1) ge1 ge2 cp. - Proof. - destruct MSYMB as (MS0 & MS1 & MS2 & MS3). unfold symbols_inject. - simpl. splits; auto. - - i. unfold meminj_public in H. des_ifs. split; auto. - - i. exists b1. split; auto. unfold meminj_public. apply Genv.find_invert_symbol in H0. - simpl. - rewrite H0. rewrite H. auto. - - i. unfold meminj_public in H. des_ifs. - - admit. - Admitted. - -End GENV. - - -Section PROOF. - - Context {F V: Type} {CF: has_comp F}. - - 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: Genv.t F V) d - : - get_wf_mem_delta ge (get_wf_mem_delta ge d) = get_wf_mem_delta ge 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: Genv.t F V) d m - : - mem_delta_apply_wf ge d m = mem_delta_apply_wf ge (get_wf_mem_delta ge d) m. - Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_idem. auto. Qed. - - Lemma wf_mem_delta_kind_is_wf - (ge: Genv.t F V) k - (WF: wf_mem_delta_kind_b ge k) - : - mem_delta_kind_inj_wf ge (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. simpl in *. - unfold Genv.find_comp_of_ident in WF. apply Genv.invert_find_symbol in Heq. - rewrite Heq in WF. - now destruct flowsto_dec. - Qed. - - Lemma get_wf_mem_delta_is_wf - (ge: Genv.t F V) d - : - mem_delta_inj_wf ge (meminj_public ge) (get_wf_mem_delta ge 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: Genv.t F V) 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 m1 - (APPD: mem_delta_apply_wf ge d (Some m0) = Some m1) - (FO: public_first_order ge m1) - : - exists m1', mem_delta_apply_wf ge 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 d (Some m0) = Some m1) - : - exists m1', mem_delta_apply_wf ge 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 d (Some m0) = Some m1) - (FO: public_first_order ge m1) - : - exists m1', mem_delta_apply_wf ge d (Some m0'') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. - Proof. - hexploit mem_delta_apply_establish_inject_preprocess_gen; eauto. i. des. - esplits; eauto. apply H0. ii. unfold meminj_public in H1. des_ifs. - eapply FO; eauto. apply Senv.invert_find_symbol; auto. - Qed. - -End PROOF. - - - -Section DEFINITIONS. - - Definition meminj_same_block (j : meminj) := - forall b1 b2 del, j b1 = Some (b2, del) -> b1 = b2. - - Definition not_global_blks (ge: Senv.t) (ebs: list block) := - Forall (fun b => Senv.invert_symbol ge b = None) ebs. - - Definition blocks_of_env2 ge e : list block := (map (fun x => fst (fst x)) (blocks_of_env ge e)). - - Definition not_inj_blks (j: meminj) (ebs: list block) := - Forall (fun b => j b = None) ebs. - - Lemma not_global_is_not_inj_bloks - ge l - (NGB: not_global_blks ge l) - : - not_inj_blks (meminj_public ge) l. - Proof. induction NGB. ss. econs; eauto. unfold meminj_public. des_ifs. Qed. - - Definition eq_policy (ge1: Asm.genv) (ge2: genv) := - Genv.genv_policy ge1 = Genv.genv_policy ge2. - -End DEFINITIONS. - - - -Section PROOF. - - (* Properties *) - Lemma eventval_match_transl - (ge: Senv.t) - ev ty v - (EM: eventval_match ge ev ty v) - : - eventval_match ge ev (typ_of_type (typ_to_type ty)) (eventval_to_val ge ev). - Proof. - inversion EM; subst; simpl; try constructor. - setoid_rewrite H0. unfold Tptr in *. destruct Archi.ptr64; auto. - Qed. - - Lemma eventval_match_eventval_to_val - (ge: Senv.t) - ev ty v - (EM: eventval_match ge ev ty v) - : - eventval_to_val ge ev = v. - Proof. inversion EM; subst; simpl; auto. setoid_rewrite H0. auto. Qed. - - Lemma eventval_list_match_transl - (ge: Senv.t) - evs tys vs - (EM: eventval_list_match ge evs tys vs) - : - eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs). - Proof. induction EM; simpl. constructor. constructor; auto. eapply eventval_match_transl; eauto. Qed. - - Lemma eventval_list_match_transl_val - (ge: Senv.t) - evs tys vs - (EM: eventval_list_match ge evs tys vs) - : - eventval_list_match ge evs tys (list_eventval_to_list_val ge evs). - Proof. induction EM; simpl. constructor. constructor; auto. erewrite eventval_match_eventval_to_val; eauto. Qed. - - Lemma typ_type_typ - (ge: Senv.t) - ev ty v - (EM: eventval_match ge ev ty v) - : - typ_of_type (typ_to_type ty) = ty. - Proof. inversion EM; simpl; auto. subst. unfold Tptr. destruct Archi.ptr64; simpl; auto. Qed. - - Lemma eventval_to_expr_val_eval - (ge: genv) en cp temp m ev ty v - (WFENV: wf_env ge en) - (EM: eventval_match ge ev ty v) - (* (WFGE: wf_eventval_ge ge ev) *) - : - eval_expr ge en cp temp m (eventval_to_expr ev) (eventval_to_val ge ev). - Proof. destruct ev; simpl in *; try constructor. inv EM. setoid_rewrite H4. eapply ptr_of_id_ofs_eval; auto. Qed. - - Lemma sem_cast_eventval_match - (ge: Senv.t) v ty vv m - (EM: eventval_match ge v (typ_of_type (typ_to_type ty)) vv) - : - Cop.sem_cast vv (typeof (eventval_to_expr v)) (typ_to_type ty) m = Some vv. - Proof. - destruct ty; simpl in *; inversion EM; subst; simpl in *; simpl_expr. - all: try rewrite ptr_of_id_ofs_typeof; simpl. - all: try (cbn; auto). - all: unfold Tptr in *; destruct Archi.ptr64 eqn:ARCH; try congruence. - { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } - { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } - { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } - { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } - Qed. - - Lemma list_eventval_to_expr_val_eval - (ge: genv) en cp temp m evs tys - (* (WFENV: Forall (wf_eventval_env en) evs) *) - (WFENV: wf_env ge en) - (EMS: eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs)) - : - eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) (list_eventval_to_list_val ge evs). - Proof. - revert en cp temp m WFENV. - match goal with | [H: eventval_list_match _ _ ?t ?v |- _] => remember t as tys2; remember v as vs2 end. - revert tys Heqtys2 Heqvs2. induction EMS; intros; subst; simpl in *. - { destruct tys; simpl in *. constructor. congruence. } - inversion Heqvs2; clear Heqvs2; subst; simpl in *. - destruct tys; simpl in Heqtys2. congruence with Heqtys2. - inversion Heqtys2; clear Heqtys2; subst; simpl in *. - econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. - (* eapply eventval_match_wf_eventval_ge; eauto. *) - eapply sem_cast_eventval_match; eauto. - Qed. - - Lemma eventval_match_eventval_to_type - (ge: Senv.t) - ev ty v - (EM: eventval_match ge ev ty v) - : - eventval_match ge ev (typ_of_type (eventval_to_type ev)) v. - Proof. inversion EM; subst; simpl; auto. Qed. - - Lemma list_eventval_match_eventval_to_type - (ge: Senv.t) - evs tys vs - (ESM: eventval_list_match ge evs tys vs) - : - eventval_list_match ge evs (typlist_of_typelist (list_eventval_to_typelist evs)) vs. - Proof. induction ESM; simpl. constructor. constructor; auto. eapply eventval_match_eventval_to_type; eauto. Qed. - - Lemma val_load_result_idem - ch v - : - Val.load_result ch (Val.load_result ch v) = Val.load_result ch v. - Proof. - destruct ch, v; simpl; auto. - 5,6,7: destruct Archi.ptr64; simpl; auto. - 1,3: rewrite Int.sign_ext_idem; auto. - 3,4: rewrite Int.zero_ext_idem; auto. - all: lia. - Qed. - - Lemma val_load_result_aux - F V (ge: Genv.t F V) - ev ch v - (EM: eventval_match ge ev (type_of_chunk ch) (Val.load_result ch v)) - : - eventval_match ge ev (type_of_chunk ch) (Val.load_result ch (eventval_to_val ge ev)). - Proof. - inversion EM; subst; simpl in *; auto. - 1,2,3,4: rewrite H1, H2; rewrite val_load_result_idem; auto. - rewrite H3, H. rewrite H0. rewrite val_load_result_idem. auto. - Qed. - - Lemma eventval_match_proj_rettype - (ge: Senv.t) - ev ty v - (EM: eventval_match ge ev ty v) - : - eventval_match ge ev (proj_rettype (rettype_of_type (typ_to_type ty))) v. - Proof. - inversion EM; subst; simpl; try constructor. - unfold Tptr in *. destruct Archi.ptr64; simpl; auto. - Qed. - - (* Lemma sem_cast_eventval *) - (* (ge: cgenv) v m *) - (* (WFEV: wf_eventval_ge ge v) *) - (* : *) - (* Cop.sem_cast (eventval_to_val ge v) (typeof (eventval_to_expr v)) (eventval_to_type v) m = Some (eventval_to_val ge v). *) - (* Proof. rewrite typeof_eventval_to_expr_type. destruct v; simpl in *; simpl_expr. destruct WFEV. rewrite H. simpl_expr. Qed. *) - - (* Lemma list_eventval_to_expr_val_eval2 *) - (* (ge: genv) en cp temp m evs *) - (* (WFENV: Forall (wf_eventval_env en) evs) *) - (* (WFGE: Forall (wf_eventval_ge ge) evs) *) - (* : *) - (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_eventval_to_typelist evs) (list_eventval_to_list_val ge evs). *) - (* Proof. *) - (* move evs at top. revert ge en cp temp m WFENV WFGE. induction evs; intros; simpl in *. *) - (* constructor. *) - (* inversion WFENV; clear WFENV; subst. inversion WFGE; clear WFGE; subst. *) - (* econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. *) - (* apply sem_cast_eventval; auto. *) - (* Qed. *) - - Lemma eventval_match_sem_cast - (* F V (ge: Genv.t F V) *) - (ge: genv) - m ev ty v - (EM: eventval_match ge ev ty v) - : - (* Cop.sem_cast (eventval_to_val ge ev) (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some (eventval_to_val ge ev). *) - Cop.sem_cast v (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some v. - Proof. - inversion EM; subst; simpl; try constructor. all: simpl_expr. - rewrite ptr_of_id_ofs_typeof. unfold Tptr. unfold Cop.sem_cast. destruct Archi.ptr64 eqn:ARCH; simpl. - - rewrite ARCH; auto. - - rewrite ARCH; auto. - Qed. - - (* Lemma list_eventval_to_expr_val_eval_typs *) - (* (ge: genv) en cp temp m evs tys vs *) - (* (WFENV: Forall (wf_eventval_env en) evs) *) - (* (EMS: eventval_list_match ge evs tys vs) *) - (* : *) - (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) vs. *) - (* Proof. *) - (* revert en cp temp m WFENV. *) - (* induction EMS; intros; subst; simpl in *. constructor. *) - (* inversion WFENV; clear WFENV; subst. *) - (* econstructor; eauto. 2: eapply eventval_match_sem_cast; eauto. *) - (* exploit eventval_match_eventval_to_val. eauto. intros. rewrite <- H0. eapply eventval_to_expr_val_eval; auto. *) - (* eapply eventval_match_wf_eventval_ge; eauto. *) - (* Qed. *) - - Lemma sem_cast_ptr - b ofs m - : - Cop.sem_cast (Vptr b ofs) (Tpointer Tvoid noattr) (typ_to_type Tptr) m = Some (Vptr b ofs). - Proof. - unfold Tptr. destruct Archi.ptr64 eqn:ARCH; unfold Cop.sem_cast; simpl; rewrite ARCH; auto. - Qed. - - Lemma sem_cast_proj_rettype - (ge: genv) evres rty res m - (EVM: eventval_match ge evres (proj_rettype rty) res) - : - Cop.sem_cast (eventval_to_val ge evres) - (typeof (eventval_to_expr evres)) - (rettype_to_type rty) m - = Some (eventval_to_val ge evres). - Proof. - destruct rty; simpl in *. - { eapply eventval_match_sem_cast. eauto. erewrite eventval_match_eventval_to_val; eauto. } - { inv EVM; simpl; simpl_expr. - setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. - unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. - unfold Cop.sem_cast. simpl. rewrite ARCH. auto. - } - { inv EVM; simpl; simpl_expr. - setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. - unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. - unfold Cop.sem_cast. simpl. rewrite ARCH. auto. - } - { inv EVM; simpl; simpl_expr. - setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. - unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. - unfold Cop.sem_cast. simpl. rewrite ARCH. auto. - } - { inv EVM; simpl; simpl_expr. - setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. - unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. - unfold Cop.sem_cast. simpl. rewrite ARCH. auto. - } - { inv EVM; simpl; simpl_expr. - setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. - unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. - unfold Cop.sem_cast. simpl. rewrite ARCH. auto. - } - Qed. - - Lemma type_of_params_eq - params ts - (PARSIGS : list_typ_to_list_type ts = map snd params) - : - type_of_params params = list_typ_to_typelist ts. - Proof. - revert params PARSIGS. induction ts; ii; ss. - { destruct params; ss. } - destruct params; ss. destruct p; ss. clarify. f_equal. auto. - Qed. - - Lemma match_senv_eventval_match - (ge0 ge1: Senv.t) - (MS: match_symbs ge0 ge1) - ev ty v - (EM: eventval_match ge0 ev ty v) - : - eventval_match ge1 ev ty v. - Proof. destruct MS as (MS0 & MS1 & MS2). inv EM; try econs; auto. rewrite MS0. auto. Qed. - - Lemma match_senv_eventval_list_match - (ge0 ge1: Senv.t) - (MS: match_symbs ge0 ge1) - evs tys vs - (EM: eventval_list_match ge0 evs tys vs) - : - eventval_list_match ge1 evs tys vs. - Proof. induction EM; ss. econs; auto. econs; auto. eapply match_senv_eventval_match; eauto. Qed. - - Lemma unbundle_trace_app - tr1 tr2 - : - unbundle_trace (tr1 ++ tr2) = (unbundle_trace tr1) ++ (unbundle_trace tr2). - Proof. induction tr1; ss. rewrite <- app_assoc. f_equal. auto. Qed. - - Lemma allowed_call_gen_function - cp (ge_i: Asm.genv) (ge_c: genv) next cnt params tr f_i f_c - (GE: symbs_find ge_i ge_c) - (GEPOL: eq_policy ge_i ge_c) - (GEN: f_c = gen_function ge_i cnt params tr f_i) - (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) - (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.Internal f_i)) - (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = Some (Internal f_c)) - : - Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). - Proof. - unfold Genv.allowed_call in *. des; [left | right]. - - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. - - subst. unfold Genv.allowed_cross_call in *. des. - unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. - specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. - { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. - apply GE. auto. - } - { i. rewrite FINDF_C in H. clarify. } - { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. - rewrite <- ALLOW1. ss. - } - Qed. - - Lemma allowed_call_gen_function_external - cp (ge_i: Asm.genv) (ge_c: genv) next ef - (GE: symbs_find ge_i ge_c) - (GEPOL: eq_policy ge_i ge_c) - (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) - (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.External ef)) - (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = - Some (External ef - (list_typ_to_typelist (sig_args (ef_sig ef))) - (rettype_to_type (sig_res (ef_sig ef))) - (sig_cc (ef_sig ef)))) - : - Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). - Proof. - unfold Genv.allowed_call in *. des; [left | right]. - - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. - - unfold Genv.allowed_cross_call in *. des. - unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. - specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. - { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. - apply GE. auto. - } - { i. rewrite FINDF_C in H. clarify. } - { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. - rewrite <- ALLOW1. ss. - } - Qed. - - Lemma eventval_list_match_list_eventval_to_list_val - (ge: Senv.t) evargs tys vargs - (EVMS: eventval_list_match ge evargs tys vargs) - : - list_eventval_to_list_val ge evargs = vargs. - Proof. - induction EVMS; ss. f_equal; auto. - eapply eventval_match_eventval_to_val. eauto. - Qed. - - Lemma match_symbs_eventval_match - ge0 ge1 ev ty v - (MS: match_symbs ge0 ge1) - (EVM: eventval_match ge0 ev ty v) - : - eventval_match ge1 ev ty v. - Proof. - destruct MS as (MS0 & MS1 & MS2). inv EVM; econs; auto. rewrite MS0; auto. - Qed. - - Lemma match_symbs_eventval_list_match - ge0 ge1 ev ty v - (MS: match_symbs ge0 ge1) - (EVM: eventval_list_match ge0 ev ty v) - : - eventval_list_match ge1 ev ty v. - Proof. - induction EVM. econs. econs; auto. eapply match_symbs_eventval_match; eauto. - Qed. - - Lemma alloc_variables_exists - ge cp e m l - : - exists e' m', alloc_variables ge cp e m l e' m'. - Proof. - revert ge cp e m. induction l; ii. - { do 2 eexists. econs 1. } - destruct a as (id & ty). - destruct (Mem.alloc m cp 0 (sizeof ge ty)) as (m0 & b0) eqn:ALLOC. - specialize (IHl ge cp (PTree.set id (b0, ty) e) m0). des. - do 2 eexists. econs 2. eapply ALLOC. eapply IHl. - Qed. - - Lemma access_mode_typ_to_type - s - : - exists ch, access_mode (typ_to_type s) = By_value ch. - Proof. destruct s; ss; eauto. Qed. - - Lemma bind_parameters_exists - (ge: genv) cp (e: env) m params vargs - (INENV: Forall (fun '(id, ty) => - exists b, (e ! id = Some (b, ty)) /\ - (forall ch, access_mode ty = By_value ch -> - Mem.valid_access m ch b 0 Writable (Some cp))) - params) - sg - (PARSIGS: list_typ_to_list_type sg = map snd params) - evargs - (EMS: eventval_list_match ge evargs sg vargs) - : - exists m', bind_parameters ge cp e m params vargs m'. - Proof. - revert e m vargs INENV sg PARSIGS evargs EMS. induction params; ii. - { ss. inv EMS; ss. eexists. econs. } - destruct a as (id & ty). inv INENV. des. ss. - destruct sg; ss. rename t into s. clarify. inv EMS. - destruct (access_mode_typ_to_type s) as (ch & ACCM). - specialize (H0 _ ACCM). hexploit Mem.valid_access_store. apply H0. instantiate (1:=v1). - intros (m0 & STORE). - assert - (FA: Forall - (fun '(id, ty) => - exists b : block, - e ! id = Some (b, ty) /\ - (forall ch : memory_chunk, access_mode ty = By_value ch -> - Mem.valid_access m0 ch b 0 Writable (Some cp))) params). - { clear - H2 STORE. move H2 before cp. revert_until H2. induction H2; ii; ss. - econs; eauto. des_ifs. des. esplits; eauto. i. eapply Mem.store_valid_access_1; eauto. - } - hexploit IHparams. apply FA. 1,2: eauto. intros. des. exists m'. - econs; eauto. econs; eauto. - Qed. - - Lemma alloc_variables_wf_id - ge cp e m params e' m' - (EA: alloc_variables ge cp e m params e' m') - (WF: list_norepet (var_names params)) - : - forall id bt, (~ In id (var_names params)) -> (e ! id = Some bt) -> (e' ! id = Some bt). - Proof. - revert WF. induction EA; ii; ss. - apply Classical_Prop.not_or_and in H0. des. inv WF. - apply IHEA; auto. rewrite PTree.gso; auto. - Qed. - - Lemma alloc_variables_valid_access - ge cp e m params e' m' - (EA: alloc_variables ge cp e m params e' m') - : - forall b' ch' ofs' p' cp', Mem.valid_access m ch' b' ofs' p' cp' -> - Mem.valid_access m' ch' b' ofs' p' cp'. - Proof. - i. assert (WF: (b' < Mem.nextblock m)%positive). - { unfold Mem.valid_access in H. des. destruct (Unusedglob.IS.MSet.Raw.MX.lt_dec b' (Mem.nextblock m)); auto. - exfalso. unfold Mem.range_perm in H. specialize (H ofs'). - eapply (Mem.nextblock_noaccess _ _ ofs' Cur) in n. - exploit H. - { pose proof (size_chunk_pos ch'). lia. } - i. unfold Mem.perm in x0. rewrite n in x0. ss. - } - revert_until EA. induction EA; ii; ss. - apply IHEA. - { eapply Mem.valid_access_alloc_other; eauto. } - { erewrite Mem.nextblock_alloc; eauto. lia. } - Qed. - - Lemma alloc_variables_forall - ge cp e m params e' m' - (EA: alloc_variables ge cp e m params e' m') - (WF: list_norepet (var_names params)) - : - Forall (fun '(id, ty) => - exists b, (e' ! id = Some (b, ty)) /\ - (forall ch, access_mode ty = By_value ch -> - Mem.valid_access m' ch b 0 Writable (Some cp))) params. - Proof. - revert WF. induction EA; ii; ss. - inv WF. econs; eauto. - hexploit alloc_variables_wf_id. apply EA. auto. apply H2. apply PTree.gss. - i. esplits; eauto. - i. eapply alloc_variables_valid_access. apply EA. - apply Mem.valid_access_freeable_any. eapply Mem.valid_access_alloc_same; eauto. lia. - { ss. clear - H1. destruct ty; ss; clarify. des_ifs; clarify; ss. des_ifs; clarify; ss. unfold Mptr. des_ifs. } - exists 0. ss. - Qed. - - Lemma assign_loc_valid_access - ge cp ty m b ofs bit v m' - (AL: assign_loc ge cp ty m b ofs bit v m') - ch' b' ofs' perm' cp' - (VA: Mem.valid_access m ch' b' ofs' perm' (Some cp')) - : - Mem.valid_access m' ch' b' ofs' perm' (Some cp'). - Proof. - inv AL. - - eapply Mem.store_valid_access_1; eauto. - - eapply Mem.storebytes_valid_access_1; eauto. - - inv H. eapply Mem.store_valid_access_1; eauto. - Qed. - - Lemma bind_parameters_valid_access - (ge: genv) cp (e: env) m params vargs m' - (BIND: bind_parameters ge cp e m params vargs m') - ch b ofs perm cp' - (VA: Mem.valid_access m ch b ofs perm (Some cp')) - : - Mem.valid_access m' ch b ofs perm (Some cp'). - Proof. - revert_until BIND. induction BIND; ii; ss. - apply IHBIND. eapply assign_loc_valid_access; eauto. - Qed. - - Lemma mem_delta_apply_wf_valid_access - ge cp d m m' - (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') - ch b ofs perm cp' - (VA: Mem.valid_access m ch b ofs perm cp') - : - Mem.valid_access m' ch b ofs perm cp'. - Proof. - move d before ge. revert_until d. induction d; ii. - { unfold mem_delta_apply_wf in APPD. ss; clarify. } - rewrite mem_delta_apply_wf_cons in APPD. des_ifs. - - destruct a; ss. hexploit mem_delta_apply_wf_some; eauto. - intros (m0 & STOREV). rewrite STOREV in APPD. - eapply IHd. apply APPD. - unfold mem_delta_apply_storev in STOREV. des_ifs. - unfold Mem.storev in STOREV. des_ifs. - eapply Mem.store_valid_access_1; eauto. - - eapply IHd; eauto. - Qed. - - Lemma bind_parameters_mem_load - ge cp e m0 params vargs m1 - (BIND: bind_parameters ge cp e m0 params vargs m1) - : - forall ch b ofs cp', - (forall id b_e ty, (e ! id = Some (b_e, ty) -> b <> b_e)) -> - (Mem.load ch m1 b ofs cp' = Mem.load ch m0 b ofs cp'). - Proof. - induction BIND; ii; ss. - rewrite IHBIND; auto. - inv H0. - - eapply Mem.load_store_other. eapply H3. left. ii. clarify. specialize (H1 _ _ _ H). clarify. - - eapply Mem.load_storebytes_other. eapply H7. left. ii. clarify. specialize (H1 _ _ _ H). clarify. - Qed. - - Lemma alloc_variables_mem_load - ge cp e m params e' m' - (EA: alloc_variables ge cp e m params e' m') - : - forall ch b ofs cp', - (b < Mem.nextblock m)%positive -> - (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). - Proof. - induction EA; ii; ss. - rewrite IHEA. - { eapply Mem.load_alloc_unchanged; eauto. } - { erewrite Mem.nextblock_alloc; eauto. lia. } - Qed. - - Lemma alloc_variables_old_blocks - ge cp e m params e' m' - (EA: alloc_variables ge cp e m params e' m') - : - forall b, (b < Mem.nextblock m)%positive -> - (forall id b' ty, e ! id = Some (b', ty) -> b <> b') -> - (forall id b' ty, e' ! id = Some (b', ty) -> b <> b'). - Proof. - induction EA; i. - { ii; clarify. specialize (H0 _ _ _ H1). clarify. } - hexploit Mem.alloc_result; eauto. intros; clarify. - eapply IHEA. 3: eapply H2. - { erewrite Mem.nextblock_alloc; eauto. lia. } - { i. destruct (Pos.eq_dec id id1). - - clarify. rewrite PTree.gss in H3. clarify. lia. - - rewrite PTree.gso in H3; auto. eapply H1; eauto. - } - Qed. - - Lemma mem_delta_apply_wf_mem_load - ge cp d m m' - (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') - : - forall id ch b ofs cp', - Senv.invert_symbol ge b = Some id -> - Senv.public_symbol ge id = false -> - (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). - Proof. - move d before ge. revert_until d. induction d; ii. - { unfold mem_delta_apply_wf in APPD. ss. clarify. } - rewrite mem_delta_apply_wf_cons in APPD. des_ifs. - { destruct a; ss. unfold wf_mem_delta_storev_b in Heq. des_ifs. ss. - hexploit mem_delta_apply_wf_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. - erewrite IHd. 2: eauto. 2: eauto. all: auto. - destruct (Pos.eq_dec b b0). - - clarify. - - erewrite Mem.load_store_other. 2: eauto. all: auto. - } - { eapply IHd; eauto. } - Qed. - - Lemma nat64_int64_add_one - n - (BOUND: Z.of_nat n < Int64.modulus) - : - Int64.add (nat64 n) Int64.one = nat64 (n + 1). - Proof. - unfold nat64. rewrite Nat2Z.inj_add. ss. - assert (N: Z.of_nat n = Int64.unsigned (Int64.repr (Z.of_nat n))). - { symmetry. apply Int64.unsigned_repr. split. apply Zle_0_nat. - unfold Int64.max_unsigned. lia. - } - assert (ONE: 1 = (Int64.unsigned (Int64.repr 1))). - { ss. } - rewrite N at 2. rewrite ONE. rewrite <- Int64.add_unsigned. ss. - Qed. - - Lemma mem_free_list_impl1 - blks m cp m_f - (FREE: Mem.free_list m blks cp = Some m_f) - : - Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks. - Proof. - Local Opaque Mem.can_access_block. - revert_until blks. induction blks; ii; ss. des_ifs. ss. econs. - 2:{ cut (Forall (fun '(b0, lo, hi) => Mem.range_perm m0 b0 lo hi Cur Freeable /\ Mem.can_access_block m0 b0 (Some cp)) blks); cycle 1. - { eapply IHblks; eauto. } - clear - Heq. intros FA. revert_until blks. induction blks; ii; ss. - destruct a as ((ba & loa) & hia). ss. inv FA. des; clarify. econs. - { - clear IHblks. split. - - unfold Mem.range_perm in *. ii. eapply Mem.perm_free_3. eauto. eauto. - - eapply Mem.free_can_access_block_inj_2; eauto. - } - eapply IHblks; eauto. - } - split. - - eapply Mem.free_range_perm; eauto. - - eapply Mem.free_can_access_block_1; eauto. - Local Transparent Mem.can_access_block. - Qed. - - Lemma mem_free_list_impl2 - blks m cp - (NR: list_norepet (map (fun x => fst (fst x)) blks)) - (FA: Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks) - : - exists m_f, (Mem.free_list m blks cp = Some m_f). - Proof. - Local Opaque Mem.can_access_block. - revert_until blks. induction blks; ii; ss; eauto. - inv FA. inv NR. des_ifs; des. - 2:{ exfalso. destruct (Mem.range_perm_free _ _ _ _ _ H1 H0) as (m0 & FREE). clarify. } - eapply IHblks; clear IHblks; eauto. ss. clear - H2 H3 Heq. - revert_until blks. induction blks; ii; ss. inv H2. des_ifs; ss. des. econs; eauto. - clear IHblks H4. apply Classical_Prop.not_or_and in H3. des. split. - - unfold Mem.range_perm in *. ii. hexploit Mem.perm_free_inv; eauto. ii. des; clarify. - - eapply Mem.free_can_access_block_inj_1; eauto. - Local Transparent Mem.can_access_block. - Qed. - - Lemma list_map_norepet_rev - A (l: list A) B (f: A -> B) - (NR: list_norepet (map f l)) - : - list_norepet l. - Proof. - revert NR. induction l; ii; ss. econs. inv NR. econs; eauto. - ii. apply H1; clear H1. apply in_map; auto. - Qed. - - Lemma alloc_variables_wunchanged_on - ge cp e m params e' m' - (EA: alloc_variables ge cp e m params e' m') - : - wunchanged_on (fun b _ => Mem.valid_block m b) m m'. - Proof. - induction EA. apply wunchanged_on_refl. - eapply wunchanged_on_implies in IHEA. - { eapply wunchanged_on_trans. 2: eauto. eapply alloc_wunchanged_on. eauto. } - { ii. ss. } - Qed. - - Lemma alloc_variables_exists_free_list - ge cp e m params e' m' - (EA: alloc_variables ge cp e m params e' m') - (ENV1: forall id1 id2 b1 b2 t1 t2, (id1 <> id2) -> (e ! id1 = Some (b1, t1)) -> (e ! id2 = Some (b2, t2)) -> (b1 <> b2)) - (ENV2: forall id b t, (e ! id = Some (b, t)) -> (Mem.valid_block m b)) - m_f0 - (FREE: Mem.free_list m' (blocks_of_env ge e) cp = Some m_f0) - : - exists m_f, Mem.free_list m' (blocks_of_env ge e') cp = Some m_f. - Proof. - revert_until EA. induction EA; ii; ss; eauto. - assert (exists m_f0, Mem.free_list m2 (blocks_of_env ge (PTree.set id (b1, ty) e)) cp = Some m_f0); cycle 1. - { des. eapply IHEA; clear IHEA; eauto. - - i. destruct (Pos.eqb_spec id id1); clarify. - + rewrite PTree.gss in H2. rewrite PTree.gso in H3; auto. clarify. specialize (ENV2 _ _ _ H3). - ii. clarify. apply Mem.fresh_block_alloc in H. clarify. - + destruct (Pos.eqb_spec id id2); clarify. - * rewrite PTree.gso in H2; auto. rewrite PTree.gss in H3; auto. clarify. specialize (ENV2 _ _ _ H2). - ii. clarify. apply Mem.fresh_block_alloc in H. clarify. - * rewrite PTree.gso in H2, H3; auto. hexploit ENV1. 2: eapply H2. 2: eapply H3. all: auto. - - i. destruct (Pos.eqb_spec id id0); clarify. - + rewrite PTree.gss in H1. clarify. eapply Mem.valid_new_block; eauto. - + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). eapply Mem.valid_block_alloc; eauto. - } - clear IHEA. eapply mem_free_list_impl2. - { unfold blocks_of_env. rewrite map_map. apply list_map_norepet. - { eapply list_map_norepet_rev. apply PTree.elements_keys_norepet. } - { i. unfold block_of_binding. des_ifs. ss. apply PTree.elements_complete in H0, H1. - destruct (Pos.eqb_spec id i); clarify. - - rewrite PTree.gss in H0. clarify. destruct (Pos.eqb_spec i i0); clarify. - + rewrite PTree.gss in H1; clarify. - + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). ii; clarify. - apply Mem.fresh_block_alloc in H. clarify. - - rewrite PTree.gso in H0; auto. destruct (Pos.eqb_spec id i0); clarify. - + rewrite PTree.gss in H1. clarify. specialize (ENV2 _ _ _ H0). ii; clarify. - apply Mem.fresh_block_alloc in H. clarify. - + rewrite PTree.gso in H1; auto. eapply ENV1. 2: apply H0. 2: apply H1. ii; clarify. - } - } - { apply mem_free_list_impl1 in FREE. rewrite Forall_forall in *. i. - assert ((x = (b1, 0%Z, sizeof ge ty)) \/ (In x (blocks_of_env ge e))). - { clear - H0. unfold blocks_of_env in *. apply list_in_map_inv in H0. des. - destruct x0 as (xid & xb & xt). apply PTree.elements_complete in H1. clarify. - destruct (Pos.eqb_spec id xid); clarify. - - rewrite PTree.gss in H1. clarify. left; auto. - - rewrite PTree.gso in H1; auto. right. apply in_map. apply PTree.elements_correct. auto. - } - des. - - clarify. split. - + ii. eapply perm_wunchanged_on. eapply alloc_variables_wunchanged_on; eauto. - { ss. eapply Mem.valid_new_block; eauto. } - { eapply Mem.perm_alloc_2; eauto. } - + rewrite <- wunchanged_on_own. 2: eapply alloc_variables_wunchanged_on; eauto. - eapply Mem.owned_new_block; eauto. eapply Mem.valid_new_block; eauto. - - eapply FREE. eauto. - } - Qed. - - Lemma assign_loc_wunchanged_on - ge cp ty m b ofs bit v m' - (AL: assign_loc ge cp ty m b ofs bit v m') - : - wunchanged_on (fun _ _ => True) m m'. - Proof. - inv AL. - - eapply store_wunchanged_on; eauto. - - eapply storebytes_wunchanged_on; eauto. - - inv H. eapply store_wunchanged_on; eauto. - Qed. - - Lemma bind_parameters_wunchanged_on - (ge: genv) cp (e: env) m params vargs m' - (BIND: bind_parameters ge cp e m params vargs m') - : - wunchanged_on (fun _ _ => True) m m'. - Proof. - induction BIND. apply wunchanged_on_refl. eapply wunchanged_on_trans. 2: apply IHBIND. - eapply assign_loc_wunchanged_on; eauto. - Qed. - - Lemma wunchanged_on_exists_free - m m' - (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') - b lo hi cp m_f - (FREE: Mem.free m b lo hi cp = Some m_f) - : - exists m_f', Mem.free m' b lo hi cp = Some m_f'. - Proof. - hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. - hexploit Mem.range_perm_free. - 3:{ intros (m0 & F). eexists; eapply F. } - - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. eapply Mem.perm_valid_block; eauto. - - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. - Qed. - - Lemma assign_loc_perm - ge cp ty m b ofs bit v m' - (AL: assign_loc ge cp ty m b ofs bit v m') - b' o' C P - (PERM: Mem.perm m b' o' C P) - : - Mem.perm m' b' o' C P. - Proof. - inv AL. - - eapply Mem.perm_store_1; eauto. - - eapply Mem.perm_storebytes_1; eauto. - - inv H. eapply Mem.perm_store_1; eauto. - Qed. - - Lemma assign_loc_own - ge cp ty m b ofs bit v m' - (AL: assign_loc ge cp ty m b ofs bit v m') - b' cp' - (OWN: Mem.can_access_block m b' cp') - : - Mem.can_access_block m' b' cp'. - Proof. - inv AL. - - rewrite <- Mem.store_can_access_block_inj; eauto. - - eapply Mem.storebytes_can_access_block_inj_1; eauto. - - inv H. rewrite <- Mem.store_can_access_block_inj; eauto. - Qed. - - Lemma assign_loc_exists_free - ge cp ty m b ofs bit v m' - (AL: assign_loc ge cp ty m b ofs bit v m') - b' lo hi cp' m_f - (FREE: Mem.free m b' lo hi cp' = Some m_f) - : - exists m_f, Mem.free m' b' lo hi cp' = Some m_f. - Proof. - hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. - hexploit Mem.range_perm_free. - 3:{ intros (m0 & F). eexists; eapply F. } - - unfold Mem.range_perm in *. i. eapply assign_loc_perm; eauto. - - eapply assign_loc_own; eauto. - Qed. - - Lemma wunchanged_on_free_preserves - m m' - (WU : wunchanged_on (fun (b : block) (_ : Z) => Mem.valid_block m b) m m') - b lo hi cp m1 m1' - (FREE: Mem.free m b lo hi cp = Some m1) - (FREE': Mem.free m' b lo hi cp = Some m1') - : - wunchanged_on (fun (b0 : block) (_ : Z) => Mem.valid_block m1 b0) m1 m1'. - Proof. - inv WU. econs. - - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. - - i. assert (VB: Mem.valid_block m b0). - { eapply Mem.valid_block_free_2; eauto. } - split; i. - + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. - eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. - hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. - + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. - eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. - hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. - - i. assert (VB: Mem.valid_block m b0). - { eapply Mem.valid_block_free_2; eauto. } - split; i. - + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. - eapply Mem.free_can_access_block_inj_2; eauto. - + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. - eapply Mem.free_can_access_block_inj_2; eauto. - Qed. - - Lemma wunchanged_on_exists_mem_free_list - m m' - (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') - l cp m_f - (FREE: Mem.free_list m l cp = Some m_f) - : - exists m_f', Mem.free_list m' l cp = Some m_f'. - Proof. - move l after m. revert_until l. induction l; ii; ss; eauto. des_ifs. - 2:{ exfalso. hexploit wunchanged_on_exists_free. 2: eapply Heq0. 2: auto. - 2:{ intros. des. rewrite H in Heq; clarify. } - auto. - } - hexploit IHl. 2: eapply FREE. - { instantiate (1:=m0). eapply wunchanged_on_free_preserves; eauto. } - eauto. - Qed. - - Lemma mem_free_list_wunchanged_on - x m l cp m' - (FL: Mem.free_list m l cp = Some m') - (WF: Forall (fun '(b, lo, hi) => (x <= b)%positive) l) - : - wunchanged_on (fun b _ => (b < x)%positive) m m'. - Proof. - move WF before x. revert_until WF. induction WF; i; ss. clarify. apply wunchanged_on_refl. des_ifs. - hexploit IHWF; eauto. i. eapply wunchanged_on_trans. 2: eauto. - eapply free_wunchanged_on; eauto. - i. lia. - Qed. - - Lemma wunchanged_on_free_list_preserves - m m' - (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') - l cp m_f m_f' - (FREE: Mem.free_list m l cp = Some m_f) - (FREE': Mem.free_list m' l cp = Some m_f') - : - wunchanged_on (fun b _ => Mem.valid_block m_f b) m_f m_f'. - Proof. - move l after m. revert_until l. induction l; ii; ss. clarify. - des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves; eauto. - Qed. - - Lemma mem_delta_apply_wf_wunchanged_on - ge cp d m m' - (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') - P - : - wunchanged_on P m m'. - Proof. - revert_until d. induction d; ii; ss. - { cbn in APPD. clarify. apply wunchanged_on_refl. } - rewrite mem_delta_apply_wf_cons in APPD. des_ifs. - - hexploit mem_delta_apply_wf_some; eauto. intros (m0 & ST). rewrite ST in APPD. - specialize (IHd _ _ APPD). unfold mem_delta_apply_kind in ST. unfold mem_delta_apply_storev in ST. des_ifs. - ss. des_ifs. ss. eapply wunchanged_on_trans. eapply store_wunchanged_on. eapply ST. - eapply wunchanged_on_implies. eapply IHd. ss. - - eauto. - Unshelve. all: exact 0%nat. - Qed. - - Lemma alloc_variables_fresh_blocks - ge cp e m params e' m' - (EA: alloc_variables ge cp e m params e' m') - x - (X: (x <= Mem.nextblock m)%positive) - (FA: Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e)) - : - Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e'). - Proof. - revert_until EA. induction EA; ii; ss. specialize (IHEA x). - eapply IHEA; clear IHEA. - { erewrite Mem.nextblock_alloc; eauto. lia. } - apply Forall_forall. rewrite Forall_forall in FA. ii. specialize (FA x0). des_ifs. - unfold blocks_of_env in H0. apply list_in_map_inv in H0. des. destruct x0 as (xid & xb & xt). - apply PTree.elements_complete in H1. destruct (Pos.eqb_spec id xid); clarify. - - rewrite PTree.gss in H1. ss. clarify. erewrite Mem.alloc_result. 2: eauto. auto. - - rewrite PTree.gso in H1; auto. apply FA. rewrite H0. unfold blocks_of_env. apply in_map. - apply PTree.elements_correct; auto. - Qed. - - Lemma alloc_variables_one_fresh_block - ge cp e m params e' m' - (EA: alloc_variables ge cp e m params e' m') - (NR: list_norepet (var_names params)) - xid xb xt - (NOT: e ! xid = None) - (GET: e' ! xid = Some (xb, xt)) - : - ~ (Mem.valid_block m xb). - Proof. - revert_until EA. induction EA; i. clarify. - inv NR. destruct (Pos.eqb_spec xid id). - { subst id. hexploit alloc_variables_wf_id. eauto. auto. eauto. apply PTree.gss. - i. rewrite GET in H0. clarify. eapply Mem.fresh_block_alloc; eauto. } - hexploit IHEA. auto. rewrite PTree.gso. eapply NOT. auto. eapply GET. i. - ii. apply H0. unfold Mem.valid_block in *. erewrite Mem.nextblock_alloc; eauto. - etransitivity. eapply H1. apply Plt_succ. - Qed. - - Lemma assign_loc_outside_mem_inject - ge cp ty m b ofs bf v m' - (AL: assign_loc ge cp ty m b ofs bf v m') - k m0 - (INJ: Mem.inject k m0 m) - (NIB: k b = None) - (MS: meminj_same_block k) - : - Mem.inject k m0 m'. - Proof. - inv AL. - - eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H1). clarify. - - eapply Mem.storebytes_outside_inject; eauto. i. specialize (MS _ _ _ H5). clarify. - - inv H. eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H). clarify. - Qed. - - Lemma bind_parameters_outside_mem_inject - ge cp e m_cur params vargs m_next - (BIND: bind_parameters ge cp e m_cur params vargs m_next) - k m - (INJ: Mem.inject k m m_cur) - (NIB: forall id b t, e ! id = Some (b, t) -> k b = None) - (MS: meminj_same_block k) - (* (NIB: not_inj_blks k (blocks_of_env2 ge e)) *) - : - Mem.inject k m m_next. - Proof. - revert_until BIND. induction BIND; ii. - { auto. } - apply IHBIND; auto. clear IHBIND. specialize (NIB _ _ _ H). - eapply assign_loc_outside_mem_inject; eauto. - Qed. - - Lemma not_inj_blks_get_env - k ge e - (NIB: not_inj_blks k (blocks_of_env2 ge e)) - : - forall id b t, e ! id = Some (b, t) -> k b = None. - Proof. - rr in NIB. unfold blocks_of_env2, blocks_of_env in NIB. rewrite map_map in NIB. - rewrite Forall_forall in NIB. i. apply PTree.elements_correct in H. - apply NIB. eapply (in_map (fun x : ident * (block * type) => fst (fst (block_of_binding ge x)))) in H. ss. - Qed. - - Lemma not_global_blks_get_env - (ge: genv) e - (NIB: not_global_blks ge (blocks_of_env2 ge e)) - : - forall id b t, e ! id = Some (b, t) -> (meminj_public ge) b = None. - Proof. eapply not_inj_blks_get_env. eapply not_global_is_not_inj_bloks. eauto. Qed. - - Lemma meminj_public_same_block - ge - : - meminj_same_block (meminj_public ge). - Proof. rr. unfold meminj_public. i. des_ifs. Qed. - - Lemma alloc_variables_mem_inject - ge cp e m params e' m' - (EA: alloc_variables ge cp e m params e' m') - k m0 - (INJ: Mem.inject k m0 m) - : - Mem.inject k m0 m'. - Proof. - revert_until EA. induction EA; ii. auto. - apply IHEA. clear IHEA. eapply Mem.alloc_right_inject; eauto. - Qed. - - Lemma mem_valid_access_wunchanged_on - m ch b ofs p cp - (MV: Mem.valid_access m ch b ofs p cp) - P m' - (WU: wunchanged_on P m m') - (SAT: forall ofs', P b ofs') - : - Mem.valid_access m' ch b ofs p cp. - Proof. - unfold Mem.valid_access in *. des. splits; auto. - - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on; eauto. - - destruct cp. 2: ss. erewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block; eauto. - Qed. - - Lemma mem_free_list_wunchanged_on_2 - l m cp m' - (FREE: Mem.free_list m l cp = Some m') - : - wunchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. - Proof. - revert_until l. induction l; ii. - { ss. clarify. apply wunchanged_on_refl. } - ss. des_ifs. eapply wunchanged_on_trans; cycle 1. - { eapply wunchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } - ss. eapply free_wunchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. - Qed. - - Lemma not_global_blks_global_not_in - (ge: genv) id b - (FIND: Genv.find_symbol ge id = Some b) - e - (NGB: not_global_blks ge (blocks_of_env2 ge e)) - : - ~ In b (map (fun x : block * Z * Z => fst (fst x)) (blocks_of_env ge e)). - Proof. - intros CONTRA. unfold not_global_blks in NGB. unfold blocks_of_env2, blocks_of_env in *. - rewrite map_map in NGB, CONTRA. rewrite Forall_forall in NGB. specialize (NGB _ CONTRA). - apply Genv.find_invert_symbol in FIND. setoid_rewrite FIND in NGB. inv NGB. - Qed. - - Lemma mem_free_list_unchanged_on - l m cp m' - (FREE: Mem.free_list m l cp = Some m') - : - Mem.unchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. - Proof. - revert_until l. induction l; ii. - { ss. clarify. apply Mem.unchanged_on_refl. } - ss. des_ifs. eapply Mem.unchanged_on_trans; cycle 1. - { eapply Mem.unchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } - ss. eapply Mem.free_unchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. - Qed. - - Lemma exists_vargs_vres - (ge1: Senv.t) (ge2: genv) - (MS: match_symbs ge1 ge2) - ef m1 vargs tr vretv m2 - (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) - e cp le m_c - (WFE: wf_env ge2 e) - : - (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) - (list_typ_to_typelist (sig_args (ef_sig ef))) vargs) /\ - (external_call ef ge2 vargs m_c tr vretv m_c). - Proof. - pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. - unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). - - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. - esplits. - + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. - + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. - - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. - esplits. - + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. - econs. 3: econs. - { instantiate (1:=v). destruct v; ss; try (econs; fail). - - destruct chunk; ss; inv H2; ss. - - destruct Archi.ptr64 eqn:ARCH. - + destruct chunk; ss; inv H2; ss; des_ifs. - * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. - eapply ptr_of_id_ofs_eval; eauto. - * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. - eapply ptr_of_id_ofs_eval; eauto. - + destruct chunk; ss; inv H2; ss; des_ifs. - * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. - eapply ptr_of_id_ofs_eval; eauto. - * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. - eapply ptr_of_id_ofs_eval; eauto. - * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. - eapply ptr_of_id_ofs_eval; eauto. - } - { rewrite EK1 in H2. - destruct v; ss. - - destruct chunk; ss; inv H2; ss. - - destruct chunk; ss. all: simpl_expr. inv H2. - - destruct chunk; ss. all: simpl_expr. - - destruct chunk; ss. inv H2. - - destruct chunk; ss. all: inv H2. - - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. - rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss; simpl_expr. - + unfold Cop.sem_cast. ss. rewrite Heq. auto. - + unfold Cop.sem_cast. ss. rewrite Heq. auto. - } - + econs. econs; auto. rewrite MS3; auto. rewrite EK1. - rewrite EK1 in H2. eapply match_symbs_eventval_match; eauto. - - esplits. - + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. - erewrite <- eventval_list_match_list_eventval_to_list_val. - 2:{ eapply match_senv_eventval_list_match in H; eauto. } - eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. - eapply match_senv_eventval_list_match; eauto. - + econs. eapply match_senv_eventval_list_match; eauto. - - esplits. - + econs. 3: econs. - * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. - eapply match_senv_eventval_match; eauto. - * erewrite eventval_match_val_to_eventval. 2: eapply H. - erewrite eventval_match_eventval_to_val. - 2:{ eapply match_senv_eventval_match; eauto. } - eapply eventval_match_sem_cast. eapply match_senv_eventval_match; eauto. - + econs. eapply match_senv_eventval_match; eauto. - Qed. - - Lemma eventval_list_match_eval_exprlist - (ge: genv) args targs vargs - (EMS: eventval_list_match ge args targs vargs) - e cp le m - (WF: wf_env ge e) - : - eval_exprlist ge e cp le m (list_eventval_to_list_expr args) - (list_eventval_to_typelist args) vargs. - Proof. - revert_until EMS. induction EMS; i; ss. econs. - econs; auto. - { clear dependent evl. clear tyl vl. inv H; try (simpl_expr; fail). - ss. eapply ptr_of_id_ofs_eval; auto. - } - { clear dependent evl. clear tyl vl. inv H; ss; try (simpl_expr; fail). - rewrite ptr_of_id_ofs_typeof. ss. - } - Qed. - - Lemma exists_vargs_vres_2 - (ge1: Senv.t) (ge2: genv) - (MS: match_symbs ge1 ge2) - ef m1 vargs tr vretv m2 - (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) - e cp le m_c - (WFE: wf_env ge2 e) - : - exists vargs2 vretv2, - (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) - (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs2) /\ - (external_call ef ge2 vargs2 m_c tr vretv2 m_c). - Proof. - pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. - unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). - - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. - esplits. - + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. - + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. - - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. - esplits. - + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. - econs. 3: econs. - { instantiate (1:=v). destruct v; ss; try (econs; fail). - - destruct chunk; ss; inv H2; ss. - - destruct Archi.ptr64 eqn:ARCH. - + destruct chunk; ss; inv H2; ss; des_ifs. - * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. - eapply ptr_of_id_ofs_eval; eauto. - * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. - eapply ptr_of_id_ofs_eval; eauto. - + destruct chunk; ss; inv H2; ss; des_ifs. - * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. - eapply ptr_of_id_ofs_eval; eauto. - * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. - eapply ptr_of_id_ofs_eval; eauto. - * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. - eapply ptr_of_id_ofs_eval; eauto. - } - { instantiate (1:=Val.load_result chunk v). rewrite EK1 in H2. rewrite EK1. - destruct v; ss. - - destruct chunk; ss; inv H2; ss. - - destruct chunk; ss. all: simpl_expr. - - destruct chunk; ss. all: simpl_expr. - - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. - rewrite ptr_of_id_ofs_typeof. simpl_expr. - } - + econs. econs; auto. rewrite MS3; auto. rewrite EK1. eapply match_symbs_eventval_match; eauto. - - esplits. - + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. - eapply eventval_list_match_eval_exprlist; eauto. - eapply match_senv_eventval_list_match; eauto. - + econs. eapply match_senv_eventval_list_match; eauto. - - esplits. - + econs. 3: econs. - * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. - eapply match_senv_eventval_match; eauto. - * inv H; ss; try (simpl_expr; fail). apply MS2 in H1. setoid_rewrite H1. - rewrite ptr_of_id_ofs_typeof. ss. - + econs. eapply match_senv_eventval_match; eauto. - Qed. - - Lemma known_obs_preserves_mem - ef ge m vargs tr vretv m' - (EK: external_call_known_observables ef ge m vargs tr vretv m') - : - m' = m. - Proof. - unfold external_call_known_observables in EK. des_ifs; des; inv EK; clarify. inv H; clarify. - Qed. - - Lemma meminj_first_order_public_first_order - ge m - (MFO: meminj_first_order (meminj_public ge) m) - : - public_first_order ge m. - Proof. - ii. apply MFO; auto. unfold meminj_public. apply Senv.find_invert_symbol in FIND. - rewrite FIND. rewrite PUBLIC. ss. - Qed. - - Lemma vals_public_eval_to_vargs - (ge: genv) ef vargs - (VP: vals_public ge (sig_args (ef_sig ef)) vargs) - e cp le m - (WFE: wf_env ge e) - : - eval_exprlist ge e cp le m - (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) - (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. - Proof. - induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. - - clear dependent l. clear dependent l'. - inv H; ss; try (simpl_expr; fail). - destruct H0 as (id & BP1 & BP2). - unfold senv_invert_symbol_total. rewrite BP1. - apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. - - clear dependent l. clear dependent l'. - inv H; ss; try (simpl_expr; fail). - destruct H0 as (id & BP1 & BP2). - unfold senv_invert_symbol_total. rewrite BP1. - rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss. - + unfold Cop.sem_cast. ss. rewrite Heq. ss. - + unfold Cop.sem_cast. ss. rewrite Heq. ss. - Qed. - - Lemma vals_public_eval_to_vargs_2 - (ge: genv) ef vargs - (VP: vals_public ge (sig_args (ef_sig ef)) vargs) - e cp le m - (WFE: wf_env ge e) - : - eval_exprlist ge e cp le m - (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) - (list_eventval_to_typelist (vals_to_eventvals ge vargs)) vargs. - Proof. - induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. - - clear dependent l. clear dependent l'. - inv H; ss; try (simpl_expr; fail). - destruct H0 as (id & BP1 & BP2). - unfold senv_invert_symbol_total. rewrite BP1. - apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. - - clear dependent l. clear dependent l'. - inv H; ss; try (simpl_expr; fail). - destruct H0 as (id & BP1 & BP2). - unfold senv_invert_symbol_total. rewrite BP1. - rewrite ptr_of_id_ofs_typeof. ss. - Qed. - - Lemma match_symbs_block_public - ge1 ge2 - (MS: match_symbs ge1 ge2) - b - (BP: block_public ge1 b) - : - block_public ge2 b. - Proof. - destruct MS as (MS1 & MS2 & MS3). destruct BP as (id & BP1 & BP2). - apply Senv.invert_find_symbol in BP1. apply MS2 in BP1. rewrite <- MS1 in BP2. - unfold block_public. esplits; eauto. apply Senv.find_invert_symbol; auto. - Qed. - - Lemma match_symbs_vals_public - ge1 ge2 - (MS: match_symbs ge1 ge2) - tys vargs - (VP: vals_public ge1 tys vargs) - : - vals_public ge2 tys vargs. - Proof. - induction VP; ss. econs; auto. clear VP IHVP. inv H; econs; auto. - eapply match_symbs_block_public; eauto. - Qed. - - Lemma match_symbs_vals_public_vals_to_eventvals - ge1 ge2 - (MS: match_symbs ge1 ge2) - tys vargs - (VP: vals_public ge1 tys vargs) - : - vals_to_eventvals ge1 vargs = vals_to_eventvals ge2 vargs. - Proof. - induction VP; ss. f_equal; auto. clear dependent l. clear dependent l'. - inv H; ss. destruct H0 as (id & BP1 & BP2). - unfold senv_invert_symbol_total at 1. des_ifs. - destruct MS as (MS0 & MS1 & MS2). - apply Senv.invert_find_symbol in Heq. apply MS1 in Heq. - unfold senv_invert_symbol_total at 1. apply Senv.find_invert_symbol in Heq. - rewrite Heq. auto. - Qed. - - Lemma match_symbs_vals_public_eval_to_vargs - ge1 (ge2: genv) - (MS: match_symbs ge1 ge2) - ef vargs - (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) - e cp le m - (WFE: wf_env ge2 e) - : - eval_exprlist ge2 e cp le m - (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) - (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. - Proof. - erewrite match_symbs_vals_public_vals_to_eventvals; eauto. - eapply vals_public_eval_to_vargs; auto. eapply match_symbs_vals_public; eauto. - Qed. - - Lemma match_symbs_vals_public_eval_to_vargs_2 - ge1 (ge2: genv) - (MS: match_symbs ge1 ge2) - ef vargs - (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) - e cp le m - (WFE: wf_env ge2 e) - : - eval_exprlist ge2 e cp le m - (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) - (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs. - Proof. - erewrite match_symbs_vals_public_vals_to_eventvals; eauto. - eapply vals_public_eval_to_vargs_2; auto. eapply match_symbs_vals_public; eauto. - Qed. - - Lemma extcall_unkowns_vals_public - ef ge m vargs - (EC: external_call_unknowns ef ge m vargs) - : - vals_public ge (sig_args (ef_sig ef)) vargs. - Proof. - unfold external_call_unknowns in EC. des_ifs; ss; auto. - all: destruct EC as (EC1 & EC2); auto. - Qed. - - - Lemma mem_unchanged_wunchanged - P m m' - (UCH: Mem.unchanged_on P m m') - : - wunchanged_on P m m'. - Proof. inv UCH. econs; eauto. Qed. - - Lemma meminj_public_not_public_not_mapped - ge cnt_cur - (NP: Senv.public_symbol ge cnt_cur = false) - cnt_cur_b - (FIND: Senv.find_symbol ge cnt_cur = Some cnt_cur_b) - : - forall b ofs, meminj_public ge b <> Some (cnt_cur_b, ofs). - Proof. - ii. unfold meminj_public in H. des_ifs. - assert (i = cnt_cur). - { eapply Senv.find_symbol_injective; eauto. apply Senv.invert_find_symbol; auto. } - subst i. rewrite NP in Heq0. ss. - Qed. - - - Lemma wunchanged_on_exists_mem_free_gen - m1 b lo hi cp m2 - (FREE: Mem.free m1 b lo hi cp = Some m2) - (P: block -> Prop) m_c - (WCH: wunchanged_on (fun b _ => P b) m1 m_c) - (NGB: P b) - : - exists m_c', Mem.free m_c b lo hi cp = Some m_c'. - Proof. - hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. - hexploit Mem.range_perm_free. - 3:{ intros (m0 & F). eexists; eapply F. } - - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. - - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. - Qed. - - Lemma wunchanged_on_exists_mem_free_2 - m1 b lo hi cp m2 - (FREE: Mem.free m1 b lo hi cp = Some m2) - ge m_c - (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) - (NGB: Senv.invert_symbol ge b = None) - : - exists m_c', Mem.free m_c b lo hi cp = Some m_c'. - Proof. eapply wunchanged_on_exists_mem_free_gen; eauto. eapply WCH. ss. Qed. - - Lemma wunchanged_on_free_preserves_gen - P m m' - (WU : wunchanged_on P m m') - b lo hi cp m1 m1' - (FREE: Mem.free m b lo hi cp = Some m1) - (FREE': Mem.free m' b lo hi cp = Some m1') - : - wunchanged_on P m1 m1'. - Proof. - inv WU. econs. - - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. - - i. assert (VB: Mem.valid_block m b0). - { eapply Mem.valid_block_free_2; eauto. } - split; i. - + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. - eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. - hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. - + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. - eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. - hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. - - i. assert (VB: Mem.valid_block m b0). - { eapply Mem.valid_block_free_2; eauto. } - split; i. - + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. - eapply Mem.free_can_access_block_inj_2; eauto. - + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. - eapply Mem.free_can_access_block_inj_2; eauto. - Qed. - - Lemma wunchanged_on_exists_mem_free_list_gen - l m1 cp m2 - (FREE: Mem.free_list m1 l cp = Some m2) - (P: block -> Prop) m_c - (WCH: wunchanged_on (fun b _ => P b) m1 m_c) - (NGB: Forall P (map (fun x => fst (fst x)) l)) - : - exists m_c', Mem.free_list m_c l cp = Some m_c'. - Proof. - revert_until l. induction l; i; ss. eauto. - destruct a as ((b & lo) & hi). ss. inv NGB. des_ifs; ss. - 2:{ exfalso. hexploit wunchanged_on_exists_mem_free_gen. 2: eapply WCH. all: eauto. - intros. des. rewrite H in Heq; clarify. - } - hexploit IHl. eapply FREE. 2: eapply H2. - { instantiate (1:=m). eapply wunchanged_on_free_preserves_gen; eauto. } - eauto. - Qed. - - Lemma wunchanged_on_exists_mem_free_list_2 - l m1 cp m2 - (FREE: Mem.free_list m1 l cp = Some m2) - ge m_c - (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) - (NGB: not_global_blks ge (map (fun x => fst (fst x)) l)) - : - exists m_c', Mem.free_list m_c l cp = Some m_c'. - Proof. eapply wunchanged_on_exists_mem_free_list_gen; eauto. ss. Qed. - - Lemma wunchanged_on_free_list_preserves_gen - P m m' - (WU: wunchanged_on P m m') - l cp m_f m_f' - (FREE: Mem.free_list m l cp = Some m_f) - (FREE': Mem.free_list m' l cp = Some m_f') - : - wunchanged_on P m_f m_f'. - Proof. - move l after m. revert_until l. induction l; ii; ss. clarify. - des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves_gen; eauto. - Qed. - - Lemma meminj_not_alloc_external_call - j m1 - (NA: meminj_not_alloc j m1) - ef ge vargs tr vretv m2 - (EC: external_call ef ge vargs m1 tr vretv m2) - : - meminj_not_alloc j m2. - Proof. - unfold meminj_not_alloc in *. i. apply NA. clear NA. - eapply external_call_nextblock in EC. etransitivity. 2: eapply H. auto. - Qed. - - Lemma public_first_order_meminj_first_order - (ge: Senv.t) m - (FO: public_first_order ge m) - : - meminj_first_order (meminj_public ge) m. - Proof. - ii. unfold meminj_public in H. des_ifs. eapply FO; eauto. - apply Senv.invert_find_symbol; auto. - Qed. - - Lemma list_length_filter_le - A P (l: list A) - : - (Datatypes.length (filter P l) <= Datatypes.length l)%nat. - Proof. - induction l; ss. des_ifs; ss; auto. rewrite <- Nat.succ_le_mono. auto. - Qed. - -End PROOF. +(* Section CODEPROOFS. *) + +(* Lemma ptr_of_id_ofs_eval *) +(* (ge: genv) id ofs e b cp le m *) +(* (GE1: wf_env ge e) *) +(* (GE2: Senv.find_symbol ge id = Some b) *) +(* : *) +(* eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). *) +(* Proof. *) +(* specialize (GE1 id). rewrite GE2 in GE1. *) +(* unfold ptr_of_id_ofs. destruct (Archi.ptr64) eqn:ARCH. *) +(* - eapply eval_Ebinop. eapply eval_Eaddrof. eapply eval_Evar_global; eauto. *) +(* simpl_expr. *) +(* simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. *) +(* rewrite Ptrofs.of_int64_to_int64; auto. *) +(* - eapply eval_Ebinop. eapply eval_Eaddrof. eapply eval_Evar_global; eauto. *) +(* simpl_expr. *) +(* simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. *) +(* erewrite Ptrofs.agree32_of_ints_eq; auto. apply Ptrofs.agree32_to_int; auto. *) +(* Qed. *) + +(* Lemma code_mem_delta_cons *) +(* (ge: Senv.t) cp k d sn *) +(* : *) +(* code_mem_delta ge cp (k :: d) sn = *) +(* Ssequence (code_mem_delta_kind ge cp k) (code_mem_delta ge cp d sn). *) +(* Proof. unfold code_mem_delta. ss. Qed. *) + +(* Lemma code_mem_delta_app *) +(* (ge: Senv.t) cp d1 d2 sn *) +(* : *) +(* code_mem_delta ge cp (d1 ++ d2) sn = (code_mem_delta ge cp d1 (code_mem_delta ge cp d2 sn)). *) +(* Proof. *) +(* revert sn d2. induction d1; intros; ss. *) +(* rewrite ! code_mem_delta_cons. erewrite IHd1. auto. *) +(* Qed. *) + +(* Lemma type_of_chunk_val_to_expr *) +(* (ge: Senv.t) ch ty v e *) +(* (WF: wf_chunk_val_b ch v) *) +(* (CT: chunk_to_type ch = Some ty) *) +(* (CVE: chunk_val_to_expr ge ch v = Some e) *) +(* : *) +(* typeof e = ty. *) +(* Proof. unfold chunk_val_to_expr in CVE. rewrite CT in CVE. des_ifs. Qed. *) + +(* Definition val_is_int (v: val) := (match v with | Vint _ => True | _ => False end). *) +(* Definition val_is_not_int (v: val) := (match v with | Vint _ => False | _ => True end). *) + +(* Lemma val_cases v: (val_is_int v) \/ (val_is_not_int v). *) +(* Proof. destruct v; ss; auto. Qed. *) + +(* Lemma sem_cast_chunk_val *) +(* (ge: Senv.t) m ch ty v e *) +(* (WF: wf_chunk_val_b ch v) *) +(* (CT: chunk_to_type ch = Some ty) *) +(* (CVE: chunk_val_to_expr ge ch v = Some e) *) +(* (NINT: val_is_not_int v) *) +(* : *) +(* Cop.sem_cast v (typeof e) ty m = Some v. *) +(* Proof. *) +(* erewrite type_of_chunk_val_to_expr; eauto. apply Cop.cast_val_casted. clear - WF CT NINT. *) +(* unfold wf_chunk_val_b, wf_chunk_val_b in WF. des_ifs; ss; inv CT; econs. *) +(* Qed. *) + +(* Definition cast_chunk_int (ch: memory_chunk) (i: int): val := *) +(* match ch with *) +(* | Mint8signed => Vint (Int.sign_ext 8 i) *) +(* | Mint8unsigned => Vint (Int.zero_ext 8 i) *) +(* | Mint16signed => Vint (Int.sign_ext 16 i) *) +(* | Mint16unsigned => Vint (Int.zero_ext 16 i) *) +(* | Mint32 => Vint i *) +(* | _ => Vundef *) +(* end. *) + +(* Lemma chunk_val_to_expr_eval *) +(* (ge: genv) ch v exp e cp le m *) +(* (EXP: chunk_val_to_expr ge ch v = Some exp) *) +(* (WF: wf_chunk_val_b ch v) *) +(* : *) +(* eval_expr ge e cp le m exp v. *) +(* Proof. unfold chunk_val_to_expr in EXP. des_ifs; ss; econs. Qed. *) + +(* Lemma wf_chunk_val_chunk_to_type *) +(* ch v *) +(* (WF: wf_chunk_val_b ch v) *) +(* : *) +(* exists ty, chunk_to_type ch = Some ty. *) +(* Proof. unfold wf_chunk_val_b in WF. des_ifs; ss; eauto. Qed. *) + +(* Lemma wf_chunk_val_chunk_val_to_expr *) +(* (ge: Senv.t) ch v *) +(* (WF: wf_chunk_val_b ch v) *) +(* : *) +(* exists ve, chunk_val_to_expr ge ch v = Some ve. *) +(* Proof. *) +(* unfold chunk_val_to_expr. exploit wf_chunk_val_chunk_to_type; eauto. *) +(* intros (ty & TY). rewrite TY. unfold wf_chunk_val_b in WF. des_ifs; ss; eauto. *) +(* Qed. *) + +(* Lemma code_mem_delta_storev_correct *) +(* (ge: genv) f k e le m m' *) +(* d *) +(* (WFE: wf_env ge e) *) +(* (STORE: mem_delta_apply_storev (Some m) d = Some m') *) +(* (WF: wf_mem_delta_storev_b ge (comp_of f) d) *) +(* : *) +(* step1 ge (State f (code_mem_delta_storev ge (comp_of f) d) k e le m) *) +(* E0 (State f Sskip k e le m'). *) +(* Proof. *) +(* unfold wf_mem_delta_storev_b in WF. des_ifs. rename m0 into ch, i into ofs. ss. *) +(* exploit wf_chunk_val_chunk_to_type; eauto. intros (ty & TY). *) +(* exploit wf_chunk_val_chunk_val_to_expr; eauto. intros (ve & EXPR). *) +(* rewrite H, Heq, TY, EXPR. *) +(* destruct (val_cases v) as [INT | NINT]. *) +(* { unfold val_is_int in INT. des_ifs. clear INT. eapply step_assign. *) +(* - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval; auto. *) +(* eapply Genv.invert_find_symbol; eauto. *) +(* - instantiate (1:=Vint i). eapply chunk_val_to_expr_eval; eauto. *) +(* - instantiate (1:=cast_chunk_int ch i). erewrite type_of_chunk_val_to_expr; eauto. *) +(* unfold chunk_to_type in TY. destruct ch; ss; inv TY. *) +(* + unfold Cop.sem_cast. ss. des_ifs. *) +(* + unfold Cop.sem_cast. ss. des_ifs. *) +(* + unfold Cop.sem_cast. ss. des_ifs. *) +(* + unfold Cop.sem_cast. ss. des_ifs. *) +(* + unfold Cop.sem_cast. ss. des_ifs. *) +(* - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. *) +(* rewrite <- STORE. apply Pos.eqb_eq in WF. subst c. destruct ch; ss. *) +(* + rewrite Mem.store_int8_sign_ext. auto. *) +(* + rewrite Mem.store_int8_zero_ext. auto. *) +(* + rewrite Mem.store_int16_sign_ext. auto. *) +(* + rewrite Mem.store_int16_zero_ext. auto. *) +(* } *) +(* { rewrite WF, H0. ss. eapply step_assign. *) +(* - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval; auto. *) +(* eapply Genv.invert_find_symbol; eauto. *) +(* - instantiate (1:=v). eapply chunk_val_to_expr_eval; eauto. *) +(* - ss. eapply sem_cast_chunk_val; eauto. *) +(* - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. *) +(* apply Pos.eqb_eq in WF. clarify. *) +(* } *) +(* Qed. *) + +(* Lemma wf_mem_delta_storev_false_is_skip *) +(* (ge: Senv.t) cp d *) +(* (NWF: wf_mem_delta_storev_b ge cp d = false) *) +(* : *) +(* code_mem_delta_storev ge cp d = Sskip. *) +(* Proof. destruct d as [[[ch ptr] v] cp0]. ss. des_ifs. Qed. *) + +(* Lemma code_mem_delta_correct *) +(* (ge: genv) *) +(* f k e le m m' *) +(* d snext *) +(* (WFE: wf_env ge e) *) +(* (APPD: mem_delta_apply_wf ge (comp_of f) d (Some m) = Some m') *) +(* : *) +(* (star step1 ge (State f (code_mem_delta ge (comp_of f) d snext) k e le m) *) +(* E0 (State f snext k e le m')). *) +(* Proof. *) +(* revert m m' snext APPD. induction d; intros. *) +(* { unfold mem_delta_apply_wf in APPD. ss. inv APPD. unfold code_mem_delta. ss. econs 1. } *) +(* rewrite mem_delta_apply_wf_cons in APPD. rewrite code_mem_delta_cons. *) +(* des_ifs. *) +(* - exploit mem_delta_apply_wf_some; eauto. intros (mi & APPD0). rewrite APPD0 in APPD. *) +(* destruct a; ss. econs 2. *) +(* { eapply step_seq. } *) +(* econs 2. *) +(* { eapply code_mem_delta_storev_correct; eauto. } *) +(* take_step. eapply IHd; eauto. eauto. auto. *) +(* - destruct a; ss. *) +(* rewrite wf_mem_delta_storev_false_is_skip; auto. *) +(* all: take_step; take_step; eapply IHd; eauto. *) +(* Qed. *) + +(* Lemma code_bundle_trace_spec *) +(* (ge: genv) cp cnt tr *) +(* f e le m k *) +(* : *) +(* star step1 ge *) +(* (State f (code_bundle_trace ge cp cnt tr) k e le m) *) +(* E0 *) +(* (State f (switch_bundle_events ge cnt cp tr) *) +(* (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge cnt cp tr)) Sskip k) *) +(* e le m). *) +(* Proof. *) +(* econs 2. *) +(* { unfold code_bundle_trace, Swhile. eapply step_loop. } *) +(* econs 2. *) +(* { eapply step_seq. } *) +(* econs 2. *) +(* { eapply step_ifthenelse. simpl_expr. ss. } *) +(* rewrite Int.eq_false; ss. econs 2. *) +(* { eapply step_skip_seq. } *) +(* econs 1. all: eauto. *) +(* Qed. *) + +(* End CODEPROOFS. *) + + +(* Section GENV. *) + +(* Definition symbs_public (ge1 ge2: Senv.t) := (forall id : ident, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id). *) +(* Definition symbs_find (ge1 ge2: Senv.t) := forall id b, Senv.find_symbol ge1 id = Some b -> Senv.find_symbol ge2 id = Some b. *) +(* Definition symbs_volatile (ge1 ge2: Senv.t) := forall b, Senv.block_is_volatile ge2 b = Senv.block_is_volatile ge1 b. *) + +(* Definition match_symbs (ge1 ge2: Senv.t) := symbs_public ge1 ge2 /\ symbs_find ge1 ge2 /\ symbs_volatile ge1 ge2. *) + +(* Lemma match_symbs_meminj_public *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* : *) +(* meminj_public ge1 = meminj_public ge2. *) +(* Proof. *) +(* destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). unfold meminj_public. extensionalities b. des_ifs. *) +(* - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. *) +(* apply Senv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. *) +(* - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. *) +(* apply Senv.find_invert_symbol in x0. clarify. *) +(* - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. *) +(* apply Senv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. *) +(* - exfalso. rewrite MSYMB1 in Heq1. apply Senv.public_symbol_exists in Heq1. des. *) +(* exploit MSYMB2; eauto. intros. apply Senv.invert_find_symbol in Heq0. clarify. *) +(* apply Senv.find_invert_symbol in Heq1. clarify. *) +(* Qed. *) + +(* Lemma match_symbs_wf_mem_delta_storev *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp0 d *) +(* : *) +(* wf_mem_delta_storev_b ge1 cp0 d = wf_mem_delta_storev_b ge2 cp0 d. *) +(* Proof. *) +(* destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). *) +(* destruct d as [[[ch ptr] v] cp]. ss. des_ifs. *) +(* - do 2 f_equal. apply Senv.invert_find_symbol, MSYMB2, Senv.find_invert_symbol in Heq. clarify. *) +(* - exfalso. apply Senv.invert_find_symbol, MSYMB2, Senv.find_invert_symbol in Heq. clarify. *) +(* - destruct (Senv.public_symbol ge2 i0) eqn:PUB; ss. *) +(* exfalso. rewrite MSYMB1 in PUB. apply Senv.public_symbol_exists in PUB. des. *) +(* exploit MSYMB2; eauto. intros. apply Senv.invert_find_symbol in Heq0. clarify. *) +(* apply Senv.find_invert_symbol in PUB. clarify. *) +(* Qed. *) + +(* Lemma match_symbs_wf_mem_delta_kind *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp *) +(* : *) +(* wf_mem_delta_kind_b ge1 cp = wf_mem_delta_kind_b ge2 cp. *) +(* Proof. unfold wf_mem_delta_kind_b. extensionalities d. des_ifs. apply match_symbs_wf_mem_delta_storev; auto. Qed. *) + +(* Lemma match_symbs_get_wf_mem_delta *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp d *) +(* : *) +(* get_wf_mem_delta ge1 cp d = get_wf_mem_delta ge2 cp d. *) +(* Proof. unfold get_wf_mem_delta. erewrite match_symbs_wf_mem_delta_kind; eauto. Qed. *) + +(* Lemma match_symbs_mem_delta_apply_wf *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp d m *) +(* : *) +(* mem_delta_apply_wf ge1 cp d m = mem_delta_apply_wf ge2 cp d m. *) +(* Proof. unfold mem_delta_apply_wf. erewrite match_symbs_get_wf_mem_delta; eauto. Qed. *) + +(* Lemma match_symbs_code_mem_delta_kind *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp *) +(* : *) +(* code_mem_delta_kind ge1 cp = code_mem_delta_kind ge2 cp. *) +(* Proof. *) +(* extensionalities k. unfold code_mem_delta_kind. des_ifs. *) +(* destruct d as [[[ch ptr] v] cp0]. ss. destruct ptr; ss. *) +(* destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). *) +(* destruct (Senv.invert_symbol ge1 b) eqn:INV1. *) +(* { exploit Senv.invert_find_symbol; eauto. intros FIND1. *) +(* exploit MSYMB2; eauto. intros FIND2. exploit Senv.find_invert_symbol; eauto. intros INV2. *) +(* rewrite INV2. destruct (chunk_to_type ch) eqn:CHTY; auto. *) +(* des_ifs. *) +(* - apply andb_prop in Heq0, Heq2. des. apply andb_prop in Heq0, Heq2. des. *) +(* assert (chunk_val_to_expr ge2 ch v = chunk_val_to_expr ge1 ch v). *) +(* { unfold chunk_val_to_expr. rewrite CHTY. clear - Heq6. *) +(* unfold wf_chunk_val_b in Heq6. des_ifs. *) +(* } *) +(* rewrite Heq, Heq1 in H. clarify. *) +(* - exfalso. apply andb_prop in Heq0. des. apply andb_prop in Heq0. des. *) +(* clarify. rewrite ! andb_true_r in Heq2. rewrite MSYMB1 in Heq2. clarify. *) +(* - exfalso. apply andb_prop in Heq0. des. apply andb_prop in Heq0. des. *) +(* apply (wf_chunk_val_chunk_val_to_expr (ge2)) in Heq3; eauto. des; clarify. *) +(* - exfalso. apply andb_prop in Heq2. des. apply andb_prop in Heq2. des. *) +(* clarify. rewrite ! andb_true_r in Heq0. rewrite MSYMB1 in Heq2; clarify. *) +(* - exfalso. apply andb_prop in Heq1. des. apply andb_prop in Heq1. des. *) +(* apply (wf_chunk_val_chunk_val_to_expr (ge1)) in Heq3; eauto. des; clarify. *) +(* } *) +(* { des_ifs. *) +(* exfalso. apply andb_prop in Heq2. des. apply andb_prop in Heq2. des. *) +(* rewrite MSYMB1 in Heq2. eapply Senv.public_symbol_exists in Heq2. des. *) +(* exploit MSYMB2. eapply Heq2. intros FIND4. eapply Senv.invert_find_symbol in Heq. clarify. *) +(* exploit Senv.find_invert_symbol. apply Heq2. intros INV3. clarify. *) +(* } *) +(* Qed. *) + +(* Lemma match_symbs_code_mem_delta *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp d s *) +(* : *) +(* code_mem_delta ge1 cp d s = code_mem_delta ge2 cp d s. *) +(* Proof. unfold code_mem_delta. erewrite match_symbs_code_mem_delta_kind; eauto. Qed. *) + +(* Lemma match_symbs_code_bundle_call *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp tr id evargs sg d *) +(* : *) +(* code_bundle_call ge1 cp tr id evargs sg d = code_bundle_call ge2 cp tr id evargs sg d. *) +(* Proof. unfold code_bundle_call. erewrite match_symbs_code_mem_delta; eauto. Qed. *) + +(* Lemma match_symbs_code_bundle_return *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp tr evr d *) +(* : *) +(* code_bundle_return ge1 cp tr evr d = code_bundle_return ge2 cp tr evr d. *) +(* Proof. unfold code_bundle_return. erewrite match_symbs_code_mem_delta; eauto. Qed. *) + +(* Lemma match_symbs_code_bundle_builtin *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp tr ef evargs d *) +(* : *) +(* code_bundle_builtin ge1 cp tr ef evargs d = code_bundle_builtin ge2 cp tr ef evargs d. *) +(* Proof. unfold code_bundle_builtin. erewrite match_symbs_code_mem_delta; eauto. Qed. *) + +(* Lemma match_symbs_code_bundle_events *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp *) +(* : *) +(* code_bundle_event ge1 cp = code_bundle_event ge2 cp. *) +(* Proof. *) +(* extensionalities be. unfold code_bundle_event. des_ifs. *) +(* eapply match_symbs_code_bundle_call; auto. eapply match_symbs_code_bundle_return; auto. eapply match_symbs_code_bundle_builtin; auto. *) +(* Qed. *) + +(* Lemma match_symbs_switch_bundle_events *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp cnt tr *) +(* : *) +(* switch_bundle_events ge1 cnt cp tr = switch_bundle_events ge2 cnt cp tr. *) +(* Proof. unfold switch_bundle_events. erewrite match_symbs_code_bundle_events; eauto. Qed. *) + +(* Lemma match_symbs_code_bundle_trace *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* cp cnt tr *) +(* : *) +(* code_bundle_trace ge1 cp cnt tr = code_bundle_trace ge2 cp cnt tr. *) +(* Proof. unfold code_bundle_trace. erewrite match_symbs_switch_bundle_events; eauto. Qed. *) + + +(* Lemma match_symbs_symbols_inject *) +(* ge1 ge2 *) +(* (MSYMB: match_symbs ge1 ge2) *) +(* : *) +(* symbols_inject (meminj_public ge1) ge1 ge2. *) +(* Proof. *) +(* destruct MSYMB as (MS0 & MS1 & MS2). unfold symbols_inject. splits; auto. *) +(* - i. unfold meminj_public in H. des_ifs. split; auto. *) +(* - i. exists b1. split; auto. unfold meminj_public. apply Senv.find_invert_symbol in H0. *) +(* rewrite H0. rewrite H. auto. *) +(* - i. unfold meminj_public in H. des_ifs. *) +(* Qed. *) + +(* End GENV. *) + + +(* Section PROOF. *) + +(* Lemma filter_filter *) +(* A (l: list A) (p q: A -> bool) *) +(* : *) +(* filter q (filter p l) = filter (fun a => (p a) && (q a)) l. *) +(* Proof. *) +(* induction l; ss. des_ifs; ss; clarify. *) +(* f_equal. auto. *) +(* Qed. *) + +(* Lemma get_wf_mem_delta_idem *) +(* ge cp d *) +(* : *) +(* get_wf_mem_delta ge cp (get_wf_mem_delta ge cp d) = get_wf_mem_delta ge cp d. *) +(* Proof. unfold get_wf_mem_delta. rewrite filter_filter. f_equal. extensionalities k. apply andb_diag. Qed. *) + +(* Lemma mem_delta_apply_wf_get_wf_mem_delta *) +(* ge cp d m *) +(* : *) +(* mem_delta_apply_wf ge cp d m = mem_delta_apply_wf ge cp (get_wf_mem_delta ge cp d) m. *) +(* Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_idem. auto. Qed. *) + +(* Lemma wf_mem_delta_kind_is_wf *) +(* ge cp k *) +(* (WF: wf_mem_delta_kind_b ge cp k) *) +(* : *) +(* mem_delta_kind_inj_wf cp (meminj_public ge) k. *) +(* Proof. unfold wf_mem_delta_kind_b in WF. des_ifs. unfold wf_mem_delta_storev_b in WF. ss. des_ifs. apply Pos.eqb_eq in WF. auto. Qed. *) + +(* Lemma get_wf_mem_delta_is_wf *) +(* cp ge d *) +(* : *) +(* mem_delta_inj_wf cp (meminj_public ge) (get_wf_mem_delta ge cp d). *) +(* Proof. induction d; ss. des_ifs. econs; auto. apply wf_mem_delta_kind_is_wf; auto. Qed. *) + +(* Lemma mem_delta_apply_establish_inject2 *) +(* (ge: Senv.t) k m0 m0' *) +(* (INJ: Mem.inject k m0 m0') *) +(* (INCR: inject_incr (meminj_public ge) k) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) +(* d cp m1 *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) *) +(* (FO: public_first_order ge m1) *) +(* : *) +(* exists m1', mem_delta_apply_wf ge cp d (Some m0') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. *) +(* Proof. *) +(* unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. eapply mem_delta_apply_establish_inject; eauto. *) +(* apply get_wf_mem_delta_is_wf. *) +(* unfold public_first_order in FO. ii. unfold meminj_public in H. des_ifs. apply Senv.invert_find_symbol in Heq. *) +(* eapply FO; eauto. *) +(* Qed. *) + +(* Lemma mem_delta_apply_establish_inject_preprocess_gen *) +(* (ge: Senv.t) (k: meminj) m0 m0' *) +(* (INJ: Mem.inject k m0 m0') *) +(* pch pb pofs pv pcp m0'' *) +(* (PRE: Mem.store pch m0' pb pofs pv pcp = Some m0'') *) +(* (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) *) +(* (INCR: inject_incr (meminj_public ge) k) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) +(* d cp m1 *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) *) +(* : *) +(* exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ *) +(* (meminj_first_order (meminj_public ge) m1 -> Mem.inject (meminj_public ge) m1 m1'). *) +(* Proof. *) +(* unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. *) +(* eapply mem_delta_apply_establish_inject_preprocess_gen; eauto. *) +(* apply get_wf_mem_delta_is_wf. *) +(* Qed. *) + +(* Lemma mem_delta_apply_establish_inject_preprocess2 *) +(* (ge: Senv.t) (k: meminj) m0 m0' *) +(* (INJ: Mem.inject k m0 m0') *) +(* pch pb pofs pv pcp m0'' *) +(* (PRE: Mem.store pch m0' pb pofs pv pcp = Some m0'') *) +(* (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) *) +(* (INCR: inject_incr (meminj_public ge) k) *) +(* (NALLOC: meminj_not_alloc (meminj_public ge) m0) *) +(* d cp m1 *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) *) +(* (FO: public_first_order ge m1) *) +(* : *) +(* exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. *) +(* Proof. *) +(* hexploit mem_delta_apply_establish_inject_preprocess_gen; eauto. i. des. *) +(* esplits; eauto. apply H0. ii. unfold meminj_public in H1. des_ifs. *) +(* eapply FO; eauto. apply Senv.invert_find_symbol; auto. *) +(* Qed. *) + +(* End PROOF. *) + + + +(* Section DEFINITIONS. *) + +(* Definition meminj_same_block (j : meminj) := *) +(* forall b1 b2 del, j b1 = Some (b2, del) -> b1 = b2. *) + +(* Definition not_global_blks (ge: Senv.t) (ebs: list block) := *) +(* Forall (fun b => Senv.invert_symbol ge b = None) ebs. *) + +(* Definition blocks_of_env2 ge e : list block := (map (fun x => fst (fst x)) (blocks_of_env ge e)). *) + +(* Definition not_inj_blks (j: meminj) (ebs: list block) := *) +(* Forall (fun b => j b = None) ebs. *) + +(* Lemma not_global_is_not_inj_bloks *) +(* ge l *) +(* (NGB: not_global_blks ge l) *) +(* : *) +(* not_inj_blks (meminj_public ge) l. *) +(* Proof. induction NGB. ss. econs; eauto. unfold meminj_public. des_ifs. Qed. *) + +(* Definition eq_policy (ge1: Asm.genv) (ge2: genv) := *) +(* Genv.genv_policy ge1 = Genv.genv_policy ge2. *) + +(* End DEFINITIONS. *) + + + +(* Section PROOF. *) + +(* (* Properties *) *) +(* Lemma eventval_match_transl *) +(* (ge: Senv.t) *) +(* ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* eventval_match ge ev (typ_of_type (typ_to_type ty)) (eventval_to_val ge ev). *) +(* Proof. *) +(* inversion EM; subst; simpl; try constructor. *) +(* setoid_rewrite H0. unfold Tptr in *. destruct Archi.ptr64; auto. *) +(* Qed. *) + +(* Lemma eventval_match_eventval_to_val *) +(* (ge: Senv.t) *) +(* ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* eventval_to_val ge ev = v. *) +(* Proof. inversion EM; subst; simpl; auto. setoid_rewrite H0. auto. Qed. *) + +(* Lemma eventval_list_match_transl *) +(* (ge: Senv.t) *) +(* evs tys vs *) +(* (EM: eventval_list_match ge evs tys vs) *) +(* : *) +(* eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs). *) +(* Proof. induction EM; simpl. constructor. constructor; auto. eapply eventval_match_transl; eauto. Qed. *) + +(* Lemma eventval_list_match_transl_val *) +(* (ge: Senv.t) *) +(* evs tys vs *) +(* (EM: eventval_list_match ge evs tys vs) *) +(* : *) +(* eventval_list_match ge evs tys (list_eventval_to_list_val ge evs). *) +(* Proof. induction EM; simpl. constructor. constructor; auto. erewrite eventval_match_eventval_to_val; eauto. Qed. *) + +(* Lemma typ_type_typ *) +(* (ge: Senv.t) *) +(* ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* typ_of_type (typ_to_type ty) = ty. *) +(* Proof. inversion EM; simpl; auto. subst. unfold Tptr. destruct Archi.ptr64; simpl; auto. Qed. *) + +(* Lemma eventval_to_expr_val_eval *) +(* (ge: genv) en cp temp m ev ty v *) +(* (WFENV: wf_env ge en) *) +(* (EM: eventval_match ge ev ty v) *) +(* (* (WFGE: wf_eventval_ge ge ev) *) *) +(* : *) +(* eval_expr ge en cp temp m (eventval_to_expr ev) (eventval_to_val ge ev). *) +(* Proof. destruct ev; simpl in *; try constructor. inv EM. setoid_rewrite H4. eapply ptr_of_id_ofs_eval; auto. Qed. *) + +(* Lemma sem_cast_eventval_match *) +(* (ge: Senv.t) v ty vv m *) +(* (EM: eventval_match ge v (typ_of_type (typ_to_type ty)) vv) *) +(* : *) +(* Cop.sem_cast vv (typeof (eventval_to_expr v)) (typ_to_type ty) m = Some vv. *) +(* Proof. *) +(* destruct ty; simpl in *; inversion EM; subst; simpl in *; simpl_expr. *) +(* all: try rewrite ptr_of_id_ofs_typeof; simpl. *) +(* all: try (cbn; auto). *) +(* all: unfold Tptr in *; destruct Archi.ptr64 eqn:ARCH; try congruence. *) +(* { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } *) +(* { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } *) +(* { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } *) +(* { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } *) +(* Qed. *) + +(* Lemma list_eventval_to_expr_val_eval *) +(* (ge: genv) en cp temp m evs tys *) +(* (* (WFENV: Forall (wf_eventval_env en) evs) *) *) +(* (WFENV: wf_env ge en) *) +(* (EMS: eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs)) *) +(* : *) +(* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) (list_eventval_to_list_val ge evs). *) +(* Proof. *) +(* revert en cp temp m WFENV. *) +(* match goal with | [H: eventval_list_match _ _ ?t ?v |- _] => remember t as tys2; remember v as vs2 end. *) +(* revert tys Heqtys2 Heqvs2. induction EMS; intros; subst; simpl in *. *) +(* { destruct tys; simpl in *. constructor. congruence. } *) +(* inversion Heqvs2; clear Heqvs2; subst; simpl in *. *) +(* destruct tys; simpl in Heqtys2. congruence with Heqtys2. *) +(* inversion Heqtys2; clear Heqtys2; subst; simpl in *. *) +(* econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. *) +(* (* eapply eventval_match_wf_eventval_ge; eauto. *) *) +(* eapply sem_cast_eventval_match; eauto. *) +(* Qed. *) + +(* Lemma eventval_match_eventval_to_type *) +(* (ge: Senv.t) *) +(* ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* eventval_match ge ev (typ_of_type (eventval_to_type ev)) v. *) +(* Proof. inversion EM; subst; simpl; auto. Qed. *) + +(* Lemma list_eventval_match_eventval_to_type *) +(* (ge: Senv.t) *) +(* evs tys vs *) +(* (ESM: eventval_list_match ge evs tys vs) *) +(* : *) +(* eventval_list_match ge evs (typlist_of_typelist (list_eventval_to_typelist evs)) vs. *) +(* Proof. induction ESM; simpl. constructor. constructor; auto. eapply eventval_match_eventval_to_type; eauto. Qed. *) + +(* Lemma val_load_result_idem *) +(* ch v *) +(* : *) +(* Val.load_result ch (Val.load_result ch v) = Val.load_result ch v. *) +(* Proof. *) +(* destruct ch, v; simpl; auto. *) +(* 5,6,7: destruct Archi.ptr64; simpl; auto. *) +(* 1,3: rewrite Int.sign_ext_idem; auto. *) +(* 3,4: rewrite Int.zero_ext_idem; auto. *) +(* all: lia. *) +(* Qed. *) + +(* Lemma val_load_result_aux *) +(* F V (ge: Genv.t F V) *) +(* ev ch v *) +(* (EM: eventval_match ge ev (type_of_chunk ch) (Val.load_result ch v)) *) +(* : *) +(* eventval_match ge ev (type_of_chunk ch) (Val.load_result ch (eventval_to_val ge ev)). *) +(* Proof. *) +(* inversion EM; subst; simpl in *; auto. *) +(* 1,2,3,4: rewrite H1, H2; rewrite val_load_result_idem; auto. *) +(* rewrite H3, H. rewrite H0. rewrite val_load_result_idem. auto. *) +(* Qed. *) + +(* Lemma eventval_match_proj_rettype *) +(* (ge: Senv.t) *) +(* ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* eventval_match ge ev (proj_rettype (rettype_of_type (typ_to_type ty))) v. *) +(* Proof. *) +(* inversion EM; subst; simpl; try constructor. *) +(* unfold Tptr in *. destruct Archi.ptr64; simpl; auto. *) +(* Qed. *) + +(* (* Lemma sem_cast_eventval *) *) +(* (* (ge: cgenv) v m *) *) +(* (* (WFEV: wf_eventval_ge ge v) *) *) +(* (* : *) *) +(* (* Cop.sem_cast (eventval_to_val ge v) (typeof (eventval_to_expr v)) (eventval_to_type v) m = Some (eventval_to_val ge v). *) *) +(* (* Proof. rewrite typeof_eventval_to_expr_type. destruct v; simpl in *; simpl_expr. destruct WFEV. rewrite H. simpl_expr. Qed. *) *) + +(* (* Lemma list_eventval_to_expr_val_eval2 *) *) +(* (* (ge: genv) en cp temp m evs *) *) +(* (* (WFENV: Forall (wf_eventval_env en) evs) *) *) +(* (* (WFGE: Forall (wf_eventval_ge ge) evs) *) *) +(* (* : *) *) +(* (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_eventval_to_typelist evs) (list_eventval_to_list_val ge evs). *) *) +(* (* Proof. *) *) +(* (* move evs at top. revert ge en cp temp m WFENV WFGE. induction evs; intros; simpl in *. *) *) +(* (* constructor. *) *) +(* (* inversion WFENV; clear WFENV; subst. inversion WFGE; clear WFGE; subst. *) *) +(* (* econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. *) *) +(* (* apply sem_cast_eventval; auto. *) *) +(* (* Qed. *) *) + +(* Lemma eventval_match_sem_cast *) +(* (* F V (ge: Genv.t F V) *) *) +(* (ge: genv) *) +(* m ev ty v *) +(* (EM: eventval_match ge ev ty v) *) +(* : *) +(* (* Cop.sem_cast (eventval_to_val ge ev) (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some (eventval_to_val ge ev). *) *) +(* Cop.sem_cast v (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some v. *) +(* Proof. *) +(* inversion EM; subst; simpl; try constructor. all: simpl_expr. *) +(* rewrite ptr_of_id_ofs_typeof. unfold Tptr. unfold Cop.sem_cast. destruct Archi.ptr64 eqn:ARCH; simpl. *) +(* - rewrite ARCH; auto. *) +(* - rewrite ARCH; auto. *) +(* Qed. *) + +(* (* Lemma list_eventval_to_expr_val_eval_typs *) *) +(* (* (ge: genv) en cp temp m evs tys vs *) *) +(* (* (WFENV: Forall (wf_eventval_env en) evs) *) *) +(* (* (EMS: eventval_list_match ge evs tys vs) *) *) +(* (* : *) *) +(* (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) vs. *) *) +(* (* Proof. *) *) +(* (* revert en cp temp m WFENV. *) *) +(* (* induction EMS; intros; subst; simpl in *. constructor. *) *) +(* (* inversion WFENV; clear WFENV; subst. *) *) +(* (* econstructor; eauto. 2: eapply eventval_match_sem_cast; eauto. *) *) +(* (* exploit eventval_match_eventval_to_val. eauto. intros. rewrite <- H0. eapply eventval_to_expr_val_eval; auto. *) *) +(* (* eapply eventval_match_wf_eventval_ge; eauto. *) *) +(* (* Qed. *) *) + +(* Lemma sem_cast_ptr *) +(* b ofs m *) +(* : *) +(* Cop.sem_cast (Vptr b ofs) (Tpointer Tvoid noattr) (typ_to_type Tptr) m = Some (Vptr b ofs). *) +(* Proof. *) +(* unfold Tptr. destruct Archi.ptr64 eqn:ARCH; unfold Cop.sem_cast; simpl; rewrite ARCH; auto. *) +(* Qed. *) + +(* Lemma sem_cast_proj_rettype *) +(* (ge: genv) evres rty res m *) +(* (EVM: eventval_match ge evres (proj_rettype rty) res) *) +(* : *) +(* Cop.sem_cast (eventval_to_val ge evres) *) +(* (typeof (eventval_to_expr evres)) *) +(* (rettype_to_type rty) m *) +(* = Some (eventval_to_val ge evres). *) +(* Proof. *) +(* destruct rty; simpl in *. *) +(* { eapply eventval_match_sem_cast. eauto. erewrite eventval_match_eventval_to_val; eauto. } *) +(* { inv EVM; simpl; simpl_expr. *) +(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) +(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) +(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) +(* } *) +(* { inv EVM; simpl; simpl_expr. *) +(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) +(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) +(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) +(* } *) +(* { inv EVM; simpl; simpl_expr. *) +(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) +(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) +(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) +(* } *) +(* { inv EVM; simpl; simpl_expr. *) +(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) +(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) +(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) +(* } *) +(* { inv EVM; simpl; simpl_expr. *) +(* setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. *) +(* unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. *) +(* unfold Cop.sem_cast. simpl. rewrite ARCH. auto. *) +(* } *) +(* Qed. *) + +(* Lemma type_of_params_eq *) +(* params ts *) +(* (PARSIGS : list_typ_to_list_type ts = map snd params) *) +(* : *) +(* type_of_params params = list_typ_to_typelist ts. *) +(* Proof. *) +(* revert params PARSIGS. induction ts; ii; ss. *) +(* { destruct params; ss. } *) +(* destruct params; ss. destruct p; ss. clarify. f_equal. auto. *) +(* Qed. *) + +(* Lemma match_senv_eventval_match *) +(* (ge0 ge1: Senv.t) *) +(* (MS: match_symbs ge0 ge1) *) +(* ev ty v *) +(* (EM: eventval_match ge0 ev ty v) *) +(* : *) +(* eventval_match ge1 ev ty v. *) +(* Proof. destruct MS as (MS0 & MS1 & MS2). inv EM; try econs; auto. rewrite MS0. auto. Qed. *) + +(* Lemma match_senv_eventval_list_match *) +(* (ge0 ge1: Senv.t) *) +(* (MS: match_symbs ge0 ge1) *) +(* evs tys vs *) +(* (EM: eventval_list_match ge0 evs tys vs) *) +(* : *) +(* eventval_list_match ge1 evs tys vs. *) +(* Proof. induction EM; ss. econs; auto. econs; auto. eapply match_senv_eventval_match; eauto. Qed. *) + +(* Lemma unbundle_trace_app *) +(* tr1 tr2 *) +(* : *) +(* unbundle_trace (tr1 ++ tr2) = (unbundle_trace tr1) ++ (unbundle_trace tr2). *) +(* Proof. induction tr1; ss. rewrite <- app_assoc. f_equal. auto. Qed. *) + +(* Lemma allowed_call_gen_function *) +(* cp (ge_i: Asm.genv) (ge_c: genv) next cnt params tr f_i f_c *) +(* (GE: symbs_find ge_i ge_c) *) +(* (GEPOL: eq_policy ge_i ge_c) *) +(* (GEN: f_c = gen_function ge_i cnt params tr f_i) *) +(* (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) *) +(* (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.Internal f_i)) *) +(* (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = Some (Internal f_c)) *) +(* : *) +(* Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). *) +(* Proof. *) +(* unfold Genv.allowed_call in *. des; [left | right]. *) +(* - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. *) +(* - subst. unfold Genv.allowed_cross_call in *. des. *) +(* unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. *) +(* specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. *) +(* { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. *) +(* apply GE. auto. *) +(* } *) +(* { i. rewrite FINDF_C in H. clarify. } *) +(* { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. *) +(* rewrite <- ALLOW1. ss. *) +(* } *) +(* Qed. *) + +(* Lemma allowed_call_gen_function_external *) +(* cp (ge_i: Asm.genv) (ge_c: genv) next ef *) +(* (GE: symbs_find ge_i ge_c) *) +(* (GEPOL: eq_policy ge_i ge_c) *) +(* (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) *) +(* (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.External ef)) *) +(* (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = *) +(* Some (External ef *) +(* (list_typ_to_typelist (sig_args (ef_sig ef))) *) +(* (rettype_to_type (sig_res (ef_sig ef))) *) +(* (sig_cc (ef_sig ef)))) *) +(* : *) +(* Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). *) +(* Proof. *) +(* unfold Genv.allowed_call in *. des; [left | right]. *) +(* - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. *) +(* - unfold Genv.allowed_cross_call in *. des. *) +(* unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. *) +(* specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. *) +(* { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. *) +(* apply GE. auto. *) +(* } *) +(* { i. rewrite FINDF_C in H. clarify. } *) +(* { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. *) +(* rewrite <- ALLOW1. ss. *) +(* } *) +(* Qed. *) + +(* Lemma eventval_list_match_list_eventval_to_list_val *) +(* (ge: Senv.t) evargs tys vargs *) +(* (EVMS: eventval_list_match ge evargs tys vargs) *) +(* : *) +(* list_eventval_to_list_val ge evargs = vargs. *) +(* Proof. *) +(* induction EVMS; ss. f_equal; auto. *) +(* eapply eventval_match_eventval_to_val. eauto. *) +(* Qed. *) + +(* Lemma match_symbs_eventval_match *) +(* ge0 ge1 ev ty v *) +(* (MS: match_symbs ge0 ge1) *) +(* (EVM: eventval_match ge0 ev ty v) *) +(* : *) +(* eventval_match ge1 ev ty v. *) +(* Proof. *) +(* destruct MS as (MS0 & MS1 & MS2). inv EVM; econs; auto. rewrite MS0; auto. *) +(* Qed. *) + +(* Lemma match_symbs_eventval_list_match *) +(* ge0 ge1 ev ty v *) +(* (MS: match_symbs ge0 ge1) *) +(* (EVM: eventval_list_match ge0 ev ty v) *) +(* : *) +(* eventval_list_match ge1 ev ty v. *) +(* Proof. *) +(* induction EVM. econs. econs; auto. eapply match_symbs_eventval_match; eauto. *) +(* Qed. *) + +(* Lemma alloc_variables_exists *) +(* ge cp e m l *) +(* : *) +(* exists e' m', alloc_variables ge cp e m l e' m'. *) +(* Proof. *) +(* revert ge cp e m. induction l; ii. *) +(* { do 2 eexists. econs 1. } *) +(* destruct a as (id & ty). *) +(* destruct (Mem.alloc m cp 0 (sizeof ge ty)) as (m0 & b0) eqn:ALLOC. *) +(* specialize (IHl ge cp (PTree.set id (b0, ty) e) m0). des. *) +(* do 2 eexists. econs 2. eapply ALLOC. eapply IHl. *) +(* Qed. *) + +(* Lemma access_mode_typ_to_type *) +(* s *) +(* : *) +(* exists ch, access_mode (typ_to_type s) = By_value ch. *) +(* Proof. destruct s; ss; eauto. Qed. *) + +(* Lemma bind_parameters_exists *) +(* (ge: genv) cp (e: env) m params vargs *) +(* (INENV: Forall (fun '(id, ty) => *) +(* exists b, (e ! id = Some (b, ty)) /\ *) +(* (forall ch, access_mode ty = By_value ch -> *) +(* Mem.valid_access m ch b 0 Writable (Some cp))) *) +(* params) *) +(* sg *) +(* (PARSIGS: list_typ_to_list_type sg = map snd params) *) +(* evargs *) +(* (EMS: eventval_list_match ge evargs sg vargs) *) +(* : *) +(* exists m', bind_parameters ge cp e m params vargs m'. *) +(* Proof. *) +(* revert e m vargs INENV sg PARSIGS evargs EMS. induction params; ii. *) +(* { ss. inv EMS; ss. eexists. econs. } *) +(* destruct a as (id & ty). inv INENV. des. ss. *) +(* destruct sg; ss. rename t into s. clarify. inv EMS. *) +(* destruct (access_mode_typ_to_type s) as (ch & ACCM). *) +(* specialize (H0 _ ACCM). hexploit Mem.valid_access_store. apply H0. instantiate (1:=v1). *) +(* intros (m0 & STORE). *) +(* assert *) +(* (FA: Forall *) +(* (fun '(id, ty) => *) +(* exists b : block, *) +(* e ! id = Some (b, ty) /\ *) +(* (forall ch : memory_chunk, access_mode ty = By_value ch -> *) +(* Mem.valid_access m0 ch b 0 Writable (Some cp))) params). *) +(* { clear - H2 STORE. move H2 before cp. revert_until H2. induction H2; ii; ss. *) +(* econs; eauto. des_ifs. des. esplits; eauto. i. eapply Mem.store_valid_access_1; eauto. *) +(* } *) +(* hexploit IHparams. apply FA. 1,2: eauto. intros. des. exists m'. *) +(* econs; eauto. econs; eauto. *) +(* Qed. *) + +(* Lemma alloc_variables_wf_id *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* (WF: list_norepet (var_names params)) *) +(* : *) +(* forall id bt, (~ In id (var_names params)) -> (e ! id = Some bt) -> (e' ! id = Some bt). *) +(* Proof. *) +(* revert WF. induction EA; ii; ss. *) +(* apply Classical_Prop.not_or_and in H0. des. inv WF. *) +(* apply IHEA; auto. rewrite PTree.gso; auto. *) +(* Qed. *) + +(* Lemma alloc_variables_valid_access *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* : *) +(* forall b' ch' ofs' p' cp', Mem.valid_access m ch' b' ofs' p' cp' -> *) +(* Mem.valid_access m' ch' b' ofs' p' cp'. *) +(* Proof. *) +(* i. assert (WF: (b' < Mem.nextblock m)%positive). *) +(* { unfold Mem.valid_access in H. des. destruct (Unusedglob.IS.MSet.Raw.MX.lt_dec b' (Mem.nextblock m)); auto. *) +(* exfalso. unfold Mem.range_perm in H. specialize (H ofs'). *) +(* eapply (Mem.nextblock_noaccess _ _ ofs' Cur) in n. *) +(* exploit H. *) +(* { pose proof (size_chunk_pos ch'). lia. } *) +(* i. unfold Mem.perm in x0. rewrite n in x0. ss. *) +(* } *) +(* revert_until EA. induction EA; ii; ss. *) +(* apply IHEA. *) +(* { eapply Mem.valid_access_alloc_other; eauto. } *) +(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) +(* Qed. *) + +(* Lemma alloc_variables_forall *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* (WF: list_norepet (var_names params)) *) +(* : *) +(* Forall (fun '(id, ty) => *) +(* exists b, (e' ! id = Some (b, ty)) /\ *) +(* (forall ch, access_mode ty = By_value ch -> *) +(* Mem.valid_access m' ch b 0 Writable (Some cp))) params. *) +(* Proof. *) +(* revert WF. induction EA; ii; ss. *) +(* inv WF. econs; eauto. *) +(* hexploit alloc_variables_wf_id. apply EA. auto. apply H2. apply PTree.gss. *) +(* i. esplits; eauto. *) +(* i. eapply alloc_variables_valid_access. apply EA. *) +(* apply Mem.valid_access_freeable_any. eapply Mem.valid_access_alloc_same; eauto. lia. *) +(* { ss. clear - H1. destruct ty; ss; clarify. des_ifs; clarify; ss. des_ifs; clarify; ss. unfold Mptr. des_ifs. } *) +(* exists 0. ss. *) +(* Qed. *) + +(* Lemma assign_loc_valid_access *) +(* ge cp ty m b ofs bit v m' *) +(* (AL: assign_loc ge cp ty m b ofs bit v m') *) +(* ch' b' ofs' perm' cp' *) +(* (VA: Mem.valid_access m ch' b' ofs' perm' (Some cp')) *) +(* : *) +(* Mem.valid_access m' ch' b' ofs' perm' (Some cp'). *) +(* Proof. *) +(* inv AL. *) +(* - eapply Mem.store_valid_access_1; eauto. *) +(* - eapply Mem.storebytes_valid_access_1; eauto. *) +(* - inv H. eapply Mem.store_valid_access_1; eauto. *) +(* Qed. *) + +(* Lemma bind_parameters_valid_access *) +(* (ge: genv) cp (e: env) m params vargs m' *) +(* (BIND: bind_parameters ge cp e m params vargs m') *) +(* ch b ofs perm cp' *) +(* (VA: Mem.valid_access m ch b ofs perm (Some cp')) *) +(* : *) +(* Mem.valid_access m' ch b ofs perm (Some cp'). *) +(* Proof. *) +(* revert_until BIND. induction BIND; ii; ss. *) +(* apply IHBIND. eapply assign_loc_valid_access; eauto. *) +(* Qed. *) + +(* Lemma mem_delta_apply_wf_valid_access *) +(* ge cp d m m' *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) +(* ch b ofs perm cp' *) +(* (VA: Mem.valid_access m ch b ofs perm cp') *) +(* : *) +(* Mem.valid_access m' ch b ofs perm cp'. *) +(* Proof. *) +(* move d before ge. revert_until d. induction d; ii. *) +(* { unfold mem_delta_apply_wf in APPD. ss; clarify. } *) +(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs. *) +(* - destruct a; ss. hexploit mem_delta_apply_wf_some; eauto. *) +(* intros (m0 & STOREV). rewrite STOREV in APPD. *) +(* eapply IHd. apply APPD. *) +(* unfold mem_delta_apply_storev in STOREV. des_ifs. *) +(* unfold Mem.storev in STOREV. des_ifs. *) +(* eapply Mem.store_valid_access_1; eauto. *) +(* - eapply IHd; eauto. *) +(* Qed. *) + +(* Lemma bind_parameters_mem_load *) +(* ge cp e m0 params vargs m1 *) +(* (BIND: bind_parameters ge cp e m0 params vargs m1) *) +(* : *) +(* forall ch b ofs cp', *) +(* (forall id b_e ty, (e ! id = Some (b_e, ty) -> b <> b_e)) -> *) +(* (Mem.load ch m1 b ofs cp' = Mem.load ch m0 b ofs cp'). *) +(* Proof. *) +(* induction BIND; ii; ss. *) +(* rewrite IHBIND; auto. *) +(* inv H0. *) +(* - eapply Mem.load_store_other. eapply H3. left. ii. clarify. specialize (H1 _ _ _ H). clarify. *) +(* - eapply Mem.load_storebytes_other. eapply H7. left. ii. clarify. specialize (H1 _ _ _ H). clarify. *) +(* Qed. *) + +(* Lemma alloc_variables_mem_load *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* : *) +(* forall ch b ofs cp', *) +(* (b < Mem.nextblock m)%positive -> *) +(* (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). *) +(* Proof. *) +(* induction EA; ii; ss. *) +(* rewrite IHEA. *) +(* { eapply Mem.load_alloc_unchanged; eauto. } *) +(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) +(* Qed. *) + +(* Lemma alloc_variables_old_blocks *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* : *) +(* forall b, (b < Mem.nextblock m)%positive -> *) +(* (forall id b' ty, e ! id = Some (b', ty) -> b <> b') -> *) +(* (forall id b' ty, e' ! id = Some (b', ty) -> b <> b'). *) +(* Proof. *) +(* induction EA; i. *) +(* { ii; clarify. specialize (H0 _ _ _ H1). clarify. } *) +(* hexploit Mem.alloc_result; eauto. intros; clarify. *) +(* eapply IHEA. 3: eapply H2. *) +(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) +(* { i. destruct (Pos.eq_dec id id1). *) +(* - clarify. rewrite PTree.gss in H3. clarify. lia. *) +(* - rewrite PTree.gso in H3; auto. eapply H1; eauto. *) +(* } *) +(* Qed. *) + +(* Lemma mem_delta_apply_wf_mem_load *) +(* ge cp d m m' *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) +(* : *) +(* forall id ch b ofs cp', *) +(* Senv.invert_symbol ge b = Some id -> *) +(* Senv.public_symbol ge id = false -> *) +(* (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). *) +(* Proof. *) +(* move d before ge. revert_until d. induction d; ii. *) +(* { unfold mem_delta_apply_wf in APPD. ss. clarify. } *) +(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs. *) +(* { destruct a; ss. unfold wf_mem_delta_storev_b in Heq. des_ifs. ss. *) +(* hexploit mem_delta_apply_wf_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. *) +(* erewrite IHd. 2: eauto. 2: eauto. all: auto. *) +(* destruct (Pos.eq_dec b b0). *) +(* - clarify. *) +(* - erewrite Mem.load_store_other. 2: eauto. all: auto. *) +(* } *) +(* { eapply IHd; eauto. } *) +(* Qed. *) + +(* Lemma nat64_int64_add_one *) +(* n *) +(* (BOUND: Z.of_nat n < Int64.modulus) *) +(* : *) +(* Int64.add (nat64 n) Int64.one = nat64 (n + 1). *) +(* Proof. *) +(* unfold nat64. rewrite Nat2Z.inj_add. ss. *) +(* assert (N: Z.of_nat n = Int64.unsigned (Int64.repr (Z.of_nat n))). *) +(* { symmetry. apply Int64.unsigned_repr. split. apply Zle_0_nat. *) +(* unfold Int64.max_unsigned. lia. *) +(* } *) +(* assert (ONE: 1 = (Int64.unsigned (Int64.repr 1))). *) +(* { ss. } *) +(* rewrite N at 2. rewrite ONE. rewrite <- Int64.add_unsigned. ss. *) +(* Qed. *) + +(* Lemma mem_free_list_impl1 *) +(* blks m cp m_f *) +(* (FREE: Mem.free_list m blks cp = Some m_f) *) +(* : *) +(* Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks. *) +(* Proof. *) +(* Local Opaque Mem.can_access_block. *) +(* revert_until blks. induction blks; ii; ss. des_ifs. ss. econs. *) +(* 2:{ cut (Forall (fun '(b0, lo, hi) => Mem.range_perm m0 b0 lo hi Cur Freeable /\ Mem.can_access_block m0 b0 (Some cp)) blks); cycle 1. *) +(* { eapply IHblks; eauto. } *) +(* clear - Heq. intros FA. revert_until blks. induction blks; ii; ss. *) +(* destruct a as ((ba & loa) & hia). ss. inv FA. des; clarify. econs. *) +(* { *) +(* clear IHblks. split. *) +(* - unfold Mem.range_perm in *. ii. eapply Mem.perm_free_3. eauto. eauto. *) +(* - eapply Mem.free_can_access_block_inj_2; eauto. *) +(* } *) +(* eapply IHblks; eauto. *) +(* } *) +(* split. *) +(* - eapply Mem.free_range_perm; eauto. *) +(* - eapply Mem.free_can_access_block_1; eauto. *) +(* Local Transparent Mem.can_access_block. *) +(* Qed. *) + +(* Lemma mem_free_list_impl2 *) +(* blks m cp *) +(* (NR: list_norepet (map (fun x => fst (fst x)) blks)) *) +(* (FA: Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks) *) +(* : *) +(* exists m_f, (Mem.free_list m blks cp = Some m_f). *) +(* Proof. *) +(* Local Opaque Mem.can_access_block. *) +(* revert_until blks. induction blks; ii; ss; eauto. *) +(* inv FA. inv NR. des_ifs; des. *) +(* 2:{ exfalso. destruct (Mem.range_perm_free _ _ _ _ _ H1 H0) as (m0 & FREE). clarify. } *) +(* eapply IHblks; clear IHblks; eauto. ss. clear - H2 H3 Heq. *) +(* revert_until blks. induction blks; ii; ss. inv H2. des_ifs; ss. des. econs; eauto. *) +(* clear IHblks H4. apply Classical_Prop.not_or_and in H3. des. split. *) +(* - unfold Mem.range_perm in *. ii. hexploit Mem.perm_free_inv; eauto. ii. des; clarify. *) +(* - eapply Mem.free_can_access_block_inj_1; eauto. *) +(* Local Transparent Mem.can_access_block. *) +(* Qed. *) + +(* Lemma list_map_norepet_rev *) +(* A (l: list A) B (f: A -> B) *) +(* (NR: list_norepet (map f l)) *) +(* : *) +(* list_norepet l. *) +(* Proof. *) +(* revert NR. induction l; ii; ss. econs. inv NR. econs; eauto. *) +(* ii. apply H1; clear H1. apply in_map; auto. *) +(* Qed. *) + +(* Lemma alloc_variables_wunchanged_on *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* : *) +(* wunchanged_on (fun b _ => Mem.valid_block m b) m m'. *) +(* Proof. *) +(* induction EA. apply wunchanged_on_refl. *) +(* eapply wunchanged_on_implies in IHEA. *) +(* { eapply wunchanged_on_trans. 2: eauto. eapply alloc_wunchanged_on. eauto. } *) +(* { ii. ss. } *) +(* Qed. *) + +(* Lemma alloc_variables_exists_free_list *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* (ENV1: forall id1 id2 b1 b2 t1 t2, (id1 <> id2) -> (e ! id1 = Some (b1, t1)) -> (e ! id2 = Some (b2, t2)) -> (b1 <> b2)) *) +(* (ENV2: forall id b t, (e ! id = Some (b, t)) -> (Mem.valid_block m b)) *) +(* m_f0 *) +(* (FREE: Mem.free_list m' (blocks_of_env ge e) cp = Some m_f0) *) +(* : *) +(* exists m_f, Mem.free_list m' (blocks_of_env ge e') cp = Some m_f. *) +(* Proof. *) +(* revert_until EA. induction EA; ii; ss; eauto. *) +(* assert (exists m_f0, Mem.free_list m2 (blocks_of_env ge (PTree.set id (b1, ty) e)) cp = Some m_f0); cycle 1. *) +(* { des. eapply IHEA; clear IHEA; eauto. *) +(* - i. destruct (Pos.eqb_spec id id1); clarify. *) +(* + rewrite PTree.gss in H2. rewrite PTree.gso in H3; auto. clarify. specialize (ENV2 _ _ _ H3). *) +(* ii. clarify. apply Mem.fresh_block_alloc in H. clarify. *) +(* + destruct (Pos.eqb_spec id id2); clarify. *) +(* * rewrite PTree.gso in H2; auto. rewrite PTree.gss in H3; auto. clarify. specialize (ENV2 _ _ _ H2). *) +(* ii. clarify. apply Mem.fresh_block_alloc in H. clarify. *) +(* * rewrite PTree.gso in H2, H3; auto. hexploit ENV1. 2: eapply H2. 2: eapply H3. all: auto. *) +(* - i. destruct (Pos.eqb_spec id id0); clarify. *) +(* + rewrite PTree.gss in H1. clarify. eapply Mem.valid_new_block; eauto. *) +(* + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). eapply Mem.valid_block_alloc; eauto. *) +(* } *) +(* clear IHEA. eapply mem_free_list_impl2. *) +(* { unfold blocks_of_env. rewrite map_map. apply list_map_norepet. *) +(* { eapply list_map_norepet_rev. apply PTree.elements_keys_norepet. } *) +(* { i. unfold block_of_binding. des_ifs. ss. apply PTree.elements_complete in H0, H1. *) +(* destruct (Pos.eqb_spec id i); clarify. *) +(* - rewrite PTree.gss in H0. clarify. destruct (Pos.eqb_spec i i0); clarify. *) +(* + rewrite PTree.gss in H1; clarify. *) +(* + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). ii; clarify. *) +(* apply Mem.fresh_block_alloc in H. clarify. *) +(* - rewrite PTree.gso in H0; auto. destruct (Pos.eqb_spec id i0); clarify. *) +(* + rewrite PTree.gss in H1. clarify. specialize (ENV2 _ _ _ H0). ii; clarify. *) +(* apply Mem.fresh_block_alloc in H. clarify. *) +(* + rewrite PTree.gso in H1; auto. eapply ENV1. 2: apply H0. 2: apply H1. ii; clarify. *) +(* } *) +(* } *) +(* { apply mem_free_list_impl1 in FREE. rewrite Forall_forall in *. i. *) +(* assert ((x = (b1, 0%Z, sizeof ge ty)) \/ (In x (blocks_of_env ge e))). *) +(* { clear - H0. unfold blocks_of_env in *. apply list_in_map_inv in H0. des. *) +(* destruct x0 as (xid & xb & xt). apply PTree.elements_complete in H1. clarify. *) +(* destruct (Pos.eqb_spec id xid); clarify. *) +(* - rewrite PTree.gss in H1. clarify. left; auto. *) +(* - rewrite PTree.gso in H1; auto. right. apply in_map. apply PTree.elements_correct. auto. *) +(* } *) +(* des. *) +(* - clarify. split. *) +(* + ii. eapply perm_wunchanged_on. eapply alloc_variables_wunchanged_on; eauto. *) +(* { ss. eapply Mem.valid_new_block; eauto. } *) +(* { eapply Mem.perm_alloc_2; eauto. } *) +(* + rewrite <- wunchanged_on_own. 2: eapply alloc_variables_wunchanged_on; eauto. *) +(* eapply Mem.owned_new_block; eauto. eapply Mem.valid_new_block; eauto. *) +(* - eapply FREE. eauto. *) +(* } *) +(* Qed. *) + +(* Lemma assign_loc_wunchanged_on *) +(* ge cp ty m b ofs bit v m' *) +(* (AL: assign_loc ge cp ty m b ofs bit v m') *) +(* : *) +(* wunchanged_on (fun _ _ => True) m m'. *) +(* Proof. *) +(* inv AL. *) +(* - eapply store_wunchanged_on; eauto. *) +(* - eapply storebytes_wunchanged_on; eauto. *) +(* - inv H. eapply store_wunchanged_on; eauto. *) +(* Qed. *) + +(* Lemma bind_parameters_wunchanged_on *) +(* (ge: genv) cp (e: env) m params vargs m' *) +(* (BIND: bind_parameters ge cp e m params vargs m') *) +(* : *) +(* wunchanged_on (fun _ _ => True) m m'. *) +(* Proof. *) +(* induction BIND. apply wunchanged_on_refl. eapply wunchanged_on_trans. 2: apply IHBIND. *) +(* eapply assign_loc_wunchanged_on; eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_exists_free *) +(* m m' *) +(* (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') *) +(* b lo hi cp m_f *) +(* (FREE: Mem.free m b lo hi cp = Some m_f) *) +(* : *) +(* exists m_f', Mem.free m' b lo hi cp = Some m_f'. *) +(* Proof. *) +(* hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. *) +(* hexploit Mem.range_perm_free. *) +(* 3:{ intros (m0 & F). eexists; eapply F. } *) +(* - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. eapply Mem.perm_valid_block; eauto. *) +(* - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. *) +(* Qed. *) + +(* Lemma assign_loc_perm *) +(* ge cp ty m b ofs bit v m' *) +(* (AL: assign_loc ge cp ty m b ofs bit v m') *) +(* b' o' C P *) +(* (PERM: Mem.perm m b' o' C P) *) +(* : *) +(* Mem.perm m' b' o' C P. *) +(* Proof. *) +(* inv AL. *) +(* - eapply Mem.perm_store_1; eauto. *) +(* - eapply Mem.perm_storebytes_1; eauto. *) +(* - inv H. eapply Mem.perm_store_1; eauto. *) +(* Qed. *) + +(* Lemma assign_loc_own *) +(* ge cp ty m b ofs bit v m' *) +(* (AL: assign_loc ge cp ty m b ofs bit v m') *) +(* b' cp' *) +(* (OWN: Mem.can_access_block m b' cp') *) +(* : *) +(* Mem.can_access_block m' b' cp'. *) +(* Proof. *) +(* inv AL. *) +(* - rewrite <- Mem.store_can_access_block_inj; eauto. *) +(* - eapply Mem.storebytes_can_access_block_inj_1; eauto. *) +(* - inv H. rewrite <- Mem.store_can_access_block_inj; eauto. *) +(* Qed. *) + +(* Lemma assign_loc_exists_free *) +(* ge cp ty m b ofs bit v m' *) +(* (AL: assign_loc ge cp ty m b ofs bit v m') *) +(* b' lo hi cp' m_f *) +(* (FREE: Mem.free m b' lo hi cp' = Some m_f) *) +(* : *) +(* exists m_f, Mem.free m' b' lo hi cp' = Some m_f. *) +(* Proof. *) +(* hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. *) +(* hexploit Mem.range_perm_free. *) +(* 3:{ intros (m0 & F). eexists; eapply F. } *) +(* - unfold Mem.range_perm in *. i. eapply assign_loc_perm; eauto. *) +(* - eapply assign_loc_own; eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_free_preserves *) +(* m m' *) +(* (WU : wunchanged_on (fun (b : block) (_ : Z) => Mem.valid_block m b) m m') *) +(* b lo hi cp m1 m1' *) +(* (FREE: Mem.free m b lo hi cp = Some m1) *) +(* (FREE': Mem.free m' b lo hi cp = Some m1') *) +(* : *) +(* wunchanged_on (fun (b0 : block) (_ : Z) => Mem.valid_block m1 b0) m1 m1'. *) +(* Proof. *) +(* inv WU. econs. *) +(* - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. *) +(* - i. assert (VB: Mem.valid_block m b0). *) +(* { eapply Mem.valid_block_free_2; eauto. } *) +(* split; i. *) +(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. *) +(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) +(* hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. *) +(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. *) +(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) +(* hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. *) +(* - i. assert (VB: Mem.valid_block m b0). *) +(* { eapply Mem.valid_block_free_2; eauto. } *) +(* split; i. *) +(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) +(* eapply Mem.free_can_access_block_inj_2; eauto. *) +(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) +(* eapply Mem.free_can_access_block_inj_2; eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_exists_mem_free_list *) +(* m m' *) +(* (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') *) +(* l cp m_f *) +(* (FREE: Mem.free_list m l cp = Some m_f) *) +(* : *) +(* exists m_f', Mem.free_list m' l cp = Some m_f'. *) +(* Proof. *) +(* move l after m. revert_until l. induction l; ii; ss; eauto. des_ifs. *) +(* 2:{ exfalso. hexploit wunchanged_on_exists_free. 2: eapply Heq0. 2: auto. *) +(* 2:{ intros. des. rewrite H in Heq; clarify. } *) +(* auto. *) +(* } *) +(* hexploit IHl. 2: eapply FREE. *) +(* { instantiate (1:=m0). eapply wunchanged_on_free_preserves; eauto. } *) +(* eauto. *) +(* Qed. *) + +(* Lemma mem_free_list_wunchanged_on *) +(* x m l cp m' *) +(* (FL: Mem.free_list m l cp = Some m') *) +(* (WF: Forall (fun '(b, lo, hi) => (x <= b)%positive) l) *) +(* : *) +(* wunchanged_on (fun b _ => (b < x)%positive) m m'. *) +(* Proof. *) +(* move WF before x. revert_until WF. induction WF; i; ss. clarify. apply wunchanged_on_refl. des_ifs. *) +(* hexploit IHWF; eauto. i. eapply wunchanged_on_trans. 2: eauto. *) +(* eapply free_wunchanged_on; eauto. *) +(* i. lia. *) +(* Qed. *) + +(* Lemma wunchanged_on_free_list_preserves *) +(* m m' *) +(* (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') *) +(* l cp m_f m_f' *) +(* (FREE: Mem.free_list m l cp = Some m_f) *) +(* (FREE': Mem.free_list m' l cp = Some m_f') *) +(* : *) +(* wunchanged_on (fun b _ => Mem.valid_block m_f b) m_f m_f'. *) +(* Proof. *) +(* move l after m. revert_until l. induction l; ii; ss. clarify. *) +(* des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves; eauto. *) +(* Qed. *) + +(* Lemma mem_delta_apply_wf_wunchanged_on *) +(* ge cp d m m' *) +(* (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') *) +(* P *) +(* : *) +(* wunchanged_on P m m'. *) +(* Proof. *) +(* revert_until d. induction d; ii; ss. *) +(* { cbn in APPD. clarify. apply wunchanged_on_refl. } *) +(* rewrite mem_delta_apply_wf_cons in APPD. des_ifs. *) +(* - hexploit mem_delta_apply_wf_some; eauto. intros (m0 & ST). rewrite ST in APPD. *) +(* specialize (IHd _ _ APPD). unfold mem_delta_apply_kind in ST. unfold mem_delta_apply_storev in ST. des_ifs. *) +(* ss. des_ifs. ss. eapply wunchanged_on_trans. eapply store_wunchanged_on. eapply ST. *) +(* eapply wunchanged_on_implies. eapply IHd. ss. *) +(* - eauto. *) +(* Unshelve. all: exact 0%nat. *) +(* Qed. *) + +(* Lemma alloc_variables_fresh_blocks *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* x *) +(* (X: (x <= Mem.nextblock m)%positive) *) +(* (FA: Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e)) *) +(* : *) +(* Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e'). *) +(* Proof. *) +(* revert_until EA. induction EA; ii; ss. specialize (IHEA x). *) +(* eapply IHEA; clear IHEA. *) +(* { erewrite Mem.nextblock_alloc; eauto. lia. } *) +(* apply Forall_forall. rewrite Forall_forall in FA. ii. specialize (FA x0). des_ifs. *) +(* unfold blocks_of_env in H0. apply list_in_map_inv in H0. des. destruct x0 as (xid & xb & xt). *) +(* apply PTree.elements_complete in H1. destruct (Pos.eqb_spec id xid); clarify. *) +(* - rewrite PTree.gss in H1. ss. clarify. erewrite Mem.alloc_result. 2: eauto. auto. *) +(* - rewrite PTree.gso in H1; auto. apply FA. rewrite H0. unfold blocks_of_env. apply in_map. *) +(* apply PTree.elements_correct; auto. *) +(* Qed. *) + +(* Lemma alloc_variables_one_fresh_block *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* (NR: list_norepet (var_names params)) *) +(* xid xb xt *) +(* (NOT: e ! xid = None) *) +(* (GET: e' ! xid = Some (xb, xt)) *) +(* : *) +(* ~ (Mem.valid_block m xb). *) +(* Proof. *) +(* revert_until EA. induction EA; i. clarify. *) +(* inv NR. destruct (Pos.eqb_spec xid id). *) +(* { subst id. hexploit alloc_variables_wf_id. eauto. auto. eauto. apply PTree.gss. *) +(* i. rewrite GET in H0. clarify. eapply Mem.fresh_block_alloc; eauto. } *) +(* hexploit IHEA. auto. rewrite PTree.gso. eapply NOT. auto. eapply GET. i. *) +(* ii. apply H0. unfold Mem.valid_block in *. erewrite Mem.nextblock_alloc; eauto. *) +(* etransitivity. eapply H1. apply Plt_succ. *) +(* Qed. *) + +(* Lemma assign_loc_outside_mem_inject *) +(* ge cp ty m b ofs bf v m' *) +(* (AL: assign_loc ge cp ty m b ofs bf v m') *) +(* k m0 *) +(* (INJ: Mem.inject k m0 m) *) +(* (NIB: k b = None) *) +(* (MS: meminj_same_block k) *) +(* : *) +(* Mem.inject k m0 m'. *) +(* Proof. *) +(* inv AL. *) +(* - eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H1). clarify. *) +(* - eapply Mem.storebytes_outside_inject; eauto. i. specialize (MS _ _ _ H5). clarify. *) +(* - inv H. eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H). clarify. *) +(* Qed. *) + +(* Lemma bind_parameters_outside_mem_inject *) +(* ge cp e m_cur params vargs m_next *) +(* (BIND: bind_parameters ge cp e m_cur params vargs m_next) *) +(* k m *) +(* (INJ: Mem.inject k m m_cur) *) +(* (NIB: forall id b t, e ! id = Some (b, t) -> k b = None) *) +(* (MS: meminj_same_block k) *) +(* (* (NIB: not_inj_blks k (blocks_of_env2 ge e)) *) *) +(* : *) +(* Mem.inject k m m_next. *) +(* Proof. *) +(* revert_until BIND. induction BIND; ii. *) +(* { auto. } *) +(* apply IHBIND; auto. clear IHBIND. specialize (NIB _ _ _ H). *) +(* eapply assign_loc_outside_mem_inject; eauto. *) +(* Qed. *) + +(* Lemma not_inj_blks_get_env *) +(* k ge e *) +(* (NIB: not_inj_blks k (blocks_of_env2 ge e)) *) +(* : *) +(* forall id b t, e ! id = Some (b, t) -> k b = None. *) +(* Proof. *) +(* rr in NIB. unfold blocks_of_env2, blocks_of_env in NIB. rewrite map_map in NIB. *) +(* rewrite Forall_forall in NIB. i. apply PTree.elements_correct in H. *) +(* apply NIB. eapply (in_map (fun x : ident * (block * type) => fst (fst (block_of_binding ge x)))) in H. ss. *) +(* Qed. *) + +(* Lemma not_global_blks_get_env *) +(* (ge: genv) e *) +(* (NIB: not_global_blks ge (blocks_of_env2 ge e)) *) +(* : *) +(* forall id b t, e ! id = Some (b, t) -> (meminj_public ge) b = None. *) +(* Proof. eapply not_inj_blks_get_env. eapply not_global_is_not_inj_bloks. eauto. Qed. *) + +(* Lemma meminj_public_same_block *) +(* ge *) +(* : *) +(* meminj_same_block (meminj_public ge). *) +(* Proof. rr. unfold meminj_public. i. des_ifs. Qed. *) + +(* Lemma alloc_variables_mem_inject *) +(* ge cp e m params e' m' *) +(* (EA: alloc_variables ge cp e m params e' m') *) +(* k m0 *) +(* (INJ: Mem.inject k m0 m) *) +(* : *) +(* Mem.inject k m0 m'. *) +(* Proof. *) +(* revert_until EA. induction EA; ii. auto. *) +(* apply IHEA. clear IHEA. eapply Mem.alloc_right_inject; eauto. *) +(* Qed. *) + +(* Lemma mem_valid_access_wunchanged_on *) +(* m ch b ofs p cp *) +(* (MV: Mem.valid_access m ch b ofs p cp) *) +(* P m' *) +(* (WU: wunchanged_on P m m') *) +(* (SAT: forall ofs', P b ofs') *) +(* : *) +(* Mem.valid_access m' ch b ofs p cp. *) +(* Proof. *) +(* unfold Mem.valid_access in *. des. splits; auto. *) +(* - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on; eauto. *) +(* - destruct cp. 2: ss. erewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block; eauto. *) +(* Qed. *) + +(* Lemma mem_free_list_wunchanged_on_2 *) +(* l m cp m' *) +(* (FREE: Mem.free_list m l cp = Some m') *) +(* : *) +(* wunchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. *) +(* Proof. *) +(* revert_until l. induction l; ii. *) +(* { ss. clarify. apply wunchanged_on_refl. } *) +(* ss. des_ifs. eapply wunchanged_on_trans; cycle 1. *) +(* { eapply wunchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } *) +(* ss. eapply free_wunchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. *) +(* Qed. *) + +(* Lemma not_global_blks_global_not_in *) +(* (ge: genv) id b *) +(* (FIND: Genv.find_symbol ge id = Some b) *) +(* e *) +(* (NGB: not_global_blks ge (blocks_of_env2 ge e)) *) +(* : *) +(* ~ In b (map (fun x : block * Z * Z => fst (fst x)) (blocks_of_env ge e)). *) +(* Proof. *) +(* intros CONTRA. unfold not_global_blks in NGB. unfold blocks_of_env2, blocks_of_env in *. *) +(* rewrite map_map in NGB, CONTRA. rewrite Forall_forall in NGB. specialize (NGB _ CONTRA). *) +(* apply Genv.find_invert_symbol in FIND. setoid_rewrite FIND in NGB. inv NGB. *) +(* Qed. *) + +(* Lemma mem_free_list_unchanged_on *) +(* l m cp m' *) +(* (FREE: Mem.free_list m l cp = Some m') *) +(* : *) +(* Mem.unchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. *) +(* Proof. *) +(* revert_until l. induction l; ii. *) +(* { ss. clarify. apply Mem.unchanged_on_refl. } *) +(* ss. des_ifs. eapply Mem.unchanged_on_trans; cycle 1. *) +(* { eapply Mem.unchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } *) +(* ss. eapply Mem.free_unchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. *) +(* Qed. *) + +(* Lemma exists_vargs_vres *) +(* (ge1: Senv.t) (ge2: genv) *) +(* (MS: match_symbs ge1 ge2) *) +(* ef m1 vargs tr vretv m2 *) +(* (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) *) +(* e cp le m_c *) +(* (WFE: wf_env ge2 e) *) +(* : *) +(* (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) +(* (list_typ_to_typelist (sig_args (ef_sig ef))) vargs) /\ *) +(* (external_call ef ge2 vargs m_c tr vretv m_c). *) +(* Proof. *) +(* pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. *) +(* unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). *) +(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) +(* esplits. *) +(* + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. *) +(* + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. *) +(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) +(* esplits. *) +(* + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. *) +(* econs. 3: econs. *) +(* { instantiate (1:=v). destruct v; ss; try (econs; fail). *) +(* - destruct chunk; ss; inv H2; ss. *) +(* - destruct Archi.ptr64 eqn:ARCH. *) +(* + destruct chunk; ss; inv H2; ss; des_ifs. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* + destruct chunk; ss; inv H2; ss; des_ifs. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* } *) +(* { rewrite EK1 in H2. *) +(* destruct v; ss. *) +(* - destruct chunk; ss; inv H2; ss. *) +(* - destruct chunk; ss. all: simpl_expr. inv H2. *) +(* - destruct chunk; ss. all: simpl_expr. *) +(* - destruct chunk; ss. inv H2. *) +(* - destruct chunk; ss. all: inv H2. *) +(* - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. *) +(* rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss; simpl_expr. *) +(* + unfold Cop.sem_cast. ss. rewrite Heq. auto. *) +(* + unfold Cop.sem_cast. ss. rewrite Heq. auto. *) +(* } *) +(* + econs. econs; auto. rewrite MS3; auto. rewrite EK1. *) +(* rewrite EK1 in H2. eapply match_symbs_eventval_match; eauto. *) +(* - esplits. *) +(* + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. *) +(* erewrite <- eventval_list_match_list_eventval_to_list_val. *) +(* 2:{ eapply match_senv_eventval_list_match in H; eauto. } *) +(* eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. *) +(* eapply match_senv_eventval_list_match; eauto. *) +(* + econs. eapply match_senv_eventval_list_match; eauto. *) +(* - esplits. *) +(* + econs. 3: econs. *) +(* * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. *) +(* eapply match_senv_eventval_match; eauto. *) +(* * erewrite eventval_match_val_to_eventval. 2: eapply H. *) +(* erewrite eventval_match_eventval_to_val. *) +(* 2:{ eapply match_senv_eventval_match; eauto. } *) +(* eapply eventval_match_sem_cast. eapply match_senv_eventval_match; eauto. *) +(* + econs. eapply match_senv_eventval_match; eauto. *) +(* Qed. *) + +(* Lemma eventval_list_match_eval_exprlist *) +(* (ge: genv) args targs vargs *) +(* (EMS: eventval_list_match ge args targs vargs) *) +(* e cp le m *) +(* (WF: wf_env ge e) *) +(* : *) +(* eval_exprlist ge e cp le m (list_eventval_to_list_expr args) *) +(* (list_eventval_to_typelist args) vargs. *) +(* Proof. *) +(* revert_until EMS. induction EMS; i; ss. econs. *) +(* econs; auto. *) +(* { clear dependent evl. clear tyl vl. inv H; try (simpl_expr; fail). *) +(* ss. eapply ptr_of_id_ofs_eval; auto. *) +(* } *) +(* { clear dependent evl. clear tyl vl. inv H; ss; try (simpl_expr; fail). *) +(* rewrite ptr_of_id_ofs_typeof. ss. *) +(* } *) +(* Qed. *) + +(* Lemma exists_vargs_vres_2 *) +(* (ge1: Senv.t) (ge2: genv) *) +(* (MS: match_symbs ge1 ge2) *) +(* ef m1 vargs tr vretv m2 *) +(* (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) *) +(* e cp le m_c *) +(* (WFE: wf_env ge2 e) *) +(* : *) +(* exists vargs2 vretv2, *) +(* (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) +(* (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs2) /\ *) +(* (external_call ef ge2 vargs2 m_c tr vretv2 m_c). *) +(* Proof. *) +(* pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. *) +(* unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). *) +(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) +(* esplits. *) +(* + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. *) +(* + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. *) +(* - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. *) +(* esplits. *) +(* + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. *) +(* econs. 3: econs. *) +(* { instantiate (1:=v). destruct v; ss; try (econs; fail). *) +(* - destruct chunk; ss; inv H2; ss. *) +(* - destruct Archi.ptr64 eqn:ARCH. *) +(* + destruct chunk; ss; inv H2; ss; des_ifs. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* + destruct chunk; ss; inv H2; ss; des_ifs. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. *) +(* eapply ptr_of_id_ofs_eval; eauto. *) +(* } *) +(* { instantiate (1:=Val.load_result chunk v). rewrite EK1 in H2. rewrite EK1. *) +(* destruct v; ss. *) +(* - destruct chunk; ss; inv H2; ss. *) +(* - destruct chunk; ss. all: simpl_expr. *) +(* - destruct chunk; ss. all: simpl_expr. *) +(* - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. *) +(* rewrite ptr_of_id_ofs_typeof. simpl_expr. *) +(* } *) +(* + econs. econs; auto. rewrite MS3; auto. rewrite EK1. eapply match_symbs_eventval_match; eauto. *) +(* - esplits. *) +(* + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. *) +(* eapply eventval_list_match_eval_exprlist; eauto. *) +(* eapply match_senv_eventval_list_match; eauto. *) +(* + econs. eapply match_senv_eventval_list_match; eauto. *) +(* - esplits. *) +(* + econs. 3: econs. *) +(* * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. *) +(* eapply match_senv_eventval_match; eauto. *) +(* * inv H; ss; try (simpl_expr; fail). apply MS2 in H1. setoid_rewrite H1. *) +(* rewrite ptr_of_id_ofs_typeof. ss. *) +(* + econs. eapply match_senv_eventval_match; eauto. *) +(* Qed. *) + +(* Lemma known_obs_preserves_mem *) +(* ef ge m vargs tr vretv m' *) +(* (EK: external_call_known_observables ef ge m vargs tr vretv m') *) +(* : *) +(* m' = m. *) +(* Proof. *) +(* unfold external_call_known_observables in EK. des_ifs; des; inv EK; clarify. inv H; clarify. *) +(* Qed. *) + +(* Lemma meminj_first_order_public_first_order *) +(* ge m *) +(* (MFO: meminj_first_order (meminj_public ge) m) *) +(* : *) +(* public_first_order ge m. *) +(* Proof. *) +(* ii. apply MFO; auto. unfold meminj_public. apply Senv.find_invert_symbol in FIND. *) +(* rewrite FIND. rewrite PUBLIC. ss. *) +(* Qed. *) + +(* Lemma vals_public_eval_to_vargs *) +(* (ge: genv) ef vargs *) +(* (VP: vals_public ge (sig_args (ef_sig ef)) vargs) *) +(* e cp le m *) +(* (WFE: wf_env ge e) *) +(* : *) +(* eval_exprlist ge e cp le m *) +(* (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) *) +(* (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. *) +(* Proof. *) +(* induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. *) +(* - clear dependent l. clear dependent l'. *) +(* inv H; ss; try (simpl_expr; fail). *) +(* destruct H0 as (id & BP1 & BP2). *) +(* unfold senv_invert_symbol_total. rewrite BP1. *) +(* apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. *) +(* - clear dependent l. clear dependent l'. *) +(* inv H; ss; try (simpl_expr; fail). *) +(* destruct H0 as (id & BP1 & BP2). *) +(* unfold senv_invert_symbol_total. rewrite BP1. *) +(* rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss. *) +(* + unfold Cop.sem_cast. ss. rewrite Heq. ss. *) +(* + unfold Cop.sem_cast. ss. rewrite Heq. ss. *) +(* Qed. *) + +(* Lemma vals_public_eval_to_vargs_2 *) +(* (ge: genv) ef vargs *) +(* (VP: vals_public ge (sig_args (ef_sig ef)) vargs) *) +(* e cp le m *) +(* (WFE: wf_env ge e) *) +(* : *) +(* eval_exprlist ge e cp le m *) +(* (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) *) +(* (list_eventval_to_typelist (vals_to_eventvals ge vargs)) vargs. *) +(* Proof. *) +(* induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. *) +(* - clear dependent l. clear dependent l'. *) +(* inv H; ss; try (simpl_expr; fail). *) +(* destruct H0 as (id & BP1 & BP2). *) +(* unfold senv_invert_symbol_total. rewrite BP1. *) +(* apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. *) +(* - clear dependent l. clear dependent l'. *) +(* inv H; ss; try (simpl_expr; fail). *) +(* destruct H0 as (id & BP1 & BP2). *) +(* unfold senv_invert_symbol_total. rewrite BP1. *) +(* rewrite ptr_of_id_ofs_typeof. ss. *) +(* Qed. *) + +(* Lemma match_symbs_block_public *) +(* ge1 ge2 *) +(* (MS: match_symbs ge1 ge2) *) +(* b *) +(* (BP: block_public ge1 b) *) +(* : *) +(* block_public ge2 b. *) +(* Proof. *) +(* destruct MS as (MS1 & MS2 & MS3). destruct BP as (id & BP1 & BP2). *) +(* apply Senv.invert_find_symbol in BP1. apply MS2 in BP1. rewrite <- MS1 in BP2. *) +(* unfold block_public. esplits; eauto. apply Senv.find_invert_symbol; auto. *) +(* Qed. *) + +(* Lemma match_symbs_vals_public *) +(* ge1 ge2 *) +(* (MS: match_symbs ge1 ge2) *) +(* tys vargs *) +(* (VP: vals_public ge1 tys vargs) *) +(* : *) +(* vals_public ge2 tys vargs. *) +(* Proof. *) +(* induction VP; ss. econs; auto. clear VP IHVP. inv H; econs; auto. *) +(* eapply match_symbs_block_public; eauto. *) +(* Qed. *) + +(* Lemma match_symbs_vals_public_vals_to_eventvals *) +(* ge1 ge2 *) +(* (MS: match_symbs ge1 ge2) *) +(* tys vargs *) +(* (VP: vals_public ge1 tys vargs) *) +(* : *) +(* vals_to_eventvals ge1 vargs = vals_to_eventvals ge2 vargs. *) +(* Proof. *) +(* induction VP; ss. f_equal; auto. clear dependent l. clear dependent l'. *) +(* inv H; ss. destruct H0 as (id & BP1 & BP2). *) +(* unfold senv_invert_symbol_total at 1. des_ifs. *) +(* destruct MS as (MS0 & MS1 & MS2). *) +(* apply Senv.invert_find_symbol in Heq. apply MS1 in Heq. *) +(* unfold senv_invert_symbol_total at 1. apply Senv.find_invert_symbol in Heq. *) +(* rewrite Heq. auto. *) +(* Qed. *) + +(* Lemma match_symbs_vals_public_eval_to_vargs *) +(* ge1 (ge2: genv) *) +(* (MS: match_symbs ge1 ge2) *) +(* ef vargs *) +(* (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) *) +(* e cp le m *) +(* (WFE: wf_env ge2 e) *) +(* : *) +(* eval_exprlist ge2 e cp le m *) +(* (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) +(* (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. *) +(* Proof. *) +(* erewrite match_symbs_vals_public_vals_to_eventvals; eauto. *) +(* eapply vals_public_eval_to_vargs; auto. eapply match_symbs_vals_public; eauto. *) +(* Qed. *) + +(* Lemma match_symbs_vals_public_eval_to_vargs_2 *) +(* ge1 (ge2: genv) *) +(* (MS: match_symbs ge1 ge2) *) +(* ef vargs *) +(* (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) *) +(* e cp le m *) +(* (WFE: wf_env ge2 e) *) +(* : *) +(* eval_exprlist ge2 e cp le m *) +(* (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) *) +(* (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs. *) +(* Proof. *) +(* erewrite match_symbs_vals_public_vals_to_eventvals; eauto. *) +(* eapply vals_public_eval_to_vargs_2; auto. eapply match_symbs_vals_public; eauto. *) +(* Qed. *) + +(* Lemma extcall_unkowns_vals_public *) +(* ef ge m vargs *) +(* (EC: external_call_unknowns ef ge m vargs) *) +(* : *) +(* vals_public ge (sig_args (ef_sig ef)) vargs. *) +(* Proof. *) +(* unfold external_call_unknowns in EC. des_ifs; ss; auto. *) +(* all: destruct EC as (EC1 & EC2); auto. *) +(* Qed. *) + + +(* Lemma mem_unchanged_wunchanged *) +(* P m m' *) +(* (UCH: Mem.unchanged_on P m m') *) +(* : *) +(* wunchanged_on P m m'. *) +(* Proof. inv UCH. econs; eauto. Qed. *) + +(* Lemma meminj_public_not_public_not_mapped *) +(* ge cnt_cur *) +(* (NP: Senv.public_symbol ge cnt_cur = false) *) +(* cnt_cur_b *) +(* (FIND: Senv.find_symbol ge cnt_cur = Some cnt_cur_b) *) +(* : *) +(* forall b ofs, meminj_public ge b <> Some (cnt_cur_b, ofs). *) +(* Proof. *) +(* ii. unfold meminj_public in H. des_ifs. *) +(* assert (i = cnt_cur). *) +(* { eapply Senv.find_symbol_injective; eauto. apply Senv.invert_find_symbol; auto. } *) +(* subst i. rewrite NP in Heq0. ss. *) +(* Qed. *) + + +(* Lemma wunchanged_on_exists_mem_free_gen *) +(* m1 b lo hi cp m2 *) +(* (FREE: Mem.free m1 b lo hi cp = Some m2) *) +(* (P: block -> Prop) m_c *) +(* (WCH: wunchanged_on (fun b _ => P b) m1 m_c) *) +(* (NGB: P b) *) +(* : *) +(* exists m_c', Mem.free m_c b lo hi cp = Some m_c'. *) +(* Proof. *) +(* hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. *) +(* hexploit Mem.range_perm_free. *) +(* 3:{ intros (m0 & F). eexists; eapply F. } *) +(* - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. *) +(* - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_exists_mem_free_2 *) +(* m1 b lo hi cp m2 *) +(* (FREE: Mem.free m1 b lo hi cp = Some m2) *) +(* ge m_c *) +(* (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) *) +(* (NGB: Senv.invert_symbol ge b = None) *) +(* : *) +(* exists m_c', Mem.free m_c b lo hi cp = Some m_c'. *) +(* Proof. eapply wunchanged_on_exists_mem_free_gen; eauto. eapply WCH. ss. Qed. *) + +(* Lemma wunchanged_on_free_preserves_gen *) +(* P m m' *) +(* (WU : wunchanged_on P m m') *) +(* b lo hi cp m1 m1' *) +(* (FREE: Mem.free m b lo hi cp = Some m1) *) +(* (FREE': Mem.free m' b lo hi cp = Some m1') *) +(* : *) +(* wunchanged_on P m1 m1'. *) +(* Proof. *) +(* inv WU. econs. *) +(* - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. *) +(* - i. assert (VB: Mem.valid_block m b0). *) +(* { eapply Mem.valid_block_free_2; eauto. } *) +(* split; i. *) +(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. *) +(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) +(* hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. *) +(* + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. *) +(* eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. *) +(* hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. *) +(* - i. assert (VB: Mem.valid_block m b0). *) +(* { eapply Mem.valid_block_free_2; eauto. } *) +(* split; i. *) +(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) +(* eapply Mem.free_can_access_block_inj_2; eauto. *) +(* + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. *) +(* eapply Mem.free_can_access_block_inj_2; eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_exists_mem_free_list_gen *) +(* l m1 cp m2 *) +(* (FREE: Mem.free_list m1 l cp = Some m2) *) +(* (P: block -> Prop) m_c *) +(* (WCH: wunchanged_on (fun b _ => P b) m1 m_c) *) +(* (NGB: Forall P (map (fun x => fst (fst x)) l)) *) +(* : *) +(* exists m_c', Mem.free_list m_c l cp = Some m_c'. *) +(* Proof. *) +(* revert_until l. induction l; i; ss. eauto. *) +(* destruct a as ((b & lo) & hi). ss. inv NGB. des_ifs; ss. *) +(* 2:{ exfalso. hexploit wunchanged_on_exists_mem_free_gen. 2: eapply WCH. all: eauto. *) +(* intros. des. rewrite H in Heq; clarify. *) +(* } *) +(* hexploit IHl. eapply FREE. 2: eapply H2. *) +(* { instantiate (1:=m). eapply wunchanged_on_free_preserves_gen; eauto. } *) +(* eauto. *) +(* Qed. *) + +(* Lemma wunchanged_on_exists_mem_free_list_2 *) +(* l m1 cp m2 *) +(* (FREE: Mem.free_list m1 l cp = Some m2) *) +(* ge m_c *) +(* (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) *) +(* (NGB: not_global_blks ge (map (fun x => fst (fst x)) l)) *) +(* : *) +(* exists m_c', Mem.free_list m_c l cp = Some m_c'. *) +(* Proof. eapply wunchanged_on_exists_mem_free_list_gen; eauto. ss. Qed. *) + +(* Lemma wunchanged_on_free_list_preserves_gen *) +(* P m m' *) +(* (WU: wunchanged_on P m m') *) +(* l cp m_f m_f' *) +(* (FREE: Mem.free_list m l cp = Some m_f) *) +(* (FREE': Mem.free_list m' l cp = Some m_f') *) +(* : *) +(* wunchanged_on P m_f m_f'. *) +(* Proof. *) +(* move l after m. revert_until l. induction l; ii; ss. clarify. *) +(* des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves_gen; eauto. *) +(* Qed. *) + +(* Lemma meminj_not_alloc_external_call *) +(* j m1 *) +(* (NA: meminj_not_alloc j m1) *) +(* ef ge vargs tr vretv m2 *) +(* (EC: external_call ef ge vargs m1 tr vretv m2) *) +(* : *) +(* meminj_not_alloc j m2. *) +(* Proof. *) +(* unfold meminj_not_alloc in *. i. apply NA. clear NA. *) +(* eapply external_call_nextblock in EC. etransitivity. 2: eapply H. auto. *) +(* Qed. *) + +(* Lemma public_first_order_meminj_first_order *) +(* (ge: Senv.t) m *) +(* (FO: public_first_order ge m) *) +(* : *) +(* meminj_first_order (meminj_public ge) m. *) +(* Proof. *) +(* ii. unfold meminj_public in H. des_ifs. eapply FO; eauto. *) +(* apply Senv.invert_find_symbol; auto. *) +(* Qed. *) + +(* Lemma list_length_filter_le *) +(* A P (l: list A) *) +(* : *) +(* (Datatypes.length (filter P l) <= Datatypes.length l)%nat. *) +(* Proof. *) +(* induction l; ss. des_ifs; ss; auto. rewrite <- Nat.succ_le_mono. auto. *) +(* Qed. *) + +(* End PROOF. *) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index c91af73d6c..0cde5a8833 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -233,7 +233,7 @@ Section IR. (SIG: sg = Asm.fn_sig f_next) (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) d m2 - (DELTA: mem_delta_apply_wf ge d (Some m1) = Some 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) @@ -256,7 +256,7 @@ Section IR. (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 d (Some m1) = Some 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) @@ -272,7 +272,7 @@ Section IR. (FINDF: Genv.find_funct ge (Vptr b_ext Ptrofs.zero) = Some (AST.External ef)) (SIG: sg = ef_sig ef) d m1' - (MEM: mem_delta_apply_wf 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 cp_cur vargs m1' tr vretv m2) (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ @@ -288,7 +288,7 @@ Section IR. cp_cur (CURCP: cp_cur = Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) d m1' - (MEM: mem_delta_apply_wf 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 cp_cur vargs m1' tr vretv m2) (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ @@ -727,11 +727,11 @@ Section FROMASM. (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 ge (meminj_public ge) 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 ge (meminj_public ge) d') /\ (mem_delta_apply d' (Some m0) = Some m'). + 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). @@ -745,9 +745,6 @@ Section FROMASM. 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) ]). - - all: try (match goal with - | |- _ ⊆ _ => admit end). { 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)])) @@ -770,7 +767,7 @@ Section FROMASM. } { apply Mem.free_result in Heqo0. unfold Mem.unchecked_free in Heqo0. unfold zle in Heqo0. des_ifs. eexists; eauto. } } - Admitted. + Qed. End FROMASM. @@ -827,7 +824,7 @@ Section INVS. end. Definition match_cur_regset (cur: block) (ge: Asm.genv) (rs: regset) := - Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) ⊆ Genv.find_comp_in_genv ge (rs PC). + Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = Genv.find_comp_in_genv ge (rs PC). Inductive match_stack (ge: Asm.genv): ir_conts -> stack -> Prop := | match_stack_nil @@ -842,11 +839,11 @@ Section INVS. : match_stack ge (ir_cont next :: ik_tl) (Stackframe b sg v ofs :: sk_tl). - Definition match_mem (ge: Asm.genv) (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 ge 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 := @@ -854,7 +851,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_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) | _, _ => False end. @@ -954,9 +951,9 @@ Section PROOF. Qed. Lemma public_rev_perm_delta_apply_inj - d (ge: genv) 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_wf 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. @@ -1023,16 +1020,16 @@ Section PROOF. Lemma match_mem_external_call_establish1 (ge: genv) cp k d m_a0 m_i m - (MEM: match_mem ge 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 cp args m t res m') (ECC: external_call_unknowns ef ge m args) : exists m1 m2 res', - (mem_delta_apply_wf ge d (Some m_i) = Some m1) /\ + (mem_delta_apply_wf ge cp d (Some m_i) = Some m1) /\ (external_call ef ge cp 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). @@ -1046,7 +1043,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. @@ -1075,12 +1072,13 @@ Section PROOF. exploit NALLOC; eauto. intros. clarify. } exfalso. apply PERM. - eapply (ec_public_not_freeable (external_call_spec ef cp)); 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. } + admit. + (* 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. @@ -1088,7 +1086,7 @@ Section PROOF. { eapply public_rev_perm_delta_apply_inj; eauto. } clear - ECC MEMINJ' PRP. eapply external_call_unknowns_mem_inj; eauto. } - Qed. + Admitted. Lemma asm_to_ir_returnstate_nccc_internal @@ -1113,7 +1111,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (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_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) t' ast' (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') t'' ast'' @@ -1142,36 +1140,37 @@ Section PROOF. { simpl. split. - unfold Genv.type_of_call in NCCC. unfold update_stack_return in STUPD. - destruct flowsto_dec; try congruence. + admit. + (* destruct (flowsto_dec); try congruence. *) + (* 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)). + { 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. - destruct flowsto_dec; try congruence. } + admit. } + (* 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 *. - unfold Genv.type_of_call in NCCC. - unfold update_stack_return in STUPD. - des_ifs. } + admit. } + (* rewrite CURCOMP. unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. auto. } *) split; auto. { unfold match_mem. splits; auto. } } intros (btr & ist' & UTR & ISTAR'). exists btr, ist'. split; auto. - Qed. + Admitted. Lemma match_mem_external_call_establish2 ge cp k d m_a0 m_i m - (MEM: match_mem ge 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 cp args m t res m') (ECKO: external_call_known_observables ef ge cp m args t res m') : (external_call ef ge cp args m_i t res m_i) /\ (external_call_known_observables ef ge cp 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). @@ -1197,16 +1196,16 @@ Section PROOF. Lemma match_mem_external_call_establish (ge: genv) cp k d m_a0 m_i m - (MEM: match_mem ge 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 cp args m t res m') (ECC: external_call_unknowns ef ge m args \/ external_call_known_observables ef ge cp m args t res m') : exists d' m1 m2 res', - (mem_delta_apply_wf ge d' (Some m_i) = Some m1) /\ + (mem_delta_apply_wf ge cp d' (Some m_i) = Some m1) /\ (external_call ef ge cp args m1 t res' m2) /\ ((external_call_unknowns ef ge m1 args) \/ (external_call_known_observables ef ge cp 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]. @@ -1226,7 +1225,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = (* callee_comp cpm st *) cur_comp) (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_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) t ast' (STEP: step ge (State st rs m_a cur_comp) t ast') b1 ofs1 @@ -1239,7 +1238,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_in_genv ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m_a') /\ (exists res, star_measure step ge n (ReturnState st (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) # PC <- (rs X1) m_a' bottom) t' ast''). @@ -1262,7 +1261,6 @@ Section PROOF. admit. (* ?? *) eauto. (* previous script *)(* eapply ECC. eauto. clear ECC. *) - intros [ECU | [ECKO | ECKS]]. - (* extcall is unknown *) @@ -1352,7 +1350,7 @@ Section PROOF. { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs, v, (Genv.find_comp_of_block ge cur))]), m_a0, m_i, m'. simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. { eapply public_not_freeable_store; eauto. } - { setoid_rewrite Forall_app. split; auto. econs; auto. ss. admit. } + { setoid_rewrite Forall_app. split; auto. econs; auto. ss. } { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } { eapply public_rev_perm_store; eauto. } } @@ -1403,6 +1401,7 @@ Section PROOF. { destruct ECKS as [_ OBS]. inv EXTCALL. exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. } + Admitted. Lemma asm_to_ir_builtin @@ -1423,7 +1422,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_in_genv 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). @@ -1526,7 +1525,7 @@ Section PROOF. exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs0, v, Genv.find_comp_of_block ge cur)]), m_a0, m_i. simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. { eapply public_not_freeable_store; eauto. } { setoid_rewrite Forall_app. split; auto. econs; auto. ss. - admit. + (* 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. } @@ -1578,7 +1577,7 @@ Section PROOF. { destruct ECKS as [_ OBS]. inv EXTCALL. exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. } - Admitted. + Qed. Lemma asm_to_ir_returnstate_undef_nccc_external @@ -1603,7 +1602,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (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_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) (RSX: rs X1 = Vundef) t' ast' (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') @@ -1631,7 +1630,8 @@ Section PROOF. assert (st' = st). { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. - destruct flowsto_dec; try congruence. } + admit. } + (* 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. @@ -1655,8 +1655,14 @@ Section PROOF. (* 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. - exfalso; apply n0; auto with comps. } + { unfold Genv.type_of_call in H. des_ifs. unfold update_stack_return in STUPD0. + clear H. rewrite Pregmap.gss in *. + admit. + (* 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 H6; inv H6. @@ -1684,7 +1690,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (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_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) t' ast' (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') t'' ast'' @@ -1769,7 +1775,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (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_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) (RSX: rs X1 = Vundef) t' ast' (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') @@ -1826,7 +1832,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (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_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) t' ast' (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') t'' ast'' @@ -1853,16 +1859,13 @@ Section PROOF. assert (st' = st). { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. - des_ifs. } + admit. } + (* 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. - { des_ifs. rewrite NEXTPC in f. rewrite NEXTPC. - simpl in *. - eapply Genv.find_funct_ptr_find_comp_of_block with (fd := External ef) in NEXTF; eauto. - rewrite NEXTF in f. setoid_rewrite NEXTF. - destruct (Genv.find_comp_of_block ge cur); try inv f; auto. } + admit. { rr; splits; eauto. } clear STEP STAR. intros (btr1 & k' & d' & m_a0' & m_i' & m_a' & UTR1 & ISTAR1 & MM' & (res & STAR)). @@ -1873,15 +1876,9 @@ Section PROOF. { 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. - { des_ifs. - rewrite NEXTPC in f. simpl in f. - eapply Genv.find_funct_ptr_find_comp_of_block with (fd := External ef) in NEXTF; eauto. - rewrite NEXTF in f. simpl in f. - simpl. - destruct (Genv.find_comp_of_block ge cur); try inv f; auto. } + all: eauto. lia. admit. { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } - Qed. + Admitted. Lemma asm_to_ir_returnstate (ge: genv) cur_comp n n0 @@ -1905,7 +1902,7 @@ Section PROOF. (CURCOMP : Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero) = cur_comp) (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_in_genv ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) t' ast' (STEP: step ge (ReturnState st rs m_a cur_comp) t' ast') t'' ast'' @@ -1984,7 +1981,9 @@ Section PROOF. 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. } + { replace (comp_of f) with (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)). eapply MEM4. + rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp_in_genv. + admit. } eapply MEM5. auto. intros (d' & MEM4' & MEM5'). destruct f0. @@ -1995,14 +1994,20 @@ Section PROOF. } assert (MTST': match_state ge k m_a0 d' (State st rs' m' cur_comp) (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_in_genv. ss. - rewrite H0 in MTST1. ss. - rewrite Genv.find_funct_ptr_find_comp_of_block with (b := b) (fd := Internal f) in MTST1; eauto. } + { unfold match_cur_regset in *. rewrite NEXTPC. rewrite <- ALLOWED. rewrite MTST1. + unfold Genv.find_comp_in_genv. rewrite H0. + admit. + (* unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. *) + (* rewrite H1. auto. *) + } split. auto. { unfold match_mem. splits; auto. eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. + { replace (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. + rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp_in_genv. + admit. + (* setoid_rewrite H1. auto. *) + } eapply public_rev_perm_exec_instr. 3: eapply H3. all: auto. } } @@ -2020,12 +2025,18 @@ Section PROOF. 1,2,3,4: rewrite NEXTPC in H9; inv H9; rewrite NEXTF in H10; inv H10. (* rewrite <- REC_CURCOMP. *) (* rewrite H9. *) - admit. } - (* rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H9; inv H9. *) - (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. *) - (* admit. } *) + rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H9; inv H9. + admit. + (* rewrite <- ALLOWED. *) + (* unfold Genv.find_comp. setoid_rewrite H1. auto. *) + } { instantiate (4:=k). instantiate (3:=d'). unfold match_mem. splits; eauto. eapply public_not_freeable_exec_instr; eauto. eapply meminj_not_alloc_delta; eauto. + { replace (Genv.find_comp_in_genv ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. + rewrite MTST1. rewrite H0. ss. + admit. + (* 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')). @@ -2041,10 +2052,11 @@ Section PROOF. 1,2,3,4: rewrite NEXTPC in H9; inv H9; rewrite NEXTF in H10; inv H10. (* rewrite <- REC_CURCOMP. *) (* rewrite H9. *) - admit. } - (* rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H9; inv H9. *) - (* erewrite Genv.find_funct_ptr_find_comp_of_block; eauto. *) - (* simpl; rewrite ALLOWED. admit. } *) + rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H9; inv H9. + (* rewrite <- ALLOWED. *) + admit. + (* unfold Genv.find_comp. setoid_rewrite H1. auto. *) + } { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } } Admitted. @@ -2436,7 +2448,7 @@ Section INIT. - 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. auto with comps. + unfold Genv.symbol_address. subst ge0. rewrite H0. ss. - econs. - unfold match_mem. assert (MNA: meminj_not_alloc (meminj_public (Genv.globalenv p)) m0). diff --git a/security/BtInfoAsmBound.v b/security/BtInfoAsmBound.v index bdbf03dd1a..12b2327213 100644 --- a/security/BtInfoAsmBound.v +++ b/security/BtInfoAsmBound.v @@ -13,70 +13,70 @@ Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. -Section AXIOM. - - Definition extcall_observable (sem: extcall_sem) (cp: compartment) (sg: signature): Prop := - forall ge vargs m1 t vres m2, - sem ge cp vargs m1 t vres m2 -> t <> E0. - - Definition external_functions_observable := - forall id cp sg, extcall_observable (external_functions_sem id sg) cp sg. - - Definition inline_assembly_observable := - forall cp id sg, extcall_observable (inline_assembly_sem id sg) cp 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 cp vargs m1 tr vretv m2 - (EC: external_call ef ge cp vargs m1 tr vretv m2) - (ECCASES : external_call_unknowns ef ge m1 vargs \/ - external_call_known_observables ef ge cp 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. +(* Section AXIOM. *) + +(* Definition extcall_observable (sem: extcall_sem) (sg: signature): Prop := *) +(* forall ge vargs m1 t vres m2, *) +(* sem ge vargs m1 t vres m2 -> t <> E0. *) + +(* Definition external_functions_observable := *) +(* forall id sg, extcall_observable (external_functions_sem id sg) sg. *) + +(* Definition inline_assembly_observable := *) +(* forall cp id sg, extcall_observable (inline_assembly_sem cp id sg) sg. *) + +(* (* Axiom external_functions_observable: *) *) +(* (* forall id sg, extcall_observable (external_functions_sem id sg) sg. *) *) + +(* (* Axiom inline_assembly_observable: *) *) +(* (* forall cp id sg, extcall_observable (inline_assembly_sem cp id sg) sg. *) *) + +(* End AXIOM. *) + +(* Section BOUND. *) + +(* Hypothesis EFO: external_functions_observable. *) +(* Hypothesis IAO: inline_assembly_observable. *) + +(* Lemma external_call_observable_length *) +(* ef ge vargs m1 tr vretv m2 *) +(* (EC: external_call ef ge vargs m1 tr vretv m2) *) +(* (ECCASES : external_call_unknowns ef ge m1 vargs \/ *) +(* external_call_known_observables ef ge m1 vargs tr vretv m2) *) +(* : *) +(* (1 <= length tr)%nat. *) +(* Proof. *) +(* des. *) +(* - unfold external_functions_observable in EFO. unfold extcall_observable in EFO. *) +(* unfold inline_assembly_observable in IAO. unfold extcall_observable in IAO. *) +(* cut (tr <> E0). *) +(* { i. destruct tr; ss. lia. } *) +(* destruct ef; ss; eauto. *) +(* + unfold builtin_or_external_sem in EC. des_ifs; ss; eauto. *) +(* + unfold builtin_or_external_sem in EC. des_ifs; ss; eauto. *) +(* - destruct ef; ss; des; clarify; try (inv EC; ss). *) +(* + destruct tr; ss. lia. *) +(* + destruct tr; ss. lia. *) +(* Qed. *) + +(* Lemma bundle_trace_bounded *) +(* ge ist ist' btr *) +(* (ISTAR: istar (ir_step) ge ist btr ist') *) +(* : *) +(* (length btr <= length (unbundle_trace btr))%nat. *) +(* Proof. *) +(* induction ISTAR. ss. subst. ss. *) +(* apply Nat.succ_le_mono in IHISTAR. etransitivity. eauto. clear IHISTAR. *) +(* rewrite app_length. cut (1 <= length (unbundle ev))%nat. lia. *) +(* unfold unbundle. *) +(* inv H; ss. *) +(* - inv TR; ss. *) +(* - inv TR; ss. *) +(* - eapply external_call_observable_length; eauto. des; auto. *) +(* - eapply external_call_observable_length; eauto. des; auto. *) +(* - inv TR; ss. *) +(* - inv TR1; ss. lia. *) +(* - inv TR1; ss. lia. *) +(* Qed. *) + +(* End BOUND. *) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index 31544efde6..bf8f8760a5 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -297,8 +297,6 @@ End MEMDELTA. Section WFDELTA. (** only wf delta is applied for back transltation *) - Context {F V: Type} {CF: has_comp F}. - (* Refer to encode_val *) Definition wf_chunk_val_b (ch: memory_chunk) (v: val) := match v with @@ -334,66 +332,62 @@ Section WFDELTA. | Vptr _ _ => false end. - Definition wf_mem_delta_storev_b (ge: Genv.t F V) (d: mem_delta_storev) := + 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) && - (* (flowsto_dec (Genv.find_comp_in_genv ge v) (Genv.find_comp_of_ident ge id)) && *) - (flowsto_dec (Genv.find_comp_of_ident ge id) cp) + | Some id => (Senv.public_symbol ge id) && (wf_chunk_val_b ch v) && (cp_eq_dec cp0 cp) | _ => false end | _ => false end. - Definition wf_mem_delta_kind_b (ge: Genv.t F V) (d: mem_delta_kind) := - match d with | mem_delta_kind_storev dd => wf_mem_delta_storev_b ge dd | _ => false end. + Definition wf_mem_delta_kind_b (ge: Senv.t) cp0 (d: mem_delta_kind) := + match d with | mem_delta_kind_storev dd => wf_mem_delta_storev_b ge cp0 dd | _ => false end. - Definition get_wf_mem_delta (ge: Genv.t F V) (d: mem_delta): mem_delta := - filter (wf_mem_delta_kind_b ge) d. + Definition get_wf_mem_delta (ge: Senv.t) cp0 (d: mem_delta): mem_delta := + filter (wf_mem_delta_kind_b ge cp0) d. Lemma get_wf_mem_delta_cons - ge d k + ge cp0 d k : - get_wf_mem_delta ge (k :: d) = - if (wf_mem_delta_kind_b ge k) then k :: (get_wf_mem_delta ge d) else (get_wf_mem_delta ge d). + get_wf_mem_delta ge cp0 (k :: d) = + if (wf_mem_delta_kind_b ge cp0 k) then k :: (get_wf_mem_delta ge cp0 d) else (get_wf_mem_delta ge cp0 d). Proof. ss. Qed. - Lemma get_wf_mem_delta_app - ge d0 d1 + ge cp0 d0 d1 : - get_wf_mem_delta ge (d0 ++ d1) = (get_wf_mem_delta ge d0) ++ (get_wf_mem_delta ge d1). + get_wf_mem_delta ge cp0 (d0 ++ d1) = (get_wf_mem_delta ge cp0 d0) ++ (get_wf_mem_delta ge cp0 d1). Proof. apply filter_app. Qed. - Definition mem_delta_apply_wf ge (d: mem_delta) (om0: option mem): option mem := - mem_delta_apply (get_wf_mem_delta ge d) om0. + 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 d m0 k + ge cp0 d m0 k : - mem_delta_apply_wf ge (k :: d) m0 = - if (wf_mem_delta_kind_b ge k) then mem_delta_apply_wf ge d (mem_delta_apply_kind k m0) else mem_delta_apply_wf ge d m0. + mem_delta_apply_wf ge cp0 (k :: d) m0 = + if (wf_mem_delta_kind_b ge cp0 k) then mem_delta_apply_wf ge cp0 d (mem_delta_apply_kind k m0) else mem_delta_apply_wf ge cp0 d m0. Proof. unfold mem_delta_apply_wf at 1. rewrite get_wf_mem_delta_cons. des_ifs. Qed. Lemma mem_delta_apply_wf_app - ge d0 d1 m0 + ge cp0 d0 d1 m0 : - mem_delta_apply_wf ge (d0 ++ d1) m0 = - mem_delta_apply_wf ge d1 (mem_delta_apply_wf ge d0 m0). + mem_delta_apply_wf ge cp0 (d0 ++ d1) m0 = + mem_delta_apply_wf ge cp0 d1 (mem_delta_apply_wf ge cp0 d0 m0). Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_app. apply mem_delta_apply_app. Qed. Lemma mem_delta_apply_wf_none - ge d + ge cp0 d : - mem_delta_apply_wf ge d None = None. + mem_delta_apply_wf ge cp0 d None = None. Proof. unfold mem_delta_apply_wf. apply mem_delta_apply_none. Qed. Lemma mem_delta_apply_wf_some - ge d m0 m1 - (APPD: mem_delta_apply_wf ge d m0 = Some m1) + 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. @@ -403,8 +397,6 @@ End WFDELTA. Section PROPS. - Context {F V: Type} {CF: has_comp F}. - (** Delta and location relations *) Let mcps := PTree.t compartment. @@ -540,10 +532,10 @@ Section PROPS. Qed. Lemma mem_delta_wf_unchanged_on - (ge: Genv.t F V) d m m' - (APPD: mem_delta_apply_wf ge d (Some m) = Some m') + 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 d) b ofs) m m'. + Mem.unchanged_on (fun b ofs => mem_delta_unchanged (get_wf_mem_delta ge cp d) b ofs) m m'. Proof. eapply mem_delta_unchanged_on; eauto. Qed. Lemma get_from_setN_same_upto_ofs @@ -732,20 +724,18 @@ End PROPS. Section PROOFS. (** Props for proofs *) - Context {F V: Type} {CF: has_comp F}. - - Definition mem_delta_kind_inj_wf (ge: Genv.t F V) (j: meminj): mem_delta_kind -> Prop := + 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) => (Genv.find_comp_in_genv ge ptr ⊆ cp) + | 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 ge (j: meminj): mem_delta -> Prop := - fun d => Forall (fun data => mem_delta_kind_inj_wf ge j data) d. + 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. Section VISIBLE. @@ -889,20 +879,20 @@ End VISIBLE. Proof. induction FA; ss. des_ifs. econs; eauto. Qed. Lemma mem_delta_unchanged_implies_wf_unchanged - (ge: Genv.t F V) d b ofs + ge cp d b ofs (UNCHG: mem_delta_unchanged d b ofs) : - mem_delta_unchanged (get_wf_mem_delta ge 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: Genv.t F V) d b ofs - (WF: mem_delta_inj_wf ge (meminj_public ge) d) + ge cp d b ofs + (WF: mem_delta_inj_wf cp (meminj_public ge) d) (INJ: (meminj_public ge) b <> None) (CHG: mem_delta_changed d b ofs) m1 m1' m2 m2' (APPD1: mem_delta_apply d (Some m1) = Some m1') - (APPD2: mem_delta_apply_wf ge d (Some m2) = Some m2') + (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) @@ -958,7 +948,7 @@ End VISIBLE. 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. simpl in INV, PUB. rewrite INV, PUB in APPD2. + 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. } @@ -968,9 +958,10 @@ End VISIBLE. { 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. - unfold Genv.find_comp_of_ident in APPD2. - apply Genv.invert_find_symbol in INV. rewrite INV in APPD2. - do 1 destruct (flowsto_dec); try congruence. simpl in APPD2. + destruct (cp_eq_dec cp cp); try contradiction. + ss. + (* 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. } @@ -1086,13 +1077,13 @@ End VISIBLE. Qed. Lemma mem_delta_apply_preserves_winject - (ge: Genv.t F V) m0 m0' + ge cp0 m0 m0' (WINJ0: winject (meminj_public ge) m0 m0') (d: mem_delta) m1 (APPD: mem_delta_apply d (Some m0) = Some m1) : - exists m1', (mem_delta_apply_wf ge d (Some m0') = Some m1') /\ (winject (meminj_public ge) 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 m1 APPD. induction d; intros. { inv APPD. exists m0'. ss. } @@ -1102,8 +1093,6 @@ End VISIBLE. * 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. - simpl in *. rewrite Heq2 in Heq0; inv Heq0. rewrite Heq1 in Heq; now simpl in Heq. - simpl in *. rewrite Heq1 in Heq0; inv Heq0. + 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. @@ -1155,17 +1144,17 @@ End VISIBLE. Qed. Lemma mem_delta_apply_establish_inject - (ge: Genv.t F V) (k: meminj) m0 m0' + (ge: Senv.t) (k: meminj) m0 m0' (INJ: Mem.inject k m0 m0') (INCR: inject_incr (meminj_public ge) k) (NALLOC: meminj_not_alloc (meminj_public ge) m0) - (d: mem_delta) - (DWF: mem_delta_inj_wf ge (meminj_public ge) d) + (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 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') /\ (Mem.inject (meminj_public ge) m1 m1'). Proof. exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. exploit mem_delta_apply_preserves_winject; eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. @@ -1189,8 +1178,7 @@ End VISIBLE. } { 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. + - 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. @@ -1202,20 +1190,20 @@ End VISIBLE. Import Mem. Lemma mem_delta_apply_establish_inject_preprocess - (ge: Genv.t F V) (k: meminj) m0 m0' + (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) - (DWF: mem_delta_inj_wf ge (meminj_public ge) d) + (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 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') /\ (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. @@ -1252,19 +1240,19 @@ End VISIBLE. Qed. Lemma mem_delta_apply_establish_inject_preprocess_gen - (ge: Genv.t F V) (k: meminj) m0 m0' + (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) - (DWF: mem_delta_inj_wf ge (meminj_public ge) d) + (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 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. From 0223a9d518be5ebc827a15e98d34b171b8bb7929 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 29 Jan 2024 12:13:29 +0100 Subject: [PATCH 79/83] Small fix --- backend/Unusedglobproof.v | 47 ++++++++++++++++++++++++++++++--------- common/Linking.v | 15 +++++++++++-- driver/Compiler.v | 1 - 3 files changed, 50 insertions(+), 13 deletions(-) diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index c7572b3778..68ce6a2a1c 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -433,17 +433,17 @@ End TRANSFORMATION. Theorem transf_program_match: forall p tp, transform_program p = OK tp -> match_prog p tp. Proof. - unfold transform_program; intros p tp TR. set (pm := prog_defmap p) in *. - admit. + unfold transform_program; intros p tp TR. + set (pm := (prog_defmap p)) in *. + (* TECHNICAL: dependent types get in the way of the destruct! *) + (* destruct (used_globals p pm) as [u|] eqn:U; try discriminate. *) + (* destruct (IS.for_all (global_defined p pm) u) eqn:DEF; inv TR. subst pm. *) + (* exists u; split. *) + (* apply used_globals_valid; auto. *) + (* constructor; simpl; auto. *) + (* intros. unfold prog_defmap; simpl. apply filter_globdefs_map. *) + (* apply filter_globdefs_unique_names. *) Admitted. -(* destruct (used_globals p pm) as [u|] eqn:U; try discriminate. *) -(* destruct (IS.for_all (global_defined p pm) u) eqn:DEF; inv TR. *) -(* exists u; split. *) -(* apply used_globals_valid; auto. *) -(* constructor; simpl; auto. *) -(* intros. unfold prog_defmap; simpl. apply filter_globdefs_map. *) -(* apply filter_globdefs_unique_names. *) -(* Qed. *) (** * Semantic preservation *) @@ -1631,6 +1631,33 @@ Proof. * eapply match_prog_main; eauto. * rewrite (match_prog_public _ _ _ B1), (match_prog_public _ _ _ B2). auto. * rewrite (match_prog_pol _ _ _ B1). rewrite (match_prog_pol _ _ _ B2). + unfold link_pol. unfold link_pol_comp. simpl. + f_equal. + assert (G: forall A B (f: A -> B) (t: PTree.t A), map (fun '(id, x) => (id, f x)) (PTree.elements t) = + PTree.elements (PTree.map1 f t)). + { clear. + intros. + unfold PTree.elements. generalize 1%positive. + assert (H: map (fun '(id, x) => (id, f x)) nil = (nil: list (positive * B))) by reflexivity. + revert H. + generalize (nil: list (positive * B)). + generalize (nil: list (positive * A)). + induction t using PTree.tree_ind. + - intros; auto. + - intros l0 l1 EQ p. + destruct l; simpl in *; auto. + + destruct o; simpl in *; auto. + * destruct r; simpl in *; try rewrite EQ; auto. + erewrite IHt0; auto. + * destruct r; simpl in *; auto. + + destruct o; simpl in *; auto. + * destruct r; simpl in *; auto. + now erewrite IHt; eauto; simpl; rewrite EQ. + now erewrite IHt; eauto; simpl; erewrite IHt0. + * destruct r; simpl in *; auto. + } + rewrite !G. f_equal. f_equal. + (* TECHNICAL: need to do *) admit. * rewrite ! prog_defmap_elements, !PTree.gcombine by auto. rewrite (match_prog_def _ _ _ B1 id), (match_prog_def _ _ _ B2 id). diff --git a/common/Linking.v b/common/Linking.v index b3afca5e5f..0846f06857 100644 --- a/common/Linking.v +++ b/common/Linking.v @@ -356,8 +356,19 @@ Lemma link_prog_subproof : Policy.eqb p1.(prog_pol) p2.(prog_pol) = true -> Policy.in_pub p1.(prog_pol) (p1.(prog_public) ++ p2.(prog_public)). Proof. - -Admitted. + intros. + split. unfold Policy.in_pub_exports. + intros. assert (In id (prog_public p1)). + { exploit prog_pol_pub; eauto. intros [G1 G2]. + unfold Policy.in_pub_exports in G1. eauto. } + eapply in_or_app; eauto. + unfold Policy.in_pub_imports. + intros. + { exploit prog_pol_pub; eauto. intros [G1 G2]. + unfold Policy.in_pub_imports in G2. + exploit G2; eauto. intros ?. + eapply in_or_app; eauto. } +Qed. Definition link_pol_comp: PTree.t compartment := let defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2) in diff --git a/driver/Compiler.v b/driver/Compiler.v index a8f22b82f2..cb451a5189 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -422,7 +422,6 @@ Remark forward_simulation_identity: Proof. intros. apply forward_simulation_step with (fun s1 s2 => s2 = s1); intros. - auto. -- auto. - exists s1; auto. - subst s2; auto. - subst s2. exists s1'; auto. From 5efe2961989a6e057befd57d0c9412903ef44af3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 29 Jan 2024 12:14:20 +0100 Subject: [PATCH 80/83] Small fix again --- driver/Compiler.v | 1 + 1 file changed, 1 insertion(+) diff --git a/driver/Compiler.v b/driver/Compiler.v index cb451a5189..a8f22b82f2 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -422,6 +422,7 @@ Remark forward_simulation_identity: Proof. intros. apply forward_simulation_step with (fun s1 s2 => s2 = s1); intros. - auto. +- auto. - exists s1; auto. - subst s2; auto. - subst s2. exists s1'; auto. From 93bf5e4bd3529ccae619a4ec577b10b88a6f192a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 29 Jan 2024 12:37:52 +0100 Subject: [PATCH 81/83] Comments on technical lemmas --- backend/Unusedglob.v | 3 +++ backend/Unusedglobproof.v | 51 ++++++++++++++------------------------- driver/Compiler.v | 1 + 3 files changed, 22 insertions(+), 33 deletions(-) diff --git a/backend/Unusedglob.v b/backend/Unusedglob.v index df9d8195a6..63d8fa5734 100644 --- a/backend/Unusedglob.v +++ b/backend/Unusedglob.v @@ -142,4 +142,7 @@ Program Definition transform_program (p: program) : res program := Error (msg "Unusedglob: reference to undefined global") end. Next Obligation. + (* Technical result that relies on the fact there are less + definitions in the new prog_defs than before, so one should be able + to use the prog_agr_comps from the program [p] *) Admitted. diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index 68ce6a2a1c..1574f5ce4f 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -430,13 +430,14 @@ Qed. End TRANSFORMATION. +(* TECHNICAL: dependent types get in the way of the destruct! But + otherwise the proof should work just as before! *) Theorem transf_program_match: forall p tp, transform_program p = OK tp -> match_prog p tp. Proof. unfold transform_program; intros p tp TR. set (pm := (prog_defmap p)) in *. - (* TECHNICAL: dependent types get in the way of the destruct! *) - (* destruct (used_globals p pm) as [u|] eqn:U; try discriminate. *) + Fail destruct (used_globals p pm) as [u|] eqn:U; try discriminate. (* destruct (IS.for_all (global_defined p pm) u) eqn:DEF; inv TR. subst pm. *) (* exists u; split. *) (* apply used_globals_valid; auto. *) @@ -1599,13 +1600,25 @@ Proof. rewrite PTree.gcombine; auto. Qed. +(* Technical result: proving this result requires doing complicated unfoldings and + case analysis, but the result should hold *) +Lemma link_match_pol: + forall p1 p2 tp1 tp2 p, + link p1 p2 = Some p -> + match_prog p1 tp1 -> match_prog p2 tp2 -> + link_pol tp1 tp2 (prog_pol tp1) (prog_pol tp2) = link_pol p1 p2 (prog_pol p1) (prog_pol p2). +Proof. +Admitted. + Theorem link_match_program: forall p1 p2 tp1 tp2 p, link p1 p2 = Some p -> match_prog p1 tp1 -> match_prog p2 tp2 -> exists tp, link tp1 tp2 = Some tp /\ match_prog p tp. Proof. - intros. destruct H0 as (used1 & A1 & B1). destruct H1 as (used2 & A2 & B2). + intros. + exploit link_match_pol; eauto. intros link_pol_match. + destruct H0 as (used1 & A1 & B1). destruct H1 as (used2 & A2 & B2). destruct (link_prog_inv _ _ _ H) as (U & V & W' & W). assert (yes : Policy.eqb (prog_pol tp1) (prog_pol tp2) = true). { @@ -1630,35 +1643,7 @@ Proof. + rewrite W. constructor; simpl; intros. * eapply match_prog_main; eauto. * rewrite (match_prog_public _ _ _ B1), (match_prog_public _ _ _ B2). auto. -* rewrite (match_prog_pol _ _ _ B1). rewrite (match_prog_pol _ _ _ B2). - unfold link_pol. unfold link_pol_comp. simpl. - f_equal. - assert (G: forall A B (f: A -> B) (t: PTree.t A), map (fun '(id, x) => (id, f x)) (PTree.elements t) = - PTree.elements (PTree.map1 f t)). - { clear. - intros. - unfold PTree.elements. generalize 1%positive. - assert (H: map (fun '(id, x) => (id, f x)) nil = (nil: list (positive * B))) by reflexivity. - revert H. - generalize (nil: list (positive * B)). - generalize (nil: list (positive * A)). - induction t using PTree.tree_ind. - - intros; auto. - - intros l0 l1 EQ p. - destruct l; simpl in *; auto. - + destruct o; simpl in *; auto. - * destruct r; simpl in *; try rewrite EQ; auto. - erewrite IHt0; auto. - * destruct r; simpl in *; auto. - + destruct o; simpl in *; auto. - * destruct r; simpl in *; auto. - now erewrite IHt; eauto; simpl; rewrite EQ. - now erewrite IHt; eauto; simpl; erewrite IHt0. - * destruct r; simpl in *; auto. - } - rewrite !G. f_equal. f_equal. - (* TECHNICAL: need to do *) - admit. +* eauto. * rewrite ! prog_defmap_elements, !PTree.gcombine by auto. rewrite (match_prog_def _ _ _ B1 id), (match_prog_def _ _ _ B2 id). rewrite ISF.union_b. @@ -1684,6 +1669,6 @@ Proof. destruct (IS.mem id used1), (IS.mem id used2); auto. } * intros. apply PTree.elements_keys_norepet. -Admitted. +Qed. Global Instance TransfSelectionLink : TransfLink match_prog := link_match_program. diff --git a/driver/Compiler.v b/driver/Compiler.v index a8f22b82f2..2f7ad5f927 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -538,6 +538,7 @@ Proof. intros. apply c_semantic_preservation. apply transf_c_program_match; auto. Qed. + (** Here is the separate compilation case. Consider a nonempty list [c_units] of C source files (compilation units), [C1 ,,, Cn]. Assume that every C compilation unit [Ci] is successfully compiled by CompCert, obtaining From 4fca9b2176e25c470fddc1a2ce81684a60e0b82d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Mon, 29 Jan 2024 13:04:38 +0100 Subject: [PATCH 82/83] Fix --- test/backtranslation/Gen.ml | 4 ++-- test/backtranslation/Gen_ctx.ml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/test/backtranslation/Gen.ml b/test/backtranslation/Gen.ml index 5d95d28388..9dbd0a90eb 100644 --- a/test/backtranslation/Gen.ml +++ b/test/backtranslation/Gen.ml @@ -57,7 +57,7 @@ let vptr ctx = let glob_vars = List.map (fun (_, v, _, _, _) -> v) (Gen_ctx.var_list ctx) in let* ident = map Camlcoq.P.of_int (oneofl glob_vars) in let asm_prog = Gen_ctx.get_asm_prog ctx in - let genv = Globalenvs.Genv.globalenv asm_prog in + let genv = Globalenvs.Genv.globalenv (fun _ -> AST.COMP.bottom) asm_prog in let block = match Globalenvs.Genv.find_symbol genv ident with | None -> failwith "Fatal error: cannot find block for symbol for vptr." | Some b -> b @@ -83,7 +83,7 @@ let mem_delta_storev curr_comp ctx = let* ident = map Camlcoq.P.of_int (oneofl glob_vars) in let asm_prog = Gen_ctx.get_asm_prog ctx in - let genv = Globalenvs.Genv.globalenv asm_prog in + let genv = Globalenvs.Genv.globalenv (fun _ -> AST.COMP.bottom) asm_prog in let block = match Globalenvs.Genv.find_symbol genv ident with | None -> failwith "Fatal error: cannot find block for symbol for mem_delta" | Some b -> b diff --git a/test/backtranslation/Gen_ctx.ml b/test/backtranslation/Gen_ctx.ml index 53f14915f6..004f42b01a 100644 --- a/test/backtranslation/Gen_ctx.ml +++ b/test/backtranslation/Gen_ctx.ml @@ -294,7 +294,7 @@ let build_prog_pol ctx = else ()) imports; let policy = - ({ policy_export = !policy_export; policy_import = !policy_import } + ({ policy_comps = PTree.empty; policy_export = !policy_export; policy_import = !policy_import } : AST.Policy.t) in policy From 494a6f28a0b8c334f8473528ff64371bd497fc6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Sun, 4 Feb 2024 22:01:36 +0100 Subject: [PATCH 83/83] Fix correctness --- backend/Selectionproof.v | 2 +- backend/Unusedglob.v | 30 ++++- backend/Unusedglobproof.v | 56 +++++---- cfrontend/Cshmgenproof.v | 1 - cfrontend/Ctypes.v | 23 +++- cfrontend/SimplExprproof.v | 3 +- cfrontend/SimplLocalsproof.v | 1 - common/AST.v | 5 +- common/Globalenvs.v | 2 + common/Linking.v | 236 ++++++++++++++++++++++++----------- 10 files changed, 247 insertions(+), 112 deletions(-) diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index fe923aafcd..3942b66ba3 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -1691,7 +1691,7 @@ Global Instance TransfSelectionLink : TransfLink match_prog. Proof. red; intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. - exact comp_match_fundef. + (* exact comp_match_fundef. *) intros. elim H3. intros hf [A1 B1]. elim H4; intros hf' [A2 B2]. Local Transparent Linker_fundef. simpl in *. destruct f1, f2; simpl in *; monadInv B1; monadInv B2; simpl. diff --git a/backend/Unusedglob.v b/backend/Unusedglob.v index 63d8fa5734..cc576f987d 100644 --- a/backend/Unusedglob.v +++ b/backend/Unusedglob.v @@ -142,7 +142,29 @@ Program Definition transform_program (p: program) : res program := Error (msg "Unusedglob: reference to undefined global") end. Next Obligation. - (* Technical result that relies on the fact there are less - definitions in the new prog_defs than before, so one should be able - to use the prog_agr_comps from the program [p] *) -Admitted. + unfold agr_comps. + apply Forall_forall. + intros [id gd] IN. + assert (H: In (id, gd) (rev (prog_defs p))). + { clear Heq_anonymous. + revert used IN. + assert (G: ~ In (id, gd) (nil: list (ident * globdef fundef unit))) by eauto. + revert G. + generalize (nil: list (ident * globdef fundef unit)) as acc. + generalize (rev (prog_defs p)). + induction l. + - intros acc NOTIN; eauto. + - intros acc NOTIN used IN. simpl in IN. + destruct (Classical_Prop.classic (a = (id, gd))); try now left. + right. + destruct a as [id' gd']; destruct (IS.mem id' used) eqn:is_used; simpl in IN. + + eapply IHl with (acc := (id', gd') :: acc). + * intros contra. inv contra; eauto. + * eauto. + + eapply IHl with (acc := acc); eauto. } + rewrite in_rev in H. rewrite rev_involutive in H. + pose proof (prog_agr_comps p) as G. + unfold agr_comps in G. + rewrite Forall_forall in G. + now eapply G. +Qed. diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index 1574f5ce4f..8892b696ab 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -26,6 +26,12 @@ Module ISP := FSetProperties.Properties(IS). (** The transformed program is obtained from the original program by keeping only the global definitions that belong to a given set [u] of names. *) +Definition match_pol (pol tpol: Policy.t): Prop := + (forall id cp, tpol.(Policy.policy_comps) ! id = Some cp -> + pol.(Policy.policy_comps) ! id = Some cp) /\ + pol.(Policy.policy_export) = tpol.(Policy.policy_export) /\ + pol.(Policy.policy_import) = tpol.(Policy.policy_import). + Record match_prog_1 (u: IS.t) (p tp: program) : Prop := { match_prog_main: @@ -33,6 +39,7 @@ Record match_prog_1 (u: IS.t) (p tp: program) : Prop := { match_prog_public: tp.(prog_public) = p.(prog_public); match_prog_pol: + (* match_pol p.(prog_pol) tp.(prog_pol); *) tp.(prog_pol) = p.(prog_pol); match_prog_def: forall id, @@ -430,22 +437,23 @@ Qed. End TRANSFORMATION. -(* TECHNICAL: dependent types get in the way of the destruct! But - otherwise the proof should work just as before! *) Theorem transf_program_match: forall p tp, transform_program p = OK tp -> match_prog p tp. Proof. unfold transform_program; intros p tp TR. set (pm := (prog_defmap p)) in *. - Fail destruct (used_globals p pm) as [u|] eqn:U; try discriminate. - (* destruct (IS.for_all (global_defined p pm) u) eqn:DEF; inv TR. subst pm. *) - (* exists u; split. *) - (* apply used_globals_valid; auto. *) - (* constructor; simpl; auto. *) - (* intros. unfold prog_defmap; simpl. apply filter_globdefs_map. *) - (* apply filter_globdefs_unique_names. *) -Admitted. - + revert TR. + generalize (Unusedglob.transform_program_obligation_1 p). + simpl. fold pm. intros a TR. + destruct (used_globals p pm) as [u|] eqn:U; try discriminate. + destruct (IS.for_all (global_defined p pm) u) eqn:DEF; inv TR. subst pm. + exists u; split. + apply used_globals_valid; auto. + constructor; simpl; auto. + unfold match_pol; eauto. + intros. unfold prog_defmap; simpl. apply filter_globdefs_map. + apply filter_globdefs_unique_names. +Qed. (** * Semantic preservation *) @@ -594,7 +602,8 @@ Proof. Qed. Lemma globals_symbols_inject: - forall j cp, meminj_preserves_globals j -> symbols_inject j (Genv.to_senv ge) (Genv.to_senv tge) cp. + forall j cp, meminj_preserves_globals j -> + symbols_inject j (Genv.to_senv ge) (Genv.to_senv tge) cp. Proof. intros. assert (E1: Genv.genv_public ge = p.(prog_public)). @@ -1600,15 +1609,16 @@ Proof. rewrite PTree.gcombine; auto. Qed. -(* Technical result: proving this result requires doing complicated unfoldings and - case analysis, but the result should hold *) -Lemma link_match_pol: - forall p1 p2 tp1 tp2 p, - link p1 p2 = Some p -> - match_prog p1 tp1 -> match_prog p2 tp2 -> - link_pol tp1 tp2 (prog_pol tp1) (prog_pol tp2) = link_pol p1 p2 (prog_pol p1) (prog_pol p2). -Proof. -Admitted. +(* (* Technical result: proving this result requires doing complicated unfoldings and *) +(* case analysis, but the result should hold *) *) +(* Lemma link_match_pol: *) +(* forall p1 p2 tp1 tp2 p, *) +(* link p1 p2 = Some p -> *) +(* match_prog p1 tp1 -> match_prog p2 tp2 -> *) +(* link_pol tp1 tp2 (prog_pol tp1) (prog_pol tp2) = *) +(* link_pol p1 p2 (prog_pol p1) (prog_pol p2). *) +(* Proof. *) +(* Admitted. *) Theorem link_match_program: forall p1 p2 tp1 tp2 p, @@ -1617,7 +1627,7 @@ Theorem link_match_program: exists tp, link tp1 tp2 = Some tp /\ match_prog p tp. Proof. intros. - exploit link_match_pol; eauto. intros link_pol_match. + (* exploit link_match_pol; eauto. intros link_pol_match. clear link_pol_match. *) destruct H0 as (used1 & A1 & B1). destruct H1 as (used2 & A2 & B2). destruct (link_prog_inv _ _ _ H) as (U & V & W' & W). assert (yes : Policy.eqb (prog_pol tp1) (prog_pol tp2) = true). @@ -1643,7 +1653,7 @@ Proof. + rewrite W. constructor; simpl; intros. * eapply match_prog_main; eauto. * rewrite (match_prog_public _ _ _ B1), (match_prog_public _ _ _ B2). auto. -* eauto. +* eapply match_prog_pol; eauto. * rewrite ! prog_defmap_elements, !PTree.gcombine by auto. rewrite (match_prog_def _ _ _ B1 id), (match_prog_def _ _ _ B2 id). rewrite ISF.union_b. diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 5e8561214e..1f007c963d 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -2106,7 +2106,6 @@ Local Transparent Ctypes.Linker_program. (prog_comp_env_eq p2) EQ) as (env & P & Q). intros E. eapply Linking.link_match_program; eauto. -- exact comp_match_fundef. - intros. Local Transparent Linker_fundef Linking.Linker_fundef. inv H3; inv H4; simpl in H2. diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index a08e127f22..ce3327d051 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -1798,7 +1798,7 @@ Qed. (** ** Linking function definitions *) -Definition link_fundef {F: Type} {CF: has_comp F} (fd1 fd2: fundef F) := +Definition link_fundef {F: Type} (fd1 fd2: fundef F) := match fd1, fd2 with | Internal _, Internal _ => None | External ef1 targs1 tres1 cc1, External ef2 targs2 tres2 cc2 => @@ -1822,13 +1822,13 @@ Definition link_fundef {F: Type} {CF: has_comp F} (fd1 fd2: fundef F) := end end. -Inductive linkorder_fundef {F: Type} {CF: has_comp F}: fundef F -> fundef F -> Prop := +Inductive linkorder_fundef {F: Type}: fundef F -> fundef F -> Prop := | linkorder_fundef_refl: forall fd, linkorder_fundef fd fd | linkorder_fundef_ext_int: forall f id sg targs tres cc, linkorder_fundef (External (EF_external id sg) targs tres cc) (Internal f). -Global Program Instance Linker_fundef (F: Type) {CF: has_comp F}: Linker (fundef F) := { +Global Program Instance Linker_fundef (F: Type): Linker (fundef F) := { link := link_fundef; linkorder := linkorder_fundef }. @@ -1851,6 +1851,21 @@ Next Obligation. InvBooleans. subst. split; constructor. Defined. +Global Instance Linker_Side_fundef {F: Type}: Linker_Side (Linker_fundef F). +Proof. + intros f f0 g. simpl. unfold link_fundef. + destruct f, f0; try congruence. + - destruct e; try congruence. + intros H; inv H; eauto. + - destruct e; try congruence. + intros H; inv H; eauto. + - destruct external_function_eq; simpl; try congruence; + destruct typelist_eq; simpl; try congruence; + destruct type_eq; simpl; try congruence; + destruct calling_convention_eq; simpl; try congruence. + intros H; inv H; eauto. +Qed. + Remark link_fundef_either: forall (F: Type) {CF: has_comp F} (f1 f2 f: fundef F), link f1 f2 = Some f -> f = f1 \/ f = f2. Proof. @@ -2012,7 +2027,7 @@ Local Transparent Linker_program. link (program_of_program tp1) (program_of_program tp2) = Some tpp /\ Linking.match_program (fun ctx f tf => match_fundef f tf) eq pp tpp). { eapply Linking.link_match_program. - - exact comp_match_fundef. + (* - exact comp_match_fundef. *) - intros. exploit link_match_fundef; eauto. intros (tf & A & B). exists tf; auto. - intros. Local Transparent Linker_types. diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index 91643cadbc..21cf5c5ef1 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -2610,8 +2610,7 @@ End PRESERVATION. Global Instance TransfSimplExprLink : TransfLink match_prog. Proof. red; intros. eapply Ctypes.link_match_program_gen; eauto. -- eapply comp_tr_fundef. -- intros. + intros. Local Transparent Linker_fundef. simpl in *; unfold link_fundef in *. inv H3; inv H4; try discriminate. destruct ef; inv H2. diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index 71523b4666..23b0b2f120 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -2531,7 +2531,6 @@ End PRESERVATION. Global Instance TransfSimplLocalsLink : TransfLink match_prog. Proof. red; intros. eapply Ctypes.link_match_program; eauto. - eapply has_comp_transl_partial_match. eapply comp_transf_fundef. intros. Local Transparent Linker_fundef. simpl in *; unfold link_fundef in *. diff --git a/common/AST.v b/common/AST.v index 9859b80c10..5120eead31 100644 --- a/common/AST.v +++ b/common/AST.v @@ -702,7 +702,8 @@ Instance has_comp_globdef F V {CF: has_comp F} : has_comp (globdef F V) := Definition agr_comps {F V: Type} {CF: has_comp F} (pol: Policy.t) (defs: list (ident * globdef F V)): Prop := Forall - (fun idg => pol.(Policy.policy_comps) ! (fst idg) = Some (comp_of (snd idg))) + (fun idg => forall cp, pol.(Policy.policy_comps) ! (fst idg) = Some cp -> + (comp_of (snd idg)) ⊆ cp) defs. (* /\ *) (* forall (id: ident) (cp: compartment), *) @@ -904,7 +905,7 @@ Proof. simpl; constructor. * simpl. apply has_comp_transl_partial_match_contextual with (g := fun id => id) in Cf. - now rewrite Cf in H; eauto. + now erewrite Cf in H; eauto. * now eauto. + destruct transf_globvar eqn:?; try congruence; simpl in *. monadInv defs'_OK. diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 2078e84eac..6412fb3e60 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -2590,6 +2590,7 @@ Section TRANSFORM_PARTIAL. Context {A B V: Type} {LA: Linker A} {LV: Linker V}. Context {CA: has_comp A} {CB: has_comp B}. +Context {HLF: Linker_Side LA}. Context {transf: A -> res B} {p: program A V} {tp: program B V}. Context {CAB: has_comp_transl_partial transf}. Hypothesis progmatch: match_program (fun cu f tf => transf f = OK tf) eq p tp. @@ -2745,6 +2746,7 @@ Section TRANSFORM_TOTAL. Context {A B V: Type} {LA: Linker A} {LV: Linker V}. Context {CA: has_comp A} {CB: has_comp B}. +Context {HLA: Linker_Side LA}. Context {transf: A -> B} {p: program A V} {tp: program B V}. Context {CAB: has_comp_transl transf}. Hypothesis progmatch: match_program (fun cu f tf => tf = transf f) eq p tp. diff --git a/common/Linking.v b/common/Linking.v index 0846f06857..212d034bcd 100644 --- a/common/Linking.v +++ b/common/Linking.v @@ -63,7 +63,7 @@ Class Linker (A: Type) := { linking is the internal definition. Two external functions can link if they are identical. *) -Definition link_fundef {F: Type} {CF: has_comp F} (fd1 fd2: fundef F) := +Definition link_fundef {F: Type} (fd1 fd2: fundef F) := match fd1, fd2 with | Internal _, Internal _ => None | External ef1, External ef2 => @@ -80,11 +80,11 @@ Definition link_fundef {F: Type} {CF: has_comp F} (fd1 fd2: fundef F) := end end. -Inductive linkorder_fundef {F: Type} {CF: has_comp F} : fundef F -> fundef F -> Prop := +Inductive linkorder_fundef {F: Type} : fundef F -> fundef F -> Prop := | linkorder_fundef_refl: forall fd, linkorder_fundef fd fd | linkorder_fundef_ext_int: forall f id sg, linkorder_fundef (External (EF_external id sg)) (Internal f). -Global Program Instance Linker_fundef (F: Type) {CP: has_comp F}: Linker (fundef F) := { +Global Program Instance Linker_fundef (F: Type): Linker (fundef F) := { link := link_fundef; linkorder := linkorder_fundef }. @@ -104,6 +104,23 @@ Next Obligation. + destruct (external_function_eq e e0); inv H. split; constructor. Defined. + +Class Linker_Side {F: Type} (LF: Linker F) := + linker_side: forall (f f0 g: F), link f f0 = Some g -> g = f \/ g = f0. + +Global Instance Linker_Side_fundef {F: Type}: Linker_Side (Linker_fundef F). +Proof. + intros f f0 g. unfold link. + simpl. unfold link_fundef. + destruct f, f0; try congruence. + - destruct e; try congruence. + intros H; inv H; auto. + - destruct e; try congruence. + intros H; inv H; auto. + - destruct external_function_eq; try congruence. + intros H; inv H; auto. +Qed. + (* Global Instance Linker_fundef_comp (F: Type) {CP: has_comp F}: *) (* has_comp_linker (Linker_fundef F). *) (* Proof. *) @@ -331,6 +348,7 @@ Section LINKER_PROG. Context {F V: Type} {CF: has_comp F} {LF: Linker F} {LV: Linker V} (* {CLF: has_comp_linker LF} (* {CLV: Has_Comp_Linker LV} *) *) + {HLF: Linker_Side LF} (p1 p2: program F V). Let dm1 := prog_defmap p1. @@ -413,10 +431,69 @@ Proof. destruct G as [G | G]. + inv G. erewrite PTree_Properties.of_list_norepet; eauto. - + exploit IN; eauto. + intros ? G; inv G; auto with comps. + + exploit IN; eauto. intros ? cp ?. exploit IHl; eauto. Qed. +Lemma prog_agr_comps_link': + (Policy.eqb p1.(prog_pol) p2.(prog_pol)) = true -> + agr_comps (p1.(prog_pol)) + (PTree.elements (PTree.combine link_prog_merge dm1 dm2)). +Proof. + intros eq_pol. + unfold agr_comps. + rewrite Forall_forall. + intros x IN. destruct x as [i gd]. + assert (G: (exists gd', comp_of gd' = comp_of gd /\ In (i, gd') (PTree.elements dm1)) \/ + (exists gd', comp_of gd' = comp_of gd /\ In (i, gd') (PTree.elements dm2))). + { apply PTree.elements_complete in IN. + rewrite PTree.gcombine in IN; auto. + destruct (dm1 ! i) eqn:?; destruct (dm2 ! i) eqn:?; simpl in IN. + - Local Transparent Linker_def Linker_vardef Linker_varinit. + destruct g, g0; simpl in IN; try congruence. + + destruct (link f f0) eqn:?; try congruence. + exploit HLF; eauto. intros [G | G]. + * subst; left; eexists; split; eauto. eapply PTree.elements_correct; eauto. + now inv IN. + * subst; right; eexists; split; eauto. eapply PTree.elements_correct; eauto. + now inv IN. + + destruct (link_vardef v v0) eqn:EQ; try congruence. + inv IN. + unfold link_vardef in EQ. + destruct (link (gvar_info v) (gvar_info v0)) eqn:?; try discriminate. + destruct (link (gvar_init v) (gvar_init v0)) eqn:?; try discriminate. + destruct (cp_eq_dec (gvar_comp v) (gvar_comp v0) && eqb (gvar_readonly v) (gvar_readonly v0) && + eqb (gvar_volatile v) (gvar_volatile v0)); try discriminate. + inv EQ. + left; eexists. split. + 2: eapply PTree.elements_correct; eauto. eauto. + - left; eexists; split; [|eapply PTree.elements_correct; eauto]. congruence. + - right; eexists; split; [|eapply PTree.elements_correct; eauto]. congruence. + - congruence. } + destruct G as [[gd' [? ?]] | [gd' [? ?]]]. + - pose proof (prog_agr_comps p1) as G. + unfold agr_comps in G. rewrite Forall_forall in G. + eapply PTree.elements_complete in H0. eapply in_prog_defmap in H0. + intros cp ?. + specialize (G (i, gd') H0 cp H1). simpl; rewrite <- H. auto. + - unfold Policy.eqb in eq_pol. + apply andb_prop in eq_pol as [eq_pol2 eq_pol3]. + apply andb_prop in eq_pol2 as [eq_pol1 eq_pol2]. + (* apply PTree.beq_correct in eq_pol1. *) + (* rewrite <- eq_pol in *. *) + pose proof (prog_agr_comps p2) as G. + unfold agr_comps in G. rewrite Forall_forall in G. + eapply PTree.elements_complete in H0. eapply in_prog_defmap in H0. + intros cp ?. + rewrite PTree.beq_correct in eq_pol1. + specialize (eq_pol1 i). simpl in H1. rewrite H1 in eq_pol1. + destruct ((Policy.policy_comps (prog_pol p2)) ! i) eqn:EQ; try contradiction. + destruct (cp_eq_dec cp c); try discriminate. subst. + specialize (G (i, gd') H0 c EQ). simpl; rewrite <- H. auto. +Qed. + + Definition link_prog := if ident_eq p1.(prog_main) p2.(prog_main) && PTree_Properties.for_all dm1 link_prog_check then @@ -426,9 +503,9 @@ Definition link_prog := Some {| prog_main := p1.(prog_main); prog_public := p1.(prog_public) ++ p2.(prog_public); prog_defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2); - prog_pol := link_pol (prog_pol p1) (prog_pol p2); + prog_pol := prog_pol p1; prog_pol_pub := link_prog_subproof yes; - prog_agr_comps := prog_agr_comps_link |} + prog_agr_comps := prog_agr_comps_link' yes |} | right _ => None end else @@ -446,9 +523,9 @@ Lemma link_prog_inv: p = {| prog_main := p1.(prog_main); prog_public := p1.(prog_public) ++ p2.(prog_public); prog_defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2); - prog_pol := link_pol (prog_pol p1) (prog_pol p2); + prog_pol := prog_pol p1; prog_pol_pub := link_prog_subproof yes; - prog_agr_comps := prog_agr_comps_link |}. + prog_agr_comps := prog_agr_comps_link' yes |}. Proof. unfold link_prog; intros p E. destruct (ident_eq (prog_main p1) (prog_main p2)); try discriminate. @@ -476,9 +553,9 @@ Lemma link_prog_succeeds: Some {| prog_main := p1.(prog_main); prog_public := p1.(prog_public) ++ p2.(prog_public); prog_defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2); - prog_pol := link_pol (prog_pol p1) (prog_pol p2); + prog_pol := (prog_pol p1); prog_pol_pub := link_prog_subproof yes; - prog_agr_comps := prog_agr_comps_link; + prog_agr_comps := prog_agr_comps_link' yes; |}. Proof. intros. unfold link_prog. unfold proj_sumbool. rewrite H, dec_eq_true. simpl. @@ -506,7 +583,7 @@ Qed. End LINKER_PROG. Global Program Instance Linker_prog (F V: Type) {CF: has_comp F} {LF: Linker F} (* {CLF: has_comp_linker LF} *) - {LV: Linker V} : Linker (program F V) := { + {LV: Linker V} {HLF: Linker_Side LF}: Linker (program F V) := { link := link_prog; linkorder := fun p1 p2 => p1.(prog_main) = p2.(prog_main) @@ -549,7 +626,10 @@ Next Obligation. Defined. Lemma prog_defmap_linkorder: - forall {F V: Type} {CF: has_comp F} {LF: Linker F} (* {CLF: has_comp_linker LF} *) {LV: Linker V} (p1 p2: program F V) id gd1, + forall {F V: Type} {CF: has_comp F} {LF: Linker F} {LV: Linker V} + {HLF: Linker_Side LF} + (* {HLF: forall (f f0 g: F), link f f0 = Some g -> g = f \/ g = f0} *) + (p1 p2: program F V) id gd1, linkorder p1 p2 -> (prog_defmap p1)!id = Some gd1 -> exists gd2, (prog_defmap p2)!id = Some gd2 /\ linkorder gd1 gd2. @@ -627,14 +707,15 @@ End MATCH_PROGRAM_GENERIC. source compilation unit itself. We provide a specialized definition for this case. *) Definition match_program {F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LF: Linker F1} - (* {CLF: has_comp_linker LF} *) {LV: Linker V1} + {LV: Linker V1} {HLF: Linker_Side LF} (match_fundef: program F1 V1 -> F1 -> F2 -> Prop) (match_varinfo: V1 -> V2 -> Prop) (p1: program F1 V1) (p2: program F2 V2) : Prop := match_program_gen match_fundef match_varinfo p1 p1 p2. Lemma match_program_main: - forall {F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LF: Linker F1} (* {CLF: has_comp_linker LF} *) {LV: Linker V1} + forall {F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LF: Linker F1} + {LV: Linker V1} {HLF: Linker_Side LF} {match_fundef: program F1 V1 -> F1 -> F2 -> Prop} {match_varinfo: V1 -> V2 -> Prop} {p1: program F1 V1} {p2: program F2 V2}, @@ -713,6 +794,7 @@ Qed. Theorem match_transform_partial_program_contextual: forall {A B V: Type} {CA: has_comp A} {CB: has_comp B} {LA: Linker A} {LV: Linker V} + {HLA: Linker_Side LA} (match_fundef: program A V -> A -> B -> Prop) (transf_fun: A -> res B) {comp_transf_fun: has_comp_transl_partial transf_fun} @@ -729,6 +811,7 @@ Qed. Theorem match_transform_program_contextual: forall {A B V: Type} {CA: has_comp A} {CB: has_comp B} {LA: Linker A} {LV: Linker V} + {HLA: Linker_Side LA} (match_fundef: program A V -> A -> B -> Prop) (transf_fun: A -> B) {comp_transf: has_comp_transl transf_fun} @@ -747,6 +830,7 @@ Qed. Theorem match_transform_partial_program: forall {A B V: Type} {CA: has_comp A} {CB: has_comp B} {LA: Linker A} {LV: Linker V} + {HLA: Linker_Side LA} (transf_fun: A -> res B) {comp_transf_fun: has_comp_transl_partial transf_fun} (p: program A V) (tp: program B V), @@ -761,6 +845,7 @@ Qed. Theorem match_transform_program: forall {A B V: Type} {CA: has_comp A} {CB: has_comp B} {LA: Linker A} {LV: Linker V} + {HLA: Linker_Side LA} (transf: A -> B) {comp_transf: has_comp_transl transf} (p: program A V), @@ -773,7 +858,9 @@ Qed. Section LINK_MATCH_PROGRAM. -Context {C F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LC: Linker C} {LF1: Linker F1} {LF2: Linker F2} {LV1: Linker V1} {LV2: Linker V2}. +Context {C F1 V1 F2 V2: Type} {CF1: has_comp F1} {CF2: has_comp F2} {LC: Linker C} + {LF1: Linker F1} {LF2: Linker F2} {LV1: Linker V1} {LV2: Linker V2} + {HLF1: Linker_Side LF1} {HLF2: Linker_Side LF2}. Variable match_fundef: C -> F1 -> F2 -> Prop. Context {has_comp_match_fundef: has_comp_match match_fundef}. Variable match_varinfo: V1 -> V2 -> Prop. @@ -881,58 +968,59 @@ Proof. intros (tg & TL & MG). rewrite Z, TL. constructor; auto. + rewrite R; simpl; auto. + rewrite R; simpl. split; try congruence. - unfold Policy.eqb. - rewrite !andb_true_iff. unfold CompTree.beq. simpl. - clear yes. unfold Policy.eqb in D1. rewrite !andb_true_iff in D1. - destruct D1 as [[? ?] ?]. - split; [split |]; auto. - unfold link_pol_comp. - rewrite PTree.beq_correct. intros x. - assert (G: forall A B (f: A -> B) (t: PTree.t A), map (fun '(id, x) => (id, f x)) (PTree.elements t) = - PTree.elements (PTree.map1 f t)). - { clear. - intros. - unfold PTree.elements. generalize 1%positive. - assert (H: map (fun '(id, x) => (id, f x)) nil = (nil: list (positive * B))) by reflexivity. - revert H. - generalize (nil: list (positive * B)). - generalize (nil: list (positive * A)). - induction t using PTree.tree_ind. - - intros; auto. - - intros l0 l1 EQ p. - destruct l; simpl in *; auto. - + destruct o; simpl in *; auto. - * destruct r; simpl in *; try rewrite EQ; auto. - erewrite IHt0; auto. - * destruct r; simpl in *; auto. - + destruct o; simpl in *; auto. - * destruct r; simpl in *; auto. - now erewrite IHt; eauto; simpl; rewrite EQ. - now erewrite IHt; eauto; simpl; erewrite IHt0. - * destruct r; simpl in *; auto. - } - rewrite !G. - rewrite !PTree_Properties.of_list_elements. - rewrite !PTree.gmap1. - unfold option_map. - assert (option_rel (match_globdef match_fundef match_varinfo ctx) - (PTree.combine link_prog_merge (prog_defmap p1) (prog_defmap p2)) ! x - (PTree.combine link_prog_merge (prog_defmap tp1) (prog_defmap tp2)) ! x). - { - rewrite ! PTree.gcombine by auto. - generalize (match_program_defmap _ _ _ _ _ H0 x) (match_program_defmap _ _ _ _ _ H1 x). - clear R. intros R1 R2; inv R1; inv R2; unfold link_prog_merge. -* constructor. -* constructor. apply match_globdef_linkorder with ctx2; auto. -* constructor. apply match_globdef_linkorder with ctx1; auto. -* exploit Q; eauto. intros (X & Y & gd & Z). - exploit link_match_globdef. eexact H2. eexact H3. eauto. eauto. eauto. - intros (tg & TL & MG). rewrite Z, TL. constructor; auto. } - inv H7; auto. inv H10; auto. - apply has_comp_match_fundef in H11. simpl; rewrite H11. - now destruct cp_eq_dec. - inv H7; simpl; now destruct cp_eq_dec. Qed. +(* unfold Policy.eqb. *) +(* rewrite !andb_true_iff. unfold CompTree.beq. simpl. *) +(* clear yes. unfold Policy.eqb in D1. rewrite !andb_true_iff in D1. *) +(* destruct D1 as [[? ?] ?]. *) +(* split; [split |]; auto. *) +(* unfold link_pol_comp. *) +(* rewrite PTree.beq_correct. intros x. *) +(* assert (G: forall A B (f: A -> B) (t: PTree.t A), map (fun '(id, x) => (id, f x)) (PTree.elements t) = *) +(* PTree.elements (PTree.map1 f t)). *) +(* { clear. *) +(* intros. *) +(* unfold PTree.elements. generalize 1%positive. *) +(* assert (H: map (fun '(id, x) => (id, f x)) nil = (nil: list (positive * B))) by reflexivity. *) +(* revert H. *) +(* generalize (nil: list (positive * B)). *) +(* generalize (nil: list (positive * A)). *) +(* induction t using PTree.tree_ind. *) +(* - intros; auto. *) +(* - intros l0 l1 EQ p. *) +(* destruct l; simpl in *; auto. *) +(* + destruct o; simpl in *; auto. *) +(* * destruct r; simpl in *; try rewrite EQ; auto. *) +(* erewrite IHt0; auto. *) +(* * destruct r; simpl in *; auto. *) +(* + destruct o; simpl in *; auto. *) +(* * destruct r; simpl in *; auto. *) +(* now erewrite IHt; eauto; simpl; rewrite EQ. *) +(* now erewrite IHt; eauto; simpl; erewrite IHt0. *) +(* * destruct r; simpl in *; auto. *) +(* } *) +(* rewrite !G. *) +(* rewrite !PTree_Properties.of_list_elements. *) +(* rewrite !PTree.gmap1. *) +(* unfold option_map. *) +(* assert (option_rel (match_globdef match_fundef match_varinfo ctx) *) +(* (PTree.combine link_prog_merge (prog_defmap p1) (prog_defmap p2)) ! x *) +(* (PTree.combine link_prog_merge (prog_defmap tp1) (prog_defmap tp2)) ! x). *) +(* { *) +(* rewrite ! PTree.gcombine by auto. *) +(* generalize (match_program_defmap _ _ _ _ _ H0 x) (match_program_defmap _ _ _ _ _ H1 x). *) +(* clear R. intros R1 R2; inv R1; inv R2; unfold link_prog_merge. *) +(* * constructor. *) +(* * constructor. apply match_globdef_linkorder with ctx2; auto. *) +(* * constructor. apply match_globdef_linkorder with ctx1; auto. *) +(* * exploit Q; eauto. intros (X & Y & gd & Z). *) +(* exploit link_match_globdef. eexact H2. eexact H3. eauto. eauto. eauto. *) +(* intros (tg & TL & MG). rewrite Z, TL. constructor; auto. } *) +(* inv H7; auto. inv H10; auto. *) +(* apply has_comp_match_fundef in H11. simpl; rewrite H11. *) +(* now destruct cp_eq_dec. *) +(* inv H7; simpl; now destruct cp_eq_dec. *) +(* Qed. *) End LINK_MATCH_PROGRAM. @@ -984,8 +1072,8 @@ Global Instance TransfPartialContextualLink Proof. red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. -- intros ? ? ? ?. eapply has_comp_transl_partial_match; eauto. - eapply comp_transf_partial_fundef. eauto. +(* - intros ? ? ? ?. eapply has_comp_transl_partial_match; eauto. *) +(* eapply comp_transf_partial_fundef. eauto. *) - intros. eapply link_transf_partial_fundef; eauto. - intros; subst. exists v; auto. Qed. @@ -1002,8 +1090,8 @@ Global Instance TransfPartialLink Proof. red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. -- intros ? ? ? ?. eapply has_comp_transl_partial_match; eauto. - eapply comp_transf_partial_fundef. eauto. +(* - intros ? ? ? ?. eapply has_comp_transl_partial_match; eauto. *) +(* eapply comp_transf_partial_fundef. eauto. *) - intros. eapply link_transf_partial_fundef; eauto. - intros; subst. exists v; auto. Qed. @@ -1021,8 +1109,8 @@ Global Instance TransfTotallContextualLink Proof. red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. -- intros ? ? ? ?. eapply has_comp_transl_match; eauto. - eapply comp_transf_fundef. eauto. +(* - intros ? ? ? ?. eapply has_comp_transl_match; eauto. *) +(* eapply comp_transf_fundef. eauto. *) - intros. subst. destruct f1, f2; simpl in *. + discriminate. + destruct e; try easy. @@ -1047,8 +1135,8 @@ Global Instance TransfTotalLink Proof. red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. eapply link_match_program; eauto. -- intros ? ? ? ?. eapply has_comp_transl_match; eauto. - eapply comp_transf_fundef. eauto. +(* - intros ? ? ? ?. eapply has_comp_transl_match; eauto. *) +(* eapply comp_transf_fundef. eauto. *) - intros. subst. destruct f1, f2; simpl in *. + discriminate. + destruct e; try easy.