Require Import AutoSep Malloc Bags ThreadQueue ThreadQueues SinglyLinkedList MoreArrays.
Import W_Bag.
Export AutoSep Malloc W_Bag.

Module Type S.
  Parameter globalSched : W.

  Parameter globalInv : bag -> HProp.
  (* Argument is set of available file objects. *)
End S.

Section specs.
  Variable globalSched : W.
  Variables sched globalInv : bag -> HProp.
  Variable starting : W -> nat -> HProp.

  Definition initGS : spec := SPEC reserving 18
    PRE[_] globalSched =?> 1 * mallocHeap 0
    POST[R] sched empty * mallocHeap 0.

  Definition spawnGS : spec := SPEC("pc", "ss") reserving 26
    Al fs,
    PRE[V] [| V "ss" >= $2 |] * sched fs * starting (V "pc") (wordToNat (V "ss") - 1) * mallocHeap 0
    POST[_] sched fs * mallocHeap 0.

  Definition exitGS : spec := SPEC("ss") reserving 18
    Al fs,
    PREexit[V] [| V "ss" >= $18 |] * sched fs * globalInv fs * mallocHeap 0.

  Definition yieldGS : spec := SPEC reserving 28
    Al fs,
    PRE[_] sched fs * globalInv fs * mallocHeap 0
    POST[_] Ex fs', [| fs %<= fs' |] * sched fs' * globalInv fs' * mallocHeap 0.

  Definition listenGS : spec := SPEC("port") reserving 25
    Al fs,
    PRE[_] sched fs * mallocHeap 0
    POST[R] Ex fs', [| fs %<= fs' |] * sched fs' * mallocHeap 0 * [| R %in fs' |].

  Definition closeGS : spec := SPEC("fr") reserving 11
    Al fs,
    PRE[V] [| V "fr" %in fs |] * sched fs * mallocHeap 0
    POST[_] sched fs * mallocHeap 0.

  Definition readGS : spec := SPEC("fr", "buffer", "size") reserving 32
    Al fs,
    PRE[V] [| V "fr" %in fs |] * V "buffer" =?>8 wordToNat (V "size") * sched fs * mallocHeap 0 * globalInv fs
    POST[_] Ex fs', [| fs %<= fs' |] * V "buffer" =?>8 wordToNat (V "size") * sched fs' * mallocHeap 0 * globalInv fs'.

  Definition writeGS : spec := SPEC("fr", "buffer", "size") reserving 32
    Al fs,
    PRE[V] [| V "fr" %in fs |] * V "buffer" =?>8 wordToNat (V "size") * sched fs * mallocHeap 0 * globalInv fs
    POST[_] Ex fs', [| fs %<= fs' |] * V "buffer" =?>8 wordToNat (V "size") * sched fs' * mallocHeap 0 * globalInv fs'.

  Definition acceptGS : spec := SPEC("fr") reserving 32
    Al fs,
    PRE[V] [| V "fr" %in fs |] * sched fs * mallocHeap 0 * globalInv fs
    POST[R] Ex fs', Ex fs'', [| fs %<= fs' |] * [| fs' %<= fs'' |]
    * [| R %in fs'' |] * sched fs'' * mallocHeap 0 * globalInv fs'.
End specs.

Module Make(M : S).
Import M.

Definition allIn (b : bag) := List.Forall (fun p => p %in b).
Definition allInOrZero (b : bag) := List.Forall (fun p => p = $0 \/ p %in b).

Definition files (ts : bag) : bag -> HProp :=
  starB (fun p => Ex fd, Ex inq, Ex outq, (p ==*> fd, inq, outq) * [| inq %in ts |] * [| outq %in ts |])%Sep.

Module M''.
  Definition world := bag.

  Definition evolve : bag -> bag -> Prop := incl.

  Theorem evolve_refl : forall w, evolve w w.
    red; bags.
  Qed.

  Theorem evolve_trans : forall w1 w2 w3, evolve w1 w2 -> evolve w2 w3 -> evolve w1 w3.
    unfold evolve in *; bags.
  Qed.

  Open Scope Sep_scope.

  Definition globalInv (ts : bag) (w : world) : HProp :=
    Ex p, Ex ready, Ex free, Ex wait, Ex waitLen, Ex freeL, Ex waitL,

    (* The scheduler entry point *)
    globalSched =*> p * (p ==*> ready, free, wait, waitLen)

    (* The ready queue is a valid thread queue, for threads ready to run immediately. *)
    * [| ready %in ts |]

    (* The free list stores available file pointers. *)
    * sll freeL free * [| allIn w freeL |]

    (* Each available file pointer stores a record of a file descriptor and input/output thread queues. *)
    * files ts w

    (* There is an array correspoinding to outstanding declare() calls, mapping each to a queue that should be poked when its event is enabled. *)
    * array waitL wait * [| allInOrZero ts waitL |]
      * [| length waitL = wordToNat waitLen |]
      * [| wait <> 0 |] * [| freeable wait (length waitL) |]

    (* Finally, the application-specific global invariant holds. *)
    * globalInv w.
End M''.

Module Q' := ThreadQueues.Make(M'').
Import M'' Q'.
Export M'' Q'.

Definition files_pick (_ : W) := files.

Module Type SCHED.
  Parameter sched : bag -> HProp.
  (* Parameter is available file pointers. *)

  Axiom sched_fwd : forall fs, sched fs ===>
    Ex ts, Ex p, globalSched =*> p
    * Ex ready, Ex free, Ex wait, Ex waitLen, (p ==*> ready, free, wait, waitLen)
    * [| ready %in ts |]
    * Ex freeL, sll freeL free * [| allIn fs freeL |]
    * files ts fs
    * Ex waitL, array waitL wait * [| allInOrZero ts waitL |] * [| length waitL = wordToNat waitLen |]
      * [| wait <> 0 |] * [| freeable wait (length waitL) |]
    * tqs ts fs.

  Axiom sched_bwd : forall fs,
    (Ex ts, Ex p, globalSched =*> p
     * Ex ready, Ex free, Ex wait, Ex waitLen, (p ==*> ready, free, wait, waitLen)
     * [| ready %in ts |]
     * Ex freeL, sll freeL free * [| allIn fs freeL |]
     * files ts fs
     * Ex waitL, array waitL wait * [| allInOrZero ts waitL |] * [| length waitL = wordToNat waitLen |]
       * [| wait <> 0 |] * [| freeable wait (length waitL) |]
     * tqs ts fs)
    ===> sched fs.

  Axiom files_empty_fwd : forall ts, files ts empty ===> Emp.
  Axiom files_empty_bwd : forall ts, Emp ===> files ts empty.

  Axiom files_pick_fwd : forall p ts fs, p %in fs
    -> files_pick p ts fs ===> Ex fd, Ex inq, Ex outq, (p ==*> fd, inq, outq)
      * [| inq %in ts |] * [| outq %in ts |] * files ts (fs %- p).
  Axiom files_pick_bwd : forall p ts fs, p %in fs
    -> (Ex fd, Ex inq, Ex outq, (p ==*> fd, inq, outq)
      * [| inq %in ts |] * [| outq %in ts |] * files ts (fs %- p)) ===> files_pick p ts fs.

  Axiom files_add_bwd : forall p ts fs,
    (Ex fd, Ex inq, Ex outq, (p ==*> fd, inq, outq)
      * [| inq %in ts |] * [| outq %in ts |] * files ts fs) ===> files ts (fs %+ p).
End SCHED.

Module Sched : SCHED.
  Open Scope Sep_scope.

  Definition sched fs :=
    Ex ts, Ex p, globalSched =*> p
    * Ex ready, Ex free, Ex wait, Ex waitLen, (p ==*> ready, free, wait, waitLen)
    * [| ready %in ts |]
    * Ex freeL, sll freeL free * [| allIn fs freeL |]
    * files ts fs
    * Ex waitL, array waitL wait * [| allInOrZero ts waitL |] * [| length waitL = wordToNat waitLen |]
      * [| wait <> 0 |] * [| freeable wait (length waitL) |]
    * tqs ts fs.

  Theorem sched_fwd : forall fs, sched fs ===>
    Ex ts, Ex p, globalSched =*> p
    * Ex ready, Ex free, Ex wait, Ex waitLen, (p ==*> ready, free, wait, waitLen)
    * [| ready %in ts |]
    * Ex freeL, sll freeL free * [| allIn fs freeL |]
    * files ts fs
    * Ex waitL, array waitL wait * [| allInOrZero ts waitL |] * [| length waitL = wordToNat waitLen |]
      * [| wait <> 0 |] * [| freeable wait (length waitL) |]
    * tqs ts fs.
    intros; apply Himp_refl.
  Qed.

  Theorem sched_bwd : forall fs,
    (Ex ts, Ex p, globalSched =*> p
     * Ex ready, Ex free, Ex wait, Ex waitLen, (p ==*> ready, free, wait, waitLen)
     * [| ready %in ts |]
     * Ex freeL, sll freeL free * [| allIn fs freeL |]
     * files ts fs
     * Ex waitL, array waitL wait * [| allInOrZero ts waitL |] * [| length waitL = wordToNat waitLen |]
       * [| wait <> 0 |] * [| freeable wait (length waitL) |]
     * tqs ts fs)
     ===> sched fs.
    intros; apply Himp_refl.
  Qed.

  Theorem files_empty_fwd : forall ts, files ts empty ===> Emp.
    intros; apply starB_empty_fwd.
  Qed.

  Theorem files_empty_bwd : forall ts, Emp ===> files ts empty.
    intros; apply starB_empty_bwd.
  Qed.

  Ltac fin ts := match goal with
                   | [ |- context[starB ?X ?Y] ] => change (starB X Y) with (files ts Y)
                 end; sepLemma.

  Theorem files_pick_fwd : forall p ts fs, p %in fs
    -> files_pick p ts fs ===> Ex fd, Ex inq, Ex outq, (p ==*> fd, inq, outq)
      * [| inq %in ts |] * [| outq %in ts |] * files ts (fs %- p).
    intros; eapply Himp_trans; [ apply starB_del_fwd | ]; eauto; fin ts.
  Qed.

  Theorem files_pick_bwd : forall p ts fs, p %in fs
    -> (Ex fd, Ex inq, Ex outq, (p ==*> fd, inq, outq)
      * [| inq %in ts |] * [| outq %in ts |] * files ts (fs %- p)) ===> files_pick p ts fs.
    intros; eapply Himp_trans; [ | apply starB_del_bwd ]; eauto; fin ts.
  Qed.

  Theorem files_add_bwd : forall p ts fs,
    (Ex fd, Ex inq, Ex outq, (p ==*> fd, inq, outq)
      * [| inq %in ts |] * [| outq %in ts |] * files ts fs) ===> files ts (fs %+ p).
    intros; eapply Himp_trans; [ | apply starB_add_bwd ]; fin ts.
  Qed.
End Sched.

Import Sched.
Export Sched.

Definition exitize_me a b c d := locals a b c d.

Lemma exitize_locals : forall xx yy ns vs res sp,
  exitize_me ("rp" :: xx :: yy :: ns) vs res sp ===> Ex vs', locals ("rp" :: "sc" :: "ss" :: nil) (upd (upd vs' "ss" (sel vs yy)) "sc" (sel vs xx)) (res + length ns) sp.
  unfold exitize_me, locals; intros.
  simpl; unfold upd; simpl.
  apply Himp_ex_c; exists (fun x => if string_dec x "rp" then vs "rp" else vs xx).
  eapply Himp_trans.
  eapply Himp_star_frame.
  eapply Himp_star_frame.
  apply Himp_refl.
  change (vs "rp" :: vs xx :: vs yy :: toArray ns vs)
    with (toArray (("rp" :: xx :: yy :: nil) ++ ns) vs).
  apply ptsto32m_split.
  apply Himp_refl.
  destruct (string_dec "rp" "rp"); intuition.
  destruct (string_dec "sc" "rp"); intuition.
  unfold array, toArray in *.
  simpl map in *.
  simpl length in *.

  Lemma switchedy : forall P Q R S : HProp,
    (P * (Q * R)) * S ===> P * (Q * (R * S)).
    sepLemma.
  Qed.

  eapply Himp_trans; [ apply switchedy | ].

  Lemma swatchedy : forall P Q R : HProp,
    P * (Q * R) ===> P * Q * R.
    sepLemma.
  Qed.

  eapply Himp_trans; [ | apply swatchedy ].
  apply Himp_star_frame.
  sepLemma; NoDup.
  apply Himp_star_frame.
  apply Himp_refl.
  eapply Himp_trans; [ | apply allocated_join ].
  apply Himp_star_frame.
  eapply Himp_trans; [ | apply allocated_shift_base ].
  apply ptsto32m_allocated.
  simpl.
  words.
  eauto.
  apply allocated_shift_base.
  rewrite map_length.
  repeat rewrite <- wplus_assoc.
  repeat rewrite <- natToW_plus.
  f_equal.
  f_equal.
  omega.
  rewrite map_length; omega.
  rewrite map_length; omega.
Qed.

Definition hints : TacPackage.
  prepare (sched_fwd, SinglyLinkedList.nil_fwd, SinglyLinkedList.cons_fwd, allocate_array,
    files_empty_fwd, files_pick_fwd, exitize_locals)
  (sched_bwd, SinglyLinkedList.nil_bwd, SinglyLinkedList.cons_bwd, free_array, tqs_empty_bwd,
    files_empty_bwd, files_pick_bwd, files_add_bwd).
Defined.

