Set Warnings "-notation-overridden".
Set Warnings "-spurious-ssr-injection".

Require Import LinearScan.Lib.
Require Import LinearScan.Context.
Require Import LinearScan.UsePos.
Require Import LinearScan.Range.
Require Import LinearScan.Interval.
Require Import LinearScan.Blocks.
Require Import LinearScan.ScanState.
Require Import LinearScan.Morph.
Require Import LinearScan.Cursor.
Require Import LinearScan.Spec.
Require Import LinearScan.Spill.
Require Import LinearScan.Split.
Require Import Coq.Program.Wf.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

Section Allocate.

Variable maxReg : nat.          (* max number of registers *)
Hypothesis registers_exist : maxReg > 0.
Definition PhysReg := 'I_maxReg.

Open Scope program_scope.

Definition intersectsWithFixedInterval {pre} (reg : PhysReg) :
  SState pre (@SSMorphHasLen maxReg) (@SSMorphHasLen maxReg) (option nat) :=
  withCursor (maxReg:=maxReg) $ fun sd cur =>
    ipure $ if vnth (fixedIntervals sd) reg is Some i
            then intervalIntersectsWithSubrange (curIntDetails cur).1 i.1
            else None.

Definition updateRegisterPos (v : Vec (option nat) maxReg)
  (r : PhysReg) (p : option nat) : Vec (option nat) maxReg :=
  match p with
  | None => v
  | Some x => vreplace v r (Some (match vnth v r with
                                  | Some n => if n < x then n else x
                                  | None   => x
                                  end))
  end.

Definition findEligibleRegister (sd : ScanStateDesc maxReg)
  `(current : Interval d) xs : PhysReg * option nat :=
  (* Make sure that if there's a fixed interval that intersection with the
     current interval, that we indicate that the register is only free up
     until that point. *)
  let: (xs, fixedAndIntersects) :=
    vfoldl_with_index (fun reg acc (mint : option IntervalSig) =>
      let: (fup, fai) := acc in
      if mint is Some int
      then let op := intervalIntersectsWithSubrange current int.2 in
           (updateRegisterPos fup reg op, vreplace fai reg (isSome op))
      else acc) (xs, vconst false) (fixedIntervals sd) in
  registerWithHighestPos registers_exist fixedAndIntersects xs.

(** If [tryAllocateFreeReg] fails to allocate a register, the [ScanState] is
    left unchanged.  If it succeeds, or is forced to split [current], then a
    register will have been assigned. *)
Definition tryAllocateFreeReg {pre} :
  SState pre (@SSMorphHasLen maxReg) (@SSMorphHasLen maxReg)
    (option (SState pre (@SSMorphHasLen maxReg) (@SSMorph maxReg) PhysReg)) :=
  withCursor (maxReg:=maxReg) $ fun sd cur =>
    let current := curInterval cur in

    (* set freeUntilPos of all physical registers to maxInt
       for each interval it in active do
         freeUntilPos[it.reg] = 0
       for each interval it in inactive intersecting with current do
         freeUntilPos[it.reg] = next intersection of it with current *)
    let go f v p := let: (i, r) := p in updateRegisterPos v r (f i) in
    let actives := foldl (go (fun _ => Some 0)) (vconst None) (active sd) in
    let freeUntilPos :=
        foldl (go (fun i => intervalsIntersect current (getInterval i)))
          actives (inactive sd) in

    (* reg = register with highest freeUntilPos *)
    (* mres = highest use position of the found register *)
    let (reg, mres) := findEligibleRegister sd current freeUntilPos in

    (** [moveUnhandledToActive] not only moves an [IntervalId] from the
        [unhandled] list to the [active] list in the current [ScanStateDesc],
        it also assigns a register to the newly active interval that can be
        accessed by calling [getAssignment]. *)
    let success := moveUnhandledToActive reg ;;; ipure reg in

    let cid := curId cur in
    context (ETryAllocateFreeReg reg mres (fst cid)) $
      ipure $
        match mres with
        | None => Some success
        | Some n =>
          (* if freeUntilPos[reg] = 0 then
               // no register available without spilling
               allocation failed
             else if current ends before freeUntilPos[reg] then
               // register available for the whole interval
               current.reg = reg
             else
               // register available for the first part of the interval
               current.reg = reg
               split current before freeUntilPos[reg] *)
          if n <= intervalStart current
          then None
          else @Some _ $
            if intervalEnd current < n
            then success
            else splitCurrentInterval (BeforePos n) ;;;
                 success
        end.

(** If [allocateBlockedReg] fails, it's possible no register was assigned and
    that the only outcome was to split one or more intervals.  In either case,
    the change to the [ScanState] must be a productive one. *)
Definition allocateBlockedReg {pre} :
  SState pre (@SSMorphHasLen maxReg) (@SSMorph maxReg) (option PhysReg) :=
  withCursor (maxReg:=maxReg) $ fun sd cur =>
    let current := curInterval cur in
    let pos     := intervalStart current in

    (* set nextUsePos of all physical registers to maxInt
       for each interval it in active do
         nextUsePos[it.reg] = next use of it after start of current
       for each interval it in inactive intersecting with current do
         nextUsePos[it.reg] = next use of it after start of current *)
    let go (v : Vec (option nat) maxReg) (p : IntervalSig * PhysReg) :=
        let: (int, reg) := p in
        let atPos u := (pos == uloc u) && regReq u in
        let pos' :=
            (* In calculating the highest use position of this register, if we
               know that it is being used at the current position, then it
               cannot be spilled there, and so we try to take it out of the
               running by returning one. *)
            match findIntervalUsePos int.2 atPos with
            | Some _ => Some 0
            | None   => nextUseAfter int.2 pos
            end in
        updateRegisterPos v reg pos' in

    let resolve xs :=
        [seq (packInterval (getInterval (fst i)), snd i) | i <- xs] in
    let actives := foldl go (vconst None) (resolve (active sd)) in
    let nextUsePos'' :=
        foldl go actives (filter (fun x => intervalsIntersect current (fst x).1)
                                 (resolve (inactive sd))) in

    (* reg = register with highest nextUsePos *)
    (* mres = highest use position of the found register *)
    let (reg, mres) := findEligibleRegister sd current nextUsePos'' in

    let cid := curId cur in
    context (EAllocateBlockedReg reg mres (fst cid)) $
      if (match mres with
          | None   => false
          | Some n =>
              n < if lookupUsePos current (fun u => pos <= uloc u)
                       is Some (nextUse; _)
                  then nextUse
                  else intervalEnd current
          end)
      then
        (* if first usage of current is after nextUsePos[reg] then
             // all other intervals are used before current, so it is best
             // to spill current itself
             assign spill slot to current
             split current before its first use position that requires a
               register *)
        @spillCurrentInterval maxReg pre ;;;

        (* // make sure that current does not intersect with
           // the fixed interval for reg
           if current intersects with the fixed interval for reg then
             split current before this intersection *)

        (* The allocation failed, so we had to spill some part of the current
           interval instead. *)
        ipure None
      else
        (* // spill intervals that currently block reg
           current.reg = reg
           split active interval for reg at position
           split any inactive interval for reg at the end of its lifetime
             hole *)
        splitAnyInactiveIntervalForReg reg pos ;;;
        splitActiveIntervalForReg reg pos ;;;

        (* The remaining part of these active and inactive intervals go back
           onto the unhandled list; the former part goes onto the inact list. *)

        (* // make sure that current does not intersect with
           // the fixed interval for reg
           if current intersects with the fixed interval for reg then
             split current before this intersection *)
        mloc <<- intersectsWithFixedInterval reg ;;;
        match mloc with
        | Some n => context (EIntersectsWithFixedInterval n reg) $
                      splitCurrentInterval (BeforePos n)
        | None   => ipure tt
        end ;;;

        moveUnhandledToActive reg ;;;
        ipure $ Some reg.

Definition morphlen_transport {b b'} :
  @SSMorphLen maxReg b b' -> IntervalId b -> IntervalId b'.
Proof.
  case. case=> ? ?.
  exact: (widen_ord _).
Defined.

Definition mt_fst b b' (sslen : SSMorphLen b b')
  (x : IntervalId b * PhysReg) :=
  let: (xid, reg) := x in (morphlen_transport sslen xid, reg).

Notation int_reg sd := (@IntervalId maxReg sd * PhysReg)%type.
Definition int_reg_seq sd := seq (int_reg sd).

Definition intermediate_result (sd z : ScanStateDesc maxReg)
  (xs : int_reg_seq z)
  (f : forall sd' : ScanStateDesc maxReg, int_reg_seq sd') :=
  { res : {z' : ScanStateDesc maxReg | SSMorphLen z z'}
  | (ScanState InUse res.1 /\ SSMorphLen sd res.1)
  & subseq [seq mt_fst res.2 i | i <- xs] (f res.1) }.

Program Definition goActive (pos : nat) (sd : ScanStateDesc maxReg)
  (e : seq SSTrace) (z : ScanStateDesc maxReg)
  (Pz : ScanState InUse z /\ SSMorphLen sd z)
  (x : int_reg z) (xs : int_reg_seq z)
  (Hsub : subseq (x :: xs) (active z)) :
  seq SSTrace + intermediate_result sd xs (@active maxReg) :=
  (* for each interval it in active do
       if it ends before position then
         move it from active to handled
       else if it does not cover position then
         move it from active to inactive *)
  let: conj st sslen := Pz in
  let i := getInterval (fst x) in
  let Hin : x \in active z := @in_subseq_sing _ _ _ x xs _ Hsub in
  let eres :=
    if intervalEnd i < pos
    then
      if prop (verifyNewHandled z i (snd x)) isn't Some Hreq
      then let: (p1, p2) := x in
           inl (ERegisterAssignmentsOverlap p2 p1 1 :: e)
      else let: exist2 x H1 H2 :=
             moveActiveToHandled st Hin Hreq (spilled:=false) in
           inr (exist2 _ _ x H1 (proj1 H2))
    else inr $ if ~~ posWithinInterval i pos
               then moveActiveToInactive st Hin
               else exist2 _ _ z st (newSSMorphLen z) in
  match eres with
  | inl err => inl err
  | inr (exist2 sd' st' sslen') =>
      inr (exist2 _ _ (sd'; sslen')
                  (conj st' (transitivity sslen sslen')) _)
  end.
Next Obligation.
  move: Heq_eres.

  case: (iend (vnth (intervals z) i).1 < pos);
  case: (prop (verifyNewHandled z (vnth (intervals z) i).1 p)) => a;
  try discriminate.

  - rewrite /moveActiveToHandled /=.
    invert as [H1]; subst; simpl.
    rewrite /mt_fst /morphlen_transport /=.
    case: sslen'.
    case=> [[?] _].
    rewrite map_widen_ord_refl.
    exact: subseq_cons_rem.

  - case: (~~ (ibeg (vnth (intervals z) i).1
             <= pos < iend (vnth (intervals z) i).1)).
      rewrite /moveActiveToInactive /=.
      invert as [H1]; subst; simpl.
      rewrite /mt_fst /morphlen_transport /=.
      case: sslen'.
      case=> [[?] _].
      rewrite map_widen_ord_refl.
      exact: subseq_cons_rem.

    invert as [H1]; subst; simpl.
    rewrite /mt_fst /morphlen_transport /=.
    case: sslen'.
    case=> [[?] _].
    rewrite map_widen_ord_refl.
    apply: subseq_impl_cons.
    exact Hsub.

  - case: (~~ (ibeg (vnth (intervals z) i).1
             <= pos < iend (vnth (intervals z) i).1)) in a *.
      inv a.
      rewrite /mt_fst /morphlen_transport /=.
      case: sslen'.
      case=> [[?] _].
      rewrite map_widen_ord_refl.
      exact: subseq_cons_rem.
    inv a.
    rewrite /mt_fst /morphlen_transport /=.
    case: sslen'.
    case=> [[?] _].
    rewrite map_widen_ord_refl.
    apply: subseq_impl_cons.
    exact Hsub.
Qed.

(* This rather excessively complicated, dependent fold function is needed in
   order to walk through a list of intervals of a [ScanState] (which have a
   type dependent on that [ScanState]), while at the same time mutating the
   same [ScanState] and adjusting the type of the remainder of the interval
   list, such that it is known to still have a relationship with the new
   [ScanState]. *)
Program Fixpoint dep_foldl_invE
  {errType : Type}              (* the short-circuiting error type *)
  {A : Type}                    (* the value being mutated through the fold *)
  {P : A -> Prop}               (* inductive predicate to be maintained on A *)
  {R : A -> A -> Prop}          (* a relation on A that must be preserved *)
  {E : A -> eqType}             (* type of the elements we are folding over *)
  (b : A)                       (* the initial state value *)
  (Pb : P b)                    (* predicate on the initial state value *)
  (v : seq (E b))               (* list of elements from the initial state *)

  (n : nat)                     (* the length of this list (as a [nat]) *)
  (* The reason to [nat] rather than [size v] is that the type of v changes
     with each iteration of the fold, which confuses [Program Fixpoint] enough
     that it fails to compute the final proof term even after ten minutes. *)

  (Hn : n == size v)            (* witness that [length == size v] *)
  (Q : forall x : A, seq (E x)) (* function that can determine [v] from [b] *)
  (Hsub : subseq v (Q b))       (* a proof that [v] is a subseq of [Q b] *)

  (F : forall (b b' : A) (Rbb' : R b b'), E b -> E b')
                                (* transports element types between states *)

  (* The fold function [f] takes an intermediate state, a witness for the
     inductive predicate on that state, an element from the initial list which
     is known to be related to that state (and whose type has been transported
     to relate to that state), the list of remaining elements to be processed
     by the fold, and proof that this element and remaining list are at least
     a subsequence of the state.
         The expected result is a new state, proof that this new state relates
     to the incoming state in terms of [R] (which must be transitive), proof
     that the inductive predicate holds for this new state, and proof that the
     transported remainder [xs] is also a subsequence of the list determined
     by [Q] from the new state. *)
  (f : forall (z : A) (Pz : P z) (x : E z) (xs : seq (E z)),
         subseq (x :: xs) (Q z)
           -> errType +
              { res : { z' : A | R z z' }
              | P res.1 & subseq (map (F z res.1 res.2) xs) (Q res.1) })

  (* The fold is done when [n] reaches zero *)
  {struct n} :
  (* The result is a final, inductively predicated state *)
  errType + { b' : A | P b' } :=
  match (v, n) with
  | (y :: ys, S n') =>
      match f b Pb y ys Hsub with
      | inl err => inl err
      | inr (exist2 (exist b' Rbb') Pb' Hsub') =>
          let ys' := map (F b b' Rbb') ys in
          @dep_foldl_invE errType A P R E b' Pb' ys' n' _ Q Hsub' F f
      end
  | _ => inr (exist P b Pb)
  end.
Obligation 2.
  first [ inversion Heq_anonymous;
          subst;
          clear Heq_anonymous0;
          move: eqSS Hn => /= -> /eqP ->;
          by rewrite size_map
        | inversion Heq_anonymous0;
          subst;
          clear Heq_anonymous;
          move: eqSS Hn => /= -> /eqP ->;
          by rewrite size_map ].
Qed.

Definition checkActiveIntervals {pre} (pos : nat) :
  SState pre (@SSMorphLen maxReg) (@SSMorphLen maxReg) unit :=
  withScanStatePO (maxReg:=maxReg) $ fun sd (st : ScanState InUse sd) =>
    e <<- Context.iask ;;;
    let unchanged := exist2 _ _ sd st (newSSMorphLen sd) in
    let eres : seq SSTrace + { sd' : ScanStateDesc maxReg
                             | ScanState InUse sd' /\ SSMorphLen sd sd' } :=
        @dep_foldl_invE (seq SSTrace) (ScanStateDesc maxReg)
          (fun sd' => ScanState InUse sd' /\ SSMorphLen sd sd')
          (@SSMorphLen maxReg) _ sd (conj st (newSSMorphLen sd))
          (active sd) (size (active sd)) (eq_refl _)
          (@active maxReg) (subseq_refl _) mt_fst (@goActive pos sd e) in
    match eres with
    | inl err => error_ err
    | inr (exist sd' (conj st' H)) =>
        Context.iput {| thisDesc  := sd'
                      ; thisHolds := H
                      ; thisState := st' |}
    end.

Program Definition moveInactiveToActive' `(st : ScanState InUse z)
  (x : int_reg z) (xs : int_reg_seq z)
  (Hsub : subseq (x :: xs) (inactive z))
  (Hin : x \in inactive z) (e : seq SSTrace) :
  seq SSTrace +
  { sd' : ScanStateDesc maxReg | ScanState InUse sd'
  & { sslen : SSMorphLen z sd'
    | subseq [seq mt_fst sslen i | i <- xs] (inactive sd')
    }
  } :=
  match snd x \notin [seq snd i | i <- active z] with
  | true  =>
      match moveInactiveToActive st Hin _ with
      | exist2 sd' st' sslen' =>
          inr (exist2 _ _ sd' st' (sslen'; _))
      end
  | false =>
      let: (p1, p2) := x in
      inl (ERegisterAssignmentsOverlap p2 p1 2 :: e)
  end.
Next Obligation.
  rewrite /moveActiveToInactive /mt_fst /morphlen_transport /=.
  case: sslen'; case=> [[?] _].
  rewrite map_widen_ord_refl.
  exact: subseq_cons_rem.
Defined.

Program Definition goInactive (pos : nat) (sd : ScanStateDesc maxReg)
  (e : seq SSTrace) (z : ScanStateDesc maxReg)
  (Pz : ScanState InUse z /\ SSMorphLen sd z)
  (x : int_reg z) (xs : int_reg_seq z)
  (Hsub : subseq (x :: xs) (inactive z)) :
  seq SSTrace + intermediate_result sd xs (@inactive maxReg) :=
  (* for each interval it in inactive do
       if it ends before position then
         move it from inactive to handled
       else if it covers position then
         move it from inactive to active *)
  let: conj st sslen := Pz in
  match getInterval (fst x)
  return seq SSTrace + intermediate_result sd xs (@inactive maxReg) with
  | i =>
    let Hin : x \in inactive z := @in_subseq_sing _ _ _ x xs _ Hsub in
    let f (sd'    : ScanStateDesc maxReg)
          (st'    : ScanState InUse sd')
          (sslen' : SSMorphLen z sd')
          (Hsub'  : subseq [seq mt_fst sslen' i | i <- xs]
                           (inactive sd')) :=
        inr (exist2 _ _ (sd'; sslen')
                    (conj st' (transitivity sslen sslen')) Hsub') in
    if intervalEnd i < pos
    then
      if prop (verifyNewHandled z i (snd x)) isn't Some Hreq
      then let: (p1, p2) := x in
           inl (ERegisterAssignmentsOverlap p2 p1 3 :: e)
      else
        match moveInactiveToHandled st Hin Hreq (spilled:=false) with
        | exist2 sd' st' (conj sslen' _) =>
            f sd' st' sslen' _
        end
    else
      if posWithinInterval i pos
      then match moveInactiveToActive' st Hsub Hin e with
           | inl err => inl err
           | inr (exist2 sd' st' (exist sslen' Hsub')) =>
               f sd' st' sslen' Hsub'
           end
      else f z st (newSSMorphLen z) _
  end.
Next Obligation.
  rewrite /mt_fst /morphlen_transport /=.
  case: sslen'.
  case=> [[?] _].
  rewrite map_widen_ord_refl.
  exact: subseq_cons_rem.
Defined.
Next Obligation.
  rewrite /mt_fst /morphlen_transport /=.
  rewrite map_widen_ord_refl.
  apply: subseq_impl_cons.
  exact Hsub.
Defined.

Definition checkInactiveIntervals {pre} (pos : nat) :
  SState pre (@SSMorphLen maxReg) (@SSMorphLen maxReg) unit :=
  withScanStatePO (maxReg:=maxReg) $ fun sd (st : ScanState InUse sd) =>
    e <<- Context.iask ;;;
    let unchanged := exist2 _ _ sd st (newSSMorphLen sd) in
    let eres : seq SSTrace + { sd' : ScanStateDesc maxReg
                             | ScanState InUse sd' /\ SSMorphLen sd sd'} :=
        @dep_foldl_invE (seq SSTrace) (ScanStateDesc maxReg)
          (fun sd' => ScanState InUse sd' /\ SSMorphLen sd sd')
          (@SSMorphLen maxReg) _ sd (conj st (newSSMorphLen sd))
          (inactive sd) (size (inactive sd)) (eq_refl _)
          (@inactive maxReg) (subseq_refl _) mt_fst (@goInactive pos sd e) in
    match eres with
    | inl err => error_ err
    | inr (exist sd' (conj st' H)) =>
        Context.iput {| thisDesc  := sd'
                      ; thisHolds := H
                      ; thisState := st' |}
    end.

Definition handleInterval {pre} :
  SState pre (@SSMorphHasLen maxReg) (@SSMorph maxReg) (option PhysReg) :=
  (* position = start position of current *)
  withCursor (maxReg:=maxReg) $ fun _ cur =>
    let current := curInterval cur in
    let pos     := intervalStart current in
    let cid     := curId cur in

    (* Remove any empty intervals from the unhandled list *)
    if firstUsePos current is None
    then @moveUnhandledToHandled maxReg pre ;;; ipure None
    else
      (* // check for intervals in active that are handled or inactive *)
      liftLen (fun sd => @checkActiveIntervals sd pos) ;;;
      (* // check for intervals in inactive that are handled or active *)
      liftLen (fun sd => @checkInactiveIntervals sd pos) ;;;

      (* // find a register for current
         tryAllocateFreeReg
         if allocation failed then
           allocateBlockedReg
         if current has a register assigned then
           add current to active (done by the helper functions) *)
      mres <<- tryAllocateFreeReg ;;;
      match mres with
      | Some x => imap (@Some _) x
      | None   => allocateBlockedReg
      end.

Program Definition finalizeScanState
  `(st : ScanState InUse sd) (finalPos : nat) :
  seq SSTrace +
  { sd' : ScanStateDesc maxReg
  | [&& size (unhandled sd') == 0
    ,   size (active sd') == 0
    &   size (inactive sd') == 0 ] } :=
  match (checkActiveIntervals   finalPos ;;;
         checkInactiveIntervals finalPos) [::]
          {| thisDesc  := sd
           ; thisHolds := newSSMorphLen sd
           ; thisState := st |} with
  | inl errs => inl errs
  | inr (tt, ss) => _
  end.
Next Obligation.
  destruct ss.
  case H1: (size (unhandled thisDesc) == 0).
    case H2: (size (active thisDesc) == 0).
      case H3: (size (inactive thisDesc) == 0).
        apply: inr _.
        exists thisDesc.
        apply/andP; split => //.
        apply/andP; split => //.
      exact: inl [:: EInactiveIntervalsRemain].
    exact: inl [:: EActiveIntervalsRemain].
  exact: inl [:: EUnhandledIntervalsRemain].
Qed.

(* Walk through all the intervals which had been defined previously as the
   [unhandled] list, and use those to determine register allocations.  The
   final result will be a [ScanState] whose [handled] list represents the
   final allocations for each interval. *)
Fixpoint walkIntervals `(st : ScanState InUse sd) (positions : nat) :
  (seq SSTrace * ScanStateSig maxReg InUse) + ScanStateSig maxReg InUse :=
  (* while unhandled /= { } do
       current = pick and remove first interval from unhandled
       HANDLE_INTERVAL (current) *)
  if positions isn't S n
  then inl ([:: EFuelExhausted], packScanState st)
  else let fix go count ss :=
    if count is S cnt
    then
      match handleInterval [::] ss with
      | inl err => inl (err, packScanState (thisState ss))
      | inr (_, ss') =>
        (* A [ScanState InUse] may not insert new unhandled intervals at the
           same position as [curPos], and so even though [unhandled sd] may
           have been changed by the call to [handleInterval], it will not
           have changed it with respect to subsequent intervals at the same
           position. *)
        match strengthenHasLen (thisHolds ss') with
        | None => inr ss'
        | Some holds' =>
            go cnt {| thisDesc  := thisDesc ss'
                    ; thisHolds := holds'
                    ; thisState := thisState ss' |}
        end
      end
    else inr {| thisDesc  := thisDesc ss
              ; thisHolds := weakenHasLen (thisHolds ss)
              ; thisState := thisState ss |} in

    match List.destruct_list (unhandled sd) with
    | inright _ => inr (packScanState st)
    | inleft (existT (_, pos) (_; H)) =>
        match go (count (fun x => snd x == pos) (unhandled sd))
                 {| thisDesc  := sd
                  ; thisHolds := newSSMorphHasLen (list_cons_nonzero H)
                  ; thisState := st |} with
        | inl err => inl err
        | inr ss  => walkIntervals (thisState ss) n
        end
    end.

Record Allocation := {
  intId  : nat;                 (* the interval ident *)
  intVal : IntervalDesc;        (* the interval description data *)
  intReg : option PhysReg       (* None if it was spilled to the stack *)
}.

Definition determineAllocations (sd : @ScanStateDesc maxReg) : seq Allocation :=
  [seq {| intId  := nat_of_ord (fst x)
        ; intVal := getIntervalDesc (getInterval (fst x))
        ; intReg := snd x |} | x <- handled sd].

End Allocate.


Require Import Bool.
Require Import List.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Thread.

Require Import SimMemory.
Require Import MemorySplit.
Require Import MemoryMerge.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Inductive fulfill_step (lc1:Local.t) (sc1:TimeMap.t) (loc:Loc.t) (from to:Time.t) (val:Const.t) (releasedm released:option View.t) (ord:Ordering.t): forall (lc2:Local.t) (sc2:TimeMap.t), Prop :=
| step_fulfill
    promises2
    (REL_LE: View.opt_le (TView.write_released lc1.(Local.tview) sc1 loc to releasedm ord) released)
    (REL_WF: View.opt_wf released)
    (WRITABLE: TView.writable lc1.(Local.tview).(TView.cur) sc1 loc to ord)
    (REMOVE: Memory.remove lc1.(Local.promises) loc from to val released promises2)
    (TIME: Time.lt from to):
    fulfill_step lc1 sc1 loc from to val releasedm released ord
                 (Local.mk (TView.write_tview lc1.(Local.tview) sc1 loc to ord) promises2)
                 sc1
.

Lemma fulfill_step_future lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2
      (STEP: fulfill_step lc1 sc1 loc from to val releasedm released ord lc2 sc2)
      (REL: Memory.closed_opt_view releasedm mem1)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (CLOSED1: Memory.closed mem1):
  <<WF2: Local.wf lc2 mem1>> /\
  <<SC2: Memory.closed_timemap sc2 mem1>> /\
  <<SC_FUTURE: TimeMap.le sc1 sc2>>.
Proof.
  inv STEP.
  hexploit Memory.remove_future; try apply REMOVE; try apply WF1; eauto. i. des.
  exploit Memory.remove_get0; eauto. i.
  inversion WF1. exploit PROMISES; eauto. i.
  exploit TViewFacts.write_future_fulfill; try apply x; try apply SC1; try apply WF1; eauto.
  { eapply CLOSED1. eauto. }
  i. des.
  esplits; eauto.
  - econs; eauto.
  - refl.
Qed.

Lemma write_promise_fulfill
      lc0 sc0 mem0 loc from to val releasedm released ord lc2 sc2 mem2 kind
      (WRITE: Local.write_step lc0 sc0 mem0 loc from to val releasedm released ord lc2 sc2 mem2 kind)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0):
  exists lc1,
    <<STEP1: Local.promise_step lc0 mem0 loc from to val released lc1 mem2 kind>> /\
    <<STEP2: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2>> /\
    <<REL: released = TView.write_released lc0.(Local.tview) sc0 loc to releasedm ord>> /\
    <<ORD: Ordering.le Ordering.strong_relaxed ord ->
           Memory.nonsynch_loc loc lc0.(Local.promises) /\
           kind = Memory.op_kind_add>>.
Proof.
  exploit Local.write_step_future; eauto. i. des.
  inv WRITE. inv WRITE0. esplits; eauto.
  - econs; eauto.
  - refine (step_fulfill _ _ _ _ _ _ _); auto.
    + refl.
    + eapply MemoryFacts.promise_time_lt. eauto.
Qed.

Lemma fulfill_write
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2
      (FULFILL: fulfill_step lc1 sc1 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem1)
      (ORD: Ordering.le ord Ordering.relaxed)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1):
  exists released' mem2',
    <<STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released' ord lc2 sc2 mem2' (Memory.op_kind_lower released)>> /\
    <<REL_LE: View.opt_le released' released>> /\
    <<MEM: sim_memory mem2' mem1>>.
Proof.
  inv FULFILL.
  exploit TViewFacts.write_future_fulfill;
    try exact REL_CLOSED; try exact SC1; eauto; try by apply WF1.
  { apply WF1. eapply Memory.remove_get0. eauto. }
  i. des.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF1; try refl.
  { eapply MEM1. apply WF1. eapply Memory.remove_get0. eauto. }
  i. des.
  esplits; eauto.
  - econs; eauto.
    + econs; eauto.
    + i. destruct ord; inv ORD; inv H.
  - eapply promise_lower_sim_memory. eauto.
Qed.

Lemma promise_fulfill_write
      lc0 sc0 mem0 loc from to val releasedm released ord lc1 lc2 sc2 mem2 kind
      (PROMISE: Local.promise_step lc0 mem0 loc from to val released lc1 mem2 kind)
      (FULFILL: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (ORD: Ordering.le Ordering.strong_relaxed ord ->
            Memory.nonsynch_loc loc lc0.(Local.promises) /\
            kind = Memory.op_kind_add)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0):
  exists released' mem2',
    <<STEP: Local.write_step lc0 sc0 mem0 loc from to val releasedm released' ord lc2 sc2 mem2' kind>> /\
    <<REL_LE: View.opt_le released' released>> /\
    <<MEM: sim_memory mem2' mem2>> /\
    <<REL: released' = TView.write_released lc0.(Local.tview) sc0 loc to releasedm ord>>.
Proof.
  exploit Local.promise_step_future; eauto. i. des.
  inv PROMISE. inv FULFILL. ss.
  exploit TViewFacts.write_future_fulfill; try exact REL_WF; eauto; try by apply WF2.
  { eapply Memory.future_closed_opt_view; eauto. }
  { apply WF2. eapply Memory.promise_get2. eauto. }
  s. i. des.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF2; try refl. i. des.
  esplits; eauto.
  - econs; eauto. econs; eauto.
    eapply MemoryMerge.promise_promise_promise; eauto.
  - eapply promise_lower_sim_memory. eauto.
Qed.

Lemma promise_fulfill_write_exact
      lc0 sc0 mem0 loc from to val releasedm released ord lc1 lc2 sc2 mem2 kind
      (PROMISE: Local.promise_step lc0 mem0 loc from to val released lc1 mem2 kind)
      (FULFILL: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (ORD: Ordering.le Ordering.strong_relaxed ord ->
            Memory.nonsynch_loc loc lc0.(Local.promises) /\
            kind = Memory.op_kind_add)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (REL: released = TView.write_released lc0.(Local.tview) sc0 loc to releasedm ord):
  Local.write_step lc0 sc0 mem0 loc from to val releasedm released ord lc2 sc2 mem2 kind.
Proof.
  exploit Local.promise_step_future; eauto. i. des.
  inv PROMISE. inv FULFILL.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF2; try refl. i. des.
  refine (Local.write_step_intro _ _ _ _ _ _); eauto.
  econs; eauto.
Qed.

Lemma fulfill_step_promises_diff
      lc1 sc1 loc1 from to val releasedm released ord lc2 sc2 loc2
      (LOC: loc1 <> loc2)
      (FULFILL: fulfill_step lc1 sc1 loc1 from to val releasedm released ord lc2 sc2):
  lc1.(Local.promises) loc2 = lc2.(Local.promises) loc2.
Proof.
  inv FULFILL. inv REMOVE. unfold LocFun.add. s.
  condtac; [congr|]. auto.
Qed.


Require Import Coqlib.
Require Import ITreelib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import HoareDef STB.
Require Import ProofMode.

Set Implicit Arguments.

Let _memRA: URA.t := (mblock ==> Z ==> (Excl.t val))%ra.
Compute (URA.car (t:=_memRA)).
Instance memRA: URA.t := Auth.t _memRA.
Compute (URA.car).

Local Arguments Z.of_nat: simpl nomatch.

Section PROOF.
  Context `{@GRA.inG memRA Σ}.

  Definition _points_to (loc: mblock * Z) (vs: list val): _memRA :=
    let (b, ofs) := loc in
    (fun _b _ofs => if (dec _b b) && ((ofs <=? _ofs) && (_ofs <? (ofs + Z.of_nat (List.length vs))))%Z
                    then (List.nth_error vs (Z.to_nat (_ofs - ofs))) else ε)
  .

  (* Opaque _points_to. *)
  Lemma unfold_points_to loc vs:
    _points_to loc vs =
    let (b, ofs) := loc in
    (fun _b _ofs => if (dec _b b) && ((ofs <=? _ofs) && (_ofs <? (ofs + Z.of_nat (List.length vs))))%Z
                    then (List.nth_error vs (Z.to_nat (_ofs - ofs))) else ε)
  .
  Proof. refl. Qed.

  Definition points_to (loc: mblock * Z) (vs: list val): memRA := Auth.white (_points_to loc vs).

  Definition var_points_to (skenv: SkEnv.t) (var: gname) (v: val): memRA :=
    match (skenv.(SkEnv.id2blk) var) with
    | Some  blk => points_to (blk, 0%Z) [v]
    | None => ε
    end.

  Lemma points_to_split
        blk ofs hd tl
    :
      (points_to (blk, ofs) (hd :: tl)) = (points_to (blk, ofs) [hd]) ⋅ (points_to (blk, (ofs + 1)%Z) tl)
  .
  Proof.
    ss. unfold points_to. unfold Auth.white. repeat (rewrite URA.unfold_add; ss).
    f_equal.
    repeat (apply func_ext; i).
    des_ifs; bsimpl; des; des_sumbool; subst; ss;
      try rewrite Z.leb_gt in *; try rewrite Z.leb_le in *; try rewrite Z.ltb_ge in *; try rewrite Z.ltb_lt in *; try lia.
    - clear_tac. subst. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      assert(x0 = ofs). { lia. } subst.
      rewrite Z.sub_diag in *. ss.
    - clear_tac. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      destruct (Z.to_nat (x0 - ofs)) eqn:T; ss.
      { exfalso. lia. }
      rewrite Z.sub_add_distr in *. rewrite Z2Nat.inj_sub in Heq1; ss. rewrite T in *. ss. rewrite Nat.sub_0_r in *. ss.
    - clear_tac. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      destruct (Z.to_nat (x0 - ofs)) eqn:T; ss.
      { exfalso. lia. }
      rewrite Z.sub_add_distr in *. rewrite Z2Nat.inj_sub in Heq1; ss. rewrite T in *. ss. rewrite Nat.sub_0_r in *. ss.
    - clear_tac. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      assert(x0 = ofs). { lia. } subst.
      rewrite Z.sub_diag in *. ss.
    - clear_tac. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      destruct (Z.to_nat (x0 - ofs)) eqn:T; ss.
      { exfalso. lia. }
      rewrite Z.sub_add_distr in *. rewrite Z2Nat.inj_sub in Heq1; ss. rewrite T in *. ss. rewrite Nat.sub_0_r in *. ss.
    - clear_tac. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      assert(x0 = ofs). { lia. } subst.
      rewrite Z.sub_diag in *. ss.
  Qed.

  Definition initial_mem_mr (csl: gname -> bool) (sk: Sk.t): _memRA :=
    fun blk ofs =>
      match List.nth_error sk blk with
      | Some (g, gd) =>
        match gd with
        | Sk.Gfun => ε
        | Sk.Gvar gv => if csl g then if (dec ofs 0%Z) then Some (Vint gv) else ε else ε
        end
      | _ => ε
      end.

(* Lemma points_tos_points_to *)
(*       loc v *)
(*   : *)
(*     (points_to loc v) = (points_tos loc [v]) *)
(* . *)
(* Proof. *)
(*   apply func_ext. i. *)
(*   apply prop_ext. *)
(*   ss. split; i; r. *)
(*   - des_ifs. ss. eapply Own_extends; et. rp; try refl. repeat f_equal. repeat (apply func_ext; i). *)
(*     des_ifs; bsimpl; des; des_sumbool; ss; clarify. *)
(*     + rewrite Z.sub_diag; ss. *)
(*     + rewrite Z.leb_refl in *; ss. *)
(*     + rewrite Z.ltb_ge in *. lia. *)
(*     + rewrite Z.ltb_lt in *. lia. *)
(*   - des_ifs. ss. eapply Own_extends; et. rp; try refl. repeat f_equal. repeat (apply func_ext; i). *)
(*     des_ifs; bsimpl; des; des_sumbool; ss; clarify. *)
(*     + rewrite Z.sub_diag; ss. *)
(*     + rewrite Z.ltb_lt in *. lia. *)
(*     + rewrite Z.leb_refl in *; ss. *)
(*     + rewrite Z.ltb_ge in *. lia. *)
(* Qed. *)

End PROOF.

Notation "loc |-> vs" := (points_to loc vs) (at level 20).

Section AUX.
  Context `{@GRA.inG memRA Σ}.

  Lemma points_to_disj
        ptr x0 x1
    :
      (OwnM (ptr |-> [x0]) -∗ OwnM (ptr |-> [x1]) -* ⌜False⌝)
  .
  Proof.
    destruct ptr as [blk ofs].
    iIntros "A B". iCombine "A B" as "A". iOwnWf "A" as WF0.
    unfold points_to in WF0. rewrite ! unfold_points_to in *. repeat (ur in WF0); ss.
    specialize (WF0 blk ofs). des_ifs; bsimpl; des; des_sumbool; zsimpl; ss; try lia.
  Qed.

  Fixpoint is_list (ll: val) (xs: list val): iProp :=
    match xs with
    | [] => (⌜ll = Vnullptr⌝: iProp)%I
    | xhd :: xtl =>
      (∃ lhd ltl, ⌜ll = Vptr lhd 0⌝ ** (OwnM ((lhd,0%Z) |-> [xhd; ltl]))
                             ** is_list ltl xtl: iProp)%I
    end
  .

  Lemma unfold_is_list: forall ll xs,
      is_list ll xs =
      match xs with
      | [] => (⌜ll = Vnullptr⌝: iProp)%I
      | xhd :: xtl =>
        (∃ lhd ltl, ⌜ll = Vptr lhd 0⌝ ** (OwnM ((lhd,0%Z) |-> [xhd; ltl]))
                               ** is_list ltl xtl: iProp)%I
      end
  .
  Proof.
    i. destruct xs; auto.
  Qed.

  Lemma unfold_is_list_cons: forall ll xhd xtl,
      is_list ll (xhd :: xtl) =
      (∃ lhd ltl, ⌜ll = Vptr lhd 0⌝ ** (OwnM ((lhd,0%Z) |-> [xhd; ltl]))
                             ** is_list ltl xtl: iProp)%I.
  Proof.
    i. eapply unfold_is_list.
  Qed.

  Lemma is_list_wf
        ll xs
    :
      (is_list ll xs) -∗ (⌜(ll = Vnullptr) \/ (match ll with | Vptr _ 0 => True | _ => False end)⌝)
  .
  Proof.
    iIntros "H0". destruct xs; ss; et.
    { iPure "H0" as H0. iPureIntro. left. et. }
    iDestruct "H0" as (lhd ltl) "[[H0 H1] H2]".
    iPure "H0" as H0. iPureIntro. right. subst. et.
  Qed.

  (* Global Opaque is_list. *)
End AUX.

Section PROOF.
  Context `{@GRA.inG memRA Σ}.

  Definition alloc_spec: fspec :=
    (mk_simple (fun sz => (
                    (ord_pure 0),
                    (fun varg => (⌜varg = [Vint (Z.of_nat sz)]↑ /\ (8 * (Z.of_nat sz) < modulus_64)%Z⌝: iProp)%I),
                    (fun vret => (∃ b, (⌜vret = (Vptr b 0)↑⌝)
                                         ** OwnM ((b, 0%Z) |-> (List.repeat Vundef sz))): iProp)%I
    ))).

  Definition free_spec: fspec :=
    (mk_simple (fun '(b, ofs) => (
                    (ord_pure 0),
                    (fun varg => (∃ v, (⌜varg = ([Vptr b ofs])↑⌝) ** OwnM ((b, ofs) |-> [v]))%I),
                    fun vret => ⌜vret = (Vint 0)↑⌝%I
    ))).

  Definition load_spec: fspec :=
    (mk_simple (fun '(b, ofs, v) => (
                    (ord_pure 0),
                    (fun varg => (⌜varg = ([Vptr b ofs])↑⌝) ** OwnM(((b, ofs) |-> [v]))),
                    (fun vret => OwnM((b, ofs) |-> [v]) ** ⌜vret = v↑⌝)
    ))).

  Definition store_spec: fspec :=
    (mk_simple
       (fun '(b, ofs, v_new) => (
            (ord_pure 0),
            (fun varg => (∃ v_old, (⌜varg = ([Vptr b ofs ; v_new])↑⌝) ** OwnM((b, ofs) |-> [v_old]))%I),
            (fun vret => OwnM((b, ofs) |-> [v_new]) ** ⌜vret = (Vint 0)↑⌝
    )))).

  Definition cmp_spec: fspec :=
    (mk_simple
       (fun '(result, resource) => (
            (ord_pure 0),
            (fun varg =>
               ((∃ b ofs v, ⌜varg = [Vptr b ofs; Vnullptr]↑⌝ ** ⌜resource = ((b, ofs) |-> [v])⌝ ** ⌜result = false⌝) ∨
                (∃ b ofs v, ⌜varg = [Vnullptr; Vptr b ofs]↑⌝ ** ⌜resource = ((b, ofs) |-> [v])⌝ ** ⌜result = false⌝) ∨
                (∃ b0 ofs0 v0 b1 ofs1 v1, ⌜varg = [Vptr b0 ofs0; Vptr b1 ofs1]↑⌝ ** ⌜resource = (((b0, ofs0) |-> [v0])) ⋅ ((b1, ofs1) |-> [v1])⌝ ** ⌜result = false⌝) ∨
                (∃ b ofs v, ⌜varg = [Vptr b ofs; Vptr b  ofs]↑⌝ ** ⌜resource = ((b, ofs) |-> [v])⌝ ** ⌜result = true⌝) ∨
                (⌜varg = [Vnullptr; Vnullptr]↑ /\ result = true⌝))
                 ** OwnM(resource)
            ),
            (fun vret => OwnM(resource) ** ⌜vret = (if result then Vint 1 else Vint 0)↑⌝)
    ))).

  Definition MemStb: list (gname * fspec).
    eapply (Seal.sealing "stb").
    apply [("alloc", alloc_spec) ; ("free", free_spec) ; ("load", load_spec) ; ("store", store_spec) ; ("cmp", cmp_spec)].
  Defined.

  Definition MemSbtb: list (gname * fspecbody) :=
    [("alloc", mk_specbody alloc_spec (fun _ => trigger (Choose _)));
    ("free",   mk_specbody free_spec (fun _ => trigger (Choose _)));
    ("load",   mk_specbody load_spec (fun _ => trigger (Choose _)));
    ("store",  mk_specbody store_spec (fun _ => trigger (Choose _)));
    ("cmp",    mk_specbody cmp_spec (fun _ => trigger (Choose _)))
    ]
  .

  Variable csl: gname -> bool.

  Definition SMemSem (sk: Sk.t): SModSem.t := {|
    SModSem.fnsems := MemSbtb;
    SModSem.mn := "Mem";
    SModSem.initial_mr := (GRA.embed (Auth.black (initial_mem_mr csl sk)));
    SModSem.initial_st := tt↑;
  |}
  .

  Definition SMem: SMod.t := {|
    SMod.get_modsem := SMemSem;
    SMod.sk := Sk.unit;
  |}
  .

  Definition Mem: Mod.t := (SMod.to_tgt (fun _ => to_stb [])) SMem.

End PROOF.
Global Hint Unfold MemStb: stb.

Global Opaque _points_to.


Require Import Coq.Strings.String.

From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype choice seq ssrnum ssrint ssralg bigop.

From deriving Require Import deriving.
From extructures Require Import ord fset fmap fperm.

From CoqUtils Require Import nominal.

From memsafe Require Import basic.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Cast.

Local Open Scope fset_scope.

Lemma eval_com_domm safe ls h ls' h' c k :
  fsubset (vars_c c) (domm ls) ->
  eval_com safe c (ls, h) k = Done (ls', h') ->
  domm ls' = domm ls.
Proof.
elim: k ls ls' h h' c => [|k IH] //= ls ls' h h'.
case=> [x e|x e|e e'|x e|e| |c1 c2|e c1 c2|e c] //=.
- rewrite fsubU1set=> /andP [Px Pe] [<- _]; rewrite domm_set.
  apply/eqP; rewrite eqEfsubset; apply/andP; split.
    by rewrite fsubU1set Px fsubsetxx.
  by rewrite fsubsetUr.
- case: eval_expr => // p sz; case: (h p)=> [v|] //=.
  rewrite fsubU1set=> /andP [Px Pe] [<- _]; rewrite domm_set.
  apply/eqP; rewrite eqEfsubset; apply/andP; split.
    by rewrite fsubU1set Px fsubsetxx.
  by rewrite fsubsetUr.
- case: eval_expr => // p sz; rewrite /updm; case: (h p)=> [v|] //=.
  by rewrite fsubUset=> /andP [Pe Pe'] [<- _].
- case: eval_expr => // - [n|] //.
  rewrite fsubU1set=> /andP [Px Pe] [<- _]; rewrite domm_set.
  apply/eqP; rewrite eqEfsubset; apply/andP; split.
    by rewrite fsubU1set Px fsubsetxx.
  by rewrite fsubsetUr.
- case: eval_expr => // p sz.
  by case: ifP=> //= _; case: ifP=> //= _ _ [<-].
- congruence.
- case eval_c1: eval_com=> [[ls'' h'']| | ] //.
  rewrite fsubUset=> /andP [vars_c1 vars_c2] eval_c2.
  rewrite -(IH _ _ _ _ _ vars_c1 eval_c1) in vars_c2 *.
  by rewrite (IH _ _ _ _ _ vars_c2 eval_c2).
- case: eval_expr=> // - b.
  by rewrite 2!fsubUset -andbA => /and3P [_ vars_c1 vars_c2]; case: b; eauto.
case: eval_expr=> // - [] P; apply: IH.
  by rewrite /= fsetUC -fsetUA fsetUid.
by rewrite fsub0set.
Qed.

Let namesm_set (T S : nominalType) (m : {fmap T -> S}) (k : T) (x : S) :
  fsubset (names (setm m k x)) (names m :|: names k :|: names x).
Proof. eapply nom_finsuppP; finsupp. Qed.

Theorem weak_frame ls1 h1 ls2 h2 ls' h' safe c k :
  fsubset (vars_c c) (domm ls1) ->
  fdisjoint (domm ls1) (domm ls2) ->
  fdisjoint (names (ls1, h1)) (names (domm h2)) ->
  eval_com safe c (unionm ls1 ls2, unionm h1 h2) k =
  Done (ls', h') ->
  exists ls1' h1',
    [/\ ls' = unionm ls1' ls2,
        h'  = unionm h1' h2,
        fdisjoint (domm ls1') (domm ls2) &
        fsubset (names (ls1', h1') :&: (names h2))
                (names (ls1, h1))].
Proof.
elim: k ls1 h1 ls' h' c=> [//=|k IH] ls1 h1 ls' h' c.
case: c=> [x e|x e|e e'|x e|e| |c1 c2|e c1 c2|e c] //=.
- (* Assn *)
  rewrite fsubU1set=> /andP [Px sub] disl dish [<- <-].
  rewrite setm_union; do 3!eexists; eauto.
    by rewrite domm_set; apply/fdisjointP=> x' /fsetU1P [->|];
    move/fdisjointP: disl; apply.
  rewrite fsetIUl fsetUSS //= 1?fsubsetIl //.
  rewrite (fsubset_trans (fsetSI _ (namesm_set _ _ _))) // fsetU0.
  rewrite eval_expr_unionm // fsetIUl fsubUset fsubsetIl /=.
  rewrite (fsubset_trans (fsubsetIl _ _)) //.
  by rewrite (fsubset_trans (eval_expr_names _ _ _)) // fsubsetxx.
- (* Load *)
  rewrite fsubU1set=> /andP [Px sub] disl dish.
  rewrite eval_expr_unionm //.
  case eval_e: eval_expr=> [| |p|] //.
  rewrite unionmE; case get_p: (h1 p)=> [v|] /=.
    move=> [<- <-]; rewrite setm_union; do 3!eexists; eauto.
      by rewrite domm_set; apply/fdisjointP=> x' /fsetU1P [->|];
      move/fdisjointP: disl; apply.
    rewrite fsetIUl /= fsubUset; apply/andP; split.
      apply: (fsubset_trans (fsubsetIl _ _)).
      apply: (fsubset_trans (namesm_set _ _ _)).
      rewrite fsetU0 fsetUSS // ?fsubsetxx //=.
      apply/fsubsetP=> n Pn; apply/namesmP.
      by eapply PMFreeNamesVal; eauto.
    by apply: fsubIset; rewrite fsubsetUr.
  move: (eval_expr_names safe ls1 e); rewrite eval_e namesvE fsub1set=> Pp.
  move/fdisjointP/(_ p.1): dish; rewrite in_fsetU /= Pp /= => /(_ erefl).
  case get_p': (h2 p) => [v|] //= /namesfsPn/(_ p).
  by rewrite mem_domm get_p'=> /(_ erefl); rewrite in_fsetU in_fset1 eqxx.
- (* Store *)
  rewrite fsubUset=> /andP [sub1 sub2] disl dish.
  rewrite !eval_expr_unionm //.
  case eval_e: eval_expr=> [| |p| ] //.
  rewrite /updm unionmE setm_union.
  case get_p: (h1 p)=> [v|] //=.
    move=> [<- <-]; do 3!eexists; eauto.
    apply: (fsubset_trans (fsubsetIl _ _)).
    rewrite fsubUset; apply/andP; split; first by rewrite fsubsetUl.
    apply/(fsubset_trans (namesm_set _ _ _)); rewrite 2!fsubUset.
    rewrite fsubsetUr /=; apply/andP; split.
      apply/fsubsetU/orP; right; apply/fsubsetP=> i Pi /=.
      by apply/namesmP; eapply PMFreeNamesKey; eauto.
    by apply/(fsubset_trans (eval_expr_names _ _ _))/fsubsetUl.
  move: (eval_expr_names safe ls1 e); rewrite eval_e namesvE fsub1set=> Pp.
  move/fdisjointP/(_ p.1): dish; rewrite in_fsetU /= Pp /= => /(_ erefl).
  case get_p': (h2 p) => [v|] //= /namesfsPn/(_ p).
  by rewrite mem_domm get_p'=> /(_ erefl); rewrite in_fsetU in_fset1 eqxx.
- (* Alloc *)
  rewrite fsubU1set=> /andP [Px sub] disl dish; rewrite eval_expr_unionm //.
  case eval_e: eval_expr=> [|[n|]| |] //= [<- <-].
  rewrite setm_union /= unionmA.
  have dis': fdisjoint (domm h1) (domm h2).
    apply/fdisjoint_names_domm/fdisjointP=> i Pi'.
    by move/fdisjointP: dish; apply; apply/fsetUP; right; apply/fsetUP; left.
  have F := (freshP (names (unionm ls1 ls2, unionm h1 h2))).
  do 3!eexists; eauto.
    by rewrite domm_set; apply/fdisjointP=> x' /fsetU1P [->|];
    move/fdisjointP: disl; apply.
  rewrite fsetIUl fsubUset; apply/andP; split=> /=.
    apply/(fsubset_trans _ (fsubsetUl _ _)).
    apply/(fsubset_trans (fsetSI _ (namesm_set _ _ _))).
    rewrite /= 2!fsetIUl 2!fsubUset fsubsetIl fset0I fsub0set /=.
    rewrite namesvE /=.
    apply/fsubsetP=> i /fsetIP [/namesnP -> {i} /= Pi].
    move: F; rewrite in_fsetU negb_or=> /andP [_] /=.
    by rewrite namesm_union_disjoint // in_fsetU negb_or Pi andbF.
  apply/fsubsetU/orP; right=> /=.
  move: (fresh _) F => i.
  rewrite namespE /= (namesm_union_disjoint dis').
  rewrite in_fsetU negb_or in_fsetU negb_or.
  case/and3P=> Fl Fh1 Fh2.
  rewrite namesm_union_disjoint 1?fsetIUl ?fdisjoint_names_domm //.
    rewrite fsubUset fsubsetIl andbT names_mkblock names_nseq if_same.
    by rewrite fun_if if_arg fsetU0 fset1I fset0I (negbTE Fh2) if_same fsub0set.
  rewrite names_domm_mkblock.
  case: ifP => _; first by rewrite fdisjoint0s.
  rewrite fdisjointC fdisjoints1.
  by apply: contra Fh1; rewrite in_fsetU => ->.
- (* Free *)
  move=> sub disl dish; rewrite eval_expr_unionm //.
  case eval_e: eval_expr=> [| |p|] //=.
  have [|] := altP eqP=> // _.
  rewrite domm_curry; case: ifP=> [/imfsetP [/= p' inD Pp]|] //=.
  move: inD; rewrite mem_domm unionmE.
  have dish': fdisjoint (names (domm h1)) (names (domm h2)).
    apply/fdisjointP=> i Pi'.
    by move/fdisjointP: dish; apply; apply/fsetUP; right; apply/fsetUP; left.
  case get_p': (h1 p') => [v|] /=.
    move=> _ [<- <-]; exists ls1, (filterm (fun p'' _ => p''.1 != p.1) h1).
    split=> //.
      rewrite filterm_union; last by apply fdisjoint_names_domm.
      congr unionm; apply/eq_fmap=> p''; rewrite filtermE.
      case get_p'': (h2 p'')=> [v'|] //=.
      have [Pp'|] //= := altP eqP.
      have names_p: p.1 \in names (domm h1).
        apply/namesfsP; exists p'; first by rewrite mem_domm get_p'.
        by rewrite Pp; rewrite in_fsetU; apply/orP; left; apply/namesnP.
      move/fdisjointP: dish'=> /(_ _ names_p).
      suff ->: p.1 \in names (domm h2) by [].
      apply/namesfsP; exists p''; first by rewrite mem_domm get_p''.
      by rewrite -Pp'; rewrite in_fsetU; apply/orP; left; apply/namesnP.
    rewrite fsetIUl fsetUSS //= ?fsubsetIl //.
    by apply/(fsubset_trans (fsubsetIl _ _))/namesm_filter.
  case get_p'': (h2 p') => [v'|] //= _.
  move: (eval_expr_names safe ls1 e); rewrite eval_e namesvE.
  move=> /fsubsetP/(_ p.1); rewrite in_fset1 eqxx=> /(_ erefl) Pp'.
  rewrite fdisjointC in dish; move/fdisjointP/(_ p.1): dish.
  have h: p.1 \in names (domm h2).
    apply/namesfsP; exists p'; first by rewrite mem_domm get_p''.
    by rewrite Pp in_fsetU; apply/orP; left; apply/namesnP.
  by rewrite in_fsetU Pp' /= => /(_ h).
- (* Skip *)
  move=> _ ? ? [<- <-]; do 3!eexists; eauto; exact: fsubsetIl.
- (* Seq *)
  case eval_c1: eval_com=> [[ls'' h'']| |] //=.
  rewrite fsubUset=> /andP [sub1 sub2] disl dish eval_c2.
  have [ls1' [h1' [? ? disl' sub']]] := IH _ _ _ _ _ sub1 disl dish eval_c1.
  subst ls'' h''.
  have dish': fdisjoint (names (ls1', h1')) (names (domm h2)).
    move/eqP in dish.
    rewrite /fdisjoint -fsubset0 -dish fsubsetI fsubsetIr andbT.
    by rewrite (fsubset_trans _ sub') // fsetIS // fsubsetUl.
  have sub1': fsubset (vars_c c1) (domm (unionm ls1 ls2)).
    by rewrite domm_union (fsubset_trans sub1) // fsubsetUl.
  have sub2' : fsubset (vars_c c2) (domm ls1').
    apply/fsubsetP=> x x_in.
    move/fsubsetP/(_ x x_in): (sub2)=> sub2'.
    have: x \in domm (unionm ls1' ls2).
      by rewrite (eval_com_domm sub1' eval_c1) domm_union in_fsetU sub2'.
    move/fdisjointP/(_ _ sub2') in disl.
    by rewrite domm_union in_fsetU (negbTE disl) orbF.
  have [ls1'' [h1'' [? ? disl'' sub'']]] :=
    IH _ _ _ _ _ sub2' disl' dish' eval_c2.
  subst; do 3!eexists; eauto.
  by apply/(fsubset_trans _ sub'); rewrite fsubsetI fsubsetIr andbT.
- (* If *)
  rewrite 2!fsubUset=> /andP [/andP [sub1 sub2] sub3].
  rewrite eval_expr_unionm //.
  case eval_e: eval_expr=> [b| | |] //= disl dish eval_c.
  have [|ls1' [h1' [? ? disl' sub']]] := IH _ _ _ _ _ _ disl dish eval_c.
    by case: b {eval_e eval_c}.
  by subst ls' h'; do 3!eexists; eauto.
(* While *)
rewrite fsubUset=> /andP [sub1 sub2]; rewrite eval_expr_unionm //.
case eval_e: eval_expr=> [b| | |] //= disl dish eval_c.
have [|ls1' [h1' [? ? sub']]] := IH _ _ _ _ _ _ disl dish eval_c.
  case: (b); last by rewrite fsub0set.
  by rewrite /= fsetUC -fsetUA fsetUid fsubUset sub1.
by subst ls' h'; do 3!eexists; eauto.
Qed.

End Cast.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

(* Import SolidityNotations. *)
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
(*Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Debug.  *)
(* Set Typeclasses Unique Instances.
Unset Typeclasses Unique Solutions. *)

(* Existing Instance monadStateT.
Existing Instance monadStateStateT. *)
(* Module MultiSigWalletSpecSig := MultiSigWalletSpecSig XTypesSig StateMonadSig. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.
Require Import depoolContract.Lib.CommonStateProofs.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope solidity_scope.

(* Require Import MultiSigWallet.Specifications._validatelimit_inlineSpec.
Module _validatelimit_inlineSpec := _validatelimit_inlineSpec MultiSigWalletSpecSig.
Import _validatelimit_inlineSpec. *)

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

(* function generateRound() internal returns (Round) {
        DePoolLib.Request req;
        Round r = Round({                      (*<<< порядок <<<<<*)
            id: m_roundQty,
            supposedElectedAt: 0, // set when round in elections phase
            unfreeze: DePoolLib.MAX_TIME, // set when round in unfreeze phase
            stakeHeldFor: 0,                    (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)
            vsetHashInElectionPhase: 0, // set when round in elections phase
            step: RoundStep.PrePooling,
            completionReason: CompletionReason.Undefined,

            stake: 0,
            recoveredStake: 0,                 (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)
            unused: 0,
            isValidatorStakeCompleted: false,  (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)
            rewards: 0,
            participantQty : 0,
            validatorStake: 0,                 (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)
            validatorRemainingStake: 0,        (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)
            handledStakesAndRewards: 0,        (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)

            validatorRequest: req,
            elector: address(0), // set when round in elections phase
            proxy: getProxy(m_roundQty)
       });
        ++m_roundQty;
        return r;
    }
*)

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo.

Lemma DePoolContract_Ф_generateRound_exec : forall (l: Ledger) ,
exec_state ( ↓ DePoolContract_Ф_generateRound ) l =

let m_roundQty1 := ( eval_state ( ↑11 ε RoundsBase_ι_m_roundQty ) l ) + 1 in

    {$ l With ( RoundsBase_ι_m_roundQty , m_roundQty1 ) $} .
 Proof.
   intros. destruct l. auto.
 Qed.

Lemma DePoolContract_Ф_generateRound_eval : forall (l: Ledger) ,
eval_state ( ↓ DePoolContract_Ф_generateRound ) l =

let req (* : DePoolLib_ι_RequestP *) := default in
let r := ( RoundsBase_ι_RoundC
  ( eval_state ( ↑11 ε RoundsBase_ι_m_roundQty ) l )
 	0
 	( eval_state ( ↑9 ε DePoolLib_ι_MAX_TIME ) l )
 	 RoundsBase_ι_RoundStepP_ι_PrePooling
 	 RoundsBase_ι_CompletionReasonP_ι_Undefined
 	 0 0 default req 0 0 0
 	( eval_state ( ↓ ( ProxyBase_Ф_getProxy ( eval_state ( ↑11 ε RoundsBase_ι_m_roundQty ) l ) ) ) l )
	0 0 0 false 0 0 0 ) in r .
 Proof.
   intros. destruct l. auto.
Qed.


(** * SLOT: a formally verified model checker *)

(** SLOT is a collection of definitions and tactics for verification
of safety properties of concurrent and distributed functional programs
doing I/O, based on Hoare logic. SLOT models have the following
properties:

- Verified systems are written in a shallow-embedded DSL, and take
  advantage of most Gallina features. They can be extracted to CPS
  programs in Ocaml or Haskell via Coq's extraction feature

- Users can define their own I/O operations (called syscalls from now
  on)

- Syscall definitions can be composed together, and all theorems about
  the individual syscall types hold for the combined system

- Syscalls can be nondeterminisic

- Current version of SLOT doesn't support verification of liveness
  properties

Some notes on the naming: originally SLOT stood for Separation Logic
Of Traces, but the current implementation has nothing to do with
separation logic. However this name was catchy, so it stuck.

* Motivation

Before diving into lengthy description of the model, let me first
motivate a skeptical reader:

** Q: Why not TLA+?

A: In SLOT the verified system is clearly separated from the I/O
model, and therefore its definition looks much like conventional
functional program. It makes extraction of the verified code easier
(at least in theory). Model of the non-deterministic I/O is
separated. This leads to much more structured definitions and proofs.

Another obvious difference is that SLOT is entirely based on Coq and
makes heavy use of inductive datatypes and symbolic evaluation under
the hood. This has both advantages and disadvantages:

- SLOT is much less automated, but it can work with inductive
  definitions and anything that can be expressed in Coq

- SLOT model checker outputs Coq proofs, ultimately it means that it
  needs to store all execution histories. Given that the number of
  histories grows exponentially, solving large proofs by pure
  bruteforce is impossible. Although this disadvantage is partially
  mitigated by several formally-verified branch-pruning algorithms, it
  means proofs about large systems should be split to lemmas

- Verified program can be extracted

- While TLA+ model checker is top notch, its proof language is not

** Q: Why not (insert model checker name)?

A: Model checkers show why the code _fails_, which is suitable for
verifying algorithms, but structured formal proofs show why the code
_works_ (via tree of assumptions). It allows to reason about
algorithms and, in particular, to predict the outcome of
optimizations. Also model checkers typically can't work with infinite
state space, while SLOT can do it to some extend via magic of Coq.

** Q: Why not Verdi?

https://github.com/uwplse/verdi

- Nondeterminisic part of Verdi is hardcoded, while SLOT allows user
  to define custom IO handlers

- Verdi models are low level: think UDP packets and disk iops. SLOT
  can work with higher-level I/O handlers: think databases and pubsub
  services.

** Q: Why not disel?

https://github.com/DistributedComponents/disel

A: disel models are closer to what I need, but implementation itself
is an incomprehensible, impenetrable wall of ssreflect. Proofs are
only as useful as their premises: "garbage in - garbage out". Good
model should be well documented and well understood.

** Q: Why not iris/aneris?

https://gitlab.mpi-sws.org/iris/iris

A: iris allows user to define semantics of their very own programming
language. SLOT is focused on proving properties of _regular pure
functinal programs_ that do IO from time to time. Hence it defines
actors in regular Gallina language, rather than some DSL, and frees
the user from reinventing basic control flow constructions.

* Navigating the code

** Core definitions

 - [LibTx.SLOT.Hoare] module contains definitions used to describe a
   single execution history

*)

From LibTx Require Export
     SLOT.EventTrace
     SLOT.Hoare
     SLOT.Handler
     SLOT.Process
     SLOT.Ensemble.

From Coq Require Import
     String
     List.

(*Module Model.
  Section defn.
    Context {PID} {SUT : Type} {Handler : @Handler.t PID}.

    Record t : Type :=
      mkModel
        { model_sut : SUT;
          model_handler : h_state Handler;
        }.

   Context `{Runnable  SUT}.

    Definition model_state_transition m m' te : Prop :=
      match m, m' with
      | mkModel s h, mkModel s' h' => (h_state_transition Handler) h h' te /\
                                     runnable_step s s' te
      end.

    Global Instance modelStateSpace : StateSpace t (@TraceElem ctx) :=
      {| state_transition := model_state_transition; |}.
  End defn.

  (* Helper function for infering type of model: *)
  Definition model_t {SUT} {PID} (sut : SUT) (h : @Handler.t PID) : Type :=
    @t PID SUT h.
End Model. *)

Ltac bruteforce Ht Hls :=
  let Ht' := type of Ht in
  match eval lazy in Ht' with
  | ThreadGenerator _ _ _ =>
    unfold_thread Ht
  | Parallel ?e1 ?e2 ?t =>
    let t1 := fresh "t_l" in
    let t2 := fresh "t_r" in
    let H1 := fresh "H" t1 in
    let H2 := fresh "H" t2 in
    let t := fresh "t" in
    let Hint := fresh "Hint_" t in
    destruct Ht as [t1 t2 t H1 H2 Hint];
    bruteforce H1 Hls; subst; bruteforce H2 Hls;
    unfold_interleaving Hint with trace_step Hls
  end.

Require Import
        Handlers.Mutex
        Handlers.Deterministic.

(*
Module ExampleModelDefn.
  Section handler.
    Context {PID : Type}.

    Definition Handler := AtomicVar.t nat <+> mutexHandler PID.
  End handler.

  Let req := get_handler_req (@Handler).
  Let ret := get_handler_ret (@Handler).

  Section defs.
    (* Let req : Type := (@avar_req_t nat + req_t).     *)
    Context {PID : Type}.

    Definition put (val : nat) : req :=
      inl (AtomicVar.write val).

    Definition get : req :=
      inl (AtomicVar.read).

    Definition grab : req :=
      inr (Mutex.grab).

    Definition release : req :=
      inr (Mutex.release).

    Let Thread := @Thread req ret.

    (* Just a demonstration how to define a program that loops
    indefinitely, as long as it does IO: *)

    CoFixpoint infinite_loop (self : PID) : Thread :=
      do _ <- put 0;
      infinite_loop self.

    (* Data race example: *)
    Definition inc (n : nat) ret : Thread :=
      do v <- get;
      do _ <- put (v + n);
      ret (v + n).

    (* Fixed example: *)
    Definition counter_correct (self : PID) :=
      do _ <- grab;
      call x <- inc 1;
      done release.

    (* Definition nop (self : PID) : Thread := *)
    (*   @throw ctx "Exception".  TODO *)
  End defs.

  Section simple.
    Let PID := bool.

    Let SUT := counter_correct I.
    Let Handler := @Handler PID.

    Let mk_counter (pid : PID) := ThreadGenerator pid (counter_correct pid).
    Let SingletonEnsemble := mk_counter true.
    Let PairEnsemble := (mk_counter true) -|| (mk_counter false).
    Let InfLoopEnsemble := ThreadGenerator true (infinite_loop true).

    Goal EnsembleInvariant (fun _ => True) SingletonEnsemble.
    Proof.
      intros t Ht.
      unfold_thread Ht. subst.
      now repeat constructor.
    Qed.

    Goal EnsembleInvariant (fun _ => True) SingletonEnsemble.
    Proof.
      intros t Ht.
      unfold_thread Ht. subst.
      now repeat constructor.
    Qed.

    Goal forall v1 v2,
      {{ fun s  => True }}
        [true @ v1 <~ get;
         true @ I <~ grab;
         true @ v2 <~ get;
         false @ I <~ grab;
         true @ I <~ grab]
      {{ fun s => False }}.
    Proof.
      intros v1 v2.
      unfold_ht.
      repeat trace_step Hls.
    Qed.

    Goal -{{ fun (s : h_state Handler) => fst s = 0 }} PairEnsemble {{ fun s => fst s = 2 }}.
    Proof.
      intros t Ht.
      unfold_ht.
      cbn in Hpre.
      bruteforce Ht Hls;
      cbn in *; repeat match goal with
                         [ H : _ /\ _ |- _] => destruct H
                       end; subst; auto.
    Qed.

    (*Let counter_invariant (sys : Model) : Prop :=
      match sys with
        mkModel sut (M, l) =>
        match l with
        | Some _ => True
        | None =>
          let n_alive := match sut with
                         | t_dead => 0
                         | t_cont _ _ => 1
                         end
          in n_alive + M = 1
        end
      end.*)
  End simple.
End ExampleModelDefn.
*)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*
Fixpoint F (n:nat) : False := F (match F n with end).
*)
(* de Bruijn mix-up *)
(* If accepted, Eval compute in f 0. loops *)
Fail Definition f :=
  let f (f1 f2:nat->nat) := f1 in
  let _ := 0 in
  let _ := 0 in
  let g (f1 f2:nat->nat) := f2 in
  let h := f in (* h = Rel 4 *)
  fix F (n:nat) : nat :=
  h F S n. (* here Rel 4 = g *)


Unset Strict Universe Declaration.
(* -*- coq-prog-args: ("-nois") -*- *)
(* File reduced by coq-bug-finder from original input, then from 830 lines to 47 lines, then from 25 lines to 11 lines *)
(* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0
   coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (8dbfee5c5f897af8186cb1bdfb04fd4f88eca677) *)

Declare ML Module "ltac_plugin".

Set Universe Polymorphism.
Class Contr_internal (A : Type) := BuildContr { center : A }.
Arguments center A {_}.
Class Contr (A : Type) : Type := Contr_is_trunc : Contr_internal A.
Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances.
Definition contr_paths_contr0 {A} `{Contr A} : Contr A := {| center := center A |}.
Instance contr_paths_contr1 {A} `{Contr A} : Contr A := {| center := center A |}.
Check @contr_paths_contr0@{i}.
Check @contr_paths_contr1@{i}. (* Error: Universe instance should have length 2 *)
(** It should have length 1, just like contr_paths_contr0 *)


(**
SimSoC-Cert, a toolkit for generating certified processor simulators.

See the COPYRIGHTS and LICENSE files.

Notations and coercions for C programs.
*)

Set Implicit Arguments.

Require Import List BinInt String.
Require Export Integers AST Values Csyntax Ascii.

(****************************************************************************)
(** notations for Coq data structures *)

Notation "[ ]" := nil.
Notation "[ a ; .. ; b ]" := (a :: .. (b :: nil) ..).

(****************************************************************************)
(** convert Coq strings into lists of Values.init_data *)

Definition init_data_of_ascii a := Init_int8 (Int.repr (Z_of_N (N_of_ascii a))).

Definition list_init_data_of_list_ascii := List.map init_data_of_ascii.

Fixpoint list_init_data_of_string s :=
  match s with
    | EmptyString => []
    | String a s => init_data_of_ascii a :: list_init_data_of_string s
  end.

Definition null_termin_string s := (s ++ String "000" "")%string.

(****************************************************************************)
(** coercions *)

Coercion Int.repr : Z >-> int.
Coercion Vint : int >-> val.
Coercion Sdo : expr >-> statement.
Coercion init_data_of_ascii : ascii >-> init_data.
Coercion list_init_data_of_string : string >-> list.

(****************************************************************************)
(* notations *)

Notation "a -: b" := (pair a b) (at level 60).

Notation "` x" := (Int.repr x) (at level 9).
Notation "`` x" := (Init_int8 ` x) (at level 9).

Notation int8 := (Tint I8 Signed).
Notation uint8 := (Tint I8 Unsigned).
Notation int16 := (Tint I16 Signed).
Notation uint16 := (Tint I16 Unsigned).
Notation int32 := (Tint I32 Signed).
Notation uint32 := (Tint I32 Unsigned).
Notation float32 := (Tfloat F32).
Notation float64 := (Tfloat F64).

Notation void := Tvoid.
Notation "`*` t" := (Tpointer t) (at level 20).

Notation "a :T: b" := (Tcons a b) (at level 70, right associativity).
Notation "T[ ]" := Tnil.
Notation "T[ a ; .. ; b ]" := (a :T: .. (b :T: Tnil) ..).

Definition fcons a := Fcons (fst a) (snd a).
Notation "a :F: b" := (fcons a b) (at level 70, right associativity).
Notation "F[ ]" := Fnil.
Notation "F[ a ; .. ; b ]" := (a :F: .. (b :F: Fnil) ..).

Notation "a :E: b" := (Econs a b) (at level 70, right associativity).
Notation "E[ ]" := Enil.
Notation "E[ a ; .. ; b ]" := (a :E: .. (b :E: Enil) ..).

Notation "! x `: t" := (Eunop Onotbool x t) (at level 10).
Notation "`~ x `: t" := (Eunop Onotint x t) (at level 10).
Notation "`- x `: t" := (Eunop Oneg x t) (at level 10).

Notation "x + y `: t" := (Ebinop Oadd x y t) (at level 20).
Notation "x - y `: t" := (Ebinop Osub x y t) (at level 20).
Notation "x * y `: t" := (Ebinop Omul x y t) (at level 20).
Notation "x / y `: t" := (Ebinop Odiv x y t) (at level 20).
Notation "x % y `: t" := (Ebinop Omod x y t) (at level 20).
Notation "x & y `: t" := (Ebinop Oand x y t) (at level 20).
Notation "x `| y `: t" := (Ebinop Oor x y t) (at level 20).
Notation "x ^ y `: t" := (Ebinop Oxor x y t) (at level 20).
Notation "x << y `: t" := (Ebinop Oshl x y t) (at level 20).
Notation "x >> y `: t" := (Ebinop Oshr x y t) (at level 20).

Notation "x == y `: t" := (Ebinop Oeq x y t) (at level 20).
Notation "x != y `: t" := (Ebinop One x y t) (at level 20).
Notation "x < y `: t" := (Ebinop Olt x y t) (at level 20).
Notation "x > y `: t" := (Ebinop Ogt x y t) (at level 20).
Notation "x <= y `: t" := (Ebinop Ole x y t) (at level 20).
Notation "x >= y `: t" := (Ebinop Oge x y t) (at level 20).

Notation "x += y `: t1 `: t2" := (Eassignop Oadd x y t1 t2) (at level 8).
Notation "x -= y `: t1 `: t2" := (Eassignop Osub x y t1 t2) (at level 8).
Notation "x *= y `: t1 `: t2" := (Eassignop Omul x y t1 t2) (at level 8).
Notation "x /= y `: t1 `: t2" := (Eassignop Odiv x y t1 t2) (at level 8).
Notation "x %= y `: t1 `: t2" := (Eassignop Omod x y t1 t2) (at level 8).
Notation "x &= y `: t1 `: t2" := (Eassignop Oand x y t1 t2) (at level 8).
Notation "x `|= y `: t1 `: t2" := (Eassignop Oor x y t1 t2) (at level 8).
Notation "x ^= y `: t1 `: t2" := (Eassignop Oxor x y t1 t2) (at level 8).
Notation "x <<= y `: t1 `: t2" := (Eassignop Oshl x y t1 t2) (at level 8).
Notation "x >>= y `: t1 `: t2" := (Eassignop Oshr x y t1 t2) (at level 8).

Notation "`* e `: t" := (Ederef e t) (at level 20).
Notation "# v `: t" := (Eval v t) (at level 20).
Notation "$ id `: t" := (Evar id t) (at level 20).
Notation "\ id `: t" := (Evalof (Evar id t) t) (at level 20).
Notation "& e `: t" := (Eaddrof e t) (at level 20).
Notation "e1 ? e2 `: e3 `: t" := (Econdition e1 e2 e3 t) (at level 20).
Notation "e -- `: t" := (Epostincr Decr e t) (at level 20).
Notation "e ++ `: t" := (Epostincr Incr e t) (at level 20).
Notation "e1 `= e2 `: t" := (Eassign e1 e2 t) (at level 8).
Notation "e | id `: t" := (Efield e id t) (at level 20).
Notation "'call'" := (Ecall).
Notation "'sizeof'" := (Esizeof).
Notation "'valof'" := (Evalof).

Notation "a ;; b" := (Ssequence a b) (at level 51, right associativity).
Notation "`if a 'then' b 'else' c" := (Sifthenelse a b c) (at level 9).
Notation "'while' a `do b" := (Swhile a b) (at level 19).
Notation "`do a 'while' b" := (Sdowhile b a) (at level 19).
Notation "'label' l `: s" := (Slabel l s) (at level 5).
Notation "'for' ( s1 , e , s2 ) { s3 }" := (Sfor s1 e s2 s3) (at level 19).

Notation "'return'" := (Sreturn) (at level 10).
Notation "'goto'" := (Sgoto).
Notation "'continue'" := (Scontinue).
Notation "'break'" := (Sbreak).
Notation "'skip'" := (Sskip).
Notation "'switch'" := (Sswitch).

Notation "`case i `: s :L: ls" := (LScase i s ls) (at level 70).
Notation "'default' `: s" := (LSdefault s) (at level 80).


Require Export
        Fiat.CertifiedExtraction.Extraction.Extraction.

Require Import
        Fiat.CertifiedExtraction.Extraction.BinEncoders.Basics
        Fiat.CertifiedExtraction.Extraction.BinEncoders.Wrappers
        Fiat.CertifiedExtraction.Extraction.BinEncoders.Properties.

Require Import
        Coq.Program.Program
        Coq.Lists.List.

Unset Implicit Arguments.

Lemma CompileCompose :
  forall {av} E B B' (transformer: Transformer.Transformer B) enc1 enc2
    (vstream: NameTag av B') (stream: B) (cache: E)
    (tenv t1 t2: Telescope av) f (g: B -> B') ext env p1 p2,
    (forall a1 a2 b, f (a1, b) = f (a2, b)) ->
    {{ [[ vstream  ->> g stream as _ ]]
         :: tenv }}
      p1
    {{ TelAppend ([[ NTNone ->> enc1 cache as encoded1 ]]
                    :: [[ vstream ->> g (Transformer.transform stream (fst encoded1)) as _ ]]
                    :: f encoded1)
                 t1 }}
    ∪ {{ ext }} // env ->
    (let encoded1 := enc1 cache in
     let stream1 := Transformer.transform stream (fst encoded1) in
     {{ TelAppend ([[ vstream ->> g stream1 as _ ]] :: f encoded1) t1 }}
       p2
     {{ TelAppend ([[ NTNone ->> enc2 (snd encoded1) as encoded2 ]]
                     :: [[ vstream ->> g (Transformer.transform stream1 (fst encoded2)) as _ ]]
                     :: f encoded2) t2 }}
     ∪ {{ ext }} // env) ->
    {{ [[ vstream ->> g stream as _ ]] :: tenv }}
      (Seq p1 p2)
    {{ TelAppend ([[ NTNone ->> @Compose.compose E B transformer enc1 enc2 cache as composed ]]
                    :: [[ vstream ->> g (Transformer.transform stream (fst composed)) as _ ]]
                    :: f composed) t2 }}
    ∪ {{ ext }} // env.
Proof.
  intros.
  repeat hoare.
  setoid_rewrite Compose_compose_acc.
  unfold compose_acc, encode_continue.
  cbv zeta in *.
  setoid_rewrite Propagate_anonymous_ret.
  setoid_rewrite Propagate_anonymous_ret in H0.
  setoid_rewrite Propagate_anonymous_ret in H1.
  destruct (enc1 _); simpl in *.
  destruct (enc2 _); simpl in *.
  erewrite (H (Transformer.transform _ _)); rewrite Transformer.transform_assoc; eassumption.
Qed.

Lemma CompileCompose_init :
  forall {av} E B B' (transformer: Transformer.Transformer B) enc1 enc2
    (vstream: NameTag av B') (cache: E)
    (tenv t1 t2: Telescope av) f (g : B -> B') ext env p1 p2 pAlloc,
    (forall a1 a2 b, f (a1, b) = f (a2, b)) ->
    {{ tenv }}
      pAlloc
    {{ [[ vstream ->> g Transformer.transform_id as _ ]] :: tenv }} ∪ {{ ext }} // env ->
    {{ [[ vstream ->> g Transformer.transform_id as _ ]] :: tenv }}
      p1
    {{ TelAppend ([[ NTNone ->> enc1 cache as encoded1 ]]
                    :: [[ vstream ->> g (Transformer.transform (Transformer.transform_id) (fst encoded1)) as _ ]]
                    :: f encoded1)
                 t1 }} ∪ {{ ext }} // env ->
    (let encoded1 := enc1 cache in
     let stream1 := Transformer.transform Transformer.transform_id (fst encoded1) in
     {{ TelAppend ([[ vstream ->> g stream1 as _ ]] :: f encoded1) t1 }}
       p2
     {{ TelAppend ([[ NTNone ->> enc2 (snd encoded1) as encoded2 ]]
                     :: [[ vstream ->> g (Transformer.transform stream1 (fst encoded2)) as _ ]]
                     :: f encoded2) t2 }} ∪ {{ ext }} // env) ->
    {{ tenv }}
      (Seq pAlloc (Seq p1 p2))
    {{ TelAppend ([[ NTNone ->> @Compose.compose E B transformer enc1 enc2 cache as composed ]]
                    :: [[ vstream ->> g (fst composed) as _ ]]
                    :: f composed) t2 }}
    ∪ {{ ext }} // env.
Proof.
  intros; hoare.
  setoid_rewrite <- (Transformer.transform_id_left (fst _)).
  eauto using CompileCompose.
Qed.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import RealmSyncHandlerAux.Specs.handle_icc_el1_sysreg_trap.
Require Import RealmSyncHandlerAux.LowSpecs.handle_icc_el1_sysreg_trap.
Require Import RealmSyncHandlerAux.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       ESR_EL2_SYSREG_ISS_RT_spec
       ESR_EL2_SYSREG_IS_WRITE_spec
       set_rec_regs_spec
    .

  Lemma handle_icc_el1_sysreg_trap_spec_exists:
    forall habd habd'  labd rec esr
      (Hspec: handle_icc_el1_sysreg_trap_spec rec esr habd = Some habd')
      (Hrel: relate_RData habd labd),
    exists labd', handle_icc_el1_sysreg_trap_spec0 rec esr labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel. destruct rec.
    unfold handle_icc_el1_sysreg_trap_spec, handle_icc_el1_sysreg_trap_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite; repeat simpl_update_reg;
        repeat (simpl_htarget; grewrite; simpl in * );
        try solve[repeat (solve_bool_range; grewrite); eexists; split; [reflexivity|constructor; reflexivity]].
  Qed.

End Refine.


From caml5 Require Import
  prelude.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.std Require Export
  base.

Section heapGS.
  Context `{!heapGS Σ}.
  Implicit Types l : loc.

  Definition record3_make : val :=
    λ: "v₀" "v₁" "v₂",
      let: "l" := AllocN #3 "v₀" in
      "l".(1) <- "v₁" ;;
      "l".(2) <- "v₂" ;;
      "l".

  Definition record3_model l dq v₀ v₁ v₂ : iProp Σ :=
    l.(0) ↦{dq} v₀ ∗
    l.(1) ↦{dq} v₁ ∗
    l.(2) ↦{dq} v₂.

  #[global] Instance record3_model_timeless l dq v₀ v₁ v₂ :
    Timeless (record3_model l dq v₀ v₁ v₂).
  Proof.
    apply _.
  Qed.
  #[global] Instance record3_model_persistent l v₀ v₁ v₂ :
    Persistent (record3_model l DfracDiscarded v₀ v₁ v₂).
  Proof.
    apply _.
  Qed.

  #[global] Instance record3_model_fractional l v₀ v₁ v₂ :
    Fractional (λ q, record3_model l (DfracOwn q) v₀ v₁ v₂).
  Proof.
    apply _.
  Qed.
  #[global] Instance record3_model_as_fractional l q v₀ v₁ v₂ :
    AsFractional (record3_model l (DfracOwn q) v₀ v₁ v₂) (λ q, record3_model l (DfracOwn q) v₀ v₁ v₂) q.
  Proof.
    split; done || apply _.
  Qed.

  Lemma record3_model_persist l dq v₀ v₁ v₂ :
    record3_model l dq v₀ v₁ v₂ ==∗
    record3_model l DfracDiscarded v₀ v₁ v₂.
  Proof.
    iIntros "(Hv₀ & Hv₁ & Hv₂)".
    iMod (mapsto_persist with "Hv₀") as "$".
    iMod (mapsto_persist with "Hv₁") as "$".
    iMod (mapsto_persist with "Hv₂") as "$".
    done.
  Qed.

  Lemma record3_model_valid l dq v₀ v₁ v₂ :
    record3_model l dq v₀ v₁ v₂ -∗
    ⌜✓ dq⌝.
  Proof.
    iIntros "(Hv₀ & Hv₁ & Hv₂)". iApply (mapsto_valid with "Hv₀").
  Qed.
  Lemma record3_model_combine l dq1 v₀1 v₁1 v₂1 dq2 v₀2 v₁2 v₂2 :
    record3_model l dq1 v₀1 v₁1 v₂1 -∗
    record3_model l dq2 v₀2 v₁2 v₂2 -∗
      record3_model l (dq1 ⋅ dq2) v₀1 v₁1 v₂1 ∗
      ⌜v₀1 = v₀2 ∧ v₁1 = v₁2 ∧ v₂1 = v₂2⌝.
  Proof.
    iIntros "(Hv₀1 & Hv₁1 & Hv₂1) (Hv₀2 & Hv₁2 & Hv₂2)".
    iDestruct (mapsto_combine with "Hv₀1 Hv₀2") as "(Hv₀ & <-)".
    iDestruct (mapsto_combine with "Hv₁1 Hv₁2") as "(Hv₁ & <-)".
    iDestruct (mapsto_combine with "Hv₂1 Hv₂2") as "(Hv₂ & <-)".
    iSplit; last done. iFrame.
  Qed.
  Lemma record3_model_valid_2 l dq1 v₀1 v₁1 v₂1 dq2 v₀2 v₁2 v₂2 :
    record3_model l dq1 v₀1 v₁1 v₂1 -∗
    record3_model l dq2 v₀2 v₁2 v₂2 -∗
    ⌜✓ (dq1 ⋅ dq2) ∧ v₀1 = v₀2 ∧ v₁1 = v₁2 ∧ v₂1 = v₂2⌝.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record3_model_combine with "Hl1 Hl2") as "(Hl & %)".
    iDestruct (record3_model_valid with "Hl") as %?.
    done.
  Qed.
  Lemma record3_model_agree l dq1 v₀1 v₁1 v₂1 dq2 v₀2 v₁2 v₂2 :
    record3_model l dq1 v₀1 v₁1 v₂1 -∗
    record3_model l dq2 v₀2 v₁2 v₂2 -∗
    ⌜v₀1 = v₀2 ∧ v₁1 = v₁2 ∧ v₂1 = v₂2⌝.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record3_model_valid_2 with "Hl1 Hl2") as %?. naive_solver.
  Qed.
  Lemma record3_model_dfrac_ne l1 dq1 v₀1 v₁1 v₂1 l2 dq2 v₀2 v₁2 v₂2 :
    ¬ ✓ (dq1 ⋅ dq2) →
    record3_model l1 dq1 v₀1 v₁1 v₂1 -∗
    record3_model l2 dq2 v₀2 v₁2 v₂2 -∗
    ⌜l1 ≠ l2⌝.
  Proof.
    iIntros "% Hl1 Hl2" (->).
    iDestruct (record3_model_valid_2 with "Hl1 Hl2") as %?. naive_solver.
  Qed.
  Lemma record3_model_ne l1 v₀1 v₁1 v₂1 l2 dq2 v₀2 v₁2 v₂2 :
    record3_model l1 (DfracOwn 1) v₀1 v₁1 v₂1 -∗
    record3_model l2 dq2 v₀2 v₁2 v₂2 -∗
    ⌜l1 ≠ l2⌝.
  Proof.
    iApply record3_model_dfrac_ne. intros []%exclusive_l. apply _.
  Qed.
  Lemma record3_model_exclusive l v₀1 v₁1 v₂1 v₀2 v₁2 v₂2 :
    record3_model l (DfracOwn 1) v₀1 v₁1 v₂1 -∗
    record3_model l (DfracOwn 1) v₀2 v₁2 v₂2 -∗
    False.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record3_model_ne with "Hl1 Hl2") as %?. naive_solver.
  Qed.

  Lemma record3_dfrac_relax dq l v₀ v₁ v₂ :
    ✓ dq →
    record3_model l (DfracOwn 1) v₀ v₁ v₂ ==∗
    record3_model l dq v₀ v₁ v₂.
  Proof.
    iIntros "% (Hv₀ & Hv₁ & Hv₂)".
    iMod (mapsto_dfrac_relax with "Hv₀") as "Hv₀"; first done.
    iMod (mapsto_dfrac_relax with "Hv₁") as "Hv₁"; first done.
    iMod (mapsto_dfrac_relax with "Hv₂") as "Hv₂"; first done.
    iFrame. done.
  Qed.

  Lemma record3_make_spec v₀ v₁ v₂ :
    {{{ True }}}
      record3_make v₀ v₁ v₂
    {{{ l, RET #l; record3_model l (DfracOwn 1) v₀ v₁ v₂ ∗ meta_token l ⊤ }}}.
  Proof.
    iIntros "%Φ _ HΦ".
    wp_rec. wp_pures.
    wp_apply (wp_allocN with "[//]"); first done. iIntros "%l (Hl & Hmeta & _)". rewrite loc_add_0.
    wp_pures.
    iDestruct (array_cons with "Hl") as "(Hv₀ & Hl)".
    iEval (setoid_rewrite <- loc_add_0) in "Hv₀".
    iDestruct (array_cons with "Hl") as "(Hv₁ & Hl)".
    iDestruct (array_singleton with "Hl") as "Hv₂".
    rewrite loc_add_assoc Z.add_1_r -Z.two_succ.
    wp_store. wp_store.
    iApply "HΦ". iFrame. done.
  Qed.

  Lemma record3_get0_spec l dq v₀ v₁ v₂ :
    {{{ record3_model l dq v₀ v₁ v₂ }}}
      !#l.(0)
    {{{ RET v₀; record3_model l dq v₀ v₁ v₂ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.
  Lemma record3_get1_spec l dq v₀ v₁ v₂ :
    {{{ record3_model l dq v₀ v₁ v₂ }}}
      !#l.(1)
    {{{ RET v₁; record3_model l dq v₀ v₁ v₂ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.
  Lemma record3_get2_spec l dq v₀ v₁ v₂ :
    {{{ record3_model l dq v₀ v₁ v₂ }}}
      !#l.(2)
    {{{ RET v₂; record3_model l dq v₀ v₁ v₂ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.

  Lemma record3_set0_spec l v₀ v₁ v₂ v :
    {{{ record3_model l (DfracOwn 1) v₀ v₁ v₂ }}}
      #l.(0) <- v
    {{{ RET #(); record3_model l (DfracOwn 1) v v₁ v₂ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.
  Lemma record3_set1_spec l v₀ v₁ v₂ v :
    {{{ record3_model l (DfracOwn 1) v₀ v₁ v₂ }}}
      #l.(1) <- v
    {{{ RET #(); record3_model l (DfracOwn 1) v₀ v v₂ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.
  Lemma record3_set2_spec l v₀ v₁ v₂ v :
    {{{ record3_model l (DfracOwn 1) v₀ v₁ v₂ }}}
      #l.(2) <- v
    {{{ RET #(); record3_model l (DfracOwn 1) v₀ v₁ v }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.
End heapGS.

#[global] Opaque record3_make.

#[global] Opaque record3_model.


Require Import VST.floyd.proofauto.
Require Import mk_acc.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition malloc_spec :=
  DECLARE _malloc
        WITH t: type
        PRE [ tuint ]
        PROP()
        PARAMS(Vint (Int.repr (sizeof t)))
        SEP()
        POST [tptr tvoid] EX p:_,
        PROP()
        RETURN(p)
        SEP(data_at_ Tsh t p).

Inductive account_card : Set :=
    | account_card_0 : account_card.

Fixpoint account (x: val) (id: Z) (bal: Z) (self_card: account_card) {struct self_card} : mpred := match self_card with
    | account_card_0  =>  !!(is_true true) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr id)) : val)); (inl ((Vint (Int.repr bal)) : val))] (x : val))
end.

Definition mk_acc_spec :=
  DECLARE _mk_acc
   WITH r: val, id: val, bal: Z
   PRE [ (tptr (Tunion _sslval noattr)), tint ]
   PROP( is_pointer_or_null((r : val)); ssl_is_valid_int((id : val)) )
   PARAMS(r; id)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inl ((Vint (Int.repr bal)) : val))] (r : val)))
   POST[ tvoid ]
   EX x: val,
   EX _alpha_513: account_card,
   PROP( is_pointer_or_null((x : val)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (x : val))] (r : val)); (account (x : val) (force_signed_int (id : val)) (bal : Z) (_alpha_513 : account_card))).

Lemma account_x_valid_pointerP x id bal self_card: account x id bal self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve account_x_valid_pointerP : valid_pointer.
Lemma account_local_factsP x id bal self_card :
  account x id bal self_card|-- !!((((is_true true)) -> (self_card = account_card_0))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve account_local_factsP : saturate_local.
Lemma unfold_account_card_0  (x: val) (id: Z) (bal: Z) : account x id bal (account_card_0 ) =  !!(is_true true) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr id)) : val)); (inl ((Vint (Int.repr bal)) : val))] (x : val)). Proof. auto. Qed.
Definition Gprog : funspecs :=
  ltac:(with_library prog [mk_acc_spec; malloc_spec]).

Lemma body_mk_acc : semax_body Vprog Gprog f_mk_acc mk_acc_spec.
Proof.
start_function.
ssl_open_context.
assert_PROP (isptr r). { entailer!. }
try rename bal into bal2.
forward.
forward_call (tarray (Tunion _sslval noattr) 2).
Intros x2.
assert_PROP (isptr x2). { entailer!. }
forward.
forward.
forward.
forward; entailer!.
Exists (x2 : val).
Exists (account_card_0  : account_card).
ssl_entailer.
rewrite (unfold_account_card_0 ) at 1.
ssl_entailer.

Qed.


Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BILogicFunc.
Require Import MirrorCharge.SynSepLog.
Require Import MirrorCharge.SepLogFold.
Require Export MirrorCore.RTac.RTac.
Require Export MirrorCore.RTac.Core.
(*Require Import MirrorCore.STac.STac.*)
Require Export mc_reify.bool_funcs.
Require MirrorCore.syms.SymEnv.
Require MirrorCore.syms.SymSum.
Require Import MirrorCore.Subst.FMapSubst.
(*Require Import MirrorCharge.RTac.ReifyLemma.*)
Require Import floyd_funcs.
Require Export MirrorCore.Lambda.Expr.
Require Export mc_reify.types.
Require Export mc_reify.func_eq.
Require Export mc_reify.funcs.

Definition typeof_func_opt t := Some (typeof_func t).

Definition eqb_sym a b := match func_beq a b with
                        | true => Some true
                        | false => None
end.

Global Instance RSym_Func' : SymI.RSym func' := {
   typeof_sym := typeof_func_opt;
   symD := funcD;
   sym_eqb := eqb_sym
}.

Global Instance RSymOk_Func' : SymI.RSymOk RSym_Func'.
constructor.
intros. unfold sym_eqb. simpl. unfold eqb_sym. simpl.
destruct (func_beq a b) eqn :?. apply func_beq_sound. auto.
auto.
Qed.

Definition appR (e1 : func') e2 :=
App (@Inj typ func (inr e1)) (e2).
Definition injR (e1 : func') := @Inj typ func (inr e1).

Instance ILogicOps_mpred : ILogic.ILogicOps expr.mpred := {
lentails := derives;
ltrue := TT;
lfalse := FF;
land := andp;
lor := orp;
limpl := imp;
lforall := @allp mpred _;
lexists := @exp mpred _
}.

Instance ILogic_mpred : ILogic.ILogic mpred.
Proof.
split; intros.
+ split.
  * intro x; apply derives_refl.
  * intros x y z Hxy Hyz; apply derives_trans with y; assumption.
+ apply prop_right. apply I.
+ apply prop_left. intro H; destruct H.
+ apply allp_left with x; assumption.
+ apply allp_right; apply H.
+ apply exp_left; apply H.
+ apply exp_right with x; apply H.
+ apply andp_left1; apply H.
+ apply andp_left2; apply H.
+ apply orp_right1; apply H.
+ apply orp_right2; apply H.
+ apply andp_right; [apply H | apply H0].
+ apply orp_left; [apply H | apply H0].
+ apply imp_andp_adjoint. apply H.
+ apply imp_andp_adjoint. apply H.
Qed.

Instance BILOperators_mpred : BILogic.BILOperators mpred := {
  empSP := emp;
  sepSP := sepcon;
  wandSP := wand
}.

Instance BILogic_mpred : BILogic.BILogic mpred.
Proof.
split; intros.
+ apply _.
+ unfold BILogic.sepSP; simpl; rewrite sepcon_comm; apply derives_refl.
+ unfold BILogic.sepSP; simpl; rewrite sepcon_assoc; apply derives_refl.
+ apply wand_sepcon_adjoint.
+ apply sepcon_derives; [apply H | apply derives_refl].
+ unfold BILogic.sepSP; simpl; rewrite sepcon_emp; reflexivity.
Qed.

Definition ilops : @logic_ops _ RType_typ :=
fun t =>
  match t
          return option (ILogic.ILogicOps (typD t))
  with
  | tympred => Some _
  | typrop => Some _
  | _ => None
end.

Definition bilops : @bilogic_ops _ RType_typ :=
fun t =>
  match t
          return option (BILogic.BILOperators (typD t))
  with
  | tympred => Some _
  | _ => None
end.

Instance RSym_ilfunc : RSym (@ilfunc typ) :=
	RSym_ilfunc _ _ ilops.
Instance RSym_bilfunc : RSym (@bilfunc typ) :=
	RSym_bilfunc _ bilops.

Existing Instance SymSum.RSym_sum.
Existing Instance SymSum.RSymOk_sum.

Definition subst : Type :=
  FMapSubst.SUBST.raw (expr typ func).
Instance SS : SubstI.Subst subst (expr typ func) :=
  @FMapSubst.SUBST.Subst_subst _.
(*Instance SU : SubstI.SubstUpdate subst (expr typ func) :=
  FMapSubst.SUBST.SubstUpdate_subst (@instantiate typ func).
Instance SO : SubstI.SubstOk SS :=
  @FMapSubst.SUBST.SubstOk_subst typ RType_typ (expr typ func) _ _.
*)

Definition RSym_sym fs := SymSum.RSym_sum
  (SymSum.RSym_sum (SymSum.RSym_sum (SymEnv.RSym_func fs) RSym_ilfunc) RSym_bilfunc)
  RSym_Func'.

SearchAbout Expr.
Definition Expr_expr_fs fs: ExprI.Expr _ (ExprCore.expr typ func) := @ExprD.Expr_expr typ func _ _ (RSym_sym fs).
Definition Expr_ok_fs fs: @ExprI.ExprOk typ RType_typ (ExprCore.expr typ func) (Expr_expr_fs fs) := ExprD.ExprOk_expr.

Definition reflect ft tus tvs e (ty : typ)
 := @exprD _ _ _ (Expr_expr_fs ft) tus tvs e ty.

Definition reflect_prop tbl e := reflect tbl nil nil e (typrop).

Definition reflect_prop' tbl e := match (reflect tbl nil nil e typrop) with
| Some p => p
| None => False
end.

Definition node l o r t : expr typ func :=
(App (App (App (Inj (inr (Data (fnode t)))) l) o) r).

Definition leaf t : expr typ func:=
(Inj (inr (Data (fleaf t)))).

Definition some_reif e t : expr typ func :=
(App (Inj (inr (Other (fsome t)))) e).

Definition none_reif t : expr typ func :=
(Inj (inr (Other (fnone t)))).

Instance MA : MentionsAny (expr typ func) := {
  mentionsAny := ExprCore.mentionsAny
}.

Let elem_ctor : forall x : typ, typD x -> @SymEnv.function typ _ :=
  @SymEnv.F _ _.

Let Ext x := @ExprCore.Inj typ func (inl (inl (inl x))).

Section tbled.

Variable tbl : SymEnv.functions RType_typ.

Let RSym_sym := RSym_sym tbl.
Existing Instance RSym_sym.
Let Expr_expr := Expr_expr_fs tbl.
Existing Instance Expr_expr.
Existing Instance Expr_ok_fs.

Definition exprD_Prop (uvar_env var_env : EnvI.env) (e : expr typ func) :=
  match exprD uvar_env var_env e typrop with
    | Some e' => e'
    | None => True
  end.

Definition goalD_Prop (uvar_env var_env : EnvI.env) goal :=
  let (tus, us) := split_env uvar_env in
  let (tvs, vs) := split_env var_env in
  match goalD tus tvs goal with
    | Some e => e us vs
    | None => False
  end.

Definition goalD_aux tus tvs goal (us : HList.hlist typD tus) (vs : HList.hlist typD tvs) :=
  match goalD tus tvs goal with
    | Some e => Some (e us vs)
    | None => None
  end.

End tbled.