Section EXPRS.
Variable e: env.
Variable w: world.
Fixpoint sem_cast_arguments (vtl: list (val * type)) (tl: typelist) (m: mem) : option (list val) :=
match vtl, tl with
| nil, Tnil => Some nil
| (v1,t1)::vtl, Tcons t1' tl =>
do v <- sem_cast v1 t1 t1' m; do vl <- sem_cast_arguments vtl tl m; Some(v::vl)
| _, _ => None
end.
(** The result of stepping an expression is a list [ll] of possible reducts. Each element of [ll] is a pair of a context and the result of reducing inside this context (see type [reduction] above). The list [ll] is empty if the expression is fully reduced (it's [Eval] for a r-value and [Eloc] for a l-value). *)
Definition reducts (A: Type): Type := list ((expr -> A) * reduction).
Definition topred (r: reduction) : reducts expr :=
((fun (x: expr) => x), r) :: nil.
Definition stuck : reducts expr :=
((fun (x: expr) => x), Stuckred) :: nil.
Definition incontext {A B: Type} (ctx: A -> B) (ll: reducts A) : reducts B :=
map (fun z => ((fun (x: expr) => ctx(fst z x)), snd z)) ll.
Definition incontext2 {A1 A2 B: Type}
(ctx1: A1 -> B) (ll1: reducts A1)
(ctx2: A2 -> B) (ll2: reducts A2) : reducts B :=
incontext ctx1 ll1 ++ incontext ctx2 ll2.
Notation "'do' X <- A ; B" := (match A with Some X => B | None => stuck end)
(at level 200, X ident, A at level 100, B at level 200)
: reducts_monad_scope.
Notation "'do' X , Y <- A ; B" := (match A with Some (X, Y) => B | None => stuck end)
(at level 200, X ident, Y ident, A at level 100, B at level 200)
: reducts_monad_scope.
Notation "'do' X , Y , Z <- A ; B" := (match A with Some (X, Y, Z) => B | None => stuck end)
(at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200)
: reducts_monad_scope.
Notation " 'check' A ; B" := (if A then B else stuck)
(at level 200, A at level 100, B at level 200)
: reducts_monad_scope.
Local Open Scope reducts_monad_scope.
Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr :=
match k, a with
| LV, Eloc b ofs ty =>
nil
| LV, Evar x ty =>
match e!x with
| Some(b, ty') =>
check type_eq ty ty';
topred (Lred "red_var_local" (Eloc b Ptrofs.zero ty) m)
| None =>
do b <- Genv.find_symbol ge x;
topred (Lred "red_var_global" (Eloc b Ptrofs.zero ty) m)
end
| LV, Ederef r ty =>
match is_val r with
| Some(Vptr b ofs, ty') =>
topred (Lred "red_deref" (Eloc b ofs ty) m)
| Some _ =>
stuck
| None =>
incontext (fun x => Ederef x ty) (step_expr RV r m)
end
| LV, Efield r f ty =>
match is_val r with
| Some(Vptr b ofs, ty') =>
match ty' with
| Tstruct id _ =>
do co <- ge.(genv_cenv)!id;
match field_offset ge f (co_members co) with
| Error _ => stuck
| OK delta => topred (Lred "red_field_struct" (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) ty) m)
end
| Tunion id _ =>
do co <- ge.(genv_cenv)!id;
topred (Lred "red_field_union" (Eloc b ofs ty) m)
| _ => stuck
end
| Some _ =>
stuck
| None =>
incontext (fun x => Efield x f ty) (step_expr RV r m)
end
| RV, Eval v ty =>
nil
| RV, Evalof l ty =>
match is_loc l with
| Some(b, ofs, ty') =>
check type_eq ty ty';
do w',t,v <- do_deref_loc w ty m b ofs;
topred (Rred "red_rvalof" (Eval v ty) m t)
| None =>
incontext (fun x => Evalof x ty) (step_expr LV l m)
end
| RV, Eaddrof l ty =>
match is_loc l with
| Some(b, ofs, ty') => topred (Rred "red_addrof" (Eval (Vptr b ofs) ty) m E0)
| None => incontext (fun x => Eaddrof x ty) (step_expr LV l m)
end
| RV, Eunop op r1 ty =>
match is_val r1 with
| Some(v1, ty1) =>
do v <- sem_unary_operation op v1 ty1 m;
topred (Rred "red_unop" (Eval v ty) m E0)
| None =>
incontext (fun x => Eunop op x ty) (step_expr RV r1 m)
end
| RV, Ebinop op r1 r2 ty =>
match is_val r1, is_val r2 with
| Some(v1, ty1), Some(v2, ty2) =>
do v <- sem_binary_operation ge op v1 ty1 v2 ty2 m;
topred (Rred "red_binop" (Eval v ty) m E0)
| _, _ =>
incontext2 (fun x => Ebinop op x r2 ty) (step_expr RV r1 m)
(fun x => Ebinop op r1 x ty) (step_expr RV r2 m)
end
| RV, Ecast r1 ty =>
match is_val r1 with
| Some(v1, ty1) =>
do v <- sem_cast v1 ty1 ty m;
topred (Rred "red_cast" (Eval v ty) m E0)
| None =>
incontext (fun x => Ecast x ty) (step_expr RV r1 m)
end
| RV, Eseqand r1 r2 ty =>
match is_val r1 with
| Some(v1, ty1) =>
do b <- bool_val v1 ty1 m;
if b then topred (Rred "red_seqand_true" (Eparen r2 type_bool ty) m E0)
else topred (Rred "red_seqand_false" (Eval (Vint Int.zero) ty) m E0)
| None =>
incontext (fun x => Eseqand x r2 ty) (step_expr RV r1 m)
end
| RV, Eseqor r1 r2 ty =>
match is_val r1 with
| Some(v1, ty1) =>
do b <- bool_val v1 ty1 m;
if b then topred (Rred "red_seqor_true" (Eval (Vint Int.one) ty) m E0)
else topred (Rred "red_seqor_false" (Eparen r2 type_bool ty) m E0)
| None =>
incontext (fun x => Eseqor x r2 ty) (step_expr RV r1 m)
end
| RV, Econdition r1 r2 r3 ty =>
match is_val r1 with
| Some(v1, ty1) =>
do b <- bool_val v1 ty1 m;
topred (Rred "red_condition" (Eparen (if b then r2 else r3) ty ty) m E0)
| None =>
incontext (fun x => Econdition x r2 r3 ty) (step_expr RV r1 m)
end
| RV, Esizeof ty' ty =>
topred (Rred "red_sizeof" (Eval (Vptrofs (Ptrofs.repr (sizeof ge ty'))) ty) m E0)
| RV, Ealignof ty' ty =>
topred (Rred "red_alignof" (Eval (Vptrofs (Ptrofs.repr (alignof ge ty'))) ty) m E0)
| RV, Eassign l1 r2 ty =>
match is_loc l1, is_val r2 with
| Some(b, ofs, ty1), Some(v2, ty2) =>
check type_eq ty1 ty;
do v <- sem_cast v2 ty2 ty1 m;
do w',t,m' <- do_assign_loc w ty1 m b ofs v;
topred (Rred "red_assign" (Eval v ty) m' t)
| _, _ =>
incontext2 (fun x => Eassign x r2 ty) (step_expr LV l1 m)
(fun x => Eassign l1 x ty) (step_expr RV r2 m)
end
| RV, Eassignop op l1 r2 tyres ty =>
match is_loc l1, is_val r2 with
| Some(b, ofs, ty1), Some(v2, ty2) =>
check type_eq ty1 ty;
do w',t,v1 <- do_deref_loc w ty1 m b ofs;
let r' := Eassign (Eloc b ofs ty1)
(Ebinop op (Eval v1 ty1) (Eval v2 ty2) tyres) ty1 in
topred (Rred "red_assignop" r' m t)
| _, _ =>
incontext2 (fun x => Eassignop op x r2 tyres ty) (step_expr LV l1 m)
(fun x => Eassignop op l1 x tyres ty) (step_expr RV r2 m)
end
| RV, Epostincr id l ty =>
match is_loc l with
| Some(b, ofs, ty1) =>
check type_eq ty1 ty;
do w',t, v1 <- do_deref_loc w ty m b ofs;
let op := match id with Incr => Oadd | Decr => Osub end in
let r' :=
Ecomma (Eassign (Eloc b ofs ty)
(Ebinop op (Eval v1 ty) (Eval (Vint Int.one) type_int32s) (incrdecr_type ty))
ty)
(Eval v1 ty) ty in
topred (Rred "red_postincr" r' m t)
| None =>
incontext (fun x => Epostincr id x ty) (step_expr LV l m)
end
| RV, Ecomma r1 r2 ty =>
match is_val r1 with
| Some _ =>
check type_eq (typeof r2) ty;
topred (Rred "red_comma" r2 m E0)
| None =>
incontext (fun x => Ecomma x r2 ty) (step_expr RV r1 m)
end
| RV, Eparen r1 tycast ty =>
match is_val r1 with
| Some (v1, ty1) =>
do v <- sem_cast v1 ty1 tycast m;
topred (Rred "red_paren" (Eval v ty) m E0)
| None =>
incontext (fun x => Eparen x tycast ty) (step_expr RV r1 m)
end
| RV, Ecall r1 rargs ty =>
match is_val r1, is_val_list rargs with
| Some(vf, tyf), Some vtl =>
match classify_fun tyf with
| fun_case_f tyargs tyres cconv =>
do fd <- Genv.find_funct ge vf;
do vargs <- sem_cast_arguments vtl tyargs m;
check type_eq (type_of_fundef fd) (Tfunction tyargs tyres cconv);
topred (Callred "red_call" fd vargs ty m)
| _ => stuck
end
| _, _ =>
incontext2 (fun x => Ecall x rargs ty) (step_expr RV r1 m)
(fun x => Ecall r1 x ty) (step_exprlist rargs m)
end
| RV, Ebuiltin ef tyargs rargs ty =>
match is_val_list rargs with
| Some vtl =>
do vargs <- sem_cast_arguments vtl tyargs m;
match do_external ef w vargs m with
| None => stuck
| Some(w',t,v,m') => topred (Rred "red_builtin" (Eval v ty) m' t)
end
| _ =>
incontext (fun x => Ebuiltin ef tyargs x ty) (step_exprlist rargs m)
end
| _, _ => stuck
end
with step_exprlist (rl: exprlist) (m: mem): reducts exprlist :=
match rl with
| Enil =>
nil
| Econs r1 rs =>
incontext2 (fun x => Econs x rs) (step_expr RV r1 m)
(fun x => Econs r1 x) (step_exprlist rs m)
end.
(** Technical properties on safe expressions. *)
Inductive imm_safe_t: kind -> expr -> mem -> Prop :=
| imm_safe_t_val: forall v ty m,
imm_safe_t RV (Eval v ty) m
| imm_safe_t_loc: forall b ofs ty m,
imm_safe_t LV (Eloc b ofs ty) m
| imm_safe_t_lred: forall to C l m l' m',
lred ge e l m l' m' ->
context LV to C ->
imm_safe_t to (C l) m
| imm_safe_t_rred: forall to C r m t r' m' w',
rred ge r m t r' m' -> possible_trace w t w' ->
context RV to C ->
imm_safe_t to (C r) m
| imm_safe_t_callred: forall to C r m fd args ty,
callred ge r m fd args ty ->
context RV to C ->
imm_safe_t to (C r) m.
Remark imm_safe_t_imm_safe:
forall k a m, imm_safe_t k a m -> imm_safe ge e k a m.
Fixpoint exprlist_all_values (rl: exprlist) : Prop :=
match rl with
| Enil => True
| Econs (Eval v ty) rl' => exprlist_all_values rl'
| Econs _ _ => False
end.
Definition invert_expr_prop (a: expr) (m: mem) : Prop :=
match a with
| Eloc b ofs ty => False
| Evar x ty =>
exists b,
e!x = Some(b, ty)
\/ (e!x = None /\ Genv.find_symbol ge x = Some b)
| Ederef (Eval v ty1) ty =>
exists b, exists ofs, v = Vptr b ofs
| Efield (Eval v ty1) f ty =>
exists b, exists ofs, v = Vptr b ofs /\
match ty1 with
| Tstruct id _ => exists co delta, ge.(genv_cenv)!id = Some co /\ field_offset ge f (co_members co) = OK delta
| Tunion  id _ => exists co, ge.(genv_cenv)!id = Some co
| _ => False
end
| Eval v ty => False
| Evalof (Eloc b ofs ty') ty =>
ty' = ty /\ exists t, exists v, exists w', deref_loc ge ty m b ofs t v /\ possible_trace w t w'
| Eunop op (Eval v1 ty1) ty =>
exists v, sem_unary_operation op v1 ty1 m = Some v
| Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty =>
exists v, sem_binary_operation ge op v1 ty1 v2 ty2 m = Some v
| Ecast (Eval v1 ty1) ty =>
exists v, sem_cast v1 ty1 ty m = Some v
| Eseqand (Eval v1 ty1) r2 ty =>
exists b, bool_val v1 ty1 m = Some b
| Eseqor (Eval v1 ty1) r2 ty =>
exists b, bool_val v1 ty1 m = Some b
| Econdition (Eval v1 ty1) r1 r2 ty =>
exists b, bool_val v1 ty1 m = Some b
| Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty =>
exists v, exists m', exists t, exists w',
ty = ty1 /\ sem_cast v2 ty2 ty1 m = Some v /\ assign_loc ge ty1 m b ofs v t m' /\ possible_trace w t w'
| Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty =>
exists t, exists v1, exists w',
ty = ty1 /\ deref_loc ge ty1 m b ofs t v1 /\ possible_trace w t w'
| Epostincr id (Eloc b ofs ty1) ty =>
exists t, exists v1, exists w',
ty = ty1 /\ deref_loc ge ty m b ofs t v1 /\ possible_trace w t w'
| Ecomma (Eval v ty1) r2 ty =>
typeof r2 = ty
| Eparen (Eval v1 ty1) tycast ty =>
exists v, sem_cast v1 ty1 tycast m = Some v
| Ecall (Eval vf tyf) rargs ty =>
exprlist_all_values rargs ->
exists tyargs tyres cconv fd vl,
classify_fun tyf = fun_case_f tyargs tyres cconv
/\ Genv.find_funct ge vf = Some fd
/\ cast_arguments m rargs tyargs vl
/\ type_of_fundef fd = Tfunction tyargs tyres cconv
| Ebuiltin ef tyargs rargs ty =>
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'
/\ possible_trace w t w'
| _ => True
end.
Scheme context_ind2 := Minimality for context Sort Prop
with contextlist_ind2 := Minimality for contextlist Sort Prop.
Combined Scheme context_contextlist_ind from context_ind2, contextlist_ind2.
(** Soundness: if [step_expr] returns [Some ll], then every element of [ll] is a reduct. *)
Local Hint Constructors context contextlist : core.
Local Hint Resolve context_compose contextlist_compose : core.
Definition reduction_ok (k: kind) (a: expr) (m: mem) (rd: reduction) : Prop :=
match k, rd with
| LV, Lred _ l' m' => lred ge e a m l' m'
| RV, Rred _ r' m' t => rred ge a m t r' m' /\ exists w', possible_trace w t w'
| RV, Callred _ fd args tyres m' => callred ge a m fd args tyres /\ m' = m
| LV, Stuckred => ~imm_safe_t k a m
| RV, Stuckred => ~imm_safe_t k a m
| _, _ => False
end.
Definition reducts_ok (k: kind) (a: expr) (m: mem) (ll: reducts expr) : Prop :=
(forall C rd,
In (C, rd) ll ->
exists a', exists k', context k' k C /\ a = C a' /\ reduction_ok k' a' m rd)
/\ (ll = nil -> match k with LV => is_loc a <> None | RV => is_val a <> None end).
Definition list_reducts_ok (al: exprlist) (m: mem) (ll: reducts exprlist) : Prop :=
(forall C rd,
In (C, rd) ll ->
exists a', exists k', contextlist k' C /\ al = C a' /\ reduction_ok k' a' m rd)
/\ (ll = nil -> is_val_list al <> None).
Ltac monadInv :=
match goal with
| [ H: match ?x with Some _ => _ | None => None end = Some ?y |- _ ] =>
destruct x eqn:?; [monadInv|discriminate]
| [ H: match ?x with left _ => _ | right _ => None end = Some ?y |- _ ] =>
destruct x; [monadInv|discriminate]
| _ => idtac
end.
Ltac myinv :=
match goal with
| [ H: False |- _ ] => destruct H
| [ H: _ /\ _ |- _ ] => destruct H; myinv
| [ H: exists _, _ |- _ ] => destruct H; myinv
| _ => idtac
end.
Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; fail)).
induction a; intros; simpl; destruct k; try (apply wrong_kind_ok; simpl; congruence).
(* Eval *)
split; intros. tauto. simpl; congruence.
(* Evar *)
destruct (e!x) as [[b ty']|] eqn:?.
destruct (type_eq ty ty')...
subst. apply topred_ok; auto. apply red_var_local; auto.
destruct (Genv.find_symbol ge x) as [b|] eqn:?...
apply topred_ok; auto. apply red_var_global; auto.
(* Efield *)
destruct (is_val a) as [[v ty'] | ] eqn:?.
rewrite (is_val_inv _ _ _ Heqo).
destruct v...
destruct ty'...
(* top struct *)
destruct (ge.(genv_cenv)!i0) as [co|] eqn:?...
destruct (field_offset ge f (co_members co)) as [delta|] eqn:?...
apply topred_ok; auto. eapply red_field_struct; eauto.
(* top union *)
destruct (ge.(genv_cenv)!i0) as [co|] eqn:?...
apply topred_ok; auto. eapply red_field_union; eauto.
(* in depth *)
eapply incontext_ok; eauto.
(* Evalof *)
destruct (is_loc a) as [[[b ofs] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ Heqo).
(* top *)
destruct (type_eq ty ty')... subst ty'.
destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ] eqn:?.
exploit do_deref_loc_sound; eauto. intros [A B].
apply topred_ok; auto. red. split. apply red_rvalof; auto. exists w'; auto.
apply not_invert_ok; simpl; intros; myinv. exploit do_deref_loc_complete; eauto. congruence.
(* depth *)
eapply incontext_ok; eauto.
(* Ederef *)
destruct (is_val a) as [[v ty'] | ] eqn:?. rewrite (is_val_inv _ _ _ Heqo).
(* top *)
destruct v... apply topred_ok; auto. apply red_deref; auto.
(* depth *)
eapply incontext_ok; eauto.
(* Eaddrof *)
destruct (is_loc a) as [[[b ofs] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ Heqo).
(* top *)
apply topred_ok; auto. split. apply red_addrof; auto. exists w; constructor.
(* depth *)
eapply incontext_ok; eauto.
(* unop *)
destruct (is_val a) as [[v ty'] | ] eqn:?. rewrite (is_val_inv _ _ _ Heqo).
(* top *)
destruct (sem_unary_operation op v ty' m) as [v'|] eqn:?...
apply topred_ok; auto. split. apply red_unop; auto. exists w; constructor.
(* depth *)
eapply incontext_ok; eauto.
(* binop *)
destruct (is_val a1) as [[v1 ty1] | ] eqn:?.
destruct (is_val a2) as [[v2 ty2] | ] eqn:?.
rewrite (is_val_inv _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0).
(* top *)
destruct (sem_binary_operation ge op v1 ty1 v2 ty2 m) as [v|] eqn:?...
apply topred_ok; auto. split. apply red_binop; auto. exists w; constructor.
(* depth *)
eapply incontext2_ok; eauto.
eapply incontext2_ok; eauto.
(* cast *)
destruct (is_val a) as [[v ty'] | ] eqn:?. rewrite (is_val_inv _ _ _ Heqo).
(* top *)
destruct (sem_cast v ty' ty m) as [v'|] eqn:?...
apply topred_ok; auto. split. apply red_cast; auto. exists w; constructor.
(* depth *)
eapply incontext_ok; eauto.
(* seqand *)
destruct (is_val a1) as [[v ty'] | ] eqn:?. rewrite (is_val_inv _ _ _ Heqo).
(* top *)
destruct (bool_val v ty' m) as [v'|] eqn:?... destruct v'.
apply topred_ok; auto. split. eapply red_seqand_true; eauto. exists w; constructor.
apply topred_ok; auto. split. eapply red_seqand_false; eauto. exists w; constructor.
(* depth *)
eapply incontext_ok; eauto.
(* seqor *)
destruct (is_val a1) as [[v ty'] | ] eqn:?. rewrite (is_val_inv _ _ _ Heqo).
(* top *)
destruct (bool_val v ty' m) as [v'|] eqn:?... destruct v'.
apply topred_ok; auto. split. eapply red_seqor_true; eauto. exists w; constructor.
apply topred_ok; auto. split. eapply red_seqor_false; eauto. exists w; constructor.
(* depth *)
eapply incontext_ok; eauto.
(* condition *)
destruct (is_val a1) as [[v ty'] | ] eqn:?. rewrite (is_val_inv _ _ _ Heqo).
(* top *)
destruct (bool_val v ty' m) as [v'|] eqn:?...
apply topred_ok; auto. split. eapply red_condition; eauto. exists w; constructor.
(* depth *)
eapply incontext_ok; eauto.
(* sizeof *)
apply topred_ok; auto. split. apply red_sizeof. exists w; constructor.
(* alignof *)
apply topred_ok; auto. split. apply red_alignof. exists w; constructor.
(* assign *)
destruct (is_loc a1) as [[[b ofs] ty1] | ] eqn:?.
destruct (is_val a2) as [[v2 ty2] | ] eqn:?.
rewrite (is_loc_inv _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0).
(* top *)
destruct (type_eq ty1 ty)... subst ty1.
destruct (sem_cast v2 ty2 ty m) as [v|] eqn:?...
destruct (do_assign_loc w ty m b ofs v) as [[[w' t] m']|] eqn:?.
exploit do_assign_loc_sound; eauto. intros [P Q].
apply topred_ok; auto. split. apply red_assign; auto. exists w'; auto.
apply not_invert_ok; simpl; intros; myinv. exploit do_assign_loc_complete; eauto. congruence.
(* depth *)
eapply incontext2_ok; eauto.
eapply incontext2_ok; eauto.
(* assignop *)
destruct (is_loc a1) as [[[b ofs] ty1] | ] eqn:?.
destruct (is_val a2) as [[v2 ty2] | ] eqn:?.
rewrite (is_loc_inv _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0).
(* top *)
destruct (type_eq ty1 ty)... subst ty1.
destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ] eqn:?.
exploit do_deref_loc_sound; eauto. intros [A B].
apply topred_ok; auto. red. split. apply red_assignop; auto. exists w'; auto.
apply not_invert_ok; simpl; intros; myinv. exploit do_deref_loc_complete; eauto. congruence.
(* depth *)
eapply incontext2_ok; eauto.
eapply incontext2_ok; eauto.
(* postincr *)
destruct (is_loc a) as [[[b ofs] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ Heqo).
(* top *)
destruct (type_eq ty' ty)... subst ty'.
destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ] eqn:?.
exploit do_deref_loc_sound; eauto. intros [A B].
apply topred_ok; auto. red. split. apply red_postincr; auto. exists w'; auto.
apply not_invert_ok; simpl; intros; myinv. exploit do_deref_loc_complete; eauto. congruence.
(* depth *)
eapply incontext_ok; eauto.
(* comma *)
destruct (is_val a1) as [[v ty'] | ] eqn:?. rewrite (is_val_inv _ _ _ Heqo).
(* top *)
destruct (type_eq (typeof a2) ty)... subst ty.
apply topred_ok; auto. split. apply red_comma; auto. exists w; constructor.
(* depth *)
eapply incontext_ok; eauto.
(* call *)
destruct (is_val a) as [[vf tyf] | ] eqn:?.
destruct (is_val_list rargs) as [vtl | ] eqn:?.
rewrite (is_val_inv _ _ _ Heqo). exploit is_val_list_all_values; eauto. intros ALLVAL.
(* top *)
destruct (classify_fun tyf) as [tyargs tyres cconv|] eqn:?...
destruct (Genv.find_funct ge vf) as [fd|] eqn:?...
destruct (sem_cast_arguments vtl tyargs m) as [vargs|] eqn:?...
destruct (type_eq (type_of_fundef fd) (Tfunction tyargs tyres cconv))...
apply topred_ok; auto. red. split; auto. eapply red_call; eauto.
eapply sem_cast_arguments_sound; eauto.
apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. congruence.
apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv.
exploit sem_cast_arguments_complete; eauto. intros [vtl' [P Q]]. congruence.
apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. congruence.
apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. congruence.
(* depth *)
eapply incontext2_list_ok; eauto.
eapply incontext2_list_ok; eauto.
(* builtin *)
destruct (is_val_list rargs) as [vtl | ] eqn:?.
exploit is_val_list_all_values; eauto. intros ALLVAL.
(* top *)
destruct (sem_cast_arguments vtl tyargs m) as [vargs|] eqn:?...
destruct (do_external ef 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.
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.
exploit sem_cast_arguments_complete; eauto. intros [vtl' [A B]]. congruence.
(* depth *)
eapply incontext_list_ok; eauto.
(* loc *)
split; intros. tauto. simpl; congruence.
(* paren *)
destruct (is_val a) as [[v ty'] | ] eqn:?. rewrite (is_val_inv _ _ _ Heqo).
(* top *)
destruct (sem_cast v ty' tycast m) as [v'|] eqn:?...
apply topred_ok; auto. split. apply red_paren; auto. exists w; constructor.
(* depth *)
eapply incontext_ok; eauto.
induction al; simpl; intros.
(* nil *)
split; intros. tauto. simpl; congruence.
(* cons *)
eapply incontext2_list_ok'; eauto.
Qed.
(** Completeness part 1: [step_expr] contains all possible non-error reducts. *)
Definition reducts_incl {A B: Type} (C: A -> B) (res1: reducts A) (res2: reducts B) : Prop :=
forall C1 rd, In (C1, rd) res1 -> In ((fun x => C(C1 x)), rd) res2.
Local Hint Resolve reducts_incl_val reducts_incl_loc reducts_incl_listval
reducts_incl_incontext reducts_incl_incontext2_left
reducts_incl_incontext2_right : core.
(** Completeness part 2: if we can reduce to [Stuckstate], [step_expr] contains at least one [Stuckred] reduction. *)
(** Connections between [imm_safe_t] and [imm_safe] *)
(** A state can "crash the world" if it can make an observable transition whose trace is not accepted by the external world. *)
Definition can_crash_world (w: world) (S: state) : Prop :=
exists t, exists S', Csem.step ge S t S' /\ forall w', ~possible_trace w t w'.
End EXPRS.
(** * Transitions over states. *)
Fixpoint do_alloc_variables (e: env) (m: mem) (l: list (ident * type)) {struct l} : env * mem :=
match l with
| nil => (e,m)
| (id, ty) :: l' =>
let (m1,b1) := Mem.alloc m 0 (sizeof ge ty) in
do_alloc_variables (PTree.set id (b1, ty) e) m1 l'
end.
Function sem_bind_parameters (w: world) (e: env) (m: mem) (l: list (ident * type)) (lv: list val)
{struct l} : option mem :=
match l, lv  with
| nil, nil => Some m
| (id, ty) :: params, v1::lv =>
match PTree.get id e with
| Some (b, ty') =>
check (type_eq ty ty');
do w', t, m1 <- do_assign_loc w ty m b Ptrofs.zero v1;
match t with nil => sem_bind_parameters w e m1 params lv | _ => None end
| None => None
end
| _, _ => None
end.
Inductive transition : Type := TR (rule: string) (t: trace) (S': state).
Definition expr_final_state (f: function) (k: cont) (e: env) (C_rd: (expr -> expr) * reduction) :=
match snd C_rd with
| Lred rule a m => TR rule E0 (ExprState f (fst C_rd a) k e m)
| Rred rule a m t => TR rule t (ExprState f (fst C_rd a) k e m)
| Callred rule fd vargs ty m => TR rule E0 (Callstate fd vargs (Kcall f e (fst C_rd) ty k) m)
| Stuckred => TR "step_stuck" E0 Stuckstate
end.
Local Open Scope list_monad_scope.
Definition ret (rule: string) (S: state) : list transition :=
TR rule E0 S :: nil.
Definition do_step (w: world) (s: state) : list transition :=
match s with
| ExprState f a k e m =>
match is_val a with
| Some(v, ty) =>
match k with
| Kdo k => ret "step_do_2" (State f Sskip k e m )
| Kifthenelse s1 s2 k =>
do b <- bool_val v ty m;
ret "step_ifthenelse_2" (State f (if b then s1 else s2) k e m)
| Kwhile1 x s k =>
do b <- bool_val v ty m;
if b
then ret "step_while_true" (State f s (Kwhile2 x s k) e m)
else ret "step_while_false" (State f Sskip k e m)
| Kdowhile2 x s k =>
do b <- bool_val v ty m;
if b
then ret "step_dowhile_true" (State f (Sdowhile x s) k e m)
else ret "step_dowhile_false" (State f Sskip k e m)
| Kfor2 a2 a3 s k =>
do b <- bool_val v ty m;
if b
then ret "step_for_true" (State f s (Kfor3 a2 a3 s k) e m)
else ret "step_for_false" (State f Sskip k e m)
| Kreturn k =>
do v' <- sem_cast v ty f.(fn_return) m;
do m' <- Mem.free_list m (blocks_of_env ge e);
ret "step_return_2" (Returnstate v' (call_cont k) m')
| Kswitch1 sl k =>
do n <- sem_switch_arg v ty;
ret "step_expr_switch" (State f (seq_of_labeled_statement (select_switch n sl)) (Kswitch2 k) e m)
| _ => nil
end
| None =>
map (expr_final_state f k e) (step_expr e w RV a m)
end
| State f (Sdo x) k e m =>
ret "step_do_1" (ExprState f x (Kdo k) e m)
| State f (Ssequence s1 s2) k e m =>
ret "step_seq" (State f s1 (Kseq s2 k) e m)
| State f Sskip (Kseq s k) e m =>
ret "step_skip_seq" (State f s k e m)
| State f Scontinue (Kseq s k) e m =>
ret "step_continue_seq" (State f Scontinue k e m)
| State f Sbreak (Kseq s k) e m =>
ret "step_break_seq" (State f Sbreak k e m)
| State f (Sifthenelse a s1 s2) k e m =>
ret "step_ifthenelse_1" (ExprState f a (Kifthenelse s1 s2 k) e m)
| State f (Swhile x s) k e m =>
ret "step_while" (ExprState f x (Kwhile1 x s k) e m)
| State f (Sskip|Scontinue) (Kwhile2 x s k) e m =>
ret "step_skip_or_continue_while" (State f (Swhile x s) k e m)
| State f Sbreak (Kwhile2 x s k) e m =>
ret "step_break_while" (State f Sskip k e m)
| State f (Sdowhile a s) k e m =>
ret "step_dowhile" (State f s (Kdowhile1 a s k) e m)
| State f (Sskip|Scontinue) (Kdowhile1 x s k) e m =>
ret "step_skip_or_continue_dowhile" (ExprState f x (Kdowhile2 x s k) e m)
| State f Sbreak (Kdowhile1 x s k) e m =>
ret "step_break_dowhile" (State f Sskip k e m)
| State f (Sfor a1 a2 a3 s) k e m =>
if is_skip a1
then ret "step_for" (ExprState f a2 (Kfor2 a2 a3 s k) e m)
else ret "step_for_start" (State f a1 (Kseq (Sfor Sskip a2 a3 s) k) e m)
| State f (Sskip|Scontinue) (Kfor3 a2 a3 s k) e m =>
ret "step_skip_or_continue_for3" (State f a3 (Kfor4 a2 a3 s k) e m)
| State f Sbreak (Kfor3 a2 a3 s k) e m =>
ret "step_break_for3" (State f Sskip k e m)
| State f Sskip (Kfor4 a2 a3 s k) e m =>
ret "step_skip_for4" (State f (Sfor Sskip a2 a3 s) k e m)
| State f (Sreturn None) k e m =>
do m' <- Mem.free_list m (blocks_of_env ge e);
ret "step_return_0" (Returnstate Vundef (call_cont k) m')
| State f (Sreturn (Some x)) k e m =>
ret "step_return_1" (ExprState f x (Kreturn k) e m)
| State f Sskip ((Kstop | Kcall _ _ _ _ _) as k) e m =>
do m' <- Mem.free_list m (blocks_of_env ge e);
ret "step_skip_call" (Returnstate Vundef k m')
| State f (Sswitch x sl) k e m =>
ret "step_switch" (ExprState f x (Kswitch1 sl k) e m)
| State f (Sskip|Sbreak) (Kswitch2 k) e m =>
ret "step_skip_break_switch" (State f Sskip k e m)
| State f Scontinue (Kswitch2 k) e m =>
ret "step_continue_switch" (State f Scontinue k e m)
| State f (Slabel lbl s) k e m =>
ret "step_label" (State f s k e m)
| State f (Sgoto lbl) k e m =>
match find_label lbl f.(fn_body) (call_cont k) with
| Some(s', k') => ret "step_goto" (State f s' k' e m)
| None => nil
end
| Callstate (Internal f) vargs k m =>
check (list_norepet_dec ident_eq (var_names (fn_params f) ++ var_names (fn_vars f)));
let (e,m1) := do_alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) in
do m2 <- sem_bind_parameters w e m1 f.(fn_params) vargs;
ret "step_internal_function" (State f f.(fn_body) k e m2)
| Callstate (External ef _ _ _) vargs k m =>
match do_external ef w vargs m with
| None => nil
| Some(w',t,v,m') => TR "step_external_function" t (Returnstate v k m') :: nil
end
| Returnstate v (Kcall f e C ty k) m =>
ret "step_returnstate" (ExprState f (C (Eval v ty)) k e m)
| _ => nil
end.
Ltac myinv :=
match goal with
| [ |- In _ nil -> _ ] => let X := fresh "X" in intro X; elim X
| [ |- In _ (ret _ _) -> _ ] =>
let X := fresh "X" in
intro X; elim X; clear X;
[let EQ := fresh "EQ" in intro EQ; unfold ret in EQ; inv EQ; myinv | myinv]
| [ |- In _ (_ :: nil) -> _ ] =>
let X := fresh "X" in
intro X; elim X; clear X; [let EQ := fresh "EQ" in intro EQ; inv EQ; myinv | myinv]
| [ |- In _ (match ?x with Some _ => _ | None => _ end) -> _ ] => destruct x eqn:?; myinv
| [ |- In _ (match ?x with false => _ | true => _ end) -> _ ] => destruct x eqn:?; myinv
| [ |- In _ (match ?x with left _ => _ | right _ => _ end) -> _ ] => destruct x; myinv
| _ => idtac
end.
Local Hint Extern 3 => exact I : core.

Theorem do_step_sound:
forall w S rule t S',
In (TR rule t S') (do_step w S) ->
Csem.step ge S t S' \/ (t = E0 /\ S' = Stuckstate /\ can_crash_world w S).