(*

  Copyright 2014 Cornell University
  Copyright 201% Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export alphaeq.
Require Export cvterm2.
Require Export terms_props.

Lemma fold_image {p} :
  forall (a b : @NTerm p), oterm (Can NImage) [ nobnd a, nobnd b ] = mk_image a b.
Proof.
  sp.
Qed.

Lemma lsubstc_mk_image {o} :
  forall A B sub,
  forall wA : wf_term A,
  forall wB : @wf_term o B,
  forall w  : wf_term (mk_image A B),
  forall cA : cover_vars A sub,
  forall cB : cover_vars B sub,
  forall c  : cover_vars (mk_image A B) sub,
   lsubstc (mk_image A B) w sub c =
             mkc_image (lsubstc A wA sub cA)
                         (lsubstc B wB sub cB).
Proof.
  sp; unfold lsubstc; simpl.
  apply cterm_eq; simpl.
  unfold csubst; simpl.
  change_to_lsubst_aux4; simpl.
  rw @sub_filter_nil_r.
  allrw @fold_nobnd;
  rw @fold_image; auto.
Qed.

Lemma lsubstc_mk_image_ex {p} :
  forall t1 t2 sub,
  forall w  : wf_term (@mk_image p t1 t2),
  forall c  : cover_vars (mk_image t1 t2) sub,
    {w1 : wf_term t1
     & {w2 : wf_term t2
     & {c1 : cover_vars t1 sub
     & {c2 : cover_vars t2 sub
        & lsubstc (mk_image t1 t2) w sub c
             = mkc_image (lsubstc t1 w1 sub c1)
                        (lsubstc t2 w2 sub c2)}}}}.
Proof.
  sp.

  assert (wf_term t1) as w1.
  { allrw <- @wf_image_iff; sp. }

  assert (wf_term t2) as w2.
  { allrw <- @wf_image_iff; sp. }

  assert (cover_vars t1 sub) as c1.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }

  assert (cover_vars t2 sub) as c2.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }

  exists w1 w2 c1 c2.
  apply lsubstc_mk_image.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Preservation of typing during register allocation. *)

Require Import Coqlib.
Require Import Maps.
Require Import Errors.
Require Import AST.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import Locations.
Require Import LTL.
Require Import Coloring.
Require Import Coloringproof.
Require Import Allocation.
Require Import Allocproof.
Require Import RTLtyping.
Require Import LTLtyping.
Require Import Conventions.

(** This file proves that register allocation (the translation from
  RTL to LTL defined in file [Allocation]) preserves typing:
  given a well-typed RTL input, it produces LTL code that is
  well-typed. *)