Definition starting (pc : W) (ss : nat) : HProp := fun s m =>
  (ExX (* pre *) : settings * state, Cptr pc #0
    /\ [| semp m |]
    /\ Al st : settings * state, Al vs, Al fs,
    [| st#Sp <> 0 /\ freeable st#Sp (1 + ss) |]
    /\ ![ ^[locals ("rp" :: nil) vs ss st#Sp * sched fs * M.globalInv fs * mallocHeap 0] ] st
    ---> #0 st)%PropX.

Lemma starting_elim : forall specs pc ss P stn st,
  interp specs (![ starting pc ss * P ] (stn, st))
  -> (exists pre, specs pc = Some (fun x => pre x)
    /\ interp specs (![ P ] (stn, st))
    /\ forall stn_st vs fs, interp specs ([| stn_st#Sp <> 0 /\ freeable stn_st#Sp (1 + ss) |]
      /\ ![ locals ("rp" :: nil) vs ss stn_st#Sp
      * sched fs * M.globalInv fs * mallocHeap 0 ] stn_st
    ---> pre stn_st)%PropX).
  cptr.
  generalize (split_semp _ _ _ H0 H); intros; subst; auto.
  rewrite <- sepFormula_eq; descend; step auto_ext.
  auto.
  step auto_ext.
Qed.

Local Hint Resolve split_a_semp_a semp_smem_emp.

Lemma starting_intro : forall specs pc ss P stn st,
  (exists pre, specs pc = Some (fun x => pre x)
    /\ interp specs (![ P ] (stn, st))
    /\ forall stn_st vs fs, interp specs ([| stn_st#Sp <> 0 /\ freeable stn_st#Sp (1 + ss) |]
      /\ ![ locals ("rp" :: nil) vs ss stn_st#Sp
      * sched fs * M.globalInv fs * mallocHeap 0 ] stn_st
    ---> pre stn_st)%PropX)
  -> interp specs (![ starting pc ss * P ] (stn, st)).
  cptr.
Qed.

Lemma other_starting_intro : forall specs ts w pc ss P stn st,
  (exists pre, specs pc = Some (fun x => pre x)
    /\ interp specs (![ P ] (stn, st))
    /\ forall stn_st vs ts' w', interp specs ([| ts %<= ts' |]
      /\ [| M''.evolve w w' |]
      /\ [| stn_st#Sp <> 0 /\ freeable stn_st#Sp (1 + ss) |]
      /\ ![ locals ("rp" :: nil) vs ss stn_st#Sp
      * tqs ts' w' * M''.globalInv ts' w' * mallocHeap 0 ] stn_st
    ---> pre stn_st)%PropX)
  -> interp specs (![ Q'.starting ts w pc ss * P ] (stn, st)).
  cptr.
Qed.

Definition initS := initGS globalSched sched.
Definition spawnS := spawnGS sched starting.
Definition exitS := exitGS sched M.globalInv.
Definition yieldS := yieldGS sched M.globalInv.
Definition listenS := listenGS sched.
Definition closeS := closeGS sched.
Definition readS := readGS sched M.globalInv.
Definition writeS := writeGS sched M.globalInv.
Definition acceptS := acceptGS sched M.globalInv.

(* Specs below this point are for "private" functions. *)

Definition pickNextS : spec := SPEC reserving 13
  Al p, Al ready, Al free, Al wait, Al waitLen, Al ts, Al fs, Al waitL,
  PRE[_] globalSched =*> p * (p ==*> ready, free, wait, waitLen)
    * tqs ts fs * [| ready %in ts |]
    * array waitL wait * [| allInOrZero ts waitL |]
    * [| length waitL = wordToNat waitLen |] * mallocHeap 0
  POST[R] [| R %in ts |]
    * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
    * tqs ts fs * [| ready %in ts |]
    * array waitL wait * [| allInOrZero ts waitL |]
    * [| length waitL = wordToNat waitLen |] * mallocHeap 0.

Definition newS : spec := SPEC("fd") reserving 21
  Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL,
  PRE[V] globalSched =*> p * (p ==*> ready, free, wait, waitLen)
    * sll freeL free * [| allIn fs freeL |]
    * files ts fs * tqs ts fs * mallocHeap 0
  POST[R] Ex ts', Ex fs', Ex free', Ex freeL',
    [| R %in fs' |] * [| ts %<= ts' |] * [| fs %<= fs' |]
    * globalSched =*> p * (p ==*> ready, free', wait, waitLen)
    * sll freeL' free' * [| allIn fs' freeL' |]
    * files ts' fs' * tqs ts' fs' * mallocHeap 0.

Definition declareS : spec := SPEC("tq", "fd", "mode") reserving 16
    Al ts, Al p, Al ready, Al free, Al wait, Al waitLen, Al waitL,
    PRE[V] [| V "tq" %in ts |] * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
      * array waitL wait * [| allInOrZero ts waitL |]
      * [| length waitL = wordToNat waitLen |]
      * [| wait <> 0 |] * [| freeable wait (length waitL) |]
      * mallocHeap 0
    POST[_] Ex wait', Ex waitLen', Ex waitL',
      globalSched =*> p * (p ==*> ready, free, wait', waitLen')
      * array waitL' wait' * [| allInOrZero ts waitL' |]
      * [| length waitL' = wordToNat waitLen' |]
      * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
      * mallocHeap 0.

Definition blockS : spec := SPEC("tq", "fd", "mode") reserving 26
  Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
  PRE[V] [| V "tq" %in ts |]
    * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
    * [| ready %in ts |]
    * sll freeL free * [| allIn fs freeL |]
    * files ts fs * tqs ts fs
    * array waitL wait * [| allInOrZero ts waitL |]
      * [| length waitL = wordToNat waitLen |]
      * [| wait <> 0 |] * [| freeable wait (length waitL) |]
    * M.globalInv fs * mallocHeap 0
  POST[_] Ex p', Ex ts', Ex fs', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
    [| ts %<= ts' |] * [| fs %<= fs' |]
    * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
    * [| ready' %in ts' |]
    * sll freeL' free' * [| allIn fs' freeL' |]
    * files ts' fs' * tqs ts' fs'
    * array waitL' wait' * [| allInOrZero ts' waitL' |]
      * [| length waitL' = wordToNat waitLen' |]
      * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
    * M.globalInv fs' * mallocHeap 0.

Definition initSize := 2.

Theorem initSize_eq : initSize = 2.
  auto.
Qed.

Opaque initSize.

Inductive add_a_file : Prop := AddAFile.
Inductive reveal_files_pick : Prop := RevealFilesPick.
Local Hint Constructors add_a_file reveal_files_pick.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS],
                           "threadqs"!"alloc" @ [Q'.allocS], "threadqs"!"spawn" @ [Q'.spawnS],
                           "threadqs"!"exit" @ [Q'.exitS], "threadqs"!"yield" @ [Q'.yieldS],
                           "threadqs"!"isEmpty" @ [Q'.isEmptyS],

                           "sys"!"abort" @ [abortS], "sys"!"close" @ [Sys.closeS],
                           "sys"!"listen" @ [Sys.listenS], "sys"!"accept" @ [Sys.acceptS],
                           "sys"!"read" @ [Sys.readS], "sys"!"write" @ [Sys.writeS],
                           "sys"!"declare" @ [Sys.declareS], "sys"!"wait" @ [Sys.waitS] ]]
  bmodule "scheduler" {{
    bfunction "init"("root", "ready", "wait") [initS]
      "root" <-- Call "malloc"!"malloc"(0, 4)
      [PRE[_, R] globalSched =?> 1 * R =?> 4 * mallocHeap 0
       POST[_] sched empty * mallocHeap 0];;

      globalSched *<- "root";;

      Assert [PRE[V] globalSched =*> V "root" * V "root" =?> 4 * mallocHeap 0 * tqs empty empty
        POST[_] sched empty * mallocHeap 0];;

      "ready" <-- Call "threadqs"!"alloc"()
      [PRE[V, R] globalSched =*> V "root" * V "root" =?> 4 * tqs (empty %+ R) empty * mallocHeap 0
       POST[_] sched empty * mallocHeap 0];;

      "wait" <-- Call "malloc"!"malloc"(0, initSize)
      [PRE[V, R] R =?> initSize * [| R <> 0 |] * [| freeable R initSize |]
         * globalSched =*> V "root" * V "root" =?> 4
         * tqs (empty %+ V "ready") empty
       POST[_] sched empty];;

      Note [make_array];;

      Assert [Al waitL,
        PRE[V] array waitL (V "wait") * [| length waitL = 2 |] * [| V "wait" <> 0 |] * [| freeable (V "wait") 2 |]
          * [| ($0 < natToW (length waitL))%word |]
          * globalSched =*> V "root" * V "root" =?> 4 * tqs (empty %+ V "ready") empty
        POST[_] sched empty];;

      "wait"+0 *<- 0;;

      Assert [Al waitL,
        PRE[V] array waitL (V "wait") * [| length waitL = 2 |] * [| V "wait" <> 0 |] * [| freeable (V "wait") 2 |]
          * [| ($1 < natToW (length waitL))%word |] * [| Array.selN waitL 0 = $0 |]
          * globalSched =*> V "root" * V "root" =?> 4 * tqs (empty %+ V "ready") empty
        POST[_] sched empty];;

      "wait"+4 *<- 0;;

      "root" *<- "ready";;
      "root"+4 *<- 0;;
      "root"+8 *<- "wait";;
      "root"+12 *<- 2;;
      Return 0
    end with bfunction "spawn"("pc", "ss", "root") [spawnS]
      "root" <-* globalSched;;
      "root" <-* "root";;

      Call "threadqs"!"spawn"("root", "pc", "ss")
      [PRE[_] Emp
       POST[_] Emp];;
      Return 0
    end with bfunctionNoRet "exit"("ss", "tq", "tmp") [exitS]
      "tq" <-- Call "scheduler"!"pickNext"()
      [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
        PREexit[V, R] globalSched =*> p * (p ==*> ready, free, wait, waitLen)
          * [| ready %in ts |] * [| R %in ts |] * [| (V "ss" >= $18)%word |]
          * sll freeL free * [| allIn fs freeL |]
          * files ts fs
          * array waitL wait * [| allInOrZero ts waitL |]
          * [| length waitL = wordToNat waitLen |]
          * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * tqs ts fs * M.globalInv fs * mallocHeap 0 ];;

      "tmp" <- "ss";;
      "ss" <- "tq";;
      "tq" <- "tmp";;
      Goto "threadqs"!"exit"
    end with bfunction "yield"("root", "ready", "q") [yieldS]
      "root" <-* globalSched;;
      "ready" <-* "root";;

      "q" <-- Call "scheduler"!"pickNext"()
      [Al ts, Al fs, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
        PRE[V, R] globalSched =*> V "root" * (V "root" ==*> V "ready", free, wait, waitLen)
          * [| V "ready" %in ts |] * [| R %in ts |]
          * sll freeL free * [| allIn fs freeL |]
          * files ts fs
          * array waitL wait * [| allInOrZero ts waitL |]
          * [| length waitL = wordToNat waitLen |]
          * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * tqs ts fs * M.globalInv fs * mallocHeap 0
        POST[_] Ex ts', Ex fs', Ex p, Ex ready, Ex free, Ex wait, Ex waitLen, Ex freeL, Ex waitL,
          [| ts %<= ts' |] * [| fs %<= fs' |]
          * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
          * [| ready %in ts' |]
          * sll freeL free * [| allIn fs' freeL |]
          * files ts' fs'
          * array waitL wait * [| allInOrZero ts' waitL |]
          * [| length waitL = wordToNat waitLen |]
          * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * tqs ts' fs' * M.globalInv fs' * mallocHeap 0 ];;

      Call "threadqs"!"yield"("ready", "q")
      [PRE[_] Emp
       POST[_] Emp];;
      Return 0
    end with bfunction "listen"("port", "fd", "fr") [listenS]
      "fd" <-- Call "sys"!"listen"("port")
      [Al fs,
        PRE[_] sched fs * mallocHeap 0
        POST[R] Ex fs', [| fs %<= fs' |] * sched fs' * mallocHeap 0 * [| R %in fs' |] ];;

      "fr" <-- Call "scheduler"!"new"("fd")
      [PRE[_, R] Emp
       POST[R'] [| R' = R |] ];;
      Return "fr"
    end with bfunction "close"("fr", "root", "free", "fd", "node") [closeS]
      "root" <-* globalSched;;
      "free" <-* "root"+4;;

      Note [reveal_files_pick];;

      Assert [Al ts, Al fs, Al ready, Al wait, Al waitLen, Al freeL,
        PRE[V] globalSched =*> V "root" * (V "root" ==*> ready, V "free", wait, waitLen)
          * sll freeL (V "free") * [| allIn fs freeL |]
          * files_pick (V "fr") ts fs * mallocHeap 0
          * [| V "fr" %in fs |]
        POST[_] Ex free', Ex freeL',
          globalSched =*> V "root" * (V "root" ==*> ready, free', wait, waitLen)
          * sll freeL' free' * [| allIn fs freeL' |]
          * files_pick (V "fr") ts fs * mallocHeap 0];;

      "fd" <-* "fr";;
      Call "sys"!"close"("fd")
      [Al fs, Al ready, Al wait, Al waitLen, Al freeL, Al fd, Al inq, Al outq,
        PRE[V] globalSched =*> V "root" * (V "root" ==*> ready, V "free", wait, waitLen)
          * sll freeL (V "free") * [| allIn fs freeL |]
          * (V "fr" ==*> fd, inq, outq) * mallocHeap 0
          * [| V "fr" %in fs |]
        POST[_] Ex free', Ex freeL',
          globalSched =*> V "root" * (V "root" ==*> ready, free', wait, waitLen)
          * sll freeL' free' * [| allIn fs freeL' |]
          * (V "fr" ==*> fd, inq, outq) * mallocHeap 0];;

      "node" <-- Call "malloc"!"malloc"(0, 2)
      [Al fs, Al ready, Al wait, Al waitLen, Al freeL,
        PRE[V, R] R =?> 2 * [| R <> 0 |] * [| freeable R 2 |]
          * globalSched =*> V "root" * (V "root" ==*> ready, V "free", wait, waitLen)
          * sll freeL (V "free") * [| allIn fs freeL |]
          * [| V "fr" %in fs |]
        POST[_] Ex free', Ex freeL',
          globalSched =*> V "root" * (V "root" ==*> ready, free', wait, waitLen)
          * sll freeL' free' * [| allIn fs freeL' |] ];;

      "node" *<- "fr";;
      "node"+4 *<- "free";;
      "root"+4 *<- "node";;
      Return 0
    end with bfunction "read"("fr", "buffer", "size", "fd", "tq") [readS]
      Note [reveal_files_pick];;

      Assert [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
        PRE[V] [| V "fr" %in fs |] * V "buffer" =?>8 wordToNat (V "size")
          * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
          * [| ready %in ts |]
          * sll freeL free * [| allIn fs freeL |]
          * files_pick (V "fr") ts fs * tqs ts fs
          * array waitL wait * [| allInOrZero ts waitL |]
            * [| length waitL = wordToNat waitLen |]
            * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * M.globalInv fs * mallocHeap 0
        POST[_] Ex p', Ex ts', Ex fs', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
          [| ts %<= ts' |] * [| fs %<= fs' |] * V "buffer" =?>8 wordToNat (V "size")
          * [| V "fr" %in fs' |]
          * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
          * [| ready' %in ts' |]
          * sll freeL' free' * [| allIn fs' freeL' |]
          * files ts' fs' * tqs ts' fs'
          * array waitL' wait' * [| allInOrZero ts' waitL' |]
            * [| length waitL' = wordToNat waitLen' |]
            * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
          * M.globalInv fs' * mallocHeap 0];;

      "fd" <-* "fr";;
      "tq" <-* "fr"+4;;

      Assert [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
        PRE[V] [| V "tq" %in ts |] * [| V "fr" %in fs |] * V "buffer" =?>8 wordToNat (V "size")
          * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
          * [| ready %in ts |]
          * sll freeL free * [| allIn fs freeL |]
          * files_pick (V "fr") ts fs * tqs ts fs
          * array waitL wait * [| allInOrZero ts waitL |]
            * [| length waitL = wordToNat waitLen |]
            * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * M.globalInv fs * mallocHeap 0
        POST[_] Ex p', Ex ts', Ex fs', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
          [| ts %<= ts' |] * [| fs %<= fs' |] * V "buffer" =?>8 wordToNat (V "size")
          * [| V "fr" %in fs' |]
          * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
          * [| ready' %in ts' |]
          * sll freeL' free' * [| allIn fs' freeL' |]
          * files ts' fs' * tqs ts' fs'
          * array waitL' wait' * [| allInOrZero ts' waitL' |]
            * [| length waitL' = wordToNat waitLen' |]
            * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
          * M.globalInv fs' * mallocHeap 0];;

      Note [reveal_files_pick];;

      Call "scheduler"!"block"("tq", "fd", 0)
      [PRE[V] V "buffer" =?>8 wordToNat (V "size")
       POST[_] V "buffer" =?>8 wordToNat (V "size")];;

      "size" <-- Call "sys"!"read"("fd", "buffer", "size")
      [PRE[_] Emp
       POST[_] Emp ];;
      Return "size"
    end with bfunction "write"("fr", "buffer", "size", "fd", "tq") [writeS]
      Note [reveal_files_pick];;

      Assert [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
        PRE[V] [| V "fr" %in fs |] * V "buffer" =?>8 wordToNat (V "size")
          * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
          * [| ready %in ts |]
          * sll freeL free * [| allIn fs freeL |]
          * files_pick (V "fr") ts fs * tqs ts fs
          * array waitL wait * [| allInOrZero ts waitL |]
            * [| length waitL = wordToNat waitLen |]
            * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * M.globalInv fs * mallocHeap 0
        POST[_] Ex p', Ex ts', Ex fs', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
          [| ts %<= ts' |] * [| fs %<= fs' |] * V "buffer" =?>8 wordToNat (V "size")
          * [| V "fr" %in fs' |]
          * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
          * [| ready' %in ts' |]
          * sll freeL' free' * [| allIn fs' freeL' |]
          * files ts' fs' * tqs ts' fs'
          * array waitL' wait' * [| allInOrZero ts' waitL' |]
            * [| length waitL' = wordToNat waitLen' |]
            * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
          * M.globalInv fs' * mallocHeap 0];;

      "fd" <-* "fr";;
      "tq" <-* "fr"+8;;

      Assert [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
        PRE[V] [| V "tq" %in ts |] * [| V "fr" %in fs |] * V "buffer" =?>8 wordToNat (V "size")
          * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
          * [| ready %in ts |]
          * sll freeL free * [| allIn fs freeL |]
          * files_pick (V "fr") ts fs * tqs ts fs
          * array waitL wait * [| allInOrZero ts waitL |]
            * [| length waitL = wordToNat waitLen |]
            * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * M.globalInv fs * mallocHeap 0
        POST[_] Ex p', Ex ts', Ex fs', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
          [| ts %<= ts' |] * [| fs %<= fs' |] * V "buffer" =?>8 wordToNat (V "size")
          * [| V "fr" %in fs' |]
          * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
          * [| ready' %in ts' |]
          * sll freeL' free' * [| allIn fs' freeL' |]
          * files ts' fs' * tqs ts' fs'
          * array waitL' wait' * [| allInOrZero ts' waitL' |]
            * [| length waitL' = wordToNat waitLen' |]
            * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
          * M.globalInv fs' * mallocHeap 0];;

      Note [reveal_files_pick];;

      Call "scheduler"!"block"("tq", "fd", 1)
      [PRE[V] V "buffer" =?>8 wordToNat (V "size")
       POST[_] V "buffer" =?>8 wordToNat (V "size")];;

      "size" <-- Call "sys"!"write"("fd", "buffer", "size")
      [PRE[_] Emp
       POST[_] Emp ];;
      Return "size"
    end with bfunction "accept"("fr", "fd", "tq") [acceptS]
      Note [reveal_files_pick];;

      Assert [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
        PRE[V] [| V "fr" %in fs |]
          * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
          * [| ready %in ts |]
          * sll freeL free * [| allIn fs freeL |]
          * files_pick (V "fr") ts fs * tqs ts fs
          * array waitL wait * [| allInOrZero ts waitL |]
            * [| length waitL = wordToNat waitLen |]
            * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * M.globalInv fs * mallocHeap 0
        POST[R] Ex p', Ex ts', Ex fs', Ex fs'', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
          [| ts %<= ts' |] * [| fs %<= fs' |] * [| fs' %<= fs'' |]
          * [| V "fr" %in fs'' |] * [| R %in fs'' |]
          * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
          * [| ready' %in ts' |]
          * sll freeL' free' * [| allIn fs'' freeL' |]
          * files ts' fs'' * tqs ts' fs''
          * array waitL' wait' * [| allInOrZero ts' waitL' |]
            * [| length waitL' = wordToNat waitLen' |]
            * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
          * M.globalInv fs' * mallocHeap 0];;

      "fd" <-* "fr";;
      "tq" <-* "fr"+4;;

      Assert [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
        PRE[V] [| V "tq" %in ts |] * [| V "fr" %in fs |]
          * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
          * [| ready %in ts |]
          * sll freeL free * [| allIn fs freeL |]
          * files_pick (V "fr") ts fs * tqs ts fs
          * array waitL wait * [| allInOrZero ts waitL |]
            * [| length waitL = wordToNat waitLen |]
            * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * M.globalInv fs * mallocHeap 0
        POST[R] Ex p', Ex ts', Ex fs', Ex fs'', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
          [| ts %<= ts' |] * [| fs %<= fs' |] * [| fs' %<= fs'' |]
          * [| V "fr" %in fs'' |] * [| R %in fs'' |]
          * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
          * [| ready' %in ts' |]
          * sll freeL' free' * [| allIn fs'' freeL' |]
          * files ts' fs'' * tqs ts' fs''
          * array waitL' wait' * [| allInOrZero ts' waitL' |]
            * [| length waitL' = wordToNat waitLen' |]
            * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
          * M.globalInv fs' * mallocHeap 0];;

      Note [reveal_files_pick];;

      Call "scheduler"!"block"("tq", "fd", 0)
      [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
        PRE[V] [| V "tq" %in ts |] * [| V "fr" %in fs |]
          * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
          * [| ready %in ts |]
          * sll freeL free * [| allIn fs freeL |]
          * files ts fs * tqs ts fs
          * array waitL wait * [| allInOrZero ts waitL |]
            * [| length waitL = wordToNat waitLen |]
            * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * M.globalInv fs * mallocHeap 0
        POST[R] Ex p', Ex ts', Ex fs', Ex fs'', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
          [| ts %<= ts' |] * [| fs %<= fs' |] * [| fs' %<= fs'' |]
          * [| V "fr" %in fs'' |] * [| R %in fs'' |]
          * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
          * [| ready' %in ts' |]
          * sll freeL' free' * [| allIn fs'' freeL' |]
          * files ts' fs'' * tqs ts' fs''
          * array waitL' wait' * [| allInOrZero ts' waitL' |]
            * [| length waitL' = wordToNat waitLen' |]
            * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
          * M.globalInv fs' * mallocHeap 0];;

      "fd" <-- Call "sys"!"accept"("fd")
      [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
        PRE[V] [| V "tq" %in ts |] * [| V "fr" %in fs |]
          * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
          * [| ready %in ts |]
          * sll freeL free * [| allIn fs freeL |]
          * files ts fs * tqs ts fs
          * array waitL wait * [| allInOrZero ts waitL |]
            * [| length waitL = wordToNat waitLen |]
            * [| wait <> 0 |] * [| freeable wait (length waitL) |]
          * M.globalInv fs * mallocHeap 0
        POST[R] Ex p', Ex ts', Ex fs', Ex fs'', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
          [| ts %<= ts' |] * [| fs %<= fs' |] * [| fs' %<= fs'' |]
          * [| V "fr" %in fs'' |] * [| R %in fs'' |]
          * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
          * [| ready' %in ts' |]
          * sll freeL' free' * [| allIn fs'' freeL' |]
          * files ts' fs'' * tqs ts' fs''
          * array waitL' wait' * [| allInOrZero ts' waitL' |]
            * [| length waitL' = wordToNat waitLen' |]
            * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
          * M.globalInv fs' * mallocHeap 0];;

      "fr" <-- Call "scheduler"!"new"("fd")
      [PRE[_, R] Emp
       POST[R'] [| R' = R |] ];;
      Return "fr"
    end with bfunction "pickNext"("root", "ready", "wait", "waitLen", "blocking", "n") [pickNextS]
      "root" <-* globalSched;;
      "ready" <-* "root";;

      "blocking" <-- Call "threadqs"!"isEmpty"("ready")
      [Al free, Al wait, Al waitLen, Al ts, Al fs, Al waitL,
        PRE[V] globalSched =*> V "root" * (V "root" ==*> V "ready", free, wait, waitLen)
          * tqs ts fs * [| V "ready" %in ts |]
          * array waitL wait * [| allInOrZero ts waitL |]
          * [| length waitL = wordToNat waitLen |]
        POST[R] [| R %in ts |]
          * tqs ts fs * globalSched =*> V "root" * (V "root" ==*> V "ready", free, wait, waitLen)
          * array waitL wait ];;

      "n" <-- Call "sys"!"wait"("blocking")
      [Al free, Al wait, Al waitLen, Al ts, Al waitL,
        PRE[V] globalSched =*> V "root" * (V "root" ==*> V "ready", free, wait, waitLen)
          * [| V "ready" %in ts |]
          * array waitL wait * [| allInOrZero ts waitL |]
          * [| length waitL = wordToNat waitLen |]
        POST[R] [| R %in ts |]
          * globalSched =*> V "root" * (V "root" ==*> V "ready", free, wait, waitLen)
          * array waitL wait ];;

      "wait" <-* "root"+8;;
      "waitLen" <-* "root"+12;;

      If ("n" < "waitLen") {
        Assert [Al free, Al ts, Al waitL,
          PRE[V] globalSched =*> V "root" * (V "root" ==*> V "ready", free, V "wait", V "waitLen")
          * [| V "ready" %in ts |] * [| allInOrZero ts waitL |]
          * array waitL (V "wait") * [| (V "n" < natToW (length waitL))%word |]
        POST[R] [| R %in ts |]
          * globalSched =*> V "root" * (V "root" ==*> V "ready", free, V "wait", V "waitLen")
          * array waitL (V "wait") ];;

        "n" <- 4 * "n";;
        "wait" <-* "wait" + "n";;

        If ("wait" = 0) {
          Call "sys"!"abort"()
          [PREonly[_] [| False |] ]
        } else {
          Return "wait"
        }
      } else {
        Return "ready"
      }
    end with bfunction "new"("fd", "root", "free", "oldFree", "fr", "inq", "outq") [newS]
      "root" <-* globalSched;;
      "free" <-* "root"+4;;

      If ("free" <> 0) {
        "oldFree" <- "free";;
        "fr" <-* "free";;
        "free" <-* "free"+4;;
        "root"+4 *<- "free";;

        Note [reveal_files_pick];;

        Call "malloc"!"free"(0, "oldFree", 2)
        [Al ts, Al fs,
          PRE[V] [| V "fr" %in fs |] * files_pick (V "fr") ts fs
          POST[R] [| R = V "fr" |] * files_pick (V "fr") ts fs];;

        "fr" *<- "fd";;
        Return "fr"
      } else {
        "inq" <-- Call "threadqs"!"alloc"()
        [Al ts, Al fs,
          PRE[V, R] files ts fs * tqs (ts %+ R) fs * mallocHeap 0
          POST[R'] Ex ts', Ex fs', [| R' %in fs' |] * [| ts %+ R %<= ts' |] * [| fs %<= fs' |]
            * files ts' fs' * tqs ts' fs' * mallocHeap 0];;

        "outq" <-- Call "threadqs"!"alloc"()
        [Al ts, Al fs,
          PRE[V, R] files ts fs * tqs (ts %+ V "inq" %+ R) fs * mallocHeap 0
          POST[R'] Ex ts', Ex fs', [| R' %in fs' |] * [| ts %+ V "inq" %+ R %<= ts' |] * [| fs %<= fs' |]
            * files ts' fs' * tqs ts' fs' * mallocHeap 0];;

        "fr" <-- Call "malloc"!"malloc"(0, 3)
        [Al ts, Al fs,
          PRE[V, R] R =?> 3 * files ts fs * tqs (ts %+ V "inq" %+ V "outq") fs
          POST[R'] Ex fs', [| fs %<= fs' |] * [| R' %in fs' |] * files (ts %+ V "inq" %+ V "outq") fs'
            * tqs (ts %+ V "inq" %+ V "outq") fs' ];;

        Note [add_a_file];;

        Assert [Al ts, Al fs,
          PRE[V] V "fr" =?> 3 * files ts fs
          POST[R] [| R = V "fr" |] * files (ts %+ V "inq" %+ V "outq") (fs %+ V "fr") ];;

        "fr" *<- "fd";;
        "fr"+4 *<- "inq";;
        "fr"+8 *<- "outq";;
        Return "fr"
      }
    end with bfunction "declare"("tq", "fd", "mode", "root", "wait", "waitLen", "n", "newWait", "newLen", "i", "j", "v") [declareS]
      "root" <-* globalSched;;
      "wait" <-* "root"+8;;
      "waitLen" <-* "root"+12;;

      "n" <-- Call "sys"!"declare"("fd", "mode")
      [Al ts, Al ready, Al free, Al waitL,
        PRE[V] [| V "tq" %in ts |] * (V "root" ==*> ready, free, V "wait", V "waitLen")
          * array waitL (V "wait") * [| allInOrZero ts waitL |]
          * [| length waitL = wordToNat (V "waitLen") |]
          * [| V "wait" <> 0 |] * [| freeable (V "wait") (length waitL) |]
          * mallocHeap 0
        POST[_] Ex wait', Ex waitLen', Ex waitL',
          (V "root" ==*> ready, free, wait', waitLen')
          * array waitL' wait' * [| allInOrZero ts waitL' |]
          * [| length waitL' = wordToNat waitLen' |]
          * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
          * mallocHeap 0];;

      If ("n" < "waitLen") {
        Assert [Al ts, Al ready, Al free, Al waitL,
          PRE[V] [| V "tq" %in ts |] * (V "root" ==*> ready, free, V "wait", V "waitLen")
            * array waitL (V "wait") * [| allInOrZero ts waitL |]
            * [| length waitL = wordToNat (V "waitLen") |]
            * [| V "wait" <> 0 |] * [| freeable (V "wait") (length waitL) |]
            * [| (V "n" < natToW (length waitL))%word |]
            * mallocHeap 0
          POST[_] Ex wait', Ex waitLen', Ex waitL',
            (V "root" ==*> ready, free, wait', waitLen')
            * array waitL' wait' * [| allInOrZero ts waitL' |]
            * [| length waitL' = wordToNat waitLen' |]
            * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
            * mallocHeap 0];;

        "n" <- 4 * "n";;
        "wait"+"n" *<- "tq";;
        Return 0
      } else {
        "newLen" <- "n" + 1;;

        If ("newLen" < 2) {
          (* This case should be impossible, following the intended API usage. *)
          Call "sys"!"abort"()
          [PREonly[_] [| False |] ]
        } else {
          "newWait" <-- Call "malloc"!"malloc"(0, "newLen")
          [Al ts, Al ready, Al free, Al waitL,
            PRE[V, R] [| V "tq" %in ts |] * (V "root" ==*> ready, free, V "wait", V "waitLen")
              * array waitL (V "wait") * [| allInOrZero ts waitL |]
              * [| length waitL = wordToNat (V "waitLen") |]
              * [| V "wait" <> 0 |] * [| freeable (V "wait") (length waitL) |]
              * R =?> wordToNat (V "newLen") * [| R <> 0 |] * [| freeable R (wordToNat (V "newLen")) |]
              * mallocHeap 0
            POST[_] Ex wait', Ex waitLen', Ex waitL',
              (V "root" ==*> ready, free, wait', waitLen')
              * array waitL' wait' * [| allInOrZero ts waitL' |]
              * [| length waitL' = wordToNat waitLen' |]
              * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
              * mallocHeap 0];;

          Note [make_array];;

          Assert [Al ts, Al ready, Al free, Al waitL, Al newL,
            PRE[V] [| V "tq" %in ts |] * (V "root" ==*> ready, free, V "wait", V "waitLen")
              * array waitL (V "wait") * [| allInOrZero ts waitL |]
              * [| length waitL = wordToNat (V "waitLen") |]
              * [| V "wait" <> 0 |] * [| freeable (V "wait") (length waitL) |]
              * array newL (V "newWait") * [| length newL = wordToNat (V "newLen") |]
              * [| V "newWait" <> 0 |] * [| freeable (V "newWait") (wordToNat (V "newLen")) |]
              * mallocHeap 0
            POST[_] Ex wait', Ex waitLen', Ex waitL',
              (V "root" ==*> ready, free, wait', waitLen')
              * array waitL' wait' * [| allInOrZero ts waitL' |]
              * [| length waitL' = wordToNat waitLen' |]
              * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
              * mallocHeap 0];;

          "i" <- 0;;
          [Al ts, Al ready, Al free, Al waitL, Al waitL',
            PRE[V] [| V "tq" %in ts |] * (V "root" ==*> ready, free, V "wait", V "waitLen")
              * array waitL (V "wait") * [| allInOrZero ts waitL |]
              * [| length waitL = wordToNat (V "waitLen") |]
              * [| V "wait" <> 0 |] * [| freeable (V "wait") (length waitL) |]
              * array waitL' (V "newWait") * [| length waitL' = wordToNat (V "newLen") |]
              * [| V "newWait" <> 0 |] * [| freeable (V "newWait") (wordToNat (V "newLen")) |]
              * [| allInOrZero ts (firstn (wordToNat (V "i")) waitL') |]
              * mallocHeap 0 * [| (V "i" <= V "newLen")%word |]
            POST[_] Ex wait', Ex waitLen', Ex waitL',
              (V "root" ==*> ready, free, wait', waitLen')
              * array waitL' wait' * [| allInOrZero ts waitL' |]
              * [| length waitL' = wordToNat waitLen' |]
              * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
              * mallocHeap 0]
          While ("i" < "newLen") {
            If ("i" = "n") {
              "v" <- "tq"
            } else {
              If ("i" < "waitLen") {
                Assert [Al ts, Al ready, Al free, Al waitL, Al waitL',
                  PRE[V] [| V "tq" %in ts |] * (V "root" ==*> ready, free, V "wait", V "waitLen")
                    * array waitL (V "wait") * [| allInOrZero ts waitL |]
                    * [| length waitL = wordToNat (V "waitLen") |]
                    * [| V "wait" <> 0 |] * [| freeable (V "wait") (length waitL) |]
                    * array waitL' (V "newWait") * [| length waitL' = wordToNat (V "newLen") |]
                    * [| V "newWait" <> 0 |] * [| freeable (V "newWait") (wordToNat (V "newLen")) |]
                    * [| allInOrZero ts (firstn (wordToNat (V "i")) waitL') |]
                    * [| (V "i" < natToW (length waitL'))%word |]
                    * [| (V "i" < natToW (length waitL))%word |]
                    * mallocHeap 0
                  POST[_] Ex wait', Ex waitLen', Ex waitL',
                    (V "root" ==*> ready, free, wait', waitLen')
                    * array waitL' wait' * [| allInOrZero ts waitL' |]
                    * [| length waitL' = wordToNat waitLen' |]
                    * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
                    * mallocHeap 0];;
                "j" <- 4 * "i";;
                "v" <-* "wait" + "j"
              } else {
                "v" <- 0
              }
            };;

            Assert [Al ts, Al ready, Al free, Al waitL, Al waitL',
              PRE[V] [| V "tq" %in ts |] * (V "root" ==*> ready, free, V "wait", V "waitLen")
                * array waitL (V "wait") * [| allInOrZero ts waitL |]
                * [| length waitL = wordToNat (V "waitLen") |]
                * [| V "wait" <> 0 |] * [| freeable (V "wait") (length waitL) |]
                * array waitL' (V "newWait") * [| length waitL' = wordToNat (V "newLen") |]
                * [| V "newWait" <> 0 |] * [| freeable (V "newWait") (wordToNat (V "newLen")) |]
                * [| allInOrZero ts (firstn (wordToNat (V "i")) waitL') |]
                * [| (V "i" < natToW (length waitL'))%word |]
                * [| V "v" = $0 \/ V "v" %in ts |]
                * mallocHeap 0
              POST[_] Ex wait', Ex waitLen', Ex waitL',
                (V "root" ==*> ready, free, wait', waitLen')
                * array waitL' wait' * [| allInOrZero ts waitL' |]
                * [| length waitL' = wordToNat waitLen' |]
                * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
                * mallocHeap 0];;

            "j" <- 4 * "i";;
            "newWait" + "j" *<- "v";;
            "i" <- "i" + 1
          };;

          Note [dissolve_array];;

          Assert [Al ts, Al ready, Al free, Al newL,
            PRE[V] [| V "tq" %in ts |] * (V "root" ==*> ready, free, V "wait", V "waitLen")
              * V "wait" =?> wordToNat (V "waitLen")
              * [| V "wait" <> 0 |] * [| freeable (V "wait") (wordToNat (V "waitLen")) |]
              * array newL (V "newWait") * [| length newL = wordToNat (V "newLen") |]
              * [| V "newWait" <> 0 |] * [| freeable (V "newWait") (wordToNat (V "newLen")) |]
              * [| allInOrZero ts newL |]
              * mallocHeap 0
            POST[_] Ex wait', Ex waitLen', Ex waitL',
              (V "root" ==*> ready, free, wait', waitLen')
              * array waitL' wait' * [| allInOrZero ts waitL' |]
              * [| length waitL' = wordToNat waitLen' |]
              * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
              * mallocHeap 0];;

          Call "malloc"!"free"(0, "wait", "waitLen")
          [Al ready, Al free,
            PRE[V] mallocHeap 0 * (V "root" ==*> ready, free, V "wait", V "waitLen")
            POST[_] mallocHeap 0 * (V "root" ==*> ready, free, V "newWait", V "newLen")];;

          "root"+8 *<- "newWait";;
          "root"+12 *<- "newLen";;
          Return 0
        }
      }
    end with bfunction "block"("tq", "fd", "mode", "tmp") [blockS]
       "tmp" <-- Call "threadqs"!"isEmpty"("tq")
       [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
         PRE[V] [| V "tq" %in ts |]
           * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
           * [| ready %in ts |]
           * sll freeL free * [| allIn fs freeL |]
           * files ts fs * tqs ts fs
           * array waitL wait * [| allInOrZero ts waitL |]
             * [| length waitL = wordToNat waitLen |]
             * [| wait <> 0 |] * [| freeable wait (length waitL) |]
           * M.globalInv fs * mallocHeap 0
         POST[_] Ex p', Ex ts', Ex fs', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
           [| ts %<= ts' |] * [| fs %<= fs' |]
           * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
           * [| ready' %in ts' |]
           * sll freeL' free' * [| allIn fs' freeL' |]
           * files ts' fs' * tqs ts' fs'
           * array waitL' wait' * [| allInOrZero ts' waitL' |]
             * [| length waitL' = wordToNat waitLen' |]
             * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
           * M.globalInv fs' * mallocHeap 0];;

       If ("tmp" = 1) {
         Call "scheduler"!"declare"("tq", "fd", "mode")
         [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
         PRE[V] [| V "tq" %in ts |]
           * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
           * [| ready %in ts |]
           * sll freeL free * [| allIn fs freeL |]
           * files ts fs * tqs ts fs
           * array waitL wait * [| allInOrZero ts waitL |]
             * [| length waitL = wordToNat waitLen |]
             * [| wait <> 0 |] * [| freeable wait (length waitL) |]
           * M.globalInv fs * mallocHeap 0
         POST[_] Ex p', Ex ts', Ex fs', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
           [| ts %<= ts' |] * [| fs %<= fs' |]
           * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
           * [| ready' %in ts' |]
           * sll freeL' free' * [| allIn fs' freeL' |]
           * files ts' fs' * tqs ts' fs'
           * array waitL' wait' * [| allInOrZero ts' waitL' |]
             * [| length waitL' = wordToNat waitLen' |]
             * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
           * M.globalInv fs' * mallocHeap 0]
       } else {
         Skip
       };;

       "tmp" <-- Call "scheduler"!"pickNext"()
       [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al freeL, Al waitL,
         PRE[V, R] [| V "tq" %in ts |] * [| R %in ts |]
           * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
           * [| ready %in ts |]
           * sll freeL free * [| allIn fs freeL |]
           * files ts fs * tqs ts fs
           * array waitL wait * [| allInOrZero ts waitL |]
             * [| length waitL = wordToNat waitLen |]
             * [| wait <> 0 |] * [| freeable wait (length waitL) |]
           * M.globalInv fs * mallocHeap 0
         POST[_] Ex p', Ex ts', Ex fs', Ex ready', Ex free', Ex wait', Ex waitLen', Ex freeL', Ex waitL',
           [| ts %<= ts' |] * [| fs %<= fs' |]
           * globalSched =*> p' * (p' ==*> ready', free', wait', waitLen')
           * [| ready' %in ts' |]
           * sll freeL' free' * [| allIn fs' freeL' |]
           * files ts' fs' * tqs ts' fs'
           * array waitL' wait' * [| allInOrZero ts' waitL' |]
             * [| length waitL' = wordToNat waitLen' |]
             * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
           * M.globalInv fs' * mallocHeap 0];;

       Call "threadqs"!"yield"("tq", "tmp")
       [Al ts, Al fs, Al p, Al ready, Al free, Al wait, Al waitLen, Al waitL,
         PRE[V] [| V "tq" %in ts |]
           * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
           * array waitL wait * [| allInOrZero ts waitL |]
             * [| length waitL = wordToNat waitLen |]
             * [| wait <> 0 |] * [| freeable wait (length waitL) |]
           * tqs ts fs * mallocHeap 0
         POST[_] Ex wait', Ex waitLen', Ex waitL',
           globalSched =*> p * (p ==*> ready, free, wait', waitLen')
           * array waitL' wait' * [| allInOrZero ts waitL' |]
             * [| length waitL' = wordToNat waitLen' |]
             * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
           * tqs ts fs * mallocHeap 0];;

       "tmp" <-- Call "threadqs"!"isEmpty"("tq")
       [Al ts, Al p, Al ready, Al free, Al wait, Al waitLen, Al waitL,
         PRE[V] [| V "tq" %in ts |]
           * globalSched =*> p * (p ==*> ready, free, wait, waitLen)
           * array waitL wait * [| allInOrZero ts waitL |]
             * [| length waitL = wordToNat waitLen |]
             * [| wait <> 0 |] * [| freeable wait (length waitL) |]
           * mallocHeap 0
         POST[_] Ex wait', Ex waitLen', Ex waitL',
           globalSched =*> p * (p ==*> ready, free, wait', waitLen')
           * array waitL' wait' * [| allInOrZero ts waitL' |]
             * [| length waitL' = wordToNat waitLen' |]
             * [| wait' <> 0 |] * [| freeable wait' (length waitL') |]
           * mallocHeap 0];;

       If ("tmp" = 0) {
         Call "scheduler"!"declare"("tq", "fd", "mode")
         [PRE[_] Emp POST[_] Emp]
       } else {
         Skip
       };;

       Return 0
    end
  }}.

Ltac finish := auto;
  try solve [ fold (@length W) in *; try rewrite initSize_eq in *;
    repeat match goal with
             | [ H : length _ = _ |- _ ] => rewrite H
           end; reflexivity || eauto 2;
  fold (@firstn W) in *; autorewrite with sepFormula; eauto 2 ].

Local Hint Extern 1 (selN _ _ = _) => apply selN_upd_eq; solve [ finish ].

Ltac t' := unfold globalInv; sep hints; finish.

Ltac spawn := post; evaluate hints;
  match goal with
    | [ H : interp _ _ |- _ ] =>
      toFront ltac:(fun P => match P with
                               | starting _ _ => idtac
                             end) H; apply starting_elim in H; post; descend
  end;
  try (toFront_conc ltac:(fun P => match P with
                                     | Q'.starting _ _ _ _ => idtac
                                   end); apply other_starting_intro; descend;
  try match goal with
        | [ |- interp _ (![ _ ] _) ] => step hints
      end);
  (try (repeat (apply andL; apply injL; intro);
    match goal with
      | [ H : forall stn_st : ST.settings * state, _ |- _ ] =>
        eapply Imply_trans; [ | apply H ]; clear H
    end); t').

Lemma tqs_weaken : forall ts fs fs',
  fs %<= fs'
  -> tqs ts fs ===>* tqs ts fs'.
  rewrite tqs_eq; intros; apply tqs'_weaken; hnf; intuition.
Qed.

Ltac funky_nomega :=
  simpl; pre_nomega;
    match goal with
      | [ H : (wordToNat (sel _ "ss") >= _)%nat |- _ ] =>
        rewrite wordToNat_natToWord_idempotent in H by reflexivity
      | [ H : (_ <= wordToNat (sel _ "ss"))%nat |- _ ] =>
        rewrite wordToNat_natToWord_idempotent in H by reflexivity
    end;
    try match goal with
          | [ |- (wordToNat (sel _ "ss") >= _)%nat ] => rewrite wordToNat_natToWord_idempotent by reflexivity
        end; omega.

Ltac t := solve [
  match goal with
    | [ |- context[localsInvariantExit] ] =>
      match goal with
        | [ |- forall stn_st specs, interp specs _ -> interp specs _ ] =>
          match goal with
            | [ |- context[evolve] ] =>
              unfold globalInv; post; evaluate hints;
                match goal with
                  | [ H : context[locals ?a ?b ?c ?d] |- _ ] =>
                    change (locals a b c d) with (exitize_me a b c d) in H
                end; evaluate hints;
                match goal with
                  | [ H : context[?ss - 4 + 1] |- _ ] =>
                    replace (ss - 4 + 1) with (ss - 3) in H by funky_nomega
                end;
                repeat match goal with
                         | [ |- Logic.ex _ ] => eexists
                         | [ |- _ /\ _ ] => split
                         | [ H : context[locals _ ?vs _ _] |- context[locals _ ?vs' _ _] ] =>
                           equate vs vs'; descend; step hints
                       end; unfold natToW in *; descend; finish; funky_nomega
            | _ =>
              post; evaluate hints;
              match goal with
                | [ H : context[locals ?ns ?vs (?ss - 2) ?p]
                  |- context[locals ?ns' _ (wordToNat (sel _ "ss") - 4) _] ] =>
                let ns'' := peelPrefix ns ns' in
                  let avail := constr:(ss - 2) in
                    let avail' := constr:(ss - 4) in
                      change (locals ns vs avail p) with (locals_in ns vs avail p ns'' ns' avail') in H;
                        assert (ok_in ns avail ns'' ns' avail')%nat
                          by (split; [
                            reflexivity
                            | split; [ funky_nomega
                              | split; [ NoDup
                                | simpl; omega ] ] ])
              end; evaluate hints;
              repeat match goal with
                       | [ |- Logic.ex _ ] => eexists
                       | [ |- _ /\ _ ] => split
                       | [ H : context[locals _ ?vs _ _] |- context[locals _ ?vs' _ _] ] =>
                         equate vs vs'; descend; step hints
                     end; finish
          end
        | [ |- forall stn st specs, interp specs _ -> forall rp : W, _ ] =>
          post; evaluate hints;
          match goal with
            | [ H : context[locals ?ns ?vs (?ss - 4) ?p]
              |- context[locals ("rp" :: nil) _ 13 _] ] =>
            let avail := constr:(ss - 4) in
              let offset := eval simpl in (4 * List.length ns)%nat in
                change (locals ns vs avail p) with (locals_call ns vs avail p ("rp" :: nil) 13 offset) in H;
                  assert (ok_call ns ("rp" :: nil) avail 13 offset)%nat
                    by (split; [ funky_nomega
                      | split; [ funky_nomega
                        | split; [ NoDup
                          | reflexivity ] ] ])
          end; unfold localsInvariantExit in *; sep hints;
          try match goal with
                | [ |- himp _ ?pre ?post ] =>
                  match post with
                    | context[locals ?ns ?vs ?avail _] =>
                      match pre with
                        | context[excessStack _ ns ?availAlt ?ns' ?avail'] =>
                          match pre with
                            | context[locals ns ?vs' 0 ?sp] =>
                              match goal with
                                | _ => equate vs vs';
                                  let offset := eval simpl in (4 * List.length ns)%nat in
                                    rewrite (create_locals_return ns' avail' ns avail offset);
                                      assert (ok_return ns ns' avail avail' offset)%nat by (split; [
                                        funky_nomega
                                        | reflexivity ] ); autorewrite with sepFormula;
                                      generalize dependent vs'; intros; step hints
                              end
                          end
                      end
                  end
              end; finish; funky_nomega
        | _ => t'
      end

    | [ |- context[starting] ] =>
      match goal with
        | [ |- context[Q'.starting] ] => spawn
      end
    | [ |- context[add_a_file] ] =>
      post; evaluate hints;
      match goal with
        | [ H : context[upd _ "fr" ?V] |- _ ] =>
          match type of H with
            | context[files _ ?B] =>
              toFront ltac:(fun P => match P with
                                       | tqs _ _ => idtac
                                     end) H;
              eapply use_HimpWeak in H; [ | apply (tqs_weaken _ _ (B %+ V)) ]; [ t | finish ]
          end
      end
    | [ |- context[reveal_files_pick] ] => unfold files_pick; t'
    | _ => t'
  end ].

Local Hint Extern 1 (@eq W _ _) => words.
Local Hint Immediate evolve_refl.

Hint Rewrite upd_length : sepFormula.

Local Hint Extern 1 (allInOrZero _ nil) => constructor.
Local Hint Extern 1 (allInOrZero _ (_ :: _)) => constructor.

Local Hint Extern 1 (allIn empty _) => constructor.

Local Hint Extern 1 (allInOrZero _ (Array.upd _ (natToW 1) (natToW 0))) =>
  hnf; rewrite upd_updN by auto;
    repeat match goal with
             | [ ls : list W |- _ ] =>
               match goal with
                 | [ _ : length ?E = _ |- _ ] =>
                   match E with
                     | context[ls] => destruct ls; try discriminate
                   end
               end
           end; simpl in *.

Local Hint Extern 1 (freeable _ _) => congruence.
Local Hint Extern 1 (himp _ _ (sll nil (natToW 0))) => solve [ step hints ].

Lemma length_ok : forall u v n,
  u < v
  -> n = wordToNat v
  -> u < natToW n.
  intros; subst; unfold natToW; rewrite natToWord_wordToNat; auto.
Qed.

Local Hint Immediate length_ok.

Lemma selN_In : forall ls n,
  (n < length ls)%nat
  -> In (Array.selN ls n) ls.
  induction ls; destruct n; simpl; intuition.
Qed.

Lemma sel_In : forall ls n,
  n < natToW (length ls)
  -> goodSize (length ls)
  -> In (Array.sel ls n) ls.
  unfold Array.sel; intros; apply selN_In; nomega.
Qed.

Lemma found_queue : forall x ls i b,
  x = Array.sel ls i
  -> Array.sel ls i <> 0
  -> allInOrZero b ls
  -> i < natToW (length ls)
  -> goodSize (length ls)
  -> x %in b.
  intros; subst.
  eapply Forall_forall in H1; [ | eauto using sel_In ].
  tauto.
Qed.

Local Hint Extern 1 (_ %in _) =>
  eapply found_queue; [ eassumption | eassumption | eassumption | eassumption | eauto ].

Lemma allIn_monotone : forall b ls b',
  allIn b ls
  -> b %<= b'
  -> allIn b' ls.
  intros; eapply Forall_weaken; eauto.
  bags.
  specialize (H0 x); omega.
Qed.

Local Hint Immediate allIn_monotone.

Lemma allIn_hd : forall b x ls,
  allIn b (x :: ls)
  -> x %in b.
  inversion 1; auto.
Qed.

Lemma allIn_tl : forall b x ls,
  allIn b (x :: ls)
  -> allIn b ls.
  inversion 1; auto.
Qed.

Local Hint Immediate allIn_hd allIn_tl.

Lemma add_incl : forall a b x,
  a %+ x %<= b
  -> a %<= b.
  bags.
  specialize (H x0).
  destruct (W_Key.eq_dec x0 x); auto.
Qed.

Local Hint Immediate add_incl.

Local Hint Extern 1 (himp _ (files _ _) (files _ _)) => apply starB_weaken; solve [ sepLemma ].

Lemma allInOrZero_monotone : forall b ls b',
  allInOrZero b ls
  -> b %<= b'
  -> allInOrZero b' ls.
  intros; eapply Forall_weaken; [ | eauto ].
  bags.
  specialize (H0 x); omega.
Qed.

Local Hint Immediate allInOrZero_monotone.

Lemma allIn_cons : forall b x ls,
  allIn b ls
  -> x %in b
  -> allIn b (x :: ls).
  constructor; auto.
Qed.

Local Hint Immediate allIn_cons.

Lemma allInOrZero_updN : forall b v ls,
  allInOrZero b ls
  -> forall i, v %in b
    -> allInOrZero b (Array.updN ls i v).
  induction 1; destruct i; simpl; intuition;
    constructor; auto; apply IHForall; auto.
Qed.

Lemma allInOrZero_upd : forall b ls i v,
  allInOrZero b ls
  -> v %in b
  -> allInOrZero b (Array.upd ls i v).
  intros; apply allInOrZero_updN; auto.
Qed.

Local Hint Immediate allInOrZero_upd.

Hint Rewrite roundTrip_0 : N.

Lemma zero_le : forall w : W, natToW 0 <= w.
  intros; nomega.
Qed.

Local Hint Immediate zero_le.

Lemma firstn_advance' : forall v n ls,
  (n < length ls)%nat
  -> firstn (n + 1) (Array.updN ls n v) = firstn n ls ++ v :: nil.
  induction n; destruct ls; simpl; intuition.
  rewrite IHn; auto.
Qed.

Lemma firstn_advance : forall ls w v,
  w < natToW (length ls)
  -> goodSize (length ls)
  -> firstn (wordToNat w + 1) (Array.upd ls w v) = firstn (wordToNat w) ls ++ v :: nil.
  unfold Array.upd; intros; apply firstn_advance'; nomega.
Qed.

Lemma allInOrZero_advance : forall b w ls (v : W),
  allInOrZero b (firstn (wordToNat w) ls)
  -> v = 0 \/ v %in b
  -> w < natToW (length ls)
  -> goodSize (length ls)
  -> allInOrZero b (firstn (wordToNat (w ^+ natToW 1)) (Array.upd ls w v)).
  intros.
  erewrite <- next; eauto.
  rewrite firstn_advance; auto; apply Forall_app; auto.
Qed.

Local Hint Extern 1 (allInOrZero _ (firstn (wordToNat (_ ^+ _)) _)) =>
  solve [ apply allInOrZero_advance; auto; [ eauto 10 ] ].

Local Hint Immediate inc.

Hint Rewrite natToW_wordToNat : sepFormula.

Lemma allInOrZero_delivers : forall b ls i,
  allInOrZero b ls
  -> i < natToW (length ls)
  -> goodSize (length ls)
  -> Array.sel ls i = natToW 0 \/ Array.sel ls i %in b.
  intros ? ? ? H ? ?; eapply Forall_forall in H; eauto; apply sel_In; auto.
Qed.

Local Hint Extern 1 (_ \/ _) => solve [ apply allInOrZero_delivers; auto; [ eauto 10 ] ].

Lemma firstn_length : forall A (ls : list A),
  firstn (length ls) ls = ls.
  induction ls; simpl; intuition.
Qed.

Lemma allInOrZero_done : forall b (i : W) ls l,
  allInOrZero b (firstn (wordToNat i) ls)
  -> l <= i
  -> i <= l
  -> length ls = wordToNat l
  -> allInOrZero b ls.
  intros; replace i with l in *.
  rewrite <- H2 in *; rewrite firstn_length in *; assumption.
  apply wordToNat_inj; nomega.
Qed.

Local Hint Immediate allInOrZero_done.

Lemma nonzero : forall sp sp' sp'' : W,
  sp ^- $16 = natToW 0
  -> sp' = sp'' ^+ natToW 16
  -> sp'' <> 0
  -> sp = sp'
  -> False.
  intros; subst; apply H1; unfold natToW in *; ring_simplify in H; auto.
Qed.

Local Hint Immediate nonzero.

Theorem ok : moduleOk m.
  vcgen; abstract t.
Qed.

Transparent initSize.

End Make.


Require Import floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.spec_salsa.
Require Import sha.general_lemmas.
Require Import tweetnacl20140427.tweetNaclBase.

Lemma vn_spec_ok: semax_body SalsaVarSpecs SalsaFunSpecs
       f_vn vn_spec.
Proof.
start_function.
forward.
assert_PROP (n = Zlength (map Vint (map Int.repr (map Byte.unsigned xcont))) /\
             n = Zlength (map Vint (map Int.repr (map Byte.unsigned ycont)))) as LEN by entailer!.
destruct LEN as [LenX LenY].
assert (ZWS: Int.zwordsize = 32) by reflexivity.
assert (BWS: Byte.zwordsize = 8) by reflexivity.
forward_for_simple_bound n
(EX i:Z, EX d:_,
  (PROP  (Byte.eq d Byte.zero = if list_eq_dec Byte.eq_dec (sublist 0 i xcont) (sublist 0 i ycont) then true else false)
   LOCAL (temp _d (Vint (Int.repr (Byte.unsigned d)));
          temp _x x; temp _y y; temp _n (Vint (Int.repr n)))
   SEP (data_at xsh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
   data_at ysh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y))).
{ Exists Byte.zero. entailer!.  }
{ Intros. rename H0 into I. rename H1 into B. rename x0 into b.
  forward. entailer!.
  apply (expr_lemmas3.zero_ext_range' 8 (Int.repr (Znth i (map Byte.unsigned xcont) 0))). omega.
  forward. entailer!.
  apply (expr_lemmas3.zero_ext_range' 8 (Int.repr (Znth i (map Byte.unsigned ycont) 0))). omega.
  forward. entailer!.
  rewrite ! Zlength_map in *.
  rewrite <- (sublist_rejoin 0 i (i+1) xcont), sublist_len_1 with (d:=Byte.zero); try omega.
  rewrite <- (sublist_rejoin 0 i (i+1) ycont), sublist_len_1 with (d:=Byte.zero); try omega.
  rewrite list_eq_dec_app. 2: rewrite 2 Zlength_sublist; trivial; omega. 2: rewrite 2 Zlength_cons, Zlength_nil; trivial.
  rewrite <- B. unfold Int.xor.
  remember (list_eq_dec Byte.eq_dec [Znth i xcont Byte.zero] [Znth i ycont Byte.zero]).  simpl.
  rewrite or_repr. clear H0 H1 H2 H4 H5 H7 SH SH0 PNx PNy Heqs.
  rewrite 2 Znth_map with (d':=Byte.zero) by omega.
  rewrite 2 zero_ext_inrange by
      (rewrite Int.unsigned_repr; [ apply Byte.unsigned_range_2 | apply byte_unsigned_range_int_unsigned_max]).
  rewrite 2 Int.unsigned_repr by apply byte_unsigned_range_int_unsigned_max.
  destruct (list_eq_dec Byte.eq_dec (sublist 0 i xcont) (sublist 0 i ycont)).
  + specialize (Byte.eq_spec b Byte.zero); rewrite B; intros; subst b; clear B.
    simpl. destruct s.
    - inv e0. rewrite H1, Z.lxor_nilpotent, Z.lor_0_r.
      Exists Byte.zero. entailer.
    - destruct (Z_lxor_byte_neq (Znth i xcont Byte.zero) (Znth i ycont Byte.zero)) as [bb [BB HBB]].
      * intros N. apply n; rewrite N; trivial.
      * rewrite BB, Zlor_Byteor, Byte.or_zero_l.
        Exists bb. entailer!.
        apply Byte.eq_false; trivial.
  + destruct s.
    - inv e. rewrite H1, Z.lxor_nilpotent, Z.lor_0_r, andb_true_r.
      Exists b. entailer!.
    - destruct (Z_lxor_byte_neq (Znth i xcont Byte.zero) (Znth i ycont Byte.zero)) as [bb [BB HBB]].
      * intros N. apply n0; rewrite N; trivial.
      * rewrite BB, Zlor_Byteor, andb_false_r.
        Exists (Byte.or b bb). entailer!. apply Byte.eq_false. intros N.
        destruct (ByteOr_zero _ _ N). contradiction. }
apply extract_exists_pre; intros b.
forward. apply prop_right.
  rewrite ! Zlength_map in *. rewrite 2 sublist_same in H0; trivial.
  clear H1 H4 H6 H3 H2 H5 SH SH0 PNx PNy.
  destruct (list_eq_dec Byte.eq_dec xcont ycont).
  + specialize (Byte.eq_spec b Byte.zero). rewrite H0; intros; subst. reflexivity.
  + specialize (Byte.eq_spec b Byte.zero). rewrite H0; intros. clear - ZWS BWS H1.
    f_equal. unfold Int.sub.
    assert (Int.shru (Int.repr (Byte.unsigned b - 1)) (Int.repr 8) = Int.zero).
    - apply Int.same_bits_eq. rewrite ZWS; intros. rewrite Int.bits_zero, Int.bits_shru; try omega.
      rewrite (Int.unsigned_repr 8), ZWS. 2: rewrite int_max_unsigned_eq; omega.
      if_tac; trivial. rewrite Int.testbit_repr by omega. apply isbyteZ_testbit. 2: omega.
      destruct (Byte.unsigned_range b). replace Byte.modulus with 256 in H3 by reflexivity. split; try omega.
      destruct (zle 0 (Byte.unsigned b - 1)); trivial. elim H1; clear H1.
      assert (ZZ: Byte.unsigned b =0) by omega.
      apply initialize.zero_ext_inj. rewrite ZZ; reflexivity.
    - rewrite H, Int.and_zero; reflexivity.
Qed.

Lemma verify16_spec_ok: semax_body SalsaVarSpecs SalsaFunSpecs
       f_crypto_verify_16_tweet verify16_spec.
Proof.
start_function.
forward_call (x,y,16,xsh,ysh,xcont,ycont).
forward.
Qed.

Lemma verify32_spec_ok: semax_body SalsaVarSpecs SalsaFunSpecs
       f_crypto_verify_32_tweet verify32_spec.
Proof.
start_function.
forward_call (x,y,32,xsh,ysh,xcont,ycont).
forward.
Qed.


(*
 * Copyright (c) 2020 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)

(**
Another (incomplete) consistency proof for [PTRS], based on Krebbers' PhD thesis, and
other formal models of C++ using structured pointers.
This is more complex than [SIMPLE_PTRS_IMPL], but will be necessary to justify [VALID_PTR_AXIOMS].

In this model, all valid pointers have an address pinned, but this is not meant
to be guaranteed.
*)

From stdpp Require Import gmap.
From bedrock.prelude Require Import base addr avl bytestring option numbers.

From bedrock.lang.cpp Require Import ast.
From bedrock.lang.cpp.semantics Require Import sub_module values.
From bedrock.lang.cpp.model Require Import simple_pointers_utils inductive_pointers_utils.

Implicit Types (σ : genv).
#[local] Close Scope nat_scope.
#[local] Open Scope Z_scope.

Module PTRS_IMPL <: PTRS_INTF.
  Import canonical_tu address_sums merge_elems.

  Inductive raw_offset_seg : Set :=
  | o_field_ (* type-name: *) (f : field)
  | o_sub_ (ty : type) (z : Z)
  | o_base_ (derived base : globname)
  | o_derived_ (base derived : globname)
  | o_invalid_.
  #[local] Instance raw_offset_seg_eq_dec : EqDecision raw_offset_seg.
  Proof. solve_decision. Defined.
  #[global] Declare Instance raw_offset_seg_countable : Countable raw_offset_seg.

  Definition offset_seg : Set := raw_offset_seg * Z.
  #[local] Instance offset_seg_eq_dec : EqDecision offset_seg := _.
  #[local] Instance offset_seg_countable : Countable offset_seg := _.

  Definition eval_raw_offset_seg σ (ro : raw_offset_seg) : option Z :=
    match ro with
    | o_field_ f => o_field_off σ f
    | o_sub_ ty z => o_sub_off σ ty z
    | o_base_ derived base => o_base_off σ derived base
    | o_derived_ base derived => o_derived_off σ base derived
    | o_invalid_ => None
    end.
  Definition mk_offset_seg σ (ro : raw_offset_seg) : offset_seg :=
    match eval_raw_offset_seg σ ro with
    | None => (o_invalid_, 0%Z)
    | Some off => (ro, off)
    end.

  (* This list is reversed.
  The list of offsets in [[p; o_1; ...; o_n]] is represented as [[o_n; ... o_1]].
  This way, we can cons new offsets to the head, and consume them at the tail. *)
  Definition raw_offset := list offset_seg.
  #[local] Instance raw_offset_eq_dec : EqDecision raw_offset := _.
  #[local] Instance raw_offset_countable : Countable raw_offset := _.

  Notation isnt o pattern :=
    (match o with | pattern => False | _ => True end).

  Implicit Types (z : Z).
  (* Close Scope nat_scope. *)
  #[local] Open Scope Z_scope.
  Section roff_canon.
    (* Context {σ : genv}. *)

    (* We currently ensure the offsets in the destination are correct wrt the source, not that the ones in the source are consistent with each other. *)
    Inductive roff_canon : raw_offset -> raw_offset -> Prop :=
    | o_nil :
      roff_canon [] []
    | o_field_canon s d f o :
      (* is_Some (o_field_off σ f) -> *) (* not canonicalization's problem? *)
      roff_canon s d ->
      roff_canon ((o_field_ f, o) :: s) ((o_field_ f, o) :: d)
    | o_base_canon s d base derived o :
      (* no, because (valid?) normal forms don't use [o_derived]? *)
      (* isnt d ((o_derived_ _ _ , _) :: _) -> *)
      roff_canon s d ->
      roff_canon ((o_base_ derived base, o) :: s) ((o_base_ derived base, o) :: d)
    (* should paths start from the complete object? If
    yes, as done by Ramananandro [POPL 2012],
    o_derived should just cancel out o_base, and this should be omitted. *)
    (* | o_derived_wf s d derived base :
      isnt d (o_base_ _ _ :: d) ->
      roff_canon s d ->
      roff_canon (o_derived_ base derived :: s) (o_derived_ base derived :: d) *)
    | o_derived_cancel_canon s d derived base o1 o2 :
      roff_canon s d ->
      (* This premise is a hack, but without it, normalization might not be deterministic. Thankfully, paths can't contain o_derived step, so we're good! *)
      (* roff_canon (o_base_ derived base :: s) (o_base_ derived base :: d) -> *)
      roff_canon ((o_derived_ base derived, o1) :: (o_base_ derived base, o2) :: s) d
    | o_sub_0_canon s d ty :
      roff_canon s d ->
      roff_canon ((o_sub_ ty 0, 0) :: s) d
    | o_sub_canon s d ty1 z o :
      match d with
      | ((o_sub_ ty2 _, _) :: _) => ty1 <> ty2
      | _ => True
      end ->
      (* In fact, we want [0 < z], but that's a matter of validity, not canonicalization. *)
      z <> 0 ->
      (* isnt o (o_sub_ _ _) *)
      roff_canon s d ->
      roff_canon ((o_sub_ ty1 z, o) :: s) ((o_sub_ ty1 z, o) :: d)
    | o_sub_merge_canon s d ty z1 z2 o1 o2 :
      (* Again, validity would require [> 0]. *)
      z1 + z2 <> 0 ->
      roff_canon s ((o_sub_ ty z1, o1) :: d) ->
      roff_canon ((o_sub_ ty z2, o2) :: s) ((o_sub_ ty (z1 + z2), o1 + o2) :: d)
    .
  End roff_canon.

  Lemma roff_canon_o_base_inv s d derived base o1 o2 :
    roff_canon ((o_base_ derived base, o1) :: s) ((o_base_ derived base, o2) :: d) ->
    roff_canon s d.
  Proof. inversion 1; auto. Qed.

  Lemma roff_canon_o_sub_wf s d ty z o :
    roff_canon s ((o_sub_ ty z, o) :: d) ->
    z <> 0.
  Proof.
    move E: (_ :: _) => d' Hcn.
    elim: Hcn E; naive_solver eauto with lia.
  Qed.

  Lemma roff_canon_o_sub_no_dup s d o ty1 z ro :
    roff_canon s ((o_sub_ ty1 z, ro) :: o :: d) ->
    match o with
    | (o_sub_ ty2 _, _) => ty1 <> ty2
    | _ => True
    end.
  Proof.
    move E: ((o_sub_ _ _, _) :: _) => d' Hcn.
    elim: Hcn z ro E; naive_solver.
  Qed.

  Definition offset_seg_cons (os : offset_seg) (oss : list offset_seg) : list offset_seg :=
    match os, oss with
    | (o_sub_ ty1 n1, off1), _ =>
      if decide (n1 = 0 /\ off1 = 0)%Z then oss else
      match oss with
        | (o_sub_ ty2 n2, off2) :: oss' =>
        if decide (ty1 <> ty2)
          then os :: oss
          else if decide (n2 + n1 = 0 /\ off1 + off2 = 0)%Z
          then oss'
          else (o_sub_ ty1 (n2 + n1), (off2 + off1)%Z) :: oss'
        | _ => os :: oss
      end
    | (o_derived_ base1 der1, off1), (o_base_ der2 base2, off2) :: oss' =>
      if decide (der1 = der2 /\ base1 = base2)
      then oss'
      else os :: oss
    (* | (o_invalid_, _), _ => [(o_invalid_, 0%Z)] *)
    | (o_invalid_, z), _ => [(o_invalid_, z)]
    | _, _ => os :: oss
    end.

  Definition raw_offset_collapse : raw_offset -> raw_offset :=
    foldr offset_seg_cons [].
  Arguments raw_offset_collapse !_ /.

  Definition raw_offset_wf (ro : raw_offset) : Prop :=
    raw_offset_collapse ro = ro.
  Arguments raw_offset_wf !_ /.
  #[global] Instance raw_offset_wf_pi ro : ProofIrrel (raw_offset_wf ro) := _.
  Lemma singleton_raw_offset_wf {os}
    (Hn0 : isnt os (o_sub_ _ 0, _)) :
    raw_offset_wf [os].
  Proof. destruct os as [[] ?] => //=; case_decide; naive_solver. Qed.

  #[local] Hint Constructors roff_canon : core.
  Theorem canon_wf_0 src dst :
    roff_canon src dst ->
    roff_canon dst dst.
  Proof.
    intros Hrc; induction Hrc; eauto.
    inversion IHHrc; eauto 2; last have ?: z0 = 0 by [lia]; subst.
    (* Show that [o_sub_merge_canon] isn't applicable. *)
    all: by efeed pose proof roff_canon_o_sub_wf.
  Qed.

  Theorem canon_wf' src dst : roff_canon src dst -> raw_offset_collapse src = dst.
  Proof.
    rewrite /raw_offset_wf /raw_offset_collapse => Hc;
    induction Hc => //=; rewrite ?IHHc /offset_seg_cons //=.
    { by [ rewrite decide_True //=; repeat (lia || f_equal)]. }
    all: repeat ((case_decide || case_match); destruct_and?; subst => //).
    by rewrite !right_id_L.
  Qed.

  Theorem canon_wf src dst : roff_canon src dst -> raw_offset_wf dst.
  Proof. intros ?%canon_wf_0. exact: canon_wf'. Qed.

  Definition raw_offset_merge (o1 o2 : raw_offset) : raw_offset :=
    raw_offset_collapse (o1 ++ o2).
  Arguments raw_offset_merge !_ _ /.

  Definition offset := {ro : raw_offset | raw_offset_wf ro}.
  #[global] Instance offset_eq_dec : EqDecision offset := _.

  #[local] Definition raw_offset_to_offset (ro : raw_offset) : option offset :=
    match decide (raw_offset_wf ro) with
    | left Hwf => Some (exist _ ro Hwf)
    | right _ => None
    end.
  #[global] Instance offset_countable : Countable offset.
  Proof.
    apply (inj_countable proj1_sig raw_offset_to_offset) => -[ro Hwf] /=.
    rewrite /raw_offset_to_offset; case_match => //.
    by rewrite (proof_irrel Hwf).
  Qed.

  Program Definition o_id : offset := [] ↾ _.
  Next Obligation. done. Qed.
  Program Definition mkOffset σ (ro : raw_offset_seg)
    (Hn0 : isnt ro (o_sub_ _ 0)) : offset :=
    [mk_offset_seg σ ro] ↾ singleton_raw_offset_wf _.
  Next Obligation.
    rewrite /mk_offset_seg; intros ? [] H => //=; repeat case_match => //.
  Qed.
  Definition o_invalid σ : offset := mkOffset σ o_invalid_ I.
  Definition o_field σ f : offset :=
    mkOffset σ (o_field_ f) I.
  Definition o_base σ derived base : offset :=
    mkOffset σ (o_base_ derived base) I.
  Definition o_derived σ base derived : offset :=
    mkOffset σ (o_derived_ base derived) I.
  Program Definition o_sub σ ty z : offset :=
    if decide (z = 0)%Z
    then
      match size_of σ ty with
      | Some _ => o_id
      | None => o_invalid σ
      end
    else
    mkOffset σ (o_sub_ ty z) _.
  Next Obligation. intros; case_match; simplify_eq/=; case_match; naive_solver. Qed.

  Lemma last_last_equiv {X} d {xs : list X} : default d (stdpp.list.last xs) = List.last xs d.
  Proof. elim: xs => // x1 xs /= <-. by case_match. Qed.
(*
  Section merge_elem.
    Context {X} (f : X -> X -> list X).
    Context (Hinv : ∀ x1 x2, merge_elems f (f x1 x2) = f x1 x2).

    #[global] Instance invol_merge_elems: Involutive (merge_elems f).
    Proof.
    Admitted.

    #[global] Instance invol_app_merge_elems: InvolApp (merge_elems f).
    Proof.
    Admitted.
  End merge_elem.
  #[local] Arguments merge_elems {X} f !_ /. *)

  Definition offset_seg_append : offset_seg -> raw_offset -> raw_offset :=
    offset_seg_cons.
(*
  Lemma offset_seg_cons_inv x1 x2 :
    raw_offset_collapse (offset_seg_cons x1 x2) = offset_seg_cons x1 x2.
  Proof.
    move=> /= [o1 off1] [o2 off2].
    destruct o1, o2 => //=; by repeat (case_decide; simpl).
  Qed. *)

  #[local] Definition test xs :=
    raw_offset_collapse (raw_offset_collapse xs) = raw_offset_collapse xs.

  Section tests.
    Ltac start := intros; red; simpl.
    Ltac step_true := rewrite ?decide_True //=.
    Ltac step_false := rewrite ?decide_False //=.
    Ltac res_true := start; repeat step_true.
    Ltac res_false := start; repeat step_false.

    Goal test []. Proof. res_true. Qed.
    Goal `{n1 <> 0 -> test [(o_sub_ ty n1, o1)] }.
    Proof. res_false; naive_solver. Qed.
    Goal `{n1 <> 0 -> n2 <> 0 -> n2 + n1 <> 0 -> test [(o_sub_ ty n1, o1); (o_sub_ ty n2, o2)] }.
    Proof. res_false; naive_solver. Qed.

    (* Goal `{test [(o_sub_ ty n1, o1); (o_sub_ ty n2, o2); (o_field_ f, o3)] }.
    Proof. res_true. Qed.

    Goal `{test [(o_field_ f, o1); (o_sub_ ty n1, o2); (o_sub_ ty n2, o3)] }.
    Proof. res_true. Qed.

    Goal `{ty1 ≠ ty2 → test [(o_sub_ ty1 n1, o1); (o_sub_ ty2 n2, o2); (o_field_ f, o3)] }.
    Proof. res_false. Qed.

    Goal `{ty1 ≠ ty2 → test [(o_sub_ ty1 n1, o1); (o_sub_ ty1 n2, o2); (o_sub_ ty2 n3, o3); (o_field_ f, o4)] }.
    Proof. start. step_false. step_true. step_false. Qed. *)
  End tests.

  (* This is probably sound, since it allows temporary underflows. *)
  Definition eval_offset_seg (os : offset_seg) : option Z :=
    match os with
    | (o_invalid_, _) => None
    | (_, z) => Some z
    end.
  Definition eval_raw_offset (o : raw_offset) : option Z :=
    foldr (liftM2 Z.add) (Some 0) (map eval_offset_seg o).
  Definition eval_offset (_ : genv) (o : offset) : option Z :=
    eval_raw_offset (`o).
  (* This is probably not generally applicable. *)
  Local Arguments liftM2 {_ _ _ _ _ _} _ !_ !_ / : simpl nomatch.

  Lemma eval_offset_nil :
    forall {σ : genv} (wf : raw_offset_wf []),
      eval_offset σ ([] ↾ wf) = Some 0.
  Proof. by unfold eval_offset, eval_raw_offset; simpl. Qed.

  Lemma eval_o_sub σ ty (i : Z) :
    eval_offset _ (o_sub _ ty i) =
      (* This order enables reducing for known ty. *)
      (fun n => Z.of_N n * i) <$> size_of _ ty.
  Proof.
    rewrite /o_sub/eval_offset/eval_raw_offset/=.
    rewrite /= /mkOffset /mk_offset_seg/=/o_sub_off/=.
    case_decide; subst => //=;
      case: size_of=> [sz|] //=.
    by f_equiv; lia.
    by rewrite (comm_L _ i) right_id_L.
  Qed.

  Lemma eval_o_field σ f n cls st :
    f = {| f_name := n ; f_type := cls |} ->
    glob_def σ cls = Some (Gstruct st) ->
    st.(s_layout) = POD \/ st.(s_layout) = Standard ->
    eval_offset σ (o_field σ f) = offset_of σ (f_type f) (f_name f).
  Proof.
    move => -> _ _. cbn.
    rewrite/mk_offset_seg /eval_raw_offset_seg /o_field_off /=.
    case: offset_of => [off|//] /=. by rewrite right_id_L.
  Qed.

  Class InvolApp {X} (f : list X → list X) :=
    invol_app : ∀ xs1 xs2,
    f (xs1 ++ xs2) = f (f xs1 ++ f xs2).
  Class Involutive {X} (f : X → X) :=
    invol : ∀ x, f (f x) = f x.
  #[global] Instance raw_offset_collapse_involutive : Involutive raw_offset_collapse.
  Admitted.
  #[global] Instance raw_offset_collapse_invol_app : InvolApp raw_offset_collapse.
  Admitted.

  Program Definition __o_dot : offset → offset → offset :=
    λ o1 o2, (raw_offset_merge (proj1_sig o1) (proj1_sig o2)) ↾ _.
  Next Obligation.
    move=> o1 o2 /=.
    exact: raw_offset_collapse_involutive.
  Qed.

  Lemma __o_dot_nil_r :
    forall o (wf_o : raw_offset_wf o) (wf_nil : raw_offset_wf []),
      __o_dot (o ↾ wf_o) ([] ↾ wf_nil) = o ↾ wf_o.
  Proof.
    intros **.
    unfold __o_dot, raw_offset_merge, raw_offset_collapse; simpl.
    induction o=> //=.
    - rewrite (proof_irrel (__o_dot_obligation_1 ([] ↾ wf_o) ([] ↾ wf_nil))).
      by rewrite (proof_irrel wf_o).
    - rewrite (proof_irrel (__o_dot_obligation_1 ((a :: o) ↾ wf_o) ([] ↾ wf_nil))). 1: {
        unfold raw_offset_wf, raw_offset_collapse, raw_offset_merge; simpl.
        rewrite app_nil_r.
        unfold raw_offset_merge, raw_offset_collapse in wf_o; simpl in wf_o.
        rewrite wf_o.
        done.
      }
      unfold raw_offset_merge, raw_offset_collapse; simpl; rewrite app_nil_r.
      unfold raw_offset_wf, raw_offset_collapse in wf_o; simpl in wf_o.
      rewrite wf_o; intros wf_o'.
      by erewrite (proof_irrel wf_o).
  Qed.

  Inductive root_ptr : Set :=
  | nullptr_
  | global_ptr_ (tu : translation_unit_canon) (o : obj_name)
  | alloc_ptr_ (a : alloc_id) (va : vaddr).

  #[local] Instance root_ptr_eq_dec : EqDecision root_ptr.
  Proof. solve_decision. Defined.
  #[global] Declare Instance root_ptr_countable : Countable root_ptr.
  #[global] Instance global_ptr__inj : Inj2 (=) (=) (=) global_ptr_.
  Proof. by intros ???? [=]. Qed.

  Definition root_ptr_alloc_id (rp : root_ptr) : option alloc_id :=
    match rp with
    | nullptr_ => Some null_alloc_id
    | global_ptr_ tu o => Some (global_ptr_encode_aid o)
    | alloc_ptr_ aid _ => Some aid
    end.

  Definition root_ptr_vaddr (rp : root_ptr) : option vaddr :=
    match rp with
    | nullptr_ => Some 0%N
    | global_ptr_ tu o => Some (global_ptr_encode_vaddr o)
    | alloc_ptr_ aid va => Some va
    end.

  Inductive ptr_ : Set :=
  | invalid_ptr_
  | fun_ptr_ (tu : translation_unit_canon) (o : obj_name)
  | offset_ptr (p : root_ptr) (o : offset).
  Definition ptr := ptr_.
  #[global] Instance ptr_eq_dec : EqDecision ptr.
  Proof. solve_decision. Defined.
  #[global] Declare Instance ptr_countable : Countable ptr.
  #[global] Instance offset_ptr_inj : Inj2 (=) (=) (=) offset_ptr.
  Proof. by intros ???? [=]. Qed.

  Definition ptr_alloc_id (p : ptr) : option alloc_id :=
    match p with
    | invalid_ptr_ => None
    | fun_ptr_ tu o => Some (global_ptr_encode_aid o)
    | offset_ptr p o => root_ptr_alloc_id p
    end.

  Definition ptr_vaddr (p : ptr) : option vaddr :=
    match p with
    | invalid_ptr_ => None
    | fun_ptr_ tu o => Some (global_ptr_encode_vaddr o)
    | offset_ptr p o =>
      foldr
        (λ off ova, ova ≫= offset_vaddr off)
        (root_ptr_vaddr p)
        (snd <$> `o)
    end.

  Definition lift_root_ptr (rp : root_ptr) : ptr := offset_ptr rp o_id.
  Definition invalid_ptr := invalid_ptr_.
  Definition fun_ptr tu o := fun_ptr_ (canonical_tu.tu_to_canon tu) o.

  Definition null_alloc_id : alloc_id := null_alloc_id.
  Definition nullptr := lift_root_ptr nullptr_.
  Definition global_ptr (tu : translation_unit) o :=
    lift_root_ptr (global_ptr_ (canonical_tu.tu_to_canon tu) o).
  Definition alloc_ptr a oid := lift_root_ptr (alloc_ptr_ a oid).

  Lemma global_ptr_nonnull tu o : global_ptr tu o <> nullptr.
  Proof. done. Qed.

  #[global] Instance global_ptr_inj tu : Inj (=) (=) (global_ptr tu) := _.

  (* Some proofs using these helpers could be shortened, tactic-wise, but I find
  them clearer this way, and they work in both models. *)
  Lemma ptr_vaddr_global_ptr tu o :
    ptr_vaddr (global_ptr tu o) = Some (global_ptr_encode_vaddr o).
  Proof. done. Qed.
  Lemma ptr_alloc_id_global_ptr tu o :
    ptr_alloc_id (global_ptr tu o) = Some (global_ptr_encode_aid o).
  Proof. done. Qed.

  Lemma global_ptr_nonnull_addr tu o : ptr_vaddr (global_ptr tu o) <> Some 0%N.
  Proof. rewrite ptr_vaddr_global_ptr. done. Qed.
  Lemma global_ptr_nonnull_aid tu o : ptr_alloc_id (global_ptr tu o) <> Some null_alloc_id.
  Proof. rewrite ptr_alloc_id_global_ptr. done. Qed.

  #[global] Instance global_ptr_addr_inj tu : Inj (=) (=) (λ o, ptr_vaddr (global_ptr tu o)).
  Proof. intros ??. rewrite !ptr_vaddr_global_ptr. by intros ?%(inj _)%(inj _). Qed.
  #[global] Instance global_ptr_aid_inj tu : Inj (=) (=) (λ o, ptr_alloc_id (global_ptr tu o)).
  Proof. intros ??. rewrite !ptr_alloc_id_global_ptr. by intros ?%(inj _)%(inj _). Qed.

  Lemma ptr_vaddr_nullptr : ptr_vaddr nullptr = Some 0%N.
  Proof. done. Qed.

  Lemma ptr_alloc_id_nullptr : ptr_alloc_id nullptr = Some null_alloc_id.
  Proof. done. Qed.

  #[local] Instance ptr_eq_dec' : EqDecision ptr := ptr_eq_dec.

  (* Instance ptr_equiv : Equiv ptr := (=).
  Instance offset_equiv : Equiv offset := (=).
  Instance ptr_equivalence : Equivalence (≡@{ptr}) := _.
  Instance offset_equivalence : Equivalence (==@{offset}) := _.
  Instance ptr_equiv_dec : RelDecision (≡@{ptr}) := _.
  Instance offset_equiv_dec : RelDecision (==@{offset}) := _. *)

  (* Instance dot_assoc : Assoc (≡) o_dot := _. *)
  (* Instance dot_proper : Proper ((≡) ==> (≡) ==> (≡)) o_dot := _. *)

  Definition __offset_ptr (p : ptr) (o : offset) : ptr :=
    match p with
    | offset_ptr p' o' => offset_ptr p' (__o_dot o' o)
    | invalid_ptr_ => invalid_ptr_ (* too eager! *)
    | fun_ptr_ _ _ =>
      match `o with
      | [] => p
      | _ => invalid_ptr_
      end
    end.

  Include PTRS_SYNTAX_MIXIN.
  (* Duplicated. *)
  #[global] Notation "p ., o" := (_dot p (o_field _ o))
    (at level 11, left associativity, only parsing) : stdpp_scope.

  #[local] Ltac UNFOLD_dot := rewrite _dot.unlock/DOT_dot/=.

  (* [eval_offset] respects the monoidal structure of [offset]s *)
  Lemma eval_offset_dot : ∀ σ (o1 o2 : offset),
    eval_offset σ (o1 ,, o2) =
    add_opt (eval_offset σ o1) (eval_offset σ o2).
  Proof.
    intros **; UNFOLD_dot.
    destruct o1 as [[] ?]; destruct o2 as [[] ?]=> //=.
    - unfold __o_dot, raw_offset_merge, raw_offset_collapse; simpl.
      unfold eval_offset, eval_raw_offset; simpl.
      unfold raw_offset_wf, raw_offset_collapse in r0; simpl in r0.
      rewrite r0/=.
      destruct (eval_offset_seg o);
        destruct (foldr (liftM2 Z.add) (Some 0) (map eval_offset_seg l))=> //.
    - rewrite __o_dot_nil_r.
      unfold eval_offset, eval_raw_offset=> /=.
      destruct (liftM2 Z.add (eval_offset_seg o)
                       (foldr (liftM2 Z.add) (Some 0) (map eval_offset_seg l)))=> //.
      unfold add_opt; simpl.
      by rewrite Z.add_0_r.
    - unfold __o_dot, raw_offset_merge, raw_offset_collapse, eval_offset, eval_raw_offset.
      unfold proj1_sig; rewrite foldr_app.
      unfold raw_offset_wf, raw_offset_collapse in *.
      rewrite !foldr_fmap.
      rewrite r0.
      admit.
  Admitted.

  #[global] Instance id_dot : LeftId (=) o_id o_dot.
  Proof. UNFOLD_dot. intros o. apply /sig_eq_pi. by case: o. Qed.
  Lemma __o_dot_id : RightId (=) o_id __o_dot.
  Proof.
    intros o. apply /sig_eq_pi.
    rewrite /= /raw_offset_merge (right_id []).
    by case: o.
  Qed.
  #[global] Instance dot_id : RightId (=) o_id o_dot.
  Proof. UNFOLD_dot. apply __o_dot_id. Qed.
  #[global] Instance dot_assoc : Assoc (=) o_dot.
  Proof.
    UNFOLD_dot.
    intros o1 o2 o3. apply /sig_eq_pi.
    move: o1 o2 o3 => [ro1 /= wf1]
      [ro2 /= wf2] [ro3 /= wf3].
      rewrite /raw_offset_merge.
      rewrite -{1}wf1 -{2}wf3.
      rewrite -!invol_app; f_equiv.
      apply: assoc.
  Qed.

  Implicit Types (p : ptr) (o : offset).

  Lemma offset_ptr_id p : p ,, o_id = p.
  Proof. UNFOLD_dot. case: p => // p o. by rewrite /__offset_ptr __o_dot_id. Qed.

  Lemma offset_ptr_dot p o1 o2 : p ,, (o1 ,, o2) = p ,, o1 ,, o2.
  Proof.
    (* TO FIX: collapse function pointers with offsets less eagerly. *)
    UNFOLD_dot.
    destruct p; rewrite //= ?assoc //=.
    move: o1 o2 => [o1 /= +] [o2 /= +]; rewrite /raw_offset_wf => WF1 WF2.
    repeat (case_match; simplify_eq/= => //).
    by rewrite H in WF2.
  Admitted.

  Lemma o_sub_0 σ ty :
    is_Some (size_of σ ty) ->
    o_sub σ ty 0 = o_id.
  Proof. rewrite /o_sub; case_decide=>// -[?]; by case: size_of. Qed.

  Lemma ptr_alloc_id_offset {p o} :
    let p' := p ,, o in
    is_Some (ptr_alloc_id p') -> ptr_alloc_id p' = ptr_alloc_id p.
  Proof. UNFOLD_dot. by destruct p, o as [[] ?] => //= /is_Some_None []. Qed.

  Axiom ptr_vaddr_o_sub_eq : forall p σ ty n1 n2 sz,
    size_of σ ty = Some sz -> (sz > 0)%N ->
    same_property ptr_vaddr (p ,, o_sub _ ty n1) (p ,, o_sub _ ty n2) ->
    n1 = n2.

  Arguments mk_offset_seg _ !_ /.
  Lemma o_dot_sub σ (z1 z2 : Z) ty :
    o_sub σ ty z1 ,, o_sub σ ty z2 = o_sub σ ty (z1 + z2).
  Proof.
    UNFOLD_dot.
    intros. apply /sig_eq_pi => /=.
    rewrite /o_sub /= /mkOffset. repeat case_decide => //=.
    all: subst; try lia.
    all: rewrite ?Z.add_0_r ?Z.add_0_l.
    all: rewrite /mk_offset_seg /= /o_sub_off; case: size_of => [sz|] //=.
    all: try by rewrite decide_False //=; lia.
    all: repeat (case_decide; try (lia || by auto)).
    repeat (lia || f_equiv).
  Qed.

  Lemma o_base_derived σ p base derived :
    directly_derives σ derived base ->
    p ,, o_base σ derived base ,, o_derived σ base derived = p.
  Proof.
    rewrite -offset_ptr_dot; UNFOLD_dot.
    intros Hsome. destruct p => //=.
    (* TODO: this model collapses invalid offsets on fun_ptr_ to invalid pointers too eagerly. *)
    admit.
    f_equiv.
    apply (sig_eq_pi _) => /=.
    move: Hsome => [?].
    rewrite /o_base_off /o_derived_off parent_offset.unlock.
    destruct parent_offset_tu => //= -[_] /=.
    rewrite /raw_offset_merge/=.
    rewrite /raw_offset_collapse /=.
    rewrite foldr_app /=.
    (* TODO: here we should prove that cancellation works out, but the
    ill-behaved normalization makes this too complex. *)
  Admitted.

  Lemma o_derived_base σ p base derived :
    directly_derives σ derived base ->
    p ,, o_derived σ base derived ,, o_base σ derived base = p.
  Proof.
    rewrite -offset_ptr_dot; UNFOLD_dot.
    intros Hsome. destruct p => //=.
    {
      case_match => //.
      exfalso.
      Fail repeat case_match; naive_solver.
      (* TODO: this model collapses invalid offsets on fun_ptr_ to invalid
      pointers too eagerly. *)
      admit.
    }
    f_equiv.
    case: o => o. rewrite /raw_offset_wf => Hwf.
    apply (sig_eq_pi _) => /=.
    move: Hsome => [?].
    rewrite /o_base_off /o_derived_off parent_offset.unlock.
    destruct parent_offset_tu => //= -[_] /=.
    rewrite decide_True //=.
    rewrite /raw_offset_merge/= app_nil_r //.
    all: done.
  Admitted.

  Include PTRS_DERIVED_MIXIN.
  Include PTRS_MIXIN.
End PTRS_IMPL.