(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(** Animating the CompCert C semantics *)
Require Cstrategy.
Local Open Scope string_scope.
Local Open Scope list_scope.
(** Error monad with options or lists *)
Notation "'do' X <- A ; B" := (match A with Some X => B | None => None end)
(at level 200, X ident, A at level 100, B at level 200)
: option_monad_scope.
Notation "'do' X , Y <- A ; B" := (match A with Some (X, Y) => B | None => None end)
(at level 200, X ident, Y ident, A at level 100, B at level 200)
: option_monad_scope.
Notation "'do' X , Y , Z <- A ; B" := (match A with Some (X, Y, Z) => B | None => None end)
(at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200)
: option_monad_scope.
Notation " 'check' A ; B" := (if A then B else None)
(at level 200, A at level 100, B at level 200)
: option_monad_scope.
Notation "'do' X <- A ; B" := (match A with Some X => B | None => nil end)
(at level 200, X ident, A at level 100, B at level 200)
: list_monad_scope.
Notation " 'check' A ; B" := (if A then B else nil)
(at level 200, A at level 100, B at level 200)
: list_monad_scope.
Definition is_val (a: expr) : option (val * type) :=
match a with
| Eval v ty => Some(v, ty)
| _ => None
end.
Definition is_loc (a: expr) : option (block * ptrofs * type) :=
match a with
| Eloc b ofs ty => Some(b, ofs, ty)
| _ => None
end.
Local Open Scope option_monad_scope.
Fixpoint is_val_list (al: exprlist) : option (list (val * type)) :=
match al with
| Enil => Some nil
| Econs a1 al => do vt1 <- is_val a1; do vtl <- is_val_list al; Some(vt1::vtl)
end.
Definition is_skip (s: statement) : {s = Sskip} + {s <> Sskip}.
Proof with try discriminate.
induction vl; destruct tl; simpl; intros; inv H.
constructor.
destruct (eventval_of_val a t) as [ev1|] eqn:?...
destruct (list_eventval_of_val vl tl) as [evl'|] eqn:?...
inv H1. constructor. apply eventval_of_val_sound; auto. eauto.
Qed.
(** Volatile memory accesses. *)
Definition do_volatile_load (w: world) (chunk: memory_chunk) (m: mem) (b: block) (ofs: ptrofs)
: option (world * trace * val) :=
if Genv.block_is_volatile ge b then
do id <- Genv.invert_symbol ge b;
match nextworld_vload w chunk id ofs with
| None => None
| Some(res, w') =>
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
else
do v <- Mem.load chunk m b (Ptrofs.unsigned ofs);
Some(w, E0, v).
Definition do_volatile_store (w: world) (chunk: memory_chunk) (m: mem) (b: block) (ofs: ptrofs) (v: val)
: option (world * trace * mem) :=
if Genv.block_is_volatile ge b then
do id <- Genv.invert_symbol ge b;
do ev <- eventval_of_val (Val.load_result chunk v) (type_of_chunk chunk);
do w' <- nextworld_vstore w chunk id ofs ev;
Some(w', Event_vstore chunk id ofs ev :: nil, m)
else
do m' <- Mem.store chunk m b (Ptrofs.unsigned ofs) v;
Some(w, E0, m').
(** Accessing locations *)
Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) : option (world * trace * val) :=
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(w, E0, v)
| true => do_volatile_load w chunk m b ofs
end
| By_reference => Some(w, E0, Vptr b ofs)
| By_copy => Some(w, E0, Vptr b ofs)
| _ => None
end.
Definition assign_copy_ok (ty: type) (b: block) (ofs: ptrofs) (b': block) (ofs': ptrofs) : Prop :=
(alignof_blockcopy ge ty | Ptrofs.unsigned ofs') /\ (alignof_blockcopy ge ty | Ptrofs.unsigned ofs) /\
(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').
Remark check_assign_copy:
forall (ty: type) (b: block) (ofs: ptrofs) (b': block) (ofs': ptrofs),
{ assign_copy_ok ty b ofs b' ofs' } + {~ assign_copy_ok ty b ofs b' ofs' }.
Proof with try (right; intuition omega).
intros. unfold assign_copy_ok.
destruct (Zdivide_dec (alignof_blockcopy ge ty) (Ptrofs.unsigned ofs')); auto...
destruct (Zdivide_dec (alignof_blockcopy ge ty) (Ptrofs.unsigned ofs)); auto...
assert (Y: {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'} +
{~(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')}).
destruct (eq_block b' b); auto.
destruct (zeq (Ptrofs.unsigned ofs') (Ptrofs.unsigned ofs)); auto.
destruct (zle (Ptrofs.unsigned ofs' + sizeof ge ty) (Ptrofs.unsigned ofs)); auto.
destruct (zle (Ptrofs.unsigned ofs + sizeof ge ty) (Ptrofs.unsigned ofs')); auto.
right; intuition omega.
destruct Y... left; intuition omega.
Defined.
Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) (v: val): option (world * trace * mem) :=
match access_mode ty with
| By_value chunk =>
match type_is_volatile ty with
| false => do m' <- Mem.storev chunk m (Vptr b ofs) v; Some(w, E0, m')
| true => do_volatile_store w chunk m b ofs v
end
| By_copy =>
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);
do m' <- Mem.storebytes m b (Ptrofs.unsigned ofs) bytes;
Some(w, E0, m')
else None
| _ => None
end
| _ => None
end.
(** External calls *)
Variable do_external_function:
string -> signature -> Senv.t -> world -> list val -> mem -> option (world * trace * val * mem).
Hypothesis do_external_function_sound:
forall id sg ge vargs m t vres m' w w',
do_external_function id sg ge w vargs m = Some(w', t, vres, m') ->
external_functions_sem id sg ge vargs m t vres m' /\ possible_trace w t w'.
Hypothesis do_external_function_complete:
forall id sg ge vargs m t vres m' w w',
external_functions_sem id sg ge vargs m t vres m' ->
possible_trace w t w' ->
do_external_function id sg ge w vargs m = Some(w', t, vres, m').
Variable do_inline_assembly:
string -> signature -> Senv.t -> world -> list val -> mem -> option (world * trace * val * mem).
Hypothesis do_inline_assembly_sound:
forall txt sg ge vargs m t vres m' w w',
do_inline_assembly txt sg ge w vargs m = Some(w', t, vres, m') ->
inline_assembly_sem txt sg ge vargs m t vres m' /\ possible_trace w t w'.
Hypothesis do_inline_assembly_complete:
forall txt sg ge vargs m t vres m' w w',
inline_assembly_sem txt sg ge vargs m t vres m' ->
possible_trace w t w' ->
do_inline_assembly txt sg ge w vargs m = Some(w', t, vres, m').
Definition do_ef_volatile_load (chunk: memory_chunk)
(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 m b ofs; Some(w',t,v,m)
| _ => None
end.
Definition do_ef_volatile_store (chunk: memory_chunk)
(w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) :=
match vargs with
| Vptr b ofs :: v :: nil => do w',t,m' <- do_volatile_store w chunk m b ofs v; Some(w',t,Vundef,m')
| _ => None
end.
Definition do_ef_volatile_load_global (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 chunk w (Vptr b ofs :: vargs) m.
Definition do_ef_volatile_store_global (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 chunk w (Vptr b ofs :: vargs) m.
Definition do_alloc_size (v: val) : option ptrofs :=
match v with
| Vint n => if Archi.ptr64 then None else Some (Ptrofs.of_int n)
| Vlong n => if Archi.ptr64 then Some (Ptrofs.of_int64 n) else None
| _ => None
end.
Definition do_ef_malloc
(w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) :=
match vargs with
| v :: nil =>
do sz <- do_alloc_size v;
let (m', b) := Mem.alloc m (- size_chunk Mptr) (Ptrofs.unsigned sz) in
do m'' <- Mem.store Mptr m' b (- size_chunk Mptr) v;
Some(w, E0, Vptr b Ptrofs.zero, m'')
| _ => None
end.
Definition do_ef_free
(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);
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);
Some(w, E0, Vundef, m')
| Vint n :: nil =>
if Int.eq_dec n Int.zero && negb Archi.ptr64
then Some(w, E0, Vundef, m)
else None
| Vlong n :: nil =>
if Int64.eq_dec n Int64.zero && Archi.ptr64
then Some(w, E0, Vundef, m)
else None
| _ => None
end.
Definition memcpy_args_ok
(sz al: Z) (bdst: block) (odst: Z) (bsrc: block) (osrc: Z) : Prop :=
(al = 1 \/ al = 2 \/ al = 4 \/ al = 8)
/\ sz >= 0 /\ (al | sz)
/\ (sz > 0 -> (al | osrc))
/\ (sz > 0 -> (al | odst))
/\ (bsrc <> bdst \/ osrc = odst \/ osrc + sz <= odst \/ odst + sz <= osrc).
Definition do_ef_memcpy (sz al: Z)
(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
do bytes <- Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz;
do m' <- Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes;
Some(w, E0, Vundef, m')
else None
| _ => None
end.
Definition do_ef_annot (text: string) (targs: list typ)
(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 (text: string) (targ: typ)
(w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) :=
match vargs with
| varg :: nil =>
do arg <- eventval_of_val varg targ;
Some(w, Event_annot text (arg :: nil) :: E0, varg, m)
| _ => None
end.
Definition do_ef_debug (kind: positive) (text: ident) (targs: list typ)
(w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) :=
Some(w, E0, Vundef, m).
Definition do_builtin_or_external (name: string) (sg: signature)
(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 w vargs m
end.
Definition do_external (ef: external_function):
world -> list val -> mem -> option (world * trace * val * mem) :=
match ef with
| 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.
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 sg,
do_builtin_or_external name sg w vargs m = Some (w', t, vres, m') ->
builtin_or_external_sem name sg ge 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.
split. constructor; auto. constructor.
- eapply do_external_function_sound; eauto.
}
destruct ef; simpl.
- (* EF_external *)
eapply do_external_function_sound; eauto.
- (* EF_builtin *)
eapply BF_EX; eauto.
- (* EF_runtime *)
eapply BF_EX; eauto.
- (* EF_vload *)
unfold do_ef_volatile_load. destruct vargs... destruct v... destruct vargs...
mydestr. destruct p as [[w'' t''] v]; mydestr.
exploit do_volatile_load_sound; eauto. intuition. econstructor; eauto.
- (* EF_vstore *)
unfold do_ef_volatile_store. destruct vargs... destruct v... destruct vargs... destruct vargs...
mydestr. destruct p as [[w'' t''] m'']. mydestr.
exploit do_volatile_store_sound; eauto. intuition. econstructor; eauto.
- (* EF_malloc *)
unfold do_ef_malloc. destruct vargs... destruct vargs... mydestr.
destruct (Mem.alloc m (- size_chunk Mptr) (Ptrofs.unsigned i)) as [m1 b] eqn:?. mydestr.
split. apply SIZE in Heqo. subst v. econstructor; eauto. constructor.
- (* EF_free *)
unfold do_ef_free. destruct vargs... destruct v...
+ destruct vargs... mydestr; InvBooleans; subst i.
replace (Vint Int.zero) with Vnullptr. split; constructor.
apply negb_true_iff in H0. unfold Vnullptr; rewrite H0; auto.
+ destruct vargs... mydestr; InvBooleans; subst i.
replace (Vlong Int64.zero) with Vnullptr. split; constructor.
unfold Vnullptr; rewrite H0; auto.
+ destruct vargs... mydestr.
split. apply SIZE in Heqo0. econstructor; eauto. congruence. omega.
constructor.
- (* EF_memcpy *)
unfold do_ef_memcpy. destruct vargs... destruct v... destruct vargs...
destruct v... destruct vargs... mydestr.
apply Decidable_sound in Heqb1. red in Heqb1.
split. econstructor; eauto; tauto. constructor.
- (* EF_annot *)
unfold do_ef_annot. mydestr.
split. constructor. apply list_eventval_of_val_sound; auto.
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.
econstructor. constructor; eauto. constructor.
- (* EF_inline_asm *)
eapply do_inline_assembly_sound; eauto.
- (* EF_debug *)
unfold do_ef_debug. mydestr. split; constructor.
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').