Section SEMAX_SC.
Context {cs: compspecs}.
End SEMAX_SC.
(************************************************  The set, load, cast-load and store rules will be used in the future.  ************************************************)
Inductive Ptrofs_eqm_unsigned: ptrofs -> Z -> Prop :=
| Ptrofs_eqm_unsigned_repr: forall z, Ptrofs_eqm_unsigned (Ptrofs.repr z) z.
Ltac solve_Ptrofs_eqm_unsigned :=
solve
[ autorewrite with norm;
rewrite ?Ptrofs_repr_Int_unsigned_special by reflexivity;
rewrite ?Ptrofs_repr_Int64_unsigned_special by reflexivity;
match goal with
| |- Ptrofs_eqm_unsigned ?V _ =>
match V with
| Ptrofs.repr _ => idtac
| Ptrofs.sub _ _ => unfold Ptrofs.sub at 1
| Ptrofs.add _ _ => unfold Ptrofs.add at 1
| Ptrofs.mul _ _ => unfold Ptrofs.mul at 1
| Ptrofs.and _ _ => unfold Ptrofs.and at 1
| Ptrofs.or _ _ => unfold Ptrofs.or at 1
(*      | Int.shl _ _ => unfold Int.shl at 1 | Int.shr _ _ => unfold Int.shr at 1*)
| _ => rewrite <- (Ptrofs.repr_unsigned V) at 1
end
end;
rewrite ?ptrofs_unsigned_ofint64_repr by reflexivity;
apply Ptrofs_eqm_unsigned_repr
].
Inductive msubst_efield_denote {cs: compspecs} (Delta: tycontext) (T1: PTree.t val) (T2: PTree.t (type * val)) (GV: option globals): list efield -> list gfield -> Prop :=
| msubst_efield_denote_nil: msubst_efield_denote Delta T1 T2 GV nil nil
| msubst_efield_denote_cons_array: forall ei i i' efs gfs,
is_int_type (typeof ei) = true ->
msubst_eval_expr Delta T1 T2 GV  ei = Some (Vint i) ->
int_signed_or_unsigned (typeof ei) i = i' ->
msubst_efield_denote Delta T1 T2 GV efs gfs ->
msubst_efield_denote Delta T1 T2 GV (eArraySubsc ei :: efs) (ArraySubsc i' :: gfs)
| msubst_efield_denote_cons_array_ptrofs: forall ei i i' efs gfs,
is_ptrofs_type (typeof ei) = true ->
msubst_eval_expr Delta T1 T2 GV  ei = Some (Vptrofs i) ->
Ptrofs_eqm_unsigned i i' ->
msubst_efield_denote Delta T1 T2 GV efs gfs ->
msubst_efield_denote Delta T1 T2 GV (eArraySubsc ei :: efs) (ArraySubsc i' :: gfs)
| msubst_efield_denote_cons_struct: forall i efs gfs,
msubst_efield_denote Delta T1 T2 GV efs gfs ->
msubst_efield_denote Delta T1 T2 GV (eStructField i :: efs) (StructField i :: gfs)
| msubst_efield_denote_cons_union: forall i efs gfs,
msubst_efield_denote Delta T1 T2 GV efs gfs ->
msubst_efield_denote Delta T1 T2 GV (eUnionField i :: efs) (UnionField i :: gfs).
Ltac insist_rep_omega :=
(auto; rep_omega) ||
match goal with |- ?A =>
fail 1000 "load or store subscript failure: rep_omega cannot prove "A
end.
Ltac solve_msubst_efield_denote :=
solve
[ repeat first
[ eapply msubst_efield_denote_cons_array_ptrofs;
[ reflexivity
| etransitivity;
[solve_msubst_eval_expr
| apply f_equal_Some;
match goal with
| |- Vint ?a = Vptrofs ?b =>
is_evar b;
unify b (Ptrofs.of_int a);
unfold Vptrofs; change Archi.ptr64 with false; cbv iota;
rewrite (Ptrofs.to_int_of_int (eq_refl _));
reflexivity
| |- Vlong ?a = Vptrofs ?b =>
is_evar b;
unify b (Ptrofs.of_int64 a);
unfold Vptrofs; change Archi.ptr64 with true; cbv iota;
rewrite (Ptrofs.to_int64_of_int64 (eq_refl _));
reflexivity
| |- Vptrofs _ = Vptrofs _ => reflexivity
end
]
| solve_Ptrofs_eqm_unsigned
| ]
| eapply msubst_efield_denote_cons_array;
[ reflexivity
| solve_msubst_eval_expr
| rewrite ?ptrofs_to_int_repr; autorewrite with norm;
(* Maybe this lazymatch...end is not needed because the autorewrite with norm takes care of it? *)
lazymatch goal with
| |- int_signed_or_unsigned _ (Int.repr ?i) = ?j =>
let x := fresh "x" in set (x:=i);
let y := fresh "y" in set (y:=j);
unfold int_signed_or_unsigned; simpl;
subst x;
rewrite ?(Int.signed_repr i) by insist_rep_omega;
rewrite ?(Int.unsigned_repr i) by insist_rep_omega;
subst y
| |- int_signed_or_unsigned ?t _ = _ =>
try change (int_signed_or_unsigned t) with Int.signed;
try change (int_signed_or_unsigned t) with Int.unsigned
| |- _ => idtac
end;
reflexivity
(*      | solve_Ptrofs_eqm_unsigned *)
| ]
| apply msubst_efield_denote_cons_struct
| apply msubst_efield_denote_cons_union
| apply msubst_efield_denote_nil
]
].
Inductive field_address_gen {cs: compspecs}: type * list gfield * val -> type * list gfield * val -> Prop :=
| field_address_gen_nil: forall t1 t2 gfs p tgp,
nested_field_type t2 gfs = t1 ->
field_address_gen (t2, gfs, p) tgp ->
field_address_gen (t1, nil, (field_address t2 gfs p)) tgp
| field_address_gen_app: forall t1 t2 gfs1 gfs2 p tgp,
nested_field_type t2 gfs2 = t1 ->
field_address_gen (t2, gfs1 ++ gfs2, p) tgp ->
field_address_gen (t1, gfs1, (field_address t2 gfs2 p)) tgp
| field_address_gen_assu: forall t gfs p1 p2 tgp,
p1 = p2 ->
field_address_gen (t, gfs, p2) tgp ->
field_address_gen (t, gfs, p1) tgp
| field_address_gen_refl: forall tgp, field_address_gen tgp tgp.
Ltac field_address_assumption :=
match goal with
|  H: ?a = field_address _ _ _ |- ?b = _ => constr_eq a b; simple eapply H
end.
(* Ltac cleanup_int_signed_or_unsigned := match goal with |- context [int_signed_or_unsigned ?t (Int.repr ?i)] => (change (int_signed_or_unsigned t) with Int.signed; rewrite ?(Int.signed_repr i) by insist_rep_omega) ||   (change (int_signed_or_unsigned t) with Int.unsigned; rewrite ?(Int.unsigned_repr i) by insist_rep_omega) end. *)
Ltac solve_field_address_gen :=
(* repeat cleanup_int_signed_or_unsigned; *)
solve [
repeat
first
[ simple apply field_address_gen_nil; [reflexivity |]
| simple apply field_address_gen_app; [reflexivity |]
| simple eapply field_address_gen_assu; [field_address_assumption |]
| simple apply field_address_gen_refl
]
].
Inductive find_type_contradict_pred {cs: compspecs} (t: type) (p: val): mpred -> Prop :=
| find_type_contradict_pred_data_at: forall sh t0 v0, eqb_type t0 t = false -> find_type_contradict_pred t p (data_at sh t0 v0 p)
| find_type_contradict_pred_data_at_: forall sh t0, eqb_type t0 t = false -> find_type_contradict_pred t p (data_at_ sh t0 p)
| find_type_contradict_pred_field_at: forall sh t0 v0, eqb_type t0 t = false -> find_type_contradict_pred t p (field_at sh t0 nil v0 p)
| find_type_contradict_pred_field_at_: forall sh t0, eqb_type t0 t = false -> find_type_contradict_pred t p (field_at_ sh t0 nil p).
Definition find_type_contradict_preds {cs: compspecs} (t: type) (p: val) :=
find_nth_preds (find_type_contradict_pred t p).
Ltac find_type_contradict_rec :=
first [ simple eapply find_type_contradict_pred_data_at; reflexivity
| simple eapply find_type_contradict_pred_data_at_; reflexivity
| simple eapply find_type_contradict_pred_field_at; reflexivity
| simple eapply find_type_contradict_pred_field_at_; reflexivity].
Definition unknown_type := Tvoid.
Ltac SEP_type_contradict_msg r e :=
let t := constr:(typeof e) in
let t := eval simpl in t in
let t' := match r with data_at _ ?u _ _ => constr:(u)
| data_at_ _ ?u _ => constr:(u)
| field_at _ ?u _ _ _ => constr:(u)
| field_at_ _ ?u _ _ => constr:(u)
| _ => constr:(unknown_type)
end in
fail 1000 "Cannot load/store with SEP clause" r "because of type mismatch
Type of expression: " t "
Type in SEP conjunct: " t'.
Ltac SEP_type_contradict LOCAL2PTREE Delta e R :=
eapply (SEP_type_contradict_lemma Delta e R);
[ exact LOCAL2PTREE
| reflexivity
| solve_msubst_eval_lvalue
| solve_msubst_eval_LR
| solve_msubst_efield_denote
| econstructor
| solve_field_address_gen
| find_nth find_type_contradict_rec
| first [left; split; [reflexivity | find_nth find_type_contradict_rec] | right; reflexivity]
| ];
match goal with
| |- Some (_, ?r) = _ /\ False => SEP_type_contradict_msg r e
| |- _ = Some (_, ?r) /\ False => SEP_type_contradict_msg r e
| |- _ => idtac
end;
fail 0.

Lemma hint_msg_lemma: forall {cs: compspecs} Delta e goal Q T1 T2 GV e_root efs lr p_full_from_e p_root_from_e gfs_from_e t_root_from_e p_root_from_hint gfs_from_hint t_root_from_hint
t gfs p,
local2ptree Q = (T1, T2, nil, GV) ->
compute_nested_efield e = (e_root, efs, lr) ->
msubst_eval_lvalue Delta T1 T2 GV e = Some p_full_from_e ->
msubst_eval_LR Delta T1 T2 GV e_root lr = Some p_root_from_e ->
msubst_efield_denote Delta T1 T2 GV efs gfs_from_e ->
compute_root_type (typeof e_root) lr t_root_from_e ->
field_address_gen (t_root_from_e, gfs_from_e, p_root_from_e) (t_root_from_hint, gfs_from_hint, p_root_from_hint) ->
p_full_from_e = field_address t gfs p /\
p_root_from_hint = field_address t gfs p /\
False ->
goal.