Require Export mc_reify.reify.
Require Export mc_reify.bool_funcs.
Require Export MirrorCore.RTac.Repeat.
Require Export MirrorCore.RTac.Try.
Require Export MirrorCore.RTac.First.
Require Export mc_reify.funcs.
Require Export mc_reify.reflexivity_tacs.
Local Open Scope logic.
(************************************************  Rtac definition  ************************************************)
Ltac reify_expr_tac :=
match goal with
| [ |- ?trm] => reify_vst trm
end.
Ltac do_local2ptree := do 2 (erewrite local2ptree_soundness; [ | repeat constructor ]);
repeat rewrite LocalD_to_localD.
(* Should change to new tactic, not constructor here.     -- Qinxiang *)
Ltac pull_sep_lift R :=
match R with
| ((`?H) :: ?T) => let rest := pull_sep_lift T in constr:(cons H rest)
| (@nil _) => constr:(@nil mpred)
end.
Ltac extract_sep_lift_semax :=
match goal with
[ |- context [semax _ (*(PROP (?P1) (LOCALx ?Q1 SEP (?R1)))*)
(PROPx ?P1 (LOCALx ?Q1 (SEPx ?R1))) _
(normal_ret_assert (*(PROPx ?P2 (LOCALx ?Q2 (SEPx ?R2))))*) _)]] =>
let R1' := pull_sep_lift R1 in
(*let R2' := pull_sep_lift R2 in*)
try (change (PROPx (P1) (LOCALx Q1 (SEPx (R1))))
with (assertD nil Q1 R1'))(*;
try  (change (PROPx (P2) (LOCALx Q2 (SEPx (R2))))
with (assertD nil Q2 R2'))*)
end.
Ltac hnf_tycontext :=
match goal with
[ |- context [semax ?s _ _ _] ] => let ss := eval hnf in s in change s with ss
end.
Ltac prepare_reify :=
do_local2ptree;
extract_sep_lift_semax;
hnf_tycontext.
Definition remove_global_spec (t : tycontext) :=
match t with
| mk_tycontext t v r gt gs => mk_tycontext t v r gt (PTree.empty _)
end.
(************************************************  Pre-rtac computations  ************************************************)
Definition is_array_type (t: Ctypes.type) : bool :=
match t with
| Tarray _ _ _ => true
| _ => false
end.
Fixpoint no_load_expr_bool (e: Clight.expr) : bool :=
match e with
| Econst_int _ _ => true
| Econst_float _ _ => true
| Econst_single _ _ => true
| Econst_long _ _ => true
| Evar _ t => is_array_type t
| Etempvar _ _ => true
| Ederef _ _ => false
| Eaddrof e0 _ => no_load_lvalue_bool e0
| Eunop _ e0 _ => no_load_expr_bool e0
| Ebinop _ e0 e1 _ => (no_load_expr_bool e0 && no_load_expr_bool e1)%bool
| Ecast e0 _ => no_load_expr_bool e0
| Efield e0 _ t => (is_array_type t && no_load_lvalue_bool e0)%bool
end
with no_load_lvalue_bool (e: Clight.expr) : bool :=
match e with
| Econst_int _ _ => false
| Econst_float _ _ => false
| Econst_single _ _ => false
| Econst_long _ _ => false
| Evar _ _ => true
| Etempvar _ _ => false
| Ederef _ _ => false
| Eaddrof _ _ => false
| Eunop _ _ _ => false
| Ebinop _ _ _ _ => false
| Ecast _ _ => false
| Efield e0 _ _ => no_load_lvalue_bool e0
end.
Inductive ForwardRule : Type :=
| ForwardSet
| ForwardLoad
| ForwardCastLoad
| ForwardStore
| ForwardSeq: statement -> statement -> ForwardRule
| ForwardSkip.
Definition compute_forward_rule (s: statement) : option ForwardRule :=
match s with
| Sskip => Some ForwardSkip
| Ssequence s1 s2 => Some (ForwardSeq s1 s2)
| Sassign _ _ => Some ForwardStore
| Sset _ e =>
if no_load_expr_bool e
then Some ForwardSet
else match e with
| Ecast _ _ => Some ForwardCastLoad
| _ => Some ForwardLoad
end
| _ => None
end.
Definition get_arguments_delta (e : expr typ func) :=
match e with
| App (Inj (inr (Smx (ftycontext t v r gt)))) gf => Some (t, v, r, gt, gf)
| _ => None
end.
Definition get_arguments_pre (e : expr typ func) :=
match e with
| App (App (App (Inj (inr (Smx fassertD))) P)
(App (App (Inj (inr (Smx flocalD))) T1) T2)) R => Some (P, T1, T2, R, rstrip_1_later_sep R)
| _ => None
end.
Definition get_arguments_statement (e : expr typ func) :=
match e with
| Inj (inr (Smx (fstatement s))) => Some s
| _ => None
end.
Fixpoint get_arguments (e : expr typ func) :=
match e with
| App (App (App (App (App (Inj (inr (Smx fsemax))) _) Delta) Pre) CCmd) _ =>
(get_arguments_delta Delta,
get_arguments_pre Pre,
get_arguments_statement CCmd)
| App _ e
| Abs _ e => get_arguments e
| _ => (None, None, None)
end.
Definition compute_hlip_arg (arg:
(PTree.t (type * bool) * PTree.t type * type * PTree.t type *
expr typ func) *
(expr typ func * expr typ func * expr typ func * expr typ func * expr typ func) *
statement) :=
match arg with
| ((t, v, r, gt, _), (_, _, _, R, _), s) => (t, v, r, gt, s, R)
end.
Definition compute_set_arg (arg:
(PTree.t (type * bool) * PTree.t type * type * PTree.t type *
expr typ func) *
(expr typ func * expr typ func * expr typ func * expr typ func * expr typ func) *
statement) :=
match arg with
| ((t, v, r, gt, _), _, s) =>
match s with
| Sset i e0 =>
match t ! i with
| Some (ty, _) => Some (t, v, r, gt, i, e0, ty)
| _ => None
end
| _ => None
end
end.
Section empty_RSym_sym.
Instance RSym_SymEnv_fun : RSym SymEnv.func := {
typeof_sym := fun _ => None;
symD := fun _ => tt;
sym_eqb := fun x y => Some (Pos.eqb x y)
}.
Instance RSymOk_SymEnv_fun : RSymOk RSym_SymEnv_fun.
split.
intros.
simpl.
pose proof Pos.eqb_eq a b.
destruct (a =? b)%positive; intros.
+ apply H; auto.
+ intro.
apply H in H0.
congruence.
Defined.
Definition sem_eqb_func := @sym_eqb _ _ _ (SymSum.RSym_sum
(SymSum.RSym_sum (SymSum.RSym_sum RSym_SymEnv_fun RSym_ilfunc) RSym_bilfunc)
RSym_Func').
Fixpoint expr_beq (e1 e2: expr typ func) : bool :=
match e1, e2 with
| Var i1, Var i2 => beq_nat i1 i2
| Inj f1, Inj f2 =>
match sem_eqb_func f1 f2 with
| Some true => true
| _ => false
end
| App e11 e12, App e21 e22 => andb (expr_beq e11 e21) (expr_beq e12 e22)
| Abs ty1 e11, Abs ty2 e21 => andb (expr_beq e11 e21) (typ_beq ty1 ty2)
| UVar i1, UVar i2 => beq_nat i1 i2
| _, _ => false
end.
End empty_RSym_sym.
Fixpoint nth_solver_rec (R: expr typ func) (p: expr typ func) (n: nat) :=
match R with
| Inj (inr (Data (fnil tympred))) => None
| App (App (Inj (inr (Data (fcons tympred)))) hd) tl =>
match hd with
| App (App (App (Inj (inr (Sep (fdata_at t_root)))) sh) v) p' =>
if (expr_beq p p')
then Some (t_root, n)
else nth_solver_rec tl p (S n)
| _ => nth_solver_rec tl p (S n)
end
| _ => None
end.
Definition nth_solver R p := nth_solver_rec R p 0.
Definition compute_load_arg (arg:
(PTree.t (type * bool) * PTree.t type * type * PTree.t type *
expr typ func) *
(expr typ func * expr typ func * expr typ func * expr typ func * expr typ func) *
statement) :=
match arg with
| ((t, v, r, gt, _), (_, T1, T2, _, R'), s) =>
match s with
| Sset i e0 =>
match t ! i, compute_nested_efield e0 with
| Some (ty, _), (e1, efs, tts) =>
let lr := compute_lr e1 efs in
match rmsubst_eval_LR T1 T2 e1 lr with
| App (Inj (inr (Other (fsome tyval)))) p =>
match nth_solver R' p with
| Some (t_root, n) =>
Some (t, v, r, gt, i, ty, t_root, e0, e1, efs, tts, lr, n)
| _ => None
end
| _ => None
end
| _, _ => None
end
| _ => None
end
end.
Definition compute_store_arg (arg:
(PTree.t (type * bool) * PTree.t type * type * PTree.t type *
expr typ func) *
(expr typ func * expr typ func * expr typ func * expr typ func * expr typ func) *
statement) :=
match arg with
| ((t, v, r, gt, _), (_, T1, T2, _, R'), s) =>
match s with
| Sassign e0 e2 =>
match compute_nested_efield e0 with
| (e1, efs, tts) =>
let ty := typeof e0 in
let lr := compute_lr e1 efs in
match rmsubst_eval_LR T1 T2 e1 lr with
| App (Inj (inr (Other (fsome tyval)))) p =>
match nth_solver R' p with
| Some (t_root, n) =>
Some (t, v, r, gt, ty, t_root, e0, e1, e2, efs, tts, lr, n)
| _ => None
end
| _ => None
end
end
| _ => None
end
end.
Section tbled.
Variable n : nat.
Variable tbl : SymEnv.functions RType_typ.
Let RSym_sym := RSym_sym tbl.
Existing Instance RSym_sym.

(* Specifications: *)
Lemma semax_seq_reif c1 c2 : forall  (Espec : OracleKind)
(P : environ -> mpred)  (P' : environ -> mpred)
(Q : ret_assert) (Delta : tycontext) ,
@semax Espec Delta P c1 (normal_ret_assert P') ->
@semax Espec (update_tycon Delta c1) P' c2 Q ->
@semax Espec Delta P (Ssequence c1 c2) Q.