Require Import Coq.omega.Omega.
Require Import Platform.AutoSepExt.
Export AutoSepExt.

Ltac refold' A :=
  progress change (fix length (l : list A) : nat :=
    match l with
      | nil => 0
      | _ :: l' => S (length l')
    end) with (@length A) in *
  || (progress change (fix app (l0 m : list A) : list A :=
    match l0 with
      | nil => m
      | a1 :: l1 => a1 :: app l1 m
    end) with (@app A) in *)
  || (progress change (fix rev (l : list W) : list W :=
    match l with
      | nil => nil
      | x8 :: l' => (rev l' ++ x8 :: nil)%list
    end) with (@rev A) in *)
  || (progress change (fix rev_append (l l' : list A) : list A :=
    match l with
      | nil => l'
      | a1 :: l0 => rev_append l0 (a1 :: l')
    end) with (@rev_append A) in *).

Ltac refold :=
  fold plus in *; fold minus in *;
    repeat match goal with
             | [ _ : list ?A |- _ ] =>
               match A with
                 | _ => refold' A
                 | W => refold' (word 32)
               end
             | [ |- context[match ?X with nil => ?D | x :: _ => x end] ] =>
               change (match X with nil => D | x :: _ => x end) with (List.hd D X)
             | [ |- context[match ?X with nil => nil | _ :: x => x end] ] =>
               change (match X with nil => nil | _ :: x => x end) with (List.tl X)
           end.

Section Note_.
  Variable imps : LabelMap.t assert.
  Variable mn : string.

  Import DefineStructured.
  Transparent evalInstrs.

  Definition Note_ (P : Prop) : cmd imps mn.
    red; refine (fun pre => {|
      Postcondition := (fun st => pre st /\ [| P |])%PropX;
      VerifCond := P :: nil;
      Generate := fun Base Exit => {|
        Entry := 0;
        Blocks := (pre, (nil, Uncond (RvLabel (mn, Local Exit)))) :: nil
      |}
    |}); abstract (struct; repeat esplit; eauto; propxFo).
  Defined.
End Note_.

Definition Note__ (P : Prop) : chunk := fun _ _ =>
  Structured nil (fun _ _ _ => Note_ _ _ P).

Notation "'Note' [ P ]" := (Note__ P) (no associativity, at level 95) : SP_scope.

Section SomethingStar.
  Variable imps : LabelMap.t assert.
  Variable mn : string.

  Fixpoint augment (specs : codeSpec W (settings * state)) (stn : settings) (ls : list (string * string)) : Prop :=
    match ls with
      | nil => True
      | (mn, f) :: ls =>
        match LabelMap.find (mn, Global f) imps with
          | None => True
          | Some p => (exists pc, stn.(Labels) (mn, Global f) = Some pc /\ specs pc = Some p) /\ augment specs stn ls
        end
    end.

  Lemma prove_augment : forall specs stn ls,
    (forall mn f (pre : assert),
      LabelMap.MapsTo (mn, Global f) pre imps
      -> exists w : W, Labels stn (mn, Global f) = Some w /\ specs w = Some pre)
    -> augment specs stn ls.
    induction ls; simpl; intuition.
    case_eq (LabelMap.find (a0, Global b) imps); intuition.
    apply LabelMap.find_2 in H1; eauto.
  Qed.

  Import DefineStructured.

  Variable ls : list (string * string).

  Transparent evalInstrs.

  Hint Resolve prove_augment.

  Section IGotoStar.
    Variable rv : rvalue.

    Definition IGotoStar_ : cmd imps mn.
      red; refine (fun pre => {|
        Postcondition := (fun _ => [|False|])%PropX;
        VerifCond := (forall specs stn st, interp specs (pre (stn, st))
          -> augment specs stn ls
          -> match evalRvalue stn st rv with
               | None => rvalueCrashes rv
               | Some w => exists pre', specs w = Some pre'
                 /\ interp specs (pre' (stn, st))
             end) :: nil;
        Generate := fun Base Exit => {|
          Entry := 0;
          Blocks := (pre, (nil, Uncond rv)) :: nil
        |}
      |}); abstract (solve [ struct
        | intros; repeat match goal with
                           | [ H : vcs nil |- _ ] => clear H
                           | [ H : vcs (_ :: _) |- _ ] => inversion H; clear H; subst
                           | [ |- List.Forall _ _ ] => constructor; simpl
                           | [ |- blockOk _ _ _ ] => hnf; intros
                           | [ H : forall x y z, interp _ _ -> augment _ _ _ -> _, H' : interp _ _ |- _ ] =>
                             specialize (H _ _ _ H');
                               match type of H with
                                 | ?P -> _ => assert P by auto; intuition simpl
                               end
                           | [ H : match ?X with None => _ | _ => _ end |- _ ] => destruct X; intuition
                           | [ H : Logic.ex _ |- _ ] => destruct H; intuition eauto
                         end ]).
    Defined.
  End IGotoStar.

  Section AssertStar.
    Variable post : assert.

    Definition AssertStar_ : cmd imps mn.
      red; refine (fun pre => {|
        Postcondition := post;
        VerifCond := (forall stn_st specs, interp specs (pre stn_st)
          -> augment specs (fst stn_st) ls
          -> interp specs (post stn_st)) :: nil;
        Generate := fun Base Exit => {|
          Entry := 0;
          Blocks := (pre, (nil, Uncond (RvLabel (mn, Local Exit)))) :: nil
        |}
      |}); abstract solve [ struct
        | intros; repeat match goal with
                           | [ H : vcs nil |- _ ] => clear H
                           | [ H : vcs (_ :: _) |- _ ] => inversion H; clear H; subst
                           | [ |- List.Forall _ _ ] => constructor; simpl
                           | [ |- blockOk _ _ _ ] => hnf; intros
                           | [ H : forall x y z, interp _ _ -> augment _ _ _ -> _, H' : interp _ _ |- _ ] =>
                             specialize (H _ _ _ H');
                               match type of H with
                                 | ?P -> _ => assert P by auto; intuition simpl
                               end
                           | [ H : match ?X with None => _ | _ => _ end |- _ ] => destruct X; intuition
                           | [ H : Logic.ex _ |- _ ] => destruct H; intuition eauto
                           | [ H : forall l : LabelMap.key, _ |- _ ] => destruct (H (mn, Local Exit) post) as [ ? [ ] ];
                             [ solve [ auto ] | ]; do 2 esplit; [ unfold evalBlock; simpl;
                               match goal with
                                 | [ H : _ |- _ ] => solve [ rewrite H; eauto ]
                               end | simpl; do 2 esplit; eauto; match goal with
                                                                  | [ H : _ |- _ ] => apply H; auto
                                                                end ]
                         end ].
    Defined.
  End AssertStar.
End SomethingStar.

Definition IGotoStar ls (rv : rvalue') : chunk := fun ns _ =>
  Structured nil (fun _ _ _ => IGotoStar_ _ _ ls (rv ns)).

Notation "'IGoto*' [ l1 , .. , lN ] rv" := (IGotoStar (cons l1 (.. (cons lN nil) ..)) rv) (no associativity, at level 95) : SP_scope.

Definition AssertStar ls (post : list string -> nat -> assert) : chunk := fun ns res =>
  Structured nil (fun _ _ _ => AssertStar_ _ _ ls (post ns res)).

Local Notation INV := (fun inv => inv true (fun w => w)).

Notation "'Assert*' [ l1 , .. , lN ] [ post ]" := (AssertStar (cons l1 (.. (cons lN nil) ..)) (INV post)) (no associativity, at level 95) : SP_scope.

Require Import Coq.Bool.Bool.

Definition localsInvariantCont (pre : vals -> W -> qspec) (rpStashed : bool) (adjustSp : W -> W)
  (ns : list string) (res : nat) : assert :=
  st ~> let sp := adjustSp st#Sp in
    ExX, Ex vs, qspecOut (pre (sel vs) st#Rv) (fun pre =>
      ![ ^[locals ("rp" :: ns) vs res sp * pre] * #0 ] st).

Notation "'PREonly' [ vs ] pre" := (localsInvariantCont (fun vs _ => pre%qspec%Sep))
  (at level 89).

Notation "'PREonly' [ vs , rv ] pre" := (localsInvariantCont (fun vs rv => pre%qspec%Sep))
  (at level 89).

Notation "'bfunctionNoRet' name () [ p ] b 'end'" :=
  (let p' := p in
   let vars := nil in
   let b' := b%SP in
    {| FName := name;
      FPrecondition := Precondition p' None;
      FBody := ((fun _ _ =>
        Structured nil (fun im mn _ => Structured.Assert_ im mn (Precondition p' (Some vars))));;
      (fun ns res => b' ns (res - (List.length vars - List.length (Formals p')))%nat))%SP;
      FVars := vars;
      FReserved := Reserved p' |})
  (no associativity, at level 95, name at level 0, p at level 0, only parsing) : SPfuncs_scope.

Notation "'bfunctionNoRet' name ( x1 , .. , xN ) [ p ] b 'end'" :=
  (let p' := p in
   let vars := cons x1 (.. (cons xN nil) ..) in
   let b' := b%SP in
    {| FName := name;
      FPrecondition := Precondition p' None;
      FBody := ((fun _ _ =>
        Structured nil (fun im mn _ => Structured.Assert_ im mn (Precondition p' (Some vars))));;
      (fun ns res => b' ns (res - (List.length vars - List.length (Formals p')))%nat))%SP;
      FVars := vars;
      FReserved := Reserved p' |})
  (no associativity, at level 95, name at level 0, p at level 0, only parsing) : SPfuncs_scope.

(* added Conditional *)
Require Import Platform.Conditional.
Export Conditional.

Ltac vcgen_simp := cbv beta iota zeta delta [map app imps
  LabelMap.add Entry Blocks Postcondition VerifCond
  Straightline_ Seq_ Diverge_ Fail_ Skip_ Assert_
  Structured.If_ Structured.While_ Goto_ Structured.Call_ IGoto
  setArgs Programming.Reserved Programming.Formals Programming.Precondition
  importsMap fullImports buildLocals blocks union Nplus Nsucc length N_of_nat
  List.fold_left ascii_lt string_lt label'_lt
  LabelKey.compare' LabelKey.compare LabelKey.eq_dec
  LabelMap.find
  toCmd Seq Instr Diverge Fail Skip Assert_
  Programming.If_ Programming.While_ Goto Programming.Call_ RvImm'
  Assign' localsInvariant localsInvariantCont
  regInL lvalIn immInR labelIn variableSlot string_eq ascii_eq
  andb eqb qspecOut
  ICall_ Structured.ICall_
  Assert_ Structured.Assert_
  LabelMap.Raw.find LabelMap.this LabelMap.Raw.add
  LabelMap.empty LabelMap.Raw.empty string_dec
  Ascii.ascii_dec string_rec string_rect sumbool_rec sumbool_rect Ascii.ascii_rec Ascii.ascii_rect
  Bool.bool_dec bool_rec bool_rect eq_rec_r eq_rec eq_rect eq_sym
  fst snd labl
  Ascii.N_of_ascii Ascii.N_of_digits N.compare Nmult Pos.compare Pos.compare_cont
  Pos.mul Pos.add LabelMap.Raw.bal
  Int.Z_as_Int.gt_le_dec Int.Z_as_Int.ge_lt_dec LabelMap.Raw.create
  ZArith_dec.Z_gt_le_dec Int.Z_as_Int.plus Int.Z_as_Int.max LabelMap.Raw.height
  ZArith_dec.Z_gt_dec Int.Z_as_Int._1 BinInt.Z.add Int.Z_as_Int._0 Int.Z_as_Int._2 BinInt.Z.max
  ZArith_dec.Zcompare_rec ZArith_dec.Z_ge_lt_dec BinInt.Z.compare ZArith_dec.Zcompare_rect
  ZArith_dec.Z_ge_dec label'_eq label'_rec label'_rect
  COperand1 CTest COperand2 Pos.succ
  makeVcs
  Note_ Note__
  IGotoStar_ IGotoStar AssertStar_ AssertStar
  Cond_ Cond
].

Ltac vcgen :=
(*TIME time "vcgen:structured_auto" ( *)
  structured_auto vcgen_simp
(*TIME ) *);
(*TIME time "vcgen:finish" ( *)
  autorewrite with sepFormula in *; simpl in *;
    unfold starB, hvarB, hpropB in *; fold hprop in *; refold
(*TIME ) *).

Hint Extern 1 => tauto : contradiction.
Hint Extern 1 => congruence : contradiction.

Ltac sep_easy := auto with contradiction.

Lemma frame_reflexivity : forall pcT stateT p q specs,
  q = (fun pr => p (fst pr) (snd pr))
  -> himp (pcType := pcT) (stateType := stateT) specs p (fun st m => q (st, m)).
  intros; hnf; simpl; intros; subst.
  apply Imply_I; eauto.
Qed.

Ltac rereg :=
  repeat match goal with
           | [ _ : context[Regs (match ?st with
                                   | (_, y) => y
                                 end) ?r] |- _ ] =>
             change (Regs (let (_, y) := st in y) r) with (st#r) in *
           | [ |- context[Regs (match ?st with
                                  | (_, y) => y
                                end) ?r] ] =>
             change (Regs (let (_, y) := st in y) r) with (st#r) in *
         end.

Ltac sep_firstorder := sep_easy;
  repeat match goal with
           | [ H : Logic.ex _ |- _ ] => destruct H
           | [ H : _ /\ _ |- _ ] => destruct H
           | [ |- Logic.ex _ ] => sep_easy; eexists
           | [ |- _ /\ _ ] => split
           | [ |- forall x, _ ] => intro
           | [ |- _ = _ ] => reflexivity
           | [ |- himp _ _ _ ] => reflexivity
             || (apply frame_reflexivity; try match goal with
                                                | [ |- _ = ?X ] => instantiate (1 := X)
                                              end; apply refl_equal)
         end; sep_easy; autorewrite with sepFormula; rereg; try subst.

Require Import Coq.NArith.NArith.
Import TacPackIL.

Ltac hints_ext_simplifier hints := fun s1 s2 s3 H =>
  match H with
  | tt =>
      cbv beta iota zeta
       delta [s1 s2 s3 hints
         (** Symbolic Evaluation **)
         SymIL.MEVAL.PredEval.fold_args
         SymIL.MEVAL.PredEval.fold_args_update SymIL.MEVAL.PredEval.pred_read_word
         SymIL.MEVAL.PredEval.pred_write_word SymIL.MEVAL.PredEval.pred_read_byte SymIL.MEVAL.PredEval.pred_write_byte
         SymIL.MEVAL.LearnHookDefault.LearnHook_default
         SymIL.IL_ReadWord SymIL.IL_WriteWord SymIL.IL_ReadByte SymIL.IL_WriteByte
         SymILTac.unfolder_LearnHook
         SymIL.MEVAL.Composite.MemEvaluator_composite
         SymIL.MEVAL.Default.smemeval_read_word_default
         SymIL.MEVAL.Default.smemeval_write_word_default
         SymIL.sym_evalInstrs
         SymIL.sym_evalInstr SymIL.sym_evalLval SymIL.sym_evalRval
         SymIL.sym_evalLoc SymIL.sym_evalStream SymIL.sym_assertTest
         SymIL.sym_setReg SymIL.sym_getReg
         SymIL.SymMem SymIL.SymRegs SymIL.SymPures
(*         SymIL.SymVars SymIL.SymUVars *)
         SymIL.stateD
         SymILTac.quantifyNewVars
         SymILTac.unfolder_LearnHook
         ILAlgoTypes.Hints ILAlgoTypes.Prover
         SymIL.MEVAL.sread_word SymIL.MEVAL.swrite_word SymIL.MEVAL.sread_byte SymIL.MEVAL.swrite_byte
         ILAlgoTypes.MemEval ILAlgoTypes.Env ILAlgoTypes.Algos
         (*SymIL.quantifyNewVars*)
         ILAlgoTypes.Algos ILAlgoTypes.Hints ILAlgoTypes.Prover

         SymEval.quantD SymEval.appendQ
         SymEval.qex SymEval.qall
         SymEval.gatherAll SymEval.gatherEx
         SymILTac.sym_eval

         (** ILEnv **)
         ILEnv.comparator ILEnv.fPlus ILEnv.fMinus ILEnv.fMult
         ILEnv.bedrock_types_r ILEnv.bedrock_funcs_r
         ILEnv.bedrock_types
         ILEnv.BedrockCoreEnv.core
         ILEnv.BedrockCoreEnv.pc ILEnv.BedrockCoreEnv.st
         ILEnv.bedrock_type_W ILEnv.bedrock_type_nat
         ILEnv.bedrock_type_setting_X_state
         ILEnv.bedrock_type_state
(*         ILEnv.bedrock_type_test *)
         ILEnv.bedrock_type_reg

(*         ILEnv.test_seq *)
         ILEnv.reg_seq
         ILEnv.W_seq

         ILEnv.word_nat_r
         ILEnv.word_state_r
(*         ILEnv.word_test_r *)

         ILEnv.wplus_r
         ILEnv.wminus_r
         ILEnv.wmult_r
(*         ILEnv.word_test_r *)
(*         ILEnv.wcomparator_r *)
         ILEnv.Regs_r
         ILEnv.wlt_r
         ILEnv.natToW_r

         (** Env **)
         Env.repr_combine Env.default Env.footprint Env.repr'
         Env.updateAt Env.nil_Repr Env.repr Env.updateAt
         Env.repr_combine Env.footprint Env.default Env.repr

         (** Expr **)
         Expr.Range Expr.Domain Expr.Denotation Expr.Impl Expr.Eqb
         Expr.exists_subst Expr.forallEach Expr.existsEach
         Expr.AllProvable Expr.AllProvable_gen
         Expr.AllProvable_and Expr.AllProvable_impl
         Expr.tvarD Expr.exprD Expr.applyD Expr.Impl_ Expr.EqDec_tvar
         Expr.liftExpr Expr.lookupAs
         Expr.Provable Expr.tvar_val_seqb
         Expr.Provable Expr.tvarD
         Expr.tvar_rec Expr.tvar_rect
         Expr.Default_signature Expr.EmptySet_type
         Expr.expr_seq_dec
         Expr.Eqb Expr.liftExpr Expr.exprSubstU
         Expr.typeof Expr.typeof_env
         Expr.typeof_sig Expr.typeof_funcs
         Expr.expr_ind
         Expr.get_Eq
         Expr.const_seqb
         Expr.tvar_seqb
         Expr.tvar_val_seqb_correct
         Expr.tvar_seqb_correct
         Expr.mentionsU
         ReifyExpr.default_type

         (** ExprUnify **)
         CancelIL.U.exprUnify CancelIL.U.exprUnify_recursor
         CancelIL.U.exprInstantiate CancelIL.U.subst_exprInstantiate
         CancelIL.U.Subst_lookup CancelIL.U.subst_lookup
         CancelIL.U.Subst_empty CancelIL.U.subst_empty
         CancelIL.U.Subst_set CancelIL.U.subst_set
         CancelIL.U.Subst_equations
         CancelIL.U.Subst_size
         CancelIL.U.dep_in

         CancelIL.U.FM.Raw.height CancelIL.U.FM.Raw.cardinal CancelIL.U.FM.Raw.assert_false CancelIL.U.FM.Raw.create
         CancelIL.U.FM.Raw.bal CancelIL.U.FM.Raw.remove_min CancelIL.U.FM.Raw.merge CancelIL.U.FM.Raw.join
         CancelIL.U.FM.Raw.t_left CancelIL.U.FM.Raw.t_opt CancelIL.U.FM.Raw.t_right
         CancelIL.U.FM.Raw.cardinal CancelIL.U.FM.Raw.empty CancelIL.U.FM.Raw.is_empty
         CancelIL.U.FM.Raw.mem CancelIL.U.FM.Raw.find
         CancelIL.U.FM.Raw.add  CancelIL.U.FM.Raw.remove
         CancelIL.U.FM.Raw.fold CancelIL.U.FM.Raw.map CancelIL.U.FM.Raw.mapi CancelIL.U.FM.Raw.map2

         CancelIL.U.FM.this CancelIL.U.FM.is_bst
         CancelIL.U.FM.empty CancelIL.U.FM.is_empty
         CancelIL.U.FM.add CancelIL.U.FM.remove
         CancelIL.U.FM.mem CancelIL.U.FM.find
         CancelIL.U.FM.map CancelIL.U.FM.mapi CancelIL.U.FM.map2
         CancelIL.U.FM.elements CancelIL.U.FM.cardinal CancelIL.U.FM.fold
         CancelIL.U.FM.equal
         CancelIL.U.FM.E.eq_dec

         (** Unfolder **)
         Unfolder.FM.empty Unfolder.FM.add Unfolder.FM.remove
         Unfolder.FM.fold Unfolder.FM.map
         Unfolder.FM.find
         UNF.Vars UNF.UVars UNF.Heap
         UNF.LEM.Foralls UNF.LEM.Hyps UNF.LEM.Lhs UNF.LEM.Rhs
         UNF.Forward UNF.forward UNF.unfoldForward
         UNF.Backward UNF.backward UNF.unfoldBackward
         UNF.findWithRest UNF.find equiv_dec
         UNF.findWithRest'
         Folds.allb
         UNF.find UNF.default_hintsPayload
         UNF.openForUnification
         UNF.quant
         UNF.liftInstantiate
         SH.applySHeap
         UNF.applicable UNF.checkAllInstantiated

         (** NatMap **)
         NatMap.singleton
         NatMap.IntMap.Raw.height NatMap.IntMap.Raw.cardinal NatMap.IntMap.Raw.assert_false NatMap.IntMap.Raw.create
         NatMap.IntMap.Raw.bal NatMap.IntMap.Raw.remove_min NatMap.IntMap.Raw.merge NatMap.IntMap.Raw.join
         NatMap.IntMap.Raw.t_left NatMap.IntMap.Raw.t_opt NatMap.IntMap.Raw.t_right
         NatMap.IntMap.Raw.cardinal NatMap.IntMap.Raw.empty NatMap.IntMap.Raw.is_empty
         NatMap.IntMap.Raw.mem NatMap.IntMap.Raw.find
         NatMap.IntMap.Raw.add  NatMap.IntMap.Raw.remove
         NatMap.IntMap.Raw.fold NatMap.IntMap.Raw.map NatMap.IntMap.Raw.mapi NatMap.IntMap.Raw.map2

         NatMap.IntMap.this NatMap.IntMap.is_bst
         NatMap.IntMap.empty NatMap.IntMap.is_empty
         NatMap.IntMap.add NatMap.IntMap.remove
         NatMap.IntMap.mem NatMap.IntMap.find
         NatMap.IntMap.map NatMap.IntMap.mapi NatMap.IntMap.map2
         NatMap.IntMap.elements NatMap.IntMap.cardinal NatMap.IntMap.fold
         NatMap.IntMap.equal

         Int.Z_as_Int._0 Int.Z_as_Int._1 Int.Z_as_Int._2 Int.Z_as_Int._3
         Int.Z_as_Int.plus Int.Z_as_Int.max
         Int.Z_as_Int.gt_le_dec Int.Z_as_Int.ge_lt_dec

         ZArith_dec.Z_gt_le_dec ZArith_dec.Z_ge_lt_dec ZArith_dec.Z_ge_dec
         ZArith_dec.Z_gt_dec
         ZArith_dec.Zcompare_rec ZArith_dec.Zcompare_rect

         BinInt.Z.add BinInt.Z.max BinInt.Z.pos_sub
         BinInt.Z.double BinInt.Z.succ_double BinInt.Z.pred_double

         BinInt.Z.compare

         BinPos.Pos.add BinPos.Pos.compare
         BinPos.Pos.succ BinPos.Pos.compare_cont

         Compare_dec.nat_compare CompOpp

         NatMap.Ordered_nat.compare

         sumor_rec sumor_rect
         sumbool_rec sumbool_rect
         eq_ind_r

         (** Prover **)
         Prover.Prove Prover.Prover Prover.Facts Prover.Learn Prover.Summarize
         Prover.composite_ProverT

         (** Provers **)
         Provers.ComboProver

(*
         (** TransitivityProver **)
         provers.TransitivityProver.transitivitySummarize
         provers.TransitivityProver.transitivityLearn
         provers.TransitivityProver.transitivityProve
         provers.TransitivityProver.groupsOf
         provers.TransitivityProver.addEquality
         provers.TransitivityProver.proveEqual
         provers.TransitivityProver.transitivityLearn
         provers.TransitivityProver.inSameGroup
         provers.TransitivityProver.in_seq
         provers.TransitivityProver.groupWith
         provers.TransitivityProver.transitivityProver
*)

         (** AssumptionProver **)
         provers.AssumptionProver.assumptionProver
         provers.AssumptionProver.assumptionSummarize
         provers.AssumptionProver.assumptionLearn
         provers.AssumptionProver.assumptionProve

         (** ReflexivityProver **)
         provers.ReflexivityProver.reflexivityProver
         provers.ReflexivityProver.reflexivitySummarize
         provers.ReflexivityProver.reflexivityLearn
         provers.ReflexivityProver.reflexivityProve

         (** WordProver **)
         provers.WordProver.wordProver provers.WordProver.Source provers.WordProver.Destination provers.WordProver.Difference
         provers.WordProver.pow32 provers.WordProver.wplus' provers.WordProver.wneg' provers.WordProver.wminus' wordBin NToWord Nplus minus
         provers.WordProver.decompose combine Expr.expr_seq_dec provers.WordProver.combineAll provers.WordProver.combine app
         provers.WordProver.alreadyCovered provers.WordProver.alreadyCovered' andb orb provers.WordProver.merge provers.WordProver.wordLearn1 provers.WordProver.wordLearn
         provers.WordProver.equalitysEq ILEnv.W_seq Word.weqb weq provers.WordProver.equalityMatches provers.WordProver.wordProve provers.WordProver.wordSummarize
         provers.WordProver.types ILEnv.bedrock_type_W provers.WordProver.zero Bool.bool_dec wzero' posToWord bool_rec bool_rect
         Nminus wordToN Nsucc Nmult Pos.mul Pos.add Pos.sub_mask Pos.succ_double_mask Pos.double_mask Pos.pred_double
         provers.WordProver.natToWord' mod2 Div2.div2 whd wtl Pos.double_pred_mask
         provers.WordProver.Equalities provers.WordProver.LessThans provers.WordProver.NotEquals
         provers.WordProver.lessThanMatches

         (** ArrayBoundProver **)
         provers.ArrayBoundProver.boundProver
         provers.ArrayBoundProver.deupd provers.ArrayBoundProver.factIn
         provers.ArrayBoundProver.boundLearn1 provers.ArrayBoundProver.boundLearn
         provers.ArrayBoundProver.boundSummarize provers.ArrayBoundProver.hypMatches
         provers.ArrayBoundProver.boundProve
         provers.ArrayBoundProver.types

         (** Induction **)
         list_ind list_rec list_rect
         sumbool_rect sumbool_rec
         nat_rect nat_ind
         eq_rect_r eq_rec_r eq_rec eq_rect eq_ind
         eq_sym f_equal
         sumbool_rec sumbool_rect
         sumbool_rec sumbool_rect
         sumor_rec sumor_rect
         nat_rec nat_rect

         (** Comparisons **)
         Compare_dec.lt_dec Compare_dec.le_dec Compare_dec.le_gt_dec
         Compare_dec.le_lt_dec Compare_dec.lt_eq_lt_dec
         Compare_dec.lt_dec Compare_dec.le_dec Compare_dec.le_gt_dec
         Compare_dec.le_lt_dec Compare_dec.lt_eq_lt_dec
         Compare_dec.lt_eq_lt_dec
         Peano_dec.eq_nat_dec
         EquivDec_nat equiv_dec seq_dec
         nat_eq_eqdec
         EquivDec_SemiDec
         Compare_dec.nat_compare
         NPeano.leb NPeano.ltb

         (** SepExpr **)
         SEP.SDomain SEP.SDenotation
         SEP.Default_predicate
         SEP.himp SEP.sexprD
         SEP.heq
         SEP.liftSExpr
         SEP.typeof_pred SEP.typeof_preds

         (** SepHeap **)
         SH.impures SH.pures SH.other
         SH.liftSHeap UNF.HEAP_FACTS.sheapSubstU
         SH.starred SH.hash
         SH.star_SHeap
         SH.SHeap_empty
         SH.sheapD

         SepHeap.FM.empty
         SepHeap.FM.map
         SepHeap.FM.find
         SepHeap.FM.add
         SepHeap.FM.remove
         SepHeap.FM.fold

         (** SepCancel **)
         CancelIL.CANCEL.sepCancel
         CancelIL.CANCEL.expr_count_meta
         CancelIL.CANCEL.exprs_count_meta
         CancelIL.CANCEL.expr_size
         CancelIL.CANCEL.meta_order_funcs
         CancelIL.CANCEL.meta_order_args
         CancelIL.CANCEL.order_impures
         CancelIL.CANCEL.cancel_in_order
         CancelIL.CANCEL.unify_remove CancelIL.CANCEL.unifyArgs
         CancelIL.CANCEL.expr_size

         CancelIL.canceller
         CancelIL.substInEnv
         CancelIL.existsMaybe
         CancelIL.existsSubst

         (** Ordering **)
         Ordering.insert_in_order Ordering.list_lex_cmp Ordering.sort

         (** Multimaps **)
         SepHeap.MM.mmap_add SepHeap.MM.mmap_extend SepHeap.MM.mmap_join
         SepHeap.MM.mmap_mapi SepHeap.MM.mmap_map
         SepHeap.MM.empty

         (** PtsTo Plugin **)
         Plugin_PtsTo.ptsto32_ssig
         Plugin_PtsTo.expr_equal Plugin_PtsTo.sym_read_word_ptsto32
         Plugin_PtsTo.sym_write_word_ptsto32 Plugin_PtsTo.ptsto32_types_r
         Plugin_PtsTo.types
         Plugin_PtsTo.MemEval_ptsto32
         Plugin_PtsTo.MemEvaluator_ptsto32

         (** General Recursion **)
         Fix Fix_F GenRec.wf_R_pair GenRec.wf_R_nat
         GenRec.guard Acc_rect well_founded_ind
         well_founded_induction_type Acc_inv ExprUnify.wf_R_expr

         (** Folds **)
         Folds.fold_left_2_opt Folds.fold_left_3_opt

         (** List Functions **)
         tl hd_error value error hd
         nth_error Datatypes.length fold_right firstn skipn rev
         rev_append map app fold_left

         (** Aux Functions **)
         fst snd projT1 projT2 Basics.impl value error
         projT1 projT2 andb orb
         plus minus

         (** Reflection **)
         (* Reflection.Reflect_eqb_nat *)

         (** Array *)
         Array.ssig Array.types_r Array.types
         Array.MemEval Array.MemEvaluator
         Array.div4 Array.deref Array.sym_read Array.sym_write
         Array.wlength_r Array.sel_r Array.upd_r

         (** Array8 *)
         Array8.ssig Array8.types_r Array8.types
         Array8.MemEval Array8.MemEvaluator
         Array8.deref Array8.sym_read Array8.sym_write
         Array8.blength_r Array8.sel_r Array8.upd_r Array8.BtoW_r Array8.WtoB_r

         (** Locals *)
         Locals.bedrock_type_string Locals.bedrock_type_listString Locals.bedrock_type_vals
         Locals.ssig Locals.types_r Locals.types
         Locals.MemEval Locals.MemEvaluator
         Locals.ascii_eq Locals.string_eq Bool.eqb
         Locals.nil_r Locals.cons_r Locals.sel_r Locals.upd_r
         Locals.deref Locals.listIn Locals.sym_sel Locals.sym_read Locals.sym_write

         (** ?? **)
         DepList.hlist_hd DepList.hlist_tl
         eq_sym eq_trans
         EqNat.beq_nat

         (** TODO: sort these **)
          ILAlgoTypes.Env ILAlgoTypes.Algos ILAlgoTypes.Algos_correct
          ILAlgoTypes.PACK.Types ILAlgoTypes.PACK.Preds ILAlgoTypes.PACK.Funcs
          ILAlgoTypes.PACK.applyTypes
          ILAlgoTypes.PACK.applyFuncs
          ILAlgoTypes.PACK.applyPreds

          ILAlgoTypes.BedrockPackage.bedrock_package
          Env.repr_combine Env.footprint Env.nil_Repr
          Env.listToRepr
          app map

          ILEnv.bedrock_funcs_r ILEnv.bedrock_types_r
          ILAlgoTypes.AllAlgos_composite
          ILAlgoTypes.oplus Prover.composite_ProverT
          (*TacPackIL.MEVAL.Composite.MemEvaluator_composite*) Env.listToRepr

          Plugin_PtsTo.ptsto32_ssig Bedrock.sep.Array.ssig
       ]
  | _ =>
    cbv beta iota zeta
       delta [s1 s2 s3 hints
         (** Symbolic Evaluation **)
         SymIL.MEVAL.PredEval.fold_args
         SymIL.MEVAL.PredEval.fold_args_update SymIL.MEVAL.PredEval.pred_read_word
         SymIL.MEVAL.PredEval.pred_write_word SymIL.MEVAL.PredEval.pred_read_byte SymIL.MEVAL.PredEval.pred_write_byte
         SymIL.MEVAL.LearnHookDefault.LearnHook_default
         SymIL.IL_ReadWord SymIL.IL_WriteWord SymIL.IL_ReadByte SymIL.IL_WriteByte
         SymILTac.unfolder_LearnHook
         SymIL.MEVAL.Composite.MemEvaluator_composite
         SymIL.MEVAL.Default.smemeval_read_word_default
         SymIL.MEVAL.Default.smemeval_write_word_default
         SymIL.sym_evalInstrs
         SymIL.sym_evalInstr SymIL.sym_evalLval SymIL.sym_evalRval
         SymIL.sym_evalLoc SymIL.sym_evalStream SymIL.sym_assertTest
         SymIL.sym_setReg SymIL.sym_getReg
         SymIL.SymMem SymIL.SymRegs SymIL.SymPures
(*         SymIL.SymVars SymIL.SymUVars *)
         SymIL.stateD SymIL.qstateD
         SymILTac.quantifyNewVars
         SymILTac.unfolder_LearnHook
         ILAlgoTypes.Hints ILAlgoTypes.Prover
         SymIL.MEVAL.sread_word SymIL.MEVAL.swrite_word SymIL.MEVAL.sread_byte SymIL.MEVAL.swrite_byte
         ILAlgoTypes.MemEval ILAlgoTypes.Env ILAlgoTypes.Algos
         (*SymIL.quantifyNewVars*)
         ILAlgoTypes.Algos ILAlgoTypes.Hints ILAlgoTypes.Prover

         SymEval.quantD SymEval.appendQ
         SymEval.qex SymEval.qall
         SymEval.gatherAll SymEval.gatherEx
         SymILTac.sym_eval

         (** ILEnv **)
         ILEnv.comparator ILEnv.fPlus ILEnv.fMinus ILEnv.fMult
         ILEnv.bedrock_types_r ILEnv.bedrock_funcs_r
         ILEnv.bedrock_types
         ILEnv.BedrockCoreEnv.core
         ILEnv.BedrockCoreEnv.pc ILEnv.BedrockCoreEnv.st
         ILEnv.bedrock_type_W ILEnv.bedrock_type_nat
         ILEnv.bedrock_type_setting_X_state
         ILEnv.bedrock_type_state
(*         ILEnv.bedrock_type_test *)
         ILEnv.bedrock_type_reg

(*         ILEnv.test_seq *)
         ILEnv.reg_seq
         ILEnv.W_seq

         ILEnv.word_nat_r
         ILEnv.word_state_r
(*         ILEnv.word_test_r *)

         ILEnv.wplus_r
         ILEnv.wminus_r
         ILEnv.wmult_r
(*         ILEnv.word_test_r *)
(*         ILEnv.wcomparator_r *)
         ILEnv.Regs_r
         ILEnv.wlt_r
         ILEnv.natToW_r

         (** Env **)
         Env.repr_combine Env.default Env.footprint Env.repr'
         Env.updateAt Env.nil_Repr Env.repr Env.updateAt
         Env.repr_combine Env.footprint Env.default Env.repr

         (** Expr **)
         Expr.Range Expr.Domain Expr.Denotation Expr.Impl
         Expr.exists_subst Expr.forallEach Expr.existsEach
         Expr.AllProvable_and Expr.AllProvable_impl Expr.AllProvable_gen
         Expr.tvarD Expr.exprD Expr.applyD Expr.Impl_ Expr.EqDec_tvar
         Expr.tvar_rec Expr.tvar_rect Expr.liftExpr Expr.lookupAs Expr.Eqb
         Expr.Provable Expr.tvar_val_seqb
         Expr.applyD Expr.exprD Expr.Range Expr.Domain Expr.Denotation
         Expr.lookupAs Expr.AllProvable Expr.AllProvable_gen
         Expr.Provable Expr.tvarD
         Expr.expr_seq_dec
         Expr.applyD Expr.exprD Expr.Range Expr.Domain Expr.Denotation
         Expr.lookupAs
         Expr.tvarD Expr.Eqb
         Expr.EqDec_tvar Expr.tvar_rec Expr.tvar_rect
         Expr.Default_signature Expr.EmptySet_type Expr.Impl Expr.EqDec_tvar Expr.tvar_rec Expr.tvar_rect
         Expr.expr_seq_dec  Expr.expr_seq_dec
         Expr.tvar_val_seqb  Expr.liftExpr Expr.exprSubstU
         Expr.typeof Expr.typeof_env
         Expr.typeof_sig Expr.typeof_funcs
         Expr.Impl_ Expr.exprD
         Expr.expr_ind
         Expr.expr_seq_dec
         Expr.get_Eq
         Expr.const_seqb
         Expr.tvar_seqb
         Expr.tvar_val_seqb_correct
         Expr.tvar_seqb_correct
         Expr.mentionsU
         ReifyExpr.default_type

         (** ExprUnify **)
         CancelIL.U.exprUnify CancelIL.U.exprUnify_recursor
         CancelIL.U.exprInstantiate CancelIL.U.subst_exprInstantiate
         CancelIL.U.Subst_lookup CancelIL.U.subst_lookup
         CancelIL.U.Subst_empty CancelIL.U.subst_empty
         CancelIL.U.Subst_set CancelIL.U.subst_set
         CancelIL.U.Subst_equations
         CancelIL.U.Subst_size
         CancelIL.U.dep_in

         CancelIL.U.FM.Raw.height CancelIL.U.FM.Raw.cardinal CancelIL.U.FM.Raw.assert_false CancelIL.U.FM.Raw.create
         CancelIL.U.FM.Raw.bal CancelIL.U.FM.Raw.remove_min CancelIL.U.FM.Raw.merge CancelIL.U.FM.Raw.join
         CancelIL.U.FM.Raw.t_left CancelIL.U.FM.Raw.t_opt CancelIL.U.FM.Raw.t_right
         CancelIL.U.FM.Raw.cardinal CancelIL.U.FM.Raw.empty CancelIL.U.FM.Raw.is_empty
         CancelIL.U.FM.Raw.mem CancelIL.U.FM.Raw.find
         CancelIL.U.FM.Raw.add  CancelIL.U.FM.Raw.remove
         CancelIL.U.FM.Raw.fold CancelIL.U.FM.Raw.map CancelIL.U.FM.Raw.mapi CancelIL.U.FM.Raw.map2

         CancelIL.U.FM.this CancelIL.U.FM.is_bst
         CancelIL.U.FM.empty CancelIL.U.FM.is_empty
         CancelIL.U.FM.add CancelIL.U.FM.remove
         CancelIL.U.FM.mem CancelIL.U.FM.find
         CancelIL.U.FM.map CancelIL.U.FM.mapi CancelIL.U.FM.map2
         CancelIL.U.FM.elements CancelIL.U.FM.cardinal CancelIL.U.FM.fold
         CancelIL.U.FM.equal
         CancelIL.U.FM.E.eq_dec

         (** Unfolder **)
         Unfolder.FM.empty Unfolder.FM.add Unfolder.FM.remove
         Unfolder.FM.fold Unfolder.FM.map
         Unfolder.FM.find
         UNF.LEM.Foralls UNF.Vars
         UNF.UVars UNF.Heap UNF.LEM.Hyps UNF.LEM.Lhs UNF.LEM.Rhs
         UNF.Forward UNF.forward UNF.unfoldForward UNF.Backward
         UNF.backward UNF.unfoldBackward  equiv_dec
         UNF.find UNF.findWithRest UNF.findWithRest'
         Folds.allb
         UNF.openForUnification
         UNF.quant
         UNF.liftInstantiate
         SH.applySHeap
         UNF.find UNF.default_hintsPayload
         UNF.applicable UNF.checkAllInstantiated

         (** NatMap **)
         NatMap.singleton
         NatMap.IntMap.Raw.height NatMap.IntMap.Raw.cardinal NatMap.IntMap.Raw.assert_false NatMap.IntMap.Raw.create
         NatMap.IntMap.Raw.bal NatMap.IntMap.Raw.remove_min NatMap.IntMap.Raw.merge NatMap.IntMap.Raw.join
         NatMap.IntMap.Raw.t_left NatMap.IntMap.Raw.t_opt NatMap.IntMap.Raw.t_right
         NatMap.IntMap.Raw.cardinal NatMap.IntMap.Raw.empty NatMap.IntMap.Raw.is_empty
         NatMap.IntMap.Raw.mem NatMap.IntMap.Raw.find
         NatMap.IntMap.Raw.add  NatMap.IntMap.Raw.remove
         NatMap.IntMap.Raw.fold NatMap.IntMap.Raw.map NatMap.IntMap.Raw.mapi NatMap.IntMap.Raw.map2

         NatMap.IntMap.this NatMap.IntMap.is_bst
         NatMap.IntMap.empty NatMap.IntMap.is_empty
         NatMap.IntMap.add NatMap.IntMap.remove
         NatMap.IntMap.mem NatMap.IntMap.find
         NatMap.IntMap.map NatMap.IntMap.mapi NatMap.IntMap.map2
         NatMap.IntMap.elements NatMap.IntMap.cardinal NatMap.IntMap.fold
         NatMap.IntMap.equal

         Int.Z_as_Int._0 Int.Z_as_Int._1 Int.Z_as_Int._2 Int.Z_as_Int._3
         Int.Z_as_Int.plus Int.Z_as_Int.max
         Int.Z_as_Int.gt_le_dec Int.Z_as_Int.ge_lt_dec

         ZArith_dec.Z_gt_le_dec ZArith_dec.Z_ge_lt_dec ZArith_dec.Z_ge_dec
         ZArith_dec.Z_gt_dec
         ZArith_dec.Zcompare_rec ZArith_dec.Zcompare_rect

         BinInt.Z.add BinInt.Z.max BinInt.Z.pos_sub
         BinInt.Z.double BinInt.Z.succ_double BinInt.Z.pred_double

         BinInt.Z.compare

         BinPos.Pos.add BinPos.Pos.compare
         BinPos.Pos.succ BinPos.Pos.compare_cont

         Compare_dec.nat_compare CompOpp

         NatMap.Ordered_nat.compare

         sumor_rec sumor_rect
         sumbool_rec sumbool_rect
         eq_ind_r

         (** Prover **)
         Prover.Prove Prover.Prover Prover.Facts Prover.Learn Prover.Summarize
         Prover.composite_ProverT

         (** Provers **)
         Provers.ComboProver

(*
         (** TransitivityProver **)
         provers.TransitivityProver.transitivitySummarize
         provers.TransitivityProver.transitivityLearn
         provers.TransitivityProver.transitivityProve
         provers.TransitivityProver.groupsOf
         provers.TransitivityProver.addEquality
         provers.TransitivityProver.proveEqual
         provers.TransitivityProver.transitivityLearn
         provers.TransitivityProver.inSameGroup
         provers.TransitivityProver.in_seq
         provers.TransitivityProver.groupWith
         provers.TransitivityProver.transitivityProver
*)

         (** AssumptionProver **)
         provers.AssumptionProver.assumptionProver
         provers.AssumptionProver.assumptionSummarize
         provers.AssumptionProver.assumptionLearn
         provers.AssumptionProver.assumptionProve

         (** ReflexivityProver **)
         provers.ReflexivityProver.reflexivityProver
         provers.ReflexivityProver.reflexivitySummarize
         provers.ReflexivityProver.reflexivityLearn
         provers.ReflexivityProver.reflexivityProve

         (** WordProver **)
         provers.WordProver.wordProver provers.WordProver.Source provers.WordProver.Destination provers.WordProver.Difference
         provers.WordProver.pow32 provers.WordProver.wplus' provers.WordProver.wneg' provers.WordProver.wminus' wordBin NToWord Nplus minus
         provers.WordProver.decompose combine Expr.expr_seq_dec provers.WordProver.combineAll provers.WordProver.combine app
         provers.WordProver.alreadyCovered provers.WordProver.alreadyCovered' andb orb provers.WordProver.merge provers.WordProver.wordLearn1 provers.WordProver.wordLearn
         provers.WordProver.equalitysEq ILEnv.W_seq Word.weqb weq provers.WordProver.equalityMatches provers.WordProver.wordProve provers.WordProver.wordSummarize
         provers.WordProver.types ILEnv.bedrock_type_W provers.WordProver.zero Bool.bool_dec wzero' posToWord bool_rec bool_rect
         Nminus wordToN Nsucc Nmult Pos.mul Pos.add Pos.sub_mask Pos.succ_double_mask Pos.double_mask Pos.pred_double
         provers.WordProver.natToWord' mod2 Div2.div2 whd wtl Pos.double_pred_mask
         provers.WordProver.Equalities provers.WordProver.LessThans provers.WordProver.NotEquals
         provers.WordProver.lessThanMatches

         (** ArrayBoundProver **)
         provers.ArrayBoundProver.boundProver
         provers.ArrayBoundProver.deupd provers.ArrayBoundProver.factIn
         provers.ArrayBoundProver.boundLearn1 provers.ArrayBoundProver.boundLearn
         provers.ArrayBoundProver.boundSummarize provers.ArrayBoundProver.hypMatches
         provers.ArrayBoundProver.boundProve
         provers.ArrayBoundProver.types

         (** Induction **)
         list_ind list_rec list_rect
         sumbool_rect sumbool_rec
         sumor_rec sumor_rect
         nat_rec nat_rect nat_ind
         eq_rect_r eq_rec_r eq_rec eq_rect
         eq_sym f_equal
         nat_rect eq_ind eq_rec eq_rect
         eq_rec_r eq_rect eq_rec nat_rec nat_rect
         sumbool_rec sumbool_rect
         sumbool_rec sumbool_rect
         sumor_rec sumor_rect
         nat_rec nat_rect

         (** Comparisons **)
         Compare_dec.lt_dec Compare_dec.le_dec Compare_dec.le_gt_dec
         Compare_dec.le_lt_dec Compare_dec.lt_eq_lt_dec
         Compare_dec.lt_dec Compare_dec.le_dec Compare_dec.le_gt_dec
         Compare_dec.le_lt_dec Compare_dec.lt_eq_lt_dec
         Compare_dec.lt_eq_lt_dec
         Peano_dec.eq_nat_dec
         EquivDec_nat  equiv_dec seq_dec
         nat_eq_eqdec
         EquivDec_SemiDec
         Compare_dec.nat_compare
         NPeano.leb NPeano.ltb

         (** SepExpr **)
         SEP.SDomain SEP.SDenotation
         SEP.Default_predicate
         SEP.himp SEP.sexprD
         SEP.heq
         nat_eq_eqdec
         SEP.liftSExpr

         (** SepHeap **)
         SH.impures SH.pures SH.other
         SH.liftSHeap UNF.HEAP_FACTS.sheapSubstU
         SH.starred SH.hash
         SH.star_SHeap
         SH.SHeap_empty
         SH.sheapD

         SepHeap.FM.empty
         SepHeap.FM.map
         SepHeap.FM.find
         SepHeap.FM.add
         SepHeap.FM.remove
         SepHeap.FM.fold

         (** SepCancel **)
         CancelIL.CANCEL.sepCancel
         CancelIL.CANCEL.expr_count_meta
         CancelIL.CANCEL.exprs_count_meta
         CancelIL.CANCEL.expr_size
         CancelIL.CANCEL.meta_order_funcs
         CancelIL.CANCEL.meta_order_args
         CancelIL.CANCEL.order_impures
         CancelIL.CANCEL.cancel_in_order
         CancelIL.CANCEL.unify_remove
         CancelIL.CANCEL.unifyArgs
         CancelIL.CANCEL.expr_size

         CancelIL.canceller
         CancelIL.substInEnv
         CancelIL.existsMaybe
         CancelIL.existsSubst

         (** Ordering **)
         Ordering.insert_in_order Ordering.list_lex_cmp Ordering.sort

         (** Multimaps **)
         SepHeap.MM.mmap_add SepHeap.MM.mmap_extend SepHeap.MM.mmap_join
         SepHeap.MM.mmap_mapi SepHeap.MM.mmap_map
         SepHeap.MM.empty

         (** PtsTo Plugin **)
         Plugin_PtsTo.ptsto32_ssig
         Plugin_PtsTo.expr_equal Plugin_PtsTo.sym_read_word_ptsto32
         Plugin_PtsTo.sym_write_word_ptsto32 Plugin_PtsTo.ptsto32_types_r
         Plugin_PtsTo.types
         Plugin_PtsTo.MemEval_ptsto32
         Plugin_PtsTo.MemEvaluator_ptsto32

         (** General Recursion **)
         Fix Fix_F GenRec.wf_R_pair GenRec.wf_R_nat
         GenRec.guard Acc_rect well_founded_ind
         well_founded_induction_type Acc_inv ExprUnify.wf_R_expr

         (** Folds **)
         Folds.fold_left_2_opt Folds.fold_left_3_opt

         (** List Functions **)
         tl hd_error value error hd
         nth_error Datatypes.length fold_right firstn skipn rev
         rev_append List.map app fold_left

         (** Aux Functions **)
         fst snd projT1 projT2 Basics.impl value error
         projT1 projT2 andb orb
         plus minus

         (** Reflection **)
         (* Reflection.Reflect_eqb_nat *)

         (** Array *)
         Array.ssig Array.types_r Array.types
         Array.MemEval Array.MemEvaluator
         Array.div4 Array.deref Array.sym_read Array.sym_write
         Array.wlength_r Array.sel_r Array.upd_r

         (** Array8 *)
         Array8.ssig Array8.types_r Array8.types
         Array8.MemEval Array8.MemEvaluator
         Array8.deref Array8.sym_read Array8.sym_write
         Array8.blength_r Array8.sel_r Array8.upd_r Array8.BtoW_r Array8.WtoB_r

         (** Locals *)
         Locals.bedrock_type_string Locals.bedrock_type_listString Locals.bedrock_type_vals
         Locals.ssig Locals.types_r Locals.types
         Locals.MemEval Locals.MemEvaluator
         Locals.ascii_eq Locals.string_eq Bool.eqb
         Locals.nil_r Locals.cons_r Locals.sel_r Locals.upd_r
         Locals.deref Locals.listIn Locals.sym_sel Locals.sym_read Locals.sym_write

         (** ?? **)
         DepList.hlist_hd DepList.hlist_tl
         eq_sym eq_trans
         EqNat.beq_nat

         (** TODO: sort these **)
         ILAlgoTypes.Env ILAlgoTypes.Algos ILAlgoTypes.Algos_correct
         ILAlgoTypes.PACK.Types ILAlgoTypes.PACK.Preds ILAlgoTypes.PACK.Funcs
         ILAlgoTypes.PACK.applyTypes
         ILAlgoTypes.PACK.applyFuncs
         ILAlgoTypes.PACK.applyPreds

         ILAlgoTypes.BedrockPackage.bedrock_package
         Env.repr_combine Env.footprint Env.nil_Repr
         Env.listToRepr
         app map

         ILEnv.bedrock_funcs_r ILEnv.bedrock_types_r
         ILAlgoTypes.AllAlgos_composite
         ILAlgoTypes.oplus Prover.composite_ProverT
         (*TacPackIL.MEVAL.Composite.MemEvaluator_composite*) Env.listToRepr

         Plugin_PtsTo.ptsto32_ssig Bedrock.sep.Array.ssig

       ] in H
  end; refold.

Ltac clear_junk := repeat match goal with
                            | [ H : True |- _ ] => clear H
                            | [ H : ?X = ?X |- _ ] => clear H
                                | [ H : ?X, H' : ?X |- _ ] => clear H'
                          end.

Ltac evaluate ext :=
  repeat match goal with
           | [ H : ?P -> False |- _ ] => change (not P) in H
         end;
  ILTac.sym_eval ltac:(ILTacCommon.isConst) ext ltac:(hints_ext_simplifier ext);
  clear_junk.

Ltac cancel ext := sep_canceller ltac:(ILTacCommon.isConst) ext ltac:(hints_ext_simplifier ext); sep_firstorder; clear_junk.

Ltac unf := unfold substH.
Ltac reduce := Programming.reduce unf.
Ltac ho := Programming.ho unf; reduce.

Theorem implyR : forall pc state specs (P Q R : PropX pc state),
  interp specs (P ---> R)
  -> interp specs (P ---> Q ---> R)%PropX.
  intros.
  do 2 apply Imply_I.
  eapply Imply_E.
  eauto.
  constructor; simpl; tauto.
Qed.

Inductive pureConsequences : HProp -> list Prop -> Prop :=
| PurePure : forall P, pureConsequences [| P |]%Sep (P :: nil)
| PureStar : forall P P' Q Q', pureConsequences P P'
  -> pureConsequences Q Q'
  -> pureConsequences (P * Q)%Sep (P' ++ Q')
| PureOther : forall P, pureConsequences P nil.

Theorem pureConsequences_correct : forall P P',
  pureConsequences P P'
  -> forall specs stn st, interp specs (P stn st ---> [| List.Forall (fun p => p) P' |]%PropX).
  induction 1; intros.

  unfold injB, inj.
  apply Imply_I.
  eapply Inj_E.
  eapply And_E1; apply Env; simpl; eauto.
  intro; apply Inj_I; repeat constructor; assumption.

  unfold starB, star.
  apply Imply_I.
  eapply Exists_E.
  apply Env; simpl; eauto.
  simpl; intro.
  eapply Exists_E.
  apply Env; simpl; left; eauto.
  simpl; intro.
  eapply Inj_E.
  eapply Imply_E.
  apply interp_weaken; apply IHpureConsequences1.
  eapply And_E1; eapply And_E2; apply Env; simpl; eauto.
  intro.
  eapply Inj_E.
  eapply Imply_E.
  apply interp_weaken; apply IHpureConsequences2.
  do 2 eapply And_E2; apply Env; simpl; eauto.
  intro.
  apply Inj_I.
  apply Forall_app; auto.

  apply Imply_I; apply Inj_I; auto.
Qed.

Theorem extractPure : forall specs P Q Q' R st,
  pureConsequences Q Q'
  -> (List.Forall (fun p => p) Q' -> interp specs (P ---> R))
  -> interp specs (P ---> ![Q] st ---> R)%PropX.
  intros.
  do 2 apply Imply_I.
  eapply Inj_E.
  eapply Imply_E.
  apply interp_weaken.
  apply pureConsequences_correct; eauto.
  rewrite sepFormula_eq.
  unfold sepFormula_def.
  apply Env; simpl; eauto.
  intro.
  eapply Imply_E.
  eauto.
  apply Env; simpl; eauto.
Qed.

Ltac words := repeat match goal with
                       | [ H : _ = _ |- _ ] => rewrite H
                     end; W_eq.

Definition locals_return ns vs avail p (ns' : list string) (avail' offset : nat) :=
  locals ns vs avail p.

Theorem create_locals_return : forall ns' avail' ns avail offset vs p,
  locals ns vs avail p = locals_return ns vs avail p ns' avail' offset.
  reflexivity.
Qed.

Definition ok_return (ns ns' : list string) (avail avail' offset : nat) :=
  (avail >= avail' + length ns')%nat
  /\ offset = 4 * length ns.

Ltac peelPrefix ls1 ls2 :=
  match ls1 with
    | nil => ls2
    | ?x :: ?ls1' =>
      match ls2 with
        | x :: ?ls2' => peelPrefix ls1' ls2'
      end
  end.

Global Opaque merge.

Theorem use_HProp_extensional : forall p, HProp_extensional p
  -> (fun st sm => p st sm) = p.
  auto.
Qed.

Ltac descend :=
  (*TIME time "descend:descend" *)
  Programming.descend;
  (*TIME time "descend:reduce" *)
  reduce;
  (*TIME time "descend:unfold_simpl" ( *)
  unfold hvarB; simpl; rereg
  (*TIME ) *);
  (*TIME time "descend:loop" *)
    (repeat match goal with
             | [ |- context[fun stn0 sm => ?f stn0 sm] ] =>
               rewrite (@use_HProp_extensional f) by auto
             | [ |- context[fun stn0 sm => ?f ?a stn0 sm] ] =>
               rewrite (@use_HProp_extensional (f a)) by auto
             | [ |- context[fun stn0 sm => ?f ?a ?b stn0 sm] ] =>
               rewrite (@use_HProp_extensional (f a b)) by auto
             | [ |- context[fun stn0 sm => ?f ?a ?b ?c stn0 sm] ] =>
               rewrite (@use_HProp_extensional (f a b c)) by auto
             | [ |- context[fun stn0 sm => ?f ?a ?b ?c ?d stn0 sm] ] =>
               rewrite (@use_HProp_extensional (f a b c d)) by auto
             | [ |- context[fun stn0 sm => ?f ?a ?b ?c ?d ?e stn0 sm] ] =>
               rewrite (@use_HProp_extensional (f a b c d e)) by auto
             | [ |- context[fun stn0 sm => ?f ?a ?b ?c ?d ?e ?f stn0 sm] ] =>
               rewrite (@use_HProp_extensional (f a b c d e f)) by auto
           end);
    try match goal with
          | [ p : (ST.settings * state)%type |- _ ] => destruct p; simpl in *
        end.

Definition locals_call ns vs avail p (ns' : list string) (avail' : nat) (offset : nat) :=
  locals ns vs avail p.

Definition ok_call (ns ns' : list string) (avail avail' : nat) (offset : nat) :=
  (length ns' <= avail)%nat
  /\ (avail' <= avail - length ns')%nat
  /\ NoDup ns'
  /\ offset = 4 * length ns.

Definition excessStack (p : W) (ns : list string) (avail : nat) (ns' : list string) (avail' : nat) :=
  reserved (p ^+ natToW (4 * (length ns + length ns' + avail')))
  (avail - length ns' - avail').

Lemma make_call : forall ns ns' vs avail avail' p offset,
  ok_call ns ns' avail avail' offset
  -> locals_call ns vs avail p ns' avail' offset ===>
  locals ns vs 0 p
  * Ex vs', locals ns' vs' avail' (p ^+ natToW offset)
  * excessStack p ns avail ns' avail'.
  unfold ok_call; intuition; subst; eapply do_call; eauto.
Qed.

Lemma make_return : forall ns ns' vs avail avail' p offset,
  ok_return ns ns' avail avail' offset
  -> (locals ns vs 0 p
    * Ex vs', locals ns' vs' avail' (p ^+ natToW offset)
    * excessStack p ns avail ns' avail')
  ===> locals_return ns vs avail p ns' avail' offset.
  unfold ok_return; intuition; subst; apply do_return; omega || words.
Qed.

Definition locals_in ns vs avail p (ns' ns'' : list string) (avail' : nat) :=
  locals ns vs avail p.

Open Scope list_scope.

Definition ok_in (ns : list string) (avail : nat) (ns' ns'' : list string) (avail' : nat) :=
  ns ++ ns' = ns'' /\ (length ns' <= avail)%nat /\ NoDup (ns ++ ns')
  /\ avail' = avail - length ns'.

Theorem init_in : forall ns ns' ns'' vs avail p avail',
  ok_in ns avail ns' ns'' avail'
  -> locals_in ns vs avail p ns' ns'' avail' ===>
  Ex vs', locals ns'' (merge vs vs' ns) avail' p.
  unfold ok_in; intuition; subst; apply prelude_in; auto.
Qed.

Definition locals_out ns vs avail p (ns' ns'' : list string) (avail' : nat) :=
  locals ns vs avail p.

Definition ok_out (ns : list string) (avail : nat) (ns' ns'' : list string) (avail' : nat) :=
  ns ++ ns' = ns'' /\ (length ns' <= avail)%nat
  /\ avail' = avail - length ns'.

Theorem init_out : forall ns ns' ns'' vs avail p avail',
  ok_out ns avail ns' ns'' avail'
  -> locals ns'' vs avail' p
  ===> locals_out ns vs avail p ns' ns'' avail'.
  unfold ok_out; intuition; subst; apply prelude_out; auto.
Qed.

Ltac prepare fwd bwd :=
  let the_unfold_tac x :=
    eval unfold empB, injB, injBX, starB, exB, hvarB in x
  in
  ILAlgoTypes.Tactics.Extension.extend the_unfold_tac
    ILTacCommon.isConst auto_ext' tt tt (make_call, init_in, fwd) (make_return, init_out, bwd).

Definition auto_ext : TacPackage.
  prepare tt tt.
Defined.

Theorem create_locals_out : forall ns' ns'' avail' ns avail vs p,
  locals ns vs avail p = locals_out ns vs avail p ns' ns'' avail'.
  reflexivity.
Qed.

Theorem unandL : forall pc state specs (P Q R : PropX pc state),
  interp specs (P /\ Q ---> R)%PropX
  -> interp specs (P ---> Q ---> R)%PropX.
  intros; do 2 apply Imply_I.
  eapply Imply_E; eauto.
  apply And_I; eapply Env; simpl; eauto.
Qed.

Lemma breakout : forall A (P : A -> _) Q R x specs,
  (forall v, interp specs (![P v * Q] x ---> R)%PropX)
  -> interp specs (![exB P * Q] x ---> R)%PropX.
  rewrite sepFormula_eq; propxFo.
  unfold sepFormula_def, exB, ex.
  simpl.
  repeat (apply existsL; intros).
  apply andL; apply injL; intro.
  apply andL.
  apply existsL; intro.
  apply unandL.
  eapply Imply_trans; try apply H; clear H.
  do 2 eapply existsR.
  simpl.
  repeat apply andR.
  apply injR; eauto.
  apply andL; apply implyR.
  apply Imply_refl.
  apply andL; apply swap; apply implyR.
  apply Imply_refl.
Qed.

Ltac imply_simp'' := match goal with
                       | [ |- interp _ (PropX.Inj _ ---> _) ] => apply injL; intro
                       | [ |- interp _ (PropX.Cptr _ _ ---> _) ] => apply cptrL; intro
                       | [ |- interp _ (PropX.And _ _ ---> _) ] => apply andL
                       | [ |- interp _ (PropX.Exists _ ---> _) ] => apply existsL; intro
                     end.

Ltac toFront' which P k :=
  match P with
    | SEP.ST.star ?Q ?R =>
      toFront' which Q ltac:(fun it P' => k it (SEP.ST.star P' R))
      || toFront' which R ltac:(fun it P' => k it (SEP.ST.star P' Q))
    | (?Q * ?R)%Sep =>
      toFront' which Q ltac:(fun it P' => k it (SEP.ST.star P' R))
      || toFront' which R ltac:(fun it P' => k it (SEP.ST.star P' Q))
    | _ => which P; k P (@SEP.ST.emp W (settings * state) nil)
  end.

Ltac step ext :=
  let considerImp pre post :=
    try match post with
          | context[locals ?ns ?vs ?avail _] =>
            match pre with
              | context[excessStack _ ns avail ?ns' ?avail'] =>
                match avail' with
                  | avail => fail 1
                  | _ =>
                    match pre with
                      | context[locals ns ?vs' 0 ?sp] =>
                        match goal with
                          | [ _ : _ = sp |- _ ] => fail 1
                          | _ => equate vs vs';
                            let offset := eval simpl in (4 * List.length ns) in
                              rewrite (create_locals_return ns' avail' ns avail offset);
                                assert (ok_return ns ns' avail avail' offset)%nat by (split; [
                                  simpl; omega
                                  | reflexivity ] ); autorewrite with sepFormula;
                                generalize dependent vs'; intros
                        end
                    end
                end
            end
        end;
    progress cancel ext in

 let exBegone :=
   match goal with
     | [ |- interp ?specs (![ ?P ] ?x ---> ?Q)%PropX ] =>
       match P with
         | context[exB] =>
           toFront' ltac:(fun R => match R with
                                     | exB _ => idtac
                                   end) P
           ltac:(fun it P' =>
             apply Imply_trans with (![ it * P'] x)%PropX; [ cancel auto_ext | ])
       end
   end; repeat match goal with
                 | [ |- interp _ (![ exB _ * _] _ ---> _)%PropX ] => apply breakout; intro
               end in

 try match goal with
       | [ |- interp _ (?P ---> _)%PropX ] =>
         match P with
           | context[exB] => repeat imply_simp''; descend; repeat exBegone
         end
     end;

  match goal with
    | [ |- _ _ = Some _ ] => solve [ eauto ]
    | [ _ : interp _ (![ ?pre ] _) |- interp _ (![ ?post ] _) ] => considerImp pre post
    | [ |- interp _ (![?pre]%PropX _ ---> ![?post]%PropX _) ] => considerImp pre post
    | [ |- himp _ ?pre ?post ] => considerImp pre post
    | [ |- interp _ (_ _ _ ?x ---> _ _ _ ?y ---> _ ?x)%PropX ] =>
      match y with
        | x => fail 1
        | _ => eapply extractPure; [ repeat constructor
          | cbv zeta; simpl; intro; repeat match goal with
                                             | [ H : List.Forall _ nil |- _ ] => clear H
                                             | [ H : List.Forall _ (_ :: _) |- _ ] => inversion H; clear H; subst
                                           end; clear_junk ]
        | _ => apply implyR
      end
    | _ => ho; rereg
  end.

Ltac slotVariable E :=
  match E with
    | 4 => constr:"0"
    | 8 => constr:"1"
    | 12 => constr:"2"
    | 16 => constr:"3"
    | 20 => constr:"4"
    | 24 => constr:"5"
    | 28 => constr:"6"
    | 32 => constr:"7"
    | 36 => constr:"8"
    | 40 => constr:"9"
  end.

Ltac slotVariables E :=
  match E with
    | Binop (LvReg Rv) (RvLval (LvReg Sp)) Plus (RvImm (natToW _))
      :: Assign (LvMem (Indir Rv (natToW ?slot))) _
      :: ?E' =>
      let v := slotVariable slot in
        let vs := slotVariables E' in
          constr:(v :: vs)
    | _ :: ?E' => slotVariables E'
    | nil => constr:(@nil string)
  end.

Ltac NoDup := repeat constructor; simpl; intuition congruence.

Ltac post :=
  (*TIME time "post:propxFo" *)
  propxFo;
  (*TIME time "post:autorewrite" ( *)
  autorewrite with sepFormula in *
  (*TIME ) *) ;
  unfold substH in *;
  (*TIME time "post:simpl" ( *)
  simpl in *; rereg; autorewrite with IL;
    try match goal with
          | [ H : context[locals ?ns ?vs ?avail ?p]
              |- context[locals ?ns' _ ?avail' _] ] =>
            match avail' with
              | avail => fail 1
              | _ =>
                (let ns'' := peelPrefix ns ns' in
                  let exposed := eval simpl in (avail - avail') in
                    let new := eval simpl in (List.length ns' - List.length ns) in
                      match new with
                        | exposed =>
                          let avail' := eval simpl in (avail - List.length ns'') in
                            change (locals ns vs avail p) with (locals_in ns vs avail p ns'' ns' avail') in H;
                              assert (ok_in ns avail ns'' ns' avail')%nat
                                by (split; [
                                  reflexivity
                                  | split; [simpl; omega
                                    | split; [ NoDup
                                      | reflexivity ] ] ])
                      end)
                || (let offset := eval simpl in (4 * List.length ns) in
                  change (locals ns vs avail p) with (locals_call ns vs avail p ns' avail' offset) in H;
                    assert (ok_call ns ns' avail avail' offset)%nat
                      by (split; [ simpl; omega
                        | split; [ simpl; omega
                          | split; [ NoDup
                            | reflexivity ] ] ]))
            end
          | [ _ : evalInstrs _ _ ?E = None, H : context[locals ?ns ?vs ?avail ?p] |- _ ] =>
            let ns' := slotVariables E in
            match ns' with
              | nil => fail 1
              | _ =>
                let ns' := constr:("rp" :: ns') in
                  let offset := eval simpl in (4 * List.length ns) in
                    change (locals ns vs avail p) with (locals_call ns vs avail p ns' 0 offset) in H;
                      assert (ok_call ns ns' avail 0 offset)%nat
                        by (split; [ simpl; omega
                          | split; [ simpl; omega
                            | split; [ NoDup
                              | reflexivity ] ] ])
            end
        end
  (*TIME ) *).

Ltac sep' ext :=
  post; evaluate ext; descend; repeat (step ext; descend).

Ltac sep ext :=
  match goal with
    | [ |- context[Assign (LvMem (Indir Sp (natToW 0))) (RvLval (LvReg Rp)) :: nil] ] =>
      sep' auto_ext (* Easy case; don't bring the hints into it *)
    | _ => sep' ext
  end.

Ltac sepLemma := unfold Himp in *; simpl; intros; cancel auto_ext.

Ltac sepLemmaLhsOnly :=
  let sllo Q := remember Q;
    match goal with
      | [ H : ?X = Q |- _ ] => let H' := fresh in
        assert (H' : bool -> X = Q) by (intro; assumption);
          clear H; rename H' into H;
            sepLemma; rewrite (H true); clear H
    end in
    simpl; intros;
      match goal with
        | [ |- _ ===> ?Q ] => sllo Q
        | [ |- himp _ _ ?Q ] => sllo Q
      end.

Ltac sep_auto := sep' auto_ext.

Hint Rewrite sel_upd_eq sel_upd_ne using congruence : sepFormula.

Lemma sel_merge : forall vs vs' ns nm,
  In nm ns
  -> sel (merge vs vs' ns) nm = sel vs nm.
  intros.
  generalize (merge_agree vs vs' ns); intro Hl.
  eapply Forall_forall in Hl; eauto.
Qed.

Hint Rewrite sel_merge using (simpl; tauto) : sepFormula.

Theorem lift0 : forall P, lift nil P = P.
  reflexivity.
Qed.

Hint Rewrite lift0 : sepFormula.

(* Within [H], find a conjunct [P] such that [which P] doesn't fail, and reassociate [H]
 * to put [P] in front. *)
Ltac toFront which H :=
  match type of H with
    | interp ?specs (![ ?P ] ?st) => toFront' which P ltac:(fun it P' =>
      let H' := fresh in
        assert (H' : interp specs (![ SEP.ST.star it P' ] st)) by step auto_ext;
          clear H; rename H' into H)
  end.

(* Just like [toFront], but for the conclusion rather than a hypothesis *)
Ltac toFront_conc which :=
  match goal with
    | [ |- interp ?specs (![ ?P ] ?st) ] => toFront' which P ltac:(fun it P' =>
      let H := fresh "H" in assert (H : interp specs (![ SEP.ST.star it P' ] st)); [ |
        generalize dependent H;
          repeat match goal with
                   | [ H : interp _ _ |- _ ] => clear H
                 end; intro; eapply Imply_sound; [ eapply sepFormula_himp_imply | ];
          [ | reflexivity | eassumption ]; solve [ step auto_ext ] ])
  end.

(* Handle a VC for an indirect function call, given the callee's formal arguments list. *)
Ltac icall formals :=
  match goal with
    | [ H : context[locals ?ns ?vs ?avail ?p] |- exists pre', _ (Regs _ Rv) = Some pre' /\ _ ] =>
      let ns' := constr:("rp" :: formals) in
        let avail' := constr:0 in
          let offset := eval simpl in (4 * List.length ns) in
            change (locals ns vs avail p) with (locals_call ns vs avail p ns' avail' offset) in H;
              assert (ok_call ns ns' avail avail' offset)%nat
                by (split; [ simpl; omega
                  | split; [ simpl; omega
                    | split; [ repeat constructor; simpl; intuition congruence
                      | reflexivity ] ] ])
  end.

Definition any : HProp := fun _ _ => [| True |]%PropX.

Theorem any_easy : forall P, P ===> any.
  unfold any; repeat intro; step auto_ext; auto.
Qed.


From mathcomp.ssreflect Require Import all_ssreflect seq.
From mathcomp Require Import finmap.

From Paco Require Import paco paco1 paco2.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import MPST.Common.
Require Import MPST.Global.
Require Import MPST.Local.

Require Import MPST.Projection.IProject.
Require Import MPST.Projection.CProject.

Lemma partof_all_unroll G CG p L n :
  g_closed G ->
  GUnroll G CG -> project simple_merge G p == Some L ->
  depth_part n p G -> part_of_all p CG.
Proof.
  elim: n G CG L=>// n Ih [||G|F T C] //= CG L cG; rewrite -/prj_all.
  - case PRJ: project=>[L0|]//; move: PRJ=>/eqP-PRJ.
    case: ifP; first by move=>/(lbinds_depth _ PRJ)->.
    move=> NB /gunroll_unfold; elim/gunr_inv=>// _ IG CG0 GU [EQ1] EQ2 _ DP.
    move: EQ1 EQ2 GU DP=>//-> _ []//GU /(depthpart_open 0 (g_rec G))-DP.
    move: NB PRJ=>/eqP-NB /eqP-PRJ; move: (project_open NB cG PRJ)=>{}/eqP-P.
    by move: cG=>/gopen_closed/Ih/(_ GU P DP).
  - move=>/gunroll_unfold; elim/gunr_inv=>// _ F' T' C' CC DOM UA E1 _ {CG}.
    move: E1 DOM UA=>[->->->] DOM UA {F' T' C'}; rewrite -/(prj_all _ _).
    case PRJ: prj_all=>[Ks|]//; case: ifP=>// FT.
    case: ifP=>[/eqP<- _|pF]; first by constructor.
    case: ifP=>[/eqP<- _|pT]; first by constructor.
    move=>MRG; rewrite eq_sym pF eq_sym pT/= => DP.
    apply: pall_cont=>l Ty CG CCl.
    move: (dom' DOM CCl)=>[G'] Cl.
    move: (UA _ _ _ _ Cl CCl)=>[|//].
    move: (prj_all_find PRJ Cl)=>[L'][_]/eqP-{}PRJ GU.
    move: (find_member Cl)=>M.
    apply: (Ih _ _ _ _ GU PRJ).
    * by move: cG; rewrite /g_closed/= flatten_eq_nil=>/member_map/(_ _ M).
    * by move: DP =>/forallbP/forall_member/member_map/(_ _ M).
Qed.

Lemma partof_unroll G CG p :
  g_closed G ->
  guarded 0 G ->
  GUnroll G CG ->
  part_of p CG ->
  p \in participants G.
Proof.
  move=> cG gG GU PART.
  elim: PART=>[F T C| F T C|{}p F T C l G0 Ty Cl PART Ih] in G cG gG GU *.
  - apply: r_in_unroll_rec_depth; move: GU=>/(GUnroll_ind (rec_depth G)).
    move: (n_unroll (rec_depth G) G) (unroll_guarded cG gG)=>{cG gG}G NR GU.
    move: GU NR=>/gunroll_unfold; elim/gunr_inv =>// _;
      first by move=> IG _ _ _ _ /(_ IG); rewrite eq_refl.
    by move=> F' T' C' CG' _ _ _ [->] _ _ _; rewrite in_cons eq_refl.
  - apply: r_in_unroll_rec_depth; move: GU=>/(GUnroll_ind (rec_depth G)).
    move: (n_unroll (rec_depth G) G) (unroll_guarded cG gG)=>{cG gG}G NR GU.
    move: GU NR=>/gunroll_unfold; elim/gunr_inv =>// _;
      first by move=> IG _ _ _ _ /(_ IG); rewrite eq_refl.
    by move=> F' T' C' CG' _ _ _ [] _ <- _ _; rewrite in_cons orbC in_cons eq_refl.
  - apply: r_in_unroll_rec_depth; move: GU=>/(GUnroll_ind (rec_depth G)).
    move: (g_guarded_nunroll (rec_depth G) cG gG) (unroll_guarded cG gG).
    move: (n_unroll (rec_depth G) G) (g_closed_unroll (rec_depth G) cG).
    move=>{cG gG}G cG gG NR GU.
    move: GU NR cG gG =>/gunroll_unfold; elim/gunr_inv =>// _;
      first by move=> IG _ _ _ _ /(_ IG); rewrite eq_refl.
    move=> F' T' C' CG' DOM UA E1 E2 _ .
    rewrite /g_closed/==>/flatten_eq_nil/member_map-cG.
    move=>/forallbP/forall_member=>gG.
    move: E1 E2 cG gG DOM UA=>_ [->->->] cG gG DOM UA {G F' T' CG'}.
    suff: p \in flatten [seq participants K.2.2 | K <- C']
      by rewrite !in_cons=>->; rewrite orbC orbT.
    move: (dom' DOM Cl)=>[G FND]; move: (find_member FND)=>M.
    move: (UA _ _ _ _ FND Cl)=>[GU|//].
    apply/flatten_mapP; exists (l, (Ty, G)); first by apply/memberP.
    by apply/(Ih _ (cG _ M) (gG _ M) GU).
Qed.

Notation CIH4 X Y H1 H2 H3 H4 H5
  := (ex_intro (fun=>_) X
               (ex_intro (fun=>_) Y
                         (conj H1 (conj H2 (conj H3 (conj H4 H5)))))).
Lemma project_wf G p L CG :
  g_closed G ->
  guarded 0 G ->
  non_empty_cont G ->
  project simple_merge G p == Some L ->
  GUnroll G CG -> WF CG.
Proof.
  move=>H1 H2 NE H3 H4; move: (CIH4 L G H1 H2 NE H3 H4)=> {H1 H2 NE H3 H4 G L}.
  move: CG; apply/paco1_acc=>r _ /(_ _ (CIH4 _ _ _ _ _ _ _))-CIH.
  move=> CG [L] [G] [cG [gG [NE [PRJ GU]]]]; apply/paco1_fold.
  move: (unroll_guarded cG gG); move: PRJ=>/eqP-PRJ.
  move: (project_unroll (rec_depth G) cG PRJ)=>[n1][n2][L'][{}PRJ] _.
  move: GU=>/(GUnroll_ind (rec_depth G)); move: PRJ.
  move: gG=>/(g_guarded_nunroll (rec_depth G) cG).
  move: cG=>/(g_closed_unroll (rec_depth G)).
  move: NE=>/(ne_unr (rec_depth G)).
  move: (n_unroll (rec_depth G) G) => {}G; move: L'=>{}L {n1 n2}.
  case: G =>/=; rewrite -/prj_all.
  - by move=>_ _ _ _  /gunroll_unfold; elim/gunr_inv=>//; constructor.
  - by move=>v /=; rewrite /g_closed/=.
  - by move=>G _ _ _ _ _ /(_ G); rewrite eq_refl.
  - rewrite /g_closed; move=> F T C NE /= /flatten_eq_nil/member_map-cC.
    move=>/forallbP/forall_member-gG; rewrite -/(prj_all _ _).
    case PRJ: prj_all =>[L'|//]; move: PRJ=>/eqP-PRJ.
    case: ifP=>// FT _; move=>/gunroll_unfold.
    have CNE: C != [::] by case: C NE {cC gG PRJ}.
    have {}NE: all id [seq non_empty_cont K.2.2 | K <- C]
      by case: C NE {CNE cC gG PRJ}.
    move: NE=>/forallbP/forall_member/member_map-NE.
    elim/gunr_inv => // _ F' T' C' CC DOM UA E1 _ _ {CG}.
    move: E1 DOM UA=>[->->->] DOM UA {F' T' C'}; constructor; rewrite ?FT//.
    * move=> l Ty G CCl; right; move: (dom' DOM CCl)=>[G']FND.
      move: PRJ=>/eqP-PRJ; move: (prj_all_find PRJ FND)=>[L0][_]/eqP-{}PRJ.
      move: (UA _ _ _ _ FND CCl) (find_member FND)=>[GU|//] M.
        by apply (CIH _ _ _ (cC _ M) (gG _ M) (NE _ M) PRJ GU).
    * case: C CNE DOM {cC gG PRJ NE UA}=>//[][l [Ty G]] Ks _.
      have FND: find_cont ((l, (Ty, G)) :: Ks) l = Some (Ty, G)
        by rewrite/find_cont/extend eq_refl.
        by move=>DOM; move: (dom DOM FND)=> CCl; exists l, Ty.
Qed.

Lemma lunroll_merge r L CL CONT Ks
      (LU : LUnroll L CL)
      (PRJ : prj_all simple_merge CONT r = Some Ks)
      (MRG : simple_merge L [seq K.2.2 | K <- Ks] = Some L)
  : exists CCL,
      same_dom (find_cont Ks) CCL /\ simple_co_merge CCL CL.
Proof.
  set CCL := fun l =>
               match find_cont Ks l with
               | Some (Ty, _) => Some (Ty, CL)
               | None => None
               end.
  exists CCL; split.
  - move=> l Ty; split=>[][G]; rewrite /CCL/=.
    + by move=>->; exists CL.
    + by case: find_cont=>// [][Ty' G'][<-_]; exists G'.
  - rewrite /CCL=>l Ty L'; case: find_cont=>//[][Ty' G'][_]->.
    by apply/EqL_refl.
Qed.

Lemma project_nonrec (r0 : proj_rel ) r CL CG L G
      (CIH : forall cG cL iG iL,
          g_closed iG ->
          guarded 0 iG ->
          non_empty_cont iG ->
          project simple_merge iG r == Some iL ->
          GUnroll iG cG ->
          LUnroll iL cL ->
          r0 cG cL)
      (cG : g_closed G)
      (gG : guarded 0 G)
      (NE : non_empty_cont G)
      (nrG : forall G' : g_ty, G != g_rec G')
      (iPrj : project simple_merge G r = Some L)
      (GU : GUnroll G CG)
      (LU : LUnroll L CL)
  : paco2 (Proj_ simple_co_merge r) r0 CG CL.
Proof.
  move: (closed_not_var cG).
  case: (boolP (r \notin participants G)); [| rewrite negbK].
  - move=> PARTS nvG; move: iPrj=>/eqP-iPrj.
    move: (proj1 (project_parts cG iPrj) PARTS)=> endL.
    move: (lunroll_isend LU endL)=>->; apply/paco2_fold.
    constructor; first by move=>/(partof_unroll cG gG GU)-P'; move: P' PARTS=>->.
    by apply/(project_wf cG gG NE iPrj).
  - case: G cG gG NE nrG iPrj GU=>//;
            first by move=> GT _ _ _ /(_ GT); rewrite eq_refl.
    move=>FROM TO CONT; rewrite project_msg /g_closed/=.
    move=>/flatten_eq_nil/member_map-cG /forallbP/forall_member-gG.
    move=>/andP-[NE_C /forallbP/forall_member/member_map-NE] _ I_prj GU PARTS _.
    move: GU; move=>/gunroll_unfold.
    case E: _ _/ =>// [FROM' TO' CONT' CC DOM GU].
    move: E DOM GU=> [<-<-<-] {FROM' TO' CONT'} DOM GU.
    apply/paco2_fold; move: I_prj.
    case E: prj_all=>[KsL|]//; case:ifP=>// F_neq_T.
    case:ifP=>[F_r | F_ne_r].
    + move=>[EL]; move: EL LU=><- {L} /lu_unfold-LU.
      case EL: _ _/LU=>[||a p Ks C LD LU]//; move: EL LD LU=>[<-<-<-] LD LU {a p Ks}.
      move: (prjall_dom E)=>iDOM.
      move: F_r CIH E=>/eqP<- CIH E; apply/prj_send; first by apply/negPf.
      * by apply/(same_dom_trans
                    (same_dom_trans ((same_dom_sym _ _).1 DOM) iDOM)).
      * move=> l Ty G G' CCl Cl; right; move: (dom' DOM CCl)=>[iG FND].
        move: (GU _ _ _ _ FND CCl)=>[{}GU|//].
        move: (dom iDOM FND)=>[iL FND'].
        move: (LU _ _ _ _ FND' Cl)=>[{}LU|//].
        move: (prjall_fnd E FND FND')=>/eqP-PRJ.
        move: (find_member FND)=>M.
        by apply: (CIH _ _ _ _ (cG _ M) (gG _ M) (NE _ M) PRJ GU LU).
    + case:ifP=>[T_r | T_ne_r].
      * move=>[EL]; move: EL LU=><- {L} /lu_unfold-LU {F_ne_r}.
        case EL: _ _/LU=>[||a p Ks C DU LU]//; move: EL DU LU=>[<-<-<-] DU LU {a p Ks}.
        move: T_r CIH E=>/eqP<- CIH E.
        move: (prjall_dom E)=>iDOM.
        apply/prj_recv; first by rewrite eq_sym (F_neq_T).
        - by apply/(same_dom_trans
                      (same_dom_trans ((same_dom_sym _ _).1 DOM) iDOM)).
        - move=> l Ty G G' CCl Cl; right; move: (dom' DOM CCl)=>[iG FND].
          move: (GU _ _ _ _ FND CCl)=>[{}GU|//].
          move: (dom iDOM FND)=>[iL FND'].
          move: (LU _ _ _ _ FND' Cl)=>[{}LU|//].
          move: (prjall_fnd E FND FND')=>/eqP-PRJ.
          move: (find_member FND)=>M.
          by apply: (CIH _ _ _ _ (cG _ M) (gG _ M) (NE _ M) PRJ GU LU).
      * move=> MRG.
        have M: simple_merge L [seq K.2.2 | K <- KsL] = Some L
          by move: MRG=>{E}; case: KsL=>//=K Ks /eqP-M;
             move: (simple_merge_some M)=>E; move: E M=>->; rewrite eq_refl=>/eqP.
        move: (lunroll_merge LU E M)=>[CCL [DL cMRG]].
        move: F_ne_r T_ne_r; rewrite eq_sym=>F_ne_r; rewrite eq_sym=>T_ne_r.
        apply: prj_mrg;rewrite ?F_ne_r ?T_ne_r ?F_neq_T//; last by apply:cMRG.
        - case: CONT NE_C DOM {cG gG NE PARTS GU E}=>// K Ks _ DOM.
          case: K DOM=>[l [Ty G] DOM]/=.
          have: (find_cont ((l, (Ty, G)) :: Ks) l = Some (Ty, G))
            by rewrite /find_cont/extend !eq_refl.
          by move=>/(dom DOM)=>[G']; exists l, Ty.
        - move: E MRG=>/eqP-E /eqP-MRG; move: (prjall_merge E MRG)=> ALL_EQ.
          move=> l Ty G CCl; move: (dom' DOM CCl)=>[iG iFND].
          move: (find_member iFND)=>MEM; move: (GU _ _ _ _ iFND CCl)=>[GU'|//].
          move: (ALL_EQ _ MEM) (cG _ MEM)=>PK cK.
          move: PARTS; rewrite !in_cons F_ne_r T_ne_r /= => PARTS.
          move: PARTS=> /flatten_mapP-[K] /memberP-K_CONT r_in_K.
          move: ((project_parts_in (cG _ K_CONT) (ALL_EQ _ K_CONT)).2 r_in_K).
          rewrite (project_depth cK PK)=>[][m] H.
          by apply/(partof_all_unroll cK GU' PK)/H.
        - move:DOM=>/same_dom_sym-DOM; apply/(same_dom_trans DOM).
          by apply/(same_dom_trans _ DL)/(prjall_dom E).
        - move=> l Ty G cL CCl CCLl; right.
          move: (dom' DOM CCl)=>[iG iFND]; move: (find_member iFND)=>MEM.
          move: (cG _ MEM) (gG _ MEM) (NE _ MEM)=>/= {}cG {}gG {}NE.
          move: E MRG=>/eqP-E /eqP-MRG; move: (prjall_merge E MRG).
          move=>/(_ _ MEM)=>/=PRJ.
          move: (GU _ _ _ _ iFND CCl)=>[{}GU|//].
          apply: (CIH _ _ _ _ cG gG NE PRJ GU).
          apply/(LUnroll_EqL LU).
          by move: (cMRG _ _ _ CCLl)=>/EqL_sym.
Qed.

Theorem ic_proj r :
  forall iG iL cG cL,
    g_closed iG ->
    guarded 0 iG ->
    non_empty_cont iG ->
    project simple_merge iG r == Some iL ->
    GUnroll iG cG ->
    LUnroll iL cL ->
    Project simple_co_merge r cG cL.
Proof.
  move=> iG iL cG cL CG GG NE Prj GU LU.
  move: (conj CG (conj GG (conj NE (conj Prj (conj GU LU)))))
  => {CG GG Prj GU LU NE}.
  move => /(ex_intro (fun iL=> _) iL) {iL}.
  move => /(ex_intro (fun iG=> _) iG) {iG}.
  move: cG cL; apply/paco2_acc=> r0 _ CIH.

  move: CIH =>/(_ _ _
                  (ex_intro _ _
                     (ex_intro _ _
                        (conj _ (conj _ (conj _ (conj _ (conj _ _))))))))-CIH.
  move=> cG cL [iG] [cG'] [ciG] [giG] [NE] [iGiL] [GU LU].

  move: iGiL  => /eqP-iGiL.
  move: (project_unroll (rec_depth iG) ciG iGiL) => [U1] [U2] [L] [proj] U12.
  move: LU =>/(LUnroll_ind U1); move: U12=>->; rewrite -LUnroll_ind=>UL.
  move : GU (unroll_guarded ciG giG)=>/(GUnroll_ind (rec_depth iG))=>GU nrG.
  move: (g_guarded_nunroll (rec_depth iG) ciG giG)=>guiG.
  move: (g_closed_unroll (rec_depth iG) ciG)=>cuiG {ciG giG iGiL}.
  move: (ne_unr (rec_depth iG) NE)=>{}NE.
  by apply/(project_nonrec CIH cuiG guiG NE nrG proj).
Qed.

Theorem coind_proj r G L :
  g_precond G ->
  project simple_merge G r == Some L ->
  Project simple_co_merge r (g_expand G) (l_expand L).
Proof.
  rewrite/g_precond=>/andP-[/andP-[cG gG] NE] P.
  move: (proj_lclosed cG P) (project_guarded P) (proj_lne NE P)=>cL gL NEl.
  move: (g_expand_unr gG cG NE) (l_expand_unr gL cL NEl)=>{cL gL NEl}.
  by apply/ic_proj.
Qed.

Theorem expand_eProject (g : g_ty) (e : seq (role * l_ty))
  : eproject simple_merge g = Some e ->
    eProject simple_co_merge (ig_end (g_expand g)) (expand_env e).
Proof.
  move=>EPRJ p; constructor.
  have PRE: g_precond g by move: EPRJ;rewrite/eproject;case:ifP.
  move: (precond_parts PRE); case: (boolP (nilp (participants g))).
  + move=> NOPARTS [//|END]; move: EPRJ; rewrite /eproject PRE.
    move: (participants g) NOPARTS=>[]//= _ [<-].
    rewrite /look -in_expanded_env/= (expand_g_end END).
    apply/paco2_fold/prj_end; first by case E: _ / =>//.
      by apply/paco1_fold; constructor.
  + move=>NE _.
    have cG: g_closed g by move: PRE=>/andP-[/andP-[cG gG] CNE].
    have gG: guarded 0 g by move: PRE=>/andP-[/andP-[_ gG] CNE].
    have CNE: non_empty_cont g by move: PRE=>/andP-[_ CNE].
    have GU: GUnroll g (g_expand g) by apply/(g_expand_unr gG cG CNE).
    move: (eproject_some EPRJ NE)=>[q [L] /eqP-PRJ'].
    have gWF: WF (g_expand g) by apply/(project_wf cG gG CNE PRJ' GU).
    move=>{PRJ' L q}.
    case: (boolP (p \in participants g)).
  - move=>PS; move: EPRJ=>/eqP/eproject_part/(_ _ PS)-PRJ.
    rewrite /look -in_expanded_env.
    have ->: (odflt rl_end (omap l_expand (find_cont e p)))
    = l_expand (odflt l_end (find_cont e p))
      by case: find_cont=>//=;rewrite (rltyU (l_expand _)).
      by apply/coind_proj=>//; apply/eqP.
  - move=>PARTS; have NP: ~ part_of p (g_expand g)
            by move=> P_of; move: PARTS; rewrite (partof_unroll cG gG GU).
    rewrite /look -in_expanded_env (fnd_not_part EPRJ PARTS)/=.
      by apply/paco2_fold/prj_end.
Qed.


Require Import floyd.proofauto.
Require Import floyd.library.
Require Import progs.list_dt. Import Links.
Require Import progs.queue.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_elem := Tstruct _elem noattr.
Definition t_struct_fifo := Tstruct _fifo noattr.

Instance QS: listspec _elem _next (fun _ _ => emp).
Proof. eapply mk_listspec; reflexivity. Defined.

Lemma isnil: forall {T: Type} (s: list T), {s=nil}+{s<>nil}.
Proof. intros. destruct s; [left|right]; auto. intro Hx; inv Hx. Qed.

Definition Qsh : share := fst (Share.split Share.Lsh).
Definition Qsh' := Share.lub (snd (Share.split Share.Lsh)) Share.Rsh.

Lemma readable_share_Qsh': readable_share Qsh'.
Proof.
unfold readable_share, Qsh'.
rewrite Share.distrib1.
rewrite Share.glb_idem.
rewrite Share.lub_commute.
rewrite Share.lub_absorb.
apply readable_nonidentity.
apply writable_readable.
apply sepalg.join_sub_refl.
Qed.  (* share hacking *)

Lemma Qsh_not_readable: ~ readable_share Qsh.
Proof.
unfold Qsh, readable_share; intro.
unfold nonempty_share in H.
apply H; clear H.
assert (Share.glb Share.Rsh (fst (Share.split Share.Lsh)) = Share.bot).
apply sub_glb_bot with Share.Lsh.
exists (snd (Share.split Share.Lsh)).
apply split_join.
destruct (Share.split Share.Lsh); reflexivity.
unfold Share.Rsh, Share.Lsh.
rewrite Share.glb_commute.
apply glb_split.
rewrite H.
apply bot_identity.
Qed.

Hint Resolve Qsh_not_readable.

Lemma Qsh_nonempty: Qsh <> Share.bot.
Proof.
unfold Qsh; intro.
destruct (Share.split Share.Lsh) eqn:?H.
simpl in H.
apply Share.split_nontrivial in H0; auto.
unfold Share.Lsh in H0; clear - H0.
destruct (Share.split Share.top) eqn:?H.
simpl in H0.
apply Share.split_nontrivial in H; auto.
apply Share.nontrivial in H.
auto.
Qed.

Hint Resolve Qsh_nonempty : valid_pointer.

Lemma Qsh_nonidentity: sepalg.nonidentity Qsh.
Proof.
  intro.
  apply identity_share_bot in H.
  apply Qsh_nonempty in H.
  auto.
Qed.

Hint Resolve Qsh_nonidentity : valid_pointer.

Lemma Qsh_Qsh': sepalg.join Qsh Qsh' Tsh.
Proof.
unfold Qsh, Qsh', Share.Lsh, Share.Rsh.
destruct (Share.split Share.top) as [a c] eqn:?H.
simpl.
destruct (Share.split a) as [x y] eqn:?H.
simpl.
pose proof (Share.split_disjoint x y a H0).
pose proof (Share.split_disjoint _ _ _ H).
split.
rewrite Share.distrib1.
rewrite H1.
rewrite Share.lub_commute, Share.lub_bot.
replace x with (Share.glb x a).
rewrite Share.glb_assoc. rewrite H2.
apply Share.glb_bot.
clear - H0.
apply split_join in H0. destruct H0.
subst a.
apply Share.glb_absorb.
rewrite <- Share.lub_assoc.
apply split_join in H0. destruct H0.
rewrite H3.
apply split_join in H. destruct H.
apply H4.
Qed.

Lemma field_at_list_cell_weak:
  forall sh i j p,
   readable_share sh ->
  field_at sh list_struct [StructField _a] i p *
  field_at sh list_struct [StructField _b] j p *
  field_at_ sh list_struct [StructField _next] p
  = list_cell QS sh (i,j) p *
  field_at_ sh list_struct [StructField _next] p.
Proof.
intros.
(* new version of proof, for constructive definition of list_cell *)
f_equal.
unfold field_at, list_cell.
autorewrite with gather_prop.
f_equal.
apply ND_prop_ext.
rewrite field_compatible_cons; simpl.
rewrite field_compatible_cons; simpl.
intuition.
+ left; auto.
+ right; left; auto.
Qed.

Lemma make_unmake:
 forall a b p,
 field_at Tsh t_struct_elem [] (Vint a, (Vint b, Vundef)) p =
 field_at Qsh' t_struct_elem [StructField _a] (Vint a) p *
 field_at Qsh' t_struct_elem [StructField _b] (Vint b) p *
 list_cell QS Qsh (Vundef, Vundef) p *
 field_at_ Tsh t_struct_elem [StructField _next] p.
Proof.
intros.
unfold_field_at 1%nat.
rewrite <- !sepcon_assoc.
match goal with |- ?A = _ => set (J := A) end.
unfold field_at_.
change (default_val (nested_field_type t_struct_elem [StructField _next])) with Vundef.
rewrite <- (field_at_share_join _ _ _ _ _ _ _ Qsh_Qsh').
rewrite <- !sepcon_assoc.
pull_left (field_at Qsh' t_struct_elem [StructField _next] Vundef p).
pull_left (field_at Qsh' t_struct_elem [StructField _b] (Vint b) p).
pull_left (field_at Qsh' t_struct_elem [StructField _a] (Vint a) p).
rewrite field_at_list_cell_weak  by apply readable_share_Qsh'.
match goal with |- _ = _ * _ * _ * ?A => change A
  with (field_at_ Qsh t_struct_elem [StructField _next] p)
end.
pull_left (list_cell QS Qsh (Vundef, Vundef) p).
rewrite join_cell_link with (psh:=Tsh) by (auto; try apply Qsh_Qsh'; apply readable_share_Qsh').
subst J.
match goal with |- _ * _ * ?A = _ => change A
  with (field_at_ Tsh t_struct_elem [StructField _next] p)
end.
rewrite field_at_list_cell_weak by auto.
rewrite sepcon_assoc.
f_equal.
unfold field_at_.
change (default_val (nested_field_type t_struct_elem [StructField _next])) with Vundef.
rewrite sepcon_comm.
symmetry.
apply (field_at_share_join _ _ _ t_struct_elem [StructField _next]
   _ p Qsh_Qsh').
Qed.

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH n:Z
   PRE [ _n OF tuint ]
       PROP (0 <= n <= Int.max_unsigned)
       LOCAL (temp _n (Vint (Int.repr n)))
       SEP ()
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (malloc_token Tsh n p * memory_block Tsh n p).

Definition elemrep (rep: elemtype QS) (p: val) : mpred :=
  field_at Tsh t_struct_elem [StructField _a] (fst rep) p *
  (field_at Tsh t_struct_elem [StructField _b] (snd rep) p *
   (field_at_ Tsh t_struct_elem [StructField _next]) p).

Definition fifo (contents: list val) (p: val) : mpred :=
  (EX ht: (val*val), let (hd,tl) := ht in
      !! is_pointer_or_null hd && !! is_pointer_or_null tl &&
      data_at Tsh t_struct_fifo (hd, tl) p * malloc_token Tsh (sizeof t_struct_fifo) p *
      if isnil contents
      then (!!(hd=nullval) && emp)
      else (EX prefix: list val,
              !!(contents = prefix++tl::nil)
            &&  (lseg QS Qsh Tsh prefix hd tl
                   * list_cell QS Qsh (Vundef,Vundef) tl
                   * field_at Tsh t_struct_elem [StructField _next] nullval tl)))%logic.

Definition fifo_new_spec :=
 DECLARE _fifo_new
  WITH u : unit
  PRE  [  ]
       PROP() LOCAL() SEP ()
  POST [ (tptr t_struct_fifo) ]
    EX v:val, PROP() LOCAL(temp ret_temp v) SEP (fifo nil v).

Definition fifo_put_spec :=
 DECLARE _fifo_put
  WITH q: val, contents: list val, p: val
  PRE  [ _Q OF (tptr t_struct_fifo) , _p OF (tptr t_struct_elem) ]
          PROP () LOCAL (temp _Q q; temp _p p)
          SEP (fifo contents q;
                 list_cell QS Qsh (Vundef, Vundef) p;
                 field_at_ Tsh t_struct_elem [StructField _next] p)
  POST [ tvoid ]
          PROP() LOCAL() SEP (fifo (contents++(p :: nil)) q).

Definition fifo_empty_spec :=
 DECLARE _fifo_empty
  WITH q: val, contents: list val
  PRE  [ _Q OF (tptr t_struct_fifo) ]
     PROP() LOCAL (temp _Q q) SEP(fifo contents q)
  POST [ tint ]
      PROP ()
      LOCAL(temp ret_temp (if isnil contents then Vtrue else Vfalse))
      SEP (fifo (contents) q).

Definition fifo_get_spec :=
 DECLARE _fifo_get
  WITH q: val, contents: list val, p: val
  PRE  [ _Q OF (tptr t_struct_fifo) ]
       PROP() LOCAL (temp _Q q) SEP (fifo (p :: contents) q)
  POST [ (tptr t_struct_elem) ]
       PROP ()
       LOCAL(temp ret_temp p)
       SEP (fifo contents q;
              list_cell QS Qsh (Vundef, Vundef) p;
              field_at_ Tsh t_struct_elem [StructField _next] p).

Definition make_elem_spec :=
 DECLARE _make_elem
  WITH a: int, b: int
  PRE  [ _a OF tint, _b OF tint ]
        PROP() LOCAL(temp _a (Vint a); temp _b (Vint b)) SEP()
  POST [ (tptr t_struct_elem) ]
      @exp (environ->mpred) _ _ (fun p:val =>  (* EX notation doesn't work for some reason *)
       PROP()
       LOCAL (temp ret_temp p)
       SEP (field_at Qsh' list_struct [StructField _a] (Vint a) p;
              field_at Qsh' list_struct [StructField _b] (Vint b) p;
              list_cell QS Qsh (Vundef, Vundef) p;
              field_at_ Tsh t_struct_elem [StructField _next] p;
              malloc_token Tsh (sizeof t_struct_elem) p)).

Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ] main_post prog nil u.

Definition Gprog : funspecs :=
  ltac:(with_library prog
    [surely_malloc_spec; fifo_new_spec; fifo_put_spec;
     fifo_empty_spec; fifo_get_spec; make_elem_spec;
     main_spec]).

Lemma body_surely_malloc: semax_body Vprog Gprog f_surely_malloc surely_malloc_spec.
Proof.
  start_function.
  forward_call (* p = malloc(n); *)
     n.
  Intros p.
  forward_if
  (PROP ( )
   LOCAL (temp _p p)
   SEP (malloc_token Tsh n p * memory_block Tsh n p)).
*
  if_tac.
    subst p. entailer!.
    entailer!.
*
    forward_call tt.
    contradiction.
*
    if_tac.
    + forward. subst p. inv H0.
    + Intros. forward. entailer!.
*
  forward. Exists p; entailer!.
Qed.

Lemma memory_block_fifo:
 forall p,
  field_compatible t_struct_fifo nil p ->
  memory_block Tsh 8 p = field_at_ Tsh t_struct_fifo nil p.
Proof.
 intros.
 change 8 with (sizeof t_struct_fifo).
 rewrite memory_block_data_at_; auto.
Qed.

Lemma fifo_isptr: forall al q, fifo al q |-- !! isptr q.
Proof.
intros.
 unfold fifo.
 if_tac; entailer; destruct ht; entailer!.
Qed.

Hint Resolve fifo_isptr : saturate_local.

Lemma body_fifo_empty: semax_body Vprog Gprog f_fifo_empty fifo_empty_spec.
Proof.
start_function.
unfold fifo.
Intros ht; destruct ht as [hd tl].
Intros.
forward. (* h = Q->head; *)
forward. (* return (h == NULL); *)
unfold fifo.
Exists (hd,tl).
destruct (isnil contents).
* entailer!.
  apply andp_right; auto with valid_pointer.
* Intros prefix.
Exists prefix.
  assert_PROP (isptr hd).
    destruct prefix; entailer.
    rewrite lseg_cons_eq by auto. Intros y. subst v.
    entailer.
 destruct hd; try contradiction.
 entailer!. entailer!.
Qed.

Lemma body_fifo_new: semax_body Vprog Gprog f_fifo_new fifo_new_spec.
Proof.
  start_function.
  forward_call (* Q = surely_malloc(sizeof ( *Q)); *)
     (sizeof t_struct_fifo).
    simpl; computable.
  Intros q.
  assert_PROP (field_compatible t_struct_fifo [] q).
   entailer!.
  rewrite memory_block_fifo by auto.
  forward. (* Q->head = NULL; *)
  (* goal_4 *)
  forward. (* Q->tail = NULL; *)
  forward. (* return Q; *)
  (* goal_5 *)
  Exists q. unfold fifo. Exists (nullval,nullval).
  rewrite if_true by auto.
  entailer!.
Qed.

Lemma body_fifo_put: semax_body Vprog Gprog f_fifo_put fifo_put_spec.
Proof.
start_function.
unfold fifo at 1.
Intros ht; destruct ht as [hd tl].
Intros.
(* goal_7 *)
forward. (* p->next = NULL; *)
forward. (*   h = Q->head; *)

forward_if
  (PROP() LOCAL () SEP (fifo (contents ++ p :: nil) q))%assert.
* if_tac; entailer.  (* typechecking clause *)
    (* entailer! should perhaps solve this one too *)
* (* then clause *)
  subst.
  (* goal 9 *)
  forward. (* Q->head=p; *)
  forward. (* Q->tail=p; *)
  (* goal 10 *)
  entailer.
  destruct (isnil contents).
  + subst. Exists (p,p).
     simpl. rewrite if_false by congruence.
     Exists (@nil val).
      rewrite lseg_nil_eq by auto.
      entailer!.
   + Intros prefix.
      destruct prefix;
      entailer!.
      contradiction (field_compatible_isptr _ _ _ H9).
      rewrite lseg_cons_eq by auto. simpl.
      Intros y. saturate_local.
      contradiction (field_compatible_isptr _ _ _ H11).
* (* else clause *)
  forward. (*  t = Q->tail; *)
  destruct (isnil contents).
  + Intros. contradiction H; auto.
  + Intros prefix.
     forward. (*  t->next=p; *)
  (* goal 12 *)
     forward. (* Q->tail=p; *)
  (* goal 13 *)
     entailer!.
     unfold fifo. Exists (hd, p).
     rewrite if_false by (clear; destruct prefix; simpl; congruence).
     Exists  (prefix ++ tl :: nil).
     entailer.
     match goal with
     | |- _ |-- _ * _ * ?AA => remember AA as A
     end.     (* prevent it from canceling! *)
     simpl sizeof.
     cancel. subst A.
(* XXX: eapply derives_trans. Focus 2. apply lseg_cons_right_neq. *)
     eapply derives_trans; [ |
       apply (lseg_cons_right_neq _ _ _ _ _ ((Vundef,Vundef) : elemtype QS));
        auto ].
     cancel.
* (* after the if *)
     forward. (* return ; *)
Qed.

Lemma body_fifo_get: semax_body Vprog Gprog f_fifo_get fifo_get_spec.
Proof.
start_function.
unfold fifo at 1.
Intros ht; destruct ht as [hd tl].
rewrite if_false by congruence.
Intros prefix.
forward.  (*   p = Q->head; *)
destruct prefix; inversion H; clear H.
+ subst_any.
   rewrite lseg_nil_eq by auto.
   Intros.
   subst_any.
   forward. (*  n=h->next; *)
   forward. (* Q->head=n; *)
   forward. (* return p; *)
   unfold fifo. Exists (nullval, tl).
   rewrite if_true by congruence.
   simpl sizeof; entailer!.
+ rewrite lseg_cons_eq by auto.
    Intros x.
    simpl @valinject. (* can we make this automatic? *)
    subst_any.
    forward. (*  n=h->next; *)
    forward. (* Q->head=n; *)
    forward. (* return p; *)
    unfold fifo. Exists (x, tl).
    rewrite if_false by (destruct prefix; simpl; congruence).
    Exists prefix.
    entailer!.
Qed.

Lemma body_make_elem: semax_body Vprog Gprog f_make_elem make_elem_spec.
Proof.
start_function. rename a into a0; rename b into b0.
forward_call (*  p = surely_malloc(sizeof ( *p));  *)
  (sizeof t_struct_elem).
 simpl; computable.
 Intros p.
 assert_PROP (field_compatible t_struct_elem [] p). entailer!.
 rewrite memory_block_data_at_ by auto.
  forward.  (*  p->a=a; *)
  simpl.  (* this should not be necessary -- Qinxiang, please look *)
  forward.  (*  p->b=b; *)
  forward.  (* return p; *)
  Exists p.
  entailer!.
  rewrite make_unmake.
  solve [auto].
Qed.

Hint Resolve readable_share_Qsh'.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
forward_call (* Q = fifo_new(); *)  tt.
Intros q.

forward_call  (*  p = make_elem(1,10); *)
     (Int.repr 1, Int.repr 10).
Intros p'.
forward_call (* fifo_put(Q,p);*)
    ((q, @nil val),p').

forward_call  (*  p = make_elem(2,20); *)
     (Int.repr 2, Int.repr 20).
Intros p2.
simpl app.
 forward_call  (* fifo_put(Q,p); *)
    ((q,(p':: nil)),p2).
simpl app.
forward_call  (*   p' = fifo_get(Q); p = p'; *)
    ((q,(p2 :: nil)),p').
forward. (*   i = p->a;  *)
forward. (*   j = p->b; *)
change (malloc_token Tsh 12) with (malloc_token Tsh (sizeof t_struct_elem)).
forward_call (*  free(p, sizeof( *p)); *)
   (p', sizeof t_struct_elem).
{
 pose (work_around_coq_bug := fifo [p2] q *
   data_at Tsh t_struct_elem (Vint (Int.repr 1), (Vint (Int.repr 10), Vundef)) p' *
   field_at Qsh' list_struct [StructField _a] (Vint (Int.repr 2)) p2 *
   field_at Qsh' list_struct [StructField _b] (Vint (Int.repr 20)) p2 *
   malloc_token Tsh (sizeof t_struct_elem) p2).
 apply derives_trans with work_around_coq_bug; subst work_around_coq_bug.
 unfold data_at; rewrite make_unmake; cancel.
 apply derives_trans with
   (data_at_ Tsh t_struct_elem p' * fold_right_sepcon Frame).
 cancel.
 rewrite data_at__memory_block by reflexivity. entailer.
}
forward. (* return i+j; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
unfold Gprog, prog, prog_funct; simpl.
semax_func_cons body_malloc. apply semax_func_cons_malloc_aux.
semax_func_cons body_free.
semax_func_cons body_exit.
semax_func_cons body_surely_malloc.
semax_func_cons body_fifo_new.
semax_func_cons body_fifo_put.
semax_func_cons body_fifo_empty.
semax_func_cons body_fifo_get.
semax_func_cons body_make_elem.
semax_func_cons body_main.
Qed.