Section CENV.
Context {cs: compspecs}.
Definition field_at (sh: Share.t) (t: type) (gfs: list gfield) (v: reptype (nested_field_type t gfs)) (p: val): mpred :=
!! (field_compatible t gfs p) &&
at_offset (data_at_rec sh (nested_field_type t gfs) v) (nested_field_offset t gfs) p.
Arguments field_at sh t gfs v p : simpl never.
Definition field_at_ (sh: Share.t) (t: type) (gfs: list gfield) (p: val): mpred :=
field_at sh t gfs (default_val (nested_field_type t gfs)) p.
Arguments field_at_ sh t gfs p : simpl never.
Definition data_at (sh: Share.t) (t: type) (v: reptype t) := field_at sh t nil v.
Definition data_at_ (sh: Share.t) (t: type) := field_at_ sh t nil.
Definition nested_reptype_structlist t gfs (m: members) :=
compact_prod (map (fun it => reptype (nested_field_type t (StructField (fst it) :: gfs))) m).
Definition nested_reptype_unionlist t gfs (m: members) :=
compact_sum (map (fun it => reptype (nested_field_type t (UnionField (fst it) :: gfs))) m).
(************************************************  Unfold and split lemmas  ************************************************)
Ltac solve_ptr_derives :=
repeat rewrite isptr_offset_val;
apply derives_refl.
Ltac solve_nptr p A :=
let H := fresh "H" in
match A with
| (?B * ?C) % logic =>
try solve [assert (~ isptr p -> B = FF) as H by solve_nptr p B;
intro; rewrite H by auto ; apply FF_sepcon];
try solve [assert (~ isptr p -> C = FF) as H by solve_nptr p C;
intro; rewrite H by auto; apply sepcon_FF]
| (?B && ?C) % logic =>
try solve [assert (~ isptr p -> B = FF) as H by solve_nptr p B;
intro; rewrite H by auto ; apply FF_andp];
try solve [assert (~ isptr p -> C = FF) as H by solve_nptr p C;
intro; rewrite H by auto; apply andp_FF]
| _ => apply (proj1 (not_ptr_FF A p)); solve_ptr p A
end
with solve_ptr p A :=
let p0 := fresh "p" in
match A with
| (_ * _) % logic => apply (proj2 (not_ptr_FF A p)); solve_nptr p A
| (_ && _) % logic => apply (proj2 (not_ptr_FF A p)); solve_nptr p A
| (!! _ /\ _)%logic => destruct A as [_ A]; solve_ptr p A
| (!! field_compatible _ _ ?q) => apply (derives_trans _ _ _ (prop_derives _ _ (field_compatible_isptr _ _ _))); solve_ptr_derives
| (!! field_compatible0 _ _ ?q) => apply (derives_trans _ _ _ (prop_derives _ _ (field_compatible0_isptr _ _ _))); solve_ptr_derives
| (memory_block _ _ ?q) => apply (derives_trans _ _ _ (memory_block_local_facts _ _ _)); solve_ptr_derives
| (withspacer _ _ _ ?P p) => apply withspacer_preserve_local_facts;
intro p0; solve_ptr p0 (P p0)
| (at_offset ?P _ ?q) => apply (derives_trans _ (!! isptr q));
[apply at_offset_preserve_local_facts; intro p0; solve_ptr p0 (P p0) |
solve_ptr_derives]
| (field_at _ _ _ _ p) => apply field_at_isptr'
end.
Ltac destruct_ptr p :=
let b := fresh "b" in
let ofs := fresh "OFS" in
match goal with
| |- (@eq mpred) ?A ?B =>
let H := fresh "H" in
let H0 := fresh "H" in
assert (~ isptr p -> A = FF) as H by solve_nptr p A;
assert (~ isptr p -> B = FF) as H0 by solve_nptr p B;
destruct p as [| | | | | b ofs]; try (rewrite H, H0 by (simpl; congruence); reflexivity);
clear H H0;
inv_int ofs
| |- (?A |-- _) =>
let H := fresh "H" in
assert (~ isptr p -> A = FF) as H by solve_nptr p A;
destruct p as [| | | | | b ofs]; try (rewrite H by (simpl; congruence); apply FF_left);
clear H;
inv_int ofs
end.
(************************************************  Reroot lemmas  ************************************************)
(************************************************  Lemmas about underscore and memory_block  ************************************************)
(*  let d := default_val _ in *)
(************************************************  Other lemmas  ************************************************)
Definition compute_legal_nested_field0 (t: type) (gfs: list gfield) : list Prop :=
match gfs with
| nil => nil
| gf :: gfs0 =>
match (nested_field_type t gfs0), gf with
| Tarray _ n _, ArraySubsc i =>
(0 <= i <= n) :: compute_legal_nested_field t gfs0
| Tstruct id _, StructField i =>
if compute_in_members i (co_members (get_co id)) then compute_legal_nested_field t gfs else False :: nil
| Tunion id _, UnionField i =>
if compute_in_members i (co_members (get_co id)) then compute_legal_nested_field t gfs else False :: nil
| _, _ => False :: nil
end
end.
(* Lemma field_at_field_at: forall sh t gfs0 gfs1 v v' p, legal_alignas_type t = true -> JMeq v v' -> field_at sh t (gfs1 ++ gfs0) v p = (!! (size_compatible t p)) && (!! (align_compatible t p)) && (!! (legal_nested_field t (gfs1 ++ gfs0))) && at_offset' (field_at sh (nested_field_type2 t gfs0) gfs1 v') (nested_field_offset2 t gfs0) p. *)
End CENV.
Hint Extern 2 (memory_block _ _ _ |-- valid_pointer _) =>
(apply memory_block_valid_ptr; [auto with valid_pointer | rep_omega]) : valid_pointer.
Hint Resolve valid_pointer_weak' : valid_pointer.
Hint Extern 1 (_ |-- valid_pointer ?Q) =>
lazymatch Q with
| offset_val _ _ => fail
| _ => apply valid_pointer_offset_zero
end : core.
Hint Extern 2 (memory_block _ _ _ |-- weak_valid_pointer _) =>
(apply SeparationLogic.memory_block_weak_valid_pointer;
[rep_omega | rep_omega | auto with valid_pointer]) : valid_pointer.
Ltac field_at_conflict z fld :=
eapply derives_trans with FF; [ | apply FF_left];
rewrite <- ?sepcon_assoc;
unfold data_at_, data_at, field_at_;
let x := fresh "x" in set (x := field_at _ _ fld _ z); pull_right x;
let y := fresh "y" in set (y := field_at _ _ fld _ z); pull_right y;
try (rewrite sepcon_assoc; eapply sepcon_FF_derives');
subst x y;
apply field_at_conflict; auto;
try solve [simpl; computable].
Ltac data_at_conflict z := field_at_conflict z (@nil gfield).
Ltac data_at_conflict_neq_aux1 A sh fld E x y :=
match A with
| context [data_at sh _ _ y] => unify fld (@nil gfield)
| context [data_at_ sh _ y]  => unify fld (@nil gfield)
| context [field_at sh _ fld _ y] => idtac
| context [field_at_ sh _ fld y]  => idtac
end;
apply derives_trans with (!! (~ E) && A);
[apply andp_right; [ | apply derives_refl];
let H := fresh in
apply not_prop_right; intro H;
(rewrite H || rewrite (ptr_eq_e _ _ H));
field_at_conflict y fld
| apply derives_extract_prop;
let H1 := fresh in intro H1;
rewrite (eq_True _ H1)
].
Ltac data_at_conflict_neq_aux2 A E x y :=
match A with
| context [data_at ?sh _ _ x] => data_at_conflict_neq_aux1 A sh (@nil gfield) E x y
| context [data_at_ ?sh _ x]  => data_at_conflict_neq_aux1 A sh (@nil gfield) E x y
| context [field_at ?sh _ ?fld _ x] => data_at_conflict_neq_aux1 A sh fld E x y
| context [field_at_ ?sh _ ?fld x]  => data_at_conflict_neq_aux1 A sh fld E x y
end.
Ltac data_at_conflict_neq :=
match goal with |- ?A |-- ?B =>
match B with
| context [?x <> ?y] => data_at_conflict_neq_aux2 A (x=y) x y
| context [~ ptr_eq ?x ?y] => data_at_conflict_neq_aux2 A (ptr_eq x y) x y
end
end.
Definition natural_aligned {cs: compspecs} (na: Z) (t: type): bool := (na mod (hardware_alignof ha_env_cs t) =? 0) && is_aligned cenv_cs ha_env_cs la_env_cs t 0.
Definition natural_aligned_soundness {cs: compspecs}: Prop :=
forall na ofs t,
complete_legal_cosu_type t = true ->
natural_aligned na t = true ->
(na | ofs) ->
align_compatible_rec cenv_cs t ofs.
Definition natural_alignment := 8.
(* TODO: change this name to malloc_compatible_ptr and merge the definition of isptr, size_compatible, align_compatible into something like: size_align_compatible_ptr *)
Definition malloc_compatible (n: Z) (p: val) : Prop :=
match p with
| Vptr b ofs => (natural_alignment | Ptrofs.unsigned ofs) /\
Ptrofs.unsigned ofs + n < Ptrofs.modulus
| _ => False
end.
Hint Extern 2 (field_compatible _ nil _) =>
(apply malloc_compatible_field_compatible;
[assumption | reflexivity | reflexivity]) : core.
Ltac field_at_saturate_local :=
unfold data_at;
match goal with |- field_at ?sh ?t ?path ?v ?c |-- _ =>
eapply derives_trans; [apply field_at_local_facts |];
cbv beta;
try rewrite proj_sumbool_is_true by auto;
try rewrite proj_sumbool_is_false by auto;
let p := fresh "p" in set (p := nested_field_type t path);
simpl in p; unfold field_type in p; simpl in p; subst p;
try rewrite value_fits_by_value by reflexivity;
try match goal with |- context [repinject ?t ?v] =>
change (repinject t v) with v
end;
apply derives_refl
end.
Ltac data_at_valid_aux :=
simpl sizeof; rewrite ?Z.max_r by rep_omega; rep_omega.
Hint Extern 1 (data_at _ _ _ _ |-- valid_pointer _) =>
(simple apply data_at_valid_ptr; [now auto | data_at_valid_aux]) : valid_pointer.
Hint Extern 1 (field_at _ _ _ _ _ |-- valid_pointer _) =>
(simple apply field_at_valid_ptr; [now auto | data_at_valid_aux]) : valid_pointer.
Hint Extern 1 (data_at_ _ _ _ |-- valid_pointer _) =>
(unfold data_at_, field_at_;
simple apply field_at_valid_ptr; [now auto | data_at_valid_aux]) : valid_pointer.
Hint Extern 1 (field_at_ _ _ _ _ |-- valid_pointer _) =>
(unfold field_at_; simple apply field_at_valid_ptr; [now auto | data_at_valid_aux]) : valid_pointer.
Hint Extern 1 (data_at_ _ _ _ |-- valid_pointer _) =>
(simple apply data_at_valid_ptr; [now auto | data_at_valid_aux]) : valid_pointer.
Hint Extern 1 (field_at_ _ _ _ _ |-- valid_pointer _) =>
(simple apply field_at_valid_ptr; [now auto | data_at_valid_aux]) : valid_pointer.
(* Hint Resolve data_at_valid_ptr field_at_valid_ptr field_at_valid_ptr0 : valid_pointer. *)
(*Hint Resolve field_at_local_facts : saturate_local.*)
Hint Extern 1 (field_at _ _ _ _ _ |-- _) =>
(field_at_saturate_local) : saturate_local.
(* Hint Resolve data_at_local_facts : saturate_local.*)
Hint Extern 1 (data_at _ _ _ _ |-- _) =>
(field_at_saturate_local) : saturate_local.
Hint Resolve @array_at_local_facts @array_at__local_facts : saturate_local.
Hint Resolve field_at__local_facts : saturate_local.
Hint Resolve data_at__local_facts : saturate_local.
Hint Extern 0 (data_at _ (Tarray _ _ _) _ _ |-- _) =>
(apply data_array_at_local_facts'; omega) : saturate_local.
Hint Extern 0 (data_at _ (tarray _ _) _ _ |-- _) =>
(apply data_array_at_local_facts'; omega) : saturate_local.
Hint Extern 1 (data_at _ (Tarray _ _ _) _ _ |-- _) =>
(apply data_array_at_local_facts) : saturate_local.
Hint Extern 1 (data_at _ (tarray _ _) _ _ |-- _) =>
(apply data_array_at_local_facts) : saturate_local.
Hint Rewrite <- @field_at_offset_zero: norm1.
Hint Rewrite <- @field_at__offset_zero: norm1.
Hint Rewrite <- @field_at_offset_zero: cancel.
Hint Rewrite <- @field_at__offset_zero: cancel.
Hint Rewrite <- @data_at__offset_zero: norm1.
Hint Rewrite <- @data_at_offset_zero: norm1.
Hint Rewrite <- @data_at__offset_zero: cancel.
Hint Rewrite <- @data_at_offset_zero: cancel.
(* We do these as specific lemmas, rather than as Hint Resolve derives_refl, to limit their application and make them fail faster *)
(* not useful? *)
(* Lemma headptr_field_compatible' {cs: compspecs}: forall t p, headptr p -> legal_alignas_type t = true -> legal_cosu_type t = true -> sizeof t < Ptrofs.modulus -> complete_type cenv_cs t = true -> field_compatible t nil p. *)
Hint Resolve data_at__data_at : cancel.
Hint Resolve field_at__field_at : cancel.
Hint Resolve data_at__field_at : cancel.
Hint Resolve field_at__data_at : cancel.
Hint Extern 1 (_ = @default_val _ _) =>
match goal with |- ?A = ?B =>
let x := fresh "x" in set (x := B); hnf in x; subst x;
match goal with |- ?A = ?B => constr_eq A B; reflexivity
end end : core.
Hint Extern 1 (_ = _) =>
match goal with |- ?A = ?B => constr_eq A B; reflexivity end : cancel.
(* enhance cancel to solve field_at and data_at *)
Hint Rewrite
@field_at_data_at_cancel'
@field_at_data_at
@field_at__data_at_
@data_at__data_at : cancel.
(* END new experiments *)

Lemma change_compspecs_data_at_cancel:
forall {cs1 cs2: compspecs} {CCE : change_composite_env cs1 cs2}
(sh: share) (t1 t2: type)
(v1: @reptype cs1 t1) (v2: @reptype cs2 t2)
(p: val),
t1 = t2 ->
cs_preserve_type cs1 cs2 (@coeq cs1 cs2 CCE) t1 = true ->
JMeq v1 v2 ->
@data_at cs1 sh t1 v1 p |-- @data_at cs2 sh t2 v2 p.