Library topsy_hmAlloc

Load seplog_header.

Require Import topsy_hm.

Require Import Bool.

Definition ENTRYSIZE (x:var.v) (tmp:var.v) :=
  tmp <-* (x -.> next);
  tmp <- (var_e tmp -e var_e x -e int_e 2%Z);
  ifte (nat_e 0 >> var_e tmp) thendo
    tmp <- nat_e 0
  elsedo
    skip.

Definition findFree (size:nat) (entry fnd sz stts:var.v) :=
  entry <- var_e hmStart;
  stts <-* (entry -.> status);
  fnd <- int_e 0%Z;
  while ((var_e entry =/= null) &&& (var_e fnd =/= int_e 1%Z)) (
    stts <-* (entry -.> status);
    ENTRYSIZE entry sz;
    ifte ((var_e stts == Free) &&& (var_e sz >>= nat_e size)) thendo
      (fnd <- int_e 1%Z)
    elsedo
      (entry <-* (entry -.> next))).

Definition LEFTOVER : nat := 8.

Definition compact' (cptr nptr brk tmp cstts nstts:var.v) :=
  while (var_e cptr =/= null) (
    nptr <-* (cptr -.> next);
    brk <- nat_e 1 ;
    cstts <-* (cptr -.> status);
    while ((var_e cstts == Free) &&& (var_e nptr =/= null) &&& (var_e brk == nat_e 1)) (
       nstts <-* (nptr -.> status);
       ifte (var_e nstts =/= Free) thendo (
          brk <- nat_e 0
       ) elsedo (
         tmp <-* nptr -.> next;
         cptr -.> next *<- var_e tmp ;
         nptr <- (var_e tmp)
       )
    );
    cptr <-* (cptr -.> next)
  ).

Definition compact (cptr nptr stts:var.v) :=
  while (var_e cptr =/= null) (
    stts <-* (cptr -.> status);
    ifte (var_e stts == Free) thendo (
      nptr <-* (cptr -.> next);
      stts <-* (nptr -.> status);
      while (var_e stts == Free) (

        stts <-* (nptr -.> next);
        (cptr -.> next) *<- var_e stts;
        nptr <- var_e stts;
        stts <-* (nptr -.> status)))
    elsedo
      skip;
      cptr <-* (cptr -.> next)).

Definition split (entry:var.v) (size:nat) (cptr sz:var.v) :=
  ENTRYSIZE entry sz;
  ifte (var_e sz >>= (nat_e size +e nat_e LEFTOVER +e nat_e 2)) thendo (
    cptr <- var_e entry +e nat_e 2 +e nat_e size;
    sz <-* (entry -.> next);
    (cptr -.> next) *<- var_e sz;
    (cptr -.> status) *<- Free;
    (entry -.> next) *<- var_e cptr)
   elsedo
     skip
  ;
  (entry -.> status) *<- Allocated.

Definition HM_ALLOCFAILED := int_e 0%Z.

Definition HM_ALLOCOK := int_e 1%Z.

Definition hmAlloc (result:var.v) (size: nat) (entry:var.v) (cptr fnd stts nptr sz:var.v) :=
       result <- null;
  findFree size entry fnd sz stts;
  ifte (var_e entry == null) thendo (
    cptr <- var_e hmStart;
    compact cptr nptr stts;
    findFree size entry fnd sz stts
  ) elsedo
    skip
  ;
  ifte (var_e entry == null) thendo (
    result <- HM_ALLOCFAILED
  ) elsedo (
    split entry size cptr sz;
    result <- var_e entry +e nat_e 2
  ).

Ltac Resolve_topsy :=
  match goal with
    | id: Heap_List ?l ?adr ?s1 ?h |-
            Heap_List ?l ?adr ?s2 ?h =>
                    eapply Heap_List_inde_store; apply id
    | |- (?s |b= ?b) =>
            (
              (rewrite <- expr_b_store_update_rewrite; Omega_exprb) ||
              Omega_exprb
            )
    | |- ?P /\ ?Q => split; Resolve_topsy
    | |- _ => auto
  end.

