(** * Abstracting memory states *)
Record amem : Type := AMem {
am_stack: ablock;
am_glob: PTree.t ablock;
am_nonstack: aptr;
am_top: aptr
}.
Record mmatch (m: mem) (am: amem) : Prop := mk_mem_match {
mmatch_stack: forall b,
bc b = BCstack ->
bmatch m b am.(am_stack);
mmatch_glob: forall id ab b,
bc b = BCglob id ->
am.(am_glob)!id = Some ab ->
bmatch m b ab;
mmatch_nonstack: forall b,
bc b <> BCstack -> bc b <> BCinvalid ->
smatch m b am.(am_nonstack);
mmatch_top: forall b,
bc b <> BCinvalid ->
smatch m b am.(am_top);
mmatch_below:
bc_below bc (Mem.nextblock m)
}.
Definition minit (p: aptr) :=
{| am_stack := ablock_init p;
am_glob := PTree.empty _;
am_nonstack := p;
am_top := p |}.
Definition mbot := minit Pbot.
Definition mtop := minit Ptop.
Definition load (chunk: memory_chunk) (rm: romem) (m: amem) (p: aptr) : aval :=
match p with
| Pbot => if va_strict tt then Vbot else Vtop
| Gl id ofs =>
match rm!id with
| Some ab => ablock_load chunk ab (Ptrofs.unsigned ofs)
| None =>
match m.(am_glob)!id with
| Some ab => ablock_load chunk ab (Ptrofs.unsigned ofs)
| None => vnormalize chunk (Ifptr m.(am_nonstack))
end
end
| Glo id =>
match rm!id with
| Some ab => ablock_load_anywhere chunk ab
| None =>
match m.(am_glob)!id with
| Some ab => ablock_load_anywhere chunk ab
| None => vnormalize chunk (Ifptr m.(am_nonstack))
end
end
| Stk ofs => ablock_load chunk m.(am_stack) (Ptrofs.unsigned ofs)
| Stack => ablock_load_anywhere chunk m.(am_stack)
| Glob | Nonstack => vnormalize chunk (Ifptr m.(am_nonstack))
| Ptop => vnormalize chunk (Ifptr m.(am_top))
end.
Definition loadv (chunk: memory_chunk) (rm: romem) (m: amem) (addr: aval) : aval :=
load chunk rm m (aptr_of_aval addr).
Definition store (chunk: memory_chunk) (m: amem) (p: aptr) (av: aval) : amem :=
{| am_stack :=
match p with
| Stk ofs      => ablock_store chunk m.(am_stack) (Ptrofs.unsigned ofs) av
| Stack | Ptop => ablock_store_anywhere chunk m.(am_stack) av
| _ => m.(am_stack)
end;
am_glob :=
match p with
| Gl id ofs =>
let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in
PTree.set id (ablock_store chunk ab (Ptrofs.unsigned ofs) av) m.(am_glob)
| Glo id =>
let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in
PTree.set id (ablock_store_anywhere chunk ab av) m.(am_glob)
| Glob | Nonstack | Ptop => PTree.empty _
| _ => m.(am_glob)
end;
am_nonstack :=
match p with
| Gl _ _ | Glo _ | Glob | Nonstack | Ptop => vplub av m.(am_nonstack)
| _ => m.(am_nonstack)
end;
am_top := vplub av m.(am_top)
|}.
Definition storev (chunk: memory_chunk) (m: amem) (addr: aval) (v: aval): amem :=
store chunk m (aptr_of_aval addr) v.
Definition loadbytes (m: amem) (rm: romem) (p: aptr) : aptr :=
match p with
| Pbot => if va_strict tt then Pbot else Ptop
| Gl id _ | Glo id =>
match rm!id with
| Some ab => ablock_loadbytes ab
| None =>
match m.(am_glob)!id with
| Some ab => ablock_loadbytes ab
| None => m.(am_nonstack)
end
end
| Stk _ | Stack => ablock_loadbytes m.(am_stack)
| Glob | Nonstack => m.(am_nonstack)
| Ptop => m.(am_top)
end.
Definition storebytes (m: amem) (dst: aptr) (sz: Z) (p: aptr) : amem :=
{| am_stack :=
match dst with
| Stk ofs      => ablock_storebytes m.(am_stack) p (Ptrofs.unsigned ofs) sz
| Stack | Ptop => ablock_storebytes_anywhere m.(am_stack) p
| _ => m.(am_stack)
end;
am_glob :=
match dst with
| Gl id ofs =>
let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in
PTree.set id (ablock_storebytes ab p (Ptrofs.unsigned ofs) sz) m.(am_glob)
| Glo id =>
let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in
PTree.set id (ablock_storebytes_anywhere ab p) m.(am_glob)
| Glob | Nonstack | Ptop => PTree.empty _
| _ => m.(am_glob)
end;
am_nonstack :=
match dst with
| Gl _ _ | Glo _ | Glob | Nonstack | Ptop => plub p m.(am_nonstack)
| _ => m.(am_nonstack)
end;
am_top := plub p m.(am_top)
|}.

Theorem storebytes_sound:
forall m b ofs bytes m' am p sz q,
Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' ->
mmatch m am ->
pmatch b ofs p ->
length bytes = nat_of_Z sz ->
(forall b' ofs' qt i, In (Fragment (Vptr b' ofs') qt i) bytes -> pmatch b' ofs' q) ->
mmatch m' (storebytes am p sz q).