Section WITHEF.
Context `{Hsc: SyntaxConfiguration}.

Section TYPING_FUNCTION.

Variable f: RTL.function.
Variable env: regenv.
Variable live: PMap.t Regset.t.
Variable alloc: reg -> loc.
Variable tf: LTL.function.

Hypothesis TYPE_RTL: type_function f = OK env.
Hypothesis LIVE: analyze f = Some live.
Hypothesis ALLOC: regalloc f live (live0 f live) env = Some alloc.
Hypothesis TRANSL: transf_function f = OK tf.

Lemma wt_rtl_function: RTLtyping.wt_function f env.
Proof.
  apply type_function_correct; auto.
Qed.

Lemma alloc_type: forall r, Loc.type (alloc r) = env r.
Proof.
  intro. eapply regalloc_preserves_types; eauto.
Qed.

Lemma alloc_types:
  forall rl, List.map Loc.type (List.map alloc rl) = List.map env rl.
Proof.
  intros. rewrite list_map_compose. apply list_map_exten.
  intros. symmetry. apply alloc_type.
Qed.

Lemma alloc_acceptable:
  forall r, loc_acceptable (alloc r).
Proof.
  intros. eapply regalloc_acceptable; eauto.
Qed.

Lemma allocs_acceptable:
  forall rl, locs_acceptable (List.map alloc rl).
Proof.
  intros. eapply regsalloc_acceptable; eauto.
Qed.

Remark transf_unroll:
  tf = transf_fun f live alloc.
Proof.
  generalize TRANSL. unfold transf_function.
  rewrite TYPE_RTL. rewrite LIVE. rewrite ALLOC. congruence.
Qed.

Lemma valid_successor_transf:
  forall s,
  RTLtyping.valid_successor f s ->
  LTLtyping.valid_successor tf s.
Proof.
  unfold RTLtyping.valid_successor, LTLtyping.valid_successor.
  intros s [i AT].
  rewrite transf_unroll; simpl. rewrite PTree.gmap.
  rewrite AT. exists (transf_instr f live alloc s i). auto.
Qed.

Hint Resolve alloc_acceptable allocs_acceptable: allocty.
Hint Rewrite alloc_type alloc_types: allocty.
Hint Resolve valid_successor_transf: allocty.

(** * Type preservation during translation from RTL to LTL *)

Ltac WT :=
  constructor; auto with allocty; autorewrite with allocty; auto.

Lemma wt_transf_instr:
  forall pc instr,
  RTLtyping.wt_instr env f instr ->
  f.(RTL.fn_code)!pc = Some instr ->
  wt_instr tf (transf_instr f live alloc pc instr).
Proof.
  intros. inv H; simpl.
  (* nop *)
  WT.
  (* move *)
  destruct (Regset.mem r live!!pc).
  destruct (is_redundant_move Omove (r1 :: nil) r alloc); WT.
  WT.
  (* other ops *)
  destruct (Regset.mem res live!!pc).
  destruct (is_redundant_move op args res alloc); WT.
  WT.
  (* load *)
  destruct (Regset.mem dst live!!pc); WT.
  (* store *)
  WT.
  (* call *)
  exploit regalloc_correct_1; eauto. unfold correct_alloc_instr.
  intros [A1 [A2 A3]].
  WT.
  destruct ros; simpl; auto.
  split. autorewrite with allocty; auto.
  split. auto with allocty. auto.
  (* tailcall *)
  exploit regalloc_correct_1; eauto. unfold correct_alloc_instr.
  intro A1.
  WT.
  destruct ros; simpl; auto.
  split. autorewrite with allocty; auto.
  split. auto with allocty. auto.
  rewrite transf_unroll; auto.
  (* builtin *)
  WT.
  (* cond *)
  WT.
  (* jumptable *)
  WT.
  (* return *)
  WT.
  rewrite transf_unroll; simpl.
  destruct optres; simpl. autorewrite with allocty. auto. auto.
  destruct optres; simpl; auto with allocty.
Qed.

End TYPING_FUNCTION.

Lemma wt_transf_function:
  forall f tf,
  transf_function f = OK tf -> wt_function tf.
Proof.
  intros. generalize H; unfold transf_function.
  caseEq (type_function f). intros env TYP.
  caseEq (analyze f). intros live ANL.
  change (transfer f (RTL.fn_entrypoint f)
                     live!!(RTL.fn_entrypoint f))
    with (live0 f live).
  caseEq (regalloc f live (live0 f live) env).
  intros alloc ALLOC.
  intro EQ; injection EQ; intro.
  assert (RTLtyping.wt_function f env). apply type_function_correct; auto.
  inversion H1.
  constructor; rewrite <- H0; simpl.
  rewrite (alloc_types _ _ _ _ ALLOC). auto.
  eapply regsalloc_acceptable; eauto.
  eapply regalloc_norepet_norepet; eauto.
  eapply regalloc_correct_2; eauto.
  intros until instr. rewrite PTree.gmap.
  caseEq (RTL.fn_code f)!pc; simpl; intros.
  inversion H3. eapply wt_transf_instr; eauto. congruence. discriminate.
  eapply valid_successor_transf; eauto. congruence.
  congruence. congruence. congruence.
Qed.

Lemma wt_transf_fundef:
  forall f tf,
  transf_fundef f = OK tf -> wt_fundef tf.
Proof.
  intros until tf; destruct f; simpl.
  caseEq (transf_function f); simpl. intros g TF EQ. inversion EQ.
  constructor. eapply wt_transf_function; eauto.
  congruence.
  intros. inversion H. constructor.
Qed.

Lemma program_typing_preserved:
  forall (p: RTL.program) (tp: LTL.program),
  transf_program p = OK tp ->
  LTLtyping.wt_program tp.
Proof.
  intros; red; intros.
  generalize (transform_partial_program_function transf_fundef p i f H H0).
  intros [f0 [IN TRANSF]].
  apply wt_transf_fundef with f0; auto.
Qed.

End WITHEF.


#[global]
Set Primitive Projections.
#[global]
Unset Printing Primitive Projection Parameters.

#[global]
Set Universe Polymorphism.

#[global]
Set Default Goal Selector "!".

Require Import Coq.Unicode.Utf8.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.
Require Psatz.
Require Import Recdef.

Import IfNotations.
Import ListNotations.

Close Scope nat.

Reserved Notation "'some' x .. y , P"
         (at level 200, x binder, y binder, right associativity,
          format "'[ ' '[ ' 'some'  x .. y ']' ,  '/' P ']'").

#[universes(cumulative)]
Record someT [A] (P: A → Type) := some_intro { head: A ; tail: P head ; }.

Arguments some_intro [A P].
Arguments head [A P].
Arguments tail [A P].

Module SomeNotations.
  Add Printing Let someT.

  Notation "'some' x .. y , P" := (someT (λ x, .. (someT (λ y,  P)) .. )) : type_scope.
End SomeNotations.

Module CylPoly.
  #[universes(cumulative)]
  Record Poly := {
    pos: Type ;
    dir: pos → string → Type ;
  }.

  Coercion pos: Poly >-> Sortclass.

  Definition CoYo (Γ: string → Type) : Poly := {|
    pos := unit ;
    dir _ := Γ ;
  |}.

  Definition K A: Poly := {| dir (_: A) _ := Empty_set |}.

  Definition I: Poly := {|
    pos := unit ;
    dir _ _ := unit  ;
  |}.

  Record ext (P: Poly) (Γ: string → Type) :=
    sup {
        tag: _ ;
        field v: dir P tag v → Γ v ;
      }.

  Arguments sup {P Γ}.
  Arguments tag {P Γ}.
  Arguments field {P Γ}.

  Coercion ext: Poly >-> Funclass.

  Definition map {H: Poly} {A B} (f: ∀ v, A v → B v) (x: H A): H B :=
      sup (tag x) (fun v y => f v (field x v y)).

  Definition Π {A: Type} (p: A → Poly): Poly :=
    {|
    pos := ∀ i, pos (p i) ;
    dir s x := someT (fun i => dir (p i) (s i) x) ;
    |}.
  Definition exp A B := Π (λ _: A, B).

 Definition bind (p: Poly) (q: string → Poly): Poly :=
    {|
    pos := p (λ x, pos (q x)) ;
    dir s x :=
      someT (fun i => dir (q x) (field s x i) x) ;
    |}.

  Definition compose x q p := bind p (λ y, exp (y = x) q).

  Definition Σ {A} (p: A → Poly): Poly :=
    {|
    pos := someT (fun i => pos (p i)) ;
    dir s x := dir (p (head s)) (tail s) x ;
    |}.

  Definition prod (p q: Poly): Poly :=
    {|
    pos := pos p * pos q ;
    dir '(x, y) v := dir p x v + dir q y v ;
    |}.

  Definition sum (p q: Poly): Poly :=
    {|
    pos := pos p + pos q ;
    dir s v :=
      match s with
      | inl x' => dir p x' v
      | inr x' => dir q x' v
      end ;
    |}.

  (* FIXME hacky *)
  Definition V x: Poly := CoYo (λ y, x = y).
  Definition subst (x: string) (A: Type) Γ := λ y, if string_dec x y then A else Γ y.

  Definition scope (x: string) (A: Type) (Γ: string → Type) :=
    λ y, {_: A | x = y } + { _: Γ y | x ≠ y }.

  Definition All x S: Poly := CoYo (λ y, x = y → S).

  Infix "*" := prod.
  Infix "+" := sum.

  (* FIXME not good *)
  Definition diag (x y: string) :=
    Σ (λ (Γ: string → Type), {|
         pos := Γ x → Γ y ;
         dir _ := Γ ;
       |}).

  Infix "~>" := diag (at level 30).

  Inductive w x (p: Poly) (Γ: string → Type) :=
  | rec (_: p (scope x (w x p Γ) Γ)).

  Definition mt := λ _: string, Empty_set.
  Definition put (x: string) (A: Type) Γ := λ y, if string_dec x y then A else Γ y.

  Fixpoint oflist (l: list (string * Type)): string → Type :=
    match l with
    | nil => mt
    | cons (X, A) T => put X A (oflist T)
    end.

  Open Scope string_scope.

  Example plist A := w "x" (K unit + K A * V "x") mt.
  Example pnil {A}: plist A.
  Proof.
    cbn in *.
    exists.
    exists (inl tt).
    cbn in *.
    intros ? ?.
    contradiction.
  Defined.

  Example pcons {A} (h: A) (t: plist A): plist A.
  Proof.
    cbn in *.
    exists.
    exists (inr (h, tt)).
    cbn in *.
    intros ? [?|?].
    1: contradiction.
    subst.
    left.
    exists.
    2: reflexivity.
    apply t.
  Defined.

  Fixpoint poflist {A} (l: list A): plist A :=
    match l with
    | nil => pnil
    | cons H T => pcons H (poflist T)
    end.

  Example foo {A B} (x: A) (y: B): ext (V "x" * V "y") (oflist [("x", A) ; ("y", B)]).
    exists (tt, tt).
    intros ? [?|?].
    all: cbn in *.
    all: subst.
    - apply x.
    - apply y.
  Defined.

  Example gar {A B} (f: A → B): ext ("x" ~> "y") (oflist [("x", A) ; ("y", B)]).
  Proof.
    cbn.
    eexists (some_intro (oflist [("x", A) ; ("y", B)]) _).
    Unshelve.
    2: {
      cbn.
      apply f.
    }
    cbn.
    intros.
    auto.
  Defined.

  Example bar := poflist ["foo" ; "bar" ; "xar"].
End CylPoly.

(* Free monad on a polynomial endofunctor *)
Module Poly.
  #[universes(cumulative)]
   Record Poly := {
    pos: Type ;
    dir: pos → Type ;
  }.

  Coercion pos: Poly >-> Sortclass.

  (* Definition K A: Poly := {| dir (_: A) := Empty_set |}. *)

  Record ext (P: Poly) A :=
    sup {
        tag: _ ;
        field: dir P tag → A ;
      }.

  Arguments sup {P A}.
  Arguments tag {P A}.
  Arguments field {P A}.

  Infix "!" := field (at level 30).

  Coercion ext: Poly >-> Funclass.

  Definition X: Poly := {| dir (_: unit) := unit |}.

  Definition CoYo (A:  Type) : Poly := {|
    pos := unit ;
    dir _ := A ;
  |}.

  Definition compose (p q: Poly): Poly :=
    {|
    pos := p (pos q) ;
    dir s := someT (fun i => dir q (s ! i)) ;
    |}.
  Infix "∘" := compose (at level 30).

  Definition Π {A} (p: A → Poly): Poly :=
    {|
    pos := ∀ i, pos (p i) ;
    dir s := someT (fun i => dir (p i) (s i)) ;
    |}.
  Definition Σ {A} (p: A → Poly): Poly :=
    {|
    pos := someT (fun i => pos (p i)) ;
    dir s := dir (p (head s)) (tail s) ;
    |}.

  Definition prod (p q: Poly): Poly :=
    {|
    pos := pos p * pos q ;
    dir '(x, y) := dir p x + dir q y ;
    |}.

  Definition sum (p q: Poly): Poly :=
    {|
    pos := pos p + pos q ;
    dir s :=
      match s with
      | inl x' => dir p x'
      | inr x' => dir q x'
      end ;
    |}.

  Infix "*" := prod.
  Infix "+" := sum.

  Definition exp A B := Π (λ _: A, B).
End Poly.

Module PolyCat.
  Module Import Cat.
    Inductive Obj := init | term | sum (_ _: Obj) | exp (_ _: Obj).
    Inductive Mor: Obj → Obj → Type :=
    | id A: Mor A A
    | compose {A B C}: Mor B C → Mor A B → Mor A C
    | absurd {A}: Mor init A
    .
  End Cat.

  Module Import Dis.
    Record Dis := {
      pos: Type ;
      dir: pos → Obj ;
    }.

    Record Mor (A B: Dis) := {
      pos_Mor: pos A → pos B  ;
      dir_Mor x: Cat.Mor (dir B (pos_Mor x)) (dir A x) ;
    }.

    Arguments pos_Mor {A B}.
    Arguments dir_Mor {A B}.

    Record ext (P: Dis) (x: Obj) := sup {
       tag: pos P ;
       field: Cat.Mor (dir P tag) x ;
    }.

    Arguments sup {P x}.
    Arguments tag {P x}.
    Arguments field {P x}.

    Coercion ext: Dis >-> Funclass.

    Definition Yo (x: Obj): Dis := {| dir (_: unit) := x |}.
    Definition K (x: Type): Dis := {| dir (_: x) := init |}.

    Definition Π {A} (p: A → Dis): Dis :=
    {|
      pos := A * (∀ i, pos (p i)) ;
      dir '(x, f) := dir (p x) (f x) ;
    |}.

    Definition Σ {A} (p: A → Dis): Dis := {|
      pos := someT (fun i => pos (p i)) ;
      dir s := dir (p (head s)) (tail s) ;
    |}.

    Definition prod (p q: Dis): Dis := {|
      pos := pos p * pos q ;
      dir '(x, y) := sum (dir p x) (dir q y) ;
     |}.

    Definition sum (p q: Dis): Dis := {|
      pos := pos p + pos q ;
      dir v :=
        match v with
        | inl v' => dir p v'
        | inr v' => dir q v'
        end ;
     |}.
  End Dis.

  #[universes(cumulative)]
  Record Poly := {
    pos: Dis ;
    dir: Dis.Mor pos {| pos := Dis ; dir _ := init ; |} ;
  }.

  #[program]
  Definition X: Poly := {|
    pos := Yo term ;
    dir := {|
            pos_Mor _ := Yo term ;
            dir_Mor _ := absurd ;
           |} ;
  |}.

  #[program]
  Definition CoYo (A: Dis) : Poly := {|
    pos := Yo term  ;
    dir := {|
            pos_Mor _ := A ;
            dir_Mor _ := absurd ;
          |}
  |}.

  (* Definition comp (p q: Poly): Poly := *)
  (*   {| *)
  (*   pos := p (pos q) ; *)
  (*   dir s := someT (fun i => dir q (field s i)) ; *)
  (*   |}. *)
  (* Infix "∘" := compose (at level 30). *)

  #[program]
  Definition Σ {A} (p: A → Poly): Poly :=
    {|
    pos := Σ (fun i => pos (p i)) ;
    dir :=
      {|
        pos_Mor x := pos (p (head x)) ;
        dir_Mor x := _ ;
       |}
    |}.

  #[program]
  Definition Π {A} (p: A → Poly): Poly :=
    {|
    pos := Π (λ i, pos (p i)) ;
    dir := {|
            pos_Mor '(x, f) := _ ;
          |}
  |}.

  Next Obligation.
  Proof.
    cbn in *.
    apply (dir (p (head x))).
  Defined.

  #[program]
  Definition K A: Poly := {|
    pos := A ;
    dir := {|
            pos_Mor _ := Yo init ;
            dir_Mor _ := absurd ;
          |} ;
  |}.

  #[program]
  Definition prod (p q: Poly): Poly :=
    {|
     pos := Dis.prod (pos p) (pos q) ;
     dir :=
       {|
         pos_Mor '(x, y) := Yo (Cat.sum (Dis.dir (pos p) x) (Dis.dir (pos q) y)) ;
         dir_Mor _ := absurd ;
       |} ;
    |}.

  #[program]
  Definition sum (p q: Poly): Poly :=
    {|
    pos := sum (pos p) (pos q) ;
    dir :=
      {|
        pos_Mor v :=
          match v with
          | inl v' => Yo (Dis.dir (pos p) v')
          | inr v' => Yo (Dis.dir (pos q) v')
          end ;
        dir_Mor _ := absurd ;
      |}
    |}.

  Infix "*" := prod.
  Infix "+" := sum.

  (* Definition exp A B := Π (λ _: A, B). *)
End PolyCat.

Module Span.
  #[universes(cumulative)]
   Record span A B := {
    s: Type ;
    π1: s → A ;
    π2: s → B ;
  }.

  Arguments s {A B}.
  Arguments π1 {A B}.
  Arguments π2 {A B}.
  Coercion s: span >-> Sortclass.

  Definition id A: span A A := {| π1 x := x ; π2 x := x |}.
  Definition compose {A B C} (f: span B C) (g: span A B) := {|
    s := { xy : s f * s g | π1 f (fst xy) = π2 g (snd xy) } ;
    π1 x := π1 g (snd (proj1_sig x)) ;
    π2 x := π1 f (fst (proj1_sig x)) ;
  |}.

  Infix "∘" := compose (at level 30).

  #[universes(cumulative)]
  Class Span_Mor {A B} {s: span A B} {t: span A B} (f: s → t) := {
    map_π1 x: π1 t (f x) = π1 s x ;
    map_π2 x: π2 t (f x) = π2 s x ;
  }.

  Inductive ext {A B} (p: span A B): A → B → Type :=
  | sup x : ext p (π1 p x) (π2 p x).

  Coercion ext: span >-> Funclass.

  Definition map {A B} (f: A → B): span A B :=
    {| π1 x := x ;
       π2 := f ;
     |}.

  Definition K {A B} (x: A) (y: B): span A B :=
    {|
    s := unit ;
    π1 _ := x ;
    π2 _ := y ;
    |}.

  Definition transpose {A B} (p: span A B): span B A :=
    {|
    s := s p ;
    π1 := π2 p ;
    π2 := π1 p ;
    |}.

  Definition sum {A B} (p q: span A B): span A B :=
    {|
    s := s p + s q ;
    π1 s :=
      match s with
      | inl x' => π1 p x'
      | inr x' => π1 q x'
      end ;
    π2 s :=
      match s with
      | inl x' => π2 p x'
      | inr x' => π2 q x'
      end ;
    |}.

  Definition Σ {B C} {A: span B C} (p: A → span B C): span B C :=
    {|
    s := someT (fun i => s (p i)) ;
    π1 s := π1 (p (head s)) (tail s) ;
    π2 s := π2 (p (head s)) (tail s) ;
    |}.

  Definition prod {A B} (f g: span A B): span A B :=
    {|
    s := { xy : s f * s g |
           π1 f (fst xy) = π1 g (snd xy) ∧
           π2 f (fst xy) = π2 g (snd xy)
         } ;
    π1 s := π1 f (fst (proj1_sig s)) ;
    π2 s := π2 f (fst (proj1_sig s)) ;
    |}.

  (* Not sure about this *)
  Definition Π {B C} {A} (p: A → span B C): span B C :=
    {|
    s := { xy :
             A *
             (∀ i, s (p i)) |
           (∀ i j,
           π1 (p i) (snd xy i) = π1 (p j) (snd xy j) ∧
           π2 (p i) (snd xy i) = π2 (p j) (snd xy j))
         } ;
    π1 s :=
      let y := fst (proj1_sig s) in
      π1 (p y) (snd (proj1_sig s) y) ;
    π2 s :=
      let y := fst (proj1_sig s) in
      π2 (p y) (snd (proj1_sig s) y) ;
    |}.

  Record Poly B C := {
    S: span B C ;
    π: S → Type ;
  }.

  #[program]
  Definition poly {B C} (S: span B C) (p: S → span B C) (X: span B C) :=
    Σ (λ y: S,
            {|
              s := p y → X ;
              π1 f := _ ;
              π2 f := _ ;
            |}).

  Next Obligation.
  Check poly.
  Infix "∧" := prod.
  Infix "∨" := sum.

  Check poly.
  Notation "'Σ' x .. y , P" := (Σ (λ x, .. (Σ (λ y,  P)) .. ))
         (at level 200, x binder, y binder, right associativity,
          format "'[ ' '[ ' 'Σ'  x .. y ']' ,  '/' P ']'").
End Span.
Module Stlc.
  Import Span.

  Inductive sort :=
  | pt
  | exp (τ0 τ1: sort).

  Inductive term :=
  | lam (x: string) (τ: sort) (e: term)
  | app (e0 e1: term)
  | var (x: string)
  .

  Definition env := list (string * sort).

  Inductive fact := ofty (Γ: env) (e: term) (τ: sort).
  Notation "Γ ⊢ e ∈ τ" := (ofty Γ e τ) (at level 30).

  Example judge: span (list fact) (list fact) :=
    Σ A,
      K A [] ∨
    Σ A B T,
      K (A :: B :: T)
        (B :: A :: T) ∨
    Σ A B T,
      K (A :: B :: T)
        (A :: T) ∨
    Σ A B T,
      K (A :: B :: T)
        (B :: T) ∨
    Σ Γ e τ T,
      K (Γ ⊢ e ∈ τ :: T)
        (Γ ⊢ e ∈ τ :: T)
  .

  Inductive rule {Γ: string → fact} :=
  | ignore_rule (A: list fact)
  | swap_rule (T: list fact) (A B: fact)
  | fst_rule (T: list fact) (A B: fact)
  | snd_rule (T: list fact) (A B: fact)

  | lookup_rule (T: list fact) (x: string)
  .
  Arguments rule: clear implicits.

  Example judge (Γ: string → fact) (r: rule Γ): (list fact * list fact) :=
    match r with
    | ignore_rule A =>
      (A,
       [])
    | lookup_rule T x =>
      (T,
       Γ x :: T)
    | swap_rule T A B =>
      (A :: B :: T,
       B :: A :: T)
    | fst_rule T A B =>
      (A :: B :: T,
       A :: T)
    | snd_rule T A B =>
      (A :: B :: T,
       B :: T)
    end.

  Example theory: displayed fact := {|
    map e := {|
              π1 r := fst (judge e r) ;
              π2 r := snd (judge e r) ;
            |} ;
  |}.
  Definition theorem := free theory.

  Example ignore Γ A: theorem Γ A [] := sup (map theory _) (ignore_rule A).
  Example lookup Γ x: theorem Γ [] [Γ x] := sup (map theory _) (lookup_rule [] x).

  Example swap' Γ A B T: theorem Γ (A :: B :: T) (B :: A :: T) := sup (map theory _) (swap_rule T A B).

  Example app' Γ e0 e1 τ0 τ1: free theory _ [_ ; _] [_] := sup (map theory _) (app_rule Γ e0 e1 τ0 τ1).

  Check app'.
  Definition sort_dec (x y: sort): {x = y} + {x ≠ y}.
  Proof.
    decide equality.
  Defined.
x
  Function lookup (x: string) (Γ: env): option sort :=
    match Γ with

    | (y, τ) :: T => if string_dec x y then Some τ else lookup x T
    | _ => None
    end.

  Function infer (Γ: env) (e: term): option sort :=
    match e with
    | var x => lookup x Γ
    | lam x τ0 e =>
      if infer ((x, τ0)::Γ) e is Some τ1
      then
        Some (exp τ0 τ1)
      else
        None
    | app e0 e1 =>
      if infer Γ e0 is Some (exp τ0 τ1)
      then
        if infer Γ e1 is Some τ0'
        then
          if sort_dec τ0 τ0'
          then
            Some τ1
          else
            None
        else
          None
      else
        None
    end.

  Definition sound {Γ e τ}:
    infer Γ e = Some τ →
    theorem [] [Γ ⊢ e ∈ τ].
  Proof.
    generalize dependent τ.
    functional induction (infer Γ e).
    all: intros τ p.
    all: inversion p.
    all: subst.
    2: {
      refine (lam' Γ x τ0 τ1 e0 ∘ _).
      apply IHo.
      auto.
    }
    2: {
      refine (app' Γ e0 e1 τ0 τ ∘ _).
      cbn.

    induction e.
    all: intros Γ A p.
    all: cbn in *.
    all: inversion p.
    all: subst.
    - Check (IHe ((x, τ) :: Γ) A p).
      all: subst.
      + cbn.
End Stlc.

Module Import Finite.
  Fixpoint fin (n: nat) :=
    match n with
    | O => Empty_set
    | S n' => option (fin n')
    end.

  Definition swap N (x: fin (2 + N)): fin (2 + N) :=
    match x with
    | Some (Some e) => Some (Some e)
    | Some None => None
    | None => Some None
    end.

  Definition weaken N (x: fin N): fin (S N) := Some x.

  Definition contract N (x: fin (2 + N)): fin (S N) :=
    match x with
    | Some (Some e) => Some e
    | Some None => None
    | None => None
    end.

  (* Not really sure about this *)
  Definition fold N (x: fin (N + N)): fin N.
  Proof.
    induction N.
    - cbn in *.
      contradiction.
    - cbn in *.
      rewrite Nat.add_comm in x.
      cbn in *.
      refine (match x with
              | Some (Some x') => Some (IHN x')
              | _ => None
              end).
  Defined.

End Finite.

(* Free category on an endospan/free monad in Span(Set) *)
Module Cat.
  Import Span.

  (* Doesn't seem right *)
  #[universes(cumulative)]
   Inductive free {Obj} (H: span Obj Obj): Obj → Obj → Type :=
  | id A: free H A A
  | compose {A B C}: free H B C → free H A B → free H A C
  | sup x: free H (π1 H x) (π2 H x)
  .
  Arguments id {Obj H}.
  Arguments compose {Obj H A B C}.
  Arguments sup {Obj}.
End Cat.

(* Free indexed category on a displayed category *)
Module IxCat.
  Import Span.
  Import Cat.

  Record displayed C := {
    op: C → Type ;
    map (c: C): span (op c) (op c) ;
  }.

  Arguments op {C}.
  Arguments map {C}.

  Coercion op: displayed >-> Funclass.

  (* A displayed category C -> Span defines a functor D -> C *)

  Definition free {V} (H: displayed V) Γ := free (map H Γ).
End IxCat.

Module CylCat.
  Import Span.
  Import Cat.
  Import IxCat.

  Definition displayed V := displayed (string → V).

  (* A cylindrified displayed category [string, V] -> Span defines an
  indexed category [string, V] → Cat *)
  Definition free {V} (H: displayed V) Γ := free H Γ.
End CylCat.

(* Free indexed monad on an indexed polynomial endofunctor *)
Module IxPoly.
   #[universes(cumulative)]
   Record Poly Env := {
    pos: Type ;
    dir: pos → Env → Type ;
  }.

   Arguments pos {Env}.
   Arguments dir {Env}.

   Definition X Γ: Poly Γ := {|
     dir (_: unit) _ := unit ;
   |}.
  (* Definition K A: Poly := {| dir (_: A) := Empty_set |}. *)

  (* Definition Π {A} (p: A → Poly): Poly := *)
  (*   {| *)
  (*   pos := ∀ i, pos (p i) ; *)
  (*   dir s := Σ i, dir (p i) (s i) ; *)
  (*   |}. *)
  (* Definition Sum {A} (p: A → Poly): Poly := *)
  (*   {| *)
  (*   pos := Σ i, pos (p i) ; *)
  (*   dir s := dir (p (head s)) (tail s) ; *)
  (*   |}. *)

  (* Definition prod (p q: Poly): Poly := *)
  (*   {| *)
  (*   pos := pos p * pos q ; *)
  (*   dir '(x, y) := dir p x + dir q y ; *)
  (*   |}. *)

  (* Definition sum (p q: Poly): Poly := *)
  (*   {| *)
  (*   pos := pos p + pos q ; *)
  (*   dir s := *)
  (*     match s with *)
  (*     | inl x' => dir p x' *)
  (*     | inr x' => dir q x' *)
  (*     end ; *)
  (*   |}. *)

  (* Infix "*" := prod. *)
  (* Infix "+" := sum. *)

  #[universes(cumulative)]
  Inductive free {Env} (H: Poly Env) A: Env → Type :=
  | var {Γ}: A Γ → free H A Γ
  | sup {Γ} x: (dir H x Γ → free H A Γ) → free H A Γ.
  Arguments var {Env H A Γ}.
  Arguments sup {Env H A Γ}.

  Definition map {Env} {H: Poly Env} {A B} (f: ∀ Γ, A Γ → B Γ): ∀ {Γ}, free H A Γ → free H B Γ :=
    fix loop Γ x :=
      match x with
      | var v => var (f _ v)
      | sup x p => sup x (fun y => loop _ (p y))
      end.
  Definition join {Env} {H: Poly Env} {A}: ∀ {Γ}, free H (free H A) Γ → free H A Γ :=
    fix loop Γ x :=
      match x with
      | var v => v
      | sup x p => sup x (fun y => loop _ (p y))
      end.
End IxPoly.

(* Free indexed category on an indexed endospan/free indexed monad in Span(Set) *)
  Record bundle B := {
    dom: Type ;
    π: dom → B;
  }.
  Arguments dom {B}.
  Arguments π {B}.
  Coercion dom: bundle >-> Sortclass.

  #[universes(cumulative)]
   Record span {Env} (A B: bundle Env) := {
    s: Type ;
    π1: s → A ;
    π2: s → B ;
  }.

  Arguments s {Env A B}.
  Arguments π1 {Env A B}.
  Arguments π2 {Env A B}.

  Coercion s: span >-> Sortclass.

  #[universes(cumulative)]
   Inductive free {Env} {Obj: bundle Env} (H: span Obj Obj): Env → Obj → Obj → Type :=
  | id {Γ} A: free H Γ A A
  | compose {Γ} {A B C}: free H Γ B C → free H Γ A B → free H Γ A C

  | sup x: (π Obj (π1 H x) = π Obj (π2 H x)) →
            free H (π Obj (π1 H x)) (π1 H x) (π2 H x)
  .
  Arguments id {Env Obj H Γ}.
  Arguments compose {Env Obj H Γ A B C}.
  Arguments sup {Env Obj}.
End IxCat.


From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype seq.
From pcm Require Import options axioms pred.
From pcm Require Import pcm unionmap heap automap.
From htt Require Import model heapauto.
From htt Require Import llist.

Record queue (T : Type) : Type := Queue {front: ptr; back: ptr}.
Definition EmptyQueue : exn := exn_from_nat 100.

Module Queue.
Section Queue.
Variable T : Type.
Notation queue := (queue T).

(* a queue is specified as a singly-linked list split into an initial segment and a last node *)
Definition is_queue (fr bq : ptr) (xs : seq T) :=
  if fr == null then [Pred h | [/\ bq = null, xs = [::] & h = Unit]]
  else [Pred h | exists xt x h',
                 [/\ xs = rcons xt x,
                     valid (h' \+ (bq :-> x \+ bq .+ 1 :-> null)),
                     h = h' \+ (bq :-> x \+ bq .+ 1 :-> null) &
                     h' \In lseg fr bq xt]].

(* the structure itself is a pair of pointers to body + last node *)
(* insertion happens at the last node, and removal at the head *)
Definition shape (q : queue) (xs : seq T) :=
  [Pred h | exists fr bq h',
    [/\ valid (front q :-> fr \+ (back q :-> bq \+ h')),
        h = front q :-> fr \+ (back q :-> bq \+ h') &
        h' \In is_queue fr bq xs]].

(* well-formed queue is a valid heap *)

Lemma shapeD q xs h : h \In shape q xs -> valid h.
Proof. by case=>h1[bq][h'] [] D ->. Qed.

(* empty queue is a pair of null pointers *)

Lemma is_queue_nil fr bq h :
        h \In is_queue fr bq [::] -> [/\ fr = null, bq = null & h = Unit].
Proof.
by rewrite /is_queue; case: eqP=>[->[-> _ ->] | _ [[|y xt][x][h'][]]].
Qed.

(* restructuring the specification for combined list *)

Lemma is_queue_rcons fr bq xt x h :
         h \In is_queue fr bq (rcons xt x) <->
         (exists h', [/\ valid (h' \+ (bq :-> x \+ bq .+ 1 :-> null)),
                         h = h' \+ (bq :-> x \+ bq .+ 1 :-> null) &
                         h' \In lseg fr bq xt]).
Proof.
rewrite /is_queue; split.
- case: eqP; first by move=>-> []; case: xt.
  by move=>N [xt'][x'][h'][/rcons_inj [->->] ???]; exists h'.
case=>h' [D -> H]; case: eqP H=>[->|_ H]; last by vauto.
move: (D)=>/[swap]; case/(lseg_null (validL D))=>->->->.
by rewrite unitL validPtUn.
Qed.

(* pointers should agree in a well-formed queue *)

Lemma backfront fr bq xs h :
        h \In is_queue fr bq xs -> (fr == null) = (bq == null).
Proof.
rewrite /is_queue; case: ifP=>[E [->]_ _| E [xt][x][h'][_] D] //.
by case: eqP D=>// -> /validR; rewrite validPtUn.
Qed.

(* main methods *)

(* new queue is a pair of pointers to an empty segment *)

Program Definition new :
          STsep (emp, [vfun v => shape v [::]]) :=
  Do (x <-- alloc null;
      y <-- alloc null;
      ret (Queue T x y)).
Next Obligation.
(* run the complete program *)
move=>[] _ /= ->; step=>x; step=>y; step=>V.
(* massage the heap to fit the postcondition *)
by exists null, null, Unit; rewrite !unitR /= in V *; rewrite joinC.
Qed.

(* freeing a queue, possible only when it's empty *)

Program Definition free (q : queue) :
          STsep (shape q [::], [vfun _ h => h = Unit]) :=
  Do (dealloc (front q);;
      dealloc (back q)).
Next Obligation.
(* pull out ghosts and precondition *)
move=>q [] _ /= [fr][bq][h][/[swap]->/[swap]].
(* both pointers are null *)
case/is_queue_nil=>->->->; rewrite unitR=>V.
(* run the program *)
by do 2![step]=>_; rewrite unitR.
Qed.

(* for enqueue/dequeue we manipulate the underlying segment directly *)

(* enqueuing is adding a node at the end *)

Program Definition enq (q : queue) (x : T) :
  {xs}, STsep (shape q xs,
               [vfun _ => shape q (rcons xs x)]) :=
  Do (next <-- allocb null 2;
      next ::= x;;
      ba <-- !back q;
      back q ::= next;;
      (if (ba : ptr) == null
         then front q
         else ba .+ 1) ::= next).
Next Obligation.
(* pull out ghosts + precondition *)
move=>q x [xs][] _ /= [fr][bq][h'][D -> H].
(* create the new last node and change the back pointer *)
step=>next; do 3!step.
(* as the pointers agree, test the front one to reason structurally *)
rewrite -(backfront H) unitR; case: ifP H=>Ef; rewrite /is_queue ?Ef.
- (* the queue was empty, set the front pointer to new node *)
  case=>_->->; step; rewrite unitR=>V.
  (* massage the heap and restructure the goal *)
  exists next, next, (next :-> x \+ next.+ 1 :-> null).
  rewrite joinA joinC; split=>//; apply/(@is_queue_rcons _ _ [::]).
  by exists Unit; rewrite unitL; split=>//; exact: (validL V).
(* the queue wasn't empty, link the new node to the last one *)
case=>s2[x2][i2][->] {}D -> H2; step=>V.
(* massage the heap and simplify the goal *)
exists fr, next, (i2 \+ bq :-> x2 \+ bq.+ 1 :-> next \+ next :-> x \+ next.+ 1 :-> null).
split; first by apply: (validX V).
- by rewrite joinC !joinA.
(* the new node conforms to the queue spec *)
apply/is_queue_rcons; exists (i2 \+ bq :-> x2 \+ bq.+ 1 :-> next).
rewrite joinA; split=>//; first by apply: (validX V).
(* assemble the old queue back *)
by apply/lseg_rcons; exists bq, i2; rewrite joinA.
Qed.

(* dequeuing is removing the head node and adjusting pointers *)

Program Definition deq (q : queue) :
  {xs}, STsep (shape q xs,
               fun y h => shape q (behead xs) h /\
                 match y with Val v => xs = v :: behead xs
                            | Exn e => e = EmptyQueue /\ xs = [::] end) :=
  Do (fr <-- !front q;
      if (fr : ptr) == null then throw EmptyQueue
      else
        x <-- !fr;
        next <-- !fr .+ 1;
        front q ::= next;;
        dealloc fr;;
        dealloc fr .+ 1;;
        if (next : ptr) == null
          then back q ::= null;;
               ret x
        else ret x).
Next Obligation.
(* pull out ghosts + precondition *)
move=>q [xs][] _ /= [fr][bq][h][D -> H].
(* read the list, branch *)
step; case: ifP H=>Ef; rewrite /is_queue Ef.
- (* list is empty, throw an exception *)
  case=>->->->/=; step=>V; split=>//.
  (* massage and simplify *)
  exists fr, null, Unit; rewrite unitR in V *; split=>//.
  by rewrite Ef.
(* deconstruct the initial segment *)
case=>[[|y xt]][x][h'][->] {}D {h}-> /=.
- (* segment is empty, so dequeuing returns the last node *)
  case=>->->; do 7!step; rewrite !unitR=>V; split=>//.
  by exists null, null, Unit; rewrite unitR.
(* segment is non-empty, run up to the branching point *)
case=>next [h2][->] H; do 5!step; rewrite !unitL.
case: ifP H=>[/eqP ->|N] H.
- (* null pointer is in the middle of the segment *)
  do 2![step]=>V2.
  (* this contradicts heap validity *)
  case/(lseg_null (validX V2)): H D=>/=-> _ _ /validR.
  by rewrite validPtUn.
(* return the segment head and simplify *)
step=>V; split=>//; exists next, bq, (h2 \+ (bq :-> x \+ bq .+ 1 :-> null)).
by rewrite N; split=>//; vauto; apply: (validX V).
Qed.

End Queue.
End Queue.


Require Import
Crypto.AbstractInterpretation.AbstractInterpretation
Crypto.AbstractInterpretation.Proofs
Crypto.AbstractInterpretation.Wf
Crypto.AbstractInterpretation.WfExtra
Crypto.AbstractInterpretation.ZRange
Crypto.AbstractInterpretation.ZRangeProofs
Crypto.Algebra.Field
Crypto.Algebra.Field_test
Crypto.Algebra.Group
Crypto.Algebra.Hierarchy
Crypto.Algebra.IntegralDomain
Crypto.Algebra.Monoid
Crypto.Algebra.Nsatz
Crypto.Algebra.NsatzTactic
Crypto.Algebra.Ring
Crypto.Algebra.ScalarMult
Crypto.Algebra.SubsetoidRing
Crypto.Arithmetic.BYInv
Crypto.Arithmetic.BarrettReduction
Crypto.Arithmetic.BarrettReduction.Generalized
Crypto.Arithmetic.BarrettReduction.HAC
Crypto.Arithmetic.BarrettReduction.RidiculousFish
Crypto.Arithmetic.BarrettReduction.Wikipedia
Crypto.Arithmetic.BaseConversion
Crypto.Arithmetic.Core
Crypto.Arithmetic.FLia
Crypto.Arithmetic.FancyMontgomeryReduction
Crypto.Arithmetic.Freeze
Crypto.Arithmetic.ModOps
Crypto.Arithmetic.ModularArithmeticPre
Crypto.Arithmetic.ModularArithmeticTheorems
Crypto.Arithmetic.MontgomeryReduction.Definition
Crypto.Arithmetic.MontgomeryReduction.Proofs
Crypto.Arithmetic.Partition
Crypto.Arithmetic.PrimeFieldTheorems
Crypto.Arithmetic.Primitives
Crypto.Arithmetic.Saturated
Crypto.Arithmetic.UniformWeight
Crypto.Arithmetic.WordByWordMontgomery
Crypto.ArithmeticCPS.BaseConversion
Crypto.ArithmeticCPS.Core
Crypto.ArithmeticCPS.Freeze
Crypto.ArithmeticCPS.ModOps
Crypto.ArithmeticCPS.Saturated
Crypto.ArithmeticCPS.WordByWordMontgomery
Crypto.Assembly.Equality
Crypto.Assembly.Equivalence
Crypto.Assembly.EquivalenceProofs
Crypto.Assembly.Parse
Crypto.Assembly.Parse.Examples.boringssl_nasm_full_mul_p256
Crypto.Assembly.Parse.Examples.fiat_25519_carry_square_optimised
Crypto.Assembly.Parse.Examples.fiat_25519_carry_square_optimised_seed10
Crypto.Assembly.Parse.Examples.fiat_25519_carry_square_optimised_seed20
Crypto.Assembly.Parse.Examples.fiat_p256_mul_optimised_seed11
Crypto.Assembly.Parse.Examples.fiat_p256_mul_optimised_seed12
Crypto.Assembly.Parse.Examples.fiat_p256_mul_optimised_seed4
Crypto.Assembly.Parse.Examples.fiat_p256_square_optimised_seed103
Crypto.Assembly.Parse.Examples.fiat_p256_square_optimised_seed46
Crypto.Assembly.Parse.Examples.fiat_p256_square_optimised_seed6
Crypto.Assembly.Parse.TestAsm
Crypto.Assembly.Symbolic
Crypto.Assembly.Syntax
Crypto.BoundsPipeline
Crypto.CLI
Crypto.COperationSpecifications
Crypto.CastLemmas
Crypto.CompilersTestCases
Crypto.Curves.Edwards.AffineProofs
Crypto.Curves.Edwards.Pre
Crypto.Curves.Edwards.XYZT.Basic
Crypto.Curves.Edwards.XYZT.Precomputed
Crypto.Curves.EdwardsMontgomery
Crypto.Curves.Montgomery.Affine
Crypto.Curves.Montgomery.AffineInstances
Crypto.Curves.Montgomery.AffineProofs
Crypto.Curves.Montgomery.XZ
Crypto.Curves.Montgomery.XZProofs
Crypto.Curves.Weierstrass.Affine
Crypto.Curves.Weierstrass.AffineProofs
Crypto.Curves.Weierstrass.Jacobian
Crypto.Curves.Weierstrass.Projective
Crypto.Demo
Crypto.Fancy.Barrett256
Crypto.Fancy.Compiler
Crypto.Fancy.Montgomery256
Crypto.Fancy.Prod
Crypto.Fancy.Spec
Crypto.Language.API
Crypto.Language.APINotations
Crypto.Language.IdentifierParameters
Crypto.Language.IdentifiersBasicGENERATED
Crypto.Language.IdentifiersGENERATED
Crypto.Language.IdentifiersGENERATEDProofs
Crypto.Language.InversionExtra
Crypto.Language.PreExtra
Crypto.Language.UnderLetsProofsExtra
Crypto.Language.WfExtra
Crypto.MiscCompilerPasses
Crypto.MiscCompilerPassesProofs
Crypto.MiscCompilerPassesProofsExtra
Crypto.Primitives.MxDHRepChange
Crypto.PushButtonSynthesis.BYInversionReificationCache
Crypto.PushButtonSynthesis.BarrettReduction
Crypto.PushButtonSynthesis.BarrettReductionReificationCache
Crypto.PushButtonSynthesis.BaseConversion
Crypto.PushButtonSynthesis.BaseConversionReificationCache
Crypto.PushButtonSynthesis.FancyMontgomeryReduction
Crypto.PushButtonSynthesis.FancyMontgomeryReductionReificationCache
Crypto.PushButtonSynthesis.InvertHighLow
Crypto.PushButtonSynthesis.Primitives
Crypto.PushButtonSynthesis.ReificationCache
Crypto.PushButtonSynthesis.SaturatedSolinas
Crypto.PushButtonSynthesis.SaturatedSolinasReificationCache
Crypto.PushButtonSynthesis.SmallExamples
Crypto.PushButtonSynthesis.UnsaturatedSolinas
Crypto.PushButtonSynthesis.UnsaturatedSolinasReificationCache
Crypto.PushButtonSynthesis.WordByWordMontgomery
Crypto.PushButtonSynthesis.WordByWordMontgomeryReificationCache
Crypto.Rewriter.All
Crypto.Rewriter.AllTacticsExtra
Crypto.Rewriter.Passes.AddAssocLeft
Crypto.Rewriter.Passes.Arith
Crypto.Rewriter.Passes.ArithWithCasts
Crypto.Rewriter.Passes.FlattenThunkedRects
Crypto.Rewriter.Passes.MulSplit
Crypto.Rewriter.Passes.MultiRetSplit
Crypto.Rewriter.Passes.NBE
Crypto.Rewriter.Passes.NoSelect
Crypto.Rewriter.Passes.RelaxBitwidthAdcSbb
Crypto.Rewriter.Passes.StripLiteralCasts
Crypto.Rewriter.Passes.Test
Crypto.Rewriter.Passes.ToFancy
Crypto.Rewriter.Passes.ToFancyWithCasts
Crypto.Rewriter.Passes.UnfoldValueBarrier
Crypto.Rewriter.PerfTesting.Core
Crypto.Rewriter.PerfTesting.StandaloneOCamlMain
Crypto.Rewriter.Rules
Crypto.Rewriter.RulesProofs
Crypto.Rewriter.TestRules
Crypto.Rewriter.TestRulesProofs
Crypto.SlowPrimeSynthesisExamples
Crypto.Spec.CompleteEdwardsCurve
Crypto.Spec.Curve25519
Crypto.Spec.ModularArithmetic
Crypto.Spec.MontgomeryCurve
Crypto.Spec.MxDH
Crypto.Spec.Test.X25519
Crypto.Spec.WeierstrassCurve
Crypto.StandaloneDebuggingExamples
Crypto.StandaloneHaskellMain
Crypto.StandaloneOCamlMain
Crypto.Stringification.C
Crypto.Stringification.Go
Crypto.Stringification.IR
Crypto.Stringification.JSON
Crypto.Stringification.Java
Crypto.Stringification.Language
Crypto.Stringification.Rust
Crypto.Stringification.Zig
Crypto.TAPSort
Crypto.UnsaturatedSolinasHeuristics
Crypto.UnsaturatedSolinasHeuristics.Tests
Crypto.Util.AdditionChainExponentiation
Crypto.Util.Arg
Crypto.Util.AutoRewrite
Crypto.Util.Bool
Crypto.Util.Bool.Equality
Crypto.Util.Bool.IsTrue
Crypto.Util.Bool.LeCompat
Crypto.Util.Bool.Reflect
Crypto.Util.CPSNotations
Crypto.Util.CPSUtil
Crypto.Util.Comparison
Crypto.Util.Compose
Crypto.Util.Curry
Crypto.Util.Decidable
Crypto.Util.Decidable.Bool2Prop
Crypto.Util.Decidable.Decidable2Bool
Crypto.Util.DefaultedTypes
Crypto.Util.DynList
Crypto.Util.Equality
Crypto.Util.ErrorT
Crypto.Util.ErrorT.List
Crypto.Util.ErrorT.Show
Crypto.Util.FSets.FMapBool
Crypto.Util.FSets.FMapEmpty
Crypto.Util.FSets.FMapFacts
Crypto.Util.FSets.FMapFlip
Crypto.Util.FSets.FMapInterface
Crypto.Util.FSets.FMapIso
Crypto.Util.FSets.FMapN
Crypto.Util.FSets.FMapOption
Crypto.Util.FSets.FMapProd
Crypto.Util.FSets.FMapSect
Crypto.Util.FSets.FMapSum
Crypto.Util.FSets.FMapTrie
Crypto.Util.FSets.FMapTrie.Shape
Crypto.Util.FSets.FMapTrie.ShapeEx
Crypto.Util.FSets.FMapTrieEx
Crypto.Util.FSets.FMapUnit
Crypto.Util.FSets.FMapZ
Crypto.Util.Factorize
Crypto.Util.FixCoqMistakes
Crypto.Util.FsatzAutoLemmas
Crypto.Util.FueledLUB
Crypto.Util.GlobalSettings
Crypto.Util.HList
Crypto.Util.HProp
Crypto.Util.IdfunWithAlt
Crypto.Util.IffT
Crypto.Util.Isomorphism
Crypto.Util.LetIn
Crypto.Util.LetInMonad
Crypto.Util.Level
Crypto.Util.ListUtil
Crypto.Util.ListUtil.CombineExtend
Crypto.Util.ListUtil.Concat
Crypto.Util.ListUtil.Filter
Crypto.Util.ListUtil.FoldBool
Crypto.Util.ListUtil.FoldMap
Crypto.Util.ListUtil.Forall
Crypto.Util.ListUtil.ForallIn
Crypto.Util.ListUtil.GroupAllBy
Crypto.Util.ListUtil.IndexOf
Crypto.Util.ListUtil.NthExt
Crypto.Util.ListUtil.Partition
Crypto.Util.ListUtil.Permutation
Crypto.Util.ListUtil.PermutationCompat
Crypto.Util.ListUtil.RemoveN
Crypto.Util.ListUtil.SetoidList
Crypto.Util.ListUtil.SetoidListFlatMap
Crypto.Util.ListUtil.SetoidListRev
Crypto.Util.ListUtil.Split
Crypto.Util.ListUtil.StdlibCompat
Crypto.Util.Listable
Crypto.Util.Logic
Crypto.Util.Logic.Exists
Crypto.Util.Logic.ExistsEqAnd
Crypto.Util.Logic.Forall
Crypto.Util.Logic.ImplAnd
Crypto.Util.Logic.ProdForall
Crypto.Util.Loops
Crypto.Util.MSets.FMapPositive.Equality
Crypto.Util.MSets.MSetIso
Crypto.Util.MSets.MSetN
Crypto.Util.MSets.MSetPositive.Equality
Crypto.Util.MSets.MSetPositive.Facts
Crypto.Util.MSets.MSetPositive.Show
Crypto.Util.MSets.MSetSum
Crypto.Util.MSets.Show
Crypto.Util.NUtil.Sorting
Crypto.Util.NUtil.Testbit
Crypto.Util.NUtil.WithoutReferenceToZ
Crypto.Util.NatUtil
Crypto.Util.Notations
Crypto.Util.NumTheoryUtil
Crypto.Util.Option
Crypto.Util.OptionList
Crypto.Util.PER
Crypto.Util.ParseTaps
Crypto.Util.PartiallyReifiedProp
Crypto.Util.Pointed
Crypto.Util.PointedProp
Crypto.Util.Pos
Crypto.Util.PrimitiveHList
Crypto.Util.PrimitiveProd
Crypto.Util.PrimitiveSigma
Crypto.Util.Prod
Crypto.Util.QUtil
Crypto.Util.Relations
Crypto.Util.SideConditions.Autosolve
Crypto.Util.SideConditions.CorePackages
Crypto.Util.SideConditions.ModInvPackage
Crypto.Util.SideConditions.ReductionPackages
Crypto.Util.SideConditions.RingPackage
Crypto.Util.Sigma
Crypto.Util.Sigma.Associativity
Crypto.Util.Sigma.Lift
Crypto.Util.Sigma.MapProjections
Crypto.Util.Sigma.Related
Crypto.Util.Sorting.Sorted.Proper
Crypto.Util.Strings.Ascii
Crypto.Util.Strings.Decimal
Crypto.Util.Strings.NamingConventions
Crypto.Util.Strings.Parse.Common
Crypto.Util.Strings.ParseArithmetic
Crypto.Util.Strings.ParseArithmeticToTaps
Crypto.Util.Strings.Show
Crypto.Util.Strings.Sorting
Crypto.Util.Strings.String
Crypto.Util.Strings.StringMap
Crypto.Util.Strings.String_as_OT
Crypto.Util.Strings.String_as_OT_old
Crypto.Util.Strings.Subscript
Crypto.Util.Strings.Superscript
Crypto.Util.Structures.Equalities
Crypto.Util.Structures.Equalities.Bool
Crypto.Util.Structures.Equalities.Empty
Crypto.Util.Structures.Equalities.Iso
Crypto.Util.Structures.Equalities.List
Crypto.Util.Structures.Equalities.Option
Crypto.Util.Structures.Equalities.Prod
Crypto.Util.Structures.Equalities.Project
Crypto.Util.Structures.Equalities.Sum
Crypto.Util.Structures.Equalities.Unit
Crypto.Util.Structures.Orders
Crypto.Util.Structures.Orders.Bool
Crypto.Util.Structures.Orders.Empty
Crypto.Util.Structures.Orders.Flip
Crypto.Util.Structures.Orders.Iso
Crypto.Util.Structures.Orders.List
Crypto.Util.Structures.Orders.Option
Crypto.Util.Structures.Orders.Prod
Crypto.Util.Structures.Orders.Sum
Crypto.Util.Structures.Orders.Unit
Crypto.Util.Structures.OrdersEx
Crypto.Util.Sum
Crypto.Util.Sumbool
Crypto.Util.Tactics
Crypto.Util.Tactics.AllInstances
Crypto.Util.Tactics.AllSuccesses
Crypto.Util.Tactics.AppendUnderscores
Crypto.Util.Tactics.Beta1
Crypto.Util.Tactics.BreakMatch
Crypto.Util.Tactics.CPSId
Crypto.Util.Tactics.CacheTerm
Crypto.Util.Tactics.ChangeInAll
Crypto.Util.Tactics.ClearAll
Crypto.Util.Tactics.ClearDuplicates
Crypto.Util.Tactics.ClearHead
Crypto.Util.Tactics.ClearbodyAll
Crypto.Util.Tactics.ConstrFail
Crypto.Util.Tactics.Contains
Crypto.Util.Tactics.ConvoyDestruct
Crypto.Util.Tactics.CountBinders
Crypto.Util.Tactics.DebugPrint
Crypto.Util.Tactics.Delta1
Crypto.Util.Tactics.DestructHead
Crypto.Util.Tactics.DestructHyps
Crypto.Util.Tactics.DestructTrivial
Crypto.Util.Tactics.DoWithHyp
Crypto.Util.Tactics.ESpecialize
Crypto.Util.Tactics.ETransitivity
Crypto.Util.Tactics.EvarExists
Crypto.Util.Tactics.EvarNormalize
Crypto.Util.Tactics.FindHyp
Crypto.Util.Tactics.Forward
Crypto.Util.Tactics.GeneralizeOverHoles
Crypto.Util.Tactics.GetGoal
Crypto.Util.Tactics.HasBody
Crypto.Util.Tactics.Head
Crypto.Util.Tactics.HeadConstrEq
Crypto.Util.Tactics.HeadUnderBinders
Crypto.Util.Tactics.InHypUnderBindersDo
Crypto.Util.Tactics.MoveLetIn
Crypto.Util.Tactics.NormalizeCommutativeIdentifier
Crypto.Util.Tactics.Not
Crypto.Util.Tactics.OnSubterms
Crypto.Util.Tactics.PoseTermWithName
Crypto.Util.Tactics.PrintContext
Crypto.Util.Tactics.PrintGoal
Crypto.Util.Tactics.Revert
Crypto.Util.Tactics.RevertUntil
Crypto.Util.Tactics.RewriteHyp
Crypto.Util.Tactics.RunTacticAsConstr
Crypto.Util.Tactics.SetEvars
Crypto.Util.Tactics.SetoidSubst
Crypto.Util.Tactics.SideConditionsBeforeToAfter
Crypto.Util.Tactics.SimplifyProjections
Crypto.Util.Tactics.SimplifyRepeatedIfs
Crypto.Util.Tactics.SpecializeAllWays
Crypto.Util.Tactics.SpecializeBy
Crypto.Util.Tactics.SpecializeUnderBindersBy
Crypto.Util.Tactics.SplitInContext
Crypto.Util.Tactics.SubstEvars
Crypto.Util.Tactics.SubstLet
Crypto.Util.Tactics.Test
Crypto.Util.Tactics.TransparentAssert
Crypto.Util.Tactics.UnfoldArg
Crypto.Util.Tactics.UnifyAbstractReflexivity
Crypto.Util.Tactics.UniquePose
Crypto.Util.Tactics.VM
Crypto.Util.Tactics.WarnIfGoalsRemain
Crypto.Util.Tactics.Zeta1
Crypto.Util.TagList
Crypto.Util.Telescope.Core
Crypto.Util.Telescope.Equality
Crypto.Util.Telescope.Instances
Crypto.Util.Tower
Crypto.Util.Tuple
Crypto.Util.Unit
Crypto.Util.Wf
Crypto.Util.Wf1
Crypto.Util.Wf2
Crypto.Util.ZBounded
Crypto.Util.ZRange
Crypto.Util.ZRange.BasicLemmas
Crypto.Util.ZRange.CornersMonotoneBounds
Crypto.Util.ZRange.LandLorBounds
Crypto.Util.ZRange.Operations
Crypto.Util.ZRange.OperationsBounds
Crypto.Util.ZRange.Show
Crypto.Util.ZRange.SplitBounds
Crypto.Util.ZRange.SplitRangeBounds
Crypto.Util.ZUtil
Crypto.Util.ZUtil.AddGetCarry
Crypto.Util.ZUtil.AddModulo
Crypto.Util.ZUtil.ArithmeticShiftr
Crypto.Util.ZUtil.Bitwise
Crypto.Util.ZUtil.CC
Crypto.Util.ZUtil.CPS
Crypto.Util.ZUtil.Combine
Crypto.Util.ZUtil.Definitions
Crypto.Util.ZUtil.DistrIf
Crypto.Util.ZUtil.Div
Crypto.Util.ZUtil.Div.Bootstrap
Crypto.Util.ZUtil.Divide
Crypto.Util.ZUtil.EquivModulo
Crypto.Util.ZUtil.Ge
Crypto.Util.ZUtil.Hints
Crypto.Util.ZUtil.Hints.Core
Crypto.Util.ZUtil.Hints.PullPush
Crypto.Util.ZUtil.Hints.ZArith
Crypto.Util.ZUtil.Hints.Ztestbit
Crypto.Util.ZUtil.Land
Crypto.Util.ZUtil.LandLorBounds
Crypto.Util.ZUtil.LandLorShiftBounds
Crypto.Util.ZUtil.Le
Crypto.Util.ZUtil.Lnot
Crypto.Util.ZUtil.LnotModulo
Crypto.Util.ZUtil.Log2
Crypto.Util.ZUtil.Lor
Crypto.Util.ZUtil.Ltz
Crypto.Util.ZUtil.Lxor
Crypto.Util.ZUtil.ModExp
Crypto.Util.ZUtil.ModInv
Crypto.Util.ZUtil.Modulo
Crypto.Util.ZUtil.Modulo.Bootstrap
Crypto.Util.ZUtil.Modulo.PullPush
Crypto.Util.ZUtil.Morphisms
Crypto.Util.ZUtil.Mul
Crypto.Util.ZUtil.MulSplit
Crypto.Util.ZUtil.N2Z
Crypto.Util.ZUtil.Nat2Z
Crypto.Util.ZUtil.Notations
Crypto.Util.ZUtil.Odd
Crypto.Util.ZUtil.Ones
Crypto.Util.ZUtil.OnesFrom
Crypto.Util.ZUtil.Opp
Crypto.Util.ZUtil.Peano
Crypto.Util.ZUtil.Pow
Crypto.Util.ZUtil.Pow2
Crypto.Util.ZUtil.Pow2Mod
Crypto.Util.ZUtil.Quot
Crypto.Util.ZUtil.Rshi
Crypto.Util.ZUtil.Sgn
Crypto.Util.ZUtil.Shift
Crypto.Util.ZUtil.SignBit
Crypto.Util.ZUtil.Sorting
Crypto.Util.ZUtil.Stabilization
Crypto.Util.ZUtil.Tactics
Crypto.Util.ZUtil.Tactics.CompareToSgn
Crypto.Util.ZUtil.Tactics.DivModToQuotRem
Crypto.Util.ZUtil.Tactics.DivideExistsMul
Crypto.Util.ZUtil.Tactics.LinearSubstitute
Crypto.Util.ZUtil.Tactics.LtbToLt
Crypto.Util.ZUtil.Tactics.PeelLe
Crypto.Util.ZUtil.Tactics.PrimeBound
Crypto.Util.ZUtil.Tactics.PullPush
Crypto.Util.ZUtil.Tactics.PullPush.Modulo
Crypto.Util.ZUtil.Tactics.ReplaceNegWithPos
Crypto.Util.ZUtil.Tactics.RewriteModSmall
Crypto.Util.ZUtil.Tactics.SimplifyFractionsLe
Crypto.Util.ZUtil.Tactics.SolveRange
Crypto.Util.ZUtil.Tactics.SolveTestbit
Crypto.Util.ZUtil.Tactics.SplitMinMax
Crypto.Util.ZUtil.Tactics.ZeroBounds
Crypto.Util.ZUtil.Tactics.Ztestbit
Crypto.Util.ZUtil.Testbit
Crypto.Util.ZUtil.TruncatingShiftl
Crypto.Util.ZUtil.TwosComplement
Crypto.Util.ZUtil.Z2Nat
Crypto.Util.ZUtil.ZSimplify
Crypto.Util.ZUtil.ZSimplify.Autogenerated
Crypto.Util.ZUtil.ZSimplify.Core
Crypto.Util.ZUtil.ZSimplify.Simple
Crypto.Util.ZUtil.Zselect
.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Hui Zhang <sa512073@mail.ustc.edu.cn>                            *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import LibEx.
Require Import bnat.
Require Import List.
Require Import ListEx.
Require Import Data.

Require Import Params.
Require Import Nand.
Require Import Bast0.
Require Import FTLProp.

Require Import Framework.

Require Import Inv.
Require Import FTLLems4.

(* To prove the theorem above, we need define a relation, R, saying the flash_device
   is equal to a hard_disk at every address.
*)

Definition Inv (fld: flash_device) : Prop :=
  let (c, f) := fld in Inv.Inv c f.

Lemma R_init : R hdd_init fld_init.
Proof.
  unfold R, hdd_init, fld_init.
  intros sec.
  unfold hdd_read, fld_read.
  destruct (bvalid_sector_no sec) eqn:Hvsec.
  rewrite list_get_list_repeat_list.
  destruct (lpn_to_lbn_off sec) as [lbn off] eqn:Hlpn.
  assert (Hvoff : bvalid_page_off off = true).
    apply valid_lpn_implies_valid_off with sec lbn; trivial.
  assert (Hvlbn : bvalid_logical_block_no lbn = true).
    apply valid_lpn_implies_valid_lbn with sec off; trivial.
  rewrite ftl_read_ftl_init; trivial.
    apply blt_true_lt; trivial.
  destruct (lpn_to_lbn_off sec) as [lbn off] eqn:Hlpn.
  assert (Hvoff : bvalid_page_off off = true).
    apply invalid_lpn_implies_valid_off with sec lbn; trivial.
  assert (Hvlbn : bvalid_logical_block_no lbn = false).
    apply invalid_lpn_implies_invalid_lbn with sec off; trivial.
  unfold FTL_read.
  rewrite Hvoff.
  unfold ftl_init.
  unfold bmt_get, bmt_init.
  unfold ftl_bm_table.
  rewrite list_get_list_repeat_list_none; trivial.
  apply blt_false_le; trivial.
Qed.

Lemma fld_write_R_preservation :
  forall hdd hdd' fld fld' sec d,
    Inv fld
    -> R hdd fld
    -> hdd_write hdd sec d = Some hdd'
    -> fld_write fld sec d = Some fld'
    -> R hdd' fld'.
Proof.
  unfold R; intros.
  destruct (beq_nat_dec sec sec0).
    desbnat.
    subst sec0.
    destruct fld as [c f].
    destruct fld' as [c' f'].
    unfold fld_write in H2.
    destruct (lpn_to_lbn_off sec) as [lbn lpo] eqn:Hsec.
    unfold fld_read.
    rewrite hdd_read_write_at_same_addr with hdd sec d hdd'; trivial.
    rewrite Hsec.
    rewrite ftl_read_write_at_same_addr with c f lbn lpo d c' f'; trivial.
  desbnat.
  unfold fld_read.
  destruct fld as [c f].
  destruct fld' as [c' f'].
  rewrite hdd_read_write_not_same_addr with hdd sec sec0 d hdd'; trivial.
  rewrite H0.
  unfold fld_read.
  destruct (lpn_to_lbn_off sec0) as [lbn' lpo'] eqn:Hsec0.
  unfold fld_write in H2.
  destruct (lpn_to_lbn_off sec) as [lbn lpo] eqn:Hsec.
  rewrite (ftl_read_write_not_same_addr c f  lbn lpo d c' f' H H2 lbn' lpo'); trivial.
  destruct (addr_neq_trans_implies_neq sec sec0 lbn lpo lbn' lpo'); trivial.
  left; trivial.
  destruct H3.
  right; auto.
Qed.

Lemma fld_run_deterministic :
  forall fld cmd fld1 bh1 fld2 bh2,
    fld_run fld cmd fld1 bh1
    -> fld_run fld cmd fld2 bh2
    -> fld1 = fld2 /\ bh1 = bh2.
Proof.
  intros.
  destruct cmd.
    simpl in * .
    destruct H as [d1 [H11 [H12 H13]]].
    destruct H0 as [d2 [H21 [H22 H23]]].
    rewrite H11 in H21.
    inversion H21.
    subst.
    split; trivial.
  simpl in * .
  destruct H as [H11 H12].
  destruct H0 as [H21 H22].
  rewrite H11 in H21.
  inversion H21; subst.
  split; trivial.
Qed.

Lemma Inv_fld_init : Inv fld_init.
Proof.
  unfold Inv, fld_init.
  apply Inv_ftl_init; trivial.
Qed.

Lemma fld_write_Inv :
  forall hdd hdd' fld sec d,
    Inv fld
    -> hdd_write hdd sec d = Some hdd'
    -> exists fld', fld_write fld sec d = Some fld'
                    /\ Inv fld'.
Proof.
  intros.
  destruct fld as [c f].
  unfold fld_write.
  destruct (lpn_to_lbn_off sec) as [lbn off] eqn:Ha.
  assert (Hv: valid_sector_no sec).
    eapply hdd_write_some_implies_valid_addr; eauto.
  assert (Hb: valid_logical_block_no lbn).
    eapply valid_lpn_implies_valid_lbn; eauto.
  assert (Ho: valid_page_off off).
    eapply valid_lpn_implies_valid_off; eauto.
  destruct (ftl_write_Inv c f lbn off d) as [c' [f' [Hx Hy]]]; auto.
  exists (c', f').
  split; trivial.
Qed.

Lemma simu_one_step_progress :
  forall cmd : command,
    forall (hdd hdd': hard_disk) (bh: behav) (fld: flash_device),
      Inv fld
      -> R hdd fld
      -> hdd_run hdd cmd hdd' bh
      -> exists fld': flash_device, fld_run fld cmd fld' bh.
Proof.
  intros.
  destruct cmd.
  intros.
  exists fld.
  inversion H1.
  subst hdd0 sec hdd' bh.
  unfold fld_run.
  inversion H1.
  subst hdd0 lpn0 d0.
  clear H3.
  exists d.
  split.
    unfold R in H0.
    rewrite <- H0; trivial.
  split; trivial.
  inversion H1.
  subst hdd0 sec d0 hdd'0 bh.
  destruct (fld_write_Inv hdd hdd' fld lpn d H Hdw) as [fld' [Hfld' Hinv]].
  exists fld'; trivial.
  unfold fld_run.
  split; trivial.
Qed.

 Lemma simu_one_step_preservation :
  forall cmd : command,
    forall (hdd hdd': hard_disk) (bh: behav) (fld fld': flash_device),
      Inv fld
      -> R hdd fld
      -> hdd_run hdd cmd hdd' bh
      -> fld_run fld cmd fld' bh
      -> Inv fld' /\ R hdd' fld'.
Proof.
  intros.
  destruct cmd.
  inversion H1.
  subst hdd0 sec hdd' bh.
  unfold fld_run in H2.
  destruct H2 as [dx [Hfr [Hdx Hfld']]].
  subst fld'.
  injection Hdx.
  intro; subst dx.
  split; trivial.
  inversion H1.
  subst hdd0 sec hdd'0 d0 bh.
  unfold fld_run in H2.
  destruct H2 as [Hfw _].
  destruct (fld_write_Inv hdd hdd' fld lpn d H Hdw) as [fld'' [Hfld' Hinv']].
  assert (fld'' = fld').
    rewrite Hfw in Hfld'.
    injection Hfld'; auto.
  subst fld''.
  split; trivial.
  apply fld_write_R_preservation with hdd fld lpn d; trivial.
Qed.

Lemma simu_multi_steps_progress :
  forall cl : list command,
    forall (hd hd': hard_disk) (B: behavior) (fl: flash_device),
      Inv fl
      -> R hd fl
      -> hdd_run_cmd_list hd cl hd' B
      -> exists fl': flash_device, fld_run_cmd_list fl cl fl' B.
Proof.
  induction cl.
    intros.
    destruct B.
      exists fl; trivial.
    simpl in H1.
    simpl. trivial.
    simpl in H1.
    destruct H1.
  intros.
  destruct B.
    simpl in H1.
    destruct H1.
  simpl in H1.
  destruct H1 as [hd'' [H1 H2]].
  rename a into cmd.
  rename b into bh.
  destruct (simu_one_step_progress cmd hd hd'' bh fl H H0 H1) as [fl'' Hfl''].
  destruct (simu_one_step_preservation cmd hd hd'' bh fl fl'' H H0 H1 Hfl'') as [Hx1 Hx2].
  assert (Hx := IHcl hd'' hd' B fl'' Hx1 Hx2 H2).
  destruct Hx as [fl' Hfl'].
  exists fl'.
  simpl.
  exists fl''; split; trivial.
Qed.

Lemma simu_multi_steps_preservation :
  forall cl : list command,
    forall (hd hd': hard_disk) (B: behavior) (fl fl': flash_device),
      Inv fl
      -> R hd fl
      -> hdd_run_cmd_list hd cl hd' B
      -> fld_run_cmd_list fl cl fl' B
      -> Inv fl' /\ R hd' fl'.
Proof.
  induction cl.
    intros.
    destruct B.
      simpl in H1.
      simpl in H2.
      subst; trivial.
      split; trivial.
    simpl in H1.
    destruct H1.
  intros.
  destruct B.
    simpl in H1.
    destruct H1.
  simpl in H1.
  destruct H1 as [hd'' [H11 H12]].
  rename a into cmd.
  rename b into bh.
  simpl in H2.
  destruct H2 as [fl'' [H21 H22]].
  destruct (simu_one_step_preservation cmd hd hd'' bh fl fl'' H H0 H11 H21) as [Hx1 Hx2].
  eapply IHcl; eauto.
Qed.

Theorem Correctness :
  forall cl : list command,
    forall (hd hd': hard_disk) (B: behavior) (fl: flash_device),
      hdd_run_cmd_list hdd_init cl hd' B
      -> exists fl': flash_device, fld_run_cmd_list fld_init cl fl' B.
Proof.
  intros.
  apply simu_multi_steps_progress with hdd_init hd'; trivial.
  apply Inv_fld_init.
  apply R_init.
Qed.


From Perennial.program_proof Require Import grove_prelude.
From Goose.github_com.mit_pdos.gokv Require Import memkv.
From Perennial.program_proof.memkv Require Export memkv_shard_definitions common_proof.

Section memkv_put_proof.

Context `{!heapGS Σ, erpcG Σ, urpcregG Σ, kvMapG Σ}.