Definition findFree_specif := forall adr x sizex size,
  size > 0 -> adr > 0 ->
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x,sizex,alloc) adr /\
     (s |b= (var_e hmStart == nat_e adr) &&& (var_e result == null)) }}
  findFree size entry fnd sz stts
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x,sizex,alloc) adr /\
     (s |b= (var_e hmStart == nat_e adr) &&& (var_e result == null)) /\
     ((exists y, exists size'', size'' >= size /\
      In_hl l (y,size'',free) adr /\
      (s |b= (var_e entry == nat_e y) &&& (nat_e y >> null)))
      \/
      s |b= var_e entry == null) }}.

Lemma findFree_verif : findFree_specif.


































Definition brk := 10.
Hint Unfold brk.
Definition tmp := 11.
Hint Unfold tmp.
Definition cstts := 12.
Hint Unfold cstts.
Definition nstts := 13.
Hint Unfold nstts.

Definition compact'_specif:= forall adr size x sizex,
  size > 0 -> adr > 0 ->
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x,sizex,alloc) adr /\ (s |b= (var_e hmStart == nat_e adr) &&&
     (var_e result == null) &&& (var_e cptr == nat_e adr)) }}
  compact' cptr nptr brk tmp cstts nstts
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x,sizex,alloc) adr /\
     (s |b= (var_e hmStart == nat_e adr) &&& (var_e result == null)) }}.

Lemma compact'_verif: compact'_specif.

























Definition compact_specif:= forall adr size sizex x,
 size > 0 -> adr > 0 ->
 {{ fun s h => exists l, Heap_List l adr s h /\
   In_hl l (x,sizex,alloc) adr /\
    (s |b= (var_e hmStart == nat_e adr) &&& (var_e result == null) &&& (var_e cptr == nat_e adr)) }}
 compact cptr nptr stts
 {{ fun s h => exists l, Heap_List l adr s h /\
    In_hl l (x,sizex,alloc) adr /\
    (s |b= (var_e hmStart == nat_e adr) &&& (var_e result == null)) }}.

Lemma compact_verif : compact_specif.































Definition split_specif := forall adr size sizex x,
  size > 0 -> adr > 0 ->
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x,sizex,alloc) adr /\
     (s |b= (var_e hmStart == nat_e adr) &&& (var_e result == null)) /\
     (exists y, exists size'', size'' >= size /\
       In_hl l (y,size'',free) adr /\
       (s |b= var_e entry == nat_e y) /\
       y > 0 /\ y <> x) }}
  split entry size cptr sz
  {{ fun s h => exists l, In_hl l (x,sizex,alloc) adr /\
     (exists y, y > 0 /\ (s |b= var_e entry == nat_e y) /\
       (exists size'', size'' >= size /\
         (Heap_List l adr ** Array (y+2) size'') s h /\
         In_hl l (y,size'',alloc) adr /\ y <> x)) }}.

Lemma split_verif : split_specif.





















Definition hmAlloc_specif := forall adr x sizex size,
  adr > 0 -> size > 0 ->
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x,sizex,alloc) adr /\
     (s |b= var_e hmStart == nat_e adr) }}
  hmAlloc result size entry cptr fnd stts nptr sz
  {{ fun s h =>
     (exists l, exists y, y > 0 /\ (s |b= var_e result == nat_e (y+2)) /\
      exists size'', size'' >= size /\
      (Heap_List l adr ** Array (y + 2) size'') s h /\
      In_hl l (x,sizex,alloc) adr /\ In_hl l (y,size'',alloc) adr /\
      x <> y)
     \/
     (exists l, (s |b= var_e result == nat_e 0) /\
       Heap_List l adr s h /\ In_hl l (x,sizex,alloc) adr) }}.

Lemma hmAlloc_verif: hmAlloc_specif.





Eval_b_hyp H8.







Eval_b_hyp H9.