Section SEMAX_PTREE.
Context {cs: compspecs}.
Definition proj_val t_root gfs v :=
repinject (nested_field_type t_root gfs) (proj_reptype t_root gfs v).
Definition upd_val t_root gfs v v0 :=
upd_reptype t_root gfs v (valinject (nested_field_type t_root gfs) v0).
End SEMAX_PTREE.
Ltac SEP_field_at_unify' gfs :=
match goal with
| |- field_at ?shl ?tl ?gfsl ?vl ?pl = field_at ?shr ?tr ?gfsr ?vr ?pr =>
unify tl tr;
unify (skipn (length gfs - length gfsl) gfs) gfsl;
unify gfsl gfsr;
unify shl shr;
unify vl vr;
generalize vl; intro;
rewrite <- ?field_at_offset_zero;
f_equal; (* this line is important to prevent blow-ups *)
reflexivity
end.
Ltac SEP_field_at_unify gfs :=
match goal with
| |- data_at _ _ _ _ = _ =>
unfold data_at; SEP_field_at_unify' gfs
| |- data_at_ _ _ _ = _ =>
unfold data_at_, field_at_; SEP_field_at_unify' gfs
| |- field_at _ _ _ _ _ = _ =>
SEP_field_at_unify' gfs
| |- field_at_ _ _ _ _ = _ =>
unfold field_at_; SEP_field_at_unify' gfs
end.
Ltac SEP_field_at_strong_unify' gfs :=
match goal with
| |- @field_at ?cs ?shl ?tl ?gfsl ?vl ?pl = ?Rv ?vr /\ (_ = fun v => field_at ?shr ?tr ?gfsr v ?pr) =>
unify tl tr;
unify (skipn (length gfs - length gfsl) gfs) gfsl;
unify gfsl gfsr;
unify shl shr;
unify vl vr;
split;
[ match type of vl with
| ?tv1 => unify Rv (fun v: tv1 => @field_at cs shl tl gfsl v pl)
end; reflexivity
| extensionality;
rewrite <- ?field_at_offset_zero; reflexivity]
| |- @data_at ?cs ?shl ?tl ?vl ?pl = ?Rv ?vr /\ (_ = fun v => field_at ?shr ?tr ?gfsr v ?pr) =>
unify tl tr;
unify gfsr (@nil gfield);
unify shl shr;
unify vl vr;
split;
[ match type of vl with
| ?tv1 => unify Rv (fun v: tv1 => @data_at cs shl tl v pl)
end; reflexivity
| extensionality;
unfold data_at;
rewrite <- ?field_at_offset_zero; reflexivity]
end.
Ltac SEP_field_at_strong_unify gfs :=
match goal with
| |- data_at_ ?sh ?t ?p = _ /\ _ =>
change (data_at_ sh t p) with (data_at sh t (default_val t) p);
SEP_field_at_strong_unify' gfs
| |- field_at_ _ _ _ _ = _ /\ _ =>
unfold field_at_; SEP_field_at_strong_unify' gfs
| _ => SEP_field_at_strong_unify' gfs
end.
(* simplifies a list expression into [e1; e2; ...] form without simplifying its elements *)
Ltac eval_list l :=
let l' := eval hnf in l in lazymatch l' with
| ?h :: ?tl => let tl' := eval_list tl in constr:(h :: tl')
| (@nil ?T) => constr:(@nil T)
end.
Ltac prove_gfs_suffix gfs :=
match goal with
| |- _ = ?gfs1 ++ ?gfs0 =>
let len := fresh "len" in
let gfs1' := eval_list (firstn ((length gfs - length gfs0)%nat) gfs) in
unify gfs1 gfs1';
reflexivity
end.
Ltac test_field_at_in_SEP :=
cbv beta;
match goal with
| |- ?A /\ ?gfs = _ ++ _ =>
split; [ match A with
| _ /\ _ => SEP_field_at_strong_unify gfs
| _ => SEP_field_at_unify gfs
end
| prove_gfs_suffix gfs]
end.
Ltac search_field_at_in_SEP := find_nth test_field_at_in_SEP.
Ltac quick_typecheck3 :=
clear;
repeat match goal with
| H := _ |- _ => clear H
| H : _ |- _ => clear H
end;
apply quick_derives_right; clear; go_lowerx; intros;
clear; repeat apply andp_right; auto; fail.
Ltac default_entailer_for_load_store :=
repeat match goal with H := _ |- _ => clear H end;
try quick_typecheck3;
unfold tc_efield, tc_LR, tc_LR_strong; simpl typeof;
try solve [entailer!].
Ltac entailer_for_load_tac := default_entailer_for_load_store.
Ltac entailer_for_store_tac := default_entailer_for_load_store.
Ltac check_hint_type :=
reflexivity ||
match goal with
| |- typeof ?A = ?B =>
let t0 := constr:(typeof A)
in let t1 := eval hnf in t0 in let t := eval simpl in t1
in let t' := eval hnf in B in let t'' := eval simpl in t'
in fail 1000 "unexpected failure in load/store_tac_with_hint."
"The expression" A "has type" t "but is expected to have type" t''
end.
Ltac load_tac_with_hint LOCAL2PTREE :=
eapply semax_PTree_field_load_with_hint;
[ exact LOCAL2PTREE
| reflexivity
| reflexivity
| reflexivity
| (solve_msubst_eval_lvalue               || fail 1000 "Cannot evaluate right-hand-side expression (sometimes this is caused by missing LOCALs in your precondition)")
| eassumption (* This line can fail. If it does not, the following should not fail. *)
| check_hint_type
| (search_field_at_in_SEP                 || fail 1000 "unexpected failure in load_tac_with_hint."
"Required field_at does not exists in SEP")
| (auto                                   || fail 1000 "unexpected failure in load_tac_with_hint."
"Cannot prove readable_share")
| first [solve_load_rule_evaluation        | fail 1000 "unexpected failure in load_tac_with_hint."
"unexpected failure in generating loaded value"]
| first [entailer_for_load_tac             | fail 1000 "unexpected failure in load_tac_with_hint."
"unexpected failure in entailer_for_load_tac"]
| first [entailer_for_load_tac             | fail 1000 "unexpected failure in load_tac_with_hint."
"unexpected failure in entailer_for_load_tac"]
].
Ltac load_tac_no_hint LOCAL2PTREE :=
eapply semax_PTree_field_load_no_hint;
[ exact LOCAL2PTREE
| reflexivity (* compute_nested_efield *)
| reflexivity
| reflexivity
| reflexivity
| (solve_msubst_eval_LR                   || fail 1000 "Cannot evaluate right-hand-side expression (sometimes this is caused by missing LOCALs in your precondition)")
| (solve_msubst_efield_denote             || fail 1000 "Cannot evaluate right-hand-side expression (sometimes this is caused by missing LOCALs in your precondition)")
| econstructor
| solve_field_address_gen
| search_field_at_in_SEP (* This line can fail. If it does not, the following should not fail. *)
| (auto                                   || fail 1000 "unexpected failure in load_tac_no_hint."
"Cannot prove readable_share")
| first [solve_load_rule_evaluation        | fail 1000 "unexpected failure in load_tac_no_hint."
"unexpected failure in generating loaded value"]
| first [solve_legal_nested_field_in_entailment
| fail 1000 "unexpected failure in load_tac_no_hint."
"unexpected failure in solve_legal_nested_field_in_entailment"]
| first [entailer_for_load_tac             | fail 1000 "unexpected failure in load_tac_no_hint."
"unexpected failure in entailer_for_load_tac"]
| first [entailer_for_load_tac             | fail 1000 "unexpected failure in load_tac_no_hint."
"unexpected failure in entailer_for_load_tac"]
].
Ltac load_tac :=
match goal with
| |- semax ?Delta (|> (PROPx ?P (LOCALx ?Q (SEPx ?R)))) (Sset _ ?e) _ =>
let T1 := fresh "T1" in evar (T1: PTree.t val);
let T2 := fresh "T2" in evar (T2: PTree.t (type * val));
let G := fresh "GV" in evar (G: option globals);
let LOCAL2PTREE := fresh "LOCAL2PTREE" in
assert (local2ptree Q = (T1, T2, nil, G)) as LOCAL2PTREE;
[subst T1 T2 G; prove_local2ptree |];
first [ load_tac_with_hint LOCAL2PTREE | load_tac_no_hint LOCAL2PTREE | SEP_type_contradict LOCAL2PTREE Delta e R | hint_msg LOCAL2PTREE Delta e];
clear T1 T2 G LOCAL2PTREE
end.
Ltac cast_load_tac_with_hint LOCAL2PTREE :=
eapply semax_PTree_field_cast_load_with_hint;
[ exact LOCAL2PTREE
| reflexivity
| reflexivity
| reflexivity
| reflexivity
| (solve_msubst_eval_lvalue               || fail 1000 "Cannot evaluate right-hand-side expression (sometimes this is caused by missing LOCALs in your precondition)")
| eassumption (* This line can fail. If it does not, the following should not fail. *)
| check_hint_type
| (search_field_at_in_SEP                 || fail 1000 "unexpected failure in cast_load_tac_with_hint."
"Required field_at does not exists in SEP")
| (auto                                   || fail 1000 "unexpected failure in cast_load_tac_with_hint."
"Cannot prove readable_share")
| first [solve_load_rule_evaluation        | fail 1000 "unexpected failure in cast_load_tac_with_hint."
"unexpected failure in generating loaded value"]
| first [entailer_for_load_tac             | fail 1000 "unexpected failure in cast_load_tac_with_hint."
"unexpected failure in entailer_for_load_tac"]
| first [entailer_for_load_tac             | fail 1000 "unexpected failure in cast_load_tac_with_hint."
"unexpected failure in entailer_for_load_tac"]
].
Ltac cast_load_tac_no_hint LOCAL2PTREE :=
eapply semax_PTree_field_cast_load_no_hint;
[ exact LOCAL2PTREE
| reflexivity (* compute_nested_efield *)
| reflexivity
| reflexivity
| reflexivity
| reflexivity
| (solve_msubst_eval_LR                   || fail 1000 "Cannot evaluate right-hand-side expression (sometimes this is caused by missing LOCALs in your precondition)")
| (solve_msubst_efield_denote             || fail 1000 "Cannot evaluate right-hand-side expression (sometimes this is caused by missing LOCALs in your precondition)")
| econstructor
| solve_field_address_gen
| search_field_at_in_SEP (* This line can fail. If it does not, the following should not fail. *)
| (auto                                   || fail 1000 "unexpected failure in cast_load_tac_no_hint."
"Cannot prove readable_share")
| first [solve_load_rule_evaluation        | fail 1000 "unexpected failure in cast_load_tac_no_hint."
"unexpected failure in generating loaded value"]
| first [solve_legal_nested_field_in_entailment
| fail 1000 "unexpected failure in cast_load_tac_no_hint."
"unexpected failure in solve_legal_nested_field_in_entailment"]
| first [entailer_for_load_tac             | fail 1000 "unexpected failure in cast_load_tac_no_hint."
"unexpected failure in entailer_for_load_tac"]
| first [entailer_for_load_tac             | fail 1000 "unexpected failure in cast_load_tac_no_hint."
"unexpected failure in entailer_for_load_tac"]
].
Ltac cast_load_tac :=
match goal with
| |- semax ?Delta (|> (PROPx ?P (LOCALx ?Q (SEPx ?R)))) (Sset _ (Ecast ?e _)) _ =>
let T1 := fresh "T1" in evar (T1: PTree.t val);
let T2 := fresh "T2" in evar (T2: PTree.t (type * val));
let G := fresh "GV" in evar (G: option globals);
let LOCAL2PTREE := fresh "LOCAL2PTREE" in
assert (local2ptree Q = (T1, T2, nil, G)) as LOCAL2PTREE;
[subst T1 T2 G; prove_local2ptree |];
first [ cast_load_tac_with_hint LOCAL2PTREE | cast_load_tac_no_hint LOCAL2PTREE | SEP_type_contradict LOCAL2PTREE Delta e R | hint_msg LOCAL2PTREE Delta e];
clear T1 T2 G LOCAL2PTREE
end.
Definition intsize_leq a b :=
match a,b with
| IBool, IBool => True
| IBool, _ => False
| _, IBool => False
| I8, _ => True
| _, I8 => False
| I16, _ => True
| _, I16 => False
| I32, I32 => True
end.

Lemma sem_cast_i2i_compose:
forall sz1 sg sz2 x,
intsize_leq sz2 sz1 ->
sem_cast_i2i sz1 sg (force_val (sem_cast_i2i sz2 sg x)) =
sem_cast_i2i sz2 sg x.