Local Ltac Zify.zify_post_hook ::= Z.div_mod_to_equations.

Lemma wp_PutRPC (s args_ptr reply_ptr:loc) val_sl args γ Q :
  is_KVShardServer s γ -∗
  {{{
       own_PutRequest args_ptr val_sl args ∗
       (∃ dummy_rep, own_PutReply reply_ptr dummy_rep) ∗
       (PreShardPut γ.(kv_gn) args.(PR_Key) Q args.(PR_Value))
  }}}
    KVShardServer__PutRPC #s #args_ptr #reply_ptr
  {{{
       rep, RET #();
       own_PutReply reply_ptr rep ∗
       (PostShardPut γ.(kv_gn) args.(PR_Key) Q args.(PR_Value)) rep
  }}}.
Proof.
  iIntros "#His_shard !#" (Φ) "Hpre HΦ".
  iDestruct "Hpre" as "(Hargs & Hrep & Hpre)".
  iNamed "Hargs". iNamed "Hrep".

  wp_lam.
  wp_pures.

  iNamed "His_shard".
  wp_loadField.
  wp_apply (acquire_spec with "[$HmuInv]").
  iIntros "[Hlocked Hown]".

  iNamed "Hown".

  wp_pures.
  wp_lam.
  wp_pures.

  wp_pures.
  wp_loadField.
  wp_apply (wp_shardOf).
  wp_pures.
  wp_loadField.

  iDestruct (typed_slice.is_slice_small_acc with "HshardMap_sl") as "[HshardMap_sl HshardMap_sl_close]".
  set (sid:=shardOfC args.(PR_Key)) in *.

  assert (∃ b, shardMapping !! int.nat sid = Some b) as [? ?].
  {
    eapply list_lookup_lt.
    move: HshardMapLength. rewrite /sid /shardOfC /uNSHARD.
    word.
  }
  wp_apply (typed_slice.wp_SliceGet with "[$HshardMap_sl]").
  {
    iPureIntro. done.
  }
  iIntros "HshardMap_sl".
  wp_pures.

  wp_if_destruct.
  { (* have the shard *)
    wp_loadField.
    wp_loadField.
    wp_loadField.
    iDestruct (is_slice_split with "Hkvss_sl") as "[Hkvss_sl Hkvss_sl_close]".
    iDestruct (big_sepS_elem_of_acc _ _ sid with "HownShards") as "[HownShard HownShards]".
    { set_solver. }
    iDestruct "HownShard" as "[%Hbad|HownShard]".
    { exfalso. done. }
    iDestruct "HownShard" as (kvs_ptr m mv) "(HshardGhost & %Hkvs_lookup & %Hdom_kvs & HkvsMap & HvalSlices)".
    wp_apply (slice.wp_SliceGet _ _ _ _ _ _ _ (#kvs_ptr) with "[Hkvss_sl]").
    {
      iFrame "Hkvss_sl".
      iPureIntro.
      rewrite list_lookup_fmap.
      rewrite Hkvs_lookup.
      done.
    }
    iIntros "[Hkvss_sl %Hkvs_ty]".

    wp_apply (map.wp_MapInsert with "[$HkvsMap]").
    iIntros "HkvsMap".
    wp_pures.
    wp_storeField.
    iDestruct (big_sepS_delete _ _ args.(PR_Key) with "HshardGhost") as "[Hghost HshardGhost]".
    { set_solver. }
    iDestruct "Hghost" as "[%Hbad|Hkvptsto]".
    { exfalso; done. }

    (* Get Q by using fupd *)
    unfold PreShardPut.
    iApply fupd_wp.
    iMod "Hpre".
    iDestruct "Hpre" as (v0) "(Hkvptsto2 & HfupdQ)".
    iMod (kvptsto_update args.(PR_Value) with "Hkvptsto Hkvptsto2") as "[Hkvptsto Hkvptsto2]".
    iMod ("HfupdQ" with "Hkvptsto") as "Q".
    iModIntro.

    iDestruct ("HshardMap_sl_close" with "HshardMap_sl") as "HshardMap_sl".
    wp_loadField.
    wp_apply (release_spec with "[> -HΦ Q HKey Hrep]").
    {
      iFrame "HmuInv Hlocked".
      iMod (readonly_load with "HValue_sl") as (?) "HValue_sl'".
      iModIntro. iNext.
      iExists _,_,_, _, _, _.
      iFrame.
      iSplitL ""; first done.
      iSplitL ""; first done.
      iApply "HownShards".
      iRight.
      iExists _, _, _.
      iFrame.
      instantiate (1:=(<[args.(PR_Key):=args.(PR_Value)]> m)).
      iSplitL "HshardGhost Hkvptsto2".
      {
        iApply (big_sepS_delete _ _ args.(PR_Key) with "[-]").
        { set_solver. }
        iSplitL "Hkvptsto2".
        {
          iRight.
          rewrite lookup_insert.
          iFrame.
        }
        iApply (big_sepS_impl with "HshardGhost").
        iModIntro; iIntros.
        rewrite lookup_insert_ne; last first.
        { set_solver. }
        iFrame.
      }
      iSplitL ""; first done.
      iSplitL "".
      { rewrite ?dom_insert_L //; eauto. iPureIntro; congruence. }
      iApply (big_sepS_delete _ _ args.(PR_Key) with "[-]").
      { set_solver. }
      iSplitL "HValue_sl'".
      {
        simpl. iRight.
        iExists _. iExists val_sl.
        rewrite lookup_insert.
        rewrite lookup_insert.
        by iFrame.
      }
      iDestruct (big_sepS_delete _ _ args.(PR_Key) with "HvalSlices") as "[_ HvalSlices]".
      { set_solver. }
      iApply (big_sepS_impl with "HvalSlices").
      iModIntro.
      iIntros.
      rewrite lookup_insert_ne; last first.
      { set_solver. }
      rewrite lookup_insert_ne; last first.
      { set_solver. }
      iFrame.
    }
    wp_pures. iModIntro. iApply "HΦ".
    iSplitL "Hrep".
    {
      instantiate (1:=mkPutReplyC _).
      iFrame.
    }
    iRight.
    iSimpl.
    by iFrame.
  }
  { (* don't have shard *)
    wp_storeField.

    wp_loadField.
    iSpecialize ("HshardMap_sl_close" with "HshardMap_sl").
    wp_apply (release_spec with "[-HΦ Hpre HKey Hrep]").
    {
      iFrame "HmuInv Hlocked".
      iNext.
      iExists _,_,_, _, _, _.
      iFrame.
      done.
    }
    wp_pures. iModIntro. iApply "HΦ".
    iSplitL "Hrep".
    {
      instantiate (1:=mkPutReplyC _).
      iFrame.
    }
    iLeft.
    iSimpl.
    by iFrame.
  }
Qed.

End memkv_put_proof.

Ltac Zify.zify_post_hook ::= idtac.


From stdpp Require Export telescopes.
From iris.bi Require Export bi.
From iris.prelude Require Import options.
Import bi.

(* This cannot import the proofmode because it is imported by the proofmode! *)

(** Telescopic quantifiers *)
Definition bi_texist {PROP : bi} {TT : tele@{Quant}} (Ψ : TT → PROP) : PROP :=
  tele_fold (@bi_exist PROP) (λ x, x) (tele_bind Ψ).
Global Arguments bi_texist {_ !_} _ /.
Definition bi_tforall {PROP : bi} {TT : tele@{Quant}} (Ψ : TT → PROP) : PROP :=
  tele_fold (@bi_forall PROP) (λ x, x) (tele_bind Ψ).
Global Arguments bi_tforall {_ !_} _ /.

Notation "'∃..' x .. y , P" := (bi_texist (λ x, .. (bi_texist (λ y, P)) .. )%I)
  (at level 200, x binder, y binder, right associativity,
  format "∃..  x  ..  y ,  P") : bi_scope.
Notation "'∀..' x .. y , P" := (bi_tforall (λ x, .. (bi_tforall (λ y, P)) .. )%I)
  (at level 200, x binder, y binder, right associativity,
  format "∀..  x  ..  y ,  P") : bi_scope.

Section telescopes.
  Context {PROP : bi} {TT : tele@{Quant}}.
  Implicit Types Ψ : TT → PROP.

  Lemma bi_tforall_forall Ψ : bi_tforall Ψ ⊣⊢ bi_forall Ψ.
  Proof.
    symmetry. unfold bi_tforall. induction TT as [|X ft IH].
    - simpl. apply (anti_symm _).
      + by rewrite (forall_elim TargO).
      + rewrite -forall_intro; first done.
        intros p. rewrite (tele_arg_O_inv p) /= //.
    - simpl. apply (anti_symm _); apply forall_intro; intros a.
      + rewrite /= -IH. apply forall_intro; intros p.
        by rewrite (forall_elim (TargS a p)).
      + destruct a=> /=.
        setoid_rewrite <- IH.
        rewrite 2!forall_elim. done.
  Qed.

  Lemma bi_texist_exist Ψ : bi_texist Ψ ⊣⊢ bi_exist Ψ.
  Proof.
    symmetry. unfold bi_texist. induction TT as [|X ft IH].
    - simpl. apply (anti_symm _).
      + apply exist_elim; intros p.
        rewrite (tele_arg_O_inv p) //.
      + by rewrite -(exist_intro TargO).
    - simpl. apply (anti_symm _); apply exist_elim.
      + intros p. destruct p => /=.
        by rewrite -exist_intro -IH -exist_intro.
      + intros x.
        rewrite /= -IH. apply exist_elim; intros p.
        by rewrite -(exist_intro (TargS x p)).
  Qed.

  Global Instance bi_tforall_ne n :
    Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_tforall PROP TT).
  Proof. intros ?? EQ. rewrite !bi_tforall_forall. rewrite EQ //. Qed.
  Global Instance bi_tforall_proper :
    Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@bi_tforall PROP TT).
  Proof. intros ?? EQ. rewrite !bi_tforall_forall. rewrite EQ //. Qed.

  Global Instance bi_texist_ne n :
    Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_texist PROP TT).
  Proof. intros ?? EQ. rewrite !bi_texist_exist. rewrite EQ //. Qed.
  Global Instance bi_texist_proper :
    Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@bi_texist PROP TT).
  Proof. intros ?? EQ. rewrite !bi_texist_exist. rewrite EQ //. Qed.

  Global Instance bi_tforall_absorbing Ψ :
    (∀ x, Absorbing (Ψ x)) → Absorbing (∀.. x, Ψ x).
  Proof. rewrite bi_tforall_forall. apply _. Qed.
  Global Instance bi_tforall_persistent `{!BiPersistentlyForall PROP} Ψ :
    (∀ x, Persistent (Ψ x)) → Persistent (∀.. x, Ψ x).
  Proof. rewrite bi_tforall_forall. apply _. Qed.

  Global Instance bi_texist_affine Ψ :
    (∀ x, Affine (Ψ x)) → Affine (∃.. x, Ψ x).
  Proof. rewrite bi_texist_exist. apply _. Qed.
  Global Instance bi_texist_absorbing Ψ :
    (∀ x, Absorbing (Ψ x)) → Absorbing (∃.. x, Ψ x).
  Proof. rewrite bi_texist_exist. apply _. Qed.
  Global Instance bi_texist_persistent Ψ :
    (∀ x, Persistent (Ψ x)) → Persistent (∃.. x, Ψ x).
  Proof. rewrite bi_texist_exist. apply _. Qed.

  Global Instance bi_tforall_timeless Ψ :
    (∀ x, Timeless (Ψ x)) → Timeless (∀.. x, Ψ x).
  Proof. rewrite bi_tforall_forall. apply _. Qed.

  Global Instance bi_texist_timeless Ψ :
    (∀ x, Timeless (Ψ x)) → Timeless (∃.. x, Ψ x).
  Proof. rewrite bi_texist_exist. apply _. Qed.
End telescopes.


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.progs64.union.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Import Memdata.

Definition Gprog : funspecs :=
    ltac:(with_library prog (@nil(ident*funspec))).

Definition g_spec :=
 DECLARE _g
 WITH i: Z
 PRE [ size_t]
   PROP() PARAMS(Vptrofs (Ptrofs.repr i)) SEP()
 POST [ size_t ]
   PROP() RETURN (Vptrofs (Ptrofs.repr i)) SEP().

Lemma body_g: semax_body Vprog Gprog f_g g_spec.
Proof.
start_function.
forward.
forward.
forward.
cancel.
Qed.

Lemma decode_float32_int32:
  forall (bl: list memval) (x: float32),
 size_chunk Mfloat32 = Z.of_nat (Datatypes.length bl) ->
 decode_val Mfloat32 bl = Vsingle x ->
 decode_val Mint32 bl = Vint (Float32.to_bits x).
Proof.
intros.
unfold decode_val,decode_int,rev_if_be in *.
destruct (proj_bytes bl) eqn:?H.
inv H0.
rewrite Float32.to_of_bits. auto.
inv H0.
Qed.

Lemma NOT_decode_int32_float32:
  Archi.ptr64=false ->
 ~ (forall (bl: list memval) (x: float32),
     size_chunk Mfloat32 = Z.of_nat (Datatypes.length bl) ->
     decode_val Mint32 bl = Vint (Float32.to_bits x) ->
     decode_val Mfloat32 bl = Vsingle x).
(* This lemma illustrates a problem: it is NOT the case that
   if (bl: list memval) decodes to Vint (Float32.to_bits x)
  then it also decodes to  Vsingle x.
  See https://github.com/AbsInt/CompCert/issues/207  for a description
  of the problem; and see https://github.com/PrincetonUniversity/VST/issues/429
  for a description of the solution,  forward_store_union_hack  *)
Proof.
intro Hp.
intro.
set (x := Float32.zero). (* nothing special about zero, any value would do *)
set (i := Float32.to_bits x).
set (bl := [Fragment (Vint i) Q32 3; Fragment (Vint i) Q32 2; Fragment (Vint i) Q32 1; Fragment (Vint i) Q32 0]).
specialize (H bl x).
specialize (H (eq_refl _)).
assert (decode_val Mint32 bl = Vint (Float32.to_bits x)).
unfold decode_val, bl.
rewrite Hp.
simpl.
destruct (Val.eq (Vint i) (Vint i)); [ | congruence].
destruct (quantity_eq Q32 Q32); [ | congruence].
simpl.
reflexivity.
specialize (H H0).
clear - H. subst bl i.
unfold decode_val in H.
simpl in H. inversion H.
Qed.

Module FABS_STUFF.

Lemma shift_pos_succ:
  forall k j, (shift_pos (Pos.succ k) j = (shift_pos k j)~0)%positive.
Proof.
intros.
change ((shift_pos k j)~0)%positive
with (2 * (shift_pos k j))%positive.
apply Pos2Z.inj.
rewrite Pos2Z.inj_mul.
rewrite !shift_pos_correct.
rewrite Z.mul_assoc.
f_equal.
rewrite <- !two_power_pos_correct.
rewrite <- Pos.add_1_l.
rewrite two_power_pos_is_exp.
reflexivity.
Qed.

Lemma nan_pl_range:
 forall k p, Binary.nan_pl k p = true ->
 Z.pos p < 2 ^ (k-1).
Proof.
intros.
unfold Binary.nan_pl in H.
apply Z.ltb_lt in H.
revert k H; induction p; simpl; intros.
-
rewrite Pos2Z.inj_succ in H.
specialize (IHp (k-1)).
spec IHp; [lia | ].
replace (2^(k-1)) with (2^1 * 2^(k-1-1)).
2:{ rewrite <- Z.pow_add_r by lia. f_equal. lia. }
rewrite Pos2Z.inj_xI.
lia.
-
rewrite Pos2Z.inj_succ in H.
specialize (IHp (k-1)).
spec IHp; [lia | ].
replace (2^(k-1)) with (2^1 * 2^(k-1-1)).
2:{ rewrite <- Z.pow_add_r by lia. f_equal. lia. }
rewrite Pos2Z.inj_xO.
lia.
-
replace (2^(k-1)) with (2^1 * 2^(k-1-1)).
2:{ rewrite <- Z.pow_add_r by lia. f_equal. lia. }
change (2^1) with 2.
assert (0 < 2 ^ (k-1-1)).
apply Z.pow_pos_nonneg; lia.
lia.
Qed.

Definition abs_nan (any_nan: {x : Bits.binary32 | Binary.is_nan 24 128 x = true}) (f: Binary.binary_float 24 128)   :=
match f with
| @Binary.B754_nan _ _ _ p H =>
    exist (fun x : Binary.binary_float 24 128 => Binary.is_nan 24 128 x = true)
      (Binary.B754_nan 24 128 false p H) eq_refl
| _ => any_nan
end.

Lemma bounded_mantissa:
  forall prec emax m e, SpecFloat.bounded prec emax m e = true ->
    Z.pos m < 2 ^ prec.
Proof.
intros.
unfold SpecFloat.bounded in H.
rewrite andb_true_iff in H.
destruct H as [H H0].
apply Z.leb_le in H0.
unfold SpecFloat.canonical_mantissa in H.
apply Zeq_bool_eq in H.
unfold FLT.FLT_exp in H.
rewrite Digits.Zpos_digits2_pos in H.
pose proof (Z.max_lub_l (Digits.Zdigits Zaux.radix2 (Z.pos m) + e - prec)
      (3 - emax - prec) e).
spec H1.
  unfold SpecFloat.fexp, SpecFloat.emin in H. lia.
clear H.
assert (Digits.Zdigits Zaux.radix2 (Z.pos m) <= prec) by  lia.
clear - H.
apply Digits.Zpower_gt_Zdigits in H.
apply H.
Qed.

Lemma binary32_abs_lemma:
 forall (x : Bits.binary32)
      (any_nan : {x : Bits.binary32 | Binary.is_nan 24 128 x = true}),
  Bits.b32_of_bits (Bits.bits_of_b32 x mod 2 ^ 31) =
  Binary.Babs 24 128 (abs_nan any_nan) x.
Proof.
intros.
destruct x.
- (* B754_zero *)
destruct s; reflexivity.
- (* B754_infinity *)
destruct s; reflexivity.
- (* B754_nan *)
assert (Hpl := nan_pl_range _ _ e).
unfold Bits.b32_of_bits, Binary.Babs, Bits.bits_of_b32, Bits.bits_of_binary_float.
assert (Bits.join_bits 23 8 s (Z.pos pl) (2 ^ 8 - 1) mod 2 ^ 31 =
            Bits.join_bits 23 8 false (Z.pos pl) (2 ^ 8 - 1)).  {
 unfold Bits.join_bits.
rewrite !Z.shiftl_mul_pow2 by computable.
rewrite Z.add_0_l.
rewrite Z.mul_add_distr_r.
rewrite <- Z.add_assoc.
rewrite Z.add_mod by (compute; lia).
replace (((if s then 2 ^ 8 else 0) * 2 ^ 23) mod 2 ^ 31) with 0
  by (destruct s; reflexivity).
rewrite Z.add_0_l.
rewrite Z.mod_mod by lia.
apply Z.mod_small.
lia.
}
rewrite H; clear H.
transitivity (Binary.B754_nan 24 128 false pl e); [ | reflexivity].
clear.
replace (Bits.join_bits 23 8 false (Z.pos pl) (2 ^ 8 - 1))
   with (Bits.bits_of_binary_float 23 8 (Binary.B754_nan 24 128 false pl e)).
apply (Bits.binary_float_of_bits_of_binary_float 23 8 eq_refl eq_refl eq_refl).
reflexivity.
- (* B754_finite *)
unfold Binary.Babs.
clear.
unfold Bits.b32_of_bits, Binary.Babs, Bits.bits_of_b32, Bits.bits_of_binary_float.
pose proof (bounded_mantissa _ _ _ _ e0).
destruct (0 <=? Z.pos m - 2 ^ 23) eqn:?H.
+
apply Z.leb_le in H0.
assert (Z.pos m - 2^23 < 2^23) by lia.
replace (Bits.join_bits 23 8 s (Z.pos m - 2 ^ 23)
                 _ mod  2 ^ 31)
   with (Bits.bits_of_binary_float 23 8 (Binary.B754_finite 24 128 false m e e0)).
apply (Bits.binary_float_of_bits_of_binary_float 23 8 eq_refl eq_refl eq_refl).
unfold Bits.bits_of_binary_float.
pose proof H0.
apply Z.leb_le in H2. rewrite H2. clear H2.
forget (Z.pos m - 2^23)  as i.
unfold SpecFloat.bounded, SpecFloat.emin in *.
rewrite andb_true_iff in e0.
destruct e0 as [H' ?H].
assert (-149 <= e). {
 clear - H'.
 unfold SpecFloat.canonical_mantissa in H'.
apply Zeq_bool_eq in H'.
unfold FLT.FLT_exp in H'.
rewrite Digits.Zpos_digits2_pos in H'.
pose proof (Z.max_lub_r (Digits.Zdigits Zaux.radix2 (Z.pos m) + e - 24)
      (3 - 128 - 24) e).
unfold SpecFloat.fexp, SpecFloat.emin in *.
spec H; lia.
}
clear H'.
apply Z.leb_le in H2.
simpl Z.sub.
replace (e - -149 + 1) with (e+150) by lia.
unfold Bits.join_bits.
rewrite !Z.shiftl_mul_pow2 by lia.
rewrite Z.add_0_l.
set (e' := e+150).
rewrite Z.mul_add_distr_r.
rewrite <- Z.add_assoc.
rewrite Z.add_mod by (compute; lia).
replace (((if s then 2 ^ 8 else 0) * 2 ^ 23) mod 2 ^ 31)
  with 0 by (destruct s; reflexivity).
rewrite Z.add_0_l.
rewrite Z.mod_mod by lia.
rewrite (Z.mod_small); auto.
subst e'.
lia.
+
replace (Bits.join_bits 23 8 s (Z.pos m) 0 mod 2 ^ 31)
 with (Bits.join_bits 23 8 false (Z.pos m) 0).
replace (Bits.join_bits 23 8 false (Z.pos m) 0)
   with (Bits.bits_of_binary_float 23 8 (Binary.B754_finite 24 128 false m e e0)).
apply (Bits.binary_float_of_bits_of_binary_float 23 8 eq_refl eq_refl eq_refl).
unfold Bits.bits_of_binary_float.
rewrite H0. auto.
clear H0.
unfold Bits.join_bits.
rewrite Z.add_mod by (compute; lia).
rewrite (Z.mod_small (Z.pos m)) by lia.
rewrite !Z.add_0_r.
replace (Z.shiftl (if s then 2 ^ 8 else 0) 23 mod 2 ^ 31) with 0 by (destruct s; reflexivity).
simpl Z.shiftl.
symmetry.
apply Z.mod_small.
lia.
Qed.

Lemma fabs_float32_lemma:
  forall x: float32,
  Float32.of_bits (Int.and (Float32.to_bits x) (Int.repr 2147483647)) =
  Float32.abs x.
Proof.
intros.
Transparent Float32.of_bits.
Transparent Float32.to_bits.
Transparent Float32.abs.
unfold Float32.of_bits, Float32.to_bits, Float32.abs.
Opaque Float32.of_bits.
Opaque Float32.to_bits.
Opaque Float32.abs.
rewrite and_repr.
change 2147483647 with (Z.ones 31).
rewrite Z.land_ones by computable.
rewrite Int.unsigned_repr
 by (pose proof (Z_mod_lt (Bits.bits_of_b32 x) (2 ^ 31) (eq_refl _)); rep_lia).
apply binary32_abs_lemma.
Qed.

End FABS_STUFF.

Module Single.

Definition fabs_single_spec :=
 DECLARE _fabs_single
 WITH x: float32
 PRE [ Tfloat F32 noattr]
   PROP() PARAMS (Vsingle x) SEP()
 POST [ Tfloat F32 noattr ]
   PROP() RETURN (Vsingle (Float32.abs x)) SEP().

Lemma body_fabs_single: semax_body Vprog Gprog f_fabs_single fabs_single_spec.
Proof.
start_function.
forward.
forward.
forward.
forward.
forward.
entailer!!.
f_equal.
apply FABS_STUFF.fabs_float32_lemma.
Qed.
End Single.

Module Float.

 (* This experiment shows what kind of error message you get
   if you put the wrong LOCAL precondition.
   In fact, Vfloat x is wrong, leading to an unsatisfying precondition,
   it must be Vsingle. *)

Definition fabs_single_spec :=
 DECLARE _fabs_single
 WITH x: float
 PRE [ Tfloat F32 noattr]
   PROP() PARAMS (Vfloat x) SEP()
 POST [ Tfloat F32 noattr ]
   PROP() RETURN (Vfloat (Float.abs x)) SEP().

Lemma body_fabs_single: semax_body Vprog Gprog f_fabs_single fabs_single_spec.
Proof.
try (start_function; fail 99).
Abort.

End Float.


From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang proofmode notation.
From iris.algebra Require Import excl.
From iris_examples.concurrent_stacks Require Import specs.

(** Stack 4: Helping, CAP spec. *)

Definition mk_offer : val :=
  λ: "v", ("v", ref #0).
Definition revoke_offer : val :=
  λ: "v", if: CAS (Snd "v") #0 #2 then SOME (Fst "v") else NONE.
Definition take_offer : val :=
  λ: "v", if: CAS (Snd "v") #0 #1 then SOME (Fst "v") else NONE.

Definition mk_mailbox : val := λ: "_", ref NONEV.
Definition put : val :=
  λ: "r" "v",
    let: "off" := mk_offer "v" in
    "r" <- SOME "off";;
    revoke_offer "off".
Definition get : val :=
  λ: "r",
    let: "offopt" := !"r" in
    match: "offopt" with
      NONE => NONE
    | SOME "x" => take_offer "x"
    end.

Definition mk_stack : val := λ: "_", (mk_mailbox #(), ref NONEV).
Definition push : val :=
  rec: "push" "p" "v" :=
    let: "mailbox" := Fst "p" in
    let: "s" := Snd "p" in
    match: put "mailbox" "v" with
      NONE => #()
    | SOME "v'" =>
      let: "tail" := ! "s" in
      let: "new" := SOME (ref ("v'", "tail")) in
      if: CAS "s" "tail" "new" then #() else "push" "p" "v'"
    end.
Definition pop : val :=
  rec: "pop" "p" :=
    let: "mailbox" := Fst "p" in
    let: "s" := Snd "p" in
    match: get "mailbox" with
      NONE =>
      match: !"s" with
        NONE => NONEV
      | SOME "l" =>
        let: "pair" := !"l" in
        if: CAS "s" (SOME "l") (Snd "pair")
        then SOME (Fst "pair")
        else "pop" "p"
      end
    | SOME "x" => SOME "x"
    end.

Definition channelR := exclR unitR.
Class channelG Σ := {channel_inG :> inG Σ channelR}.

Section proofs.
  Context `{!heapG Σ, !channelG Σ} (N : namespace).

  Implicit Types l : loc.

  Definition Nside_channel := N .@ "side_channel".
  Definition Nstack := N .@ "stack".
  Definition Nmailbox := N .@ "mailbox".

  Definition inner_mask : coPset := ⊤ ∖ ↑Nside_channel ∖ ↑Nstack.

  Lemma inner_mask_includes :
     ⊤ ∖ ↑ N ⊆ inner_mask.
  Proof. solve_ndisj. Qed.

  Lemma inner_mask_promote (P Q : iProp Σ) :
     (P ={⊤ ∖ ↑ N}=∗ Q) -∗ (P ={inner_mask}=∗ Q).
  Proof.
    iIntros "Himp P".
    iMod (fupd_intro_mask' inner_mask (⊤ ∖ ↑ N)) as "H"; first by apply inner_mask_includes.
    iDestruct ("Himp" with "P") as "HQ".
    iMod "HQ".
    by iMod "H".
  Qed.

  Definition revoke_tok γ := own γ (Excl ()).
  Definition can_push P Q v : iProp Σ :=
    (∀ (xs : list val), P xs ={inner_mask}=∗ P (v :: xs) ∗ Q #())%I.
  Definition access_inv (P : list val → iProp Σ) : iProp Σ :=
    (|={⊤ ∖ ↑Nside_channel, inner_mask}=> ∃ vs, (▷ P vs) ∗
      ((▷ P vs) ={inner_mask, ⊤ ∖ ↑Nside_channel}=∗ True))%I.

  Definition stages γ P Q l (v : val) :=
    ((l ↦ #0 ∗ can_push P Q v)  ∨
     (l ↦ #1 ∗ Q #()) ∨
     (l ↦ #1 ∗ revoke_tok γ) ∨
     (l ↦ #2 ∗ revoke_tok γ))%I.

  Definition is_offer γ P Q (v : val) : iProp Σ :=
    (∃ v' l, ⌜v = (v', #l)%V⌝ ∗ inv Nside_channel (stages γ P Q l v'))%I.

  Lemma mk_offer_works P Q v :
    {{{ can_push P Q v }}}
      mk_offer v
    {{{ o γ, RET o; is_offer γ P Q o ∗ revoke_tok γ }}}.
  Proof.
    iIntros (Φ) "HP HΦ".
    rewrite -wp_fupd.
    wp_lam. wp_alloc l as "Hl".
    iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
    iMod (inv_alloc Nside_channel _ (stages γ P Q l v) with "[Hl HP]") as "#Hinv".
    { iNext; iLeft; iFrame. }
    wp_pures; iModIntro; iApply "HΦ"; iFrame; iExists _, _; auto.
  Qed.

  Lemma revoke_works γ P Q v :
    {{{ is_offer γ P Q v ∗ revoke_tok γ }}}
      revoke_offer v
    {{{ v', RET v'; (∃ v'' : val, ⌜v' = InjRV v''⌝ ∗ can_push P Q v'') ∨ (⌜v' = InjLV #()⌝ ∗ (Q #())) }}}.
  Proof.
    iIntros (Φ) "[Hinv Hγ] HΦ". iDestruct "Hinv" as (v' l) "[-> #Hinv]".
    wp_lam. wp_pures. wp_bind (CmpXchg _ _ _).
    iInv Nside_channel as "Hstages" "Hclose".
    iDestruct "Hstages" as "[[Hl HP] | [[Hl HQ] | [[Hl H] | [Hl H]]]]".
    - wp_cmpxchg_suc.
      iMod ("Hclose" with "[Hl Hγ]") as "_".
      { iNext; iRight; iRight; iFrame. }
      iModIntro.
      wp_pures.
      by iApply "HΦ"; iLeft; iExists _; iFrame.
    - wp_cmpxchg_fail.
      iMod ("Hclose" with "[Hl Hγ]") as "_".
      { iNext; iRight; iRight; iLeft; iFrame. }
      iModIntro.
      wp_pures.
      iApply ("HΦ" with "[HQ]"); iRight; auto.
    - wp_cmpxchg_fail.
      iDestruct (own_valid_2 with "H Hγ") as %[].
    - wp_cmpxchg_fail.
      iDestruct (own_valid_2 with "H Hγ") as %[].
  Qed.

  Lemma take_works γ P Q Q' o Ψ :
    let do_pop : iProp Σ :=
        (∀ v xs, P (v :: xs) ={inner_mask}=∗ P xs ∗ Ψ (SOMEV v))%I in
    {{{ is_offer γ P Q o ∗ access_inv P ∗ (do_pop ∧ Q') }}}
      take_offer o
    {{{ v', RET v';
        (∃ v'' : val, ⌜v' = InjRV v''⌝ ∗ Ψ v') ∨ (⌜v' = InjLV #()⌝ ∗ (do_pop ∧ Q')) }}}.
  Proof.
    simpl; iIntros (Φ) "[H [Hopener Hupd]] HΦ"; iDestruct "H" as (v l) "[-> #Hinv]".
    wp_lam. wp_proj. wp_bind (CmpXchg _ _ _).
    iInv Nside_channel as "Hstages" "Hclose".
    iDestruct "Hstages" as "[[Hl Hpush] | [[Hl HQ] | [[Hl Hγ] | [Hl Hγ]]]]".
    - iMod "Hopener" as (xs) "[HP Hcloser]".
      wp_cmpxchg_suc.
      iMod ("Hpush" with "HP") as "[HP HQ]".
      iMod ("Hupd" with "HP") as "[HP HΨ]".
      iMod ("Hcloser" with "HP") as "_".
      iMod ("Hclose" with "[Hl HQ]") as "_".
      { iRight; iLeft; iFrame. }
      iApply fupd_intro_mask; first done.
      wp_pures.
      iApply "HΦ"; iLeft; auto.
    - wp_cmpxchg_fail.
      iMod ("Hclose" with "[Hl HQ]") as "_".
      { iRight; iLeft; iFrame. }
      iModIntro.
      wp_pures.
      iApply "HΦ"; auto.
    - wp_cmpxchg_fail.
      iMod ("Hclose" with "[Hl Hγ]").
      { iRight; iRight; iFrame. }
      iModIntro.
      wp_pures.
      iApply "HΦ"; auto.
    - wp_cmpxchg_fail.
      iMod ("Hclose" with "[Hl Hγ]").
      { iRight; iRight; iFrame. }
      iModIntro.
      wp_pures.
      iApply "HΦ"; auto.
  Qed.

  Definition mailbox_inv P l : iProp Σ :=
    (l ↦ NONEV ∨ (∃ v' γ Q, l ↦ SOMEV v' ∗ is_offer γ P Q v'))%I.

  Definition is_mailbox P v : iProp Σ :=
    (∃ l, ⌜v = #l⌝ ∗ inv Nmailbox (mailbox_inv P l))%I.

  Lemma mk_mailbox_works P :
    {{{ True }}} mk_mailbox #() {{{ v, RET v; is_mailbox P v }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    rewrite -wp_fupd. wp_lam. wp_alloc l as "Hl".
    iMod (inv_alloc Nmailbox _ (mailbox_inv P l) with "[Hl]") as "#Hinv".
    { iNext; by iLeft. }
    iModIntro.
    iApply "HΦ"; iExists _; auto.
  Qed.

  Lemma get_works Q P Ψ mailbox :
    let do_pop : iProp Σ :=
        (∀ v xs, P (v :: xs) ={inner_mask}=∗ P xs ∗ Ψ (SOMEV v))%I in
    {{{ is_mailbox P mailbox ∗ access_inv P ∗ (do_pop ∧ Q) }}}
      get mailbox
    {{{ ov, RET ov; (∃ v, ⌜ov = SOMEV v⌝ ∗ Ψ ov) ∨ (⌜ov = NONEV⌝ ∗ (do_pop ∧ Q)) }}}.
  Proof.
    simpl; iIntros (Φ) "[Hmail [Hopener Hpush]] HΦ". iDestruct "Hmail" as (l) "[-> #Hmail]".
    wp_lam. wp_bind (Load _).
    iInv Nmailbox as "[Hnone | Hsome]" "Hclose".
    - wp_load.
      iMod ("Hclose" with "[Hnone]") as "_".
      { by iLeft. }
      iModIntro.
      wp_pures.
      iApply "HΦ"; iRight; by iFrame.
    - iDestruct "Hsome" as (v' γ Q') "[Hl #Hoffer]".
      wp_load.
      iMod ("Hclose" with "[Hl Hoffer]") as "_".
      { iNext; iRight; iExists _, _, _; by iFrame. }
      iModIntro.
      wp_let. wp_match. wp_apply (take_works with "[Hpush Hopener]"); by iFrame.
  Qed.

  Lemma put_works P Q mailbox v :
    {{{ is_mailbox P mailbox ∗ can_push P Q v }}}
      put mailbox v
    {{{ o, RET o; (∃ v', ⌜o = SOMEV v'⌝ ∗ can_push P Q v') ∨ (⌜o = NONEV⌝ ∗ Q #()) }}}.
  Proof.
    iIntros (Φ) "[Hmail Hpush] HΦ". iDestruct "Hmail" as (l) "[-> #Hmail]".
    wp_lam. wp_let. wp_apply (mk_offer_works with "Hpush").
    iIntros (o γ) "[#Hoffer Hrev]".
    wp_let. wp_bind (Store _ _). wp_pures.
    iInv Nmailbox as "[Hnone | Hsome]" "Hclose".
    - wp_store.
      iMod ("Hclose" with "[Hnone]") as "_".
      { iNext; iRight; iExists _, _, _; by iFrame. }
      iModIntro.
      wp_pures.
      wp_apply (revoke_works with "[Hrev]"); first auto.
      iIntros (v') "H"; iApply "HΦ"; auto.
    - iDestruct "Hsome" as (? ? ?) "[Hl _]". wp_store.
      iMod ("Hclose" with "[Hl]") as "_".
      { iNext; iRight; iExists _, _, _; by iFrame. }
      iModIntro.
      wp_pures.
      wp_apply (revoke_works with "[Hrev]"); first auto.
      iIntros (v') "H"; iApply "HΦ"; auto.
  Qed.

  Local Notation "l ↦{-} v" := (∃ q, l ↦{q} v)%I
    (at level 20, format "l  ↦{-}  v") : bi_scope.

  Lemma partial_mapsto_duplicable l v :
    l ↦{-} v -∗ l ↦{-} v ∗ l ↦{-} v.
  Proof.
    iIntros "H"; iDestruct "H" as (?) "[Hl Hl']"; iSplitL "Hl"; eauto.
  Qed.

  Lemma partial_mapsto_agree l v1 v2 :
    l ↦{-} v1 -∗ l ↦{-} v2 -∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "H1 H2".
    iDestruct "H1" as (?) "H1".
    iDestruct "H2" as (?) "H2".
    iApply (mapsto_agree with "H1 H2").
  Qed.

  Definition oloc_to_val (ol: option loc) : val :=
    match ol with
    | None => NONEV
    | Some loc => SOMEV (#loc)
    end.
  Local Instance oloc_to_val_inj : Inj (=) (=) oloc_to_val.
  Proof. intros [|][|]; simpl; congruence. Qed.

  Fixpoint is_list xs v : iProp Σ :=
    (match xs, v with
     | [], None => True
     | x :: xs, Some l => ∃ t, l ↦{-} (x, oloc_to_val t)%V ∗ is_list xs t
     | _, _ => False
     end)%I.

  Lemma is_list_dup xs v :
    is_list xs v -∗ is_list xs v ∗ match v with
      | None => True
      | Some l => ∃ h t, l ↦{-} (h, oloc_to_val t)%V
      end.
  Proof.
    destruct xs, v; simpl; auto; first by iIntros "[]".
    iIntros "H"; iDestruct "H" as (t) "(Hl & Hstack)".
    iDestruct (partial_mapsto_duplicable with "Hl") as "[Hl1 Hl2]".
    iSplitR "Hl2"; first by (iExists _; iFrame). by iExists _, _.
  Qed.

  Lemma is_list_empty xs :
    is_list xs None -∗ ⌜xs = []⌝.
  Proof.
    destruct xs; iIntros "Hstack"; auto.
  Qed.

  Lemma is_list_cons xs l h t :
    l ↦{-} (h, t)%V -∗
    is_list xs (Some l) -∗
    ∃ ys, ⌜xs = h :: ys⌝.
  Proof.
    destruct xs; first by iIntros "? %".
    iIntros "Hl Hstack"; iDestruct "Hstack" as (t') "(Hl' & Hrest)".
    iDestruct (partial_mapsto_agree with "Hl Hl'") as "%"; simplify_eq; iExists _; auto.
  Qed.

  Definition stack_inv P l :=
    (∃ v xs, l ↦ oloc_to_val v ∗ is_list xs v ∗ P xs)%I.

  Definition is_stack_pred P v :=
    (∃ mailbox l, ⌜v = (mailbox, #l)%V⌝ ∗ is_mailbox P mailbox ∗ inv Nstack (stack_inv P l))%I.

  Theorem mk_stack_works (P : list val → iProp Σ) :
    {{{ P [] }}} mk_stack #() {{{ v, RET v; is_stack_pred P v }}}.
  Proof.
    iIntros (Φ) "HP HΦ".
    rewrite -wp_fupd.
    wp_lam.
    wp_alloc l as "Hl".
    wp_apply mk_mailbox_works ; first done. iIntros (v) "#Hmailbox".
    iMod (inv_alloc Nstack _ (stack_inv P l) with "[Hl HP]") as "#Hinv".
    { by iNext; iExists None, []; iFrame. }
    wp_pures. iModIntro; iApply "HΦ"; iExists _; auto.
  Qed.

  Theorem push_works P s v Ψ :
    {{{ is_stack_pred P s ∗ ∀ xs, P xs ={⊤ ∖ ↑ N}=∗ P (v :: xs) ∗ Ψ #()}}}
      push s v
    {{{ RET #(); Ψ #() }}}.
  Proof.
    iIntros (Φ) "[Hstack Hupd] HΦ". iDestruct "Hstack" as (mailbox l) "(-> & #Hmailbox & #Hinv)".
    iAssert (∀ (xs : list val), P xs ={inner_mask}=∗ P (v :: xs) ∗ Ψ #())%I with "[Hupd]" as "Hupd".
    { iIntros (xs). by iApply inner_mask_promote. }
    iLöb as "IH" forall (v).
    wp_lam. wp_pures.
    wp_apply (put_works with "[Hupd]"); first auto. iIntros (o) "H".
    iDestruct "H" as "[Hsome | [-> HΨ]]".
    - iDestruct "Hsome" as (v') "[-> Hupd]".
      wp_match.
      wp_bind (Load _).
      iInv Nstack as (list xs) "(Hl & Hlist & HP)" "Hclose".
      wp_load.
      iMod ("Hclose" with "[Hl Hlist HP]") as "_".
      { iNext; iExists _, _; iFrame. }
      clear xs.
      iModIntro.
      wp_let. wp_alloc l' as "Hl'". wp_pures. wp_bind (CmpXchg _ _ _).
      iInv Nstack as (list' xs) "(Hl & Hlist & HP)" "Hclose".
      destruct (decide (list = list')) as [ -> |].
      * wp_cmpxchg_suc. { destruct list'; left; done. }
        iMod (fupd_intro_mask' (⊤ ∖ ↑Nstack) inner_mask) as "Hupd'"; first solve_ndisj.
        iMod ("Hupd" with "HP") as "[HP HΨ]".
        iMod "Hupd'" as "_".
        iMod ("Hclose" with "[Hl Hl' HP Hlist]") as "_".
        { iNext; iExists (Some _), (v' :: xs); iFrame; iExists _; iFrame; auto. }
        iModIntro.
        wp_pures.
        by iApply ("HΦ" with "HΨ").
      * wp_cmpxchg_fail.
      { destruct list, list'; simpl; congruence. }
      { destruct list'; left; done. }
        iMod ("Hclose" with "[Hl HP Hlist]").
        { iExists _, _; iFrame. }
        iModIntro.
        wp_pures.
        iApply ("IH" with "HΦ Hupd").
    - wp_match. iApply ("HΦ" with "HΨ").
  Qed.

  Theorem pop_works P s Ψ :
    {{{ is_stack_pred P s ∗
        (∀ v xs, P (v :: xs) ={⊤ ∖ ↑ N}=∗ P xs ∗ Ψ (SOMEV v)) ∧
        (P [] ={⊤ ∖ ↑ N}=∗ P [] ∗ Ψ NONEV) }}}
      pop s
    {{{ v, RET v; Ψ v }}}.
  Proof.
    iIntros (Φ) "(Hstack & Hupd) HΦ".
    iDestruct "Hstack" as (mailbox l) "(-> & #Hmailbox & #Hinv)".
    iDestruct (bi.and_mono_r with "Hupd") as "Hupd"; first apply inner_mask_promote.
    iDestruct (bi.and_mono_l _ _ (∀ (v : val) (xs : list val), _)%I with "Hupd") as "Hupd".
    { iIntros "Hupdcons". iIntros (v xs). iSpecialize ("Hupdcons" $! v xs). iApply (inner_mask_promote with "Hupdcons"). }
    iLöb as "IH".
    wp_lam. wp_proj. wp_let. wp_proj. wp_let.
    wp_apply (get_works _ _ (λ v, Ψ v) with "[Hupd]").
    { iSplitR; first done.
      iFrame.
      iInv Nstack as (v xs) "(Hl & Hlist & HP)" "Hclose".
      iModIntro.
      iExists xs; iSplitL "HP"; first auto.
      iIntros "HP".
      iMod ("Hclose" with "[HP Hl Hlist]") as "_".
      { iNext; iExists _, _; iFrame. }
      auto. }
    iIntros (ov) "[Hsome | [-> Hupd]]".
    - iDestruct "Hsome" as (v) "[-> HΨ]".
      wp_pures.
      iApply ("HΦ" with "HΨ").
    - wp_match. wp_bind (Load _).
      iInv Nstack as (v xs) "(Hl & Hlist & HP)" "Hclose".
      wp_load.
      iDestruct (is_list_dup with "Hlist") as "[Hlist H]".
    destruct v as [l'|]; last first.
      * iDestruct (is_list_empty with "Hlist") as %->.
        iMod (fupd_intro_mask' (⊤ ∖ ↑Nstack) inner_mask) as "Hupd'"; first solve_ndisj.
        iMod ("Hupd" with "HP") as "[HP HΨ]".
        iMod "Hupd'" as "_".
        iMod ("Hclose" with "[Hlist Hl HP]") as "_".
        { iNext; iExists _, _; iFrame. }
        iModIntro.
        wp_match.
        iApply ("HΦ" with "HΨ").
      * iDestruct "H" as (h t) "Hl'".
        iMod ("Hclose" with "[Hlist Hl HP]") as "_".
        { iNext; iExists _, _; iFrame. }
        iModIntro.
        wp_match. wp_bind (Load _).
        iInv Nstack as (v xs') "(Hl & Hlist & HP)" "Hclose".
        iDestruct "Hl'" as (q) "Hl'".
        wp_load.
        iMod ("Hclose" with "[Hlist Hl HP]") as "_".
        { iNext; iExists _, _; iFrame. }
        iModIntro.
        wp_pures. wp_bind (CmpXchg _ _ _).
        iInv Nstack as (v' xs'') "(Hl & Hlist & HP)" "Hclose".
        destruct (decide (v' = (Some l'))) as [ -> |].
        + wp_cmpxchg_suc.
          iDestruct (is_list_cons with "[Hl'] Hlist") as (ys) "%"; first by iExists _.
          simplify_eq.
          iMod (fupd_intro_mask' (⊤ ∖ ↑Nstack) inner_mask) as "Hupd'"; first solve_ndisj.
          iDestruct "Hupd" as "[Hupdcons _]".
          iMod ("Hupdcons" with "HP") as "[HP HΨ]".
          iMod "Hupd'" as "_".
          iDestruct "Hlist" as (t') "(Hl'' & Hlist)".
          iDestruct "Hl''" as (q') "Hl''".
          iDestruct (mapsto_agree with "Hl' Hl''") as "%"; simplify_eq.
          iMod ("Hclose" with "[Hlist Hl HP]") as "_".
          { iNext; iExists _, _; iFrame. }
          iModIntro.
          wp_pures.
          iApply ("HΦ" with "HΨ").
        + wp_cmpxchg_fail. { destruct v'; simpl; congruence. }
          iMod ("Hclose" with "[Hlist Hl HP]") as "_".
          { iNext; iExists _, _; iFrame. }
          iModIntro.
          wp_pures.
          iApply ("IH" with "HΦ Hupd").
  Qed.
End proofs.

Program Definition spec {Σ} `{heapG Σ, channelG Σ} : concurrent_stack Σ :=
  {| is_stack := is_stack_pred; new_stack := mk_stack; stack_push := push; stack_pop := pop |} .
Solve Obligations of spec with eauto using pop_works, push_works, mk_stack_works.


Class MFix (m:Type->Type) : Type :=
  { mfix : forall {A B:Type}, ((A -> m B) -> (A -> m B)) -> (A -> m B) }.

Definition mfix2 {m} {MFix_:MFix m} {A B C}
    (ff:(A -> B -> m C) -> A -> B -> m C) (a:A) (b:B) : m C :=
  let ff' (f:A*B -> m C) (ab:A*B) : m C :=
    let f' (a:A) (b:B) : m C := f (a,b) in
    let (a,b) := ab in
    ff f' a b
  in mfix ff' (a,b).

Definition mfix3 {m} {MFix_:MFix m} {A B C D}
    (ff:(A -> B -> C -> m D) -> A -> B -> C -> m D) (a:A) (b:B) (c:C) : m D :=
  let ff' (f:A*B*C -> m D) (abc:A*B*C) : m D :=
    let f' (a:A) (b:B) (c:C) : m D := f (a,b,c) in
    let '(a,b,c) := abc in
    ff f' a b c
  in mfix ff' (a,b,c).


(** From the Coq manual, updated to work with the current (8.4)
   standard library *)
Require Import List.
Require Import Permutation.
Ltac permutAux n :=
match goal with
| |- (Permutation ?l ?l) => reflexivity
| |- (Permutation (?a :: ?l1) (?a :: ?l2)) =>
    let newn := eval compute in (length l1) in
    (apply perm_skip; permutAux newn)
| |- (Permutation (?a :: ?l1) ?l2) =>
    match eval compute in n with
    | 1 => fail
    | _ =>
        let l1' := constr:(l1 ++ a :: nil) in
        (apply (@perm_trans _ (a :: l1) l1' l2);
          [ apply Permutation_cons_append | compute; permutAux (pred n) ])
    end
end.

(** Permutation solver *)
Ltac permut :=
  match goal with
  | |- (Permutation ?l1 ?l2) =>
      match eval compute in (length l1 = length l2) with
      | (?n = ?n) => permutAux n
      end
  end.

(*
Notation "[ x , .. , y ]" := (x :: .. (y :: nil) ..) : list_scope.
Lemma fu : Permutation [1,2,3] [3,1,2].
Proof. permut. Qed.
*)