(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

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

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Preamble *)

Require BitTerminationProofs.

(* Converted imports: *)

Require Coq.Init.Peano.
Require Coq.NArith.BinNat.
Require Coq.Numbers.BinNums.
Require Data.Bits.
Require Data.Foldable.
Require Data.Maybe.
Require Data.Tuple.
Require GHC.Base.
Require GHC.Err.
Require GHC.Num.
Require GHC.Wf.
Require Utils.Containers.Internal.BitUtil.
Import Data.Bits.Notations.
Import GHC.Base.Notations.
Import GHC.Num.Notations.

(* Converted type declarations: *)

Definition Prefix :=
  Coq.Numbers.BinNums.N.

Definition Nat :=
  Coq.Numbers.BinNums.N.

Definition Mask :=
  Coq.Numbers.BinNums.N.

Definition Key :=
  Coq.Numbers.BinNums.N%type.

Definition BitMap :=
  Coq.Numbers.BinNums.N.

Inductive IntSet : Type
  := Bin : Prefix -> Mask -> IntSet -> IntSet -> IntSet
  |  Tip : Prefix -> BitMap -> IntSet
  |  Nil : IntSet.

Inductive Stack : Type
  := Push : Prefix -> IntSet -> Stack -> Stack
  |  Nada : Stack.

Instance Default__IntSet : GHC.Err.Default IntSet :=
  GHC.Err.Build_Default _ Nil.

Instance Default__Stack : GHC.Err.Default Stack := GHC.Err.Build_Default _ Nada.

(* Midamble *)

(** Additional definitions for termination proof *)

Fixpoint size_nat (t : IntSet) : nat :=
  match t with
  | Bin _ _ l r => S (size_nat l + size_nat r)%nat
  | Tip _ bm => 0
  | Nil => 0
  end.

Require Omega.
Ltac termination_by_omega :=
  Coq.Program.Tactics.program_simpl;
  simpl;Omega.omega.

Require Import Coq.NArith.NArith.
(* Z.ones 6 = 64-1 *)
(* Definition suffixBitMask := Coq.NArith.BinNat.N.ones 6%N. *)

(* Converted value declarations: *)

Definition zero : Coq.Numbers.BinNums.N -> Mask -> bool :=
  fun i m => ((i) Data.Bits..&.(**) (m)) GHC.Base.== #0.

Definition tip : Prefix -> BitMap -> IntSet :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | _, num_2__ =>
        if num_2__ GHC.Base.== #0 : bool then Nil else
        match arg_0__, arg_1__ with
        | kx, bm => Tip kx bm
        end
    end.

Definition suffixBitMask :=
  Coq.NArith.BinNat.N.ones 6.

Definition suffixOf : Coq.Numbers.BinNums.N -> Coq.Numbers.BinNums.N :=
  fun x => x Data.Bits..&.(**) suffixBitMask.

Definition splitRoot : IntSet -> list IntSet :=
  fun arg_0__ =>
    match arg_0__ with
    | Nil => nil
    | (Tip _ _ as x) => cons x nil
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool then cons r (cons l nil) else
        cons l (cons r nil)
    end.

Definition size : IntSet -> Coq.Numbers.BinNums.N :=
  let fix go arg_0__ arg_1__
            := match arg_0__, arg_1__ with
               | acc, Bin _ _ l r => go (go acc l) r
               | acc, Tip _ bm =>
                   acc GHC.Num.+ Utils.Containers.Internal.BitUtil.bitcount #0 bm
               | acc, Nil => acc
               end in
  go #0.

Definition shorter : Mask -> Mask -> bool :=
  fun m1 m2 => (m1) GHC.Base.> (m2).

Definition revNat : Nat -> Nat :=
  fun x1 =>
    let 'x2 := ((Utils.Containers.Internal.BitUtil.shiftRL x1 #1) Data.Bits..&.(**)
                  #6148914691236517205) Data.Bits..|.(**)
                 (Utils.Containers.Internal.BitUtil.shiftLL (x1 Data.Bits..&.(**)
                                                             #6148914691236517205) #1) in
    let 'x3 := ((Utils.Containers.Internal.BitUtil.shiftRL x2 #2) Data.Bits..&.(**)
                  #3689348814741910323) Data.Bits..|.(**)
                 (Utils.Containers.Internal.BitUtil.shiftLL (x2 Data.Bits..&.(**)
                                                             #3689348814741910323) #2) in
    let 'x4 := ((Utils.Containers.Internal.BitUtil.shiftRL x3 #4) Data.Bits..&.(**)
                  #1085102592571150095) Data.Bits..|.(**)
                 (Utils.Containers.Internal.BitUtil.shiftLL (x3 Data.Bits..&.(**)
                                                             #1085102592571150095) #4) in
    let 'x5 := ((Utils.Containers.Internal.BitUtil.shiftRL x4 #8) Data.Bits..&.(**)
                  #71777214294589695) Data.Bits..|.(**)
                 (Utils.Containers.Internal.BitUtil.shiftLL (x4 Data.Bits..&.(**)
                                                             #71777214294589695) #8) in
    let 'x6 := ((Utils.Containers.Internal.BitUtil.shiftRL x5 #16) Data.Bits..&.(**)
                  #281470681808895) Data.Bits..|.(**)
                 (Utils.Containers.Internal.BitUtil.shiftLL (x5 Data.Bits..&.(**)
                                                             #281470681808895) #16) in
    (Utils.Containers.Internal.BitUtil.shiftRL x6 #32) Data.Bits..|.(**)
    (Utils.Containers.Internal.BitUtil.shiftLL x6 #32).

Definition prefixOf : Coq.Numbers.BinNums.N -> Prefix :=
  fun x => Coq.NArith.BinNat.N.ldiff x suffixBitMask.

Definition null : IntSet -> bool :=
  fun arg_0__ => match arg_0__ with | Nil => true | _ => false end.

Definition nequal : IntSet -> IntSet -> bool :=
  fix nequal arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | Bin p1 m1 l1 r1, Bin p2 m2 l2 r2 =>
               orb (m1 GHC.Base./= m2) (orb (p1 GHC.Base./= p2) (orb (nequal l1 l2) (nequal r1
                                                                      r2)))
           | Tip kx1 bm1, Tip kx2 bm2 => orb (kx1 GHC.Base./= kx2) (bm1 GHC.Base./= bm2)
           | Nil, Nil => false
           | _, _ => true
           end.

Definition maskW : Nat -> Nat -> Prefix :=
  fun i m => Coq.NArith.BinNat.N.ldiff i (2 * m - 1 % N).

Definition mask : Coq.Numbers.BinNums.N -> Mask -> Prefix :=
  fun i m => maskW (i) (m).

Definition match_ : Coq.Numbers.BinNums.N -> Prefix -> Mask -> bool :=
  fun i p m => (mask i m) GHC.Base.== p.

Definition nomatch : Coq.Numbers.BinNums.N -> Prefix -> Mask -> bool :=
  fun i p m => (mask i m) GHC.Base./= p.

Definition subsetCmp : IntSet -> IntSet -> comparison :=
  fix subsetCmp arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | (Bin p1 m1 l1 r1 as t1), Bin p2 m2 l2 r2 =>
               let subsetCmpEq :=
                 match pair (subsetCmp l1 l2) (subsetCmp r1 r2) with
                 | pair Gt _ => Gt
                 | pair _ Gt => Gt
                 | pair Eq Eq => Eq
                 | _ => Lt
                 end in
               let subsetCmpLt :=
                 if nomatch p1 p2 m2 : bool then Gt else
                 if zero p1 m2 : bool then subsetCmp t1 l2 else
                 subsetCmp t1 r2 in
               if shorter m1 m2 : bool then Gt else
               if shorter m2 m1 : bool
               then match subsetCmpLt with
                    | Gt => Gt
                    | _ => Lt
                    end else
               if p1 GHC.Base.== p2 : bool then subsetCmpEq else
               Gt
           | _, _ =>
               match arg_0__, arg_1__ with
               | Bin _ _ _ _, _ => Gt
               | Tip kx1 bm1, Tip kx2 bm2 =>
                   if kx1 GHC.Base./= kx2 : bool then Gt else
                   if bm1 GHC.Base.== bm2 : bool then Eq else
                   if Data.Bits.xor bm1 (bm1 Data.Bits..&.(**) bm2) GHC.Base.== #0 : bool
                   then Lt else
                   Gt
               | (Tip kx _ as t1), Bin p m l r =>
                   if nomatch kx p m : bool then Gt else
                   if zero kx m : bool then match subsetCmp t1 l with | Gt => Gt | _ => Lt end else
                   match subsetCmp t1 r with
                   | Gt => Gt
                   | _ => Lt
                   end
               | Tip _ _, Nil => Gt
               | Nil, Nil => Eq
               | Nil, _ => Lt
               end
           end.

Definition isSubsetOf : IntSet -> IntSet -> bool :=
  fix isSubsetOf arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | (Bin p1 m1 l1 r1 as t1), Bin p2 m2 l2 r2 =>
               if shorter m1 m2 : bool then false else
               if shorter m2 m1 : bool
               then andb (match_ p1 p2 m2) (if zero p1 m2 : bool
                          then isSubsetOf t1 l2
                          else isSubsetOf t1 r2) else
               andb (p1 GHC.Base.== p2) (andb (isSubsetOf l1 l2) (isSubsetOf r1 r2))
           | _, _ =>
               match arg_0__, arg_1__ with
               | Bin _ _ _ _, _ => false
               | Tip kx1 bm1, Tip kx2 bm2 =>
                   andb (kx1 GHC.Base.== kx2) (Data.Bits.xor bm1 (bm1 Data.Bits..&.(**) bm2)
                         GHC.Base.==
                         #0)
               | (Tip kx _ as t1), Bin p m l r =>
                   if nomatch kx p m : bool then false else
                   if zero kx m : bool then isSubsetOf t1 l else
                   isSubsetOf t1 r
               | Tip _ _, Nil => false
               | Nil, _ => true
               end
           end.

Definition isProperSubsetOf : IntSet -> IntSet -> bool :=
  fun t1 t2 => match subsetCmp t1 t2 with | Lt => true | _ => false end.

Definition indexOfTheOnlyBit :=
  fun x => Coq.NArith.BinNat.N.log2 x.

Definition lowestBitSet : Nat -> Coq.Numbers.BinNums.N :=
  fun x => indexOfTheOnlyBit (Utils.Containers.Internal.BitUtil.lowestBitMask x).

Definition unsafeFindMin : IntSet -> option Key :=
  fix unsafeFindMin arg_0__
        := match arg_0__ with
           | Nil => None
           | Tip kx bm => Some (kx GHC.Num.+ lowestBitSet bm)
           | Bin _ _ l _ => unsafeFindMin l
           end.

Definition highestBitSet : Nat -> Coq.Numbers.BinNums.N :=
  fun x => indexOfTheOnlyBit (Utils.Containers.Internal.BitUtil.highestBitMask x).

Definition unsafeFindMax : IntSet -> option Key :=
  fix unsafeFindMax arg_0__
        := match arg_0__ with
           | Nil => None
           | Tip kx bm => Some (kx GHC.Num.+ highestBitSet bm)
           | Bin _ _ _ r => unsafeFindMax r
           end.

Definition revNatSafe n :=
  Coq.NArith.BinNat.N.modulo (revNat n) (Coq.NArith.BinNat.N.pow 2 64).

Program Definition foldrBits {a}
           : Coq.Numbers.BinNums.N ->
             (Coq.Numbers.BinNums.N -> a -> a) -> a -> Nat -> a :=
          fun prefix f z bitmap =>
            let go :=
              GHC.Wf.wfFix2 Coq.Init.Peano.lt (fun arg_0__ arg_1__ =>
                               Coq.NArith.BinNat.N.to_nat arg_0__) _ (fun arg_0__ arg_1__ go =>
                               match arg_0__, arg_1__ with
                               | num_2__, acc =>
                                   if Bool.Sumbool.sumbool_of_bool (num_2__ GHC.Base.== #0) then acc else
                                   match arg_0__, arg_1__ with
                                   | bm, acc =>
                                       let bitmask := Utils.Containers.Internal.BitUtil.lowestBitMask bm in
                                       let bi := indexOfTheOnlyBit bitmask in
                                       go (Data.Bits.xor bm bitmask) ((f ((prefix GHC.Num.+ (#64 GHC.Num.- #1))
                                                                          GHC.Num.-
                                                                          bi)) acc)
                                   end
                               end) in
            go (revNatSafe bitmap) z.
Solve Obligations with (BitTerminationProofs.termination_foldl).

Program Definition foldr'Bits {a}
           : Coq.Numbers.BinNums.N ->
             (Coq.Numbers.BinNums.N -> a -> a) -> a -> Nat -> a :=
          fun prefix f z bitmap =>
            let go :=
              GHC.Wf.wfFix2 Coq.Init.Peano.lt (fun arg_0__ arg_1__ =>
                               Coq.NArith.BinNat.N.to_nat arg_0__) _ (fun arg_0__ arg_1__ go =>
                               match arg_0__, arg_1__ with
                               | num_2__, acc =>
                                   if Bool.Sumbool.sumbool_of_bool (num_2__ GHC.Base.== #0) then acc else
                                   match arg_0__, arg_1__ with
                                   | bm, acc =>
                                       let bitmask := Utils.Containers.Internal.BitUtil.lowestBitMask bm in
                                       let bi := indexOfTheOnlyBit bitmask in
                                       go (Data.Bits.xor bm bitmask) ((f ((prefix GHC.Num.+ (#64 GHC.Num.- #1))
                                                                          GHC.Num.-
                                                                          bi)) acc)
                                   end
                               end) in
            go (revNatSafe bitmap) z.
Solve Obligations with (BitTerminationProofs.termination_foldl).

Definition foldr' {b} : (Key -> b -> b) -> b -> IntSet -> b :=
  fun f z =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | z', Nil => z'
                 | z', Tip kx bm => foldr'Bits kx f z' bm
                 | z', Bin _ _ l r => go (go z' r) l
                 end in
    fun t =>
      match t with
      | Bin _ m l r => if m GHC.Base.< #0 : bool then go (go z l) r else go (go z r) l
      | _ => go z t
      end.

Definition foldr {b} : (Key -> b -> b) -> b -> IntSet -> b :=
  fun f z =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | z', Nil => z'
                 | z', Tip kx bm => foldrBits kx f z' bm
                 | z', Bin _ _ l r => go (go z' r) l
                 end in
    fun t =>
      match t with
      | Bin _ m l r => if m GHC.Base.< #0 : bool then go (go z l) r else go (go z r) l
      | _ => go z t
      end.

Definition foldrFB {b} : (Key -> b -> b) -> b -> IntSet -> b :=
  foldr.

Definition toAscList : IntSet -> list Key :=
  foldr cons nil.

Definition toList : IntSet -> list Key :=
  toAscList.

Program Definition foldlBits {a}
           : Coq.Numbers.BinNums.N ->
             (a -> Coq.Numbers.BinNums.N -> a) -> a -> Nat -> a :=
          fun prefix f z bitmap =>
            let go :=
              GHC.Wf.wfFix2 Coq.Init.Peano.lt (fun arg_0__ arg_1__ =>
                               Coq.NArith.BinNat.N.to_nat arg_0__) _ (fun arg_0__ arg_1__ go =>
                               match arg_0__, arg_1__ with
                               | num_2__, acc =>
                                   if Bool.Sumbool.sumbool_of_bool (num_2__ GHC.Base.== #0) then acc else
                                   match arg_0__, arg_1__ with
                                   | bm, acc =>
                                       let bitmask := Utils.Containers.Internal.BitUtil.lowestBitMask bm in
                                       let bi := indexOfTheOnlyBit bitmask in
                                       go (Data.Bits.xor bm bitmask) (f acc (prefix GHC.Num.+ bi))
                                   end
                               end) in
            go bitmap z.
Solve Obligations with (BitTerminationProofs.termination_foldl).

Program Definition foldl'Bits {a}
           : Coq.Numbers.BinNums.N ->
             (a -> Coq.Numbers.BinNums.N -> a) -> a -> Nat -> a :=
          fun prefix f z bitmap =>
            let go :=
              GHC.Wf.wfFix2 Coq.Init.Peano.lt (fun arg_0__ arg_1__ =>
                               Coq.NArith.BinNat.N.to_nat arg_0__) _ (fun arg_0__ arg_1__ go =>
                               match arg_0__, arg_1__ with
                               | num_2__, acc =>
                                   if Bool.Sumbool.sumbool_of_bool (num_2__ GHC.Base.== #0) then acc else
                                   match arg_0__, arg_1__ with
                                   | bm, acc =>
                                       let bitmask := Utils.Containers.Internal.BitUtil.lowestBitMask bm in
                                       let bi := indexOfTheOnlyBit bitmask in
                                       go (Data.Bits.xor bm bitmask) (f acc (prefix GHC.Num.+ bi))
                                   end
                               end) in
            go bitmap z.
Solve Obligations with (BitTerminationProofs.termination_foldl).

Definition foldl' {a} : (a -> Key -> a) -> a -> IntSet -> a :=
  fun f z =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | z', Nil => z'
                 | z', Tip kx bm => foldl'Bits kx f z' bm
                 | z', Bin _ _ l r => go (go z' l) r
                 end in
    fun t =>
      match t with
      | Bin _ m l r => if m GHC.Base.< #0 : bool then go (go z r) l else go (go z l) r
      | _ => go z t
      end.

Definition foldl {a} : (a -> Key -> a) -> a -> IntSet -> a :=
  fun f z =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | z', Nil => z'
                 | z', Tip kx bm => foldlBits kx f z' bm
                 | z', Bin _ _ l r => go (go z' l) r
                 end in
    fun t =>
      match t with
      | Bin _ m l r => if m GHC.Base.< #0 : bool then go (go z r) l else go (go z l) r
      | _ => go z t
      end.

Definition foldlFB {a} : (a -> Key -> a) -> a -> IntSet -> a :=
  foldl.

Definition toDescList : IntSet -> list Key :=
  foldl (GHC.Base.flip cons) nil.

Definition fold {b} : (Key -> b -> b) -> b -> IntSet -> b :=
  foldr.

Definition equal : IntSet -> IntSet -> bool :=
  fix equal arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | Bin p1 m1 l1 r1, Bin p2 m2 l2 r2 =>
               andb (m1 GHC.Base.== m2) (andb (p1 GHC.Base.== p2) (andb (equal l1 l2) (equal r1
                                                                         r2)))
           | Tip kx1 bm1, Tip kx2 bm2 => andb (kx1 GHC.Base.== kx2) (bm1 GHC.Base.== bm2)
           | Nil, Nil => true
           | _, _ => false
           end.

Definition empty : IntSet :=
  Nil.

Definition elems : IntSet -> list Key :=
  toAscList.

Program Fixpoint disjoint (arg_0__ : IntSet) (arg_1__ : IntSet)
                          {measure (size_nat arg_0__ + size_nat arg_1__)} : bool
                   := match arg_0__, arg_1__ with
                      | (Bin p1 m1 l1 r1 as t1), (Bin p2 m2 l2 r2 as t2) =>
                          let disjoint2 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p1 p2 m2) then true else
                            if Bool.Sumbool.sumbool_of_bool (zero p1 m2) then disjoint t1 l2 else
                            disjoint t1 r2 in
                          let disjoint1 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p2 p1 m1) then true else
                            if Bool.Sumbool.sumbool_of_bool (zero p2 m1) then disjoint l1 t2 else
                            disjoint r1 t2 in
                          if Bool.Sumbool.sumbool_of_bool (shorter m1 m2) then disjoint1 else
                          if Bool.Sumbool.sumbool_of_bool (shorter m2 m1) then disjoint2 else
                          if Bool.Sumbool.sumbool_of_bool (p1 GHC.Base.== p2)
                          then andb (disjoint l1 l2) (disjoint r1 r2) else
                          true
                      | (Bin _ _ _ _ as t1), Tip kx2 bm2 =>
                          let fix disjointBM arg_11__
                                    := match arg_11__ with
                                       | Bin p1 m1 l1 r1 =>
                                           if Bool.Sumbool.sumbool_of_bool (nomatch kx2 p1 m1) then true else
                                           if Bool.Sumbool.sumbool_of_bool (zero kx2 m1) then disjointBM l1 else
                                           disjointBM r1
                                       | Tip kx1 bm1 =>
                                           if Bool.Sumbool.sumbool_of_bool (kx1 GHC.Base.== kx2)
                                           then (bm1 Data.Bits..&.(**) bm2) GHC.Base.== #0 else
                                           true
                                       | Nil => true
                                       end in
                          disjointBM t1
                      | Bin _ _ _ _, Nil => true
                      | Tip kx1 bm1, t2 =>
                          let fix disjointBM arg_18__
                                    := match arg_18__ with
                                       | Bin p2 m2 l2 r2 =>
                                           if Bool.Sumbool.sumbool_of_bool (nomatch kx1 p2 m2) then true else
                                           if Bool.Sumbool.sumbool_of_bool (zero kx1 m2) then disjointBM l2 else
                                           disjointBM r2
                                       | Tip kx2 bm2 =>
                                           if Bool.Sumbool.sumbool_of_bool (kx1 GHC.Base.== kx2)
                                           then (bm1 Data.Bits..&.(**) bm2) GHC.Base.== #0 else
                                           true
                                       | Nil => true
                                       end in
                          disjointBM t2
                      | Nil, _ => true
                      end.
Solve Obligations with (termination_by_omega).

Definition branchMask : Prefix -> Prefix -> Mask :=
  fun p1 p2 =>
    Coq.NArith.BinNat.N.pow 2 (Coq.NArith.BinNat.N.log2 (Coq.NArith.BinNat.N.lxor p1
                                                                                p2)).

Definition link : Prefix -> IntSet -> Prefix -> IntSet -> IntSet :=
  fun p1 t1 p2 t2 =>
    let m := branchMask p1 p2 in
    let p := mask p1 m in if zero p1 m : bool then Bin p m t1 t2 else Bin p m t2 t1.

Definition insertBM : Prefix -> BitMap -> IntSet -> IntSet :=
  fix insertBM arg_0__ arg_1__ arg_2__
        := match arg_0__, arg_1__, arg_2__ with
           | kx, bm, (Bin p m l r as t) =>
               if nomatch kx p m : bool then link kx (Tip kx bm) p t else
               if zero kx m : bool then Bin p m (insertBM kx bm l) r else
               Bin p m l (insertBM kx bm r)
           | kx, bm, (Tip kx' bm' as t) =>
               if kx' GHC.Base.== kx : bool then Tip kx' (bm Data.Bits..|.(**) bm') else
               link kx (Tip kx bm) kx' t
           | kx, bm, Nil => Tip kx bm
           end.

Program Fixpoint union (arg_0__ : IntSet) (arg_1__ : IntSet) {measure (size_nat
                        arg_0__ +
                        size_nat arg_1__)} : IntSet
                   := match arg_0__, arg_1__ with
                      | (Bin p1 m1 l1 r1 as t1), (Bin p2 m2 l2 r2 as t2) =>
                          let union2 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p1 p2 m2) then link p1 t1 p2 t2 else
                            if Bool.Sumbool.sumbool_of_bool (zero p1 m2)
                            then Bin p2 m2 (union t1 l2) r2 else
                            Bin p2 m2 l2 (union t1 r2) in
                          let union1 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p2 p1 m1) then link p1 t1 p2 t2 else
                            if Bool.Sumbool.sumbool_of_bool (zero p2 m1)
                            then Bin p1 m1 (union l1 t2) r1 else
                            Bin p1 m1 l1 (union r1 t2) in
                          if Bool.Sumbool.sumbool_of_bool (shorter m1 m2) then union1 else
                          if Bool.Sumbool.sumbool_of_bool (shorter m2 m1) then union2 else
                          if Bool.Sumbool.sumbool_of_bool (p1 GHC.Base.== p2)
                          then Bin p1 m1 (union l1 l2) (union r1 r2) else
                          link p1 t1 p2 t2
                      | (Bin _ _ _ _ as t), Tip kx bm => insertBM kx bm t
                      | (Bin _ _ _ _ as t), Nil => t
                      | Tip kx bm, t => insertBM kx bm t
                      | Nil, t => t
                      end.
Solve Obligations with (termination_by_omega).

Definition unions {f} `{Data.Foldable.Foldable f} : f IntSet -> IntSet :=
  fun xs => Data.Foldable.foldl' union empty xs.

Definition bitmapOfSuffix : Coq.Numbers.BinNums.N -> BitMap :=
  fun s => Utils.Containers.Internal.BitUtil.shiftLL #1 s.

Definition bitmapOf : Coq.Numbers.BinNums.N -> BitMap :=
  fun x => bitmapOfSuffix (suffixOf x).

Definition insert : Key -> IntSet -> IntSet :=
  fun x => insertBM (prefixOf x) (bitmapOf x).

Definition fromList : list Key -> IntSet :=
  fun xs => let ins := fun t x => insert x t in Data.Foldable.foldl' ins empty xs.

Definition map : (Key -> Key) -> IntSet -> IntSet :=
  fun f => fromList GHC.Base.∘ (GHC.Base.map f GHC.Base.∘ toList).

Definition lookupGE : Key -> IntSet -> option Key :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | def, Bin p m l r =>
                     if nomatch x p m : bool
                     then if x GHC.Base.< p : bool
                          then unsafeFindMin l
                          else unsafeFindMin def else
                     if zero x m : bool then go r l else
                     go def r
                 | def, Tip kx bm =>
                     let maskGE :=
                       (Coq.NArith.BinNat.N.ldiff (Coq.NArith.BinNat.N.ones (64 % N))
                                                  (Coq.NArith.BinNat.N.pred (bitmapOf x))) Data.Bits..&.(**)
                       bm in
                     if prefixOf x GHC.Base.< kx : bool then Some (kx GHC.Num.+ lowestBitSet bm) else
                     if andb (prefixOf x GHC.Base.== kx) (maskGE GHC.Base./= #0) : bool
                     then Some (kx GHC.Num.+ lowestBitSet maskGE) else
                     unsafeFindMin def
                 | def, Nil => unsafeFindMin def
                 end in
    let j_12__ := go Nil t in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then go Nil l
             else go l r else
        j_12__
    | _ => j_12__
    end.

Definition lookupGT : Key -> IntSet -> option Key :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | def, Bin p m l r =>
                     if nomatch x p m : bool
                     then if x GHC.Base.< p : bool
                          then unsafeFindMin l
                          else unsafeFindMin def else
                     if zero x m : bool then go r l else
                     go def r
                 | def, Tip kx bm =>
                     let maskGT :=
                       (Coq.NArith.BinNat.N.ldiff (Coq.NArith.BinNat.N.ones (64 % N))
                                                  (Coq.NArith.BinNat.N.pred (Utils.Containers.Internal.BitUtil.shiftLL
                                                                             (bitmapOf x) #1))) Data.Bits..&.(**)
                       bm in
                     if prefixOf x GHC.Base.< kx : bool then Some (kx GHC.Num.+ lowestBitSet bm) else
                     if andb (prefixOf x GHC.Base.== kx) (maskGT GHC.Base./= #0) : bool
                     then Some (kx GHC.Num.+ lowestBitSet maskGT) else
                     unsafeFindMin def
                 | def, Nil => unsafeFindMin def
                 end in
    let j_12__ := go Nil t in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then go Nil l
             else go l r else
        j_12__
    | _ => j_12__
    end.

Definition lookupLE : Key -> IntSet -> option Key :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | def, Bin p m l r =>
                     if nomatch x p m : bool
                     then if x GHC.Base.< p : bool
                          then unsafeFindMax def
                          else unsafeFindMax r else
                     if zero x m : bool then go def l else
                     go l r
                 | def, Tip kx bm =>
                     let maskLE :=
                       ((Utils.Containers.Internal.BitUtil.shiftLL (bitmapOf x) #1) GHC.Num.- #1)
                       Data.Bits..&.(**)
                       bm in
                     if prefixOf x GHC.Base.> kx : bool
                     then Some (kx GHC.Num.+ highestBitSet bm) else
                     if andb (prefixOf x GHC.Base.== kx) (maskLE GHC.Base./= #0) : bool
                     then Some (kx GHC.Num.+ highestBitSet maskLE) else
                     unsafeFindMax def
                 | def, Nil => unsafeFindMax def
                 end in
    let j_12__ := go Nil t in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then go r l
             else go Nil r else
        j_12__
    | _ => j_12__
    end.

Definition lookupLT : Key -> IntSet -> option Key :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | def, Bin p m l r =>
                     if nomatch x p m : bool
                     then if x GHC.Base.< p : bool
                          then unsafeFindMax def
                          else unsafeFindMax r else
                     if zero x m : bool then go def l else
                     go l r
                 | def, Tip kx bm =>
                     let maskLT := (bitmapOf x GHC.Num.- #1) Data.Bits..&.(**) bm in
                     if prefixOf x GHC.Base.> kx : bool
                     then Some (kx GHC.Num.+ highestBitSet bm) else
                     if andb (prefixOf x GHC.Base.== kx) (maskLT GHC.Base./= #0) : bool
                     then Some (kx GHC.Num.+ highestBitSet maskLT) else
                     unsafeFindMax def
                 | def, Nil => unsafeFindMax def
                 end in
    let j_12__ := go Nil t in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then go r l
             else go Nil r else
        j_12__
    | _ => j_12__
    end.

Definition member : Key -> IntSet -> bool :=
  fun x =>
    let fix go arg_0__
              := match arg_0__ with
                 | Bin p m l r =>
                     if nomatch x p m : bool then false else
                     if zero x m : bool then go l else
                     go r
                 | Tip y bm =>
                     andb (prefixOf x GHC.Base.== y) ((bitmapOf x Data.Bits..&.(**) bm) GHC.Base./=
                           #0)
                 | Nil => false
                 end in
    go.

Definition notMember : Key -> IntSet -> bool :=
  fun k => negb GHC.Base.∘ member k.

Definition singleton : Key -> IntSet :=
  fun x => Tip (prefixOf x) (bitmapOf x).

Definition split : Key -> IntSet -> (IntSet * IntSet)%type :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | x', (Bin p m l r as t') =>
                     if match_ x' p m : bool
                     then if zero x' m : bool
                          then let 'pair lt gt := go x' l in
                               pair lt (union gt r)
                          else let 'pair lt gt := go x' r in
                               pair (union lt l) gt else
                     if x' GHC.Base.< p : bool
                     then (pair Nil t')
                     else (pair t' Nil)
                 | x', (Tip kx' bm as t') =>
                     let lowerBitmap := bitmapOf x' GHC.Num.- #1 in
                     let higherBitmap :=
                       Coq.NArith.BinNat.N.ldiff (Coq.NArith.BinNat.N.ones (64 % N)) (lowerBitmap
                                                  GHC.Num.+
                                                  bitmapOf x') in
                     if kx' GHC.Base.> x' : bool then (pair Nil t') else
                     if kx' GHC.Base.< prefixOf x' : bool then (pair t' Nil) else
                     pair (tip kx' (bm Data.Bits..&.(**) lowerBitmap)) (tip kx' (bm Data.Bits..&.(**)
                                                                                higherBitmap))
                 | _, Nil => (pair Nil Nil)
                 end in
    let j_21__ := let 'pair lt gt := go x t in pair lt gt in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then let 'pair lt gt := go x l in
                  let lt' := union lt r in pair lt' gt
             else let 'pair lt gt := go x r in
                  let gt' := union gt l in pair lt gt' else
        j_21__
    | _ => j_21__
    end.

Definition splitMember : Key -> IntSet -> (IntSet * bool * IntSet)%type :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | x', (Bin p m l r as t') =>
                     if match_ x' p m : bool
                     then if zero x' m : bool
                          then let 'pair (pair lt fnd) gt := go x' l in
                               pair (pair lt fnd) (union gt r)
                          else let 'pair (pair lt fnd) gt := go x' r in
                               pair (pair (union lt l) fnd) gt else
                     if x' GHC.Base.< p : bool
                     then pair (pair Nil false) t'
                     else pair (pair t' false) Nil
                 | x', (Tip kx' bm as t') =>
                     let bitmapOfx' := bitmapOf x' in
                     let lowerBitmap := bitmapOfx' GHC.Num.- #1 in
                     let higherBitmap :=
                       Coq.NArith.BinNat.N.ldiff (Coq.NArith.BinNat.N.ones (64 % N)) (lowerBitmap
                                                  GHC.Num.+
                                                  bitmapOfx') in
                     if kx' GHC.Base.> x' : bool then pair (pair Nil false) t' else
                     if kx' GHC.Base.< prefixOf x' : bool then pair (pair t' false) Nil else
                     let gt := tip kx' (bm Data.Bits..&.(**) higherBitmap) in
                     let found := (bm Data.Bits..&.(**) bitmapOfx') GHC.Base./= #0 in
                     let lt := tip kx' (bm Data.Bits..&.(**) lowerBitmap) in pair (pair lt found) gt
                 | _, Nil => pair (pair Nil false) Nil
                 end in
    let j_22__ := go x t in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then let 'pair (pair lt fnd) gt := go x l in
                  let lt' := union lt r in pair (pair lt' fnd) gt
             else let 'pair (pair lt fnd) gt := go x r in
                  let gt' := union gt l in pair (pair lt fnd) gt' else
        j_22__
    | _ => j_22__
    end.

Definition bin : Prefix -> Mask -> IntSet -> IntSet -> IntSet :=
  fun arg_0__ arg_1__ arg_2__ arg_3__ =>
    match arg_0__, arg_1__, arg_2__, arg_3__ with
    | _, _, l, Nil => l
    | _, _, Nil, r => r
    | p, m, l, r => Bin p m l r
    end.

Definition deleteBM : Prefix -> BitMap -> IntSet -> IntSet :=
  fix deleteBM arg_0__ arg_1__ arg_2__
        := match arg_0__, arg_1__, arg_2__ with
           | kx, bm, (Bin p m l r as t) =>
               if nomatch kx p m : bool then t else
               if zero kx m : bool then bin p m (deleteBM kx bm l) r else
               bin p m l (deleteBM kx bm r)
           | kx, bm, (Tip kx' bm' as t) =>
               if kx' GHC.Base.== kx : bool
               then tip kx (Data.Bits.xor bm' (bm' Data.Bits..&.(**) bm)) else
               t
           | _, _, Nil => Nil
           end.

Definition delete : Key -> IntSet -> IntSet :=
  fun x => deleteBM (prefixOf x) (bitmapOf x).

Program Fixpoint difference (arg_0__ : IntSet) (arg_1__ : IntSet)
                            {measure (size_nat arg_0__ + size_nat arg_1__)} : IntSet
                   := match arg_0__, arg_1__ with
                      | (Bin p1 m1 l1 r1 as t1), (Bin p2 m2 l2 r2 as t2) =>
                          let difference2 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p1 p2 m2) then t1 else
                            if Bool.Sumbool.sumbool_of_bool (zero p1 m2) then difference t1 l2 else
                            difference t1 r2 in
                          let difference1 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p2 p1 m1) then t1 else
                            if Bool.Sumbool.sumbool_of_bool (zero p2 m1)
                            then bin p1 m1 (difference l1 t2) r1 else
                            bin p1 m1 l1 (difference r1 t2) in
                          if Bool.Sumbool.sumbool_of_bool (shorter m1 m2) then difference1 else
                          if Bool.Sumbool.sumbool_of_bool (shorter m2 m1) then difference2 else
                          if Bool.Sumbool.sumbool_of_bool (p1 GHC.Base.== p2)
                          then bin p1 m1 (difference l1 l2) (difference r1 r2) else
                          t1
                      | (Bin _ _ _ _ as t), Tip kx bm => deleteBM kx bm t
                      | (Bin _ _ _ _ as t), Nil => t
                      | (Tip kx bm as t1), t2 =>
                          let fix differenceTip arg_12__
                                    := match arg_12__ with
                                       | Bin p2 m2 l2 r2 =>
                                           if Bool.Sumbool.sumbool_of_bool (nomatch kx p2 m2) then t1 else
                                           if Bool.Sumbool.sumbool_of_bool (zero kx m2) then differenceTip l2 else
                                           differenceTip r2
                                       | Tip kx2 bm2 =>
                                           if Bool.Sumbool.sumbool_of_bool (kx GHC.Base.== kx2)
                                           then tip kx (Data.Bits.xor bm (bm Data.Bits..&.(**) bm2)) else
                                           t1
                                       | Nil => t1
                                       end in
                          differenceTip t2
                      | Nil, _ => Nil
                      end.
Solve Obligations with (termination_by_omega).

Definition op_zrzr__ : IntSet -> IntSet -> IntSet :=
  fun m1 m2 => difference m1 m2.

Notation "'_\\_'" := (op_zrzr__).

Infix "\\" := (_\\_) (at level 99).

Definition filter : (Key -> bool) -> IntSet -> IntSet :=
  fix filter predicate t
        := let bitPred :=
             fun kx bm bi =>
               if predicate (kx GHC.Num.+ bi) : bool
               then bm Data.Bits..|.(**) bitmapOfSuffix bi else
               bm in
           match t with
           | Bin p m l r => bin p m (filter predicate l) (filter predicate r)
           | Tip kx bm => tip kx (foldl'Bits #0 (bitPred kx) #0 bm)
           | Nil => Nil
           end.

Program Fixpoint intersection (arg_0__ : IntSet) (arg_1__ : IntSet)
                              {measure (size_nat arg_0__ + size_nat arg_1__)} : IntSet
                   := match arg_0__, arg_1__ with
                      | (Bin p1 m1 l1 r1 as t1), (Bin p2 m2 l2 r2 as t2) =>
                          let intersection2 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p1 p2 m2) then Nil else
                            if Bool.Sumbool.sumbool_of_bool (zero p1 m2) then intersection t1 l2 else
                            intersection t1 r2 in
                          let intersection1 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p2 p1 m1) then Nil else
                            if Bool.Sumbool.sumbool_of_bool (zero p2 m1) then intersection l1 t2 else
                            intersection r1 t2 in
                          if Bool.Sumbool.sumbool_of_bool (shorter m1 m2) then intersection1 else
                          if Bool.Sumbool.sumbool_of_bool (shorter m2 m1) then intersection2 else
                          if Bool.Sumbool.sumbool_of_bool (p1 GHC.Base.== p2)
                          then bin p1 m1 (intersection l1 l2) (intersection r1 r2) else
                          Nil
                      | (Bin _ _ _ _ as t1), Tip kx2 bm2 =>
                          let fix intersectBM arg_11__
                                    := match arg_11__ with
                                       | Bin p1 m1 l1 r1 =>
                                           if Bool.Sumbool.sumbool_of_bool (nomatch kx2 p1 m1) then Nil else
                                           if Bool.Sumbool.sumbool_of_bool (zero kx2 m1) then intersectBM l1 else
                                           intersectBM r1
                                       | Tip kx1 bm1 =>
                                           if Bool.Sumbool.sumbool_of_bool (kx1 GHC.Base.== kx2)
                                           then tip kx1 (bm1 Data.Bits..&.(**) bm2) else
                                           Nil
                                       | Nil => Nil
                                       end in
                          intersectBM t1
                      | Bin _ _ _ _, Nil => Nil
                      | Tip kx1 bm1, t2 =>
                          let fix intersectBM arg_18__
                                    := match arg_18__ with
                                       | Bin p2 m2 l2 r2 =>
                                           if Bool.Sumbool.sumbool_of_bool (nomatch kx1 p2 m2) then Nil else
                                           if Bool.Sumbool.sumbool_of_bool (zero kx1 m2) then intersectBM l2 else
                                           intersectBM r2
                                       | Tip kx2 bm2 =>
                                           if Bool.Sumbool.sumbool_of_bool (kx1 GHC.Base.== kx2)
                                           then tip kx1 (bm1 Data.Bits..&.(**) bm2) else
                                           Nil
                                       | Nil => Nil
                                       end in
                          intersectBM t2
                      | Nil, _ => Nil
                      end.
Solve Obligations with (termination_by_omega).

Definition maxView : IntSet -> option (Key * IntSet)%type :=
  fun t =>
    let fix go arg_0__
              := match arg_0__ with
                 | Bin p m l r => let 'pair result r' := go r in pair result (bin p m l r')
                 | Tip kx bm =>
                     let 'bi := highestBitSet bm in
                     pair (kx GHC.Num.+ bi) (tip kx (Data.Bits.xor bm (bm Data.Bits..&.(**)
                                                                    bitmapOfSuffix bi)))
                 | Nil => pair (0 % N) Nil
                 end in
    let j_12__ := Some (go t) in
    match t with
    | Nil => None
    | Bin p m l r =>
        if m GHC.Base.< #0 : bool
        then let 'pair result l' := go l in
             Some (pair result (bin p m l' r)) else
        j_12__
    | _ => j_12__
    end.

Definition deleteMax : IntSet -> IntSet :=
  Data.Maybe.maybe Nil Data.Tuple.snd GHC.Base.∘ maxView.

Definition minView : IntSet -> option (Key * IntSet)%type :=
  fun t =>
    let fix go arg_0__
              := match arg_0__ with
                 | Bin p m l r => let 'pair result l' := go l in pair result (bin p m l' r)
                 | Tip kx bm =>
                     let 'bi := lowestBitSet bm in
                     pair (kx GHC.Num.+ bi) (tip kx (Data.Bits.xor bm (bm Data.Bits..&.(**)
                                                                    bitmapOfSuffix bi)))
                 | Nil => pair (0 % N) Nil
                 end in
    let j_12__ := Some (go t) in
    match t with
    | Nil => None
    | Bin p m l r =>
        if m GHC.Base.< #0 : bool
        then let 'pair result r' := go r in
             Some (pair result (bin p m l r')) else
        j_12__
    | _ => j_12__
    end.

Definition deleteMin : IntSet -> IntSet :=
  Data.Maybe.maybe Nil Data.Tuple.snd GHC.Base.∘ minView.

Definition partition : (Key -> bool) -> IntSet -> (IntSet * IntSet)%type :=
  fun predicate0 t0 =>
    let fix go predicate t
              := let bitPred :=
                   fun kx bm bi =>
                     if predicate (kx GHC.Num.+ bi) : bool
                     then bm Data.Bits..|.(**) bitmapOfSuffix bi else
                     bm in
                 match t with
                 | Bin p m l r =>
                     let 'pair r1 r2 := go predicate r in
                     let 'pair l1 l2 := go predicate l in
                     pair (bin p m l1 r1) (bin p m l2 r2)
                 | Tip kx bm =>
                     let bm1 := foldl'Bits #0 (bitPred kx) #0 bm in
                     pair (tip kx bm1) (tip kx (Data.Bits.xor bm bm1))
                 | Nil => (pair Nil Nil)
                 end in
    id (go predicate0 t0).

(* Skipping all instances of class `Control.DeepSeq.NFData', including
   `Data.IntSet.Internal.NFData__IntSet' *)

(* Skipping all instances of class `GHC.Read.Read', including
   `Data.IntSet.Internal.Read__IntSet' *)

(* Skipping all instances of class `GHC.Show.Show', including
   `Data.IntSet.Internal.Show__IntSet' *)

Local Definition Ord__IntSet_compare : IntSet -> IntSet -> comparison :=
  fun s1 s2 => GHC.Base.compare (toAscList s1) (toAscList s2).

Local Definition Ord__IntSet_op_zl__ : IntSet -> IntSet -> bool :=
  fun x y => Ord__IntSet_compare x y GHC.Base.== Lt.

Local Definition Ord__IntSet_op_zlze__ : IntSet -> IntSet -> bool :=
  fun x y => Ord__IntSet_compare x y GHC.Base./= Gt.

Local Definition Ord__IntSet_op_zg__ : IntSet -> IntSet -> bool :=
  fun x y => Ord__IntSet_compare x y GHC.Base.== Gt.

Local Definition Ord__IntSet_op_zgze__ : IntSet -> IntSet -> bool :=
  fun x y => Ord__IntSet_compare x y GHC.Base./= Lt.

Local Definition Ord__IntSet_max : IntSet -> IntSet -> IntSet :=
  fun x y => if Ord__IntSet_op_zlze__ x y : bool then y else x.

Local Definition Ord__IntSet_min : IntSet -> IntSet -> IntSet :=
  fun x y => if Ord__IntSet_op_zlze__ x y : bool then x else y.

Local Definition Eq___IntSet_op_zeze__ : IntSet -> IntSet -> bool :=
  fun t1 t2 => equal t1 t2.

Local Definition Eq___IntSet_op_zsze__ : IntSet -> IntSet -> bool :=
  fun t1 t2 => nequal t1 t2.

Program Instance Eq___IntSet : GHC.Base.Eq_ IntSet :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zeze____ := Eq___IntSet_op_zeze__ ;
           GHC.Base.op_zsze____ := Eq___IntSet_op_zsze__ |}.

Program Instance Ord__IntSet : GHC.Base.Ord IntSet :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zl____ := Ord__IntSet_op_zl__ ;
           GHC.Base.op_zlze____ := Ord__IntSet_op_zlze__ ;
           GHC.Base.op_zg____ := Ord__IntSet_op_zg__ ;
           GHC.Base.op_zgze____ := Ord__IntSet_op_zgze__ ;
           GHC.Base.compare__ := Ord__IntSet_compare ;
           GHC.Base.max__ := Ord__IntSet_max ;
           GHC.Base.min__ := Ord__IntSet_min |}.

(* Skipping all instances of class `Data.Data.Data', including
   `Data.IntSet.Internal.Data__IntSet' *)

Local Definition Semigroup__IntSet_op_zlzlzgzg__ : IntSet -> IntSet -> IntSet :=
  union.

Program Instance Semigroup__IntSet : GHC.Base.Semigroup IntSet :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zlzlzgzg____ := Semigroup__IntSet_op_zlzlzgzg__ |}.

Local Definition Monoid__IntSet_mappend : IntSet -> IntSet -> IntSet :=
  _GHC.Base.<<>>_.

Local Definition Monoid__IntSet_mconcat : list IntSet -> IntSet :=
  unions.

Local Definition Monoid__IntSet_mempty : IntSet :=
  empty.

Program Instance Monoid__IntSet : GHC.Base.Monoid IntSet :=
  fun _ k__ =>
    k__ {| GHC.Base.mappend__ := Monoid__IntSet_mappend ;
           GHC.Base.mconcat__ := Monoid__IntSet_mconcat ;
           GHC.Base.mempty__ := Monoid__IntSet_mempty |}.

(* Skipping all instances of class `GHC.Exts.IsList', including
   `Data.IntSet.Internal.IsList__IntSet' *)

Module Notations.
Notation "'_Data.IntSet.Internal.\\_'" := (op_zrzr__).
Infix "Data.IntSet.Internal.\\" := (_\\_) (at level 99).
End Notations.

(* External variables:
     Bool.Sumbool.sumbool_of_bool Eq Gt Lt N None Some andb bool comparison cons
     false id list negb nil op_zm__ op_zp__ op_zt__ op_zv__ option orb pair size_nat
     true Coq.Init.Peano.lt Coq.NArith.BinNat.N.ldiff Coq.NArith.BinNat.N.log2
     Coq.NArith.BinNat.N.lxor Coq.NArith.BinNat.N.modulo Coq.NArith.BinNat.N.ones
     Coq.NArith.BinNat.N.pow Coq.NArith.BinNat.N.pred Coq.NArith.BinNat.N.to_nat
     Coq.Numbers.BinNums.N Data.Bits.op_zizazi__ Data.Bits.op_zizbzi__ Data.Bits.xor
     Data.Foldable.Foldable Data.Foldable.foldl' Data.Maybe.maybe Data.Tuple.snd
     GHC.Base.Eq_ GHC.Base.Monoid GHC.Base.Ord GHC.Base.Semigroup GHC.Base.compare
     GHC.Base.compare__ GHC.Base.flip GHC.Base.map GHC.Base.mappend__ GHC.Base.max__
     GHC.Base.mconcat__ GHC.Base.mempty__ GHC.Base.min__ GHC.Base.op_z2218U__
     GHC.Base.op_zeze__ GHC.Base.op_zeze____ GHC.Base.op_zg__ GHC.Base.op_zg____
     GHC.Base.op_zgze__ GHC.Base.op_zgze____ GHC.Base.op_zl__ GHC.Base.op_zl____
     GHC.Base.op_zlze____ GHC.Base.op_zlzlzgzg__ GHC.Base.op_zlzlzgzg____
     GHC.Base.op_zsze__ GHC.Base.op_zsze____ GHC.Err.Build_Default GHC.Err.Default
     GHC.Num.fromInteger GHC.Num.op_zm__ GHC.Num.op_zp__ GHC.Wf.wfFix2
     Utils.Containers.Internal.BitUtil.bitcount
     Utils.Containers.Internal.BitUtil.highestBitMask
     Utils.Containers.Internal.BitUtil.lowestBitMask
     Utils.Containers.Internal.BitUtil.shiftLL
     Utils.Containers.Internal.BitUtil.shiftRL
*)


Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Op.
Require Import Locations.
Require Import LTL.
Require Import Conventions.

Require Import Linear.

Require Import mem_lemmas. (*for mem_forward*)
Require Import semantics.
Require Import val_casted.
Require Import BuiltinEffects.

Inductive load_frame: Type :=
| mk_load_frame:
    forall (rs0: Linear.locset)  (**r location state at program entry *)
           (f: Linear.function), (**r initial function *)
    load_frame.

(** Linear execution states. *)

Inductive Linear_core: Type :=
  | Linear_State:
      forall (stack: list Linear.stackframe) (**r call stack *)
             (f: Linear.function)            (**r function currently executing *)
             (sp: val)                       (**r stack pointer *)
             (c: Linear.code)                (**r current program point *)
             (rs: Linear.locset)             (**r location state *)
             (lf: load_frame),           (**r location state at program entry *)
      Linear_core
  (*A dummy corestate, to facilitate the stacking proof.*)
  | Linear_CallstateIn:
      forall (stack: list Linear.stackframe) (**r call stack *)
             (f: Linear.fundef)              (**r function to call *)
             (rs: Linear.locset)             (**r location state at point of call *)
             (lf: load_frame),           (**r location state at program entry *)
      Linear_core
  | Linear_Callstate:
      forall (stack: list Linear.stackframe) (**r call stack *)
             (f: Linear.fundef)              (**r function to call *)
             (rs: Linear.locset)             (**r location state at point of call *)
             (lf: load_frame),           (**r location state at program entry *)
      Linear_core
  | Linear_Returnstate:
      forall (stack: list Linear.stackframe) (**r call stack *)
             (retty: option typ)      (**r optional return register int-floatness *)
             (rs: Linear.locset)             (**r location state at point of return *)
             (lf: load_frame),           (**r location state at program entry *)
      Linear_core.

Definition call_regs' (callee : LTL.locset) (l : loc) :=
  match l with
    | R r => callee (R r)
    | S Local _ _ => Vundef
    | S Outgoing ofs ty => callee (S Incoming ofs ty)
    | S Incoming _ _ => Vundef
  end.

Lemma call_regs_regs' callee ofs ty :
  call_regs' (call_regs callee) (S Outgoing ofs ty) = callee (S Outgoing ofs ty).
Proof. simpl; auto. Qed.

(** [parent_locset0 ls0 cs] returns the mapping of values for locations
    of the caller function, bottoming out with locset ls0. *)
Definition parent_locset0 (ls0: locset) (stack: list Linear.stackframe) : locset :=
  match stack with
  | nil => call_regs' ls0
  | Linear.Stackframe f sp ls c :: stack' => ls
  end.

Section LINEAR_COOP.
Variable hf : I64Helpers.helper_functions.

Inductive Linear_step (ge:genv): Linear_core -> mem -> Linear_core -> mem -> Prop :=
  | lin_exec_Lgetstack:
      forall s f sp sl ofs ty dst b rs m rs' lf,
      rs' = Locmap.set (R dst) (rs (S sl ofs ty)) (undef_regs (destroyed_by_getstack sl) rs) ->
      Linear_step ge (Linear_State s f sp (Lgetstack sl ofs ty dst :: b) rs lf) m
        (Linear_State s f sp b rs' lf) m
  | lin_exec_Lsetstack:
      forall s f sp src sl ofs ty b rs m rs' lf,
      rs' = Locmap.set (S sl ofs ty) (rs (R src)) (undef_regs (destroyed_by_setstack ty) rs) ->
      Linear_step ge (Linear_State s f sp (Lsetstack src sl ofs ty :: b) rs lf) m
        (Linear_State s f sp b rs' lf) m
  | lin_exec_Lop:
      forall s f sp op args res b rs m v rs' lf,
      eval_operation ge sp op (reglist rs args) m = Some v ->
      rs' = Locmap.set (R res) v (undef_regs (destroyed_by_op op) rs) ->
      Linear_step ge (Linear_State s f sp (Lop op args res :: b) rs lf) m
        (Linear_State s f sp b rs' lf) m
  | lin_exec_Lload:
      forall s f sp chunk addr args dst b rs m a v rs' lf,
      eval_addressing ge sp addr (reglist rs args) = Some a ->
      Mem.loadv chunk m a = Some v ->
      rs' = Locmap.set (R dst) v (undef_regs (destroyed_by_load chunk addr) rs) ->
      Linear_step ge (Linear_State s f sp (Lload chunk addr args dst :: b) rs lf) m
        (Linear_State s f sp b rs' lf) m
  | lin_exec_Lstore:
      forall s f sp chunk addr args src b rs m m' a rs' lf,
      eval_addressing ge sp addr (reglist rs args) = Some a ->
      Mem.storev chunk m a (rs (R src)) = Some m' ->
      rs' = undef_regs (destroyed_by_store chunk addr) rs ->
      Linear_step ge (Linear_State s f sp (Lstore chunk addr args src :: b) rs lf) m
        (Linear_State s f sp b rs' lf) m'
  | lin_exec_Lcall:
      forall s f sp sig ros b rs m f' lf,
      find_function ge ros rs = Some f' ->
      sig = funsig f' ->
      Linear_step ge (Linear_State s f sp (Lcall sig ros :: b) rs lf) m
        (Linear_Callstate (Stackframe f sp rs b:: s) f' rs lf) m
  | lin_exec_Ltailcall:
      forall s f stk sig ros b rs m rs' f' m' rs0 f0,
      rs' = return_regs (parent_locset0 rs0 s) rs ->
      find_function ge ros rs' = Some f' ->
      sig = funsig f' ->
      Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
      Linear_step ge (Linear_State s f (Vptr stk Int.zero) (Ltailcall sig ros :: b) rs (mk_load_frame rs0 f0)) m
        (Linear_Callstate s f' rs' (mk_load_frame rs0 f0)) m'
  | lin_exec_Lbuiltin:
      forall s f sp rs m ef args res b t vl rs' m' lf,
      external_call' ef ge (reglist rs args) m t vl m' ->
      ~ observableEF hf ef ->
      rs' = Locmap.setlist (map R res) vl (undef_regs (destroyed_by_builtin ef) rs) ->
      Linear_step ge (Linear_State s f sp (Lbuiltin ef args res :: b) rs lf) m
         (Linear_State s f sp b rs' lf) m'

(* annotations are observable, so now handled by atExternal
  | lin_exec_Lannot:
      forall s f sp rs m ef args b t v m',
      external_call' ef ge (map rs args) m t v m' ->
      Linear_step (Linear_State s f sp (Lannot ef args :: b) rs) m
         (Linear_State s f sp b rs) m'*)

  | lin_exec_Llabel:
      forall s f sp lbl b rs m lf,
      Linear_step ge (Linear_State s f sp (Llabel lbl :: b) rs lf) m
        (Linear_State s f sp b rs lf) m
  | lin_exec_Lgoto:
      forall s f sp lbl b rs m b' lf,
      find_label lbl f.(fn_code) = Some b' ->
      Linear_step ge (Linear_State s f sp (Lgoto lbl :: b) rs lf) m
        (Linear_State s f sp b' rs lf) m
  | lin_exec_Lcond_true:
      forall s f sp cond args lbl b rs m rs' b' lf,
      eval_condition cond (reglist rs args) m = Some true ->
      rs' = undef_regs (destroyed_by_cond cond) rs ->
      find_label lbl f.(fn_code) = Some b' ->
      Linear_step ge (Linear_State s f sp (Lcond cond args lbl :: b) rs lf) m
        (Linear_State s f sp b' rs' lf) m
  | lin_exec_Lcond_false:
      forall s f sp cond args lbl b rs m rs' lf,
      eval_condition cond (reglist rs args) m = Some false ->
      rs' = undef_regs (destroyed_by_cond cond) rs ->
      Linear_step ge (Linear_State s f sp (Lcond cond args lbl :: b) rs lf) m
        (Linear_State s f sp b rs' lf) m
  | lin_exec_Ljumptable:
      forall s f sp arg tbl b rs m n lbl b' rs' lf,
      rs (R arg) = Vint n ->
      list_nth_z tbl (Int.unsigned n) = Some lbl ->
      find_label lbl f.(fn_code) = Some b' ->
      rs' = undef_regs (destroyed_by_jumptable) rs ->
      Linear_step ge (Linear_State s f sp (Ljumptable arg tbl :: b) rs lf) m
        (Linear_State s f sp b' rs' lf) m
  | lin_exec_Lreturn:
      forall s f stk b rs m m' rs0 f0,
      let lf := mk_load_frame rs0 f0 in
      Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
      Linear_step ge (Linear_State s f (Vptr stk Int.zero) (Lreturn :: b) rs lf) m
        (Linear_Returnstate s (sig_res (fn_sig f)) (return_regs (parent_locset0 rs0 s) rs) lf) m'
  (*A dummy corestep, to facilitate the stacking proof.*)
  | lin_exec_function_internal0:
      forall s f rs m rs0 f0,
      Linear_step ge (Linear_CallstateIn s (Internal f) rs (mk_load_frame rs0 f0)) m
                  (Linear_Callstate s (Internal f) rs (mk_load_frame (call_regs rs0) f0)) m
  | lin_exec_function_internal:
      forall s f rs m rs' m' stk lf,
      Mem.alloc m 0 f.(fn_stacksize) = (m', stk) ->
      rs' = undef_regs destroyed_at_function_entry (call_regs rs) ->
      Linear_step ge (Linear_Callstate s (Internal f) rs lf) m
        (Linear_State s f (Vptr stk Int.zero) f.(fn_code) rs' lf) m'

  | lin_exec_function_external:
      forall s ef args res rs1 rs2 m t m' lf
      (OBS: EFisHelper hf ef),
      args = map rs1 (loc_arguments (ef_sig ef)) ->
      external_call' ef ge args m t res m' ->
      rs2 = Locmap.setlist (map R (loc_result (ef_sig ef))) res rs1 ->
      Linear_step ge (Linear_Callstate s (External ef) rs1 lf) m
          (Linear_Returnstate s (sig_res (ef_sig ef)) rs2 lf) m'

  | lin_exec_return:
      forall s f sp lf c rs retty m rs_init,
      Linear_step ge (Linear_Returnstate (Stackframe f sp lf c :: s) retty rs rs_init) m
         (Linear_State s f sp c rs rs_init) m.

Definition init_locset tys args :=
  Locmap.setlist (loc_arguments_rec tys 0) (encode_longs tys args) (Locmap.init Vundef).

Definition Linear_initial_core (ge:genv) (v: val) (args:list val):
           option Linear_core :=match v with
     | Vptr b i =>
          if Int.eq_dec i Int.zero
          then match Genv.find_funct_ptr ge b with
                 | None => None
                 | Some f =>
                    match f with Internal fi =>
                     let tyl := sig_args (funsig f) in
                     if val_has_type_list_func args (sig_args (funsig f))
                        && vals_defined args
                        && zlt (4*(2*(Zlength args))) Int.max_unsigned
                     then let ls0 := init_locset (sig_args (funsig f)) args
                          in Some (Linear_CallstateIn nil f ls0 (mk_load_frame ls0 fi))
                     else None
                    | External _ => None
                     end
               end
          else None
     | _ => None
    end.
(*Compcert's original definition is for initial PROGRAM states
Inductive initial_state (p: program): state -> Prop :=
  | initial_state_intro: forall b f m0,
      let ge := Genv.globalenv p in
      Genv.init_mem p = Some m0 ->
      Genv.find_symbol ge p.(prog_main) = Some b ->
      Genv.find_funct_ptr ge b = Some f ->
      funsig f = mksignature nil (Some Tint) ->
      initial_state p (Callstate nil f (Locmap.init Vundef) m0).
*)

(*Maybe generalize to other types?*)
Definition Linear_halted (q : Linear_core): option val :=
    match q with Linear_Returnstate nil _ rs (mk_load_frame _ f) =>
      match sig_res (fn_sig f) with
      (*Return Tlong, which must be decoded*)
      | Some Tlong =>
           match loc_result (mksignature nil (Some Tlong)) with
             | nil => None
             | r1 :: r2 :: nil =>
                 match decode_longs (Tlong::nil) (rs (R r1)::rs (R r2)::nil) with
                   | v :: nil => Some v
                   | _ => None
                 end
             | _ => None
           end

      (*Return a value of any other typ*)
      | Some retty =>
           match loc_result (mksignature nil (Some retty)) with
            | nil => None
            | r :: TL => match TL with
                           | nil => Some (rs (R r))
                           | _ :: _ => None
                         end
           end

      (*Return Tvoid - modeled as integer return*)
      | None => Some (rs (R AX))
      end
    | _ => None end.

(*Original had this:
Inductive final_state: state -> int -> Prop :=
  | final_state_intro: forall rs m r retcode,
      loc_result (mksignature nil (Some Tint)) = r :: nil ->
      rs (R r) = Vint retcode ->
      final_state (Returnstate nil rs m) retcode.
*)

Definition Linear_at_external (c: Linear_core) : option (external_function * signature * list val) :=
  match c with
  | Linear_State _ _ _ _ _ _ => None
  | Linear_Callstate s f rs _ =>
      match f with
        | Internal f => None
        | External ef =>
            if observableEF_dec hf ef
            then Some (ef, ef_sig ef, decode_longs (sig_args (ef_sig ef))
                                   (map rs (loc_arguments (ef_sig ef))))
            else None
      end
  | Linear_CallstateIn _ _ _ _ => None
  | Linear_Returnstate _ _ _ _ => None
 end.

Definition Linear_after_external (vret: option val) (c: Linear_core) : option Linear_core :=
  match c with
    | Linear_Callstate s f rs lf =>
      match f with
        | Internal f => None
        | External ef =>
          match vret with
            | None => Some (Linear_Returnstate s (sig_res (ef_sig ef))
                             (Locmap.setlist (map R (loc_result (ef_sig ef)))
                               (encode_long (sig_res (ef_sig ef)) Vundef) rs) lf)
            | Some v => Some (Linear_Returnstate s (sig_res (ef_sig ef))
                               (Locmap.setlist (map R (loc_result (ef_sig ef)))
                                 (encode_long (sig_res (ef_sig ef)) v) rs) lf)
          end
      end
    | _ => None
  end.

Lemma Linear_corestep_not_at_external ge m q m' q':
      Linear_step ge q m q' m' -> Linear_at_external q = None.
  Proof. intros. inv H; try reflexivity.
  simpl. destruct (observableEF_dec hf ef); simpl; trivial.
  exfalso. eapply EFhelpers; eassumption.
Qed.

Lemma Linear_corestep_not_halted ge m q m' q' :
       Linear_step ge q m q' m' -> Linear_halted q = None.
  Proof. intros. inv H; reflexivity. Qed.

Lemma Linear_at_external_halted_excl q:
      Linear_at_external q = None \/ Linear_halted q = None.
   Proof. intros. destruct q; auto. Qed.

Lemma Linear_after_at_external_excl retv q q':
      Linear_after_external retv q = Some q' -> Linear_at_external q' = None.
  Proof. intros.
       destruct q; simpl in *; try inv H.
       destruct f; try inv H1; simpl.
         destruct retv; inv H0; simpl; trivial.
  Qed.

Definition Linear_core_sem : CoreSemantics genv Linear_core mem.
Proof.
  eapply (@Build_CoreSemantics _ _ _
           Linear_initial_core
           Linear_at_external
           Linear_after_external
           Linear_halted
           Linear_step).
    apply Linear_corestep_not_at_external.
    apply Linear_corestep_not_halted.
    apply Linear_at_external_halted_excl.
Defined.

(************************NOW SHOW THAT WE ALSO HAVE A COOPSEM******)

Lemma Linear_forward : forall g c m c' m' (CS: Linear_step g c m c' m'),
                    mem_forward m m'.
  Proof. intros.
   inv CS; try apply mem_forward_refl.
         (*Storev*)
          destruct a; simpl in H0; inv H0.
          eapply store_forward. eassumption.
         (*Ltailcall*)
           eapply free_forward; eassumption.
         (*Lbuiltin*)
           inv H.
           eapply external_call_mem_forward; eassumption.
         (*Lannot
           inv H.
           eapply external_call_mem_forward; eassumption.*)
         (*free*)
           eapply free_forward; eassumption.
         (*internal function*)
           eapply alloc_forward; eassumption.
         (*external unobservable function*)
           inv H0. eapply external_call_mem_forward; eassumption.
Qed.

Program Definition Linear_coop_sem :
  CoopCoreSem genv Linear_core.
Proof.
apply Build_CoopCoreSem with (coopsem := Linear_core_sem).
  apply Linear_forward.
Defined.

End LINEAR_COOP.


Require Import Omega.
Require Import RelationClasses.

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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import PromiseConsistent.
Require Import ReorderPromise.
Require Import ReorderPromises.
Require Import MemoryReorder.
Require Import MemoryFacts.
Require Import Pred.
Require Import MemoryProps.

Set Implicit Arguments.

Lemma reorder_read_cancel
      lc0 mem0
      lc1 mem1
      lc2
      loc1 from1 to1 msg1
      loc2 to2 val2 released2 ord2
      (STEP1: Local.read_step lc0 mem0 loc2 to2 val2 released2 ord2 lc1)
      (STEP2: Local.promise_step lc1 mem0 loc1 from1 to1 msg1 lc2 mem1 Memory.op_kind_cancel)
  :
    exists lc1',
      (<<STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1' mem1 Memory.op_kind_cancel>>) /\
      (<<STEP2: Local.read_step lc1' mem1 loc2 to2 val2 released2 ord2 lc2>>).
Proof.
  inv STEP1. inv STEP2.
  hexploit MemoryFacts.promise_get1_diff; eauto.
  { ii. clarify. ss. inv PROMISE.
    eapply Memory.remove_get0 in MEM. des. clarify. }
  i. des. esplits; eauto.
Qed.

Lemma remove_non_synch_loc loc0 prom0 loc1 from to msg prom1
      (NONSYNCH: Memory.nonsynch_loc loc0 prom0)
      (REMOVE: Memory.remove prom0 loc1 from to msg prom1)
  :
    Memory.nonsynch_loc loc0 prom1.
Proof.
  ii. erewrite Memory.remove_o in GET; eauto.
  des_ifs. exploit NONSYNCH; eauto.
Qed.

Lemma remove_non_synch prom0 loc from to msg prom1
      (NONSYNCH: Memory.nonsynch prom0)
      (REMOVE: Memory.remove prom0 loc from to msg prom1)
  :
    Memory.nonsynch prom1.
Proof.
  ii. erewrite Memory.remove_o in GET; eauto.
  des_ifs. exploit NONSYNCH; eauto.
Qed.

Lemma reorder_write_cancel
      lc0 sc0 mem0
      lc1 mem1
      lc2 sc2 mem2
      loc1 from1 to1 msg1
      loc2 from2 to2 val2 releasedm2 released2 ord2 kind2
      (STEP1: Local.write_step lc0 sc0 mem0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc1 sc2 mem1 kind2)
      (STEP2: Local.promise_step lc1 mem1 loc1 from1 to1 msg1 lc2 mem2 Memory.op_kind_cancel)
  :
    exists lc1' mem1',
      (<<STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1' mem1' Memory.op_kind_cancel>>) /\
      (<<STEP2: Local.write_step lc1' sc0 mem1' loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2 mem2 kind2>>).
Proof.
  inv STEP2. inv PROMISE.
  inv STEP1. ss. inv WRITE.
  exploit MemoryReorder.remove_remove.
  { eapply REMOVE. }
  { eapply PROMISES. } i. des.
  assert (LOCTS: (loc2, to2) <> (loc1, to1)).
  { ii. clarify. apply Memory.remove_get0 in MEM. inv PROMISE.
    - apply Memory.add_get0 in MEM0. des. clarify.
    - apply Memory.split_get0 in MEM0. des. clarify.
    - apply Memory.lower_get0 in MEM0. des. clarify.
    - clarify. }
  inv PROMISE.
  - exploit MemoryReorder.add_remove.
    { eapply LOCTS. }
    { eapply PROMISES0. }
    { eauto. } i. des.
    exploit MemoryReorder.add_remove.
    { eapply LOCTS. }
    { eapply MEM0. }
    { eauto. } i. des.
    esplits.
    + econs; eauto.
    + econs; ss.
      * econs.
        { econs 1; eauto.
          i. erewrite Memory.remove_o in GET; eauto.
          des_ifs. eapply ATTACH; eauto. }
        { eauto. }
      * intros ORD. eapply RELEASE in ORD.
        eapply remove_non_synch_loc; eauto.
  - destruct (classic ((loc2, ts3) = (loc1, to1))) as [|LOCTS2]; clarify.
    { exploit MemoryReorder.split_remove_same.
      { eapply PROMISES0. }
      { eauto. } i. des. clarify.
    }
    { exploit MemoryReorder.split_remove.
      { eapply LOCTS. }
      { eapply LOCTS2. }
      { eapply PROMISES0. }
      { eauto. } i. des.
      exploit MemoryReorder.split_remove.
      { eapply LOCTS. }
      { eapply LOCTS2. }
      { eapply MEM0. }
      { eauto. } i. des.
      esplits.
      + econs; eauto.
      + econs; ss.
        * econs.
          { econs 2; eauto. }
          { eauto. }
        * intros ORD. eapply RELEASE in ORD.
          eapply remove_non_synch_loc; eauto. }
  - exploit MemoryReorder.lower_remove.
    { eapply LOCTS. }
    { eapply PROMISES0. }
    { eauto. } i. des.
    exploit MemoryReorder.lower_remove.
    { eapply LOCTS. }
    { eapply MEM0. }
    { eauto. } i. des.
    esplits.
    + econs; eauto.
    + econs; ss.
      * econs.
        { econs 3; eauto. }
        { eauto. }
      * intros ORD. eapply RELEASE in ORD.
        eapply remove_non_synch_loc; eauto.
  - clarify.
Qed.

Lemma reorder_fence_cancel
      lc0 mem0
      lc1 mem1
      lc2
      loc1 from1 to1 msg1
      ord1 ord2 sc0 sc1
      (STEP1: Local.fence_step lc0 sc0 ord1 ord2 lc1 sc1)
      (STEP2: Local.promise_step lc1 mem0 loc1 from1 to1 msg1 lc2 mem1 Memory.op_kind_cancel)
  :
    exists lc1',
      (<<STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1' mem1 Memory.op_kind_cancel>>) /\
      (<<STEP2: Local.fence_step lc1' sc0 ord1 ord2 lc2 sc1>>).
Proof.
  inv STEP1. inv STEP2. ss. esplits.
  - econs; eauto.
  - econs; eauto.
    + inv PROMISE. i. eapply remove_non_synch; eauto.
    + i. ss. subst. erewrite PROMISES in *; auto.
      inv PROMISE. eapply Memory.remove_get0 in PROMISES0. des.
      erewrite Memory.bot_get in *. ss.
Qed.

Lemma reorder_step_cancel
      lang
      pf1 pf2 e1 e2 th0 th1 th2
      (STEP1: @Thread.step lang pf1 e1 th0 th1)
      (STEP2: Thread.step pf2 e2 th1 th2)
      (CANCEL: ThreadEvent.is_cancel e2):
  (exists th1',
    (<<STEP1: Thread.step pf2 e2 th0 th1'>>) /\
    (<<STEP2: Thread.step pf1 e1 th1' th2>>)) \/
  (th2 = th0 /\ <<RESERVE: ThreadEvent.is_reserve e1>>)
.
Proof.
  unfold ThreadEvent.is_cancel in *. des_ifs.
  inv STEP2; inv STEP; [|inv LOCAL]. ss.
  inv STEP1; ss.
  - inv STEP. ss. exploit reorder_promise_promise_cancel; eauto.
    i. des; clarify; eauto.
    left. esplits.
    + econs 1. econs; eauto.
    + econs 1. econs; eauto.
  - left. inv STEP. ss. inv LOCAL0; ss.
    + esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_read_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_write_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_write_cancel; eauto. i. des.
      exploit reorder_read_cancel; eauto. i. des.
      esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_fence_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_fence_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto.
        econs. econs. inv LOCAL1. inv LOCAL. inv PROMISE.
        ii. ss. erewrite Memory.remove_o in PROMISE; eauto. des_ifs.
        eapply CONSISTENT; eauto.
Qed.

Lemma reorder_step_cancels
      lang
      pf e1 th0 th1 th2
      (STEP1: Thread.step pf e1 th0 th1)
      (STEPS2: rtc (@Thread.cancel_step lang) th1 th2)
  :
    (exists th1',
        (<<STEPS1: rtc (@Thread.cancel_step lang) th0 th1'>>) /\
        (<<STEP2: Thread.step pf e1 th1' th2>>)) \/
    ((<<STEPS1: rtc (@Thread.cancel_step lang) th0 th2>>) /\ (<<RESERVE: ThreadEvent.is_reserve e1>>))
.
Proof.
  ginduction STEPS2; i.
  - esplits; eauto.
  - inv H. exploit reorder_step_cancel.
    { eapply STEP1. }
    { eapply STEP. }
    { ss. }
    i. des.
    { exploit IHSTEPS2; eauto. i. des.
      - left. esplits.
        + econs 2.
          * splits; auto. econs; eauto.
          * eauto.
        + eauto.
      - right. splits; auto. econs 2; eauto. econs; eauto.
    }
    { subst. right. esplits; eauto. }
Qed.

Lemma reorder_opt_step_cancels
      lang
      e1 th0 th1 th2
      (STEP1: Thread.opt_step e1 th0 th1)
      (STEPS2: rtc (@Thread.cancel_step lang) th1 th2)
  :
    (exists th1',
        (<<STEPS1: rtc (@Thread.cancel_step lang) th0 th1'>>) /\
        (<<STEP2: Thread.opt_step e1 th1' th2>>)) \/
    ((<<STEPS1: rtc (@Thread.cancel_step lang) th0 th2>>) /\ (<<RESERVE: ThreadEvent.is_reserve e1>>)).
Proof.
  inv STEP1.
  { left. esplits; eauto. econs 1. }
  { exploit reorder_step_cancels; eauto. i. des.
    { left. esplits; eauto. econs 2; eauto. }
    { right. esplits; eauto. }
  }
Qed.

Lemma reorder_opt_step_cancels2
      lang
      e1 th0 th1 th2
      (STEP1: Thread.opt_step e1 th0 th1)
      (STEPS2: rtc (@Thread.cancel_step lang) th1 th2)
  :
    exists th1' e1',
      (<<STEPS1: rtc (@Thread.cancel_step lang) th0 th1'>>) /\
      (<<STEP2: Thread.opt_step e1' th1' th2>>) /\
      __guard__(e1' = e1 \/ e1' = ThreadEvent.silent /\ <<RESERVE: ThreadEvent.is_reserve e1>>).
Proof.
  unguard. inv STEP1.
  { esplits.
    { eauto. }
    { econs 1. }
    { auto. }
  }
  { exploit reorder_step_cancels; eauto. i. des.
    { esplits; eauto. econs 2; eauto. }
    { esplits; eauto. econs 1; eauto. }
  }
Qed.

Lemma steps_cancels_not_cancels
      P lang th0 th2
      (STEPS: rtc (tau (@pred_step P lang)) th0 th2)
  :
    exists th1,
      (<<STEPS1: rtc (@Thread.cancel_step _) th0 th1>>) /\
      (<<STEPS2: rtc (tau (@pred_step (P /1\ fun e => ~ ThreadEvent.is_cancel e) _)) th1 th2>>)
.
Proof.
  ginduction STEPS; i.
  - esplits; eauto.
  - inv H. inv TSTEP. inv STEP.
    hexploit IHSTEPS; eauto. i. des.
    destruct (classic (ThreadEvent.is_cancel e)).
    + unfold ThreadEvent.is_cancel in H. des_ifs. esplits.
      * econs 2.
        { econs; eauto. }
        { eapply STEPS1. }
      * eapply STEPS2.
    + exploit reorder_step_cancels.
      { eapply STEP0. }
      { eapply STEPS1. }
      i. des; eauto. esplits.
      * eauto.
      * econs 2.
        { econs; eauto. econs; eauto. econs; eauto. }
        { eauto. }
Qed.


From oadt.lang_oadt Require Import base syntax semantics.
From oadt.lang_oadt Require Export kind.
Import syntax.notations semantics.notations kind.notations.

Implicit Types (b : bool) (x X y Y : atom) (L : aset).

(** * Definitions *)

(** ** Typing context (Γ) *)
Notation tctx := (amap lexpr).

Section typing.

#[local]
Coercion EFVar : atom >-> expr.

Section fix_gctx.

Context (Σ : gctx).

(** ** Parallel reduction *)
Reserved Notation "e '⇛' e'" (at level 40).

Inductive pared : expr -> expr -> Prop :=
| RApp l τ e1 e2 e1' e2' L :
    e1 ⇛ e1' ->
    (forall x, x ∉ L -> <{ e2^x }> ⇛ <{ e2'^x }>) ->
    lc τ ->
    <{ (\:{l}τ => e2) e1 }> ⇛ <{ e2'^e1' }>
| RTApp X τ' τ e e' :
    Σ !! X = Some (DOADT τ' τ) ->
    e ⇛ e' ->
    <{ X@e }> ⇛ <{ τ^e' }>
| RLet e1 e2 e1' e2' L :
    e1 ⇛ e1' ->
    (forall x, x ∉ L -> <{ e2^x }> ⇛ <{ e2'^x }>) ->
    <{ let e1 in e2 }> ⇛ <{ e2'^e1' }>
| RFun x T e :
    Σ !! x = Some (DFun T e) ->
    <{ gvar x }> ⇛ <{ e }>
| RProj l b e1 e2 e1' e2' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ π{l}@b (e1, e2){l} }> ⇛ <{ ite b e1' e2' }>
| RFold X X' e e' :
    e ⇛ e' ->
    <{ unfold<X> (fold<X'> e) }> ⇛ e'
| RIte b e1 e2 e1' e2' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ if b then e1 else e2 }> ⇛ <{ ite b e1' e2' }>
| RCase b τ e0 e1 e2 e0' e1' e2' L1 L2 :
    e0 ⇛ e0' ->
    (forall x, x ∉ L1 -> <{ e1^x }> ⇛ <{ e1'^x }>) ->
    (forall x, x ∉ L2 -> <{ e2^x }> ⇛ <{ e2'^x }>) ->
    lc τ ->
    <{ case inj@b<τ> e0 of e1 | e2 }> ⇛ <{ ite b (e1'^e0') (e2'^e0') }>
(* The rules for oblivous constructs are solely for proof convenience. They are
not needed because they are not involved in type-level computation. *)
| RMux b e1 e2 e1' e2' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ mux [b] e1 e2 }> ⇛ <{ ite b e1' e2' }>
(* This rule is needed for confluence. *)
| ROIte b e1 e2 e1' e2' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ ~if [b] then e1 else e2 }> ⇛ <{ ite b e1' e2' }>
| ROCase b ω1 ω2 v v1 v2 e1 e2 e1' e2' L1 L2 :
    oval v ->
    ovalty v1 ω1 -> ovalty v2 ω2 ->
    (forall x, x ∉ L1 -> <{ e1^x }> ⇛ <{ e1'^x }>) ->
    (forall x, x ∉ L2 -> <{ e2^x }> ⇛ <{ e2'^x }>) ->
    <{ ~case [inj@b<ω1 ~+ ω2> v] of e1 | e2 }> ⇛
      <{ ~if [b] then (ite b (e1'^v) (e1'^v1)) else (ite b (e2'^v2) (e2'^v)) }>
| RSec b :
    <{ s𝔹 b }> ⇛ <{ [b] }>
| ROInj b ω v :
    otval ω -> oval v ->
    <{ ~inj@b<ω> v }> ⇛ <{ [inj@b<ω> v] }>
(* Unfortunately I have to spell out all the cases corresponding to [SOIte] for
proof convenience. *)
| ROIteApp b e1 e2 e e1' e2' e' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    e ⇛ e' ->
    <{ (~if [b] then e1 else e2) e }> ⇛ <{ ~if [b] then e1' e' else e2' e' }>
| ROIteSec b e1 e2 e1' e2' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ s𝔹 (~if [b] then e1 else e2) }> ⇛ <{ ~if [b] then s𝔹 e1' else s𝔹 e2' }>
| ROIteIte b e1 e2 e3 e4 e1' e2' e3' e4' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    e3 ⇛ e3' ->
    e4 ⇛ e4' ->
    <{ if (~if [b] then e1 else e2) then e3 else e4 }> ⇛
      <{ ~if [b] then (if e1' then e3' else e4') else (if e2' then e3' else e4') }>
| ROIteProj b b' e1 e2 e1' e2' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ π@b' (~if [b] then e1 else e2) }> ⇛
      <{ ~if [b] then π@b' e1' else π@b' e2' }>
| ROIteCase b e1 e2 e3 e4 e1' e2' e3' e4' L1 L2 :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    (forall x, x ∉ L1 -> <{ e3^x }> ⇛ <{ e3'^x }>) ->
    (forall x, x ∉ L2 -> <{ e4^x }> ⇛ <{ e4'^x }>) ->
    <{ case (~if [b] then e1 else e2) of e3 | e4 }> ⇛
      <{ ~if [b] then (case e1' of e3' | e4') else (case e2' of e3' | e4') }>
| ROIteUnfold X b e1 e2 e1' e2' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ unfold<X> (~if [b] then e1 else e2) }> ⇛
      <{ ~if [b] then unfold<X> e1' else unfold<X> e2' }>
| RTapeOIte b e1 e2 e1' e2' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ tape (~if [b] then e1 else e2) }> ⇛ <{ mux [b] (tape e1') (tape e2') }>
| RTapeOVal v :
    oval v ->
    <{ tape v }> ⇛ v
(* Congruence rules *)
| RCgrPi l τ1 τ2 τ1' τ2' L :
    τ1 ⇛ τ1' ->
    (forall x, x ∉ L -> <{ τ2^x }> ⇛ <{ τ2'^x }>) ->
    <{ Π:{l}τ1, τ2 }> ⇛ <{ Π:{l}τ1', τ2' }>
| RCgrAbs l τ e τ' e' L :
    τ ⇛ τ' ->
    (forall x, x ∉ L -> <{ e^x }> ⇛ <{ e'^x }>) ->
    <{ \:{l}τ => e }> ⇛ <{ \:{l}τ' => e' }>
| RCgrApp e1 e2 e1' e2' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ e1 e2 }> ⇛ <{ e1' e2' }>
| RCgrTApp X e e' :
    e ⇛ e' ->
    <{ X@e }> ⇛ <{ X@e' }>
| RCgrLet e1 e2 e1' e2' L :
    e1 ⇛ e1' ->
    (forall x, x ∉ L -> <{ e2^x }> ⇛ <{ e2'^x }>) ->
    <{ let e1 in e2 }> ⇛ <{ let e1' in e2' }>
| RCgrSec e e' :
    e ⇛ e' ->
    <{ s𝔹 e }> ⇛ <{ s𝔹 e' }>
| RCgrIte l e0 e1 e2 e0' e1' e2' :
    e0 ⇛ e0' ->
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ if{l} e0 then e1 else e2 }> ⇛ <{ if{l} e0' then e1' else e2' }>
| RCgrProd l τ1 τ2 τ1' τ2' :
    τ1 ⇛ τ1' ->
    τ2 ⇛ τ2' ->
    <{ τ1 *{l} τ2 }> ⇛ <{ τ1' *{l} τ2' }>
| RCgrPair l e1 e2 e1' e2' :
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ (e1, e2){l} }> ⇛ <{ (e1', e2'){l} }>
| RCgrProj l b e e' :
    e ⇛ e' ->
    <{ π{l}@b e }> ⇛ <{ π{l}@b e' }>
| RCgrSum l τ1 τ2 τ1' τ2' :
    τ1 ⇛ τ1' ->
    τ2 ⇛ τ2' ->
    <{ τ1 +{l} τ2 }> ⇛ <{ τ1' +{l} τ2' }>
| RCgrInj l b τ e τ' e' :
    e ⇛ e' ->
    τ ⇛ τ' ->
    <{ inj{l}@b<τ> e }> ⇛ <{ inj{l}@b<τ'> e' }>
| RCgrCase l e0 e1 e2 e0' e1' e2' L1 L2 :
    e0 ⇛ e0' ->
    (forall x, x ∉ L1 -> <{ e1^x }> ⇛ <{ e1'^x }>) ->
    (forall x, x ∉ L2 -> <{ e2^x }> ⇛ <{ e2'^x }>) ->
    <{ case{l} e0 of e1 | e2 }> ⇛ <{ case{l} e0' of e1' | e2' }>
| RCgrFold X e e' :
    e ⇛ e' ->
    <{ fold<X> e }> ⇛ <{ fold<X> e' }>
| RCgrUnfold X e e' :
    e ⇛ e' ->
    <{ unfold<X> e }> ⇛ <{ unfold<X> e' }>
| RCgrMux e0 e1 e2 e0' e1' e2' :
    e0 ⇛ e0' ->
    e1 ⇛ e1' ->
    e2 ⇛ e2' ->
    <{ mux e0 e1 e2 }> ⇛ <{ mux e0' e1' e2' }>
| RCgrTape e e' :
    e ⇛ e' ->
    <{ tape e }> ⇛ <{ tape e' }>
(* Reflexive rule *)
| RRefl e :
    lc e ->
    e ⇛ e

where "e1 '⇛' e2" := (pared e1 e2)
.

Notation "e '⇛*' e'" := (rtc pared e e') (at level 40).

(** ** Expression equivalence *)
(** We directly define equivalence in terms of parallel reduction. *)

(** This definition is the same as saying two expressions multi-reduce to the
same expression (i.e. [pared_equiv_join] below), but easier for induction in
most cases. *)
Inductive pared_equiv : expr -> expr -> Prop :=
| QRRefl e : e ≡ e
| QRRedL e1 e1' e2 :
    e1 ⇛ e1' ->
    e1' ≡ e2 ->
    e1 ≡ e2
| QRRedR e1 e2 e2' :
    e2 ⇛ e2' ->
    e1 ≡ e2' ->
    e1 ≡ e2

where "e1 ≡ e2" := (pared_equiv e1 e2)
.

(** This is equivalent to [pared_equiv]. *)
Definition pared_equiv_join (e1 e2 : expr) : Prop :=
  exists e, e1 ⇛* e /\ e2 ⇛* e.

(** ** Typing and kinding *)
(** They are mutually defined. *)
Reserved Notation "Γ '⊢' e ':{' l '}' τ" (at level 40,
                                          e custom oadt at level 99,
                                          l constr at level 99,
                                          τ custom oadt at level 99).
Reserved Notation "Γ '⊢' τ '::' κ" (at level 40,
                                    τ custom oadt at level 99,
                                    κ custom oadt at level 99).

Inductive typing : tctx -> expr -> llabel -> expr -> Prop :=
| TFVar Γ x l τ κ :
    Γ !! x = Some (l, τ) ->
    Γ ⊢ τ :: κ ->
    Γ ⊢ fvar x :{l} τ
| TGVar Γ x l τ e :
    Σ !! x = Some (DFun (l, τ) e) ->
    Γ ⊢ gvar x :{l} τ
| TAbs Γ l1 l2 e τ1 τ2 κ L :
    (forall x, x ∉ L -> <[x:=(l2, τ2)]>Γ ⊢ e^x :{l1} τ1^x) ->
    Γ ⊢ τ2 :: κ ->
    Γ ⊢ \:{l2}τ2 => e :{l1} (Π:{l2}τ2, τ1)
| TLet Γ l1 l2 e1 e2 τ1 τ2 L :
    Γ ⊢ e1 :{l1} τ1 ->
    (forall x, x ∉ L -> <[x:=(l1, τ1)]>Γ ⊢ e2^x :{l2} τ2^x) ->
    Γ ⊢ let e1 in e2 :{l2} τ2^e1
| TApp Γ l1 l2 e1 e2 τ1 τ2 :
    Γ ⊢ e1 :{l1} (Π:{l2}τ2, τ1) ->
    Γ ⊢ e2 :{l2} τ2 ->
    Γ ⊢ e1 e2 :{l1} τ1^e2
| TUnit Γ : Γ ⊢ () :{⊥} 𝟙
| TLit Γ b : Γ ⊢ lit b :{⊥} 𝔹
| TSec Γ l e :
    Γ ⊢ e :{l} 𝔹 ->
    Γ ⊢ s𝔹 e :{l} ~𝔹
| TIte Γ l1 l2 l e0 e1 e2 τ κ :
    Γ ⊢ e0 :{⊥} 𝔹 ->
    Γ ⊢ e1 :{l1} τ^(lit true) ->
    Γ ⊢ e2 :{l2} τ^(lit false) ->
    Γ ⊢ τ^e0 :: κ ->
    l = l1 ⊔ l2 ->
    Γ ⊢ if e0 then e1 else e2 :{l} τ^e0
| TIteNoDep Γ l0 l1 l2 l e0 e1 e2 τ :
    Γ ⊢ e0 :{l0} 𝔹 ->
    Γ ⊢ e1 :{l1} τ ->
    Γ ⊢ e2 :{l2} τ ->
    l = l0 ⊔ l1 ⊔ l2 ->
    Γ ⊢ if e0 then e1 else e2 :{l} τ
| TOIte Γ l1 l2 e0 e1 e2 τ κ :
    Γ ⊢ e0 :{⊥} ~𝔹 ->
    Γ ⊢ e1 :{l1} τ ->
    Γ ⊢ e2 :{l2} τ ->
    Γ ⊢ τ :: κ ->
    Γ ⊢ ~if e0 then e1 else e2 :{⊤} τ
| TInj Γ l b e τ1 τ2 κ :
    Γ ⊢ e :{l} ite b τ1 τ2 ->
    Γ ⊢ τ1 + τ2 :: κ ->
    Γ ⊢ inj@b<τ1 + τ2> e :{l} τ1 + τ2
| TOInj Γ b e τ1 τ2 :
    Γ ⊢ e :{⊥} ite b τ1 τ2 ->
    Γ ⊢ τ1 ~+ τ2 :: *@O ->
    Γ ⊢ ~inj@b<τ1 ~+ τ2> e :{⊥} τ1 ~+ τ2
| TCase Γ l1 l2 l e0 e1 e2 τ1 τ2 τ κ L1 L2 :
    Γ ⊢ e0 :{⊥} τ1 + τ2 ->
    (forall x, x ∉ L1 -> <[x:=(⊥, τ1)]>Γ ⊢ e1^x :{l1} τ^(inl<τ1 + τ2> x)) ->
    (forall x, x ∉ L2 -> <[x:=(⊥, τ2)]>Γ ⊢ e2^x :{l2} τ^(inr<τ1 + τ2> x)) ->
    Γ ⊢ τ^e0 :: κ ->
    l = l1 ⊔ l2 ->
    Γ ⊢ case e0 of e1 | e2 :{l} τ^e0
| TCaseNoDep Γ l0 l1 l2 l e0 e1 e2 τ1 τ2 τ κ L1 L2 :
    Γ ⊢ e0 :{l0} τ1 + τ2 ->
    (forall x, x ∉ L1 -> <[x:=(l0, τ1)]>Γ ⊢ e1^x :{l1} τ) ->
    (forall x, x ∉ L2 -> <[x:=(l0, τ2)]>Γ ⊢ e2^x :{l2} τ) ->
    Γ ⊢ τ :: κ ->
    l = l0 ⊔ l1 ⊔ l2 ->
    Γ ⊢ case e0 of e1 | e2 :{l} τ
| TOCase Γ l1 l2 e0 e1 e2 τ1 τ2 τ κ L1 L2 :
    Γ ⊢ e0 :{⊥} τ1 ~+ τ2 ->
    (forall x, x ∉ L1 -> <[x:=(⊥, τ1)]>Γ ⊢ e1^x :{l1} τ) ->
    (forall x, x ∉ L2 -> <[x:=(⊥, τ2)]>Γ ⊢ e2^x :{l2} τ) ->
    Γ ⊢ τ :: κ ->
    Γ ⊢ ~case e0 of e1 | e2 :{⊤} τ
| TPair Γ l1 l2 l e1 e2 τ1 τ2 :
    Γ ⊢ e1 :{l1} τ1 ->
    Γ ⊢ e2 :{l2} τ2 ->
    l = l1 ⊔ l2 ->
    Γ ⊢ (e1, e2) :{l} τ1 * τ2
| TOPair Γ e1 e2 τ1 τ2 :
    Γ ⊢ e1 :{⊥} τ1 ->
    Γ ⊢ e2 :{⊥} τ2 ->
    Γ ⊢ τ1 :: *@O ->
    Γ ⊢ τ2 :: *@O ->
    Γ ⊢ ~(e1, e2) :{⊥} τ1 ~* τ2
| TProj Γ l b e τ1 τ2 :
    Γ ⊢ e :{l} τ1 * τ2 ->
    Γ ⊢ π@b e :{l} ite b τ1 τ2
| TOProj Γ b e τ1 τ2 :
    Γ ⊢ e :{⊥} τ1 ~* τ2 ->
    Γ ⊢ ~π@b e :{⊥} ite b τ1 τ2
| TFold Γ l X e τ :
    Σ !! X = Some (DADT τ) ->
    Γ ⊢ e :{l} τ ->
    Γ ⊢ fold<X> e :{l} gvar X
| TUnfold Γ l X e τ :
    Σ !! X = Some (DADT τ) ->
    Γ ⊢ e :{l} gvar X ->
    Γ ⊢ unfold<X> e :{l} τ
| TMux Γ e0 e1 e2 τ :
    Γ ⊢ e0 :{⊥} ~𝔹 ->
    Γ ⊢ e1 :{⊥} τ ->
    Γ ⊢ e2 :{⊥} τ ->
    Γ ⊢ τ :: *@O ->
    Γ ⊢ mux e0 e1 e2 :{⊥} τ
| TTape Γ l e τ :
    Γ ⊢ e :{l} τ ->
    Γ ⊢ τ :: *@O ->
    Γ ⊢ tape e :{⊥} τ
(* Typing for runtime expressions is for metatheories. These expressions do not
appear in source programs. Plus, it is not possible to type them at runtime
since they are "encrypted" values. *)
| TBoxedLit Γ b : Γ ⊢ [b] :{⊥} ~𝔹
| TBoxedInj Γ b v ω :
    ovalty <{ [inj@b<ω> v] }> ω ->
    Γ ⊢ [inj@b<ω> v] :{⊥} ω
(* Type conversion *)
| TConv Γ l l' e τ τ' κ :
    Γ ⊢ e :{l'} τ' ->
    τ' ≡ τ ->
    Γ ⊢ τ :: κ ->
    l' ⊑ l ->
    Γ ⊢ e :{l} τ

with kinding : tctx -> expr -> kind -> Prop :=
| KGVar Γ X τ :
    Σ !! X = Some (DADT τ) ->
    Γ ⊢ gvar X :: *@P
| KUnit Γ : Γ ⊢ 𝟙 :: *@A
| KBool Γ l : Γ ⊢ 𝔹{l} :: ite l *@O *@P
| KPi Γ l τ1 τ2 κ1 κ2 L :
    (forall x, x ∉ L -> <[x:=(l, τ1)]>Γ ⊢ τ2^x :: κ2) ->
    Γ ⊢ τ1 :: κ1 ->
    Γ ⊢ (Π:{l}τ1, τ2) :: *@M
| KApp Γ e' e τ X :
    Σ !! X = Some (DOADT τ e') ->
    Γ ⊢ e :{⊥} τ ->
    Γ ⊢ X@e :: *@O
| KProd Γ τ1 τ2 κ :
    Γ ⊢ τ1 :: κ ->
    Γ ⊢ τ2 :: κ ->
    Γ ⊢ τ1 * τ2 :: (κ ⊔ *@P)
| KOProd Γ τ1 τ2 :
    Γ ⊢ τ1 :: *@O ->
    Γ ⊢ τ2 :: *@O ->
    Γ ⊢ τ1 ~* τ2 :: *@O
| KSum Γ τ1 τ2 κ :
    Γ ⊢ τ1 :: κ ->
    Γ ⊢ τ2 :: κ ->
    Γ ⊢ τ1 + τ2 :: (κ ⊔ *@P)
| KOSum Γ τ1 τ2 :
    Γ ⊢ τ1 :: *@O ->
    Γ ⊢ τ2 :: *@O ->
    Γ ⊢ τ1 ~+ τ2 :: *@O
| KIte Γ e0 τ1 τ2 :
    Γ ⊢ e0 :{⊥} 𝔹 ->
    Γ ⊢ τ1 :: *@O ->
    Γ ⊢ τ2 :: *@O ->
    Γ ⊢ if e0 then τ1 else τ2 :: *@O
| KCase Γ e0 τ1 τ2 τ1' τ2' L1 L2 :
    Γ ⊢ e0 :{⊥} τ1' + τ2' ->
    (forall x, x ∉ L1 -> <[x:=(⊥, τ1')]>Γ ⊢ τ1^x :: *@O) ->
    (forall x, x ∉ L2 -> <[x:=(⊥, τ2')]>Γ ⊢ τ2^x :: *@O) ->
    Γ ⊢ case e0 of τ1 | τ2 :: *@O
| KLet Γ e τ τ' L :
    Γ ⊢ e :{⊥} τ' ->
    (forall x, x ∉ L -> <[x:=(⊥, τ')]>Γ ⊢ τ^x :: *@O) ->
    Γ ⊢ let e in τ :: *@O
| KSub Γ τ κ κ' :
    Γ ⊢ τ :: κ' ->
    κ' ⊑ κ ->
    Γ ⊢ τ :: κ

where "Γ '⊢' e ':{' l '}' τ" := (typing Γ e l τ)
  and "Γ '⊢' τ '::' κ" := (kinding Γ τ κ)
.

End fix_gctx.

(** Better induction principle. *)
Scheme typing_kinding_ind := Minimality for typing Sort Prop
  with kinding_typing_ind := Minimality for kinding Sort Prop.
Combined Scheme typing_kinding_mutind
         from typing_kinding_ind, kinding_typing_ind.

Notation "Σ '⊢' e '≡' e'" := (pared_equiv Σ e e')
                               (at level 40,
                                e custom oadt at level 99,
                                e' custom oadt at level 99).
Notation "Σ ; Γ '⊢' e ':{' l '}' τ" := (typing Σ Γ e l τ)
                                         (at level 40,
                                           Γ constr at next level,
                                           e custom oadt at level 99,
                                           τ custom oadt at level 99,
                                           format "Σ ;  Γ  '⊢'  e  ':{' l '}'  τ").
Notation "Σ ; Γ '⊢' τ '::' κ" := (kinding Σ Γ τ κ)
                                   (at level 40,
                                    Γ constr at next level,
                                    τ custom oadt at level 99,
                                    κ custom oadt at level 99).

(** ** Global definitions typing *)
Reserved Notation "Σ '⊢₁' D" (at level 40).

Inductive gdef_typing : gctx -> gdef -> Prop :=
| DTADT Σ τ :
    Σ; ∅ ⊢ τ :: *@P ->
    Σ ⊢₁ (DADT τ)
| DTOADT Σ τ e L :
    Σ; ∅ ⊢ τ :: *@P ->
    (forall x, x ∉ L -> Σ; ({[x:=(⊥, τ)]}) ⊢ e^x :: *@O) ->
    Σ ⊢₁ (DOADT τ e)
| DTFun Σ l τ e κ :
    Σ; ∅ ⊢ τ :: κ ->
    Σ; ∅ ⊢ e :{l} τ ->
    Σ ⊢₁ (DFun (l, τ) e)

where "Σ '⊢₁' D" := (gdef_typing Σ D)
.

Definition gctx_typing (Σ : gctx) : Prop :=
  map_Forall (fun _ D => Σ ⊢₁ D) Σ.

(** ** Program typing *)
(** The top level expression should not contain potential leaks. *)
Definition program_typing (Σ : gctx) (e : expr) (τ : expr) :=
  gctx_typing Σ /\ Σ; ∅ ⊢ e :{⊥} τ.

(** ** Well-formedness of global context *)
(** Equivalent to [gctx_typing]. Essentially saying all definitions in [Σ] are
well-typed. *)
(* TODO: I should use a weaker assumption in some proofs, such as all global
definitions are locally closed. *)
Definition gctx_wf (Σ : gctx) :=
  map_Forall (fun _ D =>
                match D with
                | DADT τ =>
                  Σ; ∅ ⊢ τ :: *@P
                | DOADT τ e =>
                  Σ; ∅ ⊢ τ :: *@P /\
                  exists L, forall x, x ∉ L -> Σ; ({[x:=(⊥, τ)]}) ⊢ e^x :: *@O
                | DFun (l, τ) e =>
                  Σ; ∅ ⊢ e :{l} τ /\
                  exists κ, Σ; ∅ ⊢ τ :: κ
                end) Σ.

End typing.

(** * Notations *)
(* Unfortunately I have to copy-paste all notations here again. *)
Module notations.

Export kind.notations.

Notation "Σ '⊢' e '⇛' e'" := (pared Σ e e')
                               (at level 40,
                                 e custom oadt at level 99,
                                 e' custom oadt at level 99).
Notation "Σ '⊢' e '⇛*' e'" := (rtc (pared Σ) e e')
                                (at level 40,
                                  e custom oadt at level 99,
                                  e' custom oadt at level 99).
Notation "Σ '⊢' e '≡' e'" := (pared_equiv Σ e e')
                               (at level 40,
                                e custom oadt at level 99,
                                e' custom oadt at level 99).
Notation "Σ ; Γ '⊢' e ':{' l '}' τ" := (typing Σ Γ e l τ)
                                         (at level 40,
                                           Γ constr at next level,
                                           e custom oadt at level 99,
                                           τ custom oadt at level 99,
                                           format "Σ ;  Γ  '⊢'  e  ':{' l '}'  τ").
Notation "Σ ; Γ '⊢' e ':' τ" := (typing Σ Γ e _ τ)
                                         (at level 40,
                                           Γ constr at next level,
                                           e custom oadt at level 99,
                                           τ custom oadt at level 99,
                                           only parsing).
Notation "Σ ; Γ '⊢' τ '::' κ" := (kinding Σ Γ τ κ)
                                   (at level 40,
                                    Γ constr at next level,
                                    τ custom oadt at level 99,
                                    κ custom oadt at level 99).

Notation "Σ '⊢₁' D" := (gdef_typing Σ D) (at level 40).

Notation "Σ ; e '▷' τ" := (program_typing Σ e τ)
                            (at level 40,
                              e at next level).

Notation "e '⇛' e'" := (pared _ e e') (at level 40).
Notation "e '⇛*' e'" := (rtc (pared _) e e') (at level 40).

Notation "Γ '⊢' e ':{' l '}' τ" := (typing _ Γ e l τ)
                                     (at level 40,
                                       e custom oadt at level 99,
                                       l constr at level 99,
                                       τ custom oadt at level 99,
                                       format "Γ  '⊢'  e  ':{' l '}'  τ").
Notation "Γ '⊢' e ':' τ" := (typing _ Γ e _ τ)
                              (at level 40,
                                e custom oadt at level 99,
                                τ custom oadt at level 99,
                                only parsing).
Notation "Γ '⊢' τ '::' κ" := (kinding _ Γ τ κ)
                               (at level 40,
                                 τ custom oadt at level 99,
                                 κ custom oadt at level 99).
End notations.


From Utils     Require Import Defns.
From CompCert  Require Import Coqlib Maps Lattice Kildall Errors.
From PIPE      Require Import TagDomain.
From RTLT      Require Import Language Semantics Policy.
From DeadcodeT Require Import DeadDomain.
Import ListNotations.

Module Functor (Export Tags  : TagDomain.MiddleEnd)
               (Export Rules : RTLT.Policy.Sig Tags)
               (Export Lang  : RTLT.Language.Sig Tags)
               (Import Sem   : RTLT.Semantics.Sig Tags Rules Lang)
               (Import Flags : RTLT.Policy.Props Tags Lang Rules).

Module Export DDomain := DeadDomain.Functor Tags Rules Lang Sem.

Definition add_need_all (r: reg) (ne: nbank) : nbank :=
  NB.set r Live ne.

Fixpoint add_needs_all (rl: list reg) (ne: nbank) : nbank :=
  match rl with
  | nil => ne
  | r1 :: rs => add_need_all r1 (add_needs_all rs ne)
  end.

Definition kill (r: reg) (ne: nbank) : nbank := NB.set r Dead ne.

Definition is_dead_atm (v: nval) : bool :=
  match v with Dead => true | _ => false end.

Definition is_dead_rule (ti: tinst) :=
  (dfs ti) &p (lpcp ti).

Definition transfer (f: function) (pc: node) (after: NA.t) : NA.t :=
    match f.(body) ! pc with None => NA.bot | Some ti =>
  match ti with
  | (Inop _, _) => after
  | (Imov rs rd _, itag) =>
      let nrd := nreg after rd in
      if (is_dead_rule ti) &&p (is_dead_atm nrd) then after
      else add_need_all rs (if (dnd_ImovTR itag)
                             then (        kill rd after)
                             else (add_need_all rd after))
  | (Imovi _ rd _, _) =>
      let nrd := nreg after rd in
      if (is_dead_rule ti) &&p (is_dead_atm nrd) then after
      else kill rd after
  | (Iop _ r1 r2 rd _, _) =>
      let nrd := nreg after rd in
      if (is_dead_rule ti) &&p (is_dead_atm nrd) then after
      else add_needs_all [r1; r2] (kill rd after)
  | (Icond cond r1 r2 s1 s2, _) =>
      if (is_dead_rule ti) &&p (peq s1 s2) then after else
        add_needs_all [r1; r2] after
  | (Icall callee_id args rd _, _) =>
      add_needs_all args (kill rd after)
  | (Ireturn r, _) =>
      add_need_all r after
  end end.

Module DS := Backward_Dataflow_Solver(NA)(NodeSetBackward).

Definition analyze (f: function): option (PMap.t NA.t) :=
  DS.fixpoint f.(body) successors_tinst (transfer f).

Definition transl_instr (an: PMap.t NA.t) (pc: node) (ti: tinst) :=
  match ti with
  | (Imov  _   rd ns, _)
  | (Imovi _   rd ns, _)
  | (Iop _ _ _ rd ns, _) =>
      let nrd := nreg (an !! pc) rd in
      if (is_dead_rule ti) &&p (is_dead_atm nrd)
      then noop ns else ti
  | (Icond _ r1 r2 s1 s2, _) =>
      if (is_dead_rule ti) &&p (peq s1 s2)
      then noop s1 else ti
  | _ => ti
  end.

Definition transl_function (f: function) : res function :=
  match analyze f with
  | Some an =>
      OK {| arity := f.(arity);
            params := f.(params);
            body := PTree.map (transl_instr an ) f.(body);
            entrypoint := f.(entrypoint);
            fntag := f.(fntag) |}
  | None => Error [MSG "analysis failed"]
  end.

Local Open Scope error_monad_scope.
Fixpoint transl_program (p: program) : res program :=
  match p with
  | (i,f) :: tl => do tf <- transl_function f;
                   do tp <- transl_program tl;
                     OK ((i,tf) :: tp)
  | []          => OK []
  end.
Local Close Scope error_monad_scope.

(* Some utility facts about translation *)

Lemma tr_function_preserves : forall {f tf},
  transl_function f = OK tf ->
  tf.(fntag) = f.(fntag) /\
  tf.(arity) = f.(arity) /\
  tf.(entrypoint) = f.(entrypoint) /\
  tf.(params) = f.(params).
Proof.
  intros. unfold transl_function in H.
  destruct (analyze f); inv H; auto.
Qed.

Lemma tr_function_fntag:
  forall {f tf},
  transl_function f = OK tf ->
  tf.(fntag) = f.(fntag).
Proof with auto.
  intros. destruct (tr_function_preserves H)...
Qed.

Lemma tr_function_sig:
  forall {f tf},
  transl_function f = OK tf ->
  tf.(arity) = f.(arity).
Proof with auto.
  intros. destruct (tr_function_preserves H)
as [_[? _]]...
Qed.

Lemma tr_function_entry:
  forall {f tf},
  transl_function f = OK tf ->
  tf.(entrypoint) = f.(entrypoint).
Proof with auto.
  intros * H. unfold transl_function in H.
  destruct (analyze f); inv H; simpl...
Qed.

Lemma tr_function_params:
  forall {f tf},
  transl_function f = OK tf ->
  tf.(params) = f.(params).
Proof with auto.
  intros * H. unfold transl_function in H.
  destruct (analyze f); inv H; simpl...
Qed.

End Functor.

(*

port/adapt CC RTL printer / extraction

writeup should be
  organized by optimization - as the major axis
  then talk about rule constraints - which may show up under multiple optimizations
  talk about dead code, CSE, const prop, but some of them will be "hypothetical"
  ?function inlining

 *)


Require Import VST.floyd.proofauto.
Require Import VST.progs.funcptr.

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

Local Open Scope Z.
Local Open Scope logic.

Definition myspec :=
  WITH i: Z
  PRE [ tint ]
          PROP (Int.min_signed <= i < Int.max_signed)
          PARAMS (Vint (Int.repr i))
          SEP ()
  POST [ tint ]
         PROP() RETURN (Vint (Int.repr (i+1)))
          SEP().

Definition myfunc_spec := DECLARE _myfunc myspec.

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs :=   ltac:(with_library prog [
    myfunc_spec; main_spec]).

Lemma body_myfunc: semax_body Vprog Gprog f_myfunc myfunc_spec.
Proof.
unfold myfunc_spec.
unfold myspec.
start_function.
forward.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
start_function. fold cc_default noattr tint.
make_func_ptr _myfunc.
forward.

forward_call 3.
  computable.
forward.
Qed.