Require Import Coq.omega.Omega.
Require Import Bedrock.Examples.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.

Module Import Coq8485_workaround_nat_dec_uses_f_equal_nat.
  Module Coq.
    Module Init.
      Module Peano.
        Definition f_equal_nat := f_equal (A:=nat).
        Definition f_equal_pred := f_equal pred.
        Definition f_equal2_plus := f_equal2 plus.
        Definition f_equal2_nat := f_equal2 (A1:=nat) (A2:=nat).
        Definition f_equal2_mult := f_equal2 mult.
      End Peano.
    End Init.
  End Coq.
End Coq8485_workaround_nat_dec_uses_f_equal_nat.

Require Import Coq.Bool.Bool.
Require Import Bedrock.Examples.Conditional Bedrock.Examples.Lambda.
Export Conditional Lambda.

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
  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 BinInt.Z.ltb ZArith_dec.Zcompare_rect
  ZArith_dec.Z_ge_dec label'_eq label'_rec label'_rect
  COperand1 CTest COperand2 Pos.succ
  makeVcs

  Cond_ Cond
  Lambda__ Lambda_
].

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
         BinInt.Z.ltb

         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
         (* we fully qualify these names to work around the fact that they are new to 8.5 *)
         Coq.Init.Peano.f_equal_nat Coq.Init.Peano.f_equal_pred Coq.Init.Peano.f_equal2_plus Coq.Init.Peano.f_equal2_nat Coq.Init.Peano.f_equal2_mult

         (** 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

         (** 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
         BinInt.Z.ltb

         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
         (* we fully qualify these names to work around the fact that they are new to 8.5 *)
         Coq.Init.Peano.f_equal_nat Coq.Init.Peano.f_equal_pred Coq.Init.Peano.f_equal2_plus Coq.Init.Peano.f_equal2_nat Coq.Init.Peano.f_equal2_mult

         (** 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

         (** 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.

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
              | context[locals ?ns' ?vs' ?avail' _] =>
                match avail' with
                  | avail => fail 1
                  | _ =>
                    match vs' with
                      | vs => constr_eq vs' vs; fail 1
                      | _ => let ns'' := peelPrefix ns ns' in
                        rewrite (create_locals_out ns'' ns' avail' ns avail);
                          assert (ok_out ns avail ns'' ns' avail')%nat by (split; [
                            reflexivity
                            | split; [
                              simpl; omega
                              | reflexivity ] ] )
                    end
                end
            end
        end;
    progress cancel ext in

  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 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; [ repeat constructor; simpl; intuition congruence
                               | 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; [ repeat constructor; simpl; intuition congruence
                          | 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; [ repeat constructor; simpl; intuition congruence
                              | 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 reassocate [H]
 * to put [P] in front. *)
Ltac toFront which H :=
  let rec toFront' P k :=
    match P with
      | SEP.ST.star ?Q ?R =>
        toFront' Q ltac:(fun it P' => k it (SEP.ST.star P' R))
        || toFront' R ltac:(fun it P' => k it (SEP.ST.star P' Q))
          || fail 2
      | _ => which P; k P (@SEP.ST.emp W (settings * state) nil)
    end in
    match type of H with
      | interp ?specs (![ ?P ] ?st) => toFront' 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.

(* 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.


From sflib Require Import sflib.
From Paco Require Import paco.
Require Import Coq.Classes.RelationClasses Lia Program.
From Fairness Require Export ITreeLib WFLibLarge FairBeh NatStructsLarge Mod pind.
From PromisingLib Require Import Loc Event.
From PromisingSEQ Require Import Time View TView Cell Memory Local.

Set Implicit Arguments.

Module WMem.
  Program Definition init_cell: Cell.t :=
    @Cell.mk (LocMap.singleton Time.bot (Time.bot, Message.concrete (Const.of_Z (BinIntDef.Z.of_nat 0)) None)) _.
  Next Obligation.
  Proof.
    econs.
    { i. eapply LocMap.singleton_find_inv in GET. des; clarify. auto. }
    { i. eapply LocMap.singleton_find_inv in GET. des; clarify. auto. }
    { i. eapply LocMap.singleton_find_inv in GET1.
      eapply LocMap.singleton_find_inv in GET2. des; clarify.
    }
  Qed.

  Definition init_mem: Memory.t := fun _ => init_cell.

  Record t :=
    mk
      {
        memory:> Memory.t;
        sc: TimeMap.t;
      }.

  Definition init: t := mk init_mem TimeMap.bot.

  Let ident := (Loc.t * Time.t)%type.

  Definition view_to_local (vw: View.t): Local.t := Local.mk (TView.mk (fun _ => vw) vw vw) Memory.bot.

  Definition missed (m: Memory.t) (loc: Loc.t) (ts: Time.t): fmap ident :=
    fun '(loc', ts') =>
      if (Loc.eq_dec loc' loc)
      then
        if (Time.le_lt_dec ts' ts)
        then Flag.emp
        else match Memory.get loc' ts' m with
             | Some (_, Message.concrete _ (Some _)) => Flag.fail
             | _ => Flag.emp
             end
      else Flag.emp.

  Definition load_fun:
    ktree (programE ident t) (View.t * Loc.t * Ordering.t) (View.t * Const.t) :=
    fun '(vw0, loc, ord) =>
      msc <- trigger (Get id);;
      '(exist _ (lc1, val, to) _) <- trigger (Choose (sig (fun '(lc1, val, to) =>
                                                             exists released,
                                                               Local.read_step
                                                                 (view_to_local vw0)
                                                                 (msc.(memory))
                                                                 loc
                                                                 to
                                                                 val
                                                                 released
                                                                 ord
                                                                 lc1)));;
      _ <- trigger (Fair (missed msc loc to));;
      Ret (lc1.(Local.tview).(TView.cur), val)
  .

  Definition store_fun:
    ktree (programE ident t) (View.t * Loc.t * Const.t * Ordering.t) (View.t) :=
    fun '(vw0, loc, val, ord) =>
      msc <- trigger (Get id);;
      '(exist _ (lc1, to, sc1, mem1) _) <- trigger (Choose (sig (fun '(lc1, to, sc1, mem1) =>
                                                                   exists from released kind,
                                                                     Local.write_step
                                                                       (view_to_local vw0)
                                                                       (msc.(sc))
                                                                       (msc.(memory))
                                                                       loc
                                                                       from
                                                                       to
                                                                       val
                                                                       None
                                                                       released
                                                                       ord
                                                                       lc1
                                                                       sc1
                                                                       mem1
                                                                       kind)));;
      _ <- trigger (Fair (missed msc loc to));;
      _ <- trigger (Put (mk mem1 sc1));;
      Ret (lc1.(Local.tview).(TView.cur))
  .

  Definition faa_fun:
    ktree (programE ident t) (View.t * Loc.t * Const.t * Ordering.t * Ordering.t) (View.t * Const.t) :=
    fun '(vw0, loc, addendum, ordr, ordw) =>
      msc <- trigger (Get id);;
      '(exist _ (lc2, to, val, sc1, mem1) _) <-
        trigger (Choose (sig (fun '(lc2, to, val, sc1, mem1) =>
                                exists lc1 from releasedr releasedw kind,
                                  (Local.read_step
                                     (view_to_local vw0)
                                     (msc.(memory))
                                     loc
                                     from
                                     val
                                     releasedr
                                     ordr
                                     lc1) /\
                                    (Local.write_step
                                       lc1
                                       (msc.(sc))
                                       (msc.(memory))
                                       loc
                                       from
                                       to
                                       (Const.add val addendum)
                                       releasedr
                                       releasedw
                                       ordw
                                       lc2
                                       sc1
                                       mem1
                                       kind))));;
      _ <- trigger (Fair (missed msc loc to));;
      _ <- trigger (Put (mk mem1 sc1));;
      Ret (lc2.(Local.tview).(TView.cur), val)
  .

  Definition mod: Mod.t :=
    Mod.mk
      init
      (Mod.get_funs [("store", Mod.wrap_fun store_fun);
                     ("load", Mod.wrap_fun load_fun);
                     ("faa", Mod.wrap_fun faa_fun)
      ]).

End WMem.

From Fairness Require Import PCM IProp IPM FairRA StateRA MonotonePCM.
From PromisingSEQ Require Import MemoryProps.

Section MEMRA.
  Definition wmemRA: URA.t := (Loc.t ==> (Auth.t (Excl.t Cell.t)))%ra.

  Context `{WMEMRA: @GRA.inG wmemRA Σ}.

  Definition memory_resource_black (m: WMem.t): wmemRA :=
    fun loc =>
      Auth.black (Excl.just (m.(WMem.memory) loc): Excl.t Cell.t).

  Definition points_to_white (loc: Loc.t) (c: Cell.t): wmemRA :=
    fun loc' =>
      if (Loc.eq_dec loc' loc)
      then Auth.white (Excl.just c: Excl.t Cell.t)
      else URA.unit
  .

  Definition points_to (loc: Loc.t) (c: Cell.t): iProp :=
    OwnM (points_to_white loc c).

  Definition wmemory_black (m: WMem.t): iProp :=
    OwnM (memory_resource_black m).

  (* TODO: multiple locs *)
  Definition wmem_init_res (l0 l1: Loc.t): wmemRA :=
    points_to_white l0 WMem.init_cell ⋅ points_to_white l1 WMem.init_cell ⋅ memory_resource_black WMem.init.

  Lemma wmem_init_res_wf l0 l1
        (DISJ: l0 <> l1)
    :
    URA.wf (wmem_init_res l0 l1).
  Proof.
    unfold wmem_init_res, points_to_white, points_to, Auth.white.
    Local Transparent URA.unit.
    ur. i. ur. des_ifs.
    { splits.
      { eexists (URA.unit). ur. ss. }
      { ur. ss. }
    }
    { splits.
      { eexists (URA.unit). ur. ss. }
      { ur. ss. }
    }
    { splits.
      { eexists (Excl.just (WMem.init_mem k)). ur. ss. }
      { ur. ss. }
    }
  Qed.

  Lemma wmem_init_res_prop l0 l1
    :
    (OwnM (wmem_init_res l0 l1))
      -∗
      (points_to l0 WMem.init_cell ** points_to l1 WMem.init_cell ** wmemory_black WMem.init).
  Proof.
    iIntros "[[H0 H1] H2]". iFrame.
  Qed.

  (* normal points-to *)
  Definition wpoints_to (l: Loc.t) (v: Const.t) (vw: View.t): iProp :=
    ∃ c,
      (points_to l c)
        **
        (⌜exists from released,
              (<<GET: Cell.get (Cell.max_ts c) c = Some (from, Message.concrete v released)>>) /\
                (<<DEFINED: v <> Const.undef>>) /\
                (<<VIEW: View.le (View.singleton_ur l (Cell.max_ts c)) vw >>)⌝)
  .

  Lemma init_cell_max_ts
    :
    Cell.max_ts WMem.init_cell = Time.bot.
  Proof.
    auto.
  Qed.

  Lemma init_cell_get
    :
    Cell.get (Cell.max_ts WMem.init_cell) WMem.init_cell =
      Some (Time.bot, Message.concrete (BinIntDef.Z.of_nat 0) None).
  Proof.
    ss.
  Qed.

  Lemma init_cell_get_if to from msg
        (GET: Cell.get to WMem.init_cell = Some (from, msg))
    :
    (<<TO: to = Time.bot>>) /\
      (<<FROM: from = Time.bot>>) /\
      (<<MSG: msg = Message.concrete (BinIntDef.Z.of_nat 0) None>>).
  Proof.
    hexploit Cell.max_ts_spec; eauto. i. des.
    rewrite init_cell_max_ts in *. inv MAX.
    { inv H. }
    { inv H. setoid_rewrite init_cell_get in GET. clarify. }
  Qed.

  Lemma init_points_to_wpoints_to l v
    :
    (points_to l WMem.init_cell)
      -∗
      wpoints_to l (Const.of_Z (BinIntDef.Z.of_nat 0)) v.
  Proof.
    iIntros "H". iExists _. iFrame. iPureIntro. esplits.
    { rewrite init_cell_get. eauto. }
    { ss. }
    { econs.
      { ss. eapply TimeMap.singleton_spec.
        rewrite init_cell_max_ts. eapply Time.bot_spec. }
      { ss. eapply TimeMap.singleton_spec.
        rewrite init_cell_max_ts. eapply Time.bot_spec. }
    }
  Qed.

  Lemma wpoints_to_view_mon l v vw0 vw1
        (LE: View.le vw0 vw1)
    :
    (wpoints_to l v vw0)
      ⊢
      (wpoints_to l v vw1).
  Proof.
    unfold wpoints_to.
    iIntros "[% [OWN %]]". des. iExists _. iSplit; [iFrame|].
    iPureIntro. esplits; eauto.
  Qed.

  Lemma wmemory_ra_get
        m l c
    :
    (wmemory_black m)
      -∗
      (points_to l c)
      -∗
      ⌜m.(WMem.memory) l = c⌝.
  Proof.
    iIntros "BLACK WHITE".
    unfold wmemory_black, points_to.
    iCombine "BLACK WHITE" as "OWN". iOwnWf "OWN". iPureIntro.
    ur in H. specialize (H l).
    unfold memory_resource_black, points_to_white in H. des_ifs.
    ur in H. ur in H. des_ifs. des. rr in H. des. ur in H. des_ifs.
  Qed.

  Lemma pointwise_updatabable M K (a b: URA.pointwise K M)
        (POINTWISE: forall k, URA.updatable (a k) (b k))
    :
    URA.updatable a b.
  Proof.
    ii. ur. ur in H. i. eapply POINTWISE; eauto.
  Qed.

  Lemma wmemory_ra_write
        m0 m1 l c
        from to msg
        (WRITE: Memory.add m0.(WMem.memory) l from to msg m1)
    :
    (wmemory_black m0)
      -∗
      (points_to l c)
      -∗
      (#=> (wmemory_black (WMem.mk m1 m0.(WMem.sc)) ** points_to l (m1 l))).
  Proof.
    iIntros "BLACK WHITE".
    unfold wmemory_black, points_to.
    iCombine "BLACK WHITE" as "OWN". iOwnWf "OWN".
    ur in H. specialize (H l).
    unfold memory_resource_black, points_to_white in H. des_ifs.
    ur in H. ur in H. des_ifs. des. rr in H. des. ur in H. des_ifs.
    iAssert (#=> OwnM (memory_resource_black (WMem.mk m1 m0.(WMem.sc)) ⋅ points_to_white l (m1 l))) with "[OWN]" as "> [BLACK WHITE]".
    { iApply (OwnM_Upd with "OWN").
      ur. apply pointwise_updatabable. i.
      unfold memory_resource_black, points_to_white. ss.
      inv WRITE. setoid_rewrite LocFun.add_spec. des_ifs.
      eapply Auth.auth_update. ii. des. split; ss.
      { ur. ss. }
      { ur in FRAME. ur. des_ifs. rr.
        f_equal. symmetry. apply LocFun.add_spec_eq.
      }
    }
    { iModIntro. iFrame. }
  Qed.

  Lemma memory_write_max_ts m0 loc from to msg m1
        (ADD: Memory.add m0 loc from to msg m1)
        (MAX: Time.le (Memory.max_ts loc m0) to)
    :
    Memory.max_ts loc m1 = to.
  Proof.
    apply TimeFacts.antisym.
    { hexploit Memory.max_ts_spec.
      { eapply Memory.add_get0; eauto. }
      i. des. erewrite Memory.add_o in GET; eauto. des_ifs.
      { ss. des; clarify. }
      { des; ss. eapply Memory.max_ts_spec in GET. des. etrans; eauto. }
    }
    { eapply Memory.add_get0 in ADD. des.
      eapply Memory.max_ts_spec in GET0. des. auto.
    }
  Qed.

  Lemma wmemory_ra_load
        m l v0 v1 vw0 vw1
        ord lc1 to released
        (READ: Local.read_step (WMem.view_to_local vw0) m.(WMem.memory) l to v1 released ord lc1)
        (VIEW: vw1 = lc1.(Local.tview).(TView.cur))
        (ORD: ord = Ordering.plain)
    :
    (wmemory_black m)
      -∗
      (wpoints_to l v0 vw0)
      -∗
      ((wmemory_black m) ∗ (⌜(View.le vw0 vw1) /\ (v0 = v1)⌝) ∗ #=>(wpoints_to l v0 vw1)).
  Proof.
    iIntros "BLACK [% [WHITE %]]". des. subst.
    iPoseProof (wmemory_ra_get with "BLACK WHITE") as "%". subst.
    iSplitL "BLACK"; [auto|]. inv READ. ss. iSplit.
    { iPureIntro. split.
      { etrans; [|eapply View.join_l]. eapply View.join_l. }
      { assert (to = (Cell.max_ts (WMem.memory m l))).
        { eapply TimeFacts.antisym.
          { eapply Memory.max_ts_spec in GET0. des. clarify. }
          { inv READABLE. etrans; eauto.
            inv VIEW0. ss. specialize (PLN0 l).
            unfold TimeMap.singleton in PLN0.
            setoid_rewrite LocFun.add_spec_eq in PLN0. auto.
          }
        }
        subst. setoid_rewrite GET in GET0. clarify.
        inv VAL; ss.
        destruct v1, val'; ss. apply Z.eqb_eq in H0. subst. auto.
      }
    }
    { iModIntro. iExists _. iFrame. iPureIntro. esplits; eauto.
      ss. unfold View.singleton_ur_if. des_ifs.
      etrans; eauto.
      etrans; [|eapply View.join_l]. eapply View.join_l.
    }
  Qed.

  Lemma wmemory_ra_store
        m0 l v0 vw0 m1 v1 vw1
        lc1 to sc1 mem1 ord from released kind
        (WRITE: Local.write_step (WMem.view_to_local vw0) m0.(WMem.sc) m0.(WMem.memory) l from to v1 None released ord lc1 sc1 mem1 kind)
        (VIEW: vw1 = lc1.(Local.tview).(TView.cur))
        (MEM: m1 = WMem.mk mem1 sc1)
        (ORD: ord = Ordering.plain)
        (DEFINED: v1 <> Const.undef)
    :
    (wmemory_black m0)
      -∗
      (wpoints_to l v0 vw0)
      -∗
      ((⌜View.le vw0 vw1⌝) ∗ #=>((wmemory_black m1) ∗ (wpoints_to l v1 vw1))).
  Proof.
    iIntros "BLACK [% [WHITE %]]". des. subst.
    iPoseProof (wmemory_ra_get with "BLACK WHITE") as "%". subst.
    inv WRITE. ss. hexploit memory_write_bot_add; eauto. i. subst.
    inv WRITE0. inv PROMISE. clear REMOVE PROMISES ATTACH TS.
    assert (MAX: Cell.max_ts (mem1 l) = to).
    { hexploit Memory.max_ts_spec.
      { eapply Memory.add_get1; eauto. }
      i. des. erewrite Memory.add_o in GET0; eauto. des_ifs; ss.
      { des; clarify. }
      { des; ss. eapply Memory.max_ts_spec in GET0. des.
        hexploit Memory.max_ts_spec.
        { eapply Memory.add_get0; eauto. }
        i. des. inv WRITABLE.
        exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
        { eapply TS. }
        etrans; eauto.
        etrans; eauto.
        inv VIEW0. ss. specialize (RLX l).
        unfold TimeMap.singleton in RLX. setoid_rewrite LocFun.add_spec_eq in RLX. auto.
      }
    }
    subst. iSplit.
    { iPureIntro. eapply View.join_l. }
    iPoseProof (wmemory_ra_write with "BLACK WHITE") as "> [BLACK WHITE]".
    { eauto. }
    iModIntro. iSplitL "BLACK"; [auto|].
    iExists _. iSplit; [iFrame|]. iPureIntro. esplits; eauto.
    { eapply Memory.add_get0; eauto. }
    { ss. eapply View.join_r. }
  Qed.

  (* faa points-to *)
  Definition wpoints_to_faa (l: Loc.t) (v: Const.t): iProp :=
    ∃ c,
      (points_to l c)
        **
        (⌜exists from released,
              (<<GET: Cell.get (Cell.max_ts c) c = Some (from, Message.concrete v released)>>) /\
                (<<FAA: forall to from msg (GET: Cell.get to c = Some (from, msg)),
                    ((exists to' msg',
                         (<<GET: Cell.get to' c = Some (to, msg')>>) /\ (<<TS: Time.lt to to'>>)) \/
                       (<<TS: to = Cell.max_ts c>>))>>) /\
                (<<DEFINED: v <> Const.undef>>)⌝)
  .

  Lemma init_points_to_wpoints_to_faa l
    :
    (points_to l WMem.init_cell)
      -∗
      wpoints_to_faa l (Const.of_Z (BinIntDef.Z.of_nat 0)).
  Proof.
    iIntros "H". iExists _. iFrame. iPureIntro. esplits.
    { rewrite init_cell_get. eauto. }
    { i. hexploit init_cell_get_if; eauto. i. des; clarify.
      right. rewrite init_cell_max_ts. auto.
    }
    { ss. }
  Qed.

  Lemma wmemory_ra_faa
        v msc
        vw0 loc addendum ordr ordw
        lc1 from releasedr releasedw kind
        lc2 to val sc1 mem1
        (READ: Local.read_step (WMem.view_to_local vw0) (msc.(WMem.memory)) loc from val releasedr ordr lc1)
        (WRITE: Local.write_step lc1 (msc.(WMem.sc)) (msc.(WMem.memory)) loc from to (Const.add val addendum) releasedr releasedw ordw lc2 sc1 mem1 kind)
        (ORDR: ordr = Ordering.plain)
        (ORDW: ordw = Ordering.acqrel)
        (DEFINED: addendum <> Const.undef)
    :
    (wmemory_black msc)
      -∗
      (wpoints_to_faa loc v)
      -∗
      ((⌜(View.le vw0 lc2.(Local.tview).(TView.cur)) /\ (v = val)⌝)
         ∗ #=>((wmemory_black (WMem.mk mem1 sc1)) ∗ wpoints_to_faa loc (Const.add v addendum))).
  Proof.
    iIntros "BLACK [% [WHITE %]]". des. subst.
    iPoseProof (wmemory_ra_get with "BLACK WHITE") as "%". subst.
    inv READ. inv WRITE. ss.
    inv WRITE0. ss. hexploit memory_write_bot_add; eauto. i. subst.
    inv PROMISE. clear REMOVE PROMISES ATTACH TS.
    hexploit add_succeed_wf; eauto. i. des.
    assert (MAX0: from = Cell.max_ts (WMem.memory msc loc)).
    { hexploit FAA; eauto. i. des; auto.
      hexploit DISJOINT; eauto. i. exfalso. eapply H.
      { instantiate (1:=Time.meet to to'). econs; ss.
        { unfold Time.meet. des_ifs. }
        { eapply Time.meet_l. }
      }
      { econs; ss.
        { unfold Time.meet. des_ifs. }
        { eapply Time.meet_r. }
      }
    }
    subst. setoid_rewrite GET0 in GET. inv GET.
    assert (val = v).
    { inv VAL; ss. destruct val, v; ss. apply Z.eqb_eq in H0. subst. auto. }
    subst. iSplit.
    { iPureIntro. split.
      { etrans; [|eapply View.join_l].
        etrans; [|eapply View.join_l].
        eapply View.join_l.
      }
      { auto. }
    }
    assert (MAX1: to = Cell.max_ts (mem1 loc)).
    { eapply TimeFacts.antisym.
      { hexploit Memory.max_ts_spec.
        { eapply Memory.add_get0; eauto. }
        { i. des. eauto. }
      }
      { hexploit Memory.max_ts_spec.
        { eapply Memory.add_get1; eauto. }
        i. des. erewrite Memory.add_o in GET; eauto. des_ifs.
        { ss. des; subst. reflexivity. }
        { guardH o. eapply Memory.max_ts_spec in GET. des.
          etrans ;eauto. left. auto.
        }
      }
    }
    iPoseProof (wmemory_ra_write with "BLACK WHITE") as "> [BLACK WHITE]".
    { eauto. }
    iModIntro. iSplitL "BLACK"; [auto|].
    iExists _. iSplit; [iFrame|]. iPureIntro. esplits; eauto.
    { erewrite <- MAX1. eapply Memory.add_get0; eauto. }
    { i. setoid_rewrite Memory.add_o in GET; [|eauto]. des_ifs.
      { ss. des; clarify. auto. }
      { guardH o. hexploit FAA; eauto. i. des.
        { left. esplits; eauto. eapply Memory.add_get1; eauto. }
        { subst. left. esplits; eauto.
          { eapply Memory.add_get0; eauto. }
        }
      }
    }
    { ii. destruct v, addendum; ss. }
  Qed.

  (* full points-to *)
  Definition wProp := Const.t -> View.t -> Prop.
  Definition wor (P Q: wProp): wProp := fun c vw => ((P c vw) \/ (Q c vw)).
  Definition wimpl (P Q: wProp): Prop := (∀ c vw, (P c vw) -> (Q c vw)).

  Definition lift_wProp (P: wProp) (c: Const.t) (vw: View.t): iProp :=
    ∃ vw', (⌜P c vw'⌝) ∗ (⌜View.le vw' vw⌝).

  Lemma lift_wProp_mon
        P c vw0 vw1
        (LE: View.le vw0 vw1)
    :
    (lift_wProp P c vw0) -∗ (lift_wProp P c vw1).
  Proof.
    unfold lift_wProp. iIntros "[% [A %B]]". iExists vw'. iFrame.
    iPureIntro. etrans. eapply B. auto.
  Qed.

  Context `{OBLGRA: @GRA.inG ObligationRA.t Σ}.
  Context `{ARROWRA: @GRA.inG (ArrowRA (void + WMem.ident)%type) Σ}.
  Context `{IDENTTGT: @GRA.inG (identTgtRA (void + WMem.ident)%type) Σ}.
  Context `{EDGERA: @GRA.inG EdgeRA Σ}.
  Context `{ONESHOTSRA: @GRA.inG (@FiniteMap.t (OneShot.t unit)) Σ}.

  Definition wmemory_black_strong m: iProp :=
    wmemory_black m ** (FairRA.blacks (fun id => exists loc to, id = (inr (inr (loc, to))) /\ Memory.get loc to m.(WMem.memory) = None)).

  Lemma wmemory_ra_write_strong
        m0 m1 l c
        from to msg
        (WRITE: Memory.add m0.(WMem.memory) l from to msg m1)
    :
    (wmemory_black_strong m0)
      -∗
      (points_to l c)
      -∗
      (#=> (wmemory_black_strong (WMem.mk m1 m0.(WMem.sc)) ** points_to l (m1 l) ** FairRA.black_ex (inr (inr (l, to))) 1%Qp)).
  Proof.
    iIntros "[BLACK BLACKS] WHITE".
    iPoseProof (wmemory_ra_write with "BLACK WHITE") as "> [BLACK WHITE]"; [eauto|..].
    iModIntro. iFrame. iApply (FairRA.blacks_unfold with "BLACKS").
    { i. ss. des; subst.
      { erewrite Memory.add_o in IN0; eauto. des_ifs. esplits; eauto. }
      { esplits; eauto. eapply Memory.add_get0. eauto. }
    }
    { ii. des. clarify. ss. eapply Memory.add_get0 in WRITE. des; clarify. }
  Qed.

  Lemma wmemory_ra_faa_strong
        v msc
        vw0 loc addendum ordr ordw
        lc1 from releasedr releasedw kind
        lc2 to val sc1 mem1
        (READ: Local.read_step (WMem.view_to_local vw0) (msc.(WMem.memory)) loc from val releasedr ordr lc1)
        (WRITE: Local.write_step lc1 (msc.(WMem.sc)) (msc.(WMem.memory)) loc from to (Const.add val addendum) releasedr releasedw ordw lc2 sc1 mem1 kind)
        (ORDR: ordr = Ordering.plain)
        (ORDW: ordw = Ordering.acqrel)
        (DEFINED: addendum <> Const.undef)
    :
    (wmemory_black_strong msc)
      -∗
      (wpoints_to_faa loc v)
      -∗
      ((⌜(View.le vw0 lc2.(Local.tview).(TView.cur)) /\ (v = val)⌝)
         ∗ #=>((wmemory_black_strong (WMem.mk mem1 sc1)) ∗ wpoints_to_faa loc (Const.add v addendum))).
  Proof.
    iIntros "[BLACK BLACKS] WHITE".
    iPoseProof (wmemory_ra_faa with "BLACK WHITE") as "[% H]"; eauto.
    iSplitR; [auto|]. iPoseProof ("H") as "> [H0 H1]".
    iModIntro. unfold wmemory_black_strong. iFrame.
    inv READ. inv WRITE. hexploit memory_write_bot_add; eauto. i. subst. ss.
    inv WRITE0. inv PROMISE. ss.
    iPoseProof (FairRA.blacks_unfold with "BLACKS") as "[H0 H1]"; [..|iApply "H0"].
    { i. ss. des; subst.
      { erewrite Memory.add_o in IN0; eauto. des_ifs. esplits; eauto. }
      { esplits; eauto. eapply Memory.add_get0. eauto. }
    }
    { ii. des. clarify. eapply Memory.add_get0 in MEM. des; clarify. }
  Qed.

  Definition wpoints_to_full (l: Loc.t) (V: View.t) (k: nat) (P Q: wProp) : iProp :=
    ∃ c,
      (points_to l c)
        **
        (∃ v released,
            (⌜Cell.max_ts c = Time.bot⌝ ∨ ObligationRA.duty (inr (inr (l, (Cell.max_ts c)))) [(k,Ord.S Ord.O)])
              **
              (ObligationRA.pending k 1%Qp)
              **
              (⌜Q v View.bot⌝)
              **
              (⌜(<<MSGVIEW: V = View.join (View.unwrap released) (View.singleton_ur l (Cell.max_ts c))>>) /\
                 (<<DEFINED: v <> Const.undef>>) /\
                 exists from,
                   (<<GET: Cell.get (Cell.max_ts c) c = Some (from, Message.concrete v released)>>) /\
                     (<<DEFINED: v <> Const.undef>>) /\
                     (<<RELEASED: Time.lt Time.bot (Cell.max_ts c) -> released <> None>>)⌝)
              **
              (⌜forall to from' v' released' (GET: Cell.get to c = Some (from', Message.concrete v' released'))
                       (LT: Time.lt to (Cell.max_ts c)),
                    (P v' View.bot) /\ (<<DEFINED: v' <> Const.undef>>)⌝))
  .

  Lemma init_points_to_wpoints_to_full l (P Q: wProp)
        (SAT: Q (Const.of_Z (BinIntDef.Z.of_nat 0)) View.bot)
    :
    (points_to l WMem.init_cell)
      -∗
      #=>
      (∃ k, wpoints_to_full l View.bot k P Q ** ObligationRA.black k Ord.O).
  Proof.
    iIntros "H".
    iPoseProof (ObligationRA.alloc) as "> [% [[B W] PENDING]]".
    iModIntro. iExists _. iSplitR "B"; [|iApply "B"]. iExists _.
    iSplitL "H"; [iApply "H"|]. iExists _, _. iSplitL.
    { iSplitL.
      { iSplit; [|eauto]. iSplitR.
        { iLeft. iPureIntro. apply init_cell_max_ts. }
        { iApply "PENDING". }
      }
      { iPureIntro. esplits; eauto.
        { eapply View.antisym.
          { eapply View.bot_spec. }
          { ss. eapply View.join_spec.
            { reflexivity. }
            { rewrite init_cell_max_ts.
              econs; ss; eapply TimeMap.singleton_spec; eapply Time.bot_spec.
            }
          }
        }
        { i. rewrite init_cell_max_ts in H. inv H. }
      }
    }
    { iPureIntro. i. apply init_cell_get_if in GET. des. clarify.
      rewrite init_cell_max_ts in LT. inv LT.
    }
  Qed.

  Lemma wpoints_to_full_not_shot
        l V k P Q
    :
    (wpoints_to_full l V k P Q) ∗ (ObligationRA.shot k) -∗ ⌜False⌝.
  Proof.
    iIntros "[[% [? [% [% [[[[? PENDING] ?] ?] H]]]]] SHOT]".
    iApply (ObligationRA.pending_not_shot with "PENDING SHOT").
  Qed.

  Lemma wpoints_to_full_impl
        l V k P P' Q
    :
    ((⌜wimpl P P'⌝) ∗ (wpoints_to_full l V k P Q))
      -∗ (wpoints_to_full l V k P' Q).
  Proof.
    iIntros "[% [% [A [% [% [B %]]]]]]".
    iExists _. iSplitL "A"; [iFrame|]. iExists _, _. iFrame.
    iIntros (? ? ? ? ? ?). iPureIntro.
    hexploit H0; eauto. i. des. split; auto.
  Qed.

  Lemma wmemory_ra_get_strong
        m l c
    :
    (wmemory_black_strong m)
      -∗
      (points_to l c)
      -∗
      ⌜m.(WMem.memory) l = c⌝.
  Proof.
    iIntros "[BLACK _] WHITE". iApply (wmemory_ra_get with "BLACK WHITE").
  Qed.

  Lemma wmemory_ra_load_acq
        l V k (P Q: wProp)
        m val vw0 vw1
        ord lc1 to released
        (READ: Local.read_step (WMem.view_to_local vw0) m.(WMem.memory) l to val released ord lc1)
        (VIEW: vw1 = lc1.(Local.tview).(TView.cur))
        (ORD: ord = Ordering.acqrel)
    :
    (wmemory_black_strong m)
      -∗
      (wpoints_to_full l V k P Q)
      -∗
      ((⌜View.le vw0 vw1⌝)
         ∗ (wmemory_black_strong m)
         ∗ (wpoints_to_full l V k P Q)
         ∗ (((lift_wProp P val vw1)
               ∗ (∃ ts, (ObligationRA.correl (inr (inr (l, ts))) k (Ord.S Ord.O))
                          ∗ (⌜WMem.missed m.(WMem.memory) l to (l, ts) = Flag.fail⌝)))
            ∨ ((lift_wProp Q val vw1) ∗ (⌜View.le V vw1⌝)))
      ).
  Proof.
    iIntros "BLACK [% [WHITE [% [% [[[[X Y] %] %] %]]]]]". des. subst.
    iPoseProof (wmemory_ra_get_strong with "BLACK WHITE") as "%". subst.
    inv READ. ss. iSplit.
    { iPureIntro. aggrtac. }
    iAssert (⌜Cell.max_ts (WMem.memory m l) = Time.bot⌝
             ∨ (ObligationRA.correl _ _ _))%I with "[X]" as "#CORREL".
    { iPoseProof "X" as "[X|X]"; [auto|].
      iRight. iApply (ObligationRA.duty_correl with "X"). ss. eauto.
    }
    iSplitL "BLACK"; [auto|]. iSplitL.
    { iExists _. iFrame. iExists _, _. iSplit.
      { iSplit.
        { auto. }
        { iPureIntro. esplits; eauto. }
      }
      { iPureIntro. auto. }
    }
    destruct (Time.eq_dec to (Cell.max_ts (WMem.memory m l))).
    { iRight. subst. setoid_rewrite GET0 in GET. inv GET.
      assert (val = v).
      { inv VAL; ss.
        destruct v, val; ss. apply Z.eqb_eq in H2. subst. auto.
      }
      subst. iSplit.
      { unfold lift_wProp. iExists _. iSplit.
        { iPureIntro. eauto. }
        { iPureIntro. apply View.bot_spec. }
      }
      { iPureIntro. unfold View.singleton_ur_if. des_ifs.
        eapply View.join_spec.
        { aggrtac. }
        { etrans; [|eapply View.join_l]. eapply View.join_r. }
      }
    }
    { iLeft. hexploit Memory.max_ts_spec.
      { eapply GET0. }
      i. des. dup MAX. inv MAX; ss.
      hexploit H1; eauto. i. des.
      assert (val' = val).
      { inv VAL; ss. destruct val, val'; ss. apply Z.eqb_eq in H4. subst. auto. }
      subst. iSplitR.
      { unfold lift_wProp. iExists _. iSplit.
        { iPureIntro. eapply H1; eauto. }
        { iPureIntro. apply View.bot_spec. }
      }
      iExists _. iSplitR.
      { iPoseProof "CORREL" as "[%BOT|CORR]"; [|auto].
        setoid_rewrite BOT in H0. inv H0.
      }
      iPureIntro.
      destruct (LocSet.Facts.eq_dec l l); ss.
      destruct (Time.le_lt_dec (Cell.max_ts (WMem.memory m l)) to).
      { exfalso. eapply Time.lt_strorder.
        eapply TimeFacts.lt_le_lt; [|apply l0]; eauto.
      }
      setoid_rewrite GET. hexploit RELEASED; auto.
      { eapply TimeFacts.le_lt_lt; eauto. eapply Time.bot_spec. }
      { i. des_ifs. }
    }
  Qed.

  Lemma wmemory_ra_load_rlx
        l V k (P Q: wProp)
        m val vw0 vw1
        ord lc1 to released
        (READ: Local.read_step (WMem.view_to_local vw0) m.(WMem.memory) l to val released ord lc1)
        (VIEW: vw1 = lc1.(Local.tview).(TView.cur))
        (ORD: ord = Ordering.relaxed)
    :
    (wmemory_black_strong m)
      -∗
      (wpoints_to_full l V k P Q)
      -∗
      (⌜View.le V vw0⌝)
      -∗
      ((⌜View.le vw0 vw1⌝)
         ∗ (wmemory_black_strong m)
         ∗ (wpoints_to_full l V k P Q)
         ∗ (lift_wProp Q val vw1)
      ).
  Proof.
    iIntros "BLACK [% [WHITE [% [% [[[X %] %] Z]]]]] %". des. subst.
    iPoseProof (wmemory_ra_get_strong with "BLACK WHITE") as "%". subst.
    inv READ. ss.
    assert (TO: to = Cell.max_ts (WMem.memory m l)).
    { eapply TimeFacts.antisym.
      { eapply Memory.max_ts_spec in GET0. des. clarify. }
      { inv READABLE. etrans; eauto.
        inv H1. ss. specialize (PLN0 l).
        unfold TimeMap.singleton in PLN0. etrans; [|eauto].
        unfold TimeMap.join. setoid_rewrite LocFun.add_spec_eq.
        apply Time.join_r.
      }
    }
    subst. setoid_rewrite GET0 in GET. inv GET.
    assert (val = v).
    { inv VAL; ss.
      destruct v, val; ss. apply Z.eqb_eq in H2. subst. auto.
    }
    subst. iSplit.
    { iPureIntro. aggrtac. }
    iSplitL "BLACK"; [auto|]. iSplitL.
    { iExists _. iFrame. iExists _, _. iSplit; eauto. iPureIntro. esplits; eauto. }
    { unfold lift_wProp. iExists _. iPureIntro. splits; eauto. eapply View.bot_spec. }
  Qed.

  Lemma wmemory_ra_store_rel
        l V k (P Q R: wProp)
        m0 vw0 m1 val vw1
        lc1 to sc1 mem1 ord from released kind
        (WRITE: Local.write_step (WMem.view_to_local vw0) m0.(WMem.sc) m0.(WMem.memory) l from to val None released ord lc1 sc1 mem1 kind)
        (VIEW: vw1 = lc1.(Local.tview).(TView.cur))
        (MEM: m1 = WMem.mk mem1 sc1)
        (ORD: ord = Ordering.acqrel)
        (DEFINED: val <> Const.undef)
    :
    (wmemory_black_strong m0)
      -∗
      (wpoints_to_full l V k P Q)
      -∗
      (⌜View.le V vw0⌝)
      -∗
      (⌜R val View.bot⌝)
      -∗
      ((⌜View.le vw0 vw1⌝)
         ∗ #=( ObligationRA.arrows_sat (Id:=sum_tid (void + WMem.ident)%type) )=> ((wmemory_black_strong m1))
         ∗ (∃ V' k' o,
               (⌜View.le V' vw1⌝)
                 ∗
                 (⌜View.le vw0 V'⌝)
                 ∗
                 #=>((wpoints_to_full l V' k' (wor P Q) R)
                       ∗ (ObligationRA.black k' o)
                    )
           )
      ).
  Proof.
    iIntros "BLACK [% [WHITE [% [% [[[[_ Y] %] %] %]]]]] % %". des. subst.
    iPoseProof (wmemory_ra_get_strong with "BLACK WHITE") as "%". subst.
    inv WRITE. ss. iSplit.
    { iPureIntro. aggrtac. }
    hexploit memory_write_bot_add; eauto. i. subst.
    inv WRITE0. inv PROMISE. clear REMOVE PROMISES ATTACH TS.
    iPoseProof (wmemory_ra_write_strong with "BLACK WHITE") as "> [[BLACK WHITE] FAIRBLACK]".
    { eauto. }
    assert (TS: Time.lt (Cell.max_ts (WMem.memory m0 l)) to).
    { inv WRITABLE. eapply TimeFacts.le_lt_lt; [|eauto].
      inv H2. ss. etrans; [|eapply RLX].
      unfold TimeMap.join, TimeMap.singleton. setoid_rewrite LocFun.add_spec_eq.
      eapply Time.join_r.
    }
    hexploit memory_write_max_ts.
    { eauto. }
    { left. auto. }
    i. subst.
    iPoseProof (ObligationRA.alloc) as "> [% [[B W] PENDING]]".
    iPoseProof (ObligationRA.duty_alloc with "[FAIRBLACK] W") as "> DUTY".
    { unfold ObligationRA.duty. iExists [], _.  iSplit.
      { iFrame. iApply ObligationRA.duty_list_nil. }
      { ss. }
    }
    iModIntro. iSplitL "BLACK"; [auto|].
    iExists _, _, _. iSplit; cycle 1.
    { iSplitR; cycle 1.
      { iModIntro. iSplitR "B"; [|eauto].
        iExists _. iSplitL "WHITE"; [auto|].
        iExists _, _. iSplitL.
        { iSplitL.
          { iSplitL; [|eauto]. iSplitL "DUTY". eauto. iFrame. }
          { iPureIntro. splits; eauto. esplits.
            { eapply Memory.add_get0. eauto. }
            { auto. }
            { i. ss. }
          }
        }
        { iPureIntro. i. setoid_rewrite Memory.add_o in GET0; eauto. des_ifs.
          { ss. des; clarify. exfalso. eapply Time.lt_strorder. eapply LT. }
          { des; ss. hexploit Memory.max_ts_spec; eauto. i. des. inv MAX.
            { hexploit H1; eauto. i. des; ss. splits; auto. rr. auto. }
            { inv H0. clarify. setoid_rewrite GET1 in GET. clarify.
              splits; auto. rr. auto.
            }
          }
        }
      }
      { iPureIntro. unfold TView.write_released. des_ifs. ss. des_ifs.
        setoid_rewrite LocFun.add_spec_eq. aggrtac.
      }
    }
    { iPureIntro. unfold TView.write_released. des_ifs. ss. des_ifs.
      setoid_rewrite LocFun.add_spec_eq. eapply View.join_spec.
      { eapply View.join_spec.
        { eapply View.bot_spec. }
        { reflexivity. }
      }
      { eapply View.join_r. }
    }
  Qed.

End MEMRA.

Global Opaque wmemory_black wpoints_to wpoints_to_faa wpoints_to_full.


(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Constant propagation over RTL.  This is one of the optimizations
  performed at RTL level.  It proceeds by a standard dataflow analysis
  and the corresponding code rewriting. *)

Require Import Coqlib Maps Integers Floats Lattice Kildall.
Require Import AST Linking.
Require Compopts Machregs.
Require Import Op Registers RTL.
Require Import Liveness ValueDomain ValueAOp ValueAnalysis.
Require Import ConstpropOp.

(** The code transformation builds on the results of the static analysis
  of values from module [ValueAnalysis].  It proceeds instruction by
  instruction.
- Operators whose arguments are all statically known are turned into
  ``load integer constant'', ``load float constant'' or ``load
  symbol address'' operations.  Likewise for loads whose result can
  be statically predicted.
- Operators for which some but not all arguments are known are subject
  to strength reduction (replacement by cheaper operators) and
  similarly for the addressing modes of load and store instructions.
- Cast operators that have no effect (because their arguments are
  already normalized to the destination type) are removed.
- Conditional branches and multi-way branches are statically resolved
  into [Inop] instructions when possible.
- Other instructions are unchanged.

  In addition, we try to jump over conditionals whose condition can
  be statically resolved based on the abstract state "after" the
  instruction that branches to the conditional.  A typical example is:
<<
          1: x := 0 and goto 2
          2: if (x == 0) goto 3 else goto 4
>>
    where other instructions branch into 2 with different abstract values
    for [x].  We transform this code into:
<<
          1: x := 0 and goto 3
          2: if (x == 0) goto 3 else goto 4
>>
*)

Definition transf_ros (ae: AE.t) (ros: reg + ident) : reg + ident :=
  match ros with
  | inl r =>
      match areg ae r with
      | Ptr(Gl symb ofs) => if Ptrofs.eq ofs Ptrofs.zero then inr _ symb else ros
      | _ => ros
      end
  | inr s => ros
  end.

Fixpoint successor_rec (n: nat) (f: function) (ae: AE.t) (pc: node) : node :=
  match n with
  | O => pc
  | S n' =>
      match f.(fn_code)!pc with
      | Some (Inop s) =>
          successor_rec n' f ae s
      | Some (Icond cond args s1 s2) =>
          match resolve_branch (eval_static_condition cond (aregs ae args)) with
          | Some b => successor_rec n' f ae (if b then s1 else s2)
          | None => pc
          end
      | _ => pc
      end
  end.

Definition num_iter := 10%nat.

Definition successor (f: function) (ae: AE.t) (pc: node) : node :=
  successor_rec num_iter f ae pc.

Fixpoint builtin_arg_reduction (ae: AE.t) (a: builtin_arg reg) :=
  match a with
  | BA r =>
      match areg ae r with
      | I n => BA_int n
      | L n => BA_long n
      | F n => if Compopts.generate_float_constants tt then BA_float n else a
      | FS n => if Compopts.generate_float_constants tt then BA_single n else a
      | _ => a
      end
  | BA_splitlong hi lo =>
      match builtin_arg_reduction ae hi, builtin_arg_reduction ae lo with
      | BA_int nhi, BA_int nlo => BA_long (Int64.ofwords nhi nlo)
      | hi', lo' => BA_splitlong hi' lo'
      end
  | BA_addptr a1 a2 =>
      BA_addptr (builtin_arg_reduction ae a1) (builtin_arg_reduction ae a2)
  | _ => a
  end.

Definition builtin_arg_strength_reduction
      (ae: AE.t) (a: builtin_arg reg) (c: builtin_arg_constraint) :=
  let a' := builtin_arg_reduction ae a in
  if builtin_arg_ok a' c then a' else a.

Fixpoint builtin_args_strength_reduction
      (ae: AE.t) (al: list (builtin_arg reg)) (cl: list builtin_arg_constraint) :=
  match al with
  | nil => nil
  | a :: al =>
      builtin_arg_strength_reduction ae a (List.hd OK_default cl)
      :: builtin_args_strength_reduction ae al (List.tl cl)
  end.

(** For debug annotations, add constant values to the original info
    instead of replacing it. *)

Fixpoint debug_strength_reduction (ae: AE.t) (al: list (builtin_arg reg)) :=
  match al with
  | nil => nil
  | a :: al =>
      let a' := builtin_arg_reduction ae a in
      let al' := a :: debug_strength_reduction ae al in
      match a, a' with
      | BA _, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => a' :: al'
      | _, _ => al'
      end
  end.

Definition builtin_strength_reduction
             (ae: AE.t) (ef: external_function) (al: list (builtin_arg reg)) :=
  match ef with
  | EF_debug _ _ _ => debug_strength_reduction ae al
  | _ => builtin_args_strength_reduction ae al (Machregs.builtin_constraints ef)
  end.

Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem)
                        (pc: node) (instr: instruction) :=
  match an!!pc with
  | VA.Bot =>
      instr
  | VA.State ae am =>
      match instr with
      | Iop op args res s =>
          let aargs := aregs ae args in
          let a := eval_static_operation op aargs in
          let s' := successor f (AE.set res a ae) s in
          match const_for_result a with
          | Some cop =>
              Iop cop nil res s'
          | None =>
              let (op', args') := op_strength_reduction op args aargs in
              Iop op' args' res s'
          end
      | Iload chunk addr args dst s =>
          let aargs := aregs ae args in
          let a := ValueDomain.loadv chunk rm am (eval_static_addressing addr aargs) in
          match const_for_result a with
          | Some cop =>
              Iop cop nil dst s
          | None =>
              let (addr', args') := addr_strength_reduction addr args aargs in
              Iload chunk addr' args' dst s
          end
      | Istore chunk addr args src s =>
          let aargs := aregs ae args in
          let (addr', args') := addr_strength_reduction addr args aargs in
          Istore chunk addr' args' src s
      | Icall sig ros args res s =>
          Icall sig (transf_ros ae ros) args res s
      | Itailcall sig ros args =>
          Itailcall sig (transf_ros ae ros) args
      | Ibuiltin ef args res s =>
          Ibuiltin ef (builtin_strength_reduction ae ef args) res s
      | Icond cond args s1 s2 =>
          let aargs := aregs ae args in
          match resolve_branch (eval_static_condition cond aargs) with
          | Some b =>
              if b then Inop s1 else Inop s2
          | None =>
              let (cond', args') := cond_strength_reduction cond args aargs in
              Icond cond' args' s1 s2
          end
      | Ijumptable arg tbl =>
          match areg ae arg with
          | I n =>
              match list_nth_z tbl (Int.unsigned n) with
              | Some s => Inop s
              | None => instr
              end
          | _ => instr
          end
      | _ =>
          instr
      end
  end.

Definition transf_function (rm: romem) (f: function) : function :=
  let an := ValueAnalysis.analyze rm f in
  mkfunction
    f.(fn_sig)
    f.(fn_params)
    f.(fn_stacksize)
    (PTree.map (transf_instr f an rm) f.(fn_code))
    f.(fn_entrypoint).

Definition transf_fundef (rm: romem) (fd: fundef) : fundef :=
  AST.transf_fundef (transf_function rm) fd.

Section WITHROMEMFOR.
Context `{romem_for_instance: ROMemFor}.

Definition transf_program (p: program) : program :=
  let rm := romem_for p in
  transform_program (transf_fundef rm) p.

End WITHROMEMFOR.