Section DETERMINISM.
Definition deterministic {A B} (R: A -> B -> Prop):=
forall a b b', R a b -> R a b' -> b = b'.
Admitted.
End DETERMINISM.
End StrongRelaxedInjections.
Definition trivial_inject t:=
forall f t',
inject_trace f t t' -> t' = t.
Ltac trivial_inject_trace:=
match goal with
| [H: inject_trace ?f ?t ?t' |- _  ] =>
inversion H; subst; clear H;
try trivial_inject_event
end.
Ltac solve_trivial_inject:=
lazymatch goal with
| [|- trivial_inject ?T] =>
match goal with
|[H:context[T] |- _ ] =>
intros ???;
inversion H; subst;
repeat trivial_inject_trace; reflexivity
end
| _ => fail "Not an noninjectable goal."
end.
Definition injection_full (f:meminj) (m:mem):=
forall b ,
Mem.valid_block m b ->
~ f b = None.
Record extcall_properties (sem: extcall_sem) (sg: signature) : Prop :=
mk_extcall_properties {
(** 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 ->
Val.has_type vres (proj_sig_res sg);
(** 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;
(** 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 ->
Mem.valid_block m1 b -> Mem.valid_block m2 b;
(** 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 ->
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,
sem ge vargs m1 t vres m2 ->
Mem.unchanged_on (loc_not_writable 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 ->
Mem.extends m1 m1' ->
Val.lessdef_list vargs vargs' ->
exists vres', exists m2',
sem ge vargs' m1' t vres' m2'
/\ Val.lessdef vres vres'
/\ Mem.extends m2 m2'
/\ Mem.unchanged_on (loc_out_of_bounds m1) m1' m2';
(** External calls must commute with memory injections, in the following sense. *)
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 ->
Mem.inject f m1 m1' ->
injection_full f m1 ->
Val.inject_list f vargs vargs' ->
exists f', exists vres', exists m2', exists t',
sem ge2 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'
/\ inject_trace f' t t'
/\ injection_full f' m2;
(** External calls must commute with memory injections, in the following sense. *)
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 ->
Mem.inject f m1 m1' ->
Val.inject_list f vargs vargs' ->
exists f', exists vres', exists m2', exists t',
sem ge2 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'
/\ inject_trace f' t t';
(** 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;
(** 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;
(** 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)
}.
(** ** Semantics of volatile loads *)
Inductive volatile_load_sem (chunk: memory_chunk) (ge: Senv.t):
list val -> mem -> trace -> val -> mem -> Prop :=
| volatile_load_sem_intro: forall b ofs m t v,
volatile_load ge chunk m b ofs t v ->
volatile_load_sem chunk ge (Vptr b ofs :: nil) m t v m.
(* Lemma volatile_load_trivial_inject: forall {ge chunk m b ofs t vres}, volatile_load ge chunk m b ofs t vres -> trivial_inject t.  (** ** Semantics of volatile stores *)
Inductive volatile_store_sem (chunk: memory_chunk) (ge: Senv.t):
list val -> mem -> trace -> val -> mem -> Prop :=
| volatile_store_sem_intro: forall b ofs m1 v t m2,
volatile_store ge chunk m1 b ofs v t m2 ->
volatile_store_sem chunk ge (Vptr b ofs :: v :: nil) m1 t Vundef m2.
(*Lemma volatile_store_trivial_inject: forall {ge chunk m b ofs v t m'}, volatile_store ge chunk m b ofs v t m' -> trivial_inject t.  (** ** Semantics of dynamic memory allocation (malloc) *)
Inductive extcall_malloc_sem (ge: Senv.t):
list val -> mem -> trace -> val -> mem -> Prop :=
| extcall_malloc_sem_intro: forall sz m m' b m'',
Mem.alloc m (- size_chunk Mptr) (Ptrofs.unsigned sz) = (m', b) ->
Mem.store Mptr m' b (- size_chunk Mptr) (Vptrofs sz) = Some m'' ->
extcall_malloc_sem ge (Vptrofs sz :: nil) m E0 (Vptr b Ptrofs.zero) m''.
intros. exploit Mem.alloc_parallel_inject; eauto.
intros [? [? [? [? [? [? [? ?]]]]]]].
repeat (econstructor; eauto).
intros b HH.
destruct (ident_eq b b1).
- subst. rewrite H7; discriminate.
- rewrite H8; auto. eapply H1.
eapply Mem.valid_block_alloc_inv in H0; eauto.
destruct H0; auto. subst; contradict n; auto.
Qed.
(** ** Semantics of dynamic memory deallocation (free) *)
Inductive extcall_free_sem (ge: Senv.t):
list val -> mem -> trace -> val -> mem -> Prop :=
| extcall_free_sem_intro: forall b lo sz m m',
Mem.load Mptr m b (Ptrofs.unsigned lo - size_chunk Mptr) = Some (Vptrofs sz) ->
Ptrofs.unsigned sz > 0 ->
Mem.free m b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz) = Some m' ->
extcall_free_sem ge (Vptr b lo :: nil) m E0 Vundef m'.
(** ** Semantics of [memcpy] operations. *)
Inductive extcall_memcpy_sem (sz al: Z) (ge: Senv.t):
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) ->
(sz > 0 -> (al | Ptrofs.unsigned osrc)) ->
(sz > 0 -> (al | Ptrofs.unsigned odst)) ->
bsrc <> bdst \/ Ptrofs.unsigned osrc = Ptrofs.unsigned odst
\/ Ptrofs.unsigned osrc + sz <= Ptrofs.unsigned odst
\/ Ptrofs.unsigned odst + sz <= Ptrofs.unsigned osrc ->
Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz = Some bytes ->
Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes = Some m' ->
extcall_memcpy_sem sz al ge (Vptr bdst odst :: Vptr bsrc osrc :: nil) m E0 Vundef m'.
(** ** Semantics of annotations. *)
Inductive extcall_annot_sem (text: string) (targs: list typ) (ge: Senv.t):
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 text targs ge vargs m (Event_annot text args :: E0) Vundef m.
Inductive extcall_annot_val_sem (text: string) (targ: typ) (ge: Senv.t):
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 text targ ge (varg :: nil) m (Event_annot text (arg :: nil) :: E0) varg m.
Inductive extcall_debug_sem (ge: Senv.t):
list val -> mem -> trace -> val -> mem -> Prop :=
| extcall_debug_sem_intro: forall vargs m,
extcall_debug_sem ge vargs m E0 Vundef m.
(** ** Semantics of external functions. *)
(** For functions defined outside the program ([EF_external], [EF_builtin] and [EF_runtime]), we do not define their semantics, but only assume that it satisfies [extcall_properties]. *)
Parameter external_functions_sem: String.string -> signature -> extcall_sem.

Axiom external_functions_properties:
forall id sg, extcall_properties (external_functions_sem id sg) sg.