(* First draft specs.  Not specifying that chunks are aligned. *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Local Open Scope Z.
Local Open Scope logic.
(* TODO Initially I imagined the constants would be defined as parameters (with suitable assumptions, e.g., BIGBLOCK needs to be big enough for at least one chunk of the largest size, because fill_bin unconditionally initializes the last chunk. *)
Definition WORD: Z := 4. (* sizeof(size_t) 4 for 32bit Clight; 8 in clang *)
Definition ALIGN: Z := 2.
Definition BINS: Z := 8.
Parameter BIGBLOCK: Z.
Parameter BIGBLOCK_def:
Int.repr BIGBLOCK = Int.mul (Int.shl (Int.repr 2) (Int.repr 16)) (Int.repr WORD).
Definition bin2sizeZ := fun b: Z => (Z.mul ((Z.mul (b+1) ALIGN)-1) WORD).
Definition size2binZ : Z -> Z := fun s =>
if zlt (bin2sizeZ(BINS-1)) s then -1
else (s+(Z.mul WORD (ALIGN-1))-1) / (Z.mul WORD ALIGN).
Eval compute in bin2sizeZ (BINS-1).
Example bin2sizeBINS: bin2sizeZ (BINS-1) = 60. Proof. reflexivity. Qed.
(* Hint Unfold WORD ALIGN : myDB. auto with myDB *)
(* Some sanity checks; may not be needed for code verification. *)
Definition sbrk_spec :=
(* like malloc without token; and I removed the possibility of failure to streamline the proof of fill_bin *)
DECLARE _sbrk
WITH n:Z
PRE [ 1%positive OF tuint ]
PROP (0 <= n <= Int.max_unsigned)
LOCAL (temp 1%positive (Vint (Int.repr n)))
SEP ()
POST [ tptr tvoid ] EX p:_,
PROP ()
LOCAL (temp ret_temp p)
SEP ( (* if eq_dec p nullval then emp else memory_block Tsh n p) *)
memory_block Tsh n p).
Definition bin2size_spec :=
DECLARE _bin2size
WITH b: Z
PRE [ _b OF tint ]
PROP( 0 <= b <= Int.max_signed )
LOCAL (temp _b (Vint (Int.repr b))) SEP ()
POST [ tuint ]
PROP() LOCAL(temp ret_temp (Vint (Int.repr (bin2sizeZ b)))) SEP ().
Definition size2bin_spec :=
DECLARE _size2bin
WITH s: Z
PRE [ _s OF tuint ]    (* Vlong? *)
PROP( 0 <= s <= Int.max_unsigned )
LOCAL (temp _s (Vint (Int.repr s))) SEP ()
POST [ tint ]
PROP() LOCAL(temp ret_temp (Vint (Int.repr (size2binZ s)))) SEP ().
(* malloc token, which accounts for the size field and padding. * n is the size requested * Unfolding the definition reveals the stored size value and the * actual size of the block. * Note that offset_val is in bytes, not like C pointer arith. *)
Definition malloc_token' (sh: share) (n: Z) (p: val): mpred :=
data_at Tsh tuint (offset_val (- WORD) p) (Vint (Int.repr n))
* memory_block Tsh ((bin2sizeZ(size2binZ(n)) - n)) (offset_val n p).
(* linked list, for free blocks. p points to a linked list of len blocks, each of sz bytes, of the form (sz,nxt,_) with link nxt, terminated at r. Using nat for ease of termination check, at cost of Z conversions. *)
Fixpoint mmlist (sz: Z) (len: nat) (p: val) (r: val): mpred :=
match len with
| O => !! (ptr_eq p r) && emp
| (S n) => EX q:val, !! is_pointer_or_null q &&
data_at Tsh tuint (offset_val (-WORD) p) (Vint(Int.repr sz))
* data_at Tsh (tptr tvoid) p q
* memory_block Tsh (sz - WORD) (offset_val WORD p)
* mmlist sz n q r
end.
(* module invariant: Each element of array points to a null-terminated list of right size blocks.  This version folds over index list, which makes it easy to express the block size per bin; it may facilitate per-index update. *)
Definition mm_inv (arr: val): mpred :=
EX bins: list val, EX lens: list nat,
!! (Zlength bins = BINS /\ Zlength lens = BINS)  &&
data_at Tsh (tarray (tptr tvoid) BINS) bins arr
* fold_right (fun (i: nat) => fun (mp: mpred) =>
(mmlist (bin2sizeZ (Z.of_nat i)) (nth i lens O) (nth i bins nullval) nullval) * mp )
emp
(seq 0 (Z.to_nat BINS)).
(* copy of malloc_spec' from floyd library, with mm_inv added *)
Definition malloc_spec'' :=
DECLARE _malloc
WITH n:Z, bin:val
PRE [ 1%positive OF tuint ]
PROP (0 <= n <= Int.max_unsigned)
LOCAL (temp 1%positive (Vint (Int.repr n)); gvar _bin bin)
SEP ( mm_inv bin )
POST [ tptr tvoid ] EX p:_,
PROP ()
LOCAL (temp ret_temp p)
SEP ( mm_inv bin;
if eq_dec p nullval then emp
else (malloc_token Tsh n p * memory_block Tsh n p)).
Definition free_spec'' := (* copy from floyd lib, with mm_inv added *)
DECLARE _free
WITH p:_, n:_, bin:_
PRE [ 1%positive OF tptr tvoid ]
PROP ()
LOCAL (temp 1%positive p; gvar _bin bin)
SEP (malloc_token Tsh n p; memory_block Tsh n p; mm_inv bin)
POST [ Tvoid ]
PROP ()
LOCAL ()
SEP (mm_inv bin).
Definition malloc_small_spec :=
DECLARE _malloc_small
WITH n:Z, bin:_
PRE [ 1%positive OF tuint ]
PROP (0 <= n <= bin2sizeZ(BINS-1))
LOCAL (temp 1%positive (Vint (Int.repr n)); gvar _bin bin)
SEP ( mm_inv bin )
POST [ tptr tvoid ] EX p:_,
PROP ()
LOCAL (temp ret_temp p)
SEP ( mm_inv bin;
if eq_dec p nullval then emp
else (malloc_token' Tsh n p * memory_block Tsh n p)).
Definition free_small_spec :=
DECLARE _free_small
WITH p:_, n:_, s:_
PRE [ 1%positive OF tptr tvoid, 2%positive OF tint ]
PROP ( n = s )
LOCAL (temp 1%positive p; temp 2%positive (Vint (Int.repr s)))
SEP (malloc_token' Tsh n p; memory_block Tsh n p)
POST [ tvoid ]
PROP ()
LOCAL ()
SEP ().
Definition fill_bin_spec :=
DECLARE _fill_bin
WITH b: _
PRE [ _b OF tint ]
PROP(0 <= b < BINS) LOCAL (temp _b (Vint (Int.repr b))) SEP ()
POST [ (tptr tvoid) ] EX p:_, EX len:Z,
PROP( len > 0 )
LOCAL(temp ret_temp p)
SEP ( mmlist (bin2sizeZ b) (Z.to_nat len) p nullval ).
Definition main_spec :=
DECLARE _main
WITH u : unit
PRE  [] main_pre prog tt nil u
POST [ tint ]  main_post prog nil u.
Definition Gprog : funspecs :=
ltac:(with_library prog [
sbrk_spec; bin2size_spec; size2bin_spec; fill_bin_spec;
malloc_small_spec; free_small_spec; malloc_spec''; free_spec'';
main_spec]).
(* note to Andrew: forward_for wouldn't work until we added True to the Prop in the following.*)
Definition fill_bin_dummy (b:Z) (p:val) (qNs:val*Z*Z) :=
PROP(True)LOCAL(temp _q (let '(q, _, _) := qNs in q);
temp _p p;
temp _s (Vint (Int.repr (let '(_,_,s) := qNs in s)));
temp _b (Vint (Int.repr b)))
SEP().
Definition fill_bin_Inv (b:Z) (p:val) (qNs:val*Z*Z) :=
(*  EX N:Z, EX s:Z, *)
PROPx (let '(q,N,s) := qNs in
[s = bin2sizeZ b; 0 <= N; s + N*(WORD+s) <= BIGBLOCK])
(LOCALx ([temp _q (let '(q,N,s):=qNs in q);
temp _p p;
temp _s (Vint (Int.repr (let '(q,N,s):=qNs in s)));
temp _b (Vint (Int.repr b))])
(SEPx ( let '(q,N,s):=qNs in
[mmlist s (Z.to_nat N) (offset_val s p) q;
memory_block Tsh (BIGBLOCK-(s+N*(WORD+s))) q] ))).
Definition fill_bin_preIncr (b:Z) (p:val) (qNs:val*Z*Z) :=
(*  EX N:Z, EX s:Z, William suggests localizing the lets so tactic pattern-matches may work *)
PROP ( let '(q,N,s) := qNs in
s = bin2sizeZ b /\ 0 <= N /\ s + N*(WORD+s) <= BIGBLOCK )
LOCAL (temp _q (let '(q,_,_) := qNs in q);
temp _p p;
temp _s (Vint (Int.repr (let '(_,_,s) := qNs in s)));
temp _b (Vint (Int.repr b)))
SEP (  let '(q,N,s) := qNs in
mmlist s (Z.to_nat N) (offset_val s p) q
* memory_block Tsh (BIGBLOCK - (s+N*(WORD+s)) - (WORD+s)) (offset_val (WORD+s) q)
* data_at Tsh tuint (Vint (Int.repr s)) q (* size *)
* data_at Tsh (tptr tvoid) (offset_val (WORD+s) q) (offset_val WORD q) (* next *)
* memory_block Tsh (s-WORD-WORD) (offset_val (WORD+WORD) q) (* rest of block *) ).

Lemma body_fill_bin: semax_body Vprog Gprog f_fill_bin fill_bin_spec.