Module Mem <: MEM.
Definition perm_order' (po: option permission) (p: permission) :=
match po with
| Some p' => perm_order p' p
| None => False
end.
Definition perm_order'' (po1 po2: option permission) :=
match po1, po2 with
| Some p1, Some p2 => perm_order p1 p2
| _, None => True
| None, Some _ => False
end.
Record mem' : Type := mkmem {
mem_contents: PMap.t (ZMap.t memval);  (**r [block -> offset -> memval] *)
mem_access: PMap.t (Z -> perm_kind -> option permission);
(**r [block -> offset -> kind -> option permission] *)
nextblock: block;
access_max:
forall b ofs, perm_order'' (mem_access#b ofs Max) (mem_access#b ofs Cur);
nextblock_noaccess:
forall b ofs k, ~(Plt b nextblock) -> mem_access#b ofs k = None;
contents_default:
forall b, fst mem_contents#b = Undef
}.
Definition mem := mem'.
(** * Validity of blocks and accesses *)
(** A block address is valid if it was previously allocated. It remains valid even after being freed. *)
Definition valid_block (m: mem) (b: block) := Plt b (nextblock m).
Local Hint Resolve valid_not_valid_diff: mem.
(** Permissions *)
Definition perm (m: mem) (b: block) (ofs: Z) (k: perm_kind) (p: permission) : Prop :=
perm_order' (m.(mem_access)#b ofs k) p.
Local Hint Resolve perm_implies: mem.
Local Hint Resolve perm_cur perm_max: mem.
Local Hint Resolve perm_valid_block: mem.
Remark perm_order_dec:
forall p1 p2, {perm_order p1 p2} + {~perm_order p1 p2}.
Local Hint Resolve range_perm_implies range_perm_cur range_perm_max: mem.
Local Hint Resolve valid_access_implies: mem.
Local Hint Resolve valid_access_valid_block: mem.
(** C allows pointers one past the last element of an array.  These are not valid according to the previously defined [valid_pointer]. The property [weak_valid_pointer m b ofs] holds if address [b, ofs] is a valid pointer in [m], or a pointer one past a valid block in [m].  *)
Definition weak_valid_pointer (m: mem) (b: block) (ofs: Z) :=
valid_pointer m b ofs || valid_pointer m b (ofs - 1).
(** * Operations over memory stores *)
(** The initial store *)
Program Definition empty: mem :=
mkmem (PMap.init (ZMap.init Undef))
(PMap.init (fun ofs k => None))
1%positive _ _ _.
Next Obligation.
repeat rewrite PMap.gi. red; auto.
Qed.
Next Obligation.
rewrite PMap.gi. auto.
Qed.
Next Obligation.
rewrite PMap.gi. auto.
Qed.
(** Allocation of a fresh block with the given bounds.  Return an updated memory state and the address of the fresh block, which initially contains undefined cells.  Note that allocation never fails: we model an infinite memory. *)
Program Definition alloc (m: mem) (lo hi: Z) :=
(mkmem (PMap.set m.(nextblock)
(ZMap.init Undef)
m.(mem_contents))
(PMap.set m.(nextblock)
(fun ofs k => if zle lo ofs && zlt ofs hi then Some Freeable else None)
m.(mem_access))
(Pos.succ m.(nextblock))
_ _ _,
m.(nextblock)).
Next Obligation.
repeat rewrite PMap.gsspec. destruct (peq b (nextblock m)).
subst b. destruct (zle lo ofs && zlt ofs hi); red; auto with mem.
apply access_max.
Qed.
Next Obligation.
rewrite PMap.gsspec. destruct (peq b (nextblock m)).
subst b. elim H. apply Plt_succ.
apply nextblock_noaccess. red; intros; elim H.
apply Plt_trans_succ; auto.
Qed.
Next Obligation.
rewrite PMap.gsspec. destruct (peq b (nextblock m)). auto. apply contents_default.
Qed.
(** Freeing a block between the given bounds. Return the updated memory state where the given range of the given block has been invalidated: future reads and writes to this range will fail.  Requires freeable permission on the given range. *)
Program Definition unchecked_free (m: mem) (b: block) (lo hi: Z): mem :=
mkmem m.(mem_contents)
(PMap.set b
(fun ofs k => if zle lo ofs && zlt ofs hi then None else m.(mem_access)#b ofs k)
m.(mem_access))
m.(nextblock) _ _ _.
Next Obligation.
repeat rewrite PMap.gsspec. destruct (peq b0 b).
destruct (zle lo ofs && zlt ofs hi). red; auto. apply access_max.
apply access_max.
Qed.
Next Obligation.
repeat rewrite PMap.gsspec. destruct (peq b0 b). subst.
destruct (zle lo ofs && zlt ofs hi). auto. apply nextblock_noaccess; auto.
apply nextblock_noaccess; auto.
Qed.
Next Obligation.
apply contents_default.
Qed.
Definition free (m: mem) (b: block) (lo hi: Z): option mem :=
if range_perm_dec m b lo hi Cur Freeable
then Some(unchecked_free m b lo hi)
else None.
Fixpoint free_list (m: mem) (l: list (block * Z * Z)) {struct l}: option mem :=
match l with
| nil => Some m
| (b, lo, hi) :: l' =>
match free m b lo hi with
| None => None
| Some m' => free_list m' l'
end
end.
(** Memory reads. *)
(** Reading N adjacent bytes in a block content. *)
Fixpoint getN (n: nat) (p: Z) (c: ZMap.t memval) {struct n}: list memval :=
match n with
| O => nil
| S n' => ZMap.get p c :: getN n' (p + 1) c
end.
(** [load chunk m b ofs] perform a read in memory state [m], at address [b] and offset [ofs].  It returns the value of the memory chunk at that address.  [None] is returned if the accessed bytes are not readable. *)
Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z): option val :=
if valid_access_dec m chunk b ofs Readable
then Some(decode_val chunk (getN (size_chunk_nat chunk) ofs (m.(mem_contents)#b)))
else None.
(** [loadv chunk m addr] is similar, but the address and offset are given as a single value [addr], which must be a pointer value. *)
Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val :=
match addr with
| Vptr b ofs => load chunk m b (Ptrofs.unsigned ofs)
| _ => None
end.
(** [loadbytes m b ofs n] reads [n] consecutive bytes starting at location [(b, ofs)].  Returns [None] if the accessed locations are not readable. *)
Definition loadbytes (m: mem) (b: block) (ofs n: Z): option (list memval) :=
if range_perm_dec m b ofs (ofs + n) Cur Readable
then Some (getN (Z.to_nat n) ofs (m.(mem_contents)#b))
else None.
(** Memory stores. *)
(** Writing N adjacent bytes in a block content. *)
Fixpoint setN (vl: list memval) (p: Z) (c: ZMap.t memval) {struct vl}: ZMap.t memval :=
match vl with
| nil => c
| v :: vl' => setN vl' (p + 1) (ZMap.set p v c)
end.
Remark setN_other:
forall vl c p q,
(forall r, p <= r < p + Z.of_nat (length vl) -> r <> q) ->
ZMap.get q (setN vl p c) = ZMap.get q c.
Remark setN_outside:
forall vl c p q,
q < p \/ q >= p + Z.of_nat (length vl) ->
ZMap.get q (setN vl p c) = ZMap.get q c.
Remark getN_setN_same:
forall vl p c,
getN (length vl) p (setN vl p c) = vl.
Remark getN_exten:
forall c1 c2 n p,
(forall i, p <= i < p + Z.of_nat n -> ZMap.get i c1 = ZMap.get i c2) ->
getN n p c1 = getN n p c2.
Remark getN_setN_disjoint:
forall vl q c n p,
Intv.disjoint (p, p + Z.of_nat n) (q, q + Z.of_nat (length vl)) ->
getN n p (setN vl q c) = getN n p c.
Remark getN_setN_outside:
forall vl q c n p,
p + Z.of_nat n <= q \/ q + Z.of_nat (length vl) <= p ->
getN n p (setN vl q c) = getN n p c.
Remark setN_default:
forall vl q c, fst (setN vl q c) = fst c.
(** [store chunk m b ofs v] perform a write in memory state [m]. Value [v] is stored at address [b] and offset [ofs]. Return the updated memory store, or [None] if the accessed bytes are not writable. *)
Program Definition store (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val): option mem :=
if valid_access_dec m chunk b ofs Writable then
Some (mkmem (PMap.set b
(setN (encode_val chunk v) ofs (m.(mem_contents)#b))
m.(mem_contents))
m.(mem_access)
m.(nextblock)
_ _ _)
else
None.
Next Obligation. apply access_max. Qed.
Next Obligation. apply nextblock_noaccess; auto. Qed.
Next Obligation.
rewrite PMap.gsspec. destruct (peq b0 b).
rewrite setN_default. apply contents_default.
apply contents_default.
Qed.
(** [storev chunk m addr v] is similar, but the address and offset are given as a single value [addr], which must be a pointer value. *)
Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem :=
match addr with
| Vptr b ofs => store chunk m b (Ptrofs.unsigned ofs) v
| _ => None
end.
(** [storebytes m b ofs bytes] stores the given list of bytes [bytes] starting at location [(b, ofs)].  Returns updated memory state or [None] if the accessed locations are not writable. *)
Program Definition storebytes (m: mem) (b: block) (ofs: Z) (bytes: list memval) : option mem :=
if range_perm_dec m b ofs (ofs + Z.of_nat (length bytes)) Cur Writable then
Some (mkmem
(PMap.set b (setN bytes ofs (m.(mem_contents)#b)) m.(mem_contents))
m.(mem_access)
m.(nextblock)
_ _ _)
else
None.
Next Obligation. apply access_max. Qed.
Next Obligation. apply nextblock_noaccess; auto. Qed.
Next Obligation.
rewrite PMap.gsspec. destruct (peq b0 b).
rewrite setN_default. apply contents_default.
apply contents_default.
Qed.
(** [drop_perm m b lo hi p] sets the max permissions of the byte range [(b, lo) ... (b, hi - 1)] to [p].  These bytes must have current permissions [Freeable] in the initial memory state [m]. Returns updated memory state, or [None] if insufficient permissions. *)
Program Definition drop_perm (m: mem) (b: block) (lo hi: Z) (p: permission): option mem :=
if range_perm_dec m b lo hi Cur Freeable then
Some (mkmem m.(mem_contents)
(PMap.set b
(fun ofs k => if zle lo ofs && zlt ofs hi then Some p else m.(mem_access)#b ofs k)
m.(mem_access))
m.(nextblock) _ _ _)
else None.
Next Obligation.
repeat rewrite PMap.gsspec. destruct (peq b0 b). subst b0.
destruct (zle lo ofs && zlt ofs hi). red; auto with mem. apply access_max.
apply access_max.
Qed.
Next Obligation.
specialize (nextblock_noaccess m b0 ofs k H0). intros.
rewrite PMap.gsspec. destruct (peq b0 b). subst b0.
destruct (zle lo ofs). destruct (zlt ofs hi).
assert (perm m b ofs k Freeable). apply perm_cur. apply H; auto.
unfold perm in H2. rewrite H1 in H2. contradiction.
auto. auto. auto.
Qed.
Next Obligation.
apply contents_default.
Qed.
(** * Properties of the memory operations *)
(** Properties of the empty store. *)
(** ** Properties related to [load] *)
Local Hint Resolve load_valid_access valid_access_load: mem.
(** ** Properties related to [loadbytes] *)
(** ** Properties related to [store] *)
Local Hint Resolve perm_store_1 perm_store_2: mem.
Local Hint Resolve store_valid_block_1 store_valid_block_2: mem.
Local Hint Resolve store_valid_access_1 store_valid_access_2 store_valid_access_3: mem.
End STORE.
Local Hint Resolve perm_store_1 perm_store_2: mem.
Local Hint Resolve store_valid_block_1 store_valid_block_2: mem.
Local Hint Resolve store_valid_access_1 store_valid_access_2
store_valid_access_3: mem.
Definition compat_pointer_chunks (chunk1 chunk2: memory_chunk) : Prop :=
match chunk1, chunk2 with
| (Mint32 | Many32), (Mint32 | Many32) => True
| (Mint64 | Many64), (Mint64 | Many64) => True
| _, _ => False
end.

Lemma compat_pointer_chunks_true:
forall chunk1 chunk2,
(chunk1 = Mint32 \/ chunk1 = Many32 \/ chunk1 = Mint64 \/ chunk1 = Many64) ->
(chunk2 = Mint32 \/ chunk2 = Many32 \/ chunk2 = Mint64 \/ chunk2 = Many64) ->
quantity_chunk chunk1 = quantity_chunk chunk2 ->
compat_pointer_chunks chunk1 chunk2.