packages feed

llvm-extra 0.12.0.1 → 0.12.1

raw patch · 25 files changed

+4480/−4310 lines, 25 files

Files

Changes.md view
@@ -1,5 +1,12 @@ # Change log for the `llvm-extra` package +## 0.12.1++* `Multi.Value` -> `Nice.Value`++  The `Multi.Value` name was misleading.+  `Multi.Value` retained for compatibility for now.+ ## 0.11  * `Memory`: turn methods `load` and `store` into top-level functions
llvm-extra.cabal view
@@ -1,6 +1,6 @@ Cabal-Version:  2.2 Name:           llvm-extra-Version:        0.12.0.1+Version:        0.12.1 License:        BSD-3-Clause License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -38,7 +38,7 @@   .   * more functional loop construction using "LLVM.Extra.Iterator"   .-  * complex Haskell values mapped to LLVM values in "LLVM.Extra.Multi.Value"+  * complex Haskell values mapped to LLVM values in "LLVM.Extra.Nice.Value"   .   * advanced vector operations     such as sum of all vector elements, cumulative sum,@@ -61,7 +61,7 @@   default:     False  Source-Repository this-  Tag:         0.12.0.1+  Tag:         0.12.1   Type:        darcs   Location:    http://code.haskell.org/~thielema/llvm-extra/ @@ -110,6 +110,15 @@     LLVM.Extra.ScalarOrVector     LLVM.Extra.FastMath     LLVM.Extra.Iterator+    LLVM.Extra.Nice.Iterator+    LLVM.Extra.Nice.Value+    LLVM.Extra.Nice.Value.Vector+    LLVM.Extra.Nice.Value.Marshal+    LLVM.Extra.Nice.Value.Storable+    LLVM.Extra.Nice.Vector+    LLVM.Extra.Nice.Vector.Instance+    LLVM.Extra.Nice.Class+    -- retained for compatibility     LLVM.Extra.Multi.Iterator     LLVM.Extra.Multi.Value     LLVM.Extra.Multi.Value.Vector@@ -124,8 +133,8 @@     LLVM.Extra.TuplePrivate     LLVM.Extra.MaybePrivate     LLVM.Extra.EitherPrivate-    LLVM.Extra.Multi.Value.Private-    LLVM.Extra.Multi.Value.Array+    LLVM.Extra.Nice.Value.Private+    LLVM.Extra.Nice.Value.Array  Library private   Build-Depends:
src/LLVM/Extra/FastMath.hs view
@@ -12,17 +12,25 @@     Number(Number, deconsNumber),    getNumber,+   nvNumber,+   nvDenumber,    mvNumber,    mvDenumber, -   MultiValue(setMultiValueFlags),+   NiceValue(setMultiValueFlags, setNiceValueFlags),+   attachNiceValueFlags,    attachMultiValueFlags,    liftNumberM,    liftNumberM2,+   nvecNumber,+   nvecDenumber,    mvecNumber,    mvecDenumber, -   MultiVector(setMultiVectorFlags),+   NiceVector(setMultiVectorFlags, setNiceVectorFlags),+   attachNiceVectorFlags,+   liftNiceVectorM,+   liftNiceVectorM2,    attachMultiVectorFlags,    liftMultiVectorM,    liftMultiVectorM2,@@ -34,8 +42,8 @@    liftContext2,    ) where -import qualified LLVM.Extra.Multi.Vector as MultiVector-import qualified LLVM.Extra.Multi.Value.Private as MV+import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value.Private as Nice import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Core as LLVM@@ -92,289 +100,324 @@ getNumber :: flags -> Number flags a -> a getNumber _ (Number a) = a -instance MultiValue a => MV.C (Number flags a) where-   type Repr (Number flags a) = MV.Repr a-   cons = mvNumber . MV.cons . deconsNumber-   undef = mvNumber MV.undef-   zero = mvNumber MV.zero-   phi bb = fmap mvNumber . MV.phi bb . mvDenumber-   addPhi bb a b = MV.addPhi bb (mvDenumber a) (mvDenumber b)+instance NiceValue a => Nice.C (Number flags a) where+   type Repr (Number flags a) = Nice.Repr a+   cons = nvNumber . Nice.cons . deconsNumber+   undef = nvNumber Nice.undef+   zero = nvNumber Nice.zero+   phi bb = fmap nvNumber . Nice.phi bb . nvDenumber+   addPhi bb a b = Nice.addPhi bb (nvDenumber a) (nvDenumber b) -mvNumber :: MV.T a -> MV.T (Number flags a)-mvNumber (MV.Cons a) = MV.Cons a+nvNumber :: Nice.T a -> Nice.T (Number flags a)+nvNumber (Nice.Cons a) = Nice.Cons a -mvDenumber :: MV.T (Number flags a) -> MV.T a-mvDenumber (MV.Cons a) = MV.Cons a+nvDenumber :: Nice.T (Number flags a) -> Nice.T a+nvDenumber (Nice.Cons a) = Nice.Cons a +{-# DEPRECATED mvNumber "Use nvNumber instead" #-}+mvNumber :: Nice.T a -> Nice.T (Number flags a)+mvNumber (Nice.Cons a) = Nice.Cons a -class MV.C a => MultiValue a where-   setMultiValueFlags ::+{-# DEPRECATED mvDenumber "Use nvDenumber instead" #-}+mvDenumber :: Nice.T (Number flags a) -> Nice.T a+mvDenumber (Nice.Cons a) = Nice.Cons a+++{-# DEPRECATED setMultiValueFlags "use setNiceValueFlags instead" #-}+class Nice.C a => NiceValue a where+   {-# MINIMAL setNiceValueFlags | setMultiValueFlags #-}+   setNiceValueFlags, setMultiValueFlags ::       (Flags flags) =>-      Proxy flags -> Bool -> MV.T (Number flags a) -> LLVM.CodeGenFunction r ()+      Proxy flags -> Bool -> Nice.T (Number flags a) ->+      LLVM.CodeGenFunction r ()+   setNiceValueFlags = setMultiValueFlags+   setMultiValueFlags = setNiceValueFlags -instance MultiValue Float where-   setMultiValueFlags p b (MV.Cons a) = setFlags p b a+instance NiceValue Float where+   setNiceValueFlags p b (Nice.Cons a) = setFlags p b a -instance MultiValue Double where-   setMultiValueFlags p b (MV.Cons a) = setFlags p b a+instance NiceValue Double where+   setNiceValueFlags p b (Nice.Cons a) = setFlags p b a   type Id a = a -> a -attachMultiValueFlags ::-   (Flags flags, MultiValue a) =>-   Id (LLVM.CodeGenFunction r (MV.T (Number flags a)))-attachMultiValueFlags act = do+{-# DEPRECATED attachMultiValueFlags "Use attachNiceValueFlags instead." #-}+attachMultiValueFlags, attachNiceValueFlags ::+   (Flags flags, NiceValue a) =>+   Id (LLVM.CodeGenFunction r (Nice.T (Number flags a)))+attachMultiValueFlags = attachNiceValueFlags+attachNiceValueFlags act = do    mv <- act    setMultiValueFlags Proxy True mv    return mv  liftNumberM ::-   (m ~ LLVM.CodeGenFunction r, Flags flags, MultiValue b) =>-   (MV.T a -> m (MV.T b)) ->-   MV.T (Number flags a) -> m (MV.T (Number flags b))+   (m ~ LLVM.CodeGenFunction r, Flags flags, NiceValue b) =>+   (Nice.T a -> m (Nice.T b)) ->+   Nice.T (Number flags a) -> m (Nice.T (Number flags b)) liftNumberM f =-   attachMultiValueFlags . Monad.lift mvNumber . f . mvDenumber+   attachMultiValueFlags . Monad.lift nvNumber . f . nvDenumber  liftNumberM2 ::-   (m ~ LLVM.CodeGenFunction r, Flags flags, MultiValue c) =>-   (MV.T a -> MV.T b -> m (MV.T c)) ->-   MV.T (Number flags a) -> MV.T (Number flags b) -> m (MV.T (Number flags c))+   (m ~ LLVM.CodeGenFunction r, Flags flags, NiceValue c) =>+   (Nice.T a -> Nice.T b -> m (Nice.T c)) ->+   Nice.T (Number flags a) -> Nice.T (Number flags b) ->+   m (Nice.T (Number flags c)) liftNumberM2 f a b =-   attachMultiValueFlags $ Monad.lift mvNumber $ f (mvDenumber a) (mvDenumber b)+   attachMultiValueFlags $ Monad.lift nvNumber $ f (nvDenumber a) (nvDenumber b)  -instance (Flags flags, MV.Compose a) => MV.Compose (Number flags a) where-   type Composed (Number flags a) = Number flags (MV.Composed a)-   compose = mvNumber . MV.compose . deconsNumber+instance (Flags flags, Nice.Compose a) => Nice.Compose (Number flags a) where+   type Composed (Number flags a) = Number flags (Nice.Composed a)+   compose = nvNumber . Nice.compose . deconsNumber -instance (Flags flags, MV.Decompose pa) => MV.Decompose (Number flags pa) where-   decompose (Number p) = Number . MV.decompose p . mvDenumber+instance+      (Flags flags, Nice.Decompose pa) => Nice.Decompose (Number flags pa) where+   decompose (Number p) = Number . Nice.decompose p . nvDenumber  type instance-   MV.Decomposed f (Number flags pa) = Number flags (MV.Decomposed f pa)+   Nice.Decomposed f (Number flags pa) = Number flags (Nice.Decomposed f pa) type instance-   MV.PatternTuple (Number flags pa) = Number flags (MV.PatternTuple pa)+   Nice.PatternTuple (Number flags pa) = Number flags (Nice.PatternTuple pa)   instance-   (Flags flags, MultiValue a, MV.IntegerConstant a) =>-      MV.IntegerConstant (Number flags a) where-   fromInteger' = mvNumber . MV.fromInteger'+   (Flags flags, NiceValue a, Nice.IntegerConstant a) =>+      Nice.IntegerConstant (Number flags a) where+   fromInteger' = nvNumber . Nice.fromInteger'  instance-   (Flags flags, MultiValue a, MV.RationalConstant a) =>-      MV.RationalConstant (Number flags a) where-   fromRational' = mvNumber . MV.fromRational'+   (Flags flags, NiceValue a, Nice.RationalConstant a) =>+      Nice.RationalConstant (Number flags a) where+   fromRational' = nvNumber . Nice.fromRational'  instance-   (Flags flags, MultiValue a, MV.Additive a) =>-      MV.Additive (Number flags a) where-   add = liftNumberM2 MV.add-   sub = liftNumberM2 MV.sub-   neg = liftNumberM MV.neg+   (Flags flags, NiceValue a, Nice.Additive a) =>+      Nice.Additive (Number flags a) where+   add = liftNumberM2 Nice.add+   sub = liftNumberM2 Nice.sub+   neg = liftNumberM Nice.neg  instance-   (Flags flags, MultiValue a, MV.PseudoRing a) =>-      MV.PseudoRing (Number flags a) where-   mul = liftNumberM2 MV.mul+   (Flags flags, NiceValue a, Nice.PseudoRing a) =>+      Nice.PseudoRing (Number flags a) where+   mul = liftNumberM2 Nice.mul  instance-   (Flags flags, MultiValue a, MV.Field a) =>-      MV.Field (Number flags a) where-   fdiv = liftNumberM2 MV.fdiv+   (Flags flags, NiceValue a, Nice.Field a) =>+      Nice.Field (Number flags a) where+   fdiv = liftNumberM2 Nice.fdiv -type instance MV.Scalar (Number flags a) = Number flags (MV.Scalar a)+type instance Nice.Scalar (Number flags a) = Number flags (Nice.Scalar a)  instance-   (Flags flags, MultiValue a, a ~ MV.Scalar v,-    MultiValue v, MV.PseudoModule v) =>-      MV.PseudoModule (Number flags v) where-   scale = liftNumberM2 MV.scale+   (Flags flags, NiceValue a, a ~ Nice.Scalar v,+    NiceValue v, Nice.PseudoModule v) =>+      Nice.PseudoModule (Number flags v) where+   scale = liftNumberM2 Nice.scale  instance-   (Flags flags, MultiValue a, MV.Real a) =>-      MV.Real (Number flags a) where-   min = liftNumberM2 MV.min-   max = liftNumberM2 MV.max-   abs = liftNumberM MV.abs-   signum = liftNumberM MV.signum+   (Flags flags, NiceValue a, Nice.Real a) =>+      Nice.Real (Number flags a) where+   min = liftNumberM2 Nice.min+   max = liftNumberM2 Nice.max+   abs = liftNumberM Nice.abs+   signum = liftNumberM Nice.signum  instance-   (Flags flags, MultiValue a, MV.Fraction a) =>-      MV.Fraction (Number flags a) where-   truncate = liftNumberM MV.truncate-   fraction = liftNumberM MV.fraction+   (Flags flags, NiceValue a, Nice.Fraction a) =>+      Nice.Fraction (Number flags a) where+   truncate = liftNumberM Nice.truncate+   fraction = liftNumberM Nice.fraction  instance-   (Flags flags, MultiValue a, MV.Algebraic a) =>-      MV.Algebraic (Number flags a) where-   sqrt = liftNumberM MV.sqrt+   (Flags flags, NiceValue a, Nice.Algebraic a) =>+      Nice.Algebraic (Number flags a) where+   sqrt = liftNumberM Nice.sqrt  instance-   (Flags flags, MultiValue a, MV.Transcendental a) =>-      MV.Transcendental (Number flags a) where-   pi = fmap mvNumber MV.pi-   sin = liftNumberM MV.sin-   cos = liftNumberM MV.cos-   exp = liftNumberM MV.exp-   log = liftNumberM MV.log-   pow = liftNumberM2 MV.pow+   (Flags flags, NiceValue a, Nice.Transcendental a) =>+      Nice.Transcendental (Number flags a) where+   pi = fmap nvNumber Nice.pi+   sin = liftNumberM Nice.sin+   cos = liftNumberM Nice.cos+   exp = liftNumberM Nice.exp+   log = liftNumberM Nice.log+   pow = liftNumberM2 Nice.pow  instance-   (Flags flags, MultiValue a, MV.Select a) =>-      MV.Select (Number flags a) where-   select = liftNumberM2 . MV.select+   (Flags flags, NiceValue a, Nice.Select a) =>+      Nice.Select (Number flags a) where+   select = liftNumberM2 . Nice.select  instance-   (Flags flags, MultiValue a, MV.Comparison a) =>-      MV.Comparison (Number flags a) where-   cmp p a b = MV.cmp p (mvDenumber a) (mvDenumber b)+   (Flags flags, NiceValue a, Nice.Comparison a) =>+      Nice.Comparison (Number flags a) where+   cmp p a b = Nice.cmp p (nvDenumber a) (nvDenumber b)  instance-   (Flags flags, MultiValue a, MV.FloatingComparison a) =>-      MV.FloatingComparison (Number flags a) where-   fcmp p a b = MV.fcmp p (mvDenumber a) (mvDenumber b)+   (Flags flags, NiceValue a, Nice.FloatingComparison a) =>+      Nice.FloatingComparison (Number flags a) where+   fcmp p a b = Nice.fcmp p (nvDenumber a) (nvDenumber b)   -mvecNumber :: MultiVector.T n a -> MultiVector.T n (Number flags a)-mvecNumber (MultiVector.Cons v) = MultiVector.Cons v+nvecNumber :: NiceVector.T n a -> NiceVector.T n (Number flags a)+nvecNumber (NiceVector.Cons v) = NiceVector.Cons v -mvecDenumber :: MultiVector.T n (Number flags a) -> MultiVector.T n a-mvecDenumber (MultiVector.Cons v) = MultiVector.Cons v+nvecDenumber :: NiceVector.T n (Number flags a) -> NiceVector.T n a+nvecDenumber (NiceVector.Cons v) = NiceVector.Cons v -class (MultiValue a, MultiVector.C a) => MultiVector a where-   setMultiVectorFlags ::+{-# DEPRECATED mvecNumber "Use nvecNumber instead" #-}+mvecNumber :: NiceVector.T n a -> NiceVector.T n (Number flags a)+mvecNumber (NiceVector.Cons v) = NiceVector.Cons v++{-# DEPRECATED mvecDenumber "Use nvecDenumber instead" #-}+mvecDenumber :: NiceVector.T n (Number flags a) -> NiceVector.T n a+mvecDenumber (NiceVector.Cons v) = NiceVector.Cons v++{-# DEPRECATED setMultiVectorFlags "use setNiceVectorFlags instead" #-}+class (NiceValue a, NiceVector.C a) => NiceVector a where+   {-# MINIMAL setNiceVectorFlags | setMultiVectorFlags #-}+   setNiceVectorFlags, setMultiVectorFlags ::       (Flags flags, LLVM.Positive n) =>       Proxy flags -> Bool ->-      MultiVector.T n (Number flags a) -> LLVM.CodeGenFunction r ()+      NiceVector.T n (Number flags a) -> LLVM.CodeGenFunction r ()+   setNiceVectorFlags = setMultiVectorFlags+   setMultiVectorFlags = setNiceVectorFlags -instance MultiVector Float where+instance NiceVector Float where    setMultiVectorFlags p b =-      setFlags p b . MultiVector.deconsPrim . mvecDenumber+      setFlags p b . NiceVector.deconsPrim . nvecDenumber -instance MultiVector Double where+instance NiceVector Double where    setMultiVectorFlags p b =-      setFlags p b . MultiVector.deconsPrim . mvecDenumber+      setFlags p b . NiceVector.deconsPrim . nvecDenumber -attachMultiVectorFlags ::-   (LLVM.Positive n, Flags flags, MultiVector a) =>-   Id (LLVM.CodeGenFunction r (MultiVector.T n (Number flags a)))-attachMultiVectorFlags act = do+{-# DEPRECATED attachMultiVectorFlags "Use attachNiceVectorFlags instead." #-}+attachNiceVectorFlags, attachMultiVectorFlags ::+   (LLVM.Positive n, Flags flags, NiceVector a) =>+   Id (LLVM.CodeGenFunction r (NiceVector.T n (Number flags a)))+attachMultiVectorFlags = attachNiceVectorFlags+attachNiceVectorFlags act = do    mv <- act    setMultiVectorFlags Proxy True mv    return mv -liftMultiVectorM ::-   (m ~ LLVM.CodeGenFunction r, LLVM.Positive n, Flags flags, MultiVector b) =>-   (MultiVector.T n a -> m (MultiVector.T n b)) ->-   MultiVector.T n (Number flags a) -> m (MultiVector.T n (Number flags b))-liftMultiVectorM f =-   attachMultiVectorFlags . Monad.lift mvecNumber . f . mvecDenumber+{-# DEPRECATED liftMultiVectorM "Use liftNiceVectorM instead." #-}+liftNiceVectorM, liftMultiVectorM ::+   (m ~ LLVM.CodeGenFunction r, LLVM.Positive n, Flags flags, NiceVector b) =>+   (NiceVector.T n a -> m (NiceVector.T n b)) ->+   NiceVector.T n (Number flags a) -> m (NiceVector.T n (Number flags b))+liftMultiVectorM = liftNiceVectorM+liftNiceVectorM f =+   attachMultiVectorFlags . Monad.lift nvecNumber . f . nvecDenumber -liftMultiVectorM2 ::-   (m ~ LLVM.CodeGenFunction r, LLVM.Positive n, Flags flags, MultiVector c) =>-   (MultiVector.T n a -> MultiVector.T n b -> m (MultiVector.T n c)) ->-   MultiVector.T n (Number flags a) -> MultiVector.T n (Number flags b) ->-   m (MultiVector.T n (Number flags c))-liftMultiVectorM2 f a b =+{-# DEPRECATED liftMultiVectorM2 "Use liftNiceVectorM2 instead." #-}+liftNiceVectorM2, liftMultiVectorM2 ::+   (m ~ LLVM.CodeGenFunction r, LLVM.Positive n, Flags flags, NiceVector c) =>+   (NiceVector.T n a -> NiceVector.T n b -> m (NiceVector.T n c)) ->+   NiceVector.T n (Number flags a) -> NiceVector.T n (Number flags b) ->+   m (NiceVector.T n (Number flags c))+liftMultiVectorM2 = liftNiceVectorM2+liftNiceVectorM2 f a b =    attachMultiVectorFlags $-      Monad.lift mvecNumber $ f (mvecDenumber a) (mvecDenumber b)+      Monad.lift nvecNumber $ f (nvecDenumber a) (nvecDenumber b) -instance (Flags flags, MultiVector a) => MultiVector.C (Number flags a) where-   type Repr n (Number flags a) = MultiVector.Repr n a-   cons = mvecNumber . MultiVector.cons . fmap deconsNumber-   undef = mvecNumber MultiVector.undef-   zero = mvecNumber MultiVector.zero-   phi bb = fmap mvecNumber . MultiVector.phi bb . mvecDenumber-   addPhi bb a b = MultiVector.addPhi bb (mvecDenumber a) (mvecDenumber b)+instance (Flags flags, NiceVector a) => NiceVector.C (Number flags a) where+   type Repr n (Number flags a) = NiceVector.Repr n a+   cons = nvecNumber . NiceVector.cons . fmap deconsNumber+   undef = nvecNumber NiceVector.undef+   zero = nvecNumber NiceVector.zero+   phi bb = fmap nvecNumber . NiceVector.phi bb . nvecDenumber+   addPhi bb a b = NiceVector.addPhi bb (nvecDenumber a) (nvecDenumber b)    shuffle ks a b =-      fmap mvecNumber $ MultiVector.shuffle ks (mvecDenumber a) (mvecDenumber b)-   extract k = fmap mvNumber . MultiVector.extract k . mvecDenumber+      fmap nvecNumber $ NiceVector.shuffle ks (nvecDenumber a) (nvecDenumber b)+   extract k = fmap nvNumber . NiceVector.extract k . nvecDenumber    insert k x =-      fmap mvecNumber . MultiVector.insert k (mvDenumber x) . mvecDenumber+      fmap nvecNumber . NiceVector.insert k (nvDenumber x) . nvecDenumber  instance-   (Flags flags, MultiVector a, MultiVector.IntegerConstant a) =>-      MultiVector.IntegerConstant (Number flags a) where-   fromInteger' = mvecNumber . MultiVector.fromInteger'+   (Flags flags, NiceVector a, NiceVector.IntegerConstant a) =>+      NiceVector.IntegerConstant (Number flags a) where+   fromInteger' = nvecNumber . NiceVector.fromInteger'  instance-   (Flags flags, MultiVector a, MultiVector.RationalConstant a) =>-      MultiVector.RationalConstant (Number flags a) where-   fromRational' = mvecNumber . MultiVector.fromRational'+   (Flags flags, NiceVector a, NiceVector.RationalConstant a) =>+      NiceVector.RationalConstant (Number flags a) where+   fromRational' = nvecNumber . NiceVector.fromRational'  instance-   (Flags flags, MultiVector a, MultiVector.Additive a) =>-      MultiVector.Additive (Number flags a) where-   add = liftMultiVectorM2 MultiVector.add-   sub = liftMultiVectorM2 MultiVector.sub-   neg = liftMultiVectorM MultiVector.neg+   (Flags flags, NiceVector a, NiceVector.Additive a) =>+      NiceVector.Additive (Number flags a) where+   add = liftNiceVectorM2 NiceVector.add+   sub = liftNiceVectorM2 NiceVector.sub+   neg = liftNiceVectorM NiceVector.neg  instance-   (Flags flags, MultiVector a, MultiVector.PseudoRing a) =>-      MultiVector.PseudoRing (Number flags a) where-   mul = liftMultiVectorM2 MultiVector.mul+   (Flags flags, NiceVector a, NiceVector.PseudoRing a) =>+      NiceVector.PseudoRing (Number flags a) where+   mul = liftNiceVectorM2 NiceVector.mul  instance-   (Flags flags, MultiVector a, MultiVector.Field a) =>-      MultiVector.Field (Number flags a) where-   fdiv = liftMultiVectorM2 MultiVector.fdiv+   (Flags flags, NiceVector a, NiceVector.Field a) =>+      NiceVector.Field (Number flags a) where+   fdiv = liftNiceVectorM2 NiceVector.fdiv   {--type instance MultiValue.Scalar (Number flags a) =-      Number flags (MultiValue.Scalar a)+type instance NiceValue.Scalar (Number flags a) =+      Number flags (NiceValue.Scalar a) instance-   (Flags flags, MultiVector a, MultiVector.PseudoModule a) =>-      MultiVector.PseudoModule (Number flags a) where-   scale = liftMultiVectorM2 MultiVector.mul+   (Flags flags, NiceVector a, NiceVector.PseudoModule a) =>+      NiceVector.PseudoModule (Number flags a) where+   scale = liftNiceVectorM2 NiceVector.mul -}  instance-   (Flags flags, MultiVector a, MultiVector.Real a) =>-      MultiVector.Real (Number flags a) where-   min = liftMultiVectorM2 MultiVector.min-   max = liftMultiVectorM2 MultiVector.max-   abs = liftMultiVectorM MultiVector.abs-   signum = liftMultiVectorM MultiVector.signum+   (Flags flags, NiceVector a, NiceVector.Real a) =>+      NiceVector.Real (Number flags a) where+   min = liftNiceVectorM2 NiceVector.min+   max = liftNiceVectorM2 NiceVector.max+   abs = liftNiceVectorM NiceVector.abs+   signum = liftNiceVectorM NiceVector.signum  instance-   (Flags flags, MultiVector a, MultiVector.Fraction a) =>-      MultiVector.Fraction (Number flags a) where-   truncate = liftMultiVectorM MultiVector.truncate-   fraction = liftMultiVectorM MultiVector.fraction+   (Flags flags, NiceVector a, NiceVector.Fraction a) =>+      NiceVector.Fraction (Number flags a) where+   truncate = liftNiceVectorM NiceVector.truncate+   fraction = liftNiceVectorM NiceVector.fraction  instance-   (Flags flags, MultiVector a, MultiVector.Algebraic a) =>-      MultiVector.Algebraic (Number flags a) where-   sqrt = liftMultiVectorM MultiVector.sqrt+   (Flags flags, NiceVector a, NiceVector.Algebraic a) =>+      NiceVector.Algebraic (Number flags a) where+   sqrt = liftNiceVectorM NiceVector.sqrt  instance-   (Flags flags, MultiVector a, MultiVector.Transcendental a) =>-      MultiVector.Transcendental (Number flags a) where-   pi = fmap mvecNumber MultiVector.pi-   sin = liftMultiVectorM MultiVector.sin-   cos = liftMultiVectorM MultiVector.cos-   exp = liftMultiVectorM MultiVector.exp-   log = liftMultiVectorM MultiVector.log-   pow = liftMultiVectorM2 MultiVector.pow+   (Flags flags, NiceVector a, NiceVector.Transcendental a) =>+      NiceVector.Transcendental (Number flags a) where+   pi = fmap nvecNumber NiceVector.pi+   sin = liftNiceVectorM NiceVector.sin+   cos = liftNiceVectorM NiceVector.cos+   exp = liftNiceVectorM NiceVector.exp+   log = liftNiceVectorM NiceVector.log+   pow = liftNiceVectorM2 NiceVector.pow  instance-   (Flags flags, MultiVector a, MultiVector.Select a) =>-      MultiVector.Select (Number flags a) where-   select = liftMultiVectorM2 . MultiVector.select+   (Flags flags, NiceVector a, NiceVector.Select a) =>+      NiceVector.Select (Number flags a) where+   select = liftNiceVectorM2 . NiceVector.select  instance-   (Flags flags, MultiVector a, MultiVector.Comparison a) =>-      MultiVector.Comparison (Number flags a) where-   cmp p a b = MultiVector.cmp p (mvecDenumber a) (mvecDenumber b)+   (Flags flags, NiceVector a, NiceVector.Comparison a) =>+      NiceVector.Comparison (Number flags a) where+   cmp p a b = NiceVector.cmp p (nvecDenumber a) (nvecDenumber b)  instance-   (Flags flags, MultiVector a, MultiVector.FloatingComparison a) =>-      MultiVector.FloatingComparison (Number flags a) where-   fcmp p a b = MultiVector.fcmp p (mvecDenumber a) (mvecDenumber b)+   (Flags flags, NiceVector a, NiceVector.FloatingComparison a) =>+      NiceVector.FloatingComparison (Number flags a) where+   fcmp p a b = NiceVector.fcmp p (nvecDenumber a) (nvecDenumber b)
src/LLVM/Extra/Memory.hs view
@@ -12,8 +12,8 @@    loadNewtype, storeNewtype, decomposeNewtype, composeNewtype,    ) where -import qualified LLVM.Extra.Multi.Vector as MultiVector-import qualified LLVM.Extra.Multi.Value.Private as MultiValue+import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value.Private as NiceValue import qualified LLVM.Extra.Scalar as Scalar import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Struct as Struct@@ -365,26 +365,26 @@  -- redundant IsType and IsSized constraints required for loopy instance instance-   (IsType (Struct (MultiValue.Repr a)),-    IsSized (Struct (MultiValue.Repr a)),-    MultiValue.C a, C (MultiValue.Repr a)) =>-      C (MultiValue.T a) where-   type Struct (MultiValue.T a) = Struct (MultiValue.Repr a)-   load = fmap MultiValue.Cons . load-   store (MultiValue.Cons a) = store a-   decompose = fmap MultiValue.Cons . decompose-   compose (MultiValue.Cons a) = compose a+   (IsType (Struct (NiceValue.Repr a)),+    IsSized (Struct (NiceValue.Repr a)),+    NiceValue.C a, C (NiceValue.Repr a)) =>+      C (NiceValue.T a) where+   type Struct (NiceValue.T a) = Struct (NiceValue.Repr a)+   load = fmap NiceValue.Cons . load+   store (NiceValue.Cons a) = store a+   decompose = fmap NiceValue.Cons . decompose+   compose (NiceValue.Cons a) = compose a  instance-   (IsType (Struct (MultiVector.Repr n a)),-    IsSized (Struct (MultiVector.Repr n a)),-    TypeNum.Positive n, MultiVector.C a, C (MultiVector.Repr n a)) =>-      C (MultiVector.T n a) where-   type Struct (MultiVector.T n a) = Struct (MultiVector.Repr n a)-   load = fmap MultiVector.Cons . load-   store (MultiVector.Cons a) = store a-   decompose = fmap MultiVector.Cons . decompose-   compose (MultiVector.Cons a) = compose a+   (IsType (Struct (NiceVector.Repr n a)),+    IsSized (Struct (NiceVector.Repr n a)),+    TypeNum.Positive n, NiceVector.C a, C (NiceVector.Repr n a)) =>+      C (NiceVector.T n a) where+   type Struct (NiceVector.T n a) = Struct (NiceVector.Repr n a)+   load = fmap NiceVector.Cons . load+   store (NiceVector.Cons a) = store a+   decompose = fmap NiceVector.Cons . decompose+   compose (NiceVector.Cons a) = compose a
src/LLVM/Extra/Multi/Class.hs view
@@ -1,170 +1,5 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-module LLVM.Extra.Multi.Class where--import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Multi.Vector as MultiVector-import qualified LLVM.Extra.Arithmetic as A--import qualified LLVM.Core as LLVM--import qualified Type.Data.Num.Decimal as TypeNum---class C value where-   type Size value-   switch ::-      f MultiValue.T ->-      f (MultiVector.T (Size value)) ->-      f value--instance C MultiValue.T where-   type Size MultiValue.T = TypeNum.D1-   switch x _ = x--instance (TypeNum.Positive n) => C (MultiVector.T n) where-   type Size (MultiVector.T n) = n-   switch _ x = x---newtype Const a value = Const {getConst :: value a}--undef ::-   (C value, Size value ~ n, TypeNum.Positive n, MultiVector.C a) =>-   value a-undef =-   getConst $-   switch-      (Const MultiValue.undef)-      (Const MultiVector.undef)--zero ::-   (C value, Size value ~ n, TypeNum.Positive n, MultiVector.C a) =>-   value a-zero =-   getConst $-   switch-      (Const MultiValue.zero)-      (Const MultiVector.zero)---newtype-   Op0 r a value =-      Op0 {runOp0 :: LLVM.CodeGenFunction r (value a)}--newtype-   Op1 r a b value =-      Op1 {runOp1 :: value a -> LLVM.CodeGenFunction r (value b)}--newtype-   Op2 r a b c value =-      Op2 {runOp2 :: value a -> value b -> LLVM.CodeGenFunction r (value c)}--add, sub ::-   (TypeNum.Positive n, MultiVector.Additive a,-    n ~ Size value, C value) =>-   value a -> value a -> LLVM.CodeGenFunction r (value a)-add = runOp2 $ switch (Op2 A.add) (Op2 A.add)-sub = runOp2 $ switch (Op2 A.sub) (Op2 A.sub)--neg ::-   (TypeNum.Positive n, MultiVector.Additive a,-    n ~ Size value, C value) =>-   value a -> LLVM.CodeGenFunction r (value a)-neg = runOp1 $ switch (Op1 A.neg) (Op1 A.neg)---mul ::-   (TypeNum.Positive n, MultiVector.PseudoRing a,-    n ~ Size value, C value) =>-   value a -> value a -> LLVM.CodeGenFunction r (value a)-mul = runOp2 $ switch (Op2 A.mul) (Op2 A.mul)-fdiv ::-   (TypeNum.Positive n, MultiVector.Field a,-    n ~ Size value, C value) =>-   value a -> value a -> LLVM.CodeGenFunction r (value a)-fdiv = runOp2 $ switch (Op2 A.fdiv) (Op2 A.fdiv)--scale ::-   (TypeNum.Positive n, MultiVector.PseudoModule v,-    n ~ Size value, C value) =>-   value (MultiValue.Scalar v) -> value v -> LLVM.CodeGenFunction r (value v)-scale = runOp2 $ switch (Op2 A.scale) (Op2 A.scale)--min, max ::-   (TypeNum.Positive n, MultiVector.Real a,-    n ~ Size value, C value) =>-   value a -> value a -> LLVM.CodeGenFunction r (value a)-min = runOp2 $ switch (Op2 A.min) (Op2 A.min)-max = runOp2 $ switch (Op2 A.max) (Op2 A.max)--abs, signum ::-   (TypeNum.Positive n, MultiVector.Real a,-    n ~ Size value, C value) =>-   value a -> LLVM.CodeGenFunction r (value a)-abs = runOp1 $ switch (Op1 A.abs) (Op1 A.abs)-signum = runOp1 $ switch (Op1 A.signum) (Op1 A.signum)--truncate, fraction ::-   (TypeNum.Positive n, MultiVector.Fraction a,-    n ~ Size value, C value) =>-   value a -> LLVM.CodeGenFunction r (value a)-truncate = runOp1 $ switch (Op1 A.truncate) (Op1 A.truncate)-fraction = runOp1 $ switch (Op1 A.fraction) (Op1 A.fraction)--sqrt ::-   (TypeNum.Positive n, MultiVector.Algebraic a,-    n ~ Size value, C value) =>-   value a -> LLVM.CodeGenFunction r (value a)-sqrt = runOp1 $ switch (Op1 A.sqrt) (Op1 A.sqrt)--pi ::-   (TypeNum.Positive n, MultiVector.Transcendental a,-    n ~ Size value, C value) =>-   LLVM.CodeGenFunction r (value a)-pi = runOp0 $ switch (Op0 A.pi) (Op0 A.pi)--sin, cos, exp, log ::-   (TypeNum.Positive n, MultiVector.Transcendental a,-    n ~ Size value, C value) =>-   value a -> LLVM.CodeGenFunction r (value a)-sin = runOp1 $ switch (Op1 A.sin) (Op1 A.sin)-cos = runOp1 $ switch (Op1 A.cos) (Op1 A.cos)-exp = runOp1 $ switch (Op1 A.exp) (Op1 A.exp)-log = runOp1 $ switch (Op1 A.log) (Op1 A.log)--pow ::-   (TypeNum.Positive n, MultiVector.Transcendental a,-    n ~ Size value, C value) =>-   value a -> value a -> LLVM.CodeGenFunction r (value a)-pow = runOp2 $ switch (Op2 A.pow) (Op2 A.pow)---cmp ::-   (TypeNum.Positive n, MultiVector.Comparison a,-    n ~ Size value, C value) =>-   LLVM.CmpPredicate ->-   value a -> value a -> LLVM.CodeGenFunction r (value Bool)-cmp p = runOp2 $ switch (Op2 $ A.cmp p) (Op2 $ A.cmp p)--fcmp ::-   (TypeNum.Positive n, MultiVector.FloatingComparison a,-    n ~ Size value, C value) =>-   LLVM.FPPredicate ->-   value a -> value a -> LLVM.CodeGenFunction r (value Bool)-fcmp p = runOp2 $ switch (Op2 $ A.fcmp p) (Op2 $ A.fcmp p)---and, or, xor ::-   (TypeNum.Positive n, MultiVector.Logic a,-    n ~ Size value, C value) =>-   value a -> value a -> LLVM.CodeGenFunction r (value a)-and = runOp2 $ switch (Op2 A.and) (Op2 A.and)-or = runOp2 $ switch (Op2 A.or) (Op2 A.or)-xor = runOp2 $ switch (Op2 A.xor) (Op2 A.xor)+module LLVM.Extra.Multi.Class+   {-# DEPRECATED "Use LLVM.Extra.Nice.Class instead." #-}+   (module LLVM.Extra.Nice.Class) where -inv ::-   (TypeNum.Positive n, MultiVector.Logic a,-    n ~ Size value, C value) =>-   value a -> LLVM.CodeGenFunction r (value a)-inv = runOp1 $ switch (Op1 A.inv) (Op1 A.inv)+import LLVM.Extra.Nice.Class
src/LLVM/Extra/Multi/Iterator.hs view
@@ -1,95 +1,5 @@-{-# LANGUAGE TypeFamilies #-}-module LLVM.Extra.Multi.Iterator (-   takeWhile,-   countDown,-   take,-   Enum(..),-   ) where--import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Iterator as Iter-import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.MaybePrivate as Maybe-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C--import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction)--import Control.Applicative (liftA2)--import qualified Data.Enum.Storable as Enum--import qualified Prelude as P-import Prelude hiding (take, takeWhile, Enum, enumFrom, enumFromTo)----takeWhile ::-   (a -> CodeGenFunction r (MultiValue.T Bool)) ->-   Iter.T r a -> Iter.T r a-takeWhile p = Iter.takeWhile (fmap unpackBool . p)--unpackBool :: MultiValue.T Bool -> LLVM.Value Bool-unpackBool (MultiValue.Cons b) = b--countDown ::-   (MultiValue.Additive i, MultiValue.Comparison i,-    MultiValue.IntegerConstant i) =>-   MultiValue.T i -> Iter.T r (MultiValue.T i)-countDown len =-   takeWhile (MultiValue.cmp LLVM.CmpLT MultiValue.zero) $-   Iter.iterate MultiValue.dec len--take ::-   (MultiValue.Additive i, MultiValue.Comparison i,-    MultiValue.IntegerConstant i) =>-   MultiValue.T i -> Iter.T r a -> Iter.T r a-take len xs = liftA2 const xs (countDown len)---class (MultiValue.C a) => Enum a where-   succ, pred :: MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T a)-   enumFrom :: MultiValue.T a -> Iter.T r (MultiValue.T a)-   enumFromTo :: MultiValue.T a -> MultiValue.T a -> Iter.T r (MultiValue.T a)--instance-   (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,-    LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) =>-      Enum (Enum.T w e) where-   succ = MultiValue.succ-   pred = MultiValue.pred-   enumFrom = Iter.iterate MultiValue.succ-   {- |-   More complicated than 'enumFromToSimple'-   but works also for e.g. [0 .. (0xFFFF::Word16)].-   -}-   enumFromTo from to =-      Iter.takeWhileJust $-      Iter.iterate (Maybe.maybeArg Tuple.undef (succMax to)) (Maybe.just from)--succMax ::-   (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,-    LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) =>-   MultiValue.T (Enum.T w e) ->-   MultiValue.T (Enum.T w e) ->-   LLVM.CodeGenFunction r (Maybe.T (MultiValue.T (Enum.T w e)))-succMax to e = do-   MultiValue.Cons less <- MultiValue.cmpEnum A.CmpLT e to-   C.ifThen less (Maybe.nothing Tuple.undef) $-      fmap Maybe.just $ MultiValue.succ e+module LLVM.Extra.Multi.Iterator+   {-# DEPRECATED "Use LLVM.Extra.Nice.Iterator instead." #-}+   (module LLVM.Extra.Nice.Iterator) where -{- |-Warning: For [0 .. (0xFFFF::Word16)]-it would compute an undefined @0xFFFF+1@.-In modulo arithmetic it would enter an infinite loop.--}-_enumFromToSimple ::-   (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,-    LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) =>-   MultiValue.T (Enum.T w e) ->-   MultiValue.T (Enum.T w e) ->-   Iter.T r (MultiValue.T (Enum.T w e))-_enumFromToSimple from to =-   takeWhile (MultiValue.cmpEnum LLVM.CmpGE to) $ enumFrom from+import LLVM.Extra.Nice.Iterator
src/LLVM/Extra/Multi/Value.hs view
@@ -1,8 +1,5 @@-module LLVM.Extra.Multi.Value (-   module LLVM.Extra.Multi.Value.Private,-   Array(..), withArraySize, extractArrayValue, insertArrayValue,-   ) where+module LLVM.Extra.Multi.Value+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value instead." #-}+   (module LLVM.Extra.Nice.Value) where -import LLVM.Extra.Multi.Vector.Instance ()-import LLVM.Extra.Multi.Value.Array-import LLVM.Extra.Multi.Value.Private+import LLVM.Extra.Nice.Value
− src/LLVM/Extra/Multi/Value/Array.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-module LLVM.Extra.Multi.Value.Array where--import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Multi.Value.Marshal as Marshal-import qualified LLVM.Extra.Multi.Value.Private as MultiValue-import LLVM.Extra.Multi.Value.Private (Repr)--import qualified LLVM.Core as LLVM--import qualified Type.Data.Num.Decimal as TypeNum-import qualified Type.Data.Num.Decimal.Number as Dec-import Type.Base.Proxy (Proxy(Proxy))--import Control.Applicative (Applicative(pure, (<*>)))--import qualified Data.Traversable as Trav-import qualified Data.Foldable as Fold-import Data.Functor.Identity (Identity(Identity, runIdentity))-import Data.Functor ((<$>))--import Prelude2010-import Prelude ()----newtype Array n a = Array [a]-   deriving (Eq, Show)--instance (Dec.Integer n) => Functor (Array n) where-   fmap f (Array xs) = Array (map f xs)--instance (Dec.Integer n) => Applicative (Array n) where-   pure x =-      runIdentity $ withArraySize $-         \n -> Identity $ Array $ replicate (Dec.integralFromProxy n) x-   Array fs <*> Array xs = Array $ zipWith id fs xs--instance (Dec.Integer n) => Fold.Foldable (Array n) where-   foldMap f (Array xs) = Fold.foldMap f xs--instance (Dec.Integer n) => Trav.Traversable (Array n) where-   traverse f (Array xs) = Array <$> Trav.traverse f xs--withArraySize :: (Proxy n -> gen (Array n a)) -> gen (Array n a)-withArraySize f = f Proxy---instance (TypeNum.Natural n, Marshal.C a) => MultiValue.C (Array n a) where-   type Repr (Array n a) = LLVM.Value (LLVM.Array n (Marshal.Struct a))-   cons (Array xs) = MultiValue.consPrimitive $ LLVM.Array $ map Marshal.pack xs-   undef = MultiValue.undefPrimitive-   zero = MultiValue.zeroPrimitive-   phi = MultiValue.phiPrimitive-   addPhi = MultiValue.addPhiPrimitive--instance-   (TypeNum.Natural n, Marshal.C a,-    Dec.Natural (n Dec.:*: LLVM.SizeOf (Marshal.Struct a))) =>-      Marshal.C (Array n a) where-   pack (Array xs) = LLVM.Array $ map Marshal.pack xs-   unpack (LLVM.Array xs) = Array $ map Marshal.unpack xs--extractArrayValue ::-   (TypeNum.Natural n, LLVM.ArrayIndex n i, Marshal.C a) =>-   i -> MultiValue.T (Array n a) ->-   LLVM.CodeGenFunction r (MultiValue.T a)-extractArrayValue i (MultiValue.Cons arr) =-   MultiValue.Cons <$> (Memory.decompose =<< LLVM.extractvalue arr i)--insertArrayValue ::-   (TypeNum.Natural n, LLVM.ArrayIndex n i, Marshal.C a) =>-   i -> MultiValue.T a -> MultiValue.T (Array n a) ->-   LLVM.CodeGenFunction r (MultiValue.T (Array n a))-insertArrayValue i (MultiValue.Cons a) (MultiValue.Cons arr) =-   MultiValue.Cons <$> (flip (LLVM.insertvalue arr) i =<< Memory.compose a)
src/LLVM/Extra/Multi/Value/Marshal.hs view
@@ -1,221 +1,5 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{- |-Transfer values between Haskell and JIT generated code-in an LLVM-compatible format.-E.g. 'Bool' is stored as 'i1' and occupies a byte,-@'Vector' n 'Bool'@ is stored as a bit vector,-@'Vector' n 'Word8'@ is stored in an order depending on machine endianess,-and Haskell tuples are stored as LLVM structs.--}-module LLVM.Extra.Multi.Value.Marshal (-   C(..),-   Struct,-   peek,-   poke,--   VectorStruct,-   Vector(..),--   with,-   EE.alloca,-   ) where--import qualified LLVM.Extra.Multi.Vector as MultiVector-import qualified LLVM.Extra.Multi.Value.Private as MultiValue-import qualified LLVM.Extra.Memory as Memory-import LLVM.Extra.Multi.Vector.Instance ()--import qualified LLVM.ExecutionEngine as EE-import qualified LLVM.Core as LLVM--import qualified Type.Data.Num.Decimal as TypeNum--import qualified Control.Functor.HT as FuncHT-import Control.Applicative (liftA2, liftA3, (<$>))--import Foreign.Storable (Storable)-import Foreign.StablePtr (StablePtr)-import Foreign.Ptr (FunPtr, Ptr)--import Data.Complex (Complex((:+)))-import Data.Word (Word8, Word16, Word32, Word64, Word)-import Data.Int  (Int8,  Int16,  Int32,  Int64)----peek ::-   (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> IO a-peek ptr = unpack <$> EE.peek ptr--poke ::-   (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> a -> IO ()-poke ptr = EE.poke ptr . pack---type Struct a = Memory.Struct (MultiValue.Repr a)--class-   (MultiValue.C a, Memory.C (MultiValue.Repr a),-    EE.Marshal (Struct a), LLVM.IsConst (Struct a)) =>-      C a where-   pack :: a -> Struct a-   unpack :: Struct a -> a--instance C Bool   where pack = id; unpack = id-instance C Float  where pack = id; unpack = id-instance C Double where pack = id; unpack = id-instance C Word   where pack = id; unpack = id-instance C Word8  where pack = id; unpack = id-instance C Word16 where pack = id; unpack = id-instance C Word32 where pack = id; unpack = id-instance C Word64 where pack = id; unpack = id-instance C Int    where pack = id; unpack = id-instance C Int8   where pack = id; unpack = id-instance C Int16  where pack = id; unpack = id-instance C Int32  where pack = id; unpack = id-instance C Int64  where pack = id; unpack = id--instance (Storable a)        => C (Ptr a)       where pack = id; unpack = id-instance (LLVM.IsType a)     => C (LLVM.Ptr a)  where pack = id; unpack = id-instance (LLVM.IsFunction a) => C (FunPtr a)    where pack = id; unpack = id-instance                        C (StablePtr a) where pack = id; unpack = id--instance C () where-   pack = LLVM.Struct-   unpack (LLVM.Struct unit) = unit--instance (C a, C b) => C (a,b) where-   pack (a,b) = LLVM.consStruct (pack a) (pack b)-   unpack = LLVM.uncurryStruct $ \a b -> (unpack a, unpack b)--instance (C a, C b, C c) => C (a,b,c) where-   pack (a,b,c) = LLVM.consStruct (pack a) (pack b) (pack c)-   unpack = LLVM.uncurryStruct $ \a b c -> (unpack a, unpack b, unpack c)--instance (C a, C b, C c, C d) => C (a,b,c,d) where-   pack (a,b,c,d) = LLVM.consStruct (pack a) (pack b) (pack c) (pack d)-   unpack =-      LLVM.uncurryStruct $ \a b c d -> (unpack a, unpack b, unpack c, unpack d)---instance (C a) => C (Complex a) where-   pack (a:+b) = LLVM.consStruct (pack a) (pack b)-   unpack = LLVM.uncurryStruct $ \a b -> unpack a :+ unpack b----type VectorStruct n a = Memory.Struct (MultiVector.Repr n a)--class-   (TypeNum.Positive n, C a,-    MultiVector.C a, Memory.C (MultiVector.Repr n a),-    EE.Marshal (VectorStruct n a),-    LLVM.IsConst (VectorStruct n a)) =>-      Vector n a where-   packVector :: LLVM.Vector n a -> VectorStruct n a-   unpackVector :: VectorStruct n a -> LLVM.Vector n a--instance (TypeNum.Positive n, Vector n a) => C (LLVM.Vector n a) where-   pack = packVector; unpack = unpackVector---instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D1)) =>-      Vector n Bool where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>-      Vector n Float where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>-      Vector n Double where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) =>-      Vector n Word where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) =>-      Vector n Word8 where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) =>-      Vector n Word16 where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>-      Vector n Word32 where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>-      Vector n Word64 where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) =>-      Vector n Int where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) =>-      Vector n Int8 where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) =>-      Vector n Int16 where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>-      Vector n Int32 where-   packVector = id-   unpackVector = id--instance-   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>-      Vector n Int64 where-   packVector = id-   unpackVector = id--instance (Vector n a, Vector n b) => Vector n (a,b) where-   packVector x =-      case FuncHT.unzip x of-         (a,b) -> LLVM.consStruct (packVector a) (packVector b)-   unpackVector = LLVM.uncurryStruct $ \a b ->-      liftA2 (,) (unpackVector a) (unpackVector b)--instance (Vector n a, Vector n b, Vector n c) => Vector n (a,b,c) where-   packVector x =-      case FuncHT.unzip3 x of-         (a,b,c) -> LLVM.consStruct (packVector a) (packVector b) (packVector c)-   unpackVector = LLVM.uncurryStruct $ \a b c ->-      liftA3 (,,) (unpackVector a) (unpackVector b) (unpackVector c)-+module LLVM.Extra.Multi.Value.Marshal+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Marshal instead." #-}+   (module LLVM.Extra.Nice.Value.Marshal) where -with :: (C a) => a -> (LLVM.Ptr (Struct a) -> IO b) -> IO b-with a act = EE.alloca $ \ptr -> poke ptr a >> act ptr+import LLVM.Extra.Nice.Value.Marshal
− src/LLVM/Extra/Multi/Value/Private.hs 
@@ -1,1491 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module LLVM.Extra.Multi.Value.Private where--import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Struct as Struct--import qualified LLVM.ExecutionEngine as EE-import qualified LLVM.Core as LLVM-import LLVM.Core (WordN, IntN, )--import qualified Type.Data.Num.Decimal.Number as Dec--import qualified Foreign.Storable.Record.Tuple as StoreTuple-import Foreign.StablePtr (StablePtr, )-import Foreign.Ptr (Ptr, FunPtr, )--import qualified Control.Monad.HT as Monad-import qualified Control.Functor.HT as FuncHT-import Control.Monad (Monad, return, fmap, (>>), )-import Data.Functor (Functor, )--import qualified Data.Tuple.HT as TupleHT-import qualified Data.Tuple as Tup-import qualified Data.EnumBitSet as EnumBitSet-import qualified Data.Enum.Storable as Enum-import qualified Data.Bool8 as Bool8-import Data.Complex (Complex((:+)))-import Data.Tagged (Tagged(Tagged, unTagged))-import Data.Function (id, (.), ($), )-import Data.Maybe (Maybe(Nothing,Just), )-import Data.Bool (Bool(False,True), )-import Data.Word (Word8, Word16, Word32, Word64, Word)-import Data.Int (Int8, Int16, Int32, Int64, Int)-import Data.Bool8 (Bool8)--import qualified Prelude as P-import Prelude (Float, Double, Integer, Rational, )---newtype T a = Cons (Repr a)---class C a where-   type Repr a-   cons :: a -> T a-   undef :: T a-   zero :: T a-   phi :: LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-   addPhi :: LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()--instance C Bool where-   type Repr Bool = LLVM.Value Bool-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Float where-   type Repr Float = LLVM.Value Float-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Double where-   type Repr Double = LLVM.Value Double-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Word where-   type Repr Word = LLVM.Value Word-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Word8 where-   type Repr Word8 = LLVM.Value Word8-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Word16 where-   type Repr Word16 = LLVM.Value Word16-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Word32 where-   type Repr Word32 = LLVM.Value Word32-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Word64 where-   type Repr Word64 = LLVM.Value Word64-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance (Dec.Positive n) => C (LLVM.WordN n) where-   type Repr (LLVM.WordN n) = LLVM.Value (LLVM.WordN n)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Int where-   type Repr Int = LLVM.Value Int-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Int8 where-   type Repr Int8 = LLVM.Value Int8-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Int16 where-   type Repr Int16 = LLVM.Value Int16-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Int32 where-   type Repr Int32 = LLVM.Value Int32-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C Int64 where-   type Repr Int64 = LLVM.Value Int64-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance (Dec.Positive n) => C (LLVM.IntN n) where-   type Repr (LLVM.IntN n) = LLVM.Value (LLVM.IntN n)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance (LLVM.IsType a) => C (LLVM.Ptr a) where-   type Repr (LLVM.Ptr a) = LLVM.Value (LLVM.Ptr a)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C (Ptr a) where-   type Repr (Ptr a) = LLVM.Value (Ptr a)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance (LLVM.IsFunction a) => C (FunPtr a) where-   type Repr (FunPtr a) = LLVM.Value (FunPtr a)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--instance C (StablePtr a) where-   type Repr (StablePtr a) = LLVM.Value (StablePtr a)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive---cast :: (Repr a ~ Repr b) => T a -> T b-cast (Cons a) = Cons a---consPrimitive ::-   (LLVM.IsConst al, LLVM.Value al ~ Repr a) =>-   al -> T a-consPrimitive = Cons . LLVM.valueOf--undefPrimitive, zeroPrimitive ::-   (LLVM.IsType al, LLVM.Value al ~ Repr a) =>-   T a-undefPrimitive = Cons $ LLVM.value LLVM.undef-zeroPrimitive = Cons $ LLVM.value LLVM.zero--phiPrimitive ::-   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr a) =>-   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a--addPhiPrimitive ::-   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr a) =>-   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()-addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b---consTuple :: (Tuple.Value a, Repr a ~ Tuple.ValueOf a) => a -> T a-consTuple = Cons . Tuple.valueOf--undefTuple :: (Repr a ~ al, Tuple.Undefined al) => T a-undefTuple = Cons Tuple.undef--zeroTuple :: (Repr a ~ al, Tuple.Zero al) => T a-zeroTuple = Cons Tuple.zero--phiTuple ::-   (Repr a ~ al, Tuple.Phi al) =>-   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-phiTuple bb (Cons a) = fmap Cons $ Tuple.phi bb a--addPhiTuple ::-   (Repr a ~ al, Tuple.Phi al) =>-   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()-addPhiTuple bb (Cons a) (Cons b) = Tuple.addPhi bb a b---instance C () where-   type Repr () = ()-   cons = consUnit-   undef = undefUnit-   zero = zeroUnit-   phi = phiUnit-   addPhi = addPhiUnit--consUnit :: (Repr a ~ ()) => a -> T a-consUnit _ = Cons ()--undefUnit :: (Repr a ~ ()) => T a-undefUnit = Cons ()--zeroUnit :: (Repr a ~ ()) => T a-zeroUnit = Cons ()--phiUnit ::-   (Repr a ~ ()) =>-   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-phiUnit _bb (Cons ()) = return $ Cons ()--addPhiUnit ::-   (Repr a ~ ()) =>-   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()-addPhiUnit _bb (Cons ()) (Cons ()) = return ()---instance C Bool8 where-   type Repr Bool8 = LLVM.Value Bool-   cons = consPrimitive . Bool8.toBool-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--boolPFrom8 :: T Bool8 -> T Bool-boolPFrom8 (Cons b) = Cons b--bool8FromP :: T Bool -> T Bool8-bool8FromP (Cons b) = Cons b--intFromBool8 :: (NativeInteger i ir) => T Bool8 -> LLVM.CodeGenFunction r (T i)-intFromBool8 = liftM LLVM.zadapt--floatFromBool8 ::-   (NativeFloating a ar) => T Bool8 -> LLVM.CodeGenFunction r (T a)-floatFromBool8 = liftM LLVM.uitofp---instance-   (LLVM.IsInteger w, LLVM.IsConst w, P.Num w, P.Enum e) =>-      C (Enum.T w e) where-   type Repr (Enum.T w e) = LLVM.Value w-   cons = consPrimitive . P.fromIntegral . P.fromEnum . Enum.toPlain-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive--toEnum ::-   (Repr w ~ LLVM.Value w) =>-   T w -> T (Enum.T w e)-toEnum (Cons w) = Cons w--fromEnum ::-   (Repr w ~ LLVM.Value w) =>-   T (Enum.T w e) -> T w-fromEnum (Cons w) = Cons w--succ, pred ::-   (LLVM.IsArithmetic w, SoV.IntegerConstant w) =>-   T (Enum.T w e) -> LLVM.CodeGenFunction r (T (Enum.T w e))-succ = liftM $ \w -> A.add w A.one-pred = liftM $ \w -> A.sub w A.one---- cannot be an instance of 'Comparison' because there is no 'Real' instance-cmpEnum ::-   (LLVM.CmpRet w, LLVM.IsPrimitive w) =>-   LLVM.CmpPredicate -> T (Enum.T w a) -> T (Enum.T w a) ->-   LLVM.CodeGenFunction r (T Bool)-cmpEnum = liftM2 . LLVM.cmp---class (C a) => Bounded a where-   minBound, maxBound :: T a--instance-   (LLVM.IsInteger w, LLVM.IsConst w, P.Num w, P.Enum e, P.Bounded e) =>-      Bounded (Enum.T w e) where-   minBound = cons P.minBound-   maxBound = cons P.maxBound---instance (LLVM.IsInteger w, LLVM.IsConst w) => C (EnumBitSet.T w i) where-   type Repr (EnumBitSet.T w i) = LLVM.Value w-   cons = consPrimitive . EnumBitSet.decons-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive---instance (C a) => C (Maybe a) where-   type Repr (Maybe a) = (LLVM.Value Bool, Repr a)-   cons Nothing = nothing-   cons (Just a) = just $ cons a-   undef = toMaybe undef undef-   zero = toMaybe (cons False) zero-   phi bb ma =-      case splitMaybe ma of-         (b,a) -> Monad.lift2 toMaybe (phi bb b) (phi bb a)-   addPhi bb x y =-      case (splitMaybe x, splitMaybe y) of-         ((xb,xa), (yb,ya)) ->-            addPhi bb xb yb >>-            addPhi bb xa ya--splitMaybe :: T (Maybe a) -> (T Bool, T a)-splitMaybe (Cons (b,a)) = (Cons b, Cons a)--toMaybe :: T Bool -> T a -> T (Maybe a)-toMaybe (Cons b) (Cons a) = Cons (b,a)--nothing :: (C a) => T (Maybe a)-nothing = toMaybe (cons False) undef--just :: T a -> T (Maybe a)-just = toMaybe (cons True)---instance (C a, C b) => C (a,b) where-   type Repr (a, b) = (Repr a, Repr b)-   cons (a,b) = zip (cons a) (cons b)-   undef = zip undef undef-   zero = zip zero zero-   phi bb a =-      case unzip a of-         (a0,a1) ->-            Monad.lift2 zip (phi bb a0) (phi bb a1)-   addPhi bb a b =-      case (unzip a, unzip b) of-         ((a0,a1), (b0,b1)) ->-            addPhi bb a0 b0 >>-            addPhi bb a1 b1--instance (C a, C b, C c) => C (a,b,c) where-   type Repr (a, b, c) = (Repr a, Repr b, Repr c)-   cons (a,b,c) = zip3 (cons a) (cons b) (cons c)-   undef = zip3 undef undef undef-   zero = zip3 zero zero zero-   phi bb a =-      case unzip3 a of-         (a0,a1,a2) ->-            Monad.lift3 zip3 (phi bb a0) (phi bb a1) (phi bb a2)-   addPhi bb a b =-      case (unzip3 a, unzip3 b) of-         ((a0,a1,a2), (b0,b1,b2)) ->-            addPhi bb a0 b0 >>-            addPhi bb a1 b1 >>-            addPhi bb a2 b2--instance (C a, C b, C c, C d) => C (a,b,c,d) where-   type Repr (a, b, c, d) = (Repr a, Repr b, Repr c, Repr d)-   cons (a,b,c,d) = zip4 (cons a) (cons b) (cons c) (cons d)-   undef = zip4 undef undef undef undef-   zero = zip4 zero zero zero zero-   phi bb a =-      case unzip4 a of-         (a0,a1,a2,a3) ->-            Monad.lift4 zip4 (phi bb a0) (phi bb a1) (phi bb a2) (phi bb a3)-   addPhi bb a b =-      case (unzip4 a, unzip4 b) of-         ((a0,a1,a2,a3), (b0,b1,b2,b3)) ->-            addPhi bb a0 b0 >>-            addPhi bb a1 b1 >>-            addPhi bb a2 b2 >>-            addPhi bb a3 b3---fst :: T (a,b) -> T a-fst (Cons (a,_b)) = Cons a--snd :: T (a,b) -> T b-snd (Cons (_a,b)) = Cons b--curry :: (T (a,b) -> c) -> (T a -> T b -> c)-curry f a b = f $ zip a b--uncurry :: (T a -> T b -> c) -> (T (a,b) -> c)-uncurry f = Tup.uncurry f . unzip---mapFst :: (T a0 -> T a1) -> T (a0,b) -> T (a1,b)-mapFst f = Tup.uncurry zip . TupleHT.mapFst f . unzip--mapSnd :: (T b0 -> T b1) -> T (a,b0) -> T (a,b1)-mapSnd f = Tup.uncurry zip . TupleHT.mapSnd f . unzip--mapFstF :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b) -> f (T (a1,b))-mapFstF f = fmap (Tup.uncurry zip) . FuncHT.mapFst f . unzip--mapSndF :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0) -> f (T (a,b1))-mapSndF f = fmap (Tup.uncurry zip) . FuncHT.mapSnd f . unzip--swap :: T (a,b) -> T (b,a)-swap = Tup.uncurry zip . TupleHT.swap . unzip---fst3 :: T (a,b,c) -> T a-fst3 (Cons (a,_b,_c)) = Cons a--snd3 :: T (a,b,c) -> T b-snd3 (Cons (_a,b,_c)) = Cons b--thd3 :: T (a,b,c) -> T c-thd3 (Cons (_a,_b,c)) = Cons c--curry3 :: (T (a,b,c) -> d) -> (T a -> T b -> T c -> d)-curry3 f a b c = f $ zip3 a b c--uncurry3 :: (T a -> T b -> T c -> d) -> (T (a,b,c) -> d)-uncurry3 f = TupleHT.uncurry3 f . unzip3---mapFst3 :: (T a0 -> T a1) -> T (a0,b,c) -> T (a1,b,c)-mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3--mapSnd3 :: (T b0 -> T b1) -> T (a,b0,c) -> T (a,b1,c)-mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3--mapThd3 :: (T c0 -> T c1) -> T (a,b,c0) -> T (a,b,c1)-mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3--mapFst3F :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b,c) -> f (T (a1,b,c))-mapFst3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapFst3 f . unzip3--mapSnd3F :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0,c) -> f (T (a,b1,c))-mapSnd3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapSnd3 f . unzip3--mapThd3F :: (Functor f) => (T c0 -> f (T c1)) -> T (a,b,c0) -> f (T (a,b,c1))-mapThd3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapThd3 f . unzip3---zip :: T a -> T b -> T (a,b)-zip (Cons a) (Cons b) = Cons (a,b)--zip3 :: T a -> T b -> T c -> T (a,b,c)-zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c)--zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)-zip4 (Cons a) (Cons b) (Cons c) (Cons d) = Cons (a,b,c,d)--unzip :: T (a,b) -> (T a, T b)-unzip (Cons (a,b)) = (Cons a, Cons b)--unzip3 :: T (a,b,c) -> (T a, T b, T c)-unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c)--unzip4 :: T (a,b,c,d) -> (T a, T b, T c, T d)-unzip4 (Cons (a,b,c,d)) = (Cons a, Cons b, Cons c, Cons d)---instance (C tuple) => C (StoreTuple.Tuple tuple) where-   type Repr (StoreTuple.Tuple tuple) = Repr tuple-   cons = tuple . cons . StoreTuple.getTuple-   undef = tuple undef-   zero = tuple zero-   phi bb = fmap tuple . phi bb . untuple-   addPhi bb a b = addPhi bb (untuple a) (untuple b)--tuple :: T tuple -> T (StoreTuple.Tuple tuple)-tuple (Cons a) = Cons a--untuple :: T (StoreTuple.Tuple tuple) -> T tuple-untuple (Cons a) = Cons a---class Struct struct where-   consStruct :: (Struct.T struct ~ a) => a -> T a-   undefStruct :: (Struct.T struct ~ a) => T a-   zeroStruct :: (Struct.T struct ~ a) => T a-   phiStruct :: (Struct.T struct ~ a) =>-      LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-   addPhiStruct :: (Struct.T struct ~ a) =>-      LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()--instance (Struct struct) => C (Struct.T struct) where-   type Repr (Struct.T struct) = Struct.T (Repr struct)-   cons = consStruct-   undef = undefStruct-   zero = zeroStruct-   phi = phiStruct-   addPhi = addPhiStruct--instance Struct () where-   consStruct unit = Cons unit-   undefStruct = Cons (Struct.Cons ())-   zeroStruct = Cons (Struct.Cons ())-   phiStruct _bb = return-   addPhiStruct _bb _a _b = return ()--structCons :: T a -> T (Struct.T as) -> T (Struct.T (a,as))-structCons (Cons b) (Cons (Struct.Cons bs)) = Cons (Struct.Cons (b,bs))--structUncons :: T (Struct.T (a,as)) -> (T a, T (Struct.T as))-structUncons (Cons (Struct.Cons (b,bs))) = (Cons b, Cons (Struct.Cons bs))--instance (C a, Struct as) => Struct (a,as) where-   consStruct (Struct.Cons (a,as)) =-      structCons (cons a) (consStruct (Struct.Cons as))-   undefStruct = structCons undef undefStruct-   zeroStruct = structCons zero zeroStruct-   phiStruct bb at =-      case structUncons at of-         (a,as) -> Monad.lift2 structCons (phi bb a) (phiStruct bb as)-   addPhiStruct bb at bt =-      case (structUncons at, structUncons bt) of-         ((a,as), (b,bs)) -> addPhi bb a b >> addPhiStruct bb as bs---instance (LLVM.IsConst a, LLVM.IsFirstClass a) => C (EE.Stored a) where-   type Repr (EE.Stored a) = LLVM.Value a-   cons = Cons . LLVM.valueOf . EE.getStored-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive---instance C a => C (Tagged tag a) where-   type Repr (Tagged tag a) = Repr a-   cons = tag . cons . unTagged-   undef = tag undef-   zero = tag zero-   phi bb = fmap tag . phi bb . untag-   addPhi bb a b = addPhi bb (untag a) (untag b)--tag :: T a -> T (Tagged tag a)-tag = cast--untag :: T (Tagged tag a) -> T a-untag = cast--liftTaggedM ::-   (Monad m) => (T a -> m (T b)) -> T (Tagged tag a) -> m (T (Tagged tag b))-liftTaggedM f = Monad.lift tag . f . untag--liftTaggedM2 ::-   (Monad m) =>-   (T a -> T b -> m (T c)) ->-   T (Tagged tag a) -> T (Tagged tag b) -> m (T (Tagged tag c))-liftTaggedM2 f a b = Monad.lift tag $ f (untag a) (untag b)---instance (C a) => C (Complex a) where-   type Repr (Complex a) = Complex (Repr a)-   cons (a:+b) = consComplex (cons a) (cons b)-   undef = consComplex undef undef-   zero = consComplex zero zero-   phi bb a =-      case deconsComplex a of-         (a0,a1) ->-            Monad.lift2 consComplex (phi bb a0) (phi bb a1)-   addPhi bb a b =-      case (deconsComplex a, deconsComplex b) of-         ((a0,a1), (b0,b1)) ->-            addPhi bb a0 b0 >>-            addPhi bb a1 b1--consComplex :: T a -> T a -> T (Complex a)-consComplex (Cons a) (Cons b) = Cons (a:+b)--deconsComplex :: T (Complex a) -> (T a, T a)-deconsComplex (Cons (a:+b)) = (Cons a, Cons b)----class Compose multituple where-   type Composed multituple-   {- |-   A nested 'zip'.-   -}-   compose :: multituple -> T (Composed multituple)--class-   (Composed (Decomposed T pattern) ~ PatternTuple pattern) =>-      Decompose pattern where-   {- |-   A nested 'unzip'.-   Since it is not obvious how deep to decompose nested tuples,-   you must provide a pattern of the decomposed tuple.-   E.g.--   > f :: MultiValue ((a,b),(c,d)) ->-   >      ((MultiValue a, MultiValue b), MultiValue (c,d))-   > f = decompose ((atom,atom),atom)-   -}-   decompose :: pattern -> T (PatternTuple pattern) -> Decomposed T pattern--type family Decomposed (f :: * -> *) pattern-type family PatternTuple pattern---{- |-A combination of 'compose' and 'decompose'-that let you operate on tuple multivalues as Haskell tuples.--}-modify ::-   (Compose a, Decompose pattern) =>-   pattern ->-   (Decomposed T pattern -> a) ->-   T (PatternTuple pattern) -> T (Composed a)-modify p f = compose . f . decompose p--modify2 ::-   (Compose a, Decompose patternA, Decompose patternB) =>-   patternA ->-   patternB ->-   (Decomposed T patternA -> Decomposed T patternB -> a) ->-   T (PatternTuple patternA) -> T (PatternTuple patternB) -> T (Composed a)-modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b)--modifyF ::-   (Compose a, Decompose pattern, Functor f) =>-   pattern ->-   (Decomposed T pattern -> f a) ->-   T (PatternTuple pattern) -> f (T (Composed a))-modifyF p f = fmap compose . f . decompose p--modifyF2 ::-   (Compose a, Decompose patternA, Decompose patternB,-    Functor f) =>-   patternA ->-   patternB ->-   (Decomposed T patternA -> Decomposed T patternB -> f a) ->-   T (PatternTuple patternA) -> T (PatternTuple patternB) -> f (T (Composed a))-modifyF2 pa pb f a b = fmap compose $ f (decompose pa a) (decompose pb b)----instance Compose (T a) where-   type Composed (T a) = a-   compose = id--instance Decompose (Atom a) where-   decompose _ = id--type instance Decomposed f (Atom a) = f a-type instance PatternTuple (Atom a) = a--data Atom a = Atom--atom :: Atom a-atom = Atom---instance Compose () where-   type Composed () = ()-   compose = cons--instance Decompose () where-   decompose () _ = ()--type instance Decomposed f () = ()-type instance PatternTuple () = ()---instance (Compose a, Compose b) => Compose (a,b) where-   type Composed (a,b) = (Composed a, Composed b)-   compose = Tup.uncurry zip . TupleHT.mapPair (compose, compose)--instance (Decompose pa, Decompose pb) => Decompose (pa,pb) where-   decompose (pa,pb) =-      TupleHT.mapPair (decompose pa, decompose pb) . unzip--type instance Decomposed f (pa,pb) = (Decomposed f pa, Decomposed f pb)-type instance PatternTuple (pa,pb) = (PatternTuple pa, PatternTuple pb)---instance (Compose a, Compose b, Compose c) => Compose (a,b,c) where-   type Composed (a,b,c) = (Composed a, Composed b, Composed c)-   compose = TupleHT.uncurry3 zip3 . TupleHT.mapTriple (compose, compose, compose)--instance-   (Decompose pa, Decompose pb, Decompose pc) =>-      Decompose (pa,pb,pc) where-   decompose (pa,pb,pc) =-      TupleHT.mapTriple (decompose pa, decompose pb, decompose pc) . unzip3--type instance Decomposed f (pa,pb,pc) =-        (Decomposed f pa, Decomposed f pb, Decomposed f pc)-type instance PatternTuple (pa,pb,pc) =-        (PatternTuple pa, PatternTuple pb, PatternTuple pc)---instance (Compose a, Compose b, Compose c, Compose d) => Compose (a,b,c,d) where-   type Composed (a,b,c,d) = (Composed a, Composed b, Composed c, Composed d)-   compose (a,b,c,d) = zip4 (compose a) (compose b) (compose c) (compose d)--instance-   (Decompose pa, Decompose pb, Decompose pc, Decompose pd) =>-      Decompose (pa,pb,pc,pd) where-   decompose (pa,pb,pc,pd) x =-      case unzip4 x of-         (a,b,c,d) ->-            (decompose pa a, decompose pb b, decompose pc c, decompose pd d)-type instance Decomposed f (pa,pb,pc,pd) =-        (Decomposed f pa, Decomposed f pb, Decomposed f pc, Decomposed f pd)-type instance PatternTuple (pa,pb,pc,pd) =-        (PatternTuple pa, PatternTuple pb, PatternTuple pc, PatternTuple pd)---instance (Compose tuple) => Compose (StoreTuple.Tuple tuple) where-   type Composed (StoreTuple.Tuple tuple) = StoreTuple.Tuple (Composed tuple)-   compose = tuple . compose . StoreTuple.getTuple--instance (Decompose p) => Decompose (StoreTuple.Tuple p) where-   decompose (StoreTuple.Tuple p) = StoreTuple.Tuple . decompose p . untuple--type instance Decomposed f (StoreTuple.Tuple p) =-                  StoreTuple.Tuple (Decomposed f p)-type instance PatternTuple (StoreTuple.Tuple p) =-                  StoreTuple.Tuple (PatternTuple p)---instance (Compose a) => Compose (Tagged tag a) where-   type Composed (Tagged tag a) = Tagged tag (Composed a)-   compose = tag . compose . unTagged--instance (Decompose pa) => Decompose (Tagged tag pa) where-   decompose (Tagged p) = Tagged . decompose p . untag--type instance Decomposed f (Tagged tag pa) = Tagged tag (Decomposed f pa)-type instance PatternTuple (Tagged tag pa) = Tagged tag (PatternTuple pa)---instance (Compose a) => Compose (Complex a) where-   type Composed (Complex a) = Complex (Composed a)-   compose (a:+b) = consComplex (compose a) (compose b)--instance (Decompose pa) => Decompose (Complex pa) where-   decompose (pa:+pb) =-      Tup.uncurry (:+) .-      TupleHT.mapPair (decompose pa, decompose pb) . deconsComplex--type instance Decomposed f (Complex pa) = Complex (Decomposed f pa)-type instance PatternTuple (Complex pa) = Complex (PatternTuple pa)--realPart, imagPart :: T (Complex a) -> T a-realPart (Cons (a:+_)) = Cons a-imagPart (Cons (_:+b)) = Cons b----lift1 :: (Repr a -> Repr b) -> T a -> T b-lift1 f (Cons a) = Cons $ f a--liftM0 ::-   (Monad m) =>-   m (Repr a) ->-   m (T a)-liftM0 f = Monad.lift Cons f--liftM ::-   (Monad m) =>-   (Repr a -> m (Repr b)) ->-   T a -> m (T b)-liftM f (Cons a) = Monad.lift Cons $ f a--liftM2 ::-   (Monad m) =>-   (Repr a -> Repr b -> m (Repr c)) ->-   T a -> T b -> m (T c)-liftM2 f (Cons a) (Cons b) = Monad.lift Cons $ f a b--liftM3 ::-   (Monad m) =>-   (Repr a -> Repr b -> Repr c ->-    m (Repr d)) ->-   T a -> T b -> T c -> m (T d)-liftM3 f (Cons a) (Cons b) (Cons c) = Monad.lift Cons $ f a b c---instance (C a) => Tuple.Zero (T a) where-   zero = zero--instance (C a) => Tuple.Undefined (T a) where-   undef = undef--instance (C a) => Tuple.Phi (T a) where-   phi = phi-   addPhi = addPhi---class (C a) => IntegerConstant a where-   fromInteger' :: Integer -> T a--class (IntegerConstant a) => RationalConstant a where-   fromRational' :: Rational -> T a--instance IntegerConstant Float  where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Double where fromInteger' = Cons . LLVM.value . SoV.constFromInteger--instance IntegerConstant Word where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Word8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Word16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Word32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Word64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger--instance IntegerConstant Int where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Int8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Int16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Int32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Int64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger--instance (Dec.Positive n) => IntegerConstant (WordN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance (Dec.Positive n) => IntegerConstant (IntN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger--instance IntegerConstant a => IntegerConstant (Tagged tag a) where-   fromInteger' = tag . fromInteger'--instance RationalConstant Float  where fromRational' = Cons . LLVM.value . SoV.constFromRational-instance RationalConstant Double where fromRational' = Cons . LLVM.value . SoV.constFromRational--instance RationalConstant a => RationalConstant (Tagged tag a) where-   fromRational' = tag . fromRational'---instance (IntegerConstant a) => A.IntegerConstant (T a) where-   fromInteger' = fromInteger'--instance (RationalConstant a) => A.RationalConstant (T a) where-   fromRational' = fromRational'---class (C a) => Additive a where-   add :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   sub :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   neg :: T a -> LLVM.CodeGenFunction r (T a)--instance Additive Float where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Double where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Word where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Word8 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Word16 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Word32 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Word64 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Int where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Int8 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Int16 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Int32 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Int64 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance (Dec.Positive n) => Additive (WordN n) where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance (Dec.Positive n) => Additive (IntN n) where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive a => Additive (Tagged tag a) where-   add = liftTaggedM2 add-   sub = liftTaggedM2 sub-   neg = liftTaggedM neg--instance (Additive a) => A.Additive (T a) where-   zero = zero-   add = add-   sub = sub-   neg = neg--inc, dec ::-   (Additive i, IntegerConstant i) => T i -> LLVM.CodeGenFunction r (T i)-inc x = add x A.one-dec x = sub x A.one---class (Additive a) => PseudoRing a where-   mul :: T a -> T a -> LLVM.CodeGenFunction r (T a)--instance PseudoRing Float where mul = liftM2 LLVM.mul-instance PseudoRing Double where mul = liftM2 LLVM.mul-instance PseudoRing Word where mul = liftM2 LLVM.mul-instance PseudoRing Word8 where mul = liftM2 LLVM.mul-instance PseudoRing Word16 where mul = liftM2 LLVM.mul-instance PseudoRing Word32 where mul = liftM2 LLVM.mul-instance PseudoRing Word64 where mul = liftM2 LLVM.mul-instance PseudoRing Int where mul = liftM2 LLVM.mul-instance PseudoRing Int8 where mul = liftM2 LLVM.mul-instance PseudoRing Int16 where mul = liftM2 LLVM.mul-instance PseudoRing Int32 where mul = liftM2 LLVM.mul-instance PseudoRing Int64 where mul = liftM2 LLVM.mul--instance (PseudoRing a) => PseudoRing (Tagged tag a) where-   mul = liftTaggedM2 mul--instance (PseudoRing a) => A.PseudoRing (T a) where-   mul = mul---class (PseudoRing a) => Field a where-   fdiv :: T a -> T a -> LLVM.CodeGenFunction r (T a)--instance Field Float where-   fdiv = liftM2 LLVM.fdiv--instance Field Double where-   fdiv = liftM2 LLVM.fdiv--instance (Field a) => Field (Tagged tag a) where-   fdiv = liftTaggedM2 fdiv--instance (Field a) => A.Field (T a) where-   fdiv = fdiv---type family Scalar vector-type instance Scalar Float = Float-type instance Scalar Double = Double-type instance Scalar (Tagged tag a) = Tagged tag (Scalar a)-type instance A.Scalar (T a) = T (Scalar a)--class (PseudoRing (Scalar v), Additive v) => PseudoModule v where-   scale :: T (Scalar v) -> T v -> LLVM.CodeGenFunction r (T v)--instance PseudoModule Float where-   scale = liftM2 A.mul--instance PseudoModule Double where-   scale = liftM2 A.mul--instance (PseudoModule a) => PseudoModule (Tagged tag a) where-   scale = liftTaggedM2 scale--instance (PseudoModule a) => A.PseudoModule (T a) where-   scale = scale---class (Additive a) => Real a where-   min :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   max :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   abs :: T a -> LLVM.CodeGenFunction r (T a)-   signum :: T a -> LLVM.CodeGenFunction r (T a)--instance Real Float where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Double where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word8 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word16 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word32 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word64 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int8 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int16 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int32 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int64 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance (Dec.Positive n) => Real (WordN n) where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance (Dec.Positive n) => Real (IntN n) where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance (Real a) => Real (Tagged tag a) where-   min = liftTaggedM2 min-   max = liftTaggedM2 max-   abs = liftTaggedM abs-   signum = liftTaggedM signum--instance (Real a) => A.Real (T a) where-   min = min-   max = max-   abs = abs-   signum = signum---class (Real a) => Fraction a where-   truncate :: T a -> LLVM.CodeGenFunction r (T a)-   fraction :: T a -> LLVM.CodeGenFunction r (T a)--instance Fraction Float where-   truncate = liftM A.truncate-   fraction = liftM A.fraction--instance Fraction Double where-   truncate = liftM A.truncate-   fraction = liftM A.fraction--instance (Fraction a) => Fraction (Tagged tag a) where-   truncate = liftTaggedM truncate-   fraction = liftTaggedM fraction--instance (Fraction a) => A.Fraction (T a) where-   truncate = truncate-   fraction = fraction---class-   (Repr i ~ LLVM.Value ir,-    LLVM.IsInteger ir, SoV.IntegerConstant ir,-    LLVM.CmpRet ir, LLVM.IsPrimitive ir) =>-      NativeInteger i ir where--instance NativeInteger Word   Word   where-instance NativeInteger Word8  Word8  where-instance NativeInteger Word16 Word16 where-instance NativeInteger Word32 Word32 where-instance NativeInteger Word64 Word64 where--instance NativeInteger Int   Int   where-instance NativeInteger Int8  Int8  where-instance NativeInteger Int16 Int16 where-instance NativeInteger Int32 Int32 where-instance NativeInteger Int64 Int64 where--instance NativeInteger a a => NativeInteger (Tagged tag a) a where---class-   (Repr a ~ LLVM.Value ar,-    LLVM.IsFloating ar, SoV.RationalConstant ar,-    LLVM.CmpRet ar, LLVM.IsPrimitive ar) =>-      NativeFloating a ar where--instance NativeFloating Float  Float where-instance NativeFloating Double Double where---truncateToInt, floorToInt, ceilingToInt, roundToIntFast ::-   (NativeInteger i ir, NativeFloating a ar) =>-   T a -> LLVM.CodeGenFunction r (T i)-truncateToInt  = liftM SoV.truncateToInt-floorToInt     = liftM SoV.floorToInt-ceilingToInt   = liftM SoV.ceilingToInt-roundToIntFast = liftM SoV.roundToIntFast--splitFractionToInt ::-   (NativeInteger i ir, NativeFloating a ar) =>-   T a -> LLVM.CodeGenFunction r (T (i,a))-splitFractionToInt = liftM SoV.splitFractionToInt---class Field a => Algebraic a where-   sqrt :: T a -> LLVM.CodeGenFunction r (T a)--instance Algebraic Float where-   sqrt = liftM A.sqrt--instance Algebraic Double where-   sqrt = liftM A.sqrt--instance (Algebraic a) => Algebraic (Tagged tag a) where-   sqrt = liftTaggedM sqrt--instance (Algebraic a) => A.Algebraic (T a) where-   sqrt = sqrt---class Algebraic a => Transcendental a where-   pi :: LLVM.CodeGenFunction r (T a)-   sin, cos, exp, log :: T a -> LLVM.CodeGenFunction r (T a)-   pow :: T a -> T a -> LLVM.CodeGenFunction r (T a)--instance Transcendental Float where-   pi = liftM0 A.pi-   sin = liftM A.sin-   cos = liftM A.cos-   exp = liftM A.exp-   log = liftM A.log-   pow = liftM2 A.pow--instance Transcendental Double where-   pi = liftM0 A.pi-   sin = liftM A.sin-   cos = liftM A.cos-   exp = liftM A.exp-   log = liftM A.log-   pow = liftM2 A.pow--instance (Transcendental a) => Transcendental (Tagged tag a) where-   pi = fmap tag pi-   sin = liftTaggedM sin-   cos = liftTaggedM cos-   exp = liftTaggedM exp-   log = liftTaggedM log-   pow = liftTaggedM2 pow--instance (Transcendental a) => A.Transcendental (T a) where-   pi = pi-   sin = sin-   cos = cos-   exp = exp-   log = log-   pow = pow----class (C a) => Select a where-   select ::-      T Bool -> T a -> T a ->-      LLVM.CodeGenFunction r (T a)--instance Select Bool where select = liftM3 LLVM.select-instance Select Bool8 where select = liftM3 LLVM.select-instance Select Float where select = liftM3 LLVM.select-instance Select Double where select = liftM3 LLVM.select-instance Select Word where select = liftM3 LLVM.select-instance Select Word8 where select = liftM3 LLVM.select-instance Select Word16 where select = liftM3 LLVM.select-instance Select Word32 where select = liftM3 LLVM.select-instance Select Word64 where select = liftM3 LLVM.select-instance Select Int where select = liftM3 LLVM.select-instance Select Int8 where select = liftM3 LLVM.select-instance Select Int16 where select = liftM3 LLVM.select-instance Select Int32 where select = liftM3 LLVM.select-instance Select Int64 where select = liftM3 LLVM.select--instance (Select a, Select b) => Select (a,b) where-   select b =-      modifyF2 (atom,atom) (atom,atom) $-      \(a0,b0) (a1,b1) ->-         Monad.lift2 (,)-            (select b a0 a1)-            (select b b0 b1)--instance (Select a, Select b, Select c) => Select (a,b,c) where-   select b =-      modifyF2 (atom,atom,atom) (atom,atom,atom) $-      \(a0,b0,c0) (a1,b1,c1) ->-         Monad.lift3 (,,)-            (select b a0 a1)-            (select b b0 b1)-            (select b c0 c1)--instance (Select a) => Select (Tagged tag a) where-   select = liftTaggedM2 . select--instance (Select a) => C.Select (T a) where-   select b = select (Cons b)----class (Real a) => Comparison a where-   {- |-   It must hold--   > max x y  ==  do gt <- cmp CmpGT x y; select gt x y-   -}-   cmp ::-      LLVM.CmpPredicate -> T a -> T a ->-      LLVM.CodeGenFunction r (T Bool)--instance Comparison Float where cmp = liftM2 . LLVM.cmp-instance Comparison Double where cmp = liftM2 . LLVM.cmp--instance Comparison Int where cmp = liftM2 . LLVM.cmp-instance Comparison Int8 where cmp = liftM2 . LLVM.cmp-instance Comparison Int16 where cmp = liftM2 . LLVM.cmp-instance Comparison Int32 where cmp = liftM2 . LLVM.cmp-instance Comparison Int64 where cmp = liftM2 . LLVM.cmp--instance Comparison Word where cmp = liftM2 . LLVM.cmp-instance Comparison Word8 where cmp = liftM2 . LLVM.cmp-instance Comparison Word16 where cmp = liftM2 . LLVM.cmp-instance Comparison Word32 where cmp = liftM2 . LLVM.cmp-instance Comparison Word64 where cmp = liftM2 . LLVM.cmp--instance (Dec.Positive n) => Comparison (IntN n) where cmp = liftM2 . LLVM.cmp-instance (Dec.Positive n) => Comparison (WordN n) where cmp = liftM2 . LLVM.cmp--instance (Comparison a) => Comparison (Tagged tag a) where-   cmp p a b = cmp p (untag a) (untag b)--instance (Comparison a) => A.Comparison (T a) where-   type CmpResult (T a) = T Bool-   cmp = cmp----class (Comparison a) => FloatingComparison a where-   fcmp ::-      LLVM.FPPredicate -> T a -> T a ->-      LLVM.CodeGenFunction r (T Bool)--instance FloatingComparison Float where-   fcmp = liftM2 . LLVM.fcmp--instance (FloatingComparison a) => FloatingComparison (Tagged tag a) where-   fcmp p a b = fcmp p (untag a) (untag b)--instance (FloatingComparison a) => A.FloatingComparison (T a) where-   fcmp = fcmp----class (C a) => Logic a where-   and :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   or :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   xor :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   inv :: T a -> LLVM.CodeGenFunction r (T a)--instance Logic Bool where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Bool8 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word8 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word16 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word32 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word64 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance (Dec.Positive n) => Logic (WordN n) where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance (LLVM.IsInteger w, LLVM.IsConst w) => Logic (EnumBitSet.T w i) where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic a => Logic (Tagged tag a) where-   and = liftTaggedM2 and; or = liftTaggedM2 or-   xor = liftTaggedM2 xor; inv = liftTaggedM inv---instance Logic a => A.Logic (T a) where-   and = and-   or = or-   xor = xor-   inv = inv----class BitShift a where-   shl :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   shr :: T a -> T a -> LLVM.CodeGenFunction r (T a)--instance BitShift Word where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word8 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word16 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word32 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word64 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Int where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int8 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int16 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int32 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int64 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr----class (PseudoRing a) => Integral a where-   idiv :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   irem :: T a -> T a -> LLVM.CodeGenFunction r (T a)--instance Integral Word where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem--instance Integral Word32 where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem--instance Integral Word64 where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem--instance Integral Int where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem--instance Integral Int32 where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem--instance Integral Int64 where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem--instance (Integral a) => Integral (Tagged tag a) where-   idiv = liftTaggedM2 idiv-   irem = liftTaggedM2 irem---fromIntegral ::-   (NativeInteger i ir, NativeFloating a ar) =>-   T i -> LLVM.CodeGenFunction r (T a)-fromIntegral = liftM LLVM.inttofp
src/LLVM/Extra/Multi/Value/Storable.hs view
@@ -1,417 +1,5 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-module LLVM.Extra.Multi.Value.Storable (-   -- * Basic class-   C(load, store),-   storeNext,-   modify,--   -- * Classes for tuples and vectors-   Tuple(..),-   Vector(..),-   TupleVector(..),--   -- * Standard method implementations-   loadTraversable,-   loadApplicative,-   storeFoldable,--   -- * Pointer handling-   Storable.advancePtr,-   Storable.incrementPtr,-   Storable.decrementPtr,--   -- * Loops over Storable arrays-   Array.arrayLoop,-   Array.arrayLoop2,-   Array.arrayLoopMaybeCont,-   Array.arrayLoopMaybeCont2,-   ) where--import qualified LLVM.Extra.Storable.Private as Storable-import qualified LLVM.Extra.Storable.Array as Array-import LLVM.Extra.Storable.Private-         (BytePtr, advancePtrStatic, incPtrState, incrementPtr, update,-          castFromBytePtr, castToBytePtr,-          runElements, elementOffset, castElementPtr,-          assemblePrimitive, disassemblePrimitive, proxyFromElement3)--import qualified LLVM.Extra.Multi.Vector as MultiVector-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.ArithmeticPrivate as A--import qualified LLVM.ExecutionEngine as EE-import qualified LLVM.Util.Proxy as LP-import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, Value)--import qualified Type.Data.Num.Decimal as TypeNum--import qualified Control.Monad.Trans.Class as MT-import qualified Control.Monad.Trans.Reader as MR-import qualified Control.Monad.Trans.State as MS-import qualified Control.Applicative.HT as App-import qualified Control.Functor.HT as FuncHT-import Control.Monad (foldM, replicateM, replicateM_, (<=<))-import Control.Applicative (Applicative, pure, (<$>))--import qualified Foreign.Storable.Record.Tuple as StoreTuple-import qualified Foreign.Storable as Store-import Foreign.Ptr (Ptr)--import qualified Data.NonEmpty.Class as NonEmptyC-import qualified Data.Traversable as Trav-import qualified Data.Foldable as Fold-import Data.Orphans ()-import Data.Tuple.HT (uncurry3)-import Data.Complex (Complex)-import Data.Word (Word8, Word16, Word32, Word64, Word)-import Data.Int  (Int8,  Int16,  Int32,  Int64)-import Data.Bool8 (Bool8)----class (Store.Storable a, MultiValue.C a) => C a where-   {--   Not all Storable types have a compatible LLVM type,-   or even more, one LLVM type that is compatible on all platforms.-   -}-   load :: Value (Ptr a) -> CodeGenFunction r (MultiValue.T a)-   store :: MultiValue.T a -> Value (Ptr a) -> CodeGenFunction r ()--storeNext ::-   (C a, Value (Ptr a) ~ ptr) => MultiValue.T a -> ptr -> CodeGenFunction r ptr-storeNext a ptr  =  store a ptr >> incrementPtr ptr--modify ::-   (C a, MultiValue.T a ~ al) =>-   (al -> CodeGenFunction r al) ->-   Value (Ptr a) -> CodeGenFunction r ()-modify f ptr  =  flip store ptr =<< f =<< load ptr---instance-   (EE.Marshal a, LLVM.IsConst a, LLVM.IsFirstClass a) =>-      C (EE.Stored a) where-   load = fmap MultiValue.Cons . LLVM.load <=< castFromStoredPtr-   store (MultiValue.Cons a) = LLVM.store a <=< castFromStoredPtr--castFromStoredPtr ::-   (LLVM.IsType a) =>-   Value (Ptr (EE.Stored a)) -> CodeGenFunction r (Value (LLVM.Ptr a))-castFromStoredPtr = LLVM.bitcast---loadPrimitive ::-   (LLVM.Storable a, MultiValue.Repr a ~ LLVM.Value a) =>-   Value (Ptr a) -> CodeGenFunction r (MultiValue.T a)-loadPrimitive ptr = fmap MultiValue.Cons $ LLVM.load =<< LLVM.bitcast ptr--storePrimitive ::-   (LLVM.Storable a, MultiValue.Repr a ~ LLVM.Value a) =>-   MultiValue.T a -> Value (Ptr a) -> CodeGenFunction r ()-storePrimitive (MultiValue.Cons a) ptr = LLVM.store a =<< LLVM.bitcast ptr--instance C Float where-   load = loadPrimitive; store = storePrimitive--instance C Double where-   load = loadPrimitive; store = storePrimitive--instance C Word where-   load = loadPrimitive; store = storePrimitive--instance C Word8 where-   load = loadPrimitive; store = storePrimitive--instance C Word16 where-   load = loadPrimitive; store = storePrimitive--instance C Word32 where-   load = loadPrimitive; store = storePrimitive--instance C Word64 where-   load = loadPrimitive; store = storePrimitive--instance C Int where-   load = loadPrimitive; store = storePrimitive--instance C Int8 where-   load = loadPrimitive; store = storePrimitive--instance C Int16 where-   load = loadPrimitive; store = storePrimitive--instance C Int32 where-   load = loadPrimitive; store = storePrimitive--instance C Int64 where-   load = loadPrimitive; store = storePrimitive--{- |-Not very efficient implementation-because we want to adapt to @sizeOf Bool@ dynamically.-Unfortunately, LLVM-9's optimizer does not recognize the instruction pattern.-Better use 'Bool8' for booleans.--}-instance C Bool where-   load ptr = do-      bytePtr <- castToBytePtr ptr-      bytes <--         flip MS.evalStateT bytePtr $-            replicateM (Store.sizeOf (False :: Bool))-               (MT.lift . LLVM.load =<< incPtrState)-      let zero = LLVM.valueOf 0-      mask <- foldM A.or zero bytes-      MultiValue.Cons <$> A.cmp LLVM.CmpNE mask zero-   store (MultiValue.Cons b) ptr = do-      bytePtr <- castToBytePtr ptr-      byte <- LLVM.sext b-      flip MS.evalStateT bytePtr $-         replicateM_ (Store.sizeOf (False :: Bool))-            (MT.lift . LLVM.store byte =<< incPtrState)--instance C Bool8 where-   load ptr =-      fmap MultiValue.Cons $-      A.cmp LLVM.CmpNE (LLVM.valueOf 0) =<< LLVM.load =<< castToBytePtr ptr-   store (MultiValue.Cons b) ptr = do-      byte <- LLVM.zext b-      LLVM.store byte =<< castToBytePtr ptr--instance (C a) => C (Complex a) where-   load = loadApplicative; store = storeFoldable----instance (Tuple tuple) => C (StoreTuple.Tuple tuple) where-   load ptr = MultiValue.tuple <$> loadTuple ptr-   store = storeTuple . MultiValue.untuple--class (StoreTuple.Storable tuple, MultiValue.C tuple) => Tuple tuple where-   loadTuple ::-      Value (Ptr (StoreTuple.Tuple tuple)) ->-      CodeGenFunction r (MultiValue.T tuple)-   storeTuple ::-      MultiValue.T tuple ->-      Value (Ptr (StoreTuple.Tuple tuple)) ->-      CodeGenFunction r ()--instance (C a, C b) => Tuple (a,b) where-   loadTuple ptr =-      runElements ptr $ fmap (uncurry MultiValue.zip) $-         App.mapPair (loadElement, loadElement) $-         FuncHT.unzip $ proxyFromElement3 ptr-   storeTuple = MultiValue.uncurry $ \a b ptr ->-      case FuncHT.unzip $ proxyFromElement3 ptr of-         (pa,pb) -> runElements ptr $ storeElement pa a >> storeElement pb b--instance (C a, C b, C c) => Tuple (a,b,c) where-   loadTuple ptr =-      runElements ptr $ fmap (uncurry3 MultiValue.zip3) $-         App.mapTriple (loadElement, loadElement, loadElement) $-         FuncHT.unzip3 $ proxyFromElement3 ptr-   storeTuple = MultiValue.uncurry3 $ \a b c ptr ->-      case FuncHT.unzip3 $ proxyFromElement3 ptr of-         (pa,pb,pc) ->-            runElements ptr $-               storeElement pa a >> storeElement pb b >> storeElement pc c--loadElement ::-   (C a) =>-   LP.Proxy a ->-   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) (MultiValue.T a)-loadElement proxy =-   MT.lift . MT.lift . load =<< elementPtr proxy--storeElement ::-   (C a) =>-   LP.Proxy a -> MultiValue.T a ->-   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) ()-storeElement proxy a =-   MT.lift . MT.lift . store a =<< elementPtr proxy--elementPtr ::-   (C a) =>-   LP.Proxy a ->-   MR.ReaderT BytePtr-      (MS.StateT Int (CodeGenFunction r)) (LLVM.Value (Ptr a))-elementPtr proxy = do-   ptr <- MR.ask-   MT.lift $ do-      offset <- elementOffset proxy-      MT.lift $ castFromBytePtr =<< LLVM.getElementPtr ptr (offset, ())---instance-   (TypeNum.Positive n, Vector a) =>-      C (LLVM.Vector n a) where-   load ptr =-      fmap MultiValue.Cons $-      assembleVector (proxyFromElement3 ptr) =<< loadApplicativeRepr ptr-   store (MultiValue.Cons a) ptr =-      flip storeFoldableRepr ptr-         =<< disassembleVector (proxyFromElement3 ptr) a--class (C a, MultiVector.C a) => Vector a where-   assembleVector ::-      (TypeNum.Positive n) =>-      LP.Proxy a -> LLVM.Vector n (MultiValue.Repr a) ->-      CodeGenFunction r (MultiVector.Repr n a)-   disassembleVector ::-      (TypeNum.Positive n) =>-      LP.Proxy a -> MultiVector.Repr n a ->-      CodeGenFunction r (LLVM.Vector n (MultiValue.Repr a))--instance Vector Float where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Double where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Word where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Word8 where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Word16 where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Word32 where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Word64 where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Int where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Int8 where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Int16 where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Int32 where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Int64 where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Bool where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive--instance Vector Bool8 where-   assembleVector LP.Proxy = assemblePrimitive-   disassembleVector LP.Proxy = disassemblePrimitive---instance-   (Tuple tuple, TupleVector tuple) =>-      Vector (StoreTuple.Tuple tuple) where-   assembleVector = deinterleave . fmap StoreTuple.getTuple-   disassembleVector = interleave . fmap StoreTuple.getTuple---class (MultiVector.C a) => TupleVector a where-   deinterleave ::-      (TypeNum.Positive n) =>-      LP.Proxy a -> LLVM.Vector n (MultiValue.Repr a) ->-      CodeGenFunction r (MultiVector.Repr n a)-   interleave ::-      (TypeNum.Positive n) =>-      LP.Proxy a -> MultiVector.Repr n a ->-      CodeGenFunction r (LLVM.Vector n (MultiValue.Repr a))--instance (Vector a, Vector b) => TupleVector (a,b) where-   deinterleave = FuncHT.uncurry $ \pa pb -> FuncHT.uncurry $ \a b ->-      App.lift2 (,) (assembleVector pa a) (assembleVector pb b)-   interleave = FuncHT.uncurry $ \pa pb (a,b) ->-      App.lift2 (App.lift2 (,))-         (disassembleVector pa a) (disassembleVector pb b)--instance (Vector a, Vector b, Vector c) => TupleVector (a,b,c) where-   deinterleave = FuncHT.uncurry3 $ \pa pb pc -> FuncHT.uncurry3 $ \a b c ->-      App.lift3 (,,)-         (assembleVector pa a)-         (assembleVector pb b)-         (assembleVector pc c)-   interleave = FuncHT.uncurry3 $ \pa pb pc (a,b,c) ->-      App.lift3 (App.lift3 (,,))-         (disassembleVector pa a)-         (disassembleVector pb b)-         (disassembleVector pc c)---{--instance Storable () available since base-4.9/GHC-8.0.-Before we need Data.Orphans.--}-instance C () where-   load _ptr = return $ MultiValue.Cons ()-   store (MultiValue.Cons ()) _ptr = return ()---loadTraversable ::-   (NonEmptyC.Repeat f, Trav.Traversable f,-    C a, MultiValue.Repr fa ~ f (MultiValue.Repr a)) =>-   Value (Ptr (f a)) -> CodeGenFunction r (MultiValue.T fa)-loadTraversable =-   (MS.evalStateT $ fmap MultiValue.Cons $-    Trav.sequence $ NonEmptyC.repeat $ loadState)-      <=< castElementPtr--loadApplicative ::-   (Applicative f, Trav.Traversable f,-    C a, MultiValue.Repr fa ~ f (MultiValue.Repr a)) =>-   Value (Ptr (f a)) -> CodeGenFunction r (MultiValue.T fa)-loadApplicative = fmap MultiValue.Cons . loadApplicativeRepr--loadApplicativeRepr ::-   (Applicative f, Trav.Traversable f, C a) =>-   Value (Ptr (f a)) -> CodeGenFunction r (f (MultiValue.Repr a))-loadApplicativeRepr =-   (MS.evalStateT $ Trav.sequence $ pure loadState) <=< castElementPtr--loadState ::-   (C a, MultiValue.Repr a ~ al) =>-   MS.StateT (Value (Ptr a)) (CodeGenFunction r) al-loadState =-   MT.lift . fmap (\(MultiValue.Cons a) -> a) . load =<< advancePtrState---storeFoldable ::-   (Fold.Foldable f, C a, MultiValue.Repr fa ~ f (MultiValue.Repr a)) =>-    MultiValue.T fa -> Value (Ptr (f a)) -> CodeGenFunction r ()-storeFoldable (MultiValue.Cons xs) = storeFoldableRepr xs--storeFoldableRepr ::-   (Fold.Foldable f, C a) =>-   f (MultiValue.Repr a) -> Value (Ptr (f a)) -> CodeGenFunction r ()-storeFoldableRepr xs =-   MS.evalStateT (Fold.mapM_ storeState xs) <=< castElementPtr--storeState ::-   (C a, MultiValue.Repr a ~ al) =>-   al -> MS.StateT (Value (Ptr a)) (CodeGenFunction r) ()-storeState a = MT.lift . store (MultiValue.Cons a) =<< advancePtrState-+module LLVM.Extra.Multi.Value.Storable+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Storable instead." #-}+   (module LLVM.Extra.Nice.Value.Storable) where -advancePtrState ::-   (C a, Value (Ptr a) ~ ptr) =>-   MS.StateT ptr (CodeGenFunction r) ptr-advancePtrState = update $ advancePtrStatic 1+import LLVM.Extra.Nice.Value.Storable
src/LLVM/Extra/Multi/Value/Vector.hs view
@@ -1,239 +1,5 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module LLVM.Extra.Multi.Value.Vector (-   cons,-   fst, snd,-   fst3, snd3, thd3,-   zip, zip3,-   unzip, unzip3,--   swap,-   mapFst, mapSnd,-   mapFst3, mapSnd3, mapThd3,--   extract, insert,-   replicate,-   iterate,-   dissect,-   dissect1,-   select,-   cmp,-   take, takeRev,--   NativeInteger,-   NativeFloating,-   fromIntegral,-   truncateToInt,-   splitFractionToInt,-   ) where--import qualified LLVM.Extra.Multi.Vector.Instance as Inst-import qualified LLVM.Extra.Multi.Vector as MultiVector-import qualified LLVM.Extra.Multi.Value.Private as MultiValue-import qualified LLVM.Extra.ScalarOrVector as SoV-import LLVM.Extra.Multi.Vector.Instance (MVVector)--import qualified LLVM.Core as LLVM--import qualified Type.Data.Num.Decimal as TypeNum---import qualified Data.NonEmpty as NonEmpty-import qualified Data.Tuple.HT as TupleHT-import qualified Data.Tuple as Tuple-import Data.Word (Word8, Word16, Word32, Word64, Word)-import Data.Int (Int8, Int16, Int32, Int64, Int)--import Prelude (Float, Double, Bool, fmap, (.))---cons ::-   (TypeNum.Positive n, MultiVector.C a) =>-   LLVM.Vector n a -> MVVector n a-cons = Inst.toMultiValue . MultiVector.cons--fst :: MVVector n (a,b) -> MVVector n a-fst = MultiValue.lift1 Tuple.fst--snd :: MVVector n (a,b) -> MVVector n b-snd = MultiValue.lift1 Tuple.snd--swap :: MVVector n (a,b) -> MVVector n (b,a)-swap = MultiValue.lift1 TupleHT.swap--mapFst ::-   (MVVector n a0 -> MVVector n a1) ->-   MVVector n (a0,b) -> MVVector n (a1,b)-mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip--mapSnd ::-   (MVVector n b0 -> MVVector n b1) ->-   MVVector n (a,b0) -> MVVector n (a,b1)-mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip---fst3 :: MVVector n (a,b,c) -> MVVector n a-fst3 = MultiValue.lift1 TupleHT.fst3--snd3 :: MVVector n (a,b,c) -> MVVector n b-snd3 = MultiValue.lift1 TupleHT.snd3--thd3 :: MVVector n (a,b,c) -> MVVector n c-thd3 = MultiValue.lift1 TupleHT.thd3--mapFst3 ::-   (MVVector n a0 -> MVVector n a1) ->-   MVVector n (a0,b,c) -> MVVector n (a1,b,c)-mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3--mapSnd3 ::-   (MVVector n b0 -> MVVector n b1) ->-   MVVector n (a,b0,c) -> MVVector n (a,b1,c)-mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3--mapThd3 ::-   (MVVector n c0 -> MVVector n c1) ->-   MVVector n (a,b,c0) -> MVVector n (a,b,c1)-mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3---zip :: MVVector n a -> MVVector n b -> MVVector n (a,b)-zip (MultiValue.Cons a) (MultiValue.Cons b) = MultiValue.Cons (a,b)--zip3 :: MVVector n a -> MVVector n b -> MVVector n c -> MVVector n (a,b,c)-zip3 (MultiValue.Cons a) (MultiValue.Cons b) (MultiValue.Cons c) =-   MultiValue.Cons (a,b,c)--unzip :: MVVector n (a,b) -> (MVVector n a, MVVector n b)-unzip (MultiValue.Cons (a,b)) = (MultiValue.Cons a, MultiValue.Cons b)--unzip3 :: MVVector n (a,b,c) -> (MVVector n a, MVVector n b, MVVector n c)-unzip3 (MultiValue.Cons (a,b,c)) =-   (MultiValue.Cons a, MultiValue.Cons b, MultiValue.Cons c)---extract ::-   (TypeNum.Positive n, MultiVector.C a) =>-   LLVM.Value Word32 -> MVVector n a ->-   LLVM.CodeGenFunction r (MultiValue.T a)-extract k v = MultiVector.extract k (Inst.fromMultiValue v)--insert ::-   (TypeNum.Positive n, MultiVector.C a) =>-   LLVM.Value Word32 -> MultiValue.T a ->-   MVVector n a -> LLVM.CodeGenFunction r (MVVector n a)-insert k a = Inst.liftMultiValueM (MultiVector.insert k a)---replicate ::-   (TypeNum.Positive n, MultiVector.C a) =>-   MultiValue.T a -> LLVM.CodeGenFunction r (MVVector n a)-replicate = fmap Inst.toMultiValue . MultiVector.replicate--iterate ::-   (TypeNum.Positive n, MultiVector.C a) =>-   (MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T a)) ->-   MultiValue.T a -> LLVM.CodeGenFunction r (MVVector n a)-iterate f = fmap Inst.toMultiValue . MultiVector.iterate f--take ::-   (TypeNum.Positive n, TypeNum.Positive m, MultiVector.C a) =>-   MVVector n a -> LLVM.CodeGenFunction r (MVVector m a)-take = Inst.liftMultiValueM MultiVector.take--takeRev ::-   (TypeNum.Positive n, TypeNum.Positive m, MultiVector.C a) =>-   MVVector n a -> LLVM.CodeGenFunction r (MVVector m a)-takeRev = Inst.liftMultiValueM MultiVector.takeRev---dissect ::-   (TypeNum.Positive n, MultiVector.C a) =>-   MVVector n a -> LLVM.CodeGenFunction r [MultiValue.T a]-dissect = MultiVector.dissect . Inst.fromMultiValue--dissect1 ::-   (TypeNum.Positive n, MultiVector.C a) =>-   MVVector n a -> LLVM.CodeGenFunction r (NonEmpty.T [] (MultiValue.T a))-dissect1 = MultiVector.dissect1 . Inst.fromMultiValue--select ::-   (TypeNum.Positive n, MultiVector.Select a) =>-   MVVector n Bool ->-   MVVector n a -> MVVector n a ->-   LLVM.CodeGenFunction r (MVVector n a)-select = Inst.liftMultiValueM3 MultiVector.select--cmp ::-   (TypeNum.Positive n, MultiVector.Comparison a) =>-   LLVM.CmpPredicate ->-   MVVector n a -> MVVector n a ->-   LLVM.CodeGenFunction r (MVVector n Bool)-cmp = Inst.liftMultiValueM2 . MultiVector.cmp---{--ToDo: make this a super-class of MultiValue.NativeInteger-problem: we need MultiValue.Repr, which provokes an import cycle-maybe we should break the cycle using a ConstraintKind,-i.e. define class NativeIntegerVec in MultiValue,-and define NativeInteger = MultiValue.NativeIntegerVec here-and export only MultiValueVec.NativeInteger constraint synonym.--}-class-   (MultiValue.Repr i ~ LLVM.Value ir,-    LLVM.CmpRet ir, LLVM.IsInteger ir, SoV.IntegerConstant ir) =>-      NativeInteger i ir where--instance NativeInteger Word   Word   where-instance NativeInteger Word8  Word8  where-instance NativeInteger Word16 Word16 where-instance NativeInteger Word32 Word32 where-instance NativeInteger Word64 Word64 where--instance NativeInteger Int   Int   where-instance NativeInteger Int8  Int8  where-instance NativeInteger Int16 Int16 where-instance NativeInteger Int32 Int32 where-instance NativeInteger Int64 Int64 where--instance-   (TypeNum.Positive n, n ~ m,-    MultiVector.NativeInteger n i ir,-    MultiValue.NativeInteger i ir) =>-      NativeInteger (LLVM.Vector n i) (LLVM.Vector m ir) where---class-   (MultiValue.Repr a ~ LLVM.Value ar,-    LLVM.CmpRet ar,  SoV.RationalConstant ar, LLVM.IsFloating ar) =>-      NativeFloating a ar where--instance NativeFloating Float  Float  where-instance NativeFloating Double Double where--instance-   (TypeNum.Positive n, n ~ m,-    MultiVector.NativeFloating n a ar,-    MultiValue.NativeFloating a ar) =>-      NativeFloating (LLVM.Vector n a) (LLVM.Vector m ar) where--fromIntegral ::-   (NativeInteger i ir, NativeFloating a ar,-    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>-   MultiValue.T i -> LLVM.CodeGenFunction r (MultiValue.T a)-fromIntegral = MultiValue.liftM LLVM.inttofp---truncateToInt ::-   (NativeInteger i ir, NativeFloating a ar,-    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>-   MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T i)-truncateToInt = MultiValue.liftM LLVM.fptoint+module LLVM.Extra.Multi.Value.Vector+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Vector instead." #-}+   (module LLVM.Extra.Nice.Value.Vector) where -splitFractionToInt ::-   (NativeInteger i ir, NativeFloating a ar,-    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>-   MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T (i,a))-splitFractionToInt = MultiValue.liftM SoV.splitFractionToInt+import LLVM.Extra.Nice.Value.Vector
src/LLVM/Extra/Multi/Vector.hs view
@@ -1,1306 +1,5 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-module LLVM.Extra.Multi.Vector (-   T(Cons), consPrim, deconsPrim,-   C(..),-   Value,-   map,-   zip, zip3, unzip, unzip3,-   replicate,-   iterate,-   take,-   takeRev,--   sum,-   dotProduct,-   cumulate,-   cumulate1,--   lift1,--   modify,-   assemble,-   dissect,-   dissectList,--   assemble1,-   dissect1,-   dissectList1,--   assembleFromVector,--   reverse,-   rotateUp,-   rotateDown,-   shiftUp,-   shiftDown,-   shiftUpMultiZero,-   shiftDownMultiZero,-   shiftUpMultiUndef,-   shiftDownMultiUndef,--   undefPrimitive,-   shufflePrimitive,-   extractPrimitive,-   insertPrimitive,--   shuffleMatchTraversable,-   insertTraversable,-   extractTraversable,--   IntegerConstant(..),-   RationalConstant(..),-   Additive(..),-   PseudoRing(..),-   Field(..),-   scale,-   PseudoModule(..),-   Real(..),-   Fraction(..),-   NativeInteger, NativeFloating, fromIntegral,-   Algebraic(..),-   Transcendental(..),-   FloatingComparison(..),-   Select(..),-   Comparison(..),-   Logic(..),-   BitShift(..),-   ) where--import qualified LLVM.Extra.Multi.Value.Private as MultiValue-import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Tuple as Tuple--import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, IsPrimitive, valueOf, value, )--import qualified Type.Data.Num.Decimal as TypeNum--import qualified Foreign.Storable.Record.Tuple as StoreTuple--import qualified Data.Traversable as Trav-import qualified Data.NonEmpty.Class as NonEmptyC-import qualified Data.NonEmpty as NonEmpty-import qualified Data.List as List-import qualified Data.Bool8 as Bool8-import Data.Traversable (mapM, sequence, )-import Data.Foldable (foldlM)-import Data.NonEmpty ((!:), )-import Data.Function (flip, (.), ($), )-import Data.Tuple (snd, )-import Data.Maybe (maybe, )-import Data.Ord ((<), )-import Data.Word (Word8, Word16, Word32, Word64, Word)-import Data.Int (Int8, Int16, Int32, Int64, )-import Data.Bool8 (Bool8)-import Data.Bool (Bool, )--import qualified Control.Monad.HT as Monad-import qualified Control.Applicative as App-import qualified Control.Functor.HT as FuncHT-import Control.Monad.HT ((<=<), )-import Control.Monad (Monad, join, fmap, return, (>>), (=<<))-import Control.Applicative (liftA2, (<$>))--import qualified Prelude as P-import Prelude-         (Float, Double, Integer, Int, Rational, asTypeOf, (-), (+), (*), error)---newtype T n a = Cons (Repr n a)--type Value n a = LLVM.Value (LLVM.Vector n a)---consPrim :: (Repr n a ~ Value n ar) => Value n ar -> T n a-consPrim = Cons--deconsPrim :: (Repr n a ~ Value n ar) => T n a -> Value n ar-deconsPrim (Cons a) = a---instance (TypeNum.Positive n, C a) => Tuple.Undefined (T n a) where-   undef = undef--instance (TypeNum.Positive n, C a) => Tuple.Zero (T n a) where-   zero = zero--instance (TypeNum.Positive n, C a) => Tuple.Phi (T n a) where-   phi = phi-   addPhi = addPhi---sizeS :: TypeNum.Positive n => T n a -> TypeNum.Singleton n-sizeS _ = TypeNum.singleton--size :: (TypeNum.Positive n, P.Integral i) => T n a -> i-size = TypeNum.integralFromSingleton . sizeS--last ::-   (TypeNum.Positive n, C a) =>-   T n a -> CodeGenFunction r (MultiValue.T a)-last x = extract (valueOf (size x - 1)) x---zip :: T n a -> T n b -> T n (a,b)-zip (Cons a) (Cons b) = Cons (a,b)--zip3 :: T n a -> T n b -> T n c -> T n (a,b,c)-zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c)--unzip :: T n (a,b) -> (T n a, T n b)-unzip (Cons (a,b)) = (Cons a, Cons b)--unzip3 :: T n (a,b,c) -> (T n a, T n b, T n c)-unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c)---class (MultiValue.C a) => C a where-   type Repr n a-   cons :: (TypeNum.Positive n) => LLVM.Vector n a -> T n a-   undef :: (TypeNum.Positive n) => T n a-   zero :: (TypeNum.Positive n) => T n a-   phi ::-      (TypeNum.Positive n) =>-      LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)-   addPhi ::-      (TypeNum.Positive n) =>-      LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r ()--   shuffle ::-      (TypeNum.Positive n, TypeNum.Positive m) =>-      LLVM.ConstValue (LLVM.Vector m Word32) -> T n a -> T n a ->-      CodeGenFunction r (T m a)-   extract ::-      (TypeNum.Positive n) =>-      LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)-   insert ::-      (TypeNum.Positive n) =>-      LLVM.Value Word32 -> MultiValue.T a ->-      T n a -> CodeGenFunction r (T n a)--instance C Bool where-   type Repr n Bool = LLVM.Value (LLVM.Vector n Bool)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Bool8 where-   type Repr n Bool8 = LLVM.Value (LLVM.Vector n Bool)-   cons = consPrimitive . fmap Bool8.toBool-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Float where-   type Repr n Float = LLVM.Value (LLVM.Vector n Float)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Double where-   type Repr n Double = LLVM.Value (LLVM.Vector n Double)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Int where-   type Repr n Int = LLVM.Value (LLVM.Vector n Int)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Int8 where-   type Repr n Int8 = LLVM.Value (LLVM.Vector n Int8)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Int16 where-   type Repr n Int16 = LLVM.Value (LLVM.Vector n Int16)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Int32 where-   type Repr n Int32 = LLVM.Value (LLVM.Vector n Int32)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Int64 where-   type Repr n Int64 = LLVM.Value (LLVM.Vector n Int64)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Word where-   type Repr n Word = LLVM.Value (LLVM.Vector n Word)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Word8 where-   type Repr n Word8 = LLVM.Value (LLVM.Vector n Word8)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Word16 where-   type Repr n Word16 = LLVM.Value (LLVM.Vector n Word16)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Word32 where-   type Repr n Word32 = LLVM.Value (LLVM.Vector n Word32)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Word64 where-   type Repr n Word64 = LLVM.Value (LLVM.Vector n Word64)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phi = phiPrimitive-   addPhi = addPhiPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--consPrimitive ::-   (TypeNum.Positive n, LLVM.IsConst al, IsPrimitive al,-    Repr n a ~ Value n al) =>-   LLVM.Vector n al -> T n a-consPrimitive = Cons . LLVM.valueOf--undefPrimitive ::-   (TypeNum.Positive n, IsPrimitive al,-    Repr n a ~ Value n al) =>-   T n a-undefPrimitive = Cons $ LLVM.value LLVM.undef--zeroPrimitive ::-   (TypeNum.Positive n, IsPrimitive al,-    Repr n a ~ Value n al) =>-   T n a-zeroPrimitive = Cons $ LLVM.value LLVM.zero--phiPrimitive ::-   (TypeNum.Positive n, IsPrimitive al, Repr n a ~ Value n al) =>-   LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)-phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a--addPhiPrimitive ::-   (TypeNum.Positive n, IsPrimitive al, Repr n a ~ Value n al) =>-   LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r ()-addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b---shufflePrimitive ::-   (TypeNum.Positive n, TypeNum.Positive m, IsPrimitive al,-    MultiValue.Repr a ~ LLVM.Value al,-    Repr n a ~ Value n al,-    Repr m a ~ Value m al) =>-   LLVM.ConstValue (LLVM.Vector m Word32) ->-   T n a -> T n a -> CodeGenFunction r (T m a)-shufflePrimitive k (Cons u) (Cons v) =-   fmap Cons $ LLVM.shufflevector u v k--extractPrimitive ::-   (TypeNum.Positive n, IsPrimitive al,-    MultiValue.Repr a ~ LLVM.Value al,-    Repr n a ~ Value n al) =>-   LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)-extractPrimitive k (Cons v) =-   fmap MultiValue.Cons $ LLVM.extractelement v k--insertPrimitive ::-   (TypeNum.Positive n, IsPrimitive al,-    MultiValue.Repr a ~ LLVM.Value al,-    Repr n a ~ Value n al) =>-   LLVM.Value Word32 ->-   MultiValue.T a -> T n a -> CodeGenFunction r (T n a)-insertPrimitive k (MultiValue.Cons a) (Cons v) =-   fmap Cons $ LLVM.insertelement v a k---instance (C a, C b) => C (a,b) where-   type Repr n (a,b) = (Repr n a, Repr n b)-   cons v = case FuncHT.unzip v of (a,b) -> zip (cons a) (cons b)-   undef = zip undef undef-   zero = zip zero zero--   phi bb a =-      case unzip a of-         (a0,a1) ->-            Monad.lift2 zip (phi bb a0) (phi bb a1)-   addPhi bb a b =-      case (unzip a, unzip b) of-         ((a0,a1), (b0,b1)) ->-            addPhi bb a0 b0 >>-            addPhi bb a1 b1--   shuffle is u v =-      case (unzip u, unzip v) of-         ((u0,u1), (v0,v1)) ->-            Monad.lift2 zip-               (shuffle is u0 v0)-               (shuffle is u1 v1)--   extract k v =-      case unzip v of-         (v0,v1) ->-            Monad.lift2 MultiValue.zip-               (extract k v0)-               (extract k v1)--   insert k a v =-      case (MultiValue.unzip a, unzip v) of-         ((a0,a1), (v0,v1)) ->-            Monad.lift2 zip-               (insert k a0 v0)-               (insert k a1 v1)---instance (C a, C b, C c) => C (a,b,c) where-   type Repr n (a,b,c) = (Repr n a, Repr n b, Repr n c)-   cons v = case FuncHT.unzip3 v of (a,b,c) -> zip3 (cons a) (cons b) (cons c)-   undef = zip3 undef undef undef-   zero = zip3 zero zero zero--   phi bb a =-      case unzip3 a of-         (a0,a1,a2) ->-            Monad.lift3 zip3 (phi bb a0) (phi bb a1) (phi bb a2)-   addPhi bb a b =-      case (unzip3 a, unzip3 b) of-         ((a0,a1,a2), (b0,b1,b2)) ->-            addPhi bb a0 b0 >>-            addPhi bb a1 b1 >>-            addPhi bb a2 b2--   shuffle is u v =-      case (unzip3 u, unzip3 v) of-         ((u0,u1,u2), (v0,v1,v2)) ->-            Monad.lift3 zip3-               (shuffle is u0 v0)-               (shuffle is u1 v1)-               (shuffle is u2 v2)--   extract k v =-      case unzip3 v of-         (v0,v1,v2) ->-            Monad.lift3 MultiValue.zip3-               (extract k v0)-               (extract k v1)-               (extract k v2)--   insert k a v =-      case (MultiValue.unzip3 a, unzip3 v) of-         ((a0,a1,a2), (v0,v1,v2)) ->-            Monad.lift3 zip3-               (insert k a0 v0)-               (insert k a1 v1)-               (insert k a2 v2)---instance (C tuple) => C (StoreTuple.Tuple tuple) where-   type Repr n (StoreTuple.Tuple tuple) = Repr n tuple-   cons = tuple . cons . fmap StoreTuple.getTuple-   undef = tuple undef-   zero = tuple zero-   phi bb = fmap tuple . phi bb . untuple-   addPhi bb a b = addPhi bb (untuple a) (untuple b)-   shuffle is u v = tuple <$> shuffle is (untuple u) (untuple v)-   extract k v = MultiValue.tuple <$> extract k (untuple v)-   insert k a v = tuple <$> insert k (MultiValue.untuple a) (untuple v)--tuple :: T n tuple -> T n (StoreTuple.Tuple tuple)-tuple (Cons a) = Cons a--untuple :: T n (StoreTuple.Tuple tuple) -> T n tuple-untuple (Cons a) = Cons a---class (MultiValue.IntegerConstant a, C a) => IntegerConstant a where-   fromInteger' :: (TypeNum.Positive n) => Integer -> T n a--class-   (MultiValue.RationalConstant a, IntegerConstant a) =>-      RationalConstant a where-   fromRational' :: (TypeNum.Positive n) => Rational -> T n a--instance IntegerConstant Float  where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Double where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Word   where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Word8  where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Word16 where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Word32 where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Word64 where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Int   where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Int8  where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Int16 where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Int32 where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Int64 where fromInteger' = fromIntegerPrimitive--fromIntegerPrimitive ::-   (TypeNum.Positive n, IsPrimitive a, SoV.IntegerConstant a,-    Repr n a ~ Value n a) =>-   Integer -> T n a-fromIntegerPrimitive = Cons . LLVM.value . SoV.constFromInteger--instance RationalConstant Float  where fromRational' = fromRationalPrimitive-instance RationalConstant Double where fromRational' = fromRationalPrimitive--fromRationalPrimitive ::-   (TypeNum.Positive n, IsPrimitive a, SoV.RationalConstant a,-    Repr n a ~ Value n a) =>-   Rational -> T n a-fromRationalPrimitive = Cons . LLVM.value . SoV.constFromRational--instance-   (TypeNum.Positive n, IntegerConstant a) =>-      A.IntegerConstant (T n a) where-   fromInteger' = fromInteger'--instance-   (TypeNum.Positive n, RationalConstant a) =>-      A.RationalConstant (T n a) where-   fromRational' = fromRational'---modify ::-   (TypeNum.Positive n, C a) =>-   LLVM.Value Word32 ->-   (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) ->-   (T n a -> CodeGenFunction r (T n a))-modify k f v =-   flip (insert k) v =<< f =<< extract k v---assemble ::-   (TypeNum.Positive n, C a) =>-   [MultiValue.T a] -> CodeGenFunction r (T n a)-assemble =-   foldlM (\v (k,x) -> insert (valueOf k) x v) undef .-   List.zip [0..]--dissect ::-   (TypeNum.Positive n, C a) =>-   T n a -> LLVM.CodeGenFunction r [MultiValue.T a]-dissect = sequence . dissectList--dissectList ::-   (TypeNum.Positive n, C a) =>-   T n a -> [LLVM.CodeGenFunction r (MultiValue.T a)]-dissectList x =-   List.map-      (flip extract x . LLVM.valueOf)-      (List.take (size x) [0..])---assemble1 ::-   (TypeNum.Positive n, C a) =>-   NonEmpty.T [] (MultiValue.T a) -> CodeGenFunction r (T n a)-assemble1 = assemble . NonEmpty.flatten--dissect1 ::-   (TypeNum.Positive n, C a) =>-   T n a -> LLVM.CodeGenFunction r (NonEmpty.T [] (MultiValue.T a))-dissect1 = sequence . dissectList1--dissectList1 ::-   (TypeNum.Positive n, C a) =>-   T n a -> NonEmpty.T [] (LLVM.CodeGenFunction r (MultiValue.T a))-dissectList1 x =-   fmap-      (flip extract x . LLVM.valueOf)-      (0 !: List.take (size x - 1) [1 ..])---assembleFromVector ::-   (TypeNum.Positive n, C a) =>-   LLVM.Vector n (MultiValue.T a) -> CodeGenFunction r (T n a)-assembleFromVector =-   fmap snd .-   foldlM (\(k,v) x -> (,) (k+1) <$> insert (valueOf k) x v) (0,undef)---map ::-   (TypeNum.Positive n, C a, C b) =>-   (MultiValue.T a -> CodeGenFunction r (MultiValue.T b)) ->-   (T n a -> CodeGenFunction r (T n b))-map f  =  assemble <=< mapM f <=< dissect---singleton :: (C a) => MultiValue.T a -> CodeGenFunction r (T TypeNum.D1 a)-singleton x = insert (LLVM.value LLVM.zero) x undef--replicate ::-   (TypeNum.Positive n, C a) =>-   MultiValue.T a -> CodeGenFunction r (T n a)-replicate x = do-   single <- singleton x-   shuffle (constCyclicVector $ NonEmpty.singleton 0) single undef--iterate ::-   (TypeNum.Positive n, C a) =>-   (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) ->-   MultiValue.T a -> CodeGenFunction r (T n a)-iterate f x = fmap snd $ iterateCore f x Tuple.undef--iterateCore ::-   (TypeNum.Positive n, C a) =>-   (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) ->-   MultiValue.T a -> T n a ->-   CodeGenFunction r (MultiValue.T a, T n a)-iterateCore f x0 v0 =-   foldlM-      (\(x,v) k -> Monad.lift2 (,) (f x) (insert (valueOf k) x v))-      (x0,v0)-      (List.take (size v0) [0..])---sum ::-   (TypeNum.Positive n, Additive a) =>-   T n a -> CodeGenFunction r (MultiValue.T a)-sum =-   NonEmpty.foldBalanced (\x y -> join $ liftA2 MultiValue.add x y) .-   dissectList1--dotProduct ::-   (TypeNum.Positive n, PseudoRing a) =>-   T n a -> T n a -> CodeGenFunction r (MultiValue.T a)-dotProduct x y = sum =<< mul x y---cumulate ::-   (TypeNum.Positive n, Additive a) =>-   MultiValue.T a -> T n a ->-   CodeGenFunction r (MultiValue.T a, T n a)-cumulate a x0 = do-   (b,x1) <- shiftUp a x0-   y <- cumulate1 x1-   z <- A.add b =<< last y-   return (z,y)--{- |-Needs (log n) vector additions--}-cumulate1 ::-   (TypeNum.Positive n, Additive a) =>-   T n a -> CodeGenFunction r (T n a)-cumulate1 x =-   foldlM-      (\y k -> A.add y =<< shiftUpMultiZero k y)-      x-      (List.takeWhile (< size x) $ List.iterate (2*) 1)----- * re-ordering of elements--constCyclicVector ::-   (LLVM.IsConst a, TypeNum.Positive n) =>-   NonEmpty.T [] a -> LLVM.ConstValue (LLVM.Vector n a)-constCyclicVector =-   LLVM.constCyclicVector . fmap LLVM.constOf--shuffleMatch ::-   (TypeNum.Positive n, C a) =>-   LLVM.ConstValue (LLVM.Vector n Word32) -> T n a ->-   CodeGenFunction r (T n a)-shuffleMatch k v = shuffle k v undef--{- |-Rotate one element towards the higher elements.--I don't want to call it rotateLeft or rotateRight,-because there is no prefered layout for the vector elements.-In Intel's instruction manual vector-elements are indexed like the bits,-that is from right to left.-However, when working with Haskell list and enumeration syntax,-the start index is left.--}-rotateUp ::-   (TypeNum.Positive n, C a) =>-   T n a -> CodeGenFunction r (T n a)-rotateUp x =-   shuffleMatch (constCyclicVector $ (size x - 1) !: [0..]) x--rotateDown ::-   (TypeNum.Positive n, C a) =>-   T n a -> CodeGenFunction r (T n a)-rotateDown x =-   shuffleMatch-      (constCyclicVector $-       NonEmpty.snoc (List.take (size x - 1) [1..]) 0) x--reverse ::-   (TypeNum.Positive n, C a) =>-   T n a -> CodeGenFunction r (T n a)-reverse x =-   shuffleMatch-      (constCyclicVector $-       maybe (error "vector size must be positive") NonEmpty.reverse $-       NonEmpty.fetch $-       List.take (size x) [0..])-      x--take ::-   (TypeNum.Positive n, TypeNum.Positive m, C a) =>-   T n a -> CodeGenFunction r (T m a)-take u = shuffle (constCyclicVector $ NonEmptyC.iterate (1+) 0) u undef--takeRev ::-   (TypeNum.Positive n, TypeNum.Positive m, C a) =>-   T n a -> CodeGenFunction r (T m a)-takeRev u = do-   let v0 = zero-   v <--      shuffle-         (constCyclicVector $ NonEmptyC.iterate (1+) (size u - size v0))-         u undef-   return $ v `asTypeOf` v0--shiftUp ::-   (TypeNum.Positive n, C a) =>-   MultiValue.T a -> T n a -> CodeGenFunction r (MultiValue.T a, T n a)-shiftUp x0 x = do-   y <--      shuffleMatch-         (LLVM.constCyclicVector $ LLVM.undef !: List.map LLVM.constOf [0..]) x-   Monad.lift2 (,) (last x) (insert (value LLVM.zero) x0 y)--shiftDown ::-   (TypeNum.Positive n, C a) =>-   MultiValue.T a -> T n a -> CodeGenFunction r (MultiValue.T a, T n a)-shiftDown x0 x = do-   y <--      shuffleMatch-         (LLVM.constCyclicVector $-          NonEmpty.snoc-             (List.map LLVM.constOf $ List.take (size x - 1) [1..])-             LLVM.undef) x-   Monad.lift2 (,)-      (extract (value LLVM.zero) x)-      (insert (LLVM.valueOf (size x - 1)) x0 y)--shiftUpMultiIndices ::-   (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32)-shiftUpMultiIndices n sizev =-   constCyclicVector $ fmap P.fromIntegral $-   NonEmpty.appendLeft (List.replicate n sizev) (NonEmptyC.iterate (1+) 0)--shiftDownMultiIndices ::-   (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32)-shiftDownMultiIndices n sizev =-   constCyclicVector $ fmap P.fromIntegral $-   NonEmpty.appendLeft-      (List.takeWhile (< sizev) $ List.iterate (1+) n)-      (NonEmptyC.repeat sizev)--shiftUpMultiZero ::-   (TypeNum.Positive n, C a) =>-   Int -> T n a -> LLVM.CodeGenFunction r (T n a)-shiftUpMultiZero n v =-   shuffle (shiftUpMultiIndices n (size v)) v zero--shiftDownMultiZero ::-   (TypeNum.Positive n, C a) =>-   Int -> T n a -> LLVM.CodeGenFunction r (T n a)-shiftDownMultiZero n v =-   shuffle (shiftDownMultiIndices n (size v)) v zero--shiftUpMultiUndef ::-   (TypeNum.Positive n, C a) =>-   Int -> T n a -> LLVM.CodeGenFunction r (T n a)-shiftUpMultiUndef n v =-   shuffle (shiftUpMultiIndices n (size v)) v undef--shiftDownMultiUndef ::-   (TypeNum.Positive n, C a) =>-   Int -> T n a -> LLVM.CodeGenFunction r (T n a)-shiftDownMultiUndef n v =-   shuffle (shiftDownMultiIndices n (size v)) v undef----- * method implementations based on Traversable--shuffleMatchTraversable ::-   (TypeNum.Positive n, C a, Trav.Traversable f) =>-   LLVM.ConstValue (LLVM.Vector n Word32) ->-   f (T n a) -> CodeGenFunction r (f (T n a))-shuffleMatchTraversable is v =-   Trav.mapM (shuffleMatch is) v--insertTraversable ::-   (TypeNum.Positive n, C a, Trav.Traversable f, App.Applicative f) =>-   LLVM.Value Word32 -> f (MultiValue.T a) ->-   f (T n a) -> CodeGenFunction r (f (T n a))-insertTraversable n a v =-   Trav.sequence (liftA2 (insert n) a v)--extractTraversable ::-   (TypeNum.Positive n, C a, Trav.Traversable f) =>-   LLVM.Value Word32 -> f (T n a) ->-   CodeGenFunction r (f (MultiValue.T a))-extractTraversable n v =-   Trav.mapM (extract n) v----lift1 :: (Repr n a -> Repr n b) -> T n a -> T n b-lift1 f (Cons a) = Cons $ f a--_liftM0 ::-   (Monad m) =>-   m (Repr n a) ->-   m (T n a)-_liftM0 f = Monad.lift Cons f--liftM0 ::-   (Monad m,-    Repr n a ~ Value n ar) =>-   m (Value n ar) ->-   m (T n a)-liftM0 f = Monad.lift consPrim f--liftM ::-   (Monad m,-    Repr n a ~ Value n ar,-    Repr n b ~ Value n br) =>-   (Value n ar -> m (Value n br)) ->-   T n a -> m (T n b)-liftM f a = Monad.lift consPrim $ f (deconsPrim a)--liftM2 ::-   (Monad m,-    Repr n a ~ Value n ar,-    Repr n b ~ Value n br,-    Repr n c ~ Value n cr) =>-   (Value n ar -> Value n br -> m (Value n cr)) ->-   T n a -> T n b -> m (T n c)-liftM2 f a b = Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b)--liftM3 ::-   (Monad m,-    Repr n a ~ Value n ar,-    Repr n b ~ Value n br,-    Repr n c ~ Value n cr,-    Repr n d ~ Value n dr) =>-   (Value n ar -> Value n br -> Value n cr -> m (Value n dr)) ->-   T n a -> T n b -> T n c -> m (T n d)-liftM3 f a b c =-   Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b) (deconsPrim c)----class (MultiValue.Additive a, C a) => Additive a where-   add ::-      (TypeNum.Positive n) =>-      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)-   sub ::-      (TypeNum.Positive n) =>-      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)-   neg ::-      (TypeNum.Positive n) =>-      T n a -> LLVM.CodeGenFunction r (T n a)--instance Additive Float where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Double where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Int where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Int8 where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Int16 where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Int32 where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Int64 where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Word where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Word8 where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Word16 where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Word32 where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance Additive Word64 where-   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg--instance (TypeNum.Positive n, Additive a) => A.Additive (T n a) where-   zero = zero-   add = add-   sub = sub-   neg = neg---class (MultiValue.PseudoRing a, Additive a) => PseudoRing a where-   mul ::-      (TypeNum.Positive n) =>-      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)--instance PseudoRing Float where-   mul = liftM2 LLVM.mul--instance PseudoRing Double where-   mul = liftM2 LLVM.mul--instance (TypeNum.Positive n, PseudoRing a) => A.PseudoRing (T n a) where-   mul = mul---class (MultiValue.Field a, PseudoRing a) => Field a where-   fdiv ::-      (TypeNum.Positive n) =>-      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)--instance Field Float where-   fdiv = liftM2 LLVM.fdiv--instance Field Double where-   fdiv = liftM2 LLVM.fdiv--instance (TypeNum.Positive n, Field a) => A.Field (T n a) where-   fdiv = fdiv---scale ::-   (TypeNum.Positive n, PseudoRing a) =>-   MultiValue.T a -> T n a -> LLVM.CodeGenFunction r (T n a)-scale a v = flip mul v =<< replicate a---type instance A.Scalar (T n a) = T n (MultiValue.Scalar a)--class-   (MultiValue.PseudoModule v, PseudoRing (MultiValue.Scalar v), Additive v) =>-      PseudoModule v where-   scaleMulti ::-      (TypeNum.Positive n) =>-      T n (MultiValue.Scalar v) -> T n v -> LLVM.CodeGenFunction r (T n v)--instance PseudoModule Float where-   scaleMulti = liftM2 A.mul--instance PseudoModule Double where-   scaleMulti = liftM2 A.mul--instance (TypeNum.Positive n, PseudoModule a) => A.PseudoModule (T n a) where-   scale = scaleMulti---class (MultiValue.Real a, Additive a) => Real a where-   min :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)-   max :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)-   abs :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)-   signum :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)--instance Real Float where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Double where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word8 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word16 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word32 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word64 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int8 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int16 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int32 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int64 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum---instance (TypeNum.Positive n, Real a) => A.Real (T n a) where-   min = min-   max = max-   abs = abs-   signum = signum---class (MultiValue.Fraction a, Real a) => Fraction a where-   truncate :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)-   fraction :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)--instance Fraction Float where-   truncate = liftM A.truncate-   fraction = liftM A.fraction--instance Fraction Double where-   truncate = liftM A.truncate-   fraction = liftM A.fraction--instance (TypeNum.Positive n, Fraction a) => A.Fraction (T n a) where-   truncate = truncate-   fraction = fraction---class-   (TypeNum.Positive n, Repr n i ~ Value n ir,-    MultiValue.NativeInteger i ir, IsPrimitive ir, LLVM.IsInteger ir) =>-      NativeInteger n i ir where--instance (TypeNum.Positive n) => NativeInteger n Word   Word   where-instance (TypeNum.Positive n) => NativeInteger n Word8  Word8  where-instance (TypeNum.Positive n) => NativeInteger n Word16 Word16 where-instance (TypeNum.Positive n) => NativeInteger n Word32 Word32 where-instance (TypeNum.Positive n) => NativeInteger n Word64 Word64 where--instance (TypeNum.Positive n) => NativeInteger n Int   Int   where-instance (TypeNum.Positive n) => NativeInteger n Int8  Int8  where-instance (TypeNum.Positive n) => NativeInteger n Int16 Int16 where-instance (TypeNum.Positive n) => NativeInteger n Int32 Int32 where-instance (TypeNum.Positive n) => NativeInteger n Int64 Int64 where--class-   (TypeNum.Positive n, Repr n a ~ Value n ar,-    MultiValue.NativeFloating a ar, IsPrimitive ar, LLVM.IsFloating ar) =>-      NativeFloating n a ar where--instance (TypeNum.Positive n) => NativeFloating n Float  Float where-instance (TypeNum.Positive n) => NativeFloating n Double Double where--fromIntegral ::-   (NativeInteger n i ir, NativeFloating n a ar) =>-   T n i -> LLVM.CodeGenFunction r (T n a)-fromIntegral = liftM LLVM.inttofp---class (MultiValue.Algebraic a, Field a) => Algebraic a where-   sqrt :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)--instance Algebraic Float where-   sqrt = liftM A.sqrt--instance Algebraic Double where-   sqrt = liftM A.sqrt--instance (TypeNum.Positive n, Algebraic a) => A.Algebraic (T n a) where-   sqrt = sqrt---class (MultiValue.Transcendental a, Algebraic a) => Transcendental a where-   pi :: (TypeNum.Positive n) => LLVM.CodeGenFunction r (T n a)-   sin, cos, exp, log ::-      (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)-   pow ::-      (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)--instance Transcendental Float where-   pi = liftM0 A.pi-   sin = liftM A.sin-   cos = liftM A.cos-   exp = liftM A.exp-   log = liftM A.log-   pow = liftM2 A.pow--instance Transcendental Double where-   pi = liftM0 A.pi-   sin = liftM A.sin-   cos = liftM A.cos-   exp = liftM A.exp-   log = liftM A.log-   pow = liftM2 A.pow--instance (TypeNum.Positive n, Transcendental a) => A.Transcendental (T n a) where-   pi = pi-   sin = sin-   cos = cos-   exp = exp-   log = log-   pow = pow----class (MultiValue.Select a, C a) => Select a where-   select ::-      (TypeNum.Positive n) =>-      T n Bool -> T n a -> T n a ->-      LLVM.CodeGenFunction r (T n a)--instance Select Float where select = liftM3 LLVM.select-instance Select Double where select = liftM3 LLVM.select-instance Select Bool where select = liftM3 LLVM.select-instance Select Word where select = liftM3 LLVM.select-instance Select Word8 where select = liftM3 LLVM.select-instance Select Word16 where select = liftM3 LLVM.select-instance Select Word32 where select = liftM3 LLVM.select-instance Select Word64 where select = liftM3 LLVM.select-instance Select Int where select = liftM3 LLVM.select-instance Select Int8 where select = liftM3 LLVM.select-instance Select Int16 where select = liftM3 LLVM.select-instance Select Int32 where select = liftM3 LLVM.select-instance Select Int64 where select = liftM3 LLVM.select--instance (Select a, Select b) => Select (a,b) where-   select x y0 y1 =-      case (unzip y0, unzip y1) of-         ((a0,b0), (a1,b1)) ->-            Monad.lift2 zip-               (select x a0 a1)-               (select x b0 b1)--instance (Select a, Select b, Select c) => Select (a,b,c) where-   select x y0 y1 =-      case (unzip3 y0, unzip3 y1) of-         ((a0,b0,c0), (a1,b1,c1)) ->-            Monad.lift3 zip3-               (select x a0 a1)-               (select x b0 b1)-               (select x c0 c1)----class (MultiValue.Comparison a, Real a) => Comparison a where-   cmp ::-      (TypeNum.Positive n) =>-      LLVM.CmpPredicate -> T n a -> T n a ->-      LLVM.CodeGenFunction r (T n Bool)--instance Comparison Float where cmp = liftM2 . LLVM.cmp-instance Comparison Double where cmp = liftM2 . LLVM.cmp-instance Comparison Word where cmp = liftM2 . LLVM.cmp-instance Comparison Word8 where cmp = liftM2 . LLVM.cmp-instance Comparison Word16 where cmp = liftM2 . LLVM.cmp-instance Comparison Word32 where cmp = liftM2 . LLVM.cmp-instance Comparison Word64 where cmp = liftM2 . LLVM.cmp-instance Comparison Int where cmp = liftM2 . LLVM.cmp-instance Comparison Int8 where cmp = liftM2 . LLVM.cmp-instance Comparison Int16 where cmp = liftM2 . LLVM.cmp-instance Comparison Int32 where cmp = liftM2 . LLVM.cmp-instance Comparison Int64 where cmp = liftM2 . LLVM.cmp--instance (TypeNum.Positive n, Comparison a) => A.Comparison (T n a) where-   type CmpResult (T n a) = T n Bool-   cmp = cmp----class-   (MultiValue.FloatingComparison a, Comparison a) =>-      FloatingComparison a where-   fcmp ::-      (TypeNum.Positive n) =>-      LLVM.FPPredicate -> T n a -> T n a ->-      LLVM.CodeGenFunction r (T n Bool)--instance FloatingComparison Float where-   fcmp = liftM2 . LLVM.fcmp--instance-   (TypeNum.Positive n, FloatingComparison a) =>-      A.FloatingComparison (T n a) where-   fcmp = fcmp----class (MultiValue.Logic a, C a) => Logic a where-   and, or, xor ::-      (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)-   inv :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)--instance Logic Bool where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word8 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word16 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word32 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word64 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv---instance (TypeNum.Positive n, Logic a) => A.Logic (T n a) where-   and = and-   or = or-   xor = xor-   inv = inv----class (MultiValue.BitShift a, C a) => BitShift a where-   shl :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)-   shr :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)--instance BitShift Word where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word8 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word16 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word32 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word64 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Int where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int8 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int16 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int32 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int64 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr+module LLVM.Extra.Multi.Vector+   {-# DEPRECATED "Use LLVM.Extra.Nice.Vector instead." #-}+   (module LLVM.Extra.Nice.Vector) where++import LLVM.Extra.Nice.Vector
src/LLVM/Extra/Multi/Vector/Instance.hs view
@@ -1,106 +1,36 @@-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module LLVM.Extra.Multi.Vector.Instance where--import qualified LLVM.Extra.Multi.Vector as Vector-import qualified LLVM.Extra.Multi.Value.Private as MultiValue-import LLVM.Extra.Multi.Value.Private (Repr, )--import qualified LLVM.Core as LLVM--import qualified Type.Data.Num.Decimal as TypeNum+module LLVM.Extra.Multi.Vector.Instance+   {-# DEPRECATED "Use LLVM.Extra.Nice.Vector.Instance instead." #-}+   where -import Data.Functor ((<$>), )+import qualified LLVM.Extra.Nice.Vector.Instance as Inst+import qualified LLVM.Extra.Nice.Vector as Vector  import Prelude2010 import Prelude ()  -type MVVector n a = MultiValue.T (LLVM.Vector n a)+type MVVector n a = Inst.NVVector n a  toMultiValue :: Vector.T n a -> MVVector n a-toMultiValue (Vector.Cons x) = MultiValue.Cons x+toMultiValue = Inst.toNiceValue  fromMultiValue :: MVVector n a -> Vector.T n a-fromMultiValue (MultiValue.Cons x) = Vector.Cons x+fromMultiValue = Inst.fromNiceValue  liftMultiValueM ::    (Functor f) =>    (Vector.T n a -> f (Vector.T m b)) ->    (MVVector n a -> f (MVVector m b))-liftMultiValueM f a =-   toMultiValue <$> f (fromMultiValue a)+liftMultiValueM = Inst.liftNiceValueM  liftMultiValueM2 ::    (Functor f) =>    (Vector.T n a -> Vector.T m b -> f (Vector.T k c)) ->    (MVVector n a -> MVVector m b -> f (MVVector k c))-liftMultiValueM2 f a b =-   toMultiValue <$> f (fromMultiValue a) (fromMultiValue b)+liftMultiValueM2 = Inst.liftNiceValueM2  liftMultiValueM3 ::    (Functor f) =>    (Vector.T n a -> Vector.T m b -> Vector.T m c -> f (Vector.T k d)) ->    (MVVector n a -> MVVector m b -> MVVector m c -> f (MVVector k d))-liftMultiValueM3 f a b c =-   toMultiValue <$> f (fromMultiValue a) (fromMultiValue b) (fromMultiValue c)--instance-   (TypeNum.Positive n, Vector.C a) =>-      MultiValue.C (LLVM.Vector n a) where-   type Repr (LLVM.Vector n a) = Vector.Repr n a-   cons = toMultiValue . Vector.cons-   undef = toMultiValue Vector.undef-   zero = toMultiValue Vector.zero-   phi = liftMultiValueM . Vector.phi-   addPhi bb x y = Vector.addPhi bb (fromMultiValue x) (fromMultiValue y)--instance-   (TypeNum.Positive n, Vector.IntegerConstant a) =>-      MultiValue.IntegerConstant (LLVM.Vector n a) where-   fromInteger' = toMultiValue . Vector.fromInteger'--instance-   (TypeNum.Positive n, Vector.RationalConstant a) =>-      MultiValue.RationalConstant (LLVM.Vector n a) where-   fromRational' = toMultiValue . Vector.fromRational'--instance-   (TypeNum.Positive n, Vector.Additive a) =>-      MultiValue.Additive (LLVM.Vector n a) where-   add = liftMultiValueM2 Vector.add-   sub = liftMultiValueM2 Vector.sub-   neg = liftMultiValueM Vector.neg--instance-   (TypeNum.Positive n, Vector.PseudoRing a) =>-      MultiValue.PseudoRing (LLVM.Vector n a) where-   mul = liftMultiValueM2 Vector.mul--instance-   (TypeNum.Positive n, Vector.Real a) =>-      MultiValue.Real (LLVM.Vector n a) where-   min = liftMultiValueM2 Vector.min-   max = liftMultiValueM2 Vector.max-   abs = liftMultiValueM Vector.abs-   signum = liftMultiValueM Vector.signum--instance-   (TypeNum.Positive n, Vector.Fraction a) =>-      MultiValue.Fraction (LLVM.Vector n a) where-   truncate = liftMultiValueM Vector.truncate-   fraction = liftMultiValueM Vector.fraction--instance-   (TypeNum.Positive n, Vector.Logic a) =>-      MultiValue.Logic (LLVM.Vector n a) where-   and = liftMultiValueM2 Vector.and-   or = liftMultiValueM2 Vector.or-   xor = liftMultiValueM2 Vector.xor-   inv = liftMultiValueM Vector.inv--instance-   (TypeNum.Positive n, Vector.BitShift a) =>-      MultiValue.BitShift (LLVM.Vector n a) where-   shl = liftMultiValueM2 Vector.shl-   shr = liftMultiValueM2 Vector.shr+liftMultiValueM3 = Inst.liftNiceValueM3
+ src/LLVM/Extra/Nice/Class.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.Extra.Nice.Class where++import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+++class C value where+   type Size value+   switch ::+      f NiceValue.T ->+      f (NiceVector.T (Size value)) ->+      f value++instance C NiceValue.T where+   type Size NiceValue.T = TypeNum.D1+   switch x _ = x++instance (TypeNum.Positive n) => C (NiceVector.T n) where+   type Size (NiceVector.T n) = n+   switch _ x = x+++newtype Const a value = Const {getConst :: value a}++undef ::+   (C value, Size value ~ n, TypeNum.Positive n, NiceVector.C a) =>+   value a+undef =+   getConst $+   switch+      (Const NiceValue.undef)+      (Const NiceVector.undef)++zero ::+   (C value, Size value ~ n, TypeNum.Positive n, NiceVector.C a) =>+   value a+zero =+   getConst $+   switch+      (Const NiceValue.zero)+      (Const NiceVector.zero)+++newtype+   Op0 r a value =+      Op0 {runOp0 :: LLVM.CodeGenFunction r (value a)}++newtype+   Op1 r a b value =+      Op1 {runOp1 :: value a -> LLVM.CodeGenFunction r (value b)}++newtype+   Op2 r a b c value =+      Op2 {runOp2 :: value a -> value b -> LLVM.CodeGenFunction r (value c)}++add, sub ::+   (TypeNum.Positive n, NiceVector.Additive a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+add = runOp2 $ switch (Op2 A.add) (Op2 A.add)+sub = runOp2 $ switch (Op2 A.sub) (Op2 A.sub)++neg ::+   (TypeNum.Positive n, NiceVector.Additive a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+neg = runOp1 $ switch (Op1 A.neg) (Op1 A.neg)+++mul ::+   (TypeNum.Positive n, NiceVector.PseudoRing a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+mul = runOp2 $ switch (Op2 A.mul) (Op2 A.mul)+fdiv ::+   (TypeNum.Positive n, NiceVector.Field a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+fdiv = runOp2 $ switch (Op2 A.fdiv) (Op2 A.fdiv)++scale ::+   (TypeNum.Positive n, NiceVector.PseudoModule v,+    n ~ Size value, C value) =>+   value (NiceValue.Scalar v) -> value v -> LLVM.CodeGenFunction r (value v)+scale = runOp2 $ switch (Op2 A.scale) (Op2 A.scale)++min, max ::+   (TypeNum.Positive n, NiceVector.Real a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+min = runOp2 $ switch (Op2 A.min) (Op2 A.min)+max = runOp2 $ switch (Op2 A.max) (Op2 A.max)++abs, signum ::+   (TypeNum.Positive n, NiceVector.Real a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+abs = runOp1 $ switch (Op1 A.abs) (Op1 A.abs)+signum = runOp1 $ switch (Op1 A.signum) (Op1 A.signum)++truncate, fraction ::+   (TypeNum.Positive n, NiceVector.Fraction a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+truncate = runOp1 $ switch (Op1 A.truncate) (Op1 A.truncate)+fraction = runOp1 $ switch (Op1 A.fraction) (Op1 A.fraction)++sqrt ::+   (TypeNum.Positive n, NiceVector.Algebraic a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+sqrt = runOp1 $ switch (Op1 A.sqrt) (Op1 A.sqrt)++pi ::+   (TypeNum.Positive n, NiceVector.Transcendental a,+    n ~ Size value, C value) =>+   LLVM.CodeGenFunction r (value a)+pi = runOp0 $ switch (Op0 A.pi) (Op0 A.pi)++sin, cos, exp, log ::+   (TypeNum.Positive n, NiceVector.Transcendental a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+sin = runOp1 $ switch (Op1 A.sin) (Op1 A.sin)+cos = runOp1 $ switch (Op1 A.cos) (Op1 A.cos)+exp = runOp1 $ switch (Op1 A.exp) (Op1 A.exp)+log = runOp1 $ switch (Op1 A.log) (Op1 A.log)++pow ::+   (TypeNum.Positive n, NiceVector.Transcendental a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+pow = runOp2 $ switch (Op2 A.pow) (Op2 A.pow)+++cmp ::+   (TypeNum.Positive n, NiceVector.Comparison a,+    n ~ Size value, C value) =>+   LLVM.CmpPredicate ->+   value a -> value a -> LLVM.CodeGenFunction r (value Bool)+cmp p = runOp2 $ switch (Op2 $ A.cmp p) (Op2 $ A.cmp p)++fcmp ::+   (TypeNum.Positive n, NiceVector.FloatingComparison a,+    n ~ Size value, C value) =>+   LLVM.FPPredicate ->+   value a -> value a -> LLVM.CodeGenFunction r (value Bool)+fcmp p = runOp2 $ switch (Op2 $ A.fcmp p) (Op2 $ A.fcmp p)+++and, or, xor ::+   (TypeNum.Positive n, NiceVector.Logic a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+and = runOp2 $ switch (Op2 A.and) (Op2 A.and)+or = runOp2 $ switch (Op2 A.or) (Op2 A.or)+xor = runOp2 $ switch (Op2 A.xor) (Op2 A.xor)++inv ::+   (TypeNum.Positive n, NiceVector.Logic a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+inv = runOp1 $ switch (Op1 A.inv) (Op1 A.inv)
+ src/LLVM/Extra/Nice/Iterator.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.Nice.Iterator (+   takeWhile,+   countDown,+   take,+   Enum(..),+   ) where++import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.Iterator as Iter+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.MaybePrivate as Maybe+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction)++import Control.Applicative (liftA2)++import qualified Data.Enum.Storable as Enum++import qualified Prelude as P+import Prelude hiding (take, takeWhile, Enum, enumFrom, enumFromTo)++++takeWhile ::+   (a -> CodeGenFunction r (NiceValue.T Bool)) ->+   Iter.T r a -> Iter.T r a+takeWhile p = Iter.takeWhile (fmap unpackBool . p)++unpackBool :: NiceValue.T Bool -> LLVM.Value Bool+unpackBool (NiceValue.Cons b) = b++countDown ::+   (NiceValue.Additive i, NiceValue.Comparison i,+    NiceValue.IntegerConstant i) =>+   NiceValue.T i -> Iter.T r (NiceValue.T i)+countDown len =+   takeWhile (NiceValue.cmp LLVM.CmpLT NiceValue.zero) $+   Iter.iterate NiceValue.dec len++take ::+   (NiceValue.Additive i, NiceValue.Comparison i,+    NiceValue.IntegerConstant i) =>+   NiceValue.T i -> Iter.T r a -> Iter.T r a+take len xs = liftA2 const xs (countDown len)+++class (NiceValue.C a) => Enum a where+   succ, pred :: NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T a)+   enumFrom :: NiceValue.T a -> Iter.T r (NiceValue.T a)+   enumFromTo :: NiceValue.T a -> NiceValue.T a -> Iter.T r (NiceValue.T a)++instance+   (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,+    LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) =>+      Enum (Enum.T w e) where+   succ = NiceValue.succ+   pred = NiceValue.pred+   enumFrom = Iter.iterate NiceValue.succ+   {- |+   More complicated than 'enumFromToSimple'+   but works also for e.g. [0 .. (0xFFFF::Word16)].+   -}+   enumFromTo from to =+      Iter.takeWhileJust $+      Iter.iterate (Maybe.maybeArg Tuple.undef (succMax to)) (Maybe.just from)++succMax ::+   (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,+    LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) =>+   NiceValue.T (Enum.T w e) ->+   NiceValue.T (Enum.T w e) ->+   LLVM.CodeGenFunction r (Maybe.T (NiceValue.T (Enum.T w e)))+succMax to e = do+   NiceValue.Cons less <- NiceValue.cmpEnum A.CmpLT e to+   C.ifThen less (Maybe.nothing Tuple.undef) $+      fmap Maybe.just $ NiceValue.succ e++{- |+Warning: For [0 .. (0xFFFF::Word16)]+it would compute an undefined @0xFFFF+1@.+In modulo arithmetic it would enter an infinite loop.+-}+_enumFromToSimple ::+   (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,+    LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) =>+   NiceValue.T (Enum.T w e) ->+   NiceValue.T (Enum.T w e) ->+   Iter.T r (NiceValue.T (Enum.T w e))+_enumFromToSimple from to =+   takeWhile (NiceValue.cmpEnum LLVM.CmpGE to) $ enumFrom from
+ src/LLVM/Extra/Nice/Value.hs view
@@ -0,0 +1,8 @@+module LLVM.Extra.Nice.Value (+   module LLVM.Extra.Nice.Value.Private,+   Array(..), withArraySize, extractArrayValue, insertArrayValue,+   ) where++import LLVM.Extra.Nice.Vector.Instance ()+import LLVM.Extra.Nice.Value.Array+import LLVM.Extra.Nice.Value.Private
+ src/LLVM/Extra/Nice/Value/Array.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module LLVM.Extra.Nice.Value.Array where++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import LLVM.Extra.Nice.Value.Private (Repr)++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy(Proxy))++import Control.Applicative (Applicative(pure, (<*>)))++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import Data.Functor.Identity (Identity(Identity, runIdentity))+import Data.Functor ((<$>))++import Prelude2010+import Prelude ()++++newtype Array n a = Array [a]+   deriving (Eq, Show)++instance (Dec.Integer n) => Functor (Array n) where+   fmap f (Array xs) = Array (map f xs)++instance (Dec.Integer n) => Applicative (Array n) where+   pure x =+      runIdentity $ withArraySize $+         \n -> Identity $ Array $ replicate (Dec.integralFromProxy n) x+   Array fs <*> Array xs = Array $ zipWith id fs xs++instance (Dec.Integer n) => Fold.Foldable (Array n) where+   foldMap f (Array xs) = Fold.foldMap f xs++instance (Dec.Integer n) => Trav.Traversable (Array n) where+   traverse f (Array xs) = Array <$> Trav.traverse f xs++withArraySize :: (Proxy n -> gen (Array n a)) -> gen (Array n a)+withArraySize f = f Proxy+++instance (TypeNum.Natural n, Marshal.C a) => NiceValue.C (Array n a) where+   type Repr (Array n a) = LLVM.Value (LLVM.Array n (Marshal.Struct a))+   cons (Array xs) = NiceValue.consPrimitive $ LLVM.Array $ map Marshal.pack xs+   undef = NiceValue.undefPrimitive+   zero = NiceValue.zeroPrimitive+   phi = NiceValue.phiPrimitive+   addPhi = NiceValue.addPhiPrimitive++instance+   (TypeNum.Natural n, Marshal.C a,+    Dec.Natural (n Dec.:*: LLVM.SizeOf (Marshal.Struct a))) =>+      Marshal.C (Array n a) where+   pack (Array xs) = LLVM.Array $ map Marshal.pack xs+   unpack (LLVM.Array xs) = Array $ map Marshal.unpack xs++extractArrayValue ::+   (TypeNum.Natural n, LLVM.ArrayIndex n i, Marshal.C a) =>+   i -> NiceValue.T (Array n a) ->+   LLVM.CodeGenFunction r (NiceValue.T a)+extractArrayValue i (NiceValue.Cons arr) =+   NiceValue.Cons <$> (Memory.decompose =<< LLVM.extractvalue arr i)++insertArrayValue ::+   (TypeNum.Natural n, LLVM.ArrayIndex n i, Marshal.C a) =>+   i -> NiceValue.T a -> NiceValue.T (Array n a) ->+   LLVM.CodeGenFunction r (NiceValue.T (Array n a))+insertArrayValue i (NiceValue.Cons a) (NiceValue.Cons arr) =+   NiceValue.Cons <$> (flip (LLVM.insertvalue arr) i =<< Memory.compose a)
+ src/LLVM/Extra/Nice/Value/Marshal.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+Transfer values between Haskell and JIT generated code+in an LLVM-compatible format.+E.g. 'Bool' is stored as 'i1' and occupies a byte,+@'Vector' n 'Bool'@ is stored as a bit vector,+@'Vector' n 'Word8'@ is stored in an order depending on machine endianess,+and Haskell tuples are stored as LLVM structs.+-}+module LLVM.Extra.Nice.Value.Marshal (+   C(..),+   Struct,+   peek,+   poke,++   VectorStruct,+   Vector(..),++   with,+   EE.alloca,+   ) where++import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Nice.Vector.Instance ()++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Control.Functor.HT as FuncHT+import Control.Applicative (liftA2, liftA3, (<$>))++import Foreign.Storable (Storable)+import Foreign.StablePtr (StablePtr)+import Foreign.Ptr (FunPtr, Ptr)++import Data.Complex (Complex((:+)))+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64)++++peek ::+   (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> IO a+peek ptr = unpack <$> EE.peek ptr++poke ::+   (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> a -> IO ()+poke ptr = EE.poke ptr . pack+++type Struct a = Memory.Struct (NiceValue.Repr a)++class+   (NiceValue.C a, Memory.C (NiceValue.Repr a),+    EE.Marshal (Struct a), LLVM.IsConst (Struct a)) =>+      C a where+   pack :: a -> Struct a+   unpack :: Struct a -> a++instance C Bool   where pack = id; unpack = id+instance C Float  where pack = id; unpack = id+instance C Double where pack = id; unpack = id+instance C Word   where pack = id; unpack = id+instance C Word8  where pack = id; unpack = id+instance C Word16 where pack = id; unpack = id+instance C Word32 where pack = id; unpack = id+instance C Word64 where pack = id; unpack = id+instance C Int    where pack = id; unpack = id+instance C Int8   where pack = id; unpack = id+instance C Int16  where pack = id; unpack = id+instance C Int32  where pack = id; unpack = id+instance C Int64  where pack = id; unpack = id++instance (Storable a)        => C (Ptr a)       where pack = id; unpack = id+instance (LLVM.IsType a)     => C (LLVM.Ptr a)  where pack = id; unpack = id+instance (LLVM.IsFunction a) => C (FunPtr a)    where pack = id; unpack = id+instance                        C (StablePtr a) where pack = id; unpack = id++instance C () where+   pack = LLVM.Struct+   unpack (LLVM.Struct unit) = unit++instance (C a, C b) => C (a,b) where+   pack (a,b) = LLVM.consStruct (pack a) (pack b)+   unpack = LLVM.uncurryStruct $ \a b -> (unpack a, unpack b)++instance (C a, C b, C c) => C (a,b,c) where+   pack (a,b,c) = LLVM.consStruct (pack a) (pack b) (pack c)+   unpack = LLVM.uncurryStruct $ \a b c -> (unpack a, unpack b, unpack c)++instance (C a, C b, C c, C d) => C (a,b,c,d) where+   pack (a,b,c,d) = LLVM.consStruct (pack a) (pack b) (pack c) (pack d)+   unpack =+      LLVM.uncurryStruct $ \a b c d -> (unpack a, unpack b, unpack c, unpack d)+++instance (C a) => C (Complex a) where+   pack (a:+b) = LLVM.consStruct (pack a) (pack b)+   unpack = LLVM.uncurryStruct $ \a b -> unpack a :+ unpack b++++type VectorStruct n a = Memory.Struct (NiceVector.Repr n a)++class+   (TypeNum.Positive n, C a,+    NiceVector.C a, Memory.C (NiceVector.Repr n a),+    EE.Marshal (VectorStruct n a),+    LLVM.IsConst (VectorStruct n a)) =>+      Vector n a where+   packVector :: LLVM.Vector n a -> VectorStruct n a+   unpackVector :: VectorStruct n a -> LLVM.Vector n a++instance (TypeNum.Positive n, Vector n a) => C (LLVM.Vector n a) where+   pack = packVector; unpack = unpackVector+++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D1)) =>+      Vector n Bool where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>+      Vector n Float where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>+      Vector n Double where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) =>+      Vector n Word where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) =>+      Vector n Word8 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) =>+      Vector n Word16 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>+      Vector n Word32 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>+      Vector n Word64 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) =>+      Vector n Int where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) =>+      Vector n Int8 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) =>+      Vector n Int16 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>+      Vector n Int32 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>+      Vector n Int64 where+   packVector = id+   unpackVector = id++instance (Vector n a, Vector n b) => Vector n (a,b) where+   packVector x =+      case FuncHT.unzip x of+         (a,b) -> LLVM.consStruct (packVector a) (packVector b)+   unpackVector = LLVM.uncurryStruct $ \a b ->+      liftA2 (,) (unpackVector a) (unpackVector b)++instance (Vector n a, Vector n b, Vector n c) => Vector n (a,b,c) where+   packVector x =+      case FuncHT.unzip3 x of+         (a,b,c) -> LLVM.consStruct (packVector a) (packVector b) (packVector c)+   unpackVector = LLVM.uncurryStruct $ \a b c ->+      liftA3 (,,) (unpackVector a) (unpackVector b) (unpackVector c)+++with :: (C a) => a -> (LLVM.Ptr (Struct a) -> IO b) -> IO b+with a act = EE.alloca $ \ptr -> poke ptr a >> act ptr
+ src/LLVM/Extra/Nice/Value/Private.hs view
@@ -0,0 +1,1491 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module LLVM.Extra.Nice.Value.Private where++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Struct as Struct++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM+import LLVM.Core (WordN, IntN, )++import qualified Type.Data.Num.Decimal.Number as Dec++import qualified Foreign.Storable.Record.Tuple as StoreTuple+import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (Ptr, FunPtr, )++import qualified Control.Monad.HT as Monad+import qualified Control.Functor.HT as FuncHT+import Control.Monad (Monad, return, fmap, (>>), )+import Data.Functor (Functor, )++import qualified Data.Tuple.HT as TupleHT+import qualified Data.Tuple as Tup+import qualified Data.EnumBitSet as EnumBitSet+import qualified Data.Enum.Storable as Enum+import qualified Data.Bool8 as Bool8+import Data.Complex (Complex((:+)))+import Data.Tagged (Tagged(Tagged, unTagged))+import Data.Function (id, (.), ($), )+import Data.Maybe (Maybe(Nothing,Just), )+import Data.Bool (Bool(False,True), )+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int (Int8, Int16, Int32, Int64, Int)+import Data.Bool8 (Bool8)++import qualified Prelude as P+import Prelude (Float, Double, Integer, Rational, )+++newtype T a = Cons (Repr a)+++class C a where+   type Repr a+   cons :: a -> T a+   undef :: T a+   zero :: T a+   phi :: LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+   addPhi :: LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()++instance C Bool where+   type Repr Bool = LLVM.Value Bool+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Float where+   type Repr Float = LLVM.Value Float+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Double where+   type Repr Double = LLVM.Value Double+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Word where+   type Repr Word = LLVM.Value Word+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Word8 where+   type Repr Word8 = LLVM.Value Word8+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Word16 where+   type Repr Word16 = LLVM.Value Word16+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Word32 where+   type Repr Word32 = LLVM.Value Word32+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Word64 where+   type Repr Word64 = LLVM.Value Word64+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance (Dec.Positive n) => C (LLVM.WordN n) where+   type Repr (LLVM.WordN n) = LLVM.Value (LLVM.WordN n)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Int where+   type Repr Int = LLVM.Value Int+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Int8 where+   type Repr Int8 = LLVM.Value Int8+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Int16 where+   type Repr Int16 = LLVM.Value Int16+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Int32 where+   type Repr Int32 = LLVM.Value Int32+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Int64 where+   type Repr Int64 = LLVM.Value Int64+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance (Dec.Positive n) => C (LLVM.IntN n) where+   type Repr (LLVM.IntN n) = LLVM.Value (LLVM.IntN n)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance (LLVM.IsType a) => C (LLVM.Ptr a) where+   type Repr (LLVM.Ptr a) = LLVM.Value (LLVM.Ptr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C (Ptr a) where+   type Repr (Ptr a) = LLVM.Value (Ptr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance (LLVM.IsFunction a) => C (FunPtr a) where+   type Repr (FunPtr a) = LLVM.Value (FunPtr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C (StablePtr a) where+   type Repr (StablePtr a) = LLVM.Value (StablePtr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+++cast :: (Repr a ~ Repr b) => T a -> T b+cast (Cons a) = Cons a+++consPrimitive ::+   (LLVM.IsConst al, LLVM.Value al ~ Repr a) =>+   al -> T a+consPrimitive = Cons . LLVM.valueOf++undefPrimitive, zeroPrimitive ::+   (LLVM.IsType al, LLVM.Value al ~ Repr a) =>+   T a+undefPrimitive = Cons $ LLVM.value LLVM.undef+zeroPrimitive = Cons $ LLVM.value LLVM.zero++phiPrimitive ::+   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr a) =>+   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a++addPhiPrimitive ::+   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr a) =>+   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()+addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b+++consTuple :: (Tuple.Value a, Repr a ~ Tuple.ValueOf a) => a -> T a+consTuple = Cons . Tuple.valueOf++undefTuple :: (Repr a ~ al, Tuple.Undefined al) => T a+undefTuple = Cons Tuple.undef++zeroTuple :: (Repr a ~ al, Tuple.Zero al) => T a+zeroTuple = Cons Tuple.zero++phiTuple ::+   (Repr a ~ al, Tuple.Phi al) =>+   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+phiTuple bb (Cons a) = fmap Cons $ Tuple.phi bb a++addPhiTuple ::+   (Repr a ~ al, Tuple.Phi al) =>+   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()+addPhiTuple bb (Cons a) (Cons b) = Tuple.addPhi bb a b+++instance C () where+   type Repr () = ()+   cons = consUnit+   undef = undefUnit+   zero = zeroUnit+   phi = phiUnit+   addPhi = addPhiUnit++consUnit :: (Repr a ~ ()) => a -> T a+consUnit _ = Cons ()++undefUnit :: (Repr a ~ ()) => T a+undefUnit = Cons ()++zeroUnit :: (Repr a ~ ()) => T a+zeroUnit = Cons ()++phiUnit ::+   (Repr a ~ ()) =>+   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+phiUnit _bb (Cons ()) = return $ Cons ()++addPhiUnit ::+   (Repr a ~ ()) =>+   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()+addPhiUnit _bb (Cons ()) (Cons ()) = return ()+++instance C Bool8 where+   type Repr Bool8 = LLVM.Value Bool+   cons = consPrimitive . Bool8.toBool+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++boolPFrom8 :: T Bool8 -> T Bool+boolPFrom8 (Cons b) = Cons b++bool8FromP :: T Bool -> T Bool8+bool8FromP (Cons b) = Cons b++intFromBool8 :: (NativeInteger i ir) => T Bool8 -> LLVM.CodeGenFunction r (T i)+intFromBool8 = liftM LLVM.zadapt++floatFromBool8 ::+   (NativeFloating a ar) => T Bool8 -> LLVM.CodeGenFunction r (T a)+floatFromBool8 = liftM LLVM.uitofp+++instance+   (LLVM.IsInteger w, LLVM.IsConst w, P.Num w, P.Enum e) =>+      C (Enum.T w e) where+   type Repr (Enum.T w e) = LLVM.Value w+   cons = consPrimitive . P.fromIntegral . P.fromEnum . Enum.toPlain+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++toEnum ::+   (Repr w ~ LLVM.Value w) =>+   T w -> T (Enum.T w e)+toEnum (Cons w) = Cons w++fromEnum ::+   (Repr w ~ LLVM.Value w) =>+   T (Enum.T w e) -> T w+fromEnum (Cons w) = Cons w++succ, pred ::+   (LLVM.IsArithmetic w, SoV.IntegerConstant w) =>+   T (Enum.T w e) -> LLVM.CodeGenFunction r (T (Enum.T w e))+succ = liftM $ \w -> A.add w A.one+pred = liftM $ \w -> A.sub w A.one++-- cannot be an instance of 'Comparison' because there is no 'Real' instance+cmpEnum ::+   (LLVM.CmpRet w, LLVM.IsPrimitive w) =>+   LLVM.CmpPredicate -> T (Enum.T w a) -> T (Enum.T w a) ->+   LLVM.CodeGenFunction r (T Bool)+cmpEnum = liftM2 . LLVM.cmp+++class (C a) => Bounded a where+   minBound, maxBound :: T a++instance+   (LLVM.IsInteger w, LLVM.IsConst w, P.Num w, P.Enum e, P.Bounded e) =>+      Bounded (Enum.T w e) where+   minBound = cons P.minBound+   maxBound = cons P.maxBound+++instance (LLVM.IsInteger w, LLVM.IsConst w) => C (EnumBitSet.T w i) where+   type Repr (EnumBitSet.T w i) = LLVM.Value w+   cons = consPrimitive . EnumBitSet.decons+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+++instance (C a) => C (Maybe a) where+   type Repr (Maybe a) = (LLVM.Value Bool, Repr a)+   cons Nothing = nothing+   cons (Just a) = just $ cons a+   undef = toMaybe undef undef+   zero = toMaybe (cons False) zero+   phi bb ma =+      case splitMaybe ma of+         (b,a) -> Monad.lift2 toMaybe (phi bb b) (phi bb a)+   addPhi bb x y =+      case (splitMaybe x, splitMaybe y) of+         ((xb,xa), (yb,ya)) ->+            addPhi bb xb yb >>+            addPhi bb xa ya++splitMaybe :: T (Maybe a) -> (T Bool, T a)+splitMaybe (Cons (b,a)) = (Cons b, Cons a)++toMaybe :: T Bool -> T a -> T (Maybe a)+toMaybe (Cons b) (Cons a) = Cons (b,a)++nothing :: (C a) => T (Maybe a)+nothing = toMaybe (cons False) undef++just :: T a -> T (Maybe a)+just = toMaybe (cons True)+++instance (C a, C b) => C (a,b) where+   type Repr (a, b) = (Repr a, Repr b)+   cons (a,b) = zip (cons a) (cons b)+   undef = zip undef undef+   zero = zip zero zero+   phi bb a =+      case unzip a of+         (a0,a1) ->+            Monad.lift2 zip (phi bb a0) (phi bb a1)+   addPhi bb a b =+      case (unzip a, unzip b) of+         ((a0,a1), (b0,b1)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1++instance (C a, C b, C c) => C (a,b,c) where+   type Repr (a, b, c) = (Repr a, Repr b, Repr c)+   cons (a,b,c) = zip3 (cons a) (cons b) (cons c)+   undef = zip3 undef undef undef+   zero = zip3 zero zero zero+   phi bb a =+      case unzip3 a of+         (a0,a1,a2) ->+            Monad.lift3 zip3 (phi bb a0) (phi bb a1) (phi bb a2)+   addPhi bb a b =+      case (unzip3 a, unzip3 b) of+         ((a0,a1,a2), (b0,b1,b2)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1 >>+            addPhi bb a2 b2++instance (C a, C b, C c, C d) => C (a,b,c,d) where+   type Repr (a, b, c, d) = (Repr a, Repr b, Repr c, Repr d)+   cons (a,b,c,d) = zip4 (cons a) (cons b) (cons c) (cons d)+   undef = zip4 undef undef undef undef+   zero = zip4 zero zero zero zero+   phi bb a =+      case unzip4 a of+         (a0,a1,a2,a3) ->+            Monad.lift4 zip4 (phi bb a0) (phi bb a1) (phi bb a2) (phi bb a3)+   addPhi bb a b =+      case (unzip4 a, unzip4 b) of+         ((a0,a1,a2,a3), (b0,b1,b2,b3)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1 >>+            addPhi bb a2 b2 >>+            addPhi bb a3 b3+++fst :: T (a,b) -> T a+fst (Cons (a,_b)) = Cons a++snd :: T (a,b) -> T b+snd (Cons (_a,b)) = Cons b++curry :: (T (a,b) -> c) -> (T a -> T b -> c)+curry f a b = f $ zip a b++uncurry :: (T a -> T b -> c) -> (T (a,b) -> c)+uncurry f = Tup.uncurry f . unzip+++mapFst :: (T a0 -> T a1) -> T (a0,b) -> T (a1,b)+mapFst f = Tup.uncurry zip . TupleHT.mapFst f . unzip++mapSnd :: (T b0 -> T b1) -> T (a,b0) -> T (a,b1)+mapSnd f = Tup.uncurry zip . TupleHT.mapSnd f . unzip++mapFstF :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b) -> f (T (a1,b))+mapFstF f = fmap (Tup.uncurry zip) . FuncHT.mapFst f . unzip++mapSndF :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0) -> f (T (a,b1))+mapSndF f = fmap (Tup.uncurry zip) . FuncHT.mapSnd f . unzip++swap :: T (a,b) -> T (b,a)+swap = Tup.uncurry zip . TupleHT.swap . unzip+++fst3 :: T (a,b,c) -> T a+fst3 (Cons (a,_b,_c)) = Cons a++snd3 :: T (a,b,c) -> T b+snd3 (Cons (_a,b,_c)) = Cons b++thd3 :: T (a,b,c) -> T c+thd3 (Cons (_a,_b,c)) = Cons c++curry3 :: (T (a,b,c) -> d) -> (T a -> T b -> T c -> d)+curry3 f a b c = f $ zip3 a b c++uncurry3 :: (T a -> T b -> T c -> d) -> (T (a,b,c) -> d)+uncurry3 f = TupleHT.uncurry3 f . unzip3+++mapFst3 :: (T a0 -> T a1) -> T (a0,b,c) -> T (a1,b,c)+mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3++mapSnd3 :: (T b0 -> T b1) -> T (a,b0,c) -> T (a,b1,c)+mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3++mapThd3 :: (T c0 -> T c1) -> T (a,b,c0) -> T (a,b,c1)+mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3++mapFst3F :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b,c) -> f (T (a1,b,c))+mapFst3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapFst3 f . unzip3++mapSnd3F :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0,c) -> f (T (a,b1,c))+mapSnd3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapSnd3 f . unzip3++mapThd3F :: (Functor f) => (T c0 -> f (T c1)) -> T (a,b,c0) -> f (T (a,b,c1))+mapThd3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapThd3 f . unzip3+++zip :: T a -> T b -> T (a,b)+zip (Cons a) (Cons b) = Cons (a,b)++zip3 :: T a -> T b -> T c -> T (a,b,c)+zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c)++zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)+zip4 (Cons a) (Cons b) (Cons c) (Cons d) = Cons (a,b,c,d)++unzip :: T (a,b) -> (T a, T b)+unzip (Cons (a,b)) = (Cons a, Cons b)++unzip3 :: T (a,b,c) -> (T a, T b, T c)+unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c)++unzip4 :: T (a,b,c,d) -> (T a, T b, T c, T d)+unzip4 (Cons (a,b,c,d)) = (Cons a, Cons b, Cons c, Cons d)+++instance (C tuple) => C (StoreTuple.Tuple tuple) where+   type Repr (StoreTuple.Tuple tuple) = Repr tuple+   cons = tuple . cons . StoreTuple.getTuple+   undef = tuple undef+   zero = tuple zero+   phi bb = fmap tuple . phi bb . untuple+   addPhi bb a b = addPhi bb (untuple a) (untuple b)++tuple :: T tuple -> T (StoreTuple.Tuple tuple)+tuple (Cons a) = Cons a++untuple :: T (StoreTuple.Tuple tuple) -> T tuple+untuple (Cons a) = Cons a+++class Struct struct where+   consStruct :: (Struct.T struct ~ a) => a -> T a+   undefStruct :: (Struct.T struct ~ a) => T a+   zeroStruct :: (Struct.T struct ~ a) => T a+   phiStruct :: (Struct.T struct ~ a) =>+      LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+   addPhiStruct :: (Struct.T struct ~ a) =>+      LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()++instance (Struct struct) => C (Struct.T struct) where+   type Repr (Struct.T struct) = Struct.T (Repr struct)+   cons = consStruct+   undef = undefStruct+   zero = zeroStruct+   phi = phiStruct+   addPhi = addPhiStruct++instance Struct () where+   consStruct unit = Cons unit+   undefStruct = Cons (Struct.Cons ())+   zeroStruct = Cons (Struct.Cons ())+   phiStruct _bb = return+   addPhiStruct _bb _a _b = return ()++structCons :: T a -> T (Struct.T as) -> T (Struct.T (a,as))+structCons (Cons b) (Cons (Struct.Cons bs)) = Cons (Struct.Cons (b,bs))++structUncons :: T (Struct.T (a,as)) -> (T a, T (Struct.T as))+structUncons (Cons (Struct.Cons (b,bs))) = (Cons b, Cons (Struct.Cons bs))++instance (C a, Struct as) => Struct (a,as) where+   consStruct (Struct.Cons (a,as)) =+      structCons (cons a) (consStruct (Struct.Cons as))+   undefStruct = structCons undef undefStruct+   zeroStruct = structCons zero zeroStruct+   phiStruct bb at =+      case structUncons at of+         (a,as) -> Monad.lift2 structCons (phi bb a) (phiStruct bb as)+   addPhiStruct bb at bt =+      case (structUncons at, structUncons bt) of+         ((a,as), (b,bs)) -> addPhi bb a b >> addPhiStruct bb as bs+++instance (LLVM.IsConst a, LLVM.IsFirstClass a) => C (EE.Stored a) where+   type Repr (EE.Stored a) = LLVM.Value a+   cons = Cons . LLVM.valueOf . EE.getStored+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+++instance C a => C (Tagged tag a) where+   type Repr (Tagged tag a) = Repr a+   cons = tag . cons . unTagged+   undef = tag undef+   zero = tag zero+   phi bb = fmap tag . phi bb . untag+   addPhi bb a b = addPhi bb (untag a) (untag b)++tag :: T a -> T (Tagged tag a)+tag = cast++untag :: T (Tagged tag a) -> T a+untag = cast++liftTaggedM ::+   (Monad m) => (T a -> m (T b)) -> T (Tagged tag a) -> m (T (Tagged tag b))+liftTaggedM f = Monad.lift tag . f . untag++liftTaggedM2 ::+   (Monad m) =>+   (T a -> T b -> m (T c)) ->+   T (Tagged tag a) -> T (Tagged tag b) -> m (T (Tagged tag c))+liftTaggedM2 f a b = Monad.lift tag $ f (untag a) (untag b)+++instance (C a) => C (Complex a) where+   type Repr (Complex a) = Complex (Repr a)+   cons (a:+b) = consComplex (cons a) (cons b)+   undef = consComplex undef undef+   zero = consComplex zero zero+   phi bb a =+      case deconsComplex a of+         (a0,a1) ->+            Monad.lift2 consComplex (phi bb a0) (phi bb a1)+   addPhi bb a b =+      case (deconsComplex a, deconsComplex b) of+         ((a0,a1), (b0,b1)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1++consComplex :: T a -> T a -> T (Complex a)+consComplex (Cons a) (Cons b) = Cons (a:+b)++deconsComplex :: T (Complex a) -> (T a, T a)+deconsComplex (Cons (a:+b)) = (Cons a, Cons b)++++class Compose nicetuple where+   type Composed nicetuple+   {- |+   A nested 'zip'.+   -}+   compose :: nicetuple -> T (Composed nicetuple)++class+   (Composed (Decomposed T pattern) ~ PatternTuple pattern) =>+      Decompose pattern where+   {- |+   A nested 'unzip'.+   Since it is not obvious how deep to decompose nested tuples,+   you must provide a pattern of the decomposed tuple.+   E.g.++   > f :: NiceValue ((a,b),(c,d)) ->+   >      ((NiceValue a, NiceValue b), NiceValue (c,d))+   > f = decompose ((atom,atom),atom)+   -}+   decompose :: pattern -> T (PatternTuple pattern) -> Decomposed T pattern++type family Decomposed (f :: * -> *) pattern+type family PatternTuple pattern+++{- |+A combination of 'compose' and 'decompose'+that let you operate on tuple NiceValues as Haskell tuples.+-}+modify ::+   (Compose a, Decompose pattern) =>+   pattern ->+   (Decomposed T pattern -> a) ->+   T (PatternTuple pattern) -> T (Composed a)+modify p f = compose . f . decompose p++modify2 ::+   (Compose a, Decompose patternA, Decompose patternB) =>+   patternA ->+   patternB ->+   (Decomposed T patternA -> Decomposed T patternB -> a) ->+   T (PatternTuple patternA) -> T (PatternTuple patternB) -> T (Composed a)+modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b)++modifyF ::+   (Compose a, Decompose pattern, Functor f) =>+   pattern ->+   (Decomposed T pattern -> f a) ->+   T (PatternTuple pattern) -> f (T (Composed a))+modifyF p f = fmap compose . f . decompose p++modifyF2 ::+   (Compose a, Decompose patternA, Decompose patternB,+    Functor f) =>+   patternA ->+   patternB ->+   (Decomposed T patternA -> Decomposed T patternB -> f a) ->+   T (PatternTuple patternA) -> T (PatternTuple patternB) -> f (T (Composed a))+modifyF2 pa pb f a b = fmap compose $ f (decompose pa a) (decompose pb b)++++instance Compose (T a) where+   type Composed (T a) = a+   compose = id++instance Decompose (Atom a) where+   decompose _ = id++type instance Decomposed f (Atom a) = f a+type instance PatternTuple (Atom a) = a++data Atom a = Atom++atom :: Atom a+atom = Atom+++instance Compose () where+   type Composed () = ()+   compose = cons++instance Decompose () where+   decompose () _ = ()++type instance Decomposed f () = ()+type instance PatternTuple () = ()+++instance (Compose a, Compose b) => Compose (a,b) where+   type Composed (a,b) = (Composed a, Composed b)+   compose = Tup.uncurry zip . TupleHT.mapPair (compose, compose)++instance (Decompose pa, Decompose pb) => Decompose (pa,pb) where+   decompose (pa,pb) =+      TupleHT.mapPair (decompose pa, decompose pb) . unzip++type instance Decomposed f (pa,pb) = (Decomposed f pa, Decomposed f pb)+type instance PatternTuple (pa,pb) = (PatternTuple pa, PatternTuple pb)+++instance (Compose a, Compose b, Compose c) => Compose (a,b,c) where+   type Composed (a,b,c) = (Composed a, Composed b, Composed c)+   compose = TupleHT.uncurry3 zip3 . TupleHT.mapTriple (compose, compose, compose)++instance+   (Decompose pa, Decompose pb, Decompose pc) =>+      Decompose (pa,pb,pc) where+   decompose (pa,pb,pc) =+      TupleHT.mapTriple (decompose pa, decompose pb, decompose pc) . unzip3++type instance Decomposed f (pa,pb,pc) =+        (Decomposed f pa, Decomposed f pb, Decomposed f pc)+type instance PatternTuple (pa,pb,pc) =+        (PatternTuple pa, PatternTuple pb, PatternTuple pc)+++instance (Compose a, Compose b, Compose c, Compose d) => Compose (a,b,c,d) where+   type Composed (a,b,c,d) = (Composed a, Composed b, Composed c, Composed d)+   compose (a,b,c,d) = zip4 (compose a) (compose b) (compose c) (compose d)++instance+   (Decompose pa, Decompose pb, Decompose pc, Decompose pd) =>+      Decompose (pa,pb,pc,pd) where+   decompose (pa,pb,pc,pd) x =+      case unzip4 x of+         (a,b,c,d) ->+            (decompose pa a, decompose pb b, decompose pc c, decompose pd d)+type instance Decomposed f (pa,pb,pc,pd) =+        (Decomposed f pa, Decomposed f pb, Decomposed f pc, Decomposed f pd)+type instance PatternTuple (pa,pb,pc,pd) =+        (PatternTuple pa, PatternTuple pb, PatternTuple pc, PatternTuple pd)+++instance (Compose tuple) => Compose (StoreTuple.Tuple tuple) where+   type Composed (StoreTuple.Tuple tuple) = StoreTuple.Tuple (Composed tuple)+   compose = tuple . compose . StoreTuple.getTuple++instance (Decompose p) => Decompose (StoreTuple.Tuple p) where+   decompose (StoreTuple.Tuple p) = StoreTuple.Tuple . decompose p . untuple++type instance Decomposed f (StoreTuple.Tuple p) =+                  StoreTuple.Tuple (Decomposed f p)+type instance PatternTuple (StoreTuple.Tuple p) =+                  StoreTuple.Tuple (PatternTuple p)+++instance (Compose a) => Compose (Tagged tag a) where+   type Composed (Tagged tag a) = Tagged tag (Composed a)+   compose = tag . compose . unTagged++instance (Decompose pa) => Decompose (Tagged tag pa) where+   decompose (Tagged p) = Tagged . decompose p . untag++type instance Decomposed f (Tagged tag pa) = Tagged tag (Decomposed f pa)+type instance PatternTuple (Tagged tag pa) = Tagged tag (PatternTuple pa)+++instance (Compose a) => Compose (Complex a) where+   type Composed (Complex a) = Complex (Composed a)+   compose (a:+b) = consComplex (compose a) (compose b)++instance (Decompose pa) => Decompose (Complex pa) where+   decompose (pa:+pb) =+      Tup.uncurry (:+) .+      TupleHT.mapPair (decompose pa, decompose pb) . deconsComplex++type instance Decomposed f (Complex pa) = Complex (Decomposed f pa)+type instance PatternTuple (Complex pa) = Complex (PatternTuple pa)++realPart, imagPart :: T (Complex a) -> T a+realPart (Cons (a:+_)) = Cons a+imagPart (Cons (_:+b)) = Cons b++++lift1 :: (Repr a -> Repr b) -> T a -> T b+lift1 f (Cons a) = Cons $ f a++liftM0 ::+   (Monad m) =>+   m (Repr a) ->+   m (T a)+liftM0 f = Monad.lift Cons f++liftM ::+   (Monad m) =>+   (Repr a -> m (Repr b)) ->+   T a -> m (T b)+liftM f (Cons a) = Monad.lift Cons $ f a++liftM2 ::+   (Monad m) =>+   (Repr a -> Repr b -> m (Repr c)) ->+   T a -> T b -> m (T c)+liftM2 f (Cons a) (Cons b) = Monad.lift Cons $ f a b++liftM3 ::+   (Monad m) =>+   (Repr a -> Repr b -> Repr c ->+    m (Repr d)) ->+   T a -> T b -> T c -> m (T d)+liftM3 f (Cons a) (Cons b) (Cons c) = Monad.lift Cons $ f a b c+++instance (C a) => Tuple.Zero (T a) where+   zero = zero++instance (C a) => Tuple.Undefined (T a) where+   undef = undef++instance (C a) => Tuple.Phi (T a) where+   phi = phi+   addPhi = addPhi+++class (C a) => IntegerConstant a where+   fromInteger' :: Integer -> T a++class (IntegerConstant a) => RationalConstant a where+   fromRational' :: Rational -> T a++instance IntegerConstant Float  where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Double where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance IntegerConstant Word where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance IntegerConstant Int where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance (Dec.Positive n) => IntegerConstant (WordN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance (Dec.Positive n) => IntegerConstant (IntN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance IntegerConstant a => IntegerConstant (Tagged tag a) where+   fromInteger' = tag . fromInteger'++instance RationalConstant Float  where fromRational' = Cons . LLVM.value . SoV.constFromRational+instance RationalConstant Double where fromRational' = Cons . LLVM.value . SoV.constFromRational++instance RationalConstant a => RationalConstant (Tagged tag a) where+   fromRational' = tag . fromRational'+++instance (IntegerConstant a) => A.IntegerConstant (T a) where+   fromInteger' = fromInteger'++instance (RationalConstant a) => A.RationalConstant (T a) where+   fromRational' = fromRational'+++class (C a) => Additive a where+   add :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   sub :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   neg :: T a -> LLVM.CodeGenFunction r (T a)++instance Additive Float where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Double where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word8 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word16 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word32 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word64 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int8 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int16 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int32 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int64 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance (Dec.Positive n) => Additive (WordN n) where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance (Dec.Positive n) => Additive (IntN n) where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive a => Additive (Tagged tag a) where+   add = liftTaggedM2 add+   sub = liftTaggedM2 sub+   neg = liftTaggedM neg++instance (Additive a) => A.Additive (T a) where+   zero = zero+   add = add+   sub = sub+   neg = neg++inc, dec ::+   (Additive i, IntegerConstant i) => T i -> LLVM.CodeGenFunction r (T i)+inc x = add x A.one+dec x = sub x A.one+++class (Additive a) => PseudoRing a where+   mul :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance PseudoRing Float where mul = liftM2 LLVM.mul+instance PseudoRing Double where mul = liftM2 LLVM.mul+instance PseudoRing Word where mul = liftM2 LLVM.mul+instance PseudoRing Word8 where mul = liftM2 LLVM.mul+instance PseudoRing Word16 where mul = liftM2 LLVM.mul+instance PseudoRing Word32 where mul = liftM2 LLVM.mul+instance PseudoRing Word64 where mul = liftM2 LLVM.mul+instance PseudoRing Int where mul = liftM2 LLVM.mul+instance PseudoRing Int8 where mul = liftM2 LLVM.mul+instance PseudoRing Int16 where mul = liftM2 LLVM.mul+instance PseudoRing Int32 where mul = liftM2 LLVM.mul+instance PseudoRing Int64 where mul = liftM2 LLVM.mul++instance (PseudoRing a) => PseudoRing (Tagged tag a) where+   mul = liftTaggedM2 mul++instance (PseudoRing a) => A.PseudoRing (T a) where+   mul = mul+++class (PseudoRing a) => Field a where+   fdiv :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance Field Float where+   fdiv = liftM2 LLVM.fdiv++instance Field Double where+   fdiv = liftM2 LLVM.fdiv++instance (Field a) => Field (Tagged tag a) where+   fdiv = liftTaggedM2 fdiv++instance (Field a) => A.Field (T a) where+   fdiv = fdiv+++type family Scalar vector+type instance Scalar Float = Float+type instance Scalar Double = Double+type instance Scalar (Tagged tag a) = Tagged tag (Scalar a)+type instance A.Scalar (T a) = T (Scalar a)++class (PseudoRing (Scalar v), Additive v) => PseudoModule v where+   scale :: T (Scalar v) -> T v -> LLVM.CodeGenFunction r (T v)++instance PseudoModule Float where+   scale = liftM2 A.mul++instance PseudoModule Double where+   scale = liftM2 A.mul++instance (PseudoModule a) => PseudoModule (Tagged tag a) where+   scale = liftTaggedM2 scale++instance (PseudoModule a) => A.PseudoModule (T a) where+   scale = scale+++class (Additive a) => Real a where+   min :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   max :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   abs :: T a -> LLVM.CodeGenFunction r (T a)+   signum :: T a -> LLVM.CodeGenFunction r (T a)++instance Real Float where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Double where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word8 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word16 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int8 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int16 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (Dec.Positive n) => Real (WordN n) where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (Dec.Positive n) => Real (IntN n) where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (Real a) => Real (Tagged tag a) where+   min = liftTaggedM2 min+   max = liftTaggedM2 max+   abs = liftTaggedM abs+   signum = liftTaggedM signum++instance (Real a) => A.Real (T a) where+   min = min+   max = max+   abs = abs+   signum = signum+++class (Real a) => Fraction a where+   truncate :: T a -> LLVM.CodeGenFunction r (T a)+   fraction :: T a -> LLVM.CodeGenFunction r (T a)++instance Fraction Float where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance Fraction Double where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance (Fraction a) => Fraction (Tagged tag a) where+   truncate = liftTaggedM truncate+   fraction = liftTaggedM fraction++instance (Fraction a) => A.Fraction (T a) where+   truncate = truncate+   fraction = fraction+++class+   (Repr i ~ LLVM.Value ir,+    LLVM.IsInteger ir, SoV.IntegerConstant ir,+    LLVM.CmpRet ir, LLVM.IsPrimitive ir) =>+      NativeInteger i ir where++instance NativeInteger Word   Word   where+instance NativeInteger Word8  Word8  where+instance NativeInteger Word16 Word16 where+instance NativeInteger Word32 Word32 where+instance NativeInteger Word64 Word64 where++instance NativeInteger Int   Int   where+instance NativeInteger Int8  Int8  where+instance NativeInteger Int16 Int16 where+instance NativeInteger Int32 Int32 where+instance NativeInteger Int64 Int64 where++instance NativeInteger a a => NativeInteger (Tagged tag a) a where+++class+   (Repr a ~ LLVM.Value ar,+    LLVM.IsFloating ar, SoV.RationalConstant ar,+    LLVM.CmpRet ar, LLVM.IsPrimitive ar) =>+      NativeFloating a ar where++instance NativeFloating Float  Float where+instance NativeFloating Double Double where+++truncateToInt, floorToInt, ceilingToInt, roundToIntFast ::+   (NativeInteger i ir, NativeFloating a ar) =>+   T a -> LLVM.CodeGenFunction r (T i)+truncateToInt  = liftM SoV.truncateToInt+floorToInt     = liftM SoV.floorToInt+ceilingToInt   = liftM SoV.ceilingToInt+roundToIntFast = liftM SoV.roundToIntFast++splitFractionToInt ::+   (NativeInteger i ir, NativeFloating a ar) =>+   T a -> LLVM.CodeGenFunction r (T (i,a))+splitFractionToInt = liftM SoV.splitFractionToInt+++class Field a => Algebraic a where+   sqrt :: T a -> LLVM.CodeGenFunction r (T a)++instance Algebraic Float where+   sqrt = liftM A.sqrt++instance Algebraic Double where+   sqrt = liftM A.sqrt++instance (Algebraic a) => Algebraic (Tagged tag a) where+   sqrt = liftTaggedM sqrt++instance (Algebraic a) => A.Algebraic (T a) where+   sqrt = sqrt+++class Algebraic a => Transcendental a where+   pi :: LLVM.CodeGenFunction r (T a)+   sin, cos, exp, log :: T a -> LLVM.CodeGenFunction r (T a)+   pow :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance Transcendental Float where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance Transcendental Double where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance (Transcendental a) => Transcendental (Tagged tag a) where+   pi = fmap tag pi+   sin = liftTaggedM sin+   cos = liftTaggedM cos+   exp = liftTaggedM exp+   log = liftTaggedM log+   pow = liftTaggedM2 pow++instance (Transcendental a) => A.Transcendental (T a) where+   pi = pi+   sin = sin+   cos = cos+   exp = exp+   log = log+   pow = pow++++class (C a) => Select a where+   select ::+      T Bool -> T a -> T a ->+      LLVM.CodeGenFunction r (T a)++instance Select Bool where select = liftM3 LLVM.select+instance Select Bool8 where select = liftM3 LLVM.select+instance Select Float where select = liftM3 LLVM.select+instance Select Double where select = liftM3 LLVM.select+instance Select Word where select = liftM3 LLVM.select+instance Select Word8 where select = liftM3 LLVM.select+instance Select Word16 where select = liftM3 LLVM.select+instance Select Word32 where select = liftM3 LLVM.select+instance Select Word64 where select = liftM3 LLVM.select+instance Select Int where select = liftM3 LLVM.select+instance Select Int8 where select = liftM3 LLVM.select+instance Select Int16 where select = liftM3 LLVM.select+instance Select Int32 where select = liftM3 LLVM.select+instance Select Int64 where select = liftM3 LLVM.select++instance (Select a, Select b) => Select (a,b) where+   select b =+      modifyF2 (atom,atom) (atom,atom) $+      \(a0,b0) (a1,b1) ->+         Monad.lift2 (,)+            (select b a0 a1)+            (select b b0 b1)++instance (Select a, Select b, Select c) => Select (a,b,c) where+   select b =+      modifyF2 (atom,atom,atom) (atom,atom,atom) $+      \(a0,b0,c0) (a1,b1,c1) ->+         Monad.lift3 (,,)+            (select b a0 a1)+            (select b b0 b1)+            (select b c0 c1)++instance (Select a) => Select (Tagged tag a) where+   select = liftTaggedM2 . select++instance (Select a) => C.Select (T a) where+   select b = select (Cons b)++++class (Real a) => Comparison a where+   {- |+   It must hold++   > max x y  ==  do gt <- cmp CmpGT x y; select gt x y+   -}+   cmp ::+      LLVM.CmpPredicate -> T a -> T a ->+      LLVM.CodeGenFunction r (T Bool)++instance Comparison Float where cmp = liftM2 . LLVM.cmp+instance Comparison Double where cmp = liftM2 . LLVM.cmp++instance Comparison Int where cmp = liftM2 . LLVM.cmp+instance Comparison Int8 where cmp = liftM2 . LLVM.cmp+instance Comparison Int16 where cmp = liftM2 . LLVM.cmp+instance Comparison Int32 where cmp = liftM2 . LLVM.cmp+instance Comparison Int64 where cmp = liftM2 . LLVM.cmp++instance Comparison Word where cmp = liftM2 . LLVM.cmp+instance Comparison Word8 where cmp = liftM2 . LLVM.cmp+instance Comparison Word16 where cmp = liftM2 . LLVM.cmp+instance Comparison Word32 where cmp = liftM2 . LLVM.cmp+instance Comparison Word64 where cmp = liftM2 . LLVM.cmp++instance (Dec.Positive n) => Comparison (IntN n) where cmp = liftM2 . LLVM.cmp+instance (Dec.Positive n) => Comparison (WordN n) where cmp = liftM2 . LLVM.cmp++instance (Comparison a) => Comparison (Tagged tag a) where+   cmp p a b = cmp p (untag a) (untag b)++instance (Comparison a) => A.Comparison (T a) where+   type CmpResult (T a) = T Bool+   cmp = cmp++++class (Comparison a) => FloatingComparison a where+   fcmp ::+      LLVM.FPPredicate -> T a -> T a ->+      LLVM.CodeGenFunction r (T Bool)++instance FloatingComparison Float where+   fcmp = liftM2 . LLVM.fcmp++instance (FloatingComparison a) => FloatingComparison (Tagged tag a) where+   fcmp p a b = fcmp p (untag a) (untag b)++instance (FloatingComparison a) => A.FloatingComparison (T a) where+   fcmp = fcmp++++class (C a) => Logic a where+   and :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   or :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   xor :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   inv :: T a -> LLVM.CodeGenFunction r (T a)++instance Logic Bool where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Bool8 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word8 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word16 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word32 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word64 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance (Dec.Positive n) => Logic (WordN n) where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance (LLVM.IsInteger w, LLVM.IsConst w) => Logic (EnumBitSet.T w i) where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic a => Logic (Tagged tag a) where+   and = liftTaggedM2 and; or = liftTaggedM2 or+   xor = liftTaggedM2 xor; inv = liftTaggedM inv+++instance Logic a => A.Logic (T a) where+   and = and+   or = or+   xor = xor+   inv = inv++++class BitShift a where+   shl :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   shr :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance BitShift Word where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word8 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word16 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word32 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word64 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Int where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int8 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int16 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int32 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int64 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++++class (PseudoRing a) => Integral a where+   idiv :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   irem :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance Integral Word where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Word32 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Word64 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Int where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Int32 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Int64 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance (Integral a) => Integral (Tagged tag a) where+   idiv = liftTaggedM2 idiv+   irem = liftTaggedM2 irem+++fromIntegral ::+   (NativeInteger i ir, NativeFloating a ar) =>+   T i -> LLVM.CodeGenFunction r (T a)+fromIntegral = liftM LLVM.inttofp
+ src/LLVM/Extra/Nice/Value/Storable.hs view
@@ -0,0 +1,417 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.Extra.Nice.Value.Storable (+   -- * Basic class+   C(load, store),+   storeNext,+   modify,++   -- * Classes for tuples and vectors+   Tuple(..),+   Vector(..),+   TupleVector(..),++   -- * Standard method implementations+   loadTraversable,+   loadApplicative,+   storeFoldable,++   -- * Pointer handling+   Storable.advancePtr,+   Storable.incrementPtr,+   Storable.decrementPtr,++   -- * Loops over Storable arrays+   Array.arrayLoop,+   Array.arrayLoop2,+   Array.arrayLoopMaybeCont,+   Array.arrayLoopMaybeCont2,+   ) where++import qualified LLVM.Extra.Storable.Private as Storable+import qualified LLVM.Extra.Storable.Array as Array+import LLVM.Extra.Storable.Private+         (BytePtr, advancePtrStatic, incPtrState, incrementPtr, update,+          castFromBytePtr, castToBytePtr,+          runElements, elementOffset, castElementPtr,+          assemblePrimitive, disassemblePrimitive, proxyFromElement3)++import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.ArithmeticPrivate as A++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, Value)++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.Reader as MR+import qualified Control.Monad.Trans.State as MS+import qualified Control.Applicative.HT as App+import qualified Control.Functor.HT as FuncHT+import Control.Monad (foldM, replicateM, replicateM_, (<=<))+import Control.Applicative (Applicative, pure, (<$>))++import qualified Foreign.Storable.Record.Tuple as StoreTuple+import qualified Foreign.Storable as Store+import Foreign.Ptr (Ptr)++import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import Data.Orphans ()+import Data.Tuple.HT (uncurry3)+import Data.Complex (Complex)+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64)+import Data.Bool8 (Bool8)++++class (Store.Storable a, NiceValue.C a) => C a where+   {-+   Not all Storable types have a compatible LLVM type,+   or even more, one LLVM type that is compatible on all platforms.+   -}+   load :: Value (Ptr a) -> CodeGenFunction r (NiceValue.T a)+   store :: NiceValue.T a -> Value (Ptr a) -> CodeGenFunction r ()++storeNext ::+   (C a, Value (Ptr a) ~ ptr) => NiceValue.T a -> ptr -> CodeGenFunction r ptr+storeNext a ptr  =  store a ptr >> incrementPtr ptr++modify ::+   (C a, NiceValue.T a ~ al) =>+   (al -> CodeGenFunction r al) ->+   Value (Ptr a) -> CodeGenFunction r ()+modify f ptr  =  flip store ptr =<< f =<< load ptr+++instance+   (EE.Marshal a, LLVM.IsConst a, LLVM.IsFirstClass a) =>+      C (EE.Stored a) where+   load = fmap NiceValue.Cons . LLVM.load <=< castFromStoredPtr+   store (NiceValue.Cons a) = LLVM.store a <=< castFromStoredPtr++castFromStoredPtr ::+   (LLVM.IsType a) =>+   Value (Ptr (EE.Stored a)) -> CodeGenFunction r (Value (LLVM.Ptr a))+castFromStoredPtr = LLVM.bitcast+++loadPrimitive ::+   (LLVM.Storable a, NiceValue.Repr a ~ LLVM.Value a) =>+   Value (Ptr a) -> CodeGenFunction r (NiceValue.T a)+loadPrimitive ptr = fmap NiceValue.Cons $ LLVM.load =<< LLVM.bitcast ptr++storePrimitive ::+   (LLVM.Storable a, NiceValue.Repr a ~ LLVM.Value a) =>+   NiceValue.T a -> Value (Ptr a) -> CodeGenFunction r ()+storePrimitive (NiceValue.Cons a) ptr = LLVM.store a =<< LLVM.bitcast ptr++instance C Float where+   load = loadPrimitive; store = storePrimitive++instance C Double where+   load = loadPrimitive; store = storePrimitive++instance C Word where+   load = loadPrimitive; store = storePrimitive++instance C Word8 where+   load = loadPrimitive; store = storePrimitive++instance C Word16 where+   load = loadPrimitive; store = storePrimitive++instance C Word32 where+   load = loadPrimitive; store = storePrimitive++instance C Word64 where+   load = loadPrimitive; store = storePrimitive++instance C Int where+   load = loadPrimitive; store = storePrimitive++instance C Int8 where+   load = loadPrimitive; store = storePrimitive++instance C Int16 where+   load = loadPrimitive; store = storePrimitive++instance C Int32 where+   load = loadPrimitive; store = storePrimitive++instance C Int64 where+   load = loadPrimitive; store = storePrimitive++{- |+Not very efficient implementation+because we want to adapt to @sizeOf Bool@ dynamically.+Unfortunately, LLVM-9's optimizer does not recognize the instruction pattern.+Better use 'Bool8' for booleans.+-}+instance C Bool where+   load ptr = do+      bytePtr <- castToBytePtr ptr+      bytes <-+         flip MS.evalStateT bytePtr $+            replicateM (Store.sizeOf (False :: Bool))+               (MT.lift . LLVM.load =<< incPtrState)+      let zero = LLVM.valueOf 0+      mask <- foldM A.or zero bytes+      NiceValue.Cons <$> A.cmp LLVM.CmpNE mask zero+   store (NiceValue.Cons b) ptr = do+      bytePtr <- castToBytePtr ptr+      byte <- LLVM.sext b+      flip MS.evalStateT bytePtr $+         replicateM_ (Store.sizeOf (False :: Bool))+            (MT.lift . LLVM.store byte =<< incPtrState)++instance C Bool8 where+   load ptr =+      fmap NiceValue.Cons $+      A.cmp LLVM.CmpNE (LLVM.valueOf 0) =<< LLVM.load =<< castToBytePtr ptr+   store (NiceValue.Cons b) ptr = do+      byte <- LLVM.zext b+      LLVM.store byte =<< castToBytePtr ptr++instance (C a) => C (Complex a) where+   load = loadApplicative; store = storeFoldable++++instance (Tuple tuple) => C (StoreTuple.Tuple tuple) where+   load ptr = NiceValue.tuple <$> loadTuple ptr+   store = storeTuple . NiceValue.untuple++class (StoreTuple.Storable tuple, NiceValue.C tuple) => Tuple tuple where+   loadTuple ::+      Value (Ptr (StoreTuple.Tuple tuple)) ->+      CodeGenFunction r (NiceValue.T tuple)+   storeTuple ::+      NiceValue.T tuple ->+      Value (Ptr (StoreTuple.Tuple tuple)) ->+      CodeGenFunction r ()++instance (C a, C b) => Tuple (a,b) where+   loadTuple ptr =+      runElements ptr $ fmap (uncurry NiceValue.zip) $+         App.mapPair (loadElement, loadElement) $+         FuncHT.unzip $ proxyFromElement3 ptr+   storeTuple = NiceValue.uncurry $ \a b ptr ->+      case FuncHT.unzip $ proxyFromElement3 ptr of+         (pa,pb) -> runElements ptr $ storeElement pa a >> storeElement pb b++instance (C a, C b, C c) => Tuple (a,b,c) where+   loadTuple ptr =+      runElements ptr $ fmap (uncurry3 NiceValue.zip3) $+         App.mapTriple (loadElement, loadElement, loadElement) $+         FuncHT.unzip3 $ proxyFromElement3 ptr+   storeTuple = NiceValue.uncurry3 $ \a b c ptr ->+      case FuncHT.unzip3 $ proxyFromElement3 ptr of+         (pa,pb,pc) ->+            runElements ptr $+               storeElement pa a >> storeElement pb b >> storeElement pc c++loadElement ::+   (C a) =>+   LP.Proxy a ->+   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) (NiceValue.T a)+loadElement proxy =+   MT.lift . MT.lift . load =<< elementPtr proxy++storeElement ::+   (C a) =>+   LP.Proxy a -> NiceValue.T a ->+   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) ()+storeElement proxy a =+   MT.lift . MT.lift . store a =<< elementPtr proxy++elementPtr ::+   (C a) =>+   LP.Proxy a ->+   MR.ReaderT BytePtr+      (MS.StateT Int (CodeGenFunction r)) (LLVM.Value (Ptr a))+elementPtr proxy = do+   ptr <- MR.ask+   MT.lift $ do+      offset <- elementOffset proxy+      MT.lift $ castFromBytePtr =<< LLVM.getElementPtr ptr (offset, ())+++instance+   (TypeNum.Positive n, Vector a) =>+      C (LLVM.Vector n a) where+   load ptr =+      fmap NiceValue.Cons $+      assembleVector (proxyFromElement3 ptr) =<< loadApplicativeRepr ptr+   store (NiceValue.Cons a) ptr =+      flip storeFoldableRepr ptr+         =<< disassembleVector (proxyFromElement3 ptr) a++class (C a, NiceVector.C a) => Vector a where+   assembleVector ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> LLVM.Vector n (NiceValue.Repr a) ->+      CodeGenFunction r (NiceVector.Repr n a)+   disassembleVector ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> NiceVector.Repr n a ->+      CodeGenFunction r (LLVM.Vector n (NiceValue.Repr a))++instance Vector Float where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Double where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word8 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word16 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word32 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word64 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int8 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int16 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int32 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int64 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Bool where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Bool8 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive+++instance+   (Tuple tuple, TupleVector tuple) =>+      Vector (StoreTuple.Tuple tuple) where+   assembleVector = deinterleave . fmap StoreTuple.getTuple+   disassembleVector = interleave . fmap StoreTuple.getTuple+++class (NiceVector.C a) => TupleVector a where+   deinterleave ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> LLVM.Vector n (NiceValue.Repr a) ->+      CodeGenFunction r (NiceVector.Repr n a)+   interleave ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> NiceVector.Repr n a ->+      CodeGenFunction r (LLVM.Vector n (NiceValue.Repr a))++instance (Vector a, Vector b) => TupleVector (a,b) where+   deinterleave = FuncHT.uncurry $ \pa pb -> FuncHT.uncurry $ \a b ->+      App.lift2 (,) (assembleVector pa a) (assembleVector pb b)+   interleave = FuncHT.uncurry $ \pa pb (a,b) ->+      App.lift2 (App.lift2 (,))+         (disassembleVector pa a) (disassembleVector pb b)++instance (Vector a, Vector b, Vector c) => TupleVector (a,b,c) where+   deinterleave = FuncHT.uncurry3 $ \pa pb pc -> FuncHT.uncurry3 $ \a b c ->+      App.lift3 (,,)+         (assembleVector pa a)+         (assembleVector pb b)+         (assembleVector pc c)+   interleave = FuncHT.uncurry3 $ \pa pb pc (a,b,c) ->+      App.lift3 (App.lift3 (,,))+         (disassembleVector pa a)+         (disassembleVector pb b)+         (disassembleVector pc c)+++{-+instance Storable () available since base-4.9/GHC-8.0.+Before we need Data.Orphans.+-}+instance C () where+   load _ptr = return $ NiceValue.Cons ()+   store (NiceValue.Cons ()) _ptr = return ()+++loadTraversable ::+   (NonEmptyC.Repeat f, Trav.Traversable f,+    C a, NiceValue.Repr fa ~ f (NiceValue.Repr a)) =>+   Value (Ptr (f a)) -> CodeGenFunction r (NiceValue.T fa)+loadTraversable =+   (MS.evalStateT $ fmap NiceValue.Cons $+    Trav.sequence $ NonEmptyC.repeat $ loadState)+      <=< castElementPtr++loadApplicative ::+   (Applicative f, Trav.Traversable f,+    C a, NiceValue.Repr fa ~ f (NiceValue.Repr a)) =>+   Value (Ptr (f a)) -> CodeGenFunction r (NiceValue.T fa)+loadApplicative = fmap NiceValue.Cons . loadApplicativeRepr++loadApplicativeRepr ::+   (Applicative f, Trav.Traversable f, C a) =>+   Value (Ptr (f a)) -> CodeGenFunction r (f (NiceValue.Repr a))+loadApplicativeRepr =+   (MS.evalStateT $ Trav.sequence $ pure loadState) <=< castElementPtr++loadState ::+   (C a, NiceValue.Repr a ~ al) =>+   MS.StateT (Value (Ptr a)) (CodeGenFunction r) al+loadState =+   MT.lift . fmap (\(NiceValue.Cons a) -> a) . load =<< advancePtrState+++storeFoldable ::+   (Fold.Foldable f, C a, NiceValue.Repr fa ~ f (NiceValue.Repr a)) =>+    NiceValue.T fa -> Value (Ptr (f a)) -> CodeGenFunction r ()+storeFoldable (NiceValue.Cons xs) = storeFoldableRepr xs++storeFoldableRepr ::+   (Fold.Foldable f, C a) =>+   f (NiceValue.Repr a) -> Value (Ptr (f a)) -> CodeGenFunction r ()+storeFoldableRepr xs =+   MS.evalStateT (Fold.mapM_ storeState xs) <=< castElementPtr++storeState ::+   (C a, NiceValue.Repr a ~ al) =>+   al -> MS.StateT (Value (Ptr a)) (CodeGenFunction r) ()+storeState a = MT.lift . store (NiceValue.Cons a) =<< advancePtrState+++advancePtrState ::+   (C a, Value (Ptr a) ~ ptr) =>+   MS.StateT ptr (CodeGenFunction r) ptr+advancePtrState = update $ advancePtrStatic 1
+ src/LLVM/Extra/Nice/Value/Vector.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module LLVM.Extra.Nice.Value.Vector (+   cons,+   fst, snd,+   fst3, snd3, thd3,+   zip, zip3,+   unzip, unzip3,++   swap,+   mapFst, mapSnd,+   mapFst3, mapSnd3, mapThd3,++   extract, insert,+   replicate,+   iterate,+   dissect,+   dissect1,+   select,+   cmp,+   take, takeRev,++   NativeInteger,+   NativeFloating,+   fromIntegral,+   truncateToInt,+   splitFractionToInt,+   ) where++import qualified LLVM.Extra.Nice.Vector.Instance as Inst+import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import qualified LLVM.Extra.ScalarOrVector as SoV+import LLVM.Extra.Nice.Vector.Instance (NVVector)++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+++import qualified Data.NonEmpty as NonEmpty+import qualified Data.Tuple.HT as TupleHT+import qualified Data.Tuple as Tuple+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int (Int8, Int16, Int32, Int64, Int)++import Prelude (Float, Double, Bool, fmap, (.))+++cons ::+   (TypeNum.Positive n, NiceVector.C a) =>+   LLVM.Vector n a -> NVVector n a+cons = Inst.toNiceValue . NiceVector.cons++fst :: NVVector n (a,b) -> NVVector n a+fst = NiceValue.lift1 Tuple.fst++snd :: NVVector n (a,b) -> NVVector n b+snd = NiceValue.lift1 Tuple.snd++swap :: NVVector n (a,b) -> NVVector n (b,a)+swap = NiceValue.lift1 TupleHT.swap++mapFst ::+   (NVVector n a0 -> NVVector n a1) ->+   NVVector n (a0,b) -> NVVector n (a1,b)+mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip++mapSnd ::+   (NVVector n b0 -> NVVector n b1) ->+   NVVector n (a,b0) -> NVVector n (a,b1)+mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip+++fst3 :: NVVector n (a,b,c) -> NVVector n a+fst3 = NiceValue.lift1 TupleHT.fst3++snd3 :: NVVector n (a,b,c) -> NVVector n b+snd3 = NiceValue.lift1 TupleHT.snd3++thd3 :: NVVector n (a,b,c) -> NVVector n c+thd3 = NiceValue.lift1 TupleHT.thd3++mapFst3 ::+   (NVVector n a0 -> NVVector n a1) ->+   NVVector n (a0,b,c) -> NVVector n (a1,b,c)+mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3++mapSnd3 ::+   (NVVector n b0 -> NVVector n b1) ->+   NVVector n (a,b0,c) -> NVVector n (a,b1,c)+mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3++mapThd3 ::+   (NVVector n c0 -> NVVector n c1) ->+   NVVector n (a,b,c0) -> NVVector n (a,b,c1)+mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3+++zip :: NVVector n a -> NVVector n b -> NVVector n (a,b)+zip (NiceValue.Cons a) (NiceValue.Cons b) = NiceValue.Cons (a,b)++zip3 :: NVVector n a -> NVVector n b -> NVVector n c -> NVVector n (a,b,c)+zip3 (NiceValue.Cons a) (NiceValue.Cons b) (NiceValue.Cons c) =+   NiceValue.Cons (a,b,c)++unzip :: NVVector n (a,b) -> (NVVector n a, NVVector n b)+unzip (NiceValue.Cons (a,b)) = (NiceValue.Cons a, NiceValue.Cons b)++unzip3 :: NVVector n (a,b,c) -> (NVVector n a, NVVector n b, NVVector n c)+unzip3 (NiceValue.Cons (a,b,c)) =+   (NiceValue.Cons a, NiceValue.Cons b, NiceValue.Cons c)+++extract ::+   (TypeNum.Positive n, NiceVector.C a) =>+   LLVM.Value Word32 -> NVVector n a ->+   LLVM.CodeGenFunction r (NiceValue.T a)+extract k v = NiceVector.extract k (Inst.fromNiceValue v)++insert ::+   (TypeNum.Positive n, NiceVector.C a) =>+   LLVM.Value Word32 -> NiceValue.T a ->+   NVVector n a -> LLVM.CodeGenFunction r (NVVector n a)+insert k a = Inst.liftNiceValueM (NiceVector.insert k a)+++replicate ::+   (TypeNum.Positive n, NiceVector.C a) =>+   NiceValue.T a -> LLVM.CodeGenFunction r (NVVector n a)+replicate = fmap Inst.toNiceValue . NiceVector.replicate++iterate ::+   (TypeNum.Positive n, NiceVector.C a) =>+   (NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T a)) ->+   NiceValue.T a -> LLVM.CodeGenFunction r (NVVector n a)+iterate f = fmap Inst.toNiceValue . NiceVector.iterate f++take ::+   (TypeNum.Positive n, TypeNum.Positive m, NiceVector.C a) =>+   NVVector n a -> LLVM.CodeGenFunction r (NVVector m a)+take = Inst.liftNiceValueM NiceVector.take++takeRev ::+   (TypeNum.Positive n, TypeNum.Positive m, NiceVector.C a) =>+   NVVector n a -> LLVM.CodeGenFunction r (NVVector m a)+takeRev = Inst.liftNiceValueM NiceVector.takeRev+++dissect ::+   (TypeNum.Positive n, NiceVector.C a) =>+   NVVector n a -> LLVM.CodeGenFunction r [NiceValue.T a]+dissect = NiceVector.dissect . Inst.fromNiceValue++dissect1 ::+   (TypeNum.Positive n, NiceVector.C a) =>+   NVVector n a -> LLVM.CodeGenFunction r (NonEmpty.T [] (NiceValue.T a))+dissect1 = NiceVector.dissect1 . Inst.fromNiceValue++select ::+   (TypeNum.Positive n, NiceVector.Select a) =>+   NVVector n Bool ->+   NVVector n a -> NVVector n a ->+   LLVM.CodeGenFunction r (NVVector n a)+select = Inst.liftNiceValueM3 NiceVector.select++cmp ::+   (TypeNum.Positive n, NiceVector.Comparison a) =>+   LLVM.CmpPredicate ->+   NVVector n a -> NVVector n a ->+   LLVM.CodeGenFunction r (NVVector n Bool)+cmp = Inst.liftNiceValueM2 . NiceVector.cmp+++{-+ToDo: make this a super-class of NiceValue.NativeInteger+problem: we need NiceValue.Repr, which provokes an import cycle+maybe we should break the cycle using a ConstraintKind,+i.e. define class NativeIntegerVec in NiceValue,+and define NativeInteger = NiceValue.NativeIntegerVec here+and export only NiceValueVec.NativeInteger constraint synonym.+-}+class+   (NiceValue.Repr i ~ LLVM.Value ir,+    LLVM.CmpRet ir, LLVM.IsInteger ir, SoV.IntegerConstant ir) =>+      NativeInteger i ir where++instance NativeInteger Word   Word   where+instance NativeInteger Word8  Word8  where+instance NativeInteger Word16 Word16 where+instance NativeInteger Word32 Word32 where+instance NativeInteger Word64 Word64 where++instance NativeInteger Int   Int   where+instance NativeInteger Int8  Int8  where+instance NativeInteger Int16 Int16 where+instance NativeInteger Int32 Int32 where+instance NativeInteger Int64 Int64 where++instance+   (TypeNum.Positive n, n ~ m,+    NiceVector.NativeInteger n i ir,+    NiceValue.NativeInteger i ir) =>+      NativeInteger (LLVM.Vector n i) (LLVM.Vector m ir) where+++class+   (NiceValue.Repr a ~ LLVM.Value ar,+    LLVM.CmpRet ar,  SoV.RationalConstant ar, LLVM.IsFloating ar) =>+      NativeFloating a ar where++instance NativeFloating Float  Float  where+instance NativeFloating Double Double where++instance+   (TypeNum.Positive n, n ~ m,+    NiceVector.NativeFloating n a ar,+    NiceValue.NativeFloating a ar) =>+      NativeFloating (LLVM.Vector n a) (LLVM.Vector m ar) where++fromIntegral ::+   (NativeInteger i ir, NativeFloating a ar,+    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>+   NiceValue.T i -> LLVM.CodeGenFunction r (NiceValue.T a)+fromIntegral = NiceValue.liftM LLVM.inttofp+++truncateToInt ::+   (NativeInteger i ir, NativeFloating a ar,+    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>+   NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T i)+truncateToInt = NiceValue.liftM LLVM.fptoint++splitFractionToInt ::+   (NativeInteger i ir, NativeFloating a ar,+    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>+   NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T (i,a))+splitFractionToInt = NiceValue.liftM SoV.splitFractionToInt
+ src/LLVM/Extra/Nice/Vector.hs view
@@ -0,0 +1,1346 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.Nice.Vector (+   T(Cons), consPrim, deconsPrim,+   C(..),+   Value,+   map,+   zip, zip3, unzip, unzip3,+   replicate,+   iterate,+   take,+   takeRev,++   sum,+   dotProduct,+   cumulate,+   cumulate1,++   lift1,++   modify,+   assemble,+   dissect,+   dissectList,++   assemble1,+   dissect1,+   dissectList1,++   assembleFromVector,+   consVarArg,++   reverse,+   rotateUp,+   rotateDown,+   shiftUp,+   shiftDown,+   shiftUpMultiZero,+   shiftDownMultiZero,+   shiftUpMultiUndef,+   shiftDownMultiUndef,++   undefPrimitive,+   shufflePrimitive,+   extractPrimitive,+   insertPrimitive,++   shuffleMatchTraversable,+   insertTraversable,+   extractTraversable,++   IntegerConstant(..),+   RationalConstant(..),+   Additive(..),+   PseudoRing(..),+   Field(..),+   scale,+   PseudoModule(..),+   Real(..),+   Fraction(..),+   NativeInteger, NativeFloating, fromIntegral,+   Algebraic(..),+   Transcendental(..),+   FloatingComparison(..),+   Select(..),+   Comparison(..),+   Logic(..),+   BitShift(..),+   ) where++import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, IsPrimitive, valueOf, value, )++import qualified Type.Data.Num.Decimal as TypeNum+import qualified Type.Data.Num.Decimal as Dec+import qualified Type.Data.Num.Unary as Unary++import qualified Foreign.Storable.Record.Tuple as StoreTuple++import qualified Data.Traversable as Trav+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.List as List+import qualified Data.Bool8 as Bool8+import Data.Traversable (mapM, sequence, )+import Data.Foldable (foldlM)+import Data.NonEmpty ((!:), )+import Data.Function (flip, (.), ($), )+import Data.Tuple (snd, )+import Data.Maybe (maybe, )+import Data.Ord ((<), )+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int (Int8, Int16, Int32, Int64, )+import Data.Bool8 (Bool8)+import Data.Bool (Bool, )++import qualified Control.Monad.HT as Monad+import qualified Control.Applicative as App+import qualified Control.Functor.HT as FuncHT+import Control.Monad.HT ((<=<), )+import Control.Monad (Monad, join, fmap, return, (>>), (=<<))+import Control.Applicative (liftA2, (<$>))++import qualified Prelude as P+import Prelude+         (Float, Double, Integer, Int, Rational, asTypeOf, (-), (+), (*), error)+++newtype T n a = Cons (Repr n a)++type Value n a = LLVM.Value (LLVM.Vector n a)+++consPrim :: (Repr n a ~ Value n ar) => Value n ar -> T n a+consPrim = Cons++deconsPrim :: (Repr n a ~ Value n ar) => T n a -> Value n ar+deconsPrim (Cons a) = a+++instance (TypeNum.Positive n, C a) => Tuple.Undefined (T n a) where+   undef = undef++instance (TypeNum.Positive n, C a) => Tuple.Zero (T n a) where+   zero = zero++instance (TypeNum.Positive n, C a) => Tuple.Phi (T n a) where+   phi = phi+   addPhi = addPhi+++sizeS :: TypeNum.Positive n => T n a -> TypeNum.Singleton n+sizeS _ = TypeNum.singleton++size :: (TypeNum.Positive n, P.Integral i) => T n a -> i+size = TypeNum.integralFromSingleton . sizeS++last ::+   (TypeNum.Positive n, C a) =>+   T n a -> CodeGenFunction r (NiceValue.T a)+last x = extract (valueOf (size x - 1)) x+++zip :: T n a -> T n b -> T n (a,b)+zip (Cons a) (Cons b) = Cons (a,b)++zip3 :: T n a -> T n b -> T n c -> T n (a,b,c)+zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c)++unzip :: T n (a,b) -> (T n a, T n b)+unzip (Cons (a,b)) = (Cons a, Cons b)++unzip3 :: T n (a,b,c) -> (T n a, T n b, T n c)+unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c)+++class (NiceValue.C a) => C a where+   type Repr n a+   cons :: (TypeNum.Positive n) => LLVM.Vector n a -> T n a+   undef :: (TypeNum.Positive n) => T n a+   zero :: (TypeNum.Positive n) => T n a+   phi ::+      (TypeNum.Positive n) =>+      LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)+   addPhi ::+      (TypeNum.Positive n) =>+      LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r ()++   shuffle ::+      (TypeNum.Positive n, TypeNum.Positive m) =>+      LLVM.ConstValue (LLVM.Vector m Word32) -> T n a -> T n a ->+      CodeGenFunction r (T m a)+   extract ::+      (TypeNum.Positive n) =>+      LLVM.Value Word32 -> T n a -> CodeGenFunction r (NiceValue.T a)+   insert ::+      (TypeNum.Positive n) =>+      LLVM.Value Word32 -> NiceValue.T a ->+      T n a -> CodeGenFunction r (T n a)++instance C Bool where+   type Repr n Bool = LLVM.Value (LLVM.Vector n Bool)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Bool8 where+   type Repr n Bool8 = LLVM.Value (LLVM.Vector n Bool)+   cons = consPrimitive . fmap Bool8.toBool+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Float where+   type Repr n Float = LLVM.Value (LLVM.Vector n Float)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Double where+   type Repr n Double = LLVM.Value (LLVM.Vector n Double)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int where+   type Repr n Int = LLVM.Value (LLVM.Vector n Int)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int8 where+   type Repr n Int8 = LLVM.Value (LLVM.Vector n Int8)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int16 where+   type Repr n Int16 = LLVM.Value (LLVM.Vector n Int16)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int32 where+   type Repr n Int32 = LLVM.Value (LLVM.Vector n Int32)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int64 where+   type Repr n Int64 = LLVM.Value (LLVM.Vector n Int64)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word where+   type Repr n Word = LLVM.Value (LLVM.Vector n Word)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word8 where+   type Repr n Word8 = LLVM.Value (LLVM.Vector n Word8)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word16 where+   type Repr n Word16 = LLVM.Value (LLVM.Vector n Word16)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word32 where+   type Repr n Word32 = LLVM.Value (LLVM.Vector n Word32)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word64 where+   type Repr n Word64 = LLVM.Value (LLVM.Vector n Word64)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++consPrimitive ::+   (TypeNum.Positive n, LLVM.IsConst al, IsPrimitive al,+    Repr n a ~ Value n al) =>+   LLVM.Vector n al -> T n a+consPrimitive = Cons . LLVM.valueOf++undefPrimitive ::+   (TypeNum.Positive n, IsPrimitive al,+    Repr n a ~ Value n al) =>+   T n a+undefPrimitive = Cons $ LLVM.value LLVM.undef++zeroPrimitive ::+   (TypeNum.Positive n, IsPrimitive al,+    Repr n a ~ Value n al) =>+   T n a+zeroPrimitive = Cons $ LLVM.value LLVM.zero++phiPrimitive ::+   (TypeNum.Positive n, IsPrimitive al, Repr n a ~ Value n al) =>+   LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)+phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a++addPhiPrimitive ::+   (TypeNum.Positive n, IsPrimitive al, Repr n a ~ Value n al) =>+   LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r ()+addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b+++shufflePrimitive ::+   (TypeNum.Positive n, TypeNum.Positive m, IsPrimitive al,+    NiceValue.Repr a ~ LLVM.Value al,+    Repr n a ~ Value n al,+    Repr m a ~ Value m al) =>+   LLVM.ConstValue (LLVM.Vector m Word32) ->+   T n a -> T n a -> CodeGenFunction r (T m a)+shufflePrimitive k (Cons u) (Cons v) =+   fmap Cons $ LLVM.shufflevector u v k++extractPrimitive ::+   (TypeNum.Positive n, IsPrimitive al,+    NiceValue.Repr a ~ LLVM.Value al,+    Repr n a ~ Value n al) =>+   LLVM.Value Word32 -> T n a -> CodeGenFunction r (NiceValue.T a)+extractPrimitive k (Cons v) =+   fmap NiceValue.Cons $ LLVM.extractelement v k++insertPrimitive ::+   (TypeNum.Positive n, IsPrimitive al,+    NiceValue.Repr a ~ LLVM.Value al,+    Repr n a ~ Value n al) =>+   LLVM.Value Word32 ->+   NiceValue.T a -> T n a -> CodeGenFunction r (T n a)+insertPrimitive k (NiceValue.Cons a) (Cons v) =+   fmap Cons $ LLVM.insertelement v a k+++instance (C a, C b) => C (a,b) where+   type Repr n (a,b) = (Repr n a, Repr n b)+   cons v = case FuncHT.unzip v of (a,b) -> zip (cons a) (cons b)+   undef = zip undef undef+   zero = zip zero zero++   phi bb a =+      case unzip a of+         (a0,a1) ->+            Monad.lift2 zip (phi bb a0) (phi bb a1)+   addPhi bb a b =+      case (unzip a, unzip b) of+         ((a0,a1), (b0,b1)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1++   shuffle is u v =+      case (unzip u, unzip v) of+         ((u0,u1), (v0,v1)) ->+            Monad.lift2 zip+               (shuffle is u0 v0)+               (shuffle is u1 v1)++   extract k v =+      case unzip v of+         (v0,v1) ->+            Monad.lift2 NiceValue.zip+               (extract k v0)+               (extract k v1)++   insert k a v =+      case (NiceValue.unzip a, unzip v) of+         ((a0,a1), (v0,v1)) ->+            Monad.lift2 zip+               (insert k a0 v0)+               (insert k a1 v1)+++instance (C a, C b, C c) => C (a,b,c) where+   type Repr n (a,b,c) = (Repr n a, Repr n b, Repr n c)+   cons v = case FuncHT.unzip3 v of (a,b,c) -> zip3 (cons a) (cons b) (cons c)+   undef = zip3 undef undef undef+   zero = zip3 zero zero zero++   phi bb a =+      case unzip3 a of+         (a0,a1,a2) ->+            Monad.lift3 zip3 (phi bb a0) (phi bb a1) (phi bb a2)+   addPhi bb a b =+      case (unzip3 a, unzip3 b) of+         ((a0,a1,a2), (b0,b1,b2)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1 >>+            addPhi bb a2 b2++   shuffle is u v =+      case (unzip3 u, unzip3 v) of+         ((u0,u1,u2), (v0,v1,v2)) ->+            Monad.lift3 zip3+               (shuffle is u0 v0)+               (shuffle is u1 v1)+               (shuffle is u2 v2)++   extract k v =+      case unzip3 v of+         (v0,v1,v2) ->+            Monad.lift3 NiceValue.zip3+               (extract k v0)+               (extract k v1)+               (extract k v2)++   insert k a v =+      case (NiceValue.unzip3 a, unzip3 v) of+         ((a0,a1,a2), (v0,v1,v2)) ->+            Monad.lift3 zip3+               (insert k a0 v0)+               (insert k a1 v1)+               (insert k a2 v2)+++instance (C tuple) => C (StoreTuple.Tuple tuple) where+   type Repr n (StoreTuple.Tuple tuple) = Repr n tuple+   cons = tuple . cons . fmap StoreTuple.getTuple+   undef = tuple undef+   zero = tuple zero+   phi bb = fmap tuple . phi bb . untuple+   addPhi bb a b = addPhi bb (untuple a) (untuple b)+   shuffle is u v = tuple <$> shuffle is (untuple u) (untuple v)+   extract k v = NiceValue.tuple <$> extract k (untuple v)+   insert k a v = tuple <$> insert k (NiceValue.untuple a) (untuple v)++tuple :: T n tuple -> T n (StoreTuple.Tuple tuple)+tuple (Cons a) = Cons a++untuple :: T n (StoreTuple.Tuple tuple) -> T n tuple+untuple (Cons a) = Cons a+++class (NiceValue.IntegerConstant a, C a) => IntegerConstant a where+   fromInteger' :: (TypeNum.Positive n) => Integer -> T n a++class+   (NiceValue.RationalConstant a, IntegerConstant a) =>+      RationalConstant a where+   fromRational' :: (TypeNum.Positive n) => Rational -> T n a++instance IntegerConstant Float  where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Double where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word   where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word8  where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word16 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word32 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word64 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int   where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int8  where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int16 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int32 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int64 where fromInteger' = fromIntegerPrimitive++fromIntegerPrimitive ::+   (TypeNum.Positive n, IsPrimitive a, SoV.IntegerConstant a,+    Repr n a ~ Value n a) =>+   Integer -> T n a+fromIntegerPrimitive = Cons . LLVM.value . SoV.constFromInteger++instance RationalConstant Float  where fromRational' = fromRationalPrimitive+instance RationalConstant Double where fromRational' = fromRationalPrimitive++fromRationalPrimitive ::+   (TypeNum.Positive n, IsPrimitive a, SoV.RationalConstant a,+    Repr n a ~ Value n a) =>+   Rational -> T n a+fromRationalPrimitive = Cons . LLVM.value . SoV.constFromRational++instance+   (TypeNum.Positive n, IntegerConstant a) =>+      A.IntegerConstant (T n a) where+   fromInteger' = fromInteger'++instance+   (TypeNum.Positive n, RationalConstant a) =>+      A.RationalConstant (T n a) where+   fromRational' = fromRational'+++modify ::+   (TypeNum.Positive n, C a) =>+   LLVM.Value Word32 ->+   (NiceValue.T a -> CodeGenFunction r (NiceValue.T a)) ->+   (T n a -> CodeGenFunction r (T n a))+modify k f v =+   flip (insert k) v =<< f =<< extract k v+++assemble ::+   (TypeNum.Positive n, C a) =>+   [NiceValue.T a] -> CodeGenFunction r (T n a)+assemble =+   foldlM (\v (k,x) -> insert (valueOf k) x v) undef .+   List.zip [0..]++dissect ::+   (TypeNum.Positive n, C a) =>+   T n a -> LLVM.CodeGenFunction r [NiceValue.T a]+dissect = sequence . dissectList++dissectList ::+   (TypeNum.Positive n, C a) =>+   T n a -> [LLVM.CodeGenFunction r (NiceValue.T a)]+dissectList x =+   List.map+      (flip extract x . LLVM.valueOf)+      (List.take (size x) [0..])+++assemble1 ::+   (TypeNum.Positive n, C a) =>+   NonEmpty.T [] (NiceValue.T a) -> CodeGenFunction r (T n a)+assemble1 = assemble . NonEmpty.flatten++dissect1 ::+   (TypeNum.Positive n, C a) =>+   T n a -> LLVM.CodeGenFunction r (NonEmpty.T [] (NiceValue.T a))+dissect1 = sequence . dissectList1++dissectList1 ::+   (TypeNum.Positive n, C a) =>+   T n a -> NonEmpty.T [] (LLVM.CodeGenFunction r (NiceValue.T a))+dissectList1 x =+   fmap+      (flip extract x . LLVM.valueOf)+      (0 !: List.take (size x - 1) [1 ..])+++assembleFromVector ::+   (TypeNum.Positive n, C a) =>+   LLVM.Vector n (NiceValue.T a) -> CodeGenFunction r (T n a)+assembleFromVector =+   fmap snd .+   foldlM (\(k,v) x -> (,) (k+1) <$> insert (valueOf k) x v) (0,undef)+++type family VectorSize v+type instance VectorSize (T n a) = n++type family VectorElement v+type instance VectorElement (T n a) = a++class+   (Dec.Positive n, C a, ResultRet f ~ r,+    VectorSize (ResultVector f) ~ n, VectorElement (ResultVector f) ~ a) =>+      Cons r n a f where+   type NumberOfArguments f+   type ResultRet f+   type ResultVector f+   consAux :: Word32 -> CodeGenFunction r (T n a) -> f++instance+   (Dec.Positive n, C a, r0 ~ r, T n a ~ v) =>+      Cons r0 n a (CodeGenFunction r v) where+   type NumberOfArguments (CodeGenFunction r v) = Unary.Zero+   type ResultRet (CodeGenFunction r v) = r+   type ResultVector (CodeGenFunction r v) = v+   consAux _ mv = mv++instance (NiceValue.T a ~ arg, Cons r n a f) => Cons r n a (arg -> f) where+   type NumberOfArguments (arg -> f) = Unary.Succ (NumberOfArguments f)+   type ResultRet (arg -> f) = ResultRet f+   type ResultVector (arg -> f) = ResultVector f+   consAux k mv x = consAux (k+1) (insert (LLVM.valueOf k) x =<< mv)++consVarArg ::+   (Cons r n a f, NumberOfArguments f ~ u,+    u ~ Dec.ToUnary n, Dec.FromUnary u ~ n, Dec.Natural n) =>+   f+consVarArg = consAux 0 (return undef)++++map ::+   (TypeNum.Positive n, C a, C b) =>+   (NiceValue.T a -> CodeGenFunction r (NiceValue.T b)) ->+   (T n a -> CodeGenFunction r (T n b))+map f  =  assemble <=< mapM f <=< dissect+++singleton :: (C a) => NiceValue.T a -> CodeGenFunction r (T TypeNum.D1 a)+singleton x = insert (LLVM.value LLVM.zero) x undef++replicate ::+   (TypeNum.Positive n, C a) =>+   NiceValue.T a -> CodeGenFunction r (T n a)+replicate x = do+   single <- singleton x+   shuffle (constCyclicVector $ NonEmpty.singleton 0) single undef++iterate ::+   (TypeNum.Positive n, C a) =>+   (NiceValue.T a -> CodeGenFunction r (NiceValue.T a)) ->+   NiceValue.T a -> CodeGenFunction r (T n a)+iterate f x = fmap snd $ iterateCore f x Tuple.undef++iterateCore ::+   (TypeNum.Positive n, C a) =>+   (NiceValue.T a -> CodeGenFunction r (NiceValue.T a)) ->+   NiceValue.T a -> T n a ->+   CodeGenFunction r (NiceValue.T a, T n a)+iterateCore f x0 v0 =+   foldlM+      (\(x,v) k -> Monad.lift2 (,) (f x) (insert (valueOf k) x v))+      (x0,v0)+      (List.take (size v0) [0..])+++sum ::+   (TypeNum.Positive n, Additive a) =>+   T n a -> CodeGenFunction r (NiceValue.T a)+sum =+   NonEmpty.foldBalanced (\x y -> join $ liftA2 NiceValue.add x y) .+   dissectList1++dotProduct ::+   (TypeNum.Positive n, PseudoRing a) =>+   T n a -> T n a -> CodeGenFunction r (NiceValue.T a)+dotProduct x y = sum =<< mul x y+++cumulate ::+   (TypeNum.Positive n, Additive a) =>+   NiceValue.T a -> T n a ->+   CodeGenFunction r (NiceValue.T a, T n a)+cumulate a x0 = do+   (b,x1) <- shiftUp a x0+   y <- cumulate1 x1+   z <- A.add b =<< last y+   return (z,y)++{- |+Needs (log n) vector additions+-}+cumulate1 ::+   (TypeNum.Positive n, Additive a) =>+   T n a -> CodeGenFunction r (T n a)+cumulate1 x =+   foldlM+      (\y k -> A.add y =<< shiftUpMultiZero k y)+      x+      (List.takeWhile (< size x) $ List.iterate (2*) 1)+++-- * re-ordering of elements++constCyclicVector ::+   (LLVM.IsConst a, TypeNum.Positive n) =>+   NonEmpty.T [] a -> LLVM.ConstValue (LLVM.Vector n a)+constCyclicVector =+   LLVM.constCyclicVector . fmap LLVM.constOf++shuffleMatch ::+   (TypeNum.Positive n, C a) =>+   LLVM.ConstValue (LLVM.Vector n Word32) -> T n a ->+   CodeGenFunction r (T n a)+shuffleMatch k v = shuffle k v undef++{- |+Rotate one element towards the higher elements.++I don't want to call it rotateLeft or rotateRight,+because there is no prefered layout for the vector elements.+In Intel's instruction manual vector+elements are indexed like the bits,+that is from right to left.+However, when working with Haskell list and enumeration syntax,+the start index is left.+-}+rotateUp ::+   (TypeNum.Positive n, C a) =>+   T n a -> CodeGenFunction r (T n a)+rotateUp x =+   shuffleMatch (constCyclicVector $ (size x - 1) !: [0..]) x++rotateDown ::+   (TypeNum.Positive n, C a) =>+   T n a -> CodeGenFunction r (T n a)+rotateDown x =+   shuffleMatch+      (constCyclicVector $+       NonEmpty.snoc (List.take (size x - 1) [1..]) 0) x++reverse ::+   (TypeNum.Positive n, C a) =>+   T n a -> CodeGenFunction r (T n a)+reverse x =+   shuffleMatch+      (constCyclicVector $+       maybe (error "vector size must be positive") NonEmpty.reverse $+       NonEmpty.fetch $+       List.take (size x) [0..])+      x++take ::+   (TypeNum.Positive n, TypeNum.Positive m, C a) =>+   T n a -> CodeGenFunction r (T m a)+take u = shuffle (constCyclicVector $ NonEmptyC.iterate (1+) 0) u undef++takeRev ::+   (TypeNum.Positive n, TypeNum.Positive m, C a) =>+   T n a -> CodeGenFunction r (T m a)+takeRev u = do+   let v0 = zero+   v <-+      shuffle+         (constCyclicVector $ NonEmptyC.iterate (1+) (size u - size v0))+         u undef+   return $ v `asTypeOf` v0++shiftUp ::+   (TypeNum.Positive n, C a) =>+   NiceValue.T a -> T n a -> CodeGenFunction r (NiceValue.T a, T n a)+shiftUp x0 x = do+   y <-+      shuffleMatch+         (LLVM.constCyclicVector $ LLVM.undef !: List.map LLVM.constOf [0..]) x+   Monad.lift2 (,) (last x) (insert (value LLVM.zero) x0 y)++shiftDown ::+   (TypeNum.Positive n, C a) =>+   NiceValue.T a -> T n a -> CodeGenFunction r (NiceValue.T a, T n a)+shiftDown x0 x = do+   y <-+      shuffleMatch+         (LLVM.constCyclicVector $+          NonEmpty.snoc+             (List.map LLVM.constOf $ List.take (size x - 1) [1..])+             LLVM.undef) x+   Monad.lift2 (,)+      (extract (value LLVM.zero) x)+      (insert (LLVM.valueOf (size x - 1)) x0 y)++shiftUpMultiIndices ::+   (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32)+shiftUpMultiIndices n sizev =+   constCyclicVector $ fmap P.fromIntegral $+   NonEmpty.appendLeft (List.replicate n sizev) (NonEmptyC.iterate (1+) 0)++shiftDownMultiIndices ::+   (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32)+shiftDownMultiIndices n sizev =+   constCyclicVector $ fmap P.fromIntegral $+   NonEmpty.appendLeft+      (List.takeWhile (< sizev) $ List.iterate (1+) n)+      (NonEmptyC.repeat sizev)++shiftUpMultiZero ::+   (TypeNum.Positive n, C a) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftUpMultiZero n v =+   shuffle (shiftUpMultiIndices n (size v)) v zero++shiftDownMultiZero ::+   (TypeNum.Positive n, C a) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftDownMultiZero n v =+   shuffle (shiftDownMultiIndices n (size v)) v zero++shiftUpMultiUndef ::+   (TypeNum.Positive n, C a) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftUpMultiUndef n v =+   shuffle (shiftUpMultiIndices n (size v)) v undef++shiftDownMultiUndef ::+   (TypeNum.Positive n, C a) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftDownMultiUndef n v =+   shuffle (shiftDownMultiIndices n (size v)) v undef+++-- * method implementations based on Traversable++shuffleMatchTraversable ::+   (TypeNum.Positive n, C a, Trav.Traversable f) =>+   LLVM.ConstValue (LLVM.Vector n Word32) ->+   f (T n a) -> CodeGenFunction r (f (T n a))+shuffleMatchTraversable is v =+   Trav.mapM (shuffleMatch is) v++insertTraversable ::+   (TypeNum.Positive n, C a, Trav.Traversable f, App.Applicative f) =>+   LLVM.Value Word32 -> f (NiceValue.T a) ->+   f (T n a) -> CodeGenFunction r (f (T n a))+insertTraversable n a v =+   Trav.sequence (liftA2 (insert n) a v)++extractTraversable ::+   (TypeNum.Positive n, C a, Trav.Traversable f) =>+   LLVM.Value Word32 -> f (T n a) ->+   CodeGenFunction r (f (NiceValue.T a))+extractTraversable n v =+   Trav.mapM (extract n) v++++lift1 :: (Repr n a -> Repr n b) -> T n a -> T n b+lift1 f (Cons a) = Cons $ f a++_liftM0 ::+   (Monad m) =>+   m (Repr n a) ->+   m (T n a)+_liftM0 f = Monad.lift Cons f++liftM0 ::+   (Monad m,+    Repr n a ~ Value n ar) =>+   m (Value n ar) ->+   m (T n a)+liftM0 f = Monad.lift consPrim f++liftM ::+   (Monad m,+    Repr n a ~ Value n ar,+    Repr n b ~ Value n br) =>+   (Value n ar -> m (Value n br)) ->+   T n a -> m (T n b)+liftM f a = Monad.lift consPrim $ f (deconsPrim a)++liftM2 ::+   (Monad m,+    Repr n a ~ Value n ar,+    Repr n b ~ Value n br,+    Repr n c ~ Value n cr) =>+   (Value n ar -> Value n br -> m (Value n cr)) ->+   T n a -> T n b -> m (T n c)+liftM2 f a b = Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b)++liftM3 ::+   (Monad m,+    Repr n a ~ Value n ar,+    Repr n b ~ Value n br,+    Repr n c ~ Value n cr,+    Repr n d ~ Value n dr) =>+   (Value n ar -> Value n br -> Value n cr -> m (Value n dr)) ->+   T n a -> T n b -> T n c -> m (T n d)+liftM3 f a b c =+   Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b) (deconsPrim c)++++class (NiceValue.Additive a, C a) => Additive a where+   add ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   sub ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   neg ::+      (TypeNum.Positive n) =>+      T n a -> LLVM.CodeGenFunction r (T n a)++instance Additive Float where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Double where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int8 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int16 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int32 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int64 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word8 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word16 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word32 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word64 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance (TypeNum.Positive n, Additive a) => A.Additive (T n a) where+   zero = zero+   add = add+   sub = sub+   neg = neg+++class (NiceValue.PseudoRing a, Additive a) => PseudoRing a where+   mul ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance PseudoRing Float where+   mul = liftM2 LLVM.mul++instance PseudoRing Double where+   mul = liftM2 LLVM.mul++instance (TypeNum.Positive n, PseudoRing a) => A.PseudoRing (T n a) where+   mul = mul+++class (NiceValue.Field a, PseudoRing a) => Field a where+   fdiv ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance Field Float where+   fdiv = liftM2 LLVM.fdiv++instance Field Double where+   fdiv = liftM2 LLVM.fdiv++instance (TypeNum.Positive n, Field a) => A.Field (T n a) where+   fdiv = fdiv+++scale ::+   (TypeNum.Positive n, PseudoRing a) =>+   NiceValue.T a -> T n a -> LLVM.CodeGenFunction r (T n a)+scale a v = flip mul v =<< replicate a+++type instance A.Scalar (T n a) = T n (NiceValue.Scalar a)++class+   (NiceValue.PseudoModule v, PseudoRing (NiceValue.Scalar v), Additive v) =>+      PseudoModule v where+   scaleMulti ::+      (TypeNum.Positive n) =>+      T n (NiceValue.Scalar v) -> T n v -> LLVM.CodeGenFunction r (T n v)++instance PseudoModule Float where+   scaleMulti = liftM2 A.mul++instance PseudoModule Double where+   scaleMulti = liftM2 A.mul++instance (TypeNum.Positive n, PseudoModule a) => A.PseudoModule (T n a) where+   scale = scaleMulti+++class (NiceValue.Real a, Additive a) => Real a where+   min :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   max :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   abs :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)+   signum :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Real Float where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Double where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word8 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word16 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int8 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int16 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum+++instance (TypeNum.Positive n, Real a) => A.Real (T n a) where+   min = min+   max = max+   abs = abs+   signum = signum+++class (NiceValue.Fraction a, Real a) => Fraction a where+   truncate :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)+   fraction :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Fraction Float where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance Fraction Double where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance (TypeNum.Positive n, Fraction a) => A.Fraction (T n a) where+   truncate = truncate+   fraction = fraction+++class+   (TypeNum.Positive n, Repr n i ~ Value n ir,+    NiceValue.NativeInteger i ir, IsPrimitive ir, LLVM.IsInteger ir) =>+      NativeInteger n i ir where++instance (TypeNum.Positive n) => NativeInteger n Word   Word   where+instance (TypeNum.Positive n) => NativeInteger n Word8  Word8  where+instance (TypeNum.Positive n) => NativeInteger n Word16 Word16 where+instance (TypeNum.Positive n) => NativeInteger n Word32 Word32 where+instance (TypeNum.Positive n) => NativeInteger n Word64 Word64 where++instance (TypeNum.Positive n) => NativeInteger n Int   Int   where+instance (TypeNum.Positive n) => NativeInteger n Int8  Int8  where+instance (TypeNum.Positive n) => NativeInteger n Int16 Int16 where+instance (TypeNum.Positive n) => NativeInteger n Int32 Int32 where+instance (TypeNum.Positive n) => NativeInteger n Int64 Int64 where++class+   (TypeNum.Positive n, Repr n a ~ Value n ar,+    NiceValue.NativeFloating a ar, IsPrimitive ar, LLVM.IsFloating ar) =>+      NativeFloating n a ar where++instance (TypeNum.Positive n) => NativeFloating n Float  Float where+instance (TypeNum.Positive n) => NativeFloating n Double Double where++fromIntegral ::+   (NativeInteger n i ir, NativeFloating n a ar) =>+   T n i -> LLVM.CodeGenFunction r (T n a)+fromIntegral = liftM LLVM.inttofp+++class (NiceValue.Algebraic a, Field a) => Algebraic a where+   sqrt :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Algebraic Float where+   sqrt = liftM A.sqrt++instance Algebraic Double where+   sqrt = liftM A.sqrt++instance (TypeNum.Positive n, Algebraic a) => A.Algebraic (T n a) where+   sqrt = sqrt+++class (NiceValue.Transcendental a, Algebraic a) => Transcendental a where+   pi :: (TypeNum.Positive n) => LLVM.CodeGenFunction r (T n a)+   sin, cos, exp, log ::+      (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)+   pow ::+      (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance Transcendental Float where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance Transcendental Double where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance (TypeNum.Positive n, Transcendental a) => A.Transcendental (T n a) where+   pi = pi+   sin = sin+   cos = cos+   exp = exp+   log = log+   pow = pow++++class (NiceValue.Select a, C a) => Select a where+   select ::+      (TypeNum.Positive n) =>+      T n Bool -> T n a -> T n a ->+      LLVM.CodeGenFunction r (T n a)++instance Select Float where select = liftM3 LLVM.select+instance Select Double where select = liftM3 LLVM.select+instance Select Bool where select = liftM3 LLVM.select+instance Select Word where select = liftM3 LLVM.select+instance Select Word8 where select = liftM3 LLVM.select+instance Select Word16 where select = liftM3 LLVM.select+instance Select Word32 where select = liftM3 LLVM.select+instance Select Word64 where select = liftM3 LLVM.select+instance Select Int where select = liftM3 LLVM.select+instance Select Int8 where select = liftM3 LLVM.select+instance Select Int16 where select = liftM3 LLVM.select+instance Select Int32 where select = liftM3 LLVM.select+instance Select Int64 where select = liftM3 LLVM.select++instance (Select a, Select b) => Select (a,b) where+   select x y0 y1 =+      case (unzip y0, unzip y1) of+         ((a0,b0), (a1,b1)) ->+            Monad.lift2 zip+               (select x a0 a1)+               (select x b0 b1)++instance (Select a, Select b, Select c) => Select (a,b,c) where+   select x y0 y1 =+      case (unzip3 y0, unzip3 y1) of+         ((a0,b0,c0), (a1,b1,c1)) ->+            Monad.lift3 zip3+               (select x a0 a1)+               (select x b0 b1)+               (select x c0 c1)++++class (NiceValue.Comparison a, Real a) => Comparison a where+   cmp ::+      (TypeNum.Positive n) =>+      LLVM.CmpPredicate -> T n a -> T n a ->+      LLVM.CodeGenFunction r (T n Bool)++instance Comparison Float where cmp = liftM2 . LLVM.cmp+instance Comparison Double where cmp = liftM2 . LLVM.cmp+instance Comparison Word where cmp = liftM2 . LLVM.cmp+instance Comparison Word8 where cmp = liftM2 . LLVM.cmp+instance Comparison Word16 where cmp = liftM2 . LLVM.cmp+instance Comparison Word32 where cmp = liftM2 . LLVM.cmp+instance Comparison Word64 where cmp = liftM2 . LLVM.cmp+instance Comparison Int where cmp = liftM2 . LLVM.cmp+instance Comparison Int8 where cmp = liftM2 . LLVM.cmp+instance Comparison Int16 where cmp = liftM2 . LLVM.cmp+instance Comparison Int32 where cmp = liftM2 . LLVM.cmp+instance Comparison Int64 where cmp = liftM2 . LLVM.cmp++instance (TypeNum.Positive n, Comparison a) => A.Comparison (T n a) where+   type CmpResult (T n a) = T n Bool+   cmp = cmp++++class+   (NiceValue.FloatingComparison a, Comparison a) =>+      FloatingComparison a where+   fcmp ::+      (TypeNum.Positive n) =>+      LLVM.FPPredicate -> T n a -> T n a ->+      LLVM.CodeGenFunction r (T n Bool)++instance FloatingComparison Float where+   fcmp = liftM2 . LLVM.fcmp++instance+   (TypeNum.Positive n, FloatingComparison a) =>+      A.FloatingComparison (T n a) where+   fcmp = fcmp++++class (NiceValue.Logic a, C a) => Logic a where+   and, or, xor ::+      (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   inv :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Logic Bool where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word8 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word16 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word32 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word64 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv+++instance (TypeNum.Positive n, Logic a) => A.Logic (T n a) where+   and = and+   or = or+   xor = xor+   inv = inv++++class (NiceValue.BitShift a, C a) => BitShift a where+   shl :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   shr :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance BitShift Word where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word8 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word16 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word32 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word64 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Int where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int8 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int16 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int32 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int64 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr
+ src/LLVM/Extra/Nice/Vector/Instance.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module LLVM.Extra.Nice.Vector.Instance where++import qualified LLVM.Extra.Nice.Vector as Vector+import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import LLVM.Extra.Nice.Value.Private (Repr, )++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import Data.Functor ((<$>), )++import Prelude2010+import Prelude ()+++type NVVector n a = NiceValue.T (LLVM.Vector n a)++toNiceValue :: Vector.T n a -> NVVector n a+toNiceValue (Vector.Cons x) = NiceValue.Cons x++fromNiceValue :: NVVector n a -> Vector.T n a+fromNiceValue (NiceValue.Cons x) = Vector.Cons x++liftNiceValueM ::+   (Functor f) =>+   (Vector.T n a -> f (Vector.T m b)) ->+   (NVVector n a -> f (NVVector m b))+liftNiceValueM f a =+   toNiceValue <$> f (fromNiceValue a)++liftNiceValueM2 ::+   (Functor f) =>+   (Vector.T n a -> Vector.T m b -> f (Vector.T k c)) ->+   (NVVector n a -> NVVector m b -> f (NVVector k c))+liftNiceValueM2 f a b =+   toNiceValue <$> f (fromNiceValue a) (fromNiceValue b)++liftNiceValueM3 ::+   (Functor f) =>+   (Vector.T n a -> Vector.T m b -> Vector.T m c -> f (Vector.T k d)) ->+   (NVVector n a -> NVVector m b -> NVVector m c -> f (NVVector k d))+liftNiceValueM3 f a b c =+   toNiceValue <$> f (fromNiceValue a) (fromNiceValue b) (fromNiceValue c)++instance+   (TypeNum.Positive n, Vector.C a) =>+      NiceValue.C (LLVM.Vector n a) where+   type Repr (LLVM.Vector n a) = Vector.Repr n a+   cons = toNiceValue . Vector.cons+   undef = toNiceValue Vector.undef+   zero = toNiceValue Vector.zero+   phi = liftNiceValueM . Vector.phi+   addPhi bb x y = Vector.addPhi bb (fromNiceValue x) (fromNiceValue y)++instance+   (TypeNum.Positive n, Vector.IntegerConstant a) =>+      NiceValue.IntegerConstant (LLVM.Vector n a) where+   fromInteger' = toNiceValue . Vector.fromInteger'++instance+   (TypeNum.Positive n, Vector.RationalConstant a) =>+      NiceValue.RationalConstant (LLVM.Vector n a) where+   fromRational' = toNiceValue . Vector.fromRational'++instance+   (TypeNum.Positive n, Vector.Additive a) =>+      NiceValue.Additive (LLVM.Vector n a) where+   add = liftNiceValueM2 Vector.add+   sub = liftNiceValueM2 Vector.sub+   neg = liftNiceValueM Vector.neg++instance+   (TypeNum.Positive n, Vector.PseudoRing a) =>+      NiceValue.PseudoRing (LLVM.Vector n a) where+   mul = liftNiceValueM2 Vector.mul++instance+   (TypeNum.Positive n, Vector.Real a) =>+      NiceValue.Real (LLVM.Vector n a) where+   min = liftNiceValueM2 Vector.min+   max = liftNiceValueM2 Vector.max+   abs = liftNiceValueM Vector.abs+   signum = liftNiceValueM Vector.signum++instance+   (TypeNum.Positive n, Vector.Fraction a) =>+      NiceValue.Fraction (LLVM.Vector n a) where+   truncate = liftNiceValueM Vector.truncate+   fraction = liftNiceValueM Vector.fraction++instance+   (TypeNum.Positive n, Vector.Logic a) =>+      NiceValue.Logic (LLVM.Vector n a) where+   and = liftNiceValueM2 Vector.and+   or = liftNiceValueM2 Vector.or+   xor = liftNiceValueM2 Vector.xor+   inv = liftNiceValueM Vector.inv++instance+   (TypeNum.Positive n, Vector.BitShift a) =>+      NiceValue.BitShift (LLVM.Vector n a) where+   shl = liftNiceValueM2 Vector.shl+   shr = liftNiceValueM2 Vector.shr
src/LLVM/Extra/Struct.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {- | In contrast to 'LLVM.Struct' it allows to store high-level values-and thus allows to implement arbitrary-sized tuples of MultiValue's.+and thus allows to implement arbitrary-sized tuples of NiceValue's. -} module LLVM.Extra.Struct where