Section MATCH_TRACES_INV.
Variables ge1 ge2: Senv.t.
Hypothesis public_preserved:
forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id.
End MATCH_TRACES_INV.
(** An output trace is a trace composed only of output events, that is, events that do not take any result from the outside world. *)
Definition output_event (ev: event) : Prop :=
match ev with
| Event_syscall _ _ _ => False
| Event_vload _ _ _ _ => False
| Event_vstore _ _ _ _ => True
| Event_annot _ _ => True
end.
Fixpoint output_trace (t: trace) : Prop :=
match t with
| nil => True
| ev :: t' => output_event ev /\ output_trace t'
end.
(** * Semantics of volatile memory accesses *)
Inductive volatile_load (ge: Senv.t):
memory_chunk -> mem -> block -> ptrofs -> trace -> val -> Prop :=
| 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 ->
eventval_match ge ev (type_of_chunk chunk) v ->
volatile_load ge chunk m b ofs
(Event_vload chunk id ofs ev :: nil)
(Val.load_result chunk v)
| volatile_load_nonvol: forall chunk m b ofs v,
Senv.block_is_volatile ge b = false ->
Mem.load chunk m b (Ptrofs.unsigned ofs) = Some v ->
volatile_load ge chunk m b ofs E0 v.
Inductive volatile_store (ge: Senv.t):
memory_chunk -> mem -> block -> ptrofs -> val -> trace -> mem -> Prop :=
| 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 ->
eventval_match ge ev (type_of_chunk chunk) (Val.load_result chunk v) ->
volatile_store ge chunk m b ofs v
(Event_vstore chunk id ofs ev :: nil)
m
| volatile_store_nonvol: forall chunk m b ofs v m',
Senv.block_is_volatile ge b = false ->
Mem.store chunk m b (Ptrofs.unsigned ofs) v = Some m' ->
volatile_store ge 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 this predicate. *)
Definition loc_out_of_bounds (m: mem) (b: block) (ofs: Z) : Prop :=
~Mem.perm m b ofs Max Nonempty.
Definition loc_not_writable (m: mem) (b: block) (ofs: Z) : Prop :=
~Mem.perm m b ofs Max Writable.
Definition loc_unmapped (f: meminj) (b: block) (ofs: Z): Prop :=
f b = None.
Definition loc_out_of_reach (f: meminj) (m: mem) (b: block) (ofs: Z): Prop :=
forall b0 delta,
f b0 = Some(b, delta) -> ~Mem.perm m b0 (ofs - delta) Max Nonempty.
Definition inject_separated (f f': meminj) (m1 m2: mem): Prop :=
forall b1 b2 delta,
f b1 = None -> f' b1 = Some(b2, delta) ->
~Mem.valid_block m1 b1 /\ ~Mem.valid_block m2 b2.
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' ->
Val.inject_list f vargs vargs' ->
exists f', exists vres', exists m2',
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';
(** 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.
(** ** 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.
(** ** 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''.
(** ** 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.
(** We treat inline assembly similarly. *)
Parameter inline_assembly_sem: String.string -> signature -> extcall_sem.
(** ** Combined semantics of external calls *)
(** 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 - 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).  This predicate is used in the semantics of all CompCert languages. *)
Definition external_call (ef: external_function): extcall_sem :=
match ef with
| EF_external name sg  => external_functions_sem name sg
| EF_builtin name sg   => external_functions_sem name sg
| EF_runtime name sg   => external_functions_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.
Definition external_call_well_typed 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_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).
(** Corollary of [external_call_valid_block]. *)
(** Special case of [external_call_mem_inject_gen] (for backward compatibility) *)
Definition meminj_preserves_globals (F V: Type) (ge: Genv.t F V) (f: block -> option (block * Z)) : Prop :=
(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).

Lemma external_call_mem_inject:
forall ef F V (ge: Genv.t F V) vargs m1 t vres m2 f m1' vargs',
meminj_preserves_globals ge f ->
external_call ef ge vargs m1 t vres m2 ->
Mem.inject f m1 m1' ->
Val.inject_list f vargs vargs' ->
exists f', exists vres', exists m2',
external_call ef ge vargs' m1' t vres' m2'
/\ Val.inject f' vres vres'
/\ Mem.inject f' m2 m2'
/\ Mem.unchanged_on (loc_unmapped f) m1 m2
/\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2'
/\ inject_incr f f'
/\ inject_separated f f' m1 m1'.