packages feed

llvm-extra 0.9.1 → 0.13.0.1

raw patch · 54 files changed

Files

Changes.md view
@@ -1,5 +1,42 @@ # 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+  based on `decompose` and `compose`.+  Deriving `decompose` and `compose` from `load` and `store`, respectively,+  requires `alloca` which will blast your stack when used in a loop.++## 0.10++* `Storable`: We do not support storing tuple types directly anymore.+  This would require the `storable-tuple` package.+  That package ships orphan `Storable` instances+  with a memory layout that does not match your system's ABI.+  Instead, we support the `Tuple` wrapper from `storable-record`.++* `Memory`: Attention!+  Memory layout is no longer compatible with `Foreign.Storable`.+  E.g. `Bool` now takes 1 byte space like LLVM does,+  but no longer 4 byte like `Foreign.Storable`.+  A `Foreign.Storable`-compliant layout+  is provided by `LLVM.Extra.Storable` now.++* `Marshal`: Now based on `Memory.load` and `Memory.store`.+  Does not need `Proxy` anymore.++* `Class` -> `Tuple`,+  `Tuple.Vector` class added.+  Pro: `valueOf vector` is no longer restricted to `IsPrimitive` elements.+  Cons: type inference works less well than before+ ## 0.9  * `Extension`: Move to new package `llvm-extension`.
llvm-extra.cabal view
@@ -1,6 +1,6 @@ Cabal-Version:  2.2 Name:           llvm-extra-Version:        0.9.1+Version:        0.13.0.1 License:        BSD-3-Clause License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -21,9 +21,15 @@   * a type class for loading and storing sets of values with one command (macro)     in "LLVM.Extra.Memory",   .-  * support instance declarations of LLVM classes-    in "LLVM.Extra.Class",+  * storing and reading Haskell values in an LLVM compatible format+    in "LLVM.Extra.Marshal",   .+  * LLVM functions for loading and storing values in Haskell's @Storable@ format+    in "LLVM.Extra.Storable",+  .+  * support value tuples and instance declarations of LLVM classes+    in "LLVM.Extra.Tuple",+  .   * handling of termination by a custom monad on top of @CodeGenFunction@     in "LLVM.Extra.MaybeContinuation"   .@@ -32,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,@@ -48,6 +54,8 @@ Build-Type:     Simple Extra-Source-Files:   Makefile++Extra-Doc-Files:   Changes.md  Flag buildExamples@@ -55,7 +63,7 @@   default:     False  Source-Repository this-  Tag:         0.9.1+  Tag:         0.13.0.1   Type:        darcs   Location:    http://code.haskell.org/~thielema/llvm-extra/ @@ -66,18 +74,21 @@ Library   Build-Depends:     private,-    llvm-tf >=9.1 && <9.2,+    llvm-tf >=12.1 && <21.1,     tfp >=1.0 && <1.1,     non-empty >=0.2.1 && <0.4,-    containers >=0.1 && <0.7,-    enumset >=0.0.5 && <0.1,+    fixed-length >=0.2.1 && <0.3,+    containers >=0.1 && <0.9,+    enumset >=0.0.5 && <0.2,+    storable-record >=0.0.5 && <0.1,     storable-enum >=0.0 && <0.1,     bool8 >=0.0 && <0.1,-    transformers >=0.1.1 && <0.6,+    transformers >=0.1.1 && <0.7,     tagged >=0.7 && <0.9,-    utility-ht >=0.0.11 && <0.1,+    utility-ht >=0.0.15 && <0.1,     prelude-compat >=0.0 && <0.0.1,-    base >=3 && <5+    base-orphans >= 0.5 && <1,+    base >=4.8 && <5    Default-Language: Haskell98   GHC-Options: -Wall@@ -87,30 +98,45 @@     LLVM.Extra.Monad     LLVM.Extra.Memory     LLVM.Extra.Marshal+    LLVM.Extra.Storable     LLVM.Extra.Maybe     LLVM.Extra.MaybeContinuation     LLVM.Extra.Either-    LLVM.Extra.Class+    LLVM.Extra.Tuple+    LLVM.Extra.Struct     LLVM.Extra.Control+    LLVM.Extra.Function     LLVM.Extra.Array     LLVM.Extra.Scalar     LLVM.Extra.Vector     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.Memory     LLVM.Extra.Multi.Value.Vector+    LLVM.Extra.Multi.Value.Marshal+    LLVM.Extra.Multi.Value.Storable     LLVM.Extra.Multi.Vector-    LLVM.Extra.Multi.Vector.Memory     LLVM.Extra.Multi.Vector.Instance     LLVM.Extra.Multi.Class   Other-Modules:+    LLVM.Extra.Storable.Array+    LLVM.Extra.Storable.Private+    LLVM.Extra.TuplePrivate     LLVM.Extra.MaybePrivate     LLVM.Extra.EitherPrivate-    LLVM.Extra.MemoryPrivate-    LLVM.Extra.Multi.Value.Private+    LLVM.Extra.Nice.Value.Private+    LLVM.Extra.Nice.Value.Array  Library private   Build-Depends:@@ -118,7 +144,7 @@     tfp,     non-empty,     utility-ht,-    base+    base >=3 && <5    Default-Language: Haskell98   GHC-Options: -Wall@@ -134,7 +160,7 @@       llvm-tf,       tfp,       non-empty,-      containers >=0.1 && <0.7,+      containers >=0.1 && <0.9,       transformers,       utility-ht >=0.0.1 && <0.1,       base >=3 && <5@@ -147,17 +173,21 @@ Test-Suite llvm-extra-test   Type: exitcode-stdio-1.0   Build-Depends:+    doctest-exitcode-stdio >=0.0 && <0.1,     QuickCheck >=2.11 && <3,     private,     llvm-extra,     llvm-tf,     tfp,+    storable-record,     utility-ht >=0.0.1 && <0.1,+    transformers,     base >=3 && <5   Default-Language: Haskell98   GHC-Options: -Wall   Hs-Source-Dirs: test   Main-Is: Main.hs   Other-Modules:+    Test.Storable     Test.Vector     LLVM.Extra.VectorAlt
private/LLVM/Extra/ArithmeticPrivate.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module LLVM.Extra.ArithmeticPrivate where  import qualified LLVM.Util.Intrinsic as Intrinsic@@ -10,7 +11,6 @@     IsConst, IsPrimitive, IsArithmetic, IsInteger, IsFloating,     getElementPtr, ) -import Foreign.Ptr (Ptr, ) import Data.Word (Word32, ) import Data.Int (Int32, ) @@ -39,14 +39,16 @@ dec x = sub x (valueOf 1)  advanceArrayElementPtr ::-   Value (Ptr a) ->-   CodeGenFunction r (Value (Ptr a))+   (LLVM.IsType a) =>+   Value (LLVM.Ptr a) ->+   CodeGenFunction r (Value (LLVM.Ptr a)) advanceArrayElementPtr p =    getElementPtr p (valueOf 1 :: Value Word32, ())  decreaseArrayElementPtr ::-   Value (Ptr a) ->-   CodeGenFunction r (Value (Ptr a))+   (LLVM.IsType a) =>+   Value (LLVM.Ptr a) ->+   CodeGenFunction r (Value (LLVM.Ptr a)) decreaseArrayElementPtr p =    getElementPtr p (valueOf (-1) :: Value Int32, ())
private/LLVM/Extra/ScalarOrVectorPrivate.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module LLVM.Extra.ScalarOrVectorPrivate where  import qualified LLVM.Extra.ArithmeticPrivate as A@@ -14,22 +15,24 @@     IsConst, IsInteger, CodeGenFunction)  import qualified Data.NonEmpty as NonEmpty-import Data.Word (Word8, Word16, Word32, Word64)+import Data.Word (Word8, Word16, Word32, Word64, Word) import Data.Int  (Int8,  Int16,  Int32,  Int64)  import Prelude hiding (replicate)  -type family Scalar vector :: *+type family Scalar vector  type instance Scalar Float  = Float type instance Scalar Double = Double type instance Scalar FP128  = FP128 type instance Scalar Bool   = Bool+type instance Scalar Int    = Int type instance Scalar Int8   = Int8 type instance Scalar Int16  = Int16 type instance Scalar Int32  = Int32 type instance Scalar Int64  = Int64+type instance Scalar Word   = Word type instance Scalar Word8  = Word8 type instance Scalar Word16 = Word16 type instance Scalar Word32 = Word32@@ -48,10 +51,12 @@ instance Replicate Double where replicate = return; replicateConst = id; instance Replicate FP128  where replicate = return; replicateConst = id; instance Replicate Bool   where replicate = return; replicateConst = id;+instance Replicate Int    where replicate = return; replicateConst = id; instance Replicate Int8   where replicate = return; replicateConst = id; instance Replicate Int16  where replicate = return; replicateConst = id; instance Replicate Int32  where replicate = return; replicateConst = id; instance Replicate Int64  where replicate = return; replicateConst = id;+instance Replicate Word   where replicate = return; replicateConst = id; instance Replicate Word8  where replicate = return; replicateConst = id; instance Replicate Word16 where replicate = return; replicateConst = id; instance Replicate Word32 where replicate = return; replicateConst = id;
src/Array.hs view
@@ -7,17 +7,18 @@ import qualified LLVM.Extra.Vector as Vector  import qualified LLVM.Extra.Iterator as Iter-import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Arithmetic as A-import LLVM.Extra.Control (arrayLoop, )+import LLVM.Extra.Storable (arrayLoop, store)+import LLVM.Extra.Control (ret)  import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Core as LLVM import LLVM.ExecutionEngine (simpleFunction, ) import LLVM.Core          (Value, valueOf, value, constOf, undef, zero, add, sub, mul, frem,-          createFunction, Function, Linkage(ExternalLinkage), ret,-          CodeGenModule, CodeGenFunction, store,+          createFunction, Function, Linkage(ExternalLinkage),+          CodeGenModule, CodeGenFunction,           Vector, extractelement, insertelement, shufflevector, ) import qualified System.IO as IO @@ -42,7 +43,7 @@ constVec ::    Float -> CodeGenFunction r (Value (Vector D4 Float)) constVec x =-   return $ valueOf $ LLVM.toVector (x,x,x,x)+   return $ valueOf $ LLVM.consVector x x x x  constVecInsert ::    Float -> CodeGenFunction r (Value (Vector D4 Float))@@ -68,7 +69,7 @@ This call      fill (fromIntegral len) ptr-       (LLVM.toVector (0.01003, 0.01001, 0.00999, 0.00997)) >>+       (LLVM.consVector 0.01003 0.01001 0.00999 0.00997) >>  would not work, because Vector is not of type Generic. -}@@ -164,7 +165,7 @@       liftA2         (\ptri phase ->           flip store ptri =<< mixGeneric =<< add const1 =<< mul const2 phase)-        (Iter.arrayPtrs ptr)+        (Iter.storableArrayPtrs ptr)         (Iter.iterate (Vector.fraction <=< A.add freq) (value (zero :: Vec)))     ret (value zero :: Value Float) @@ -174,7 +175,8 @@   A.sub (valueOf 1) =<<   A.mul (valueOf 2) t -osciSaw :: Value Float -> Value Float -> CodeGenFunction r (Value Float, Value Float)+osciSaw ::+  Value Float -> Value Float -> CodeGenFunction r (Value Float, Value Float) osciSaw freq phase =   liftM2 (,) (waveSaw phase) (SoV.incPhase freq phase) @@ -184,7 +186,7 @@       (Word32 -> Ptr Float -> Float -> Float -> Float -> Float -> IO Float)) mChorus =   createFunction ExternalLinkage $ \ size ptr f0 f1 f2 f3 -> do-    s <- arrayLoop size ptr Class.zeroTuple $+    s <- arrayLoop size ptr Tuple.zero $          \ ptri ((phase0, phase1), (phase2, phase3)) -> do       (y0, phase0') <- osciSaw f0 phase0       (y1, phase1') <- osciSaw f1 phase1@@ -230,7 +232,7 @@       (Word32 -> Ptr Float -> Float -> Float -> Float -> Float -> IO Float)) mChorusMonadic =   createFunction ExternalLinkage $ \ size ptr f0 f1 f2 f3 -> do-    s <- arrayLoop size ptr Class.zeroTuple $+    s <- arrayLoop size ptr Tuple.zero $          \ ptri phases -> do       (y, phases') <-          flip runStateT phases $
src/LLVM/Extra/Arithmetic.hs view
@@ -23,13 +23,14 @@    -- * transcendental functions    Algebraic (sqrt),    Transcendental (pi, sin, cos, exp, log, pow),+   exp2, log2, log10,    ) where  import qualified LLVM.Util.Intrinsic as Intrinsic import LLVM.Extra.ArithmeticPrivate    (inc, dec, advanceArrayElementPtr, decreaseArrayElementPtr, ) -import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Core as LLVM import LLVM.Core@@ -58,7 +59,7 @@ Disadvantage: You cannot use constant values directly, but you have to convert them all to 'Value'. -}-class (Class.Zero a) => Additive a where+class (Tuple.Zero a) => Additive a where    zero :: a    add :: a -> a -> CodeGenFunction r a    sub :: a -> a -> CodeGenFunction r a@@ -70,11 +71,11 @@    sub = LLVM.sub    neg = LLVM.neg -instance (IsArithmetic a) => Additive (ConstValue a) where+instance (IsInteger a) => Additive (ConstValue a) where    zero = LLVM.zero-   add = LLVM.add-   sub = LLVM.sub-   neg = sub LLVM.zero+   add = LLVM.iadd+   sub = LLVM.isub+   neg = LLVM.isub LLVM.zero  instance (Additive a, Additive b) => Additive (a,b) where    zero = (zero, zero)@@ -101,11 +102,8 @@ instance (IsArithmetic v) => PseudoRing (Value v) where    mul = LLVM.mul -instance (IsArithmetic v) => PseudoRing (ConstValue v) where-   mul = LLVM.mul --type family Scalar vector :: *+type family Scalar vector type instance Scalar (Value a) = Value (SoV.Scalar a) type instance Scalar (ConstValue a) = ConstValue (SoV.Scalar a) @@ -115,10 +113,7 @@ instance (SoV.PseudoModule v) => PseudoModule (Value v) where    scale = SoV.scale -instance (SoV.PseudoModule v) => PseudoModule (ConstValue v) where-   scale = SoV.scaleConst - class IntegerConstant a where    fromInteger' :: Integer -> a @@ -160,10 +155,7 @@ instance (LLVM.IsFloating v) => Field (Value v) where    fdiv = LLVM.fdiv -instance (LLVM.IsFloating v) => Field (ConstValue v) where-   fdiv = LLVM.fdiv - class (IntegerConstant a) => RationalConstant a where    fromRational' :: Rational -> a @@ -234,29 +226,22 @@   class Comparison a where-   type CmpResult a :: *+   type CmpResult a    cmp :: LLVM.CmpPredicate -> a -> a -> CodeGenFunction r (CmpResult a)  instance (LLVM.CmpRet a) => Comparison (Value a) where    type CmpResult (Value a) = Value (LLVM.CmpResult a)    cmp = LLVM.cmp -instance (LLVM.CmpRet a) => Comparison (ConstValue a) where-   type CmpResult (ConstValue a) = ConstValue (LLVM.CmpResult a)-   cmp = LLVM.cmp - class (Comparison a) => FloatingComparison a where    fcmp :: LLVM.FPPredicate -> a -> a -> CodeGenFunction r (CmpResult a)  instance (IsFloating a, LLVM.CmpRet a) => FloatingComparison (Value a) where    fcmp = LLVM.fcmp -instance (IsFloating a, LLVM.CmpRet a) => FloatingComparison (ConstValue a) where-   fcmp = LLVM.fcmp  - class Logic a where    and :: a -> a -> CodeGenFunction r a    or :: a -> a -> CodeGenFunction r a@@ -269,14 +254,8 @@    xor = LLVM.xor    inv = LLVM.inv -instance (LLVM.IsInteger a) => Logic (ConstValue a) where-   and = LLVM.and-   or = LLVM.or-   xor = LLVM.xor-   inv = LLVM.inv  - class Field a => Algebraic a where    sqrt :: a -> CodeGenFunction r a @@ -296,3 +275,13 @@    exp = Intrinsic.call1 "exp"    log = Intrinsic.call1 "log"    pow = Intrinsic.call2 "pow"+++exp2 :: (IsFloating a) => Value a -> CodeGenFunction r (Value a)+exp2 = Intrinsic.call1 "exp2"++log2 :: (IsFloating a) => Value a -> CodeGenFunction r (Value a)+log2 = Intrinsic.call1 "log2"++log10 :: (IsFloating a) => Value a -> CodeGenFunction r (Value a)+log10 = Intrinsic.call1 "log10"
src/LLVM/Extra/Array.hs view
@@ -5,7 +5,7 @@    map,    ) where -import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Tuple as Tuple  import qualified LLVM.Core as LLVM import LLVM.Core (Value, Array, CodeGenFunction, )@@ -41,10 +41,10 @@ This can be considered the inverse of 'extractAll'. -} assemble ::-   (TypeNum.Natural n, LLVM.IsFirstClass a, LLVM.IsSized a) =>+   (TypeNum.Natural n, LLVM.IsSized a) =>    [Value a] -> CodeGenFunction r (Value (Array n a)) assemble =-   foldM (\v (k,x) -> LLVM.insertvalue v x (k::Word32)) Class.undefTuple .+   foldM (\v (k,x) -> LLVM.insertvalue v x (k::Word32)) Tuple.undef .    List.zip [0..]  {- |@@ -53,7 +53,7 @@ This can be considered the inverse of 'assemble'. -} extractAll ::-   (TypeNum.Natural n, LLVM.IsFirstClass a, LLVM.IsSized a) =>+   (TypeNum.Natural n, LLVM.IsSized a) =>    Value (Array n a) -> LLVM.CodeGenFunction r [Value a] extractAll x =    mapM@@ -65,9 +65,7 @@ since 'LLVM.insertvalue' and 'LLVM.extractvalue' expect constant indices. -} map ::-   (TypeNum.Natural n,-    LLVM.IsFirstClass a, LLVM.IsSized a,-    LLVM.IsFirstClass b, LLVM.IsSized b) =>+   (TypeNum.Natural n, LLVM.IsSized a, LLVM.IsSized b) =>    (Value a -> CodeGenFunction r (Value b)) ->    (Value (Array n a) -> CodeGenFunction r (Value (Array n b))) map f =
− src/LLVM/Extra/Class.hs 
@@ -1,220 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-module LLVM.Extra.Class where--import qualified LLVM.Extra.EitherPrivate as Either-import qualified LLVM.Extra.MaybePrivate as Maybe-import qualified LLVM.Core as LLVM-import LLVM.Core-   (Value, value, valueOf, undef,-    ConstValue,-    Vector,-    IsConst, IsType, IsFirstClass, IsPrimitive,-    CodeGenFunction, BasicBlock, )-import LLVM.Util.Loop (Phi, phis, addPhis, )-import qualified Type.Data.Num.Decimal as TypeNum--import qualified Control.Applicative as App-import Control.Applicative (pure, liftA2, )--import qualified Data.Foldable as Fold-import qualified Data.Traversable as Trav--import Foreign.StablePtr (StablePtr, )-import Foreign.Ptr (FunPtr, Ptr, )--import Data.Word (Word8, Word16, Word32, Word64, )-import Data.Int  (Int8,  Int16,  Int32,  Int64, )--import Prelude2010 hiding (and, iterate, map, zipWith, writeFile, )-import Prelude ()----- * class for tuples of undefined values--class Undefined a where-   undefTuple :: a--instance Undefined () where-   undefTuple = ()--instance (IsFirstClass a) => Undefined (Value a) where-   undefTuple = value undef--instance (IsFirstClass a) => Undefined (ConstValue a) where-   undefTuple = undef--instance (Undefined a, Undefined b) => Undefined (a, b) where-   undefTuple = (undefTuple, undefTuple)--instance (Undefined a, Undefined b, Undefined c) => Undefined (a, b, c) where-   undefTuple = (undefTuple, undefTuple, undefTuple)--instance (Undefined a) => Undefined (Maybe.T a) where-   undefTuple = Maybe.Cons undefTuple undefTuple--instance (Undefined a, Undefined b) => Undefined (Either.T a b) where-   undefTuple = Either.Cons undefTuple undefTuple undefTuple----- * class for tuples of zero values--class Zero a where-   zeroTuple :: a--instance Zero () where-   zeroTuple = ()--instance (LLVM.IsFirstClass a) => Zero (Value a) where-   zeroTuple = LLVM.value LLVM.zero--instance (LLVM.IsFirstClass a) => Zero (ConstValue a) where-   zeroTuple = LLVM.zero--instance (Zero a, Zero b) => Zero (a, b) where-   zeroTuple = (zeroTuple, zeroTuple)--instance (Zero a, Zero b, Zero c) => Zero (a, b, c) where-   zeroTuple = (zeroTuple, zeroTuple, zeroTuple)--zeroTuplePointed ::-   (Zero a, App.Applicative f) =>-   f a-zeroTuplePointed =-   pure zeroTuple----- * class for creating tuples of constant values--class (Undefined (ValueTuple haskellValue)) =>-      MakeValueTuple haskellValue where-   type ValueTuple haskellValue :: *-   valueTupleOf :: haskellValue -> ValueTuple haskellValue--instance (MakeValueTuple ah, MakeValueTuple bh) =>-      MakeValueTuple (ah,bh) where-   type ValueTuple (ah,bh) = (ValueTuple ah, ValueTuple bh)-   valueTupleOf ~(a,b) = (valueTupleOf a, valueTupleOf b)--instance (MakeValueTuple ah, MakeValueTuple bh, MakeValueTuple ch) =>-      MakeValueTuple (ah,bh,ch) where-   type ValueTuple (ah,bh,ch) = (ValueTuple ah, ValueTuple bh, ValueTuple ch)-   valueTupleOf ~(a,b,c) = (valueTupleOf a, valueTupleOf b, valueTupleOf c)--instance (MakeValueTuple a) => MakeValueTuple (Maybe a) where-   type ValueTuple (Maybe a) = Maybe.T (ValueTuple a)-   valueTupleOf = maybe (Maybe.nothing undefTuple) (Maybe.just . valueTupleOf)--instance-   (MakeValueTuple a, MakeValueTuple b) =>-      MakeValueTuple (Either a b) where-   type ValueTuple (Either a b) = Either.T (ValueTuple a) (ValueTuple b)-   valueTupleOf =-      either-         (Either.left undefTuple . valueTupleOf)-         (Either.right undefTuple . valueTupleOf)--instance MakeValueTuple Float  where type ValueTuple Float  = Value Float  ; valueTupleOf = valueOf-instance MakeValueTuple Double where type ValueTuple Double = Value Double ; valueTupleOf = valueOf--- instance MakeValueTuple FP128  where type ValueTuple FP128  = Value FP128  ; valueTupleOf = valueOf-instance MakeValueTuple Bool   where type ValueTuple Bool   = Value Bool   ; valueTupleOf = valueOf-instance MakeValueTuple Int8   where type ValueTuple Int8   = Value Int8   ; valueTupleOf = valueOf-instance MakeValueTuple Int16  where type ValueTuple Int16  = Value Int16  ; valueTupleOf = valueOf-instance MakeValueTuple Int32  where type ValueTuple Int32  = Value Int32  ; valueTupleOf = valueOf-instance MakeValueTuple Int64  where type ValueTuple Int64  = Value Int64  ; valueTupleOf = valueOf-instance MakeValueTuple Word8  where type ValueTuple Word8  = Value Word8  ; valueTupleOf = valueOf-instance MakeValueTuple Word16 where type ValueTuple Word16 = Value Word16 ; valueTupleOf = valueOf-instance MakeValueTuple Word32 where type ValueTuple Word32 = Value Word32 ; valueTupleOf = valueOf-instance MakeValueTuple Word64 where type ValueTuple Word64 = Value Word64 ; valueTupleOf = valueOf-instance MakeValueTuple ()     where type ValueTuple ()     = ()           ; valueTupleOf = id--{--I'm not sure about this instance.-Maybe it is better to convert the pointer target type-according to a class that maps Haskell tuples to LLVM structs.--}-instance IsType a => MakeValueTuple (Ptr a) where-   type ValueTuple (Ptr a) = Value (Ptr a)-   valueTupleOf = valueOf--instance LLVM.IsFunction a => MakeValueTuple (FunPtr a) where-   type ValueTuple (FunPtr a) = Value (FunPtr a)-   valueTupleOf = valueOf--instance MakeValueTuple (StablePtr a) where-   type ValueTuple (StablePtr a) = Value (StablePtr a)-   valueTupleOf = valueOf--{--instance (MakeValueTuple haskellValue llvmValue, Memory llvmValue llvmStruct) =>-         MakeValueTuple (Ptr haskellValue) (Value (Ptr llvmStruct)) where-   valueTupleOf = valueOf . castTuplePtr--instance (Pos n) => MakeValueTuple (IntN n) where-   type ValueTuple (IntN n) = (Value (IntN n))-instance (Pos n) => MakeValueTuple (WordN n) where-   type ValueTuple (WordN n) = (Value (WordN n))--}-instance (TypeNum.Positive n, IsPrimitive a, IsConst a) =>-         MakeValueTuple (Vector n a) where-   type ValueTuple (Vector n a) = Value (Vector n a)-   valueTupleOf = valueOf----- * default methods for LLVM classes--{--buildTupleTraversable ::-   (Undefined a, Trav.Traversable f, App.Applicative f) =>-   FunctionRef -> State Int (f a)-buildTupleTraversable f =-   Trav.sequence (pure (buildTuple f))--}-{--buildTupleTraversable ::-   (Trav.Traversable f, App.Applicative f) =>-   State Int a ->-   State Int (f a)-buildTupleTraversable build =-   Trav.sequence (pure build)--}-{- this is the version I used-buildTupleTraversable ::-   (Monad m, Trav.Traversable f, App.Applicative f) =>-   m a ->-   m (f a)-buildTupleTraversable build =-   Trav.sequence (pure build)--}--undefTuplePointed ::-   (Undefined a, App.Applicative f) =>-   f a-undefTuplePointed =-   pure undefTuple--valueTupleOfFunctor ::-   (MakeValueTuple h, Functor f) =>-   f h -> f (ValueTuple h)-valueTupleOfFunctor =-   fmap valueTupleOf--{--tupleDescFoldable ::-   (IsTuple a, Fold.Foldable f) =>-   f a -> [TypeDesc]-tupleDescFoldable =-   Fold.foldMap tupleDesc--}--phisTraversable ::-   (Phi a, Trav.Traversable f) =>-   BasicBlock -> f a -> CodeGenFunction r (f a)-phisTraversable bb x =-   Trav.mapM (phis bb) x--addPhisFoldable ::-   (Phi a, Fold.Foldable f, App.Applicative f) =>-   BasicBlock -> f a -> f a -> CodeGenFunction r ()-addPhisFoldable bb x y =-   Fold.sequence_ (liftA2 (addPhis bb) x y)
src/LLVM/Extra/Control.hs view
@@ -16,13 +16,15 @@    Select(select),    selectTraversable,    ifThenSelect,+   ret,+   retVoid,    ) where -import LLVM.Extra.ArithmeticPrivate-   (cmp, sub, dec, advanceArrayElementPtr, ) import qualified LLVM.Extra.ArithmeticPrivate as A+import qualified LLVM.Extra.TuplePrivate as Tuple+import LLVM.Extra.ArithmeticPrivate (cmp, sub, dec, advanceArrayElementPtr)+ import qualified LLVM.Core as LLVM-import LLVM.Util.Loop (Phi, phis, addPhis, ) import LLVM.Core    (getCurrentBasicBlock, newBasicBlock, defineBasicBlock,     br, condBr,@@ -33,8 +35,6 @@     CodeGenFunction,     CodeGenModule, newModule, defineModule, writeBitcodeToFile, ) -import Foreign.Ptr (Ptr, )- import qualified Control.Applicative as App import qualified Data.Traversable as Trav import Control.Monad (liftM3, liftM2, )@@ -46,14 +46,14 @@ -- * control structures  {--I had to export Phi's methods in llvm-0.6.8+I had to export Tuple.Phi's methods in llvm-0.6.8 in order to be able to implement this function. -} arrayLoop ::-   (Phi a, IsType b,+   (Tuple.Phi a, IsType b,     Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>-   Value i -> Value (Ptr b) -> a ->-   (Value (Ptr b) -> a -> CodeGenFunction r a) ->+   Value i -> Value (LLVM.Ptr b) -> a ->+   (Value (LLVM.Ptr b) -> a -> CodeGenFunction r a) ->    CodeGenFunction r a arrayLoop len ptr start loopBody =    fmap snd $@@ -63,10 +63,10 @@          (loopBody p s)  arrayLoop2 ::-   (Phi s, IsType a, IsType b,+   (Tuple.Phi s, IsType a, IsType b,     Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>-   Value i -> Value (Ptr a) -> Value (Ptr b) -> s ->-   (Value (Ptr a) -> Value (Ptr b) -> s -> CodeGenFunction r s) ->+   Value i -> Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s ->+   (Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s -> CodeGenFunction r s) ->    CodeGenFunction r s arrayLoop2 len ptrA ptrB start loopBody =    fmap snd $@@ -78,10 +78,10 @@   arrayLoopWithExit ::-   (Phi s, IsType a,+   (Tuple.Phi s, IsType a,     Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>-   Value i -> Value (Ptr a) -> s ->-   (Value (Ptr a) -> s -> CodeGenFunction r (Value Bool, s)) ->+   Value i -> Value (LLVM.Ptr a) -> s ->+   (Value (LLVM.Ptr a) -> s -> CodeGenFunction r (Value Bool, s)) ->    CodeGenFunction r (Value i, s) arrayLoopWithExit len ptr start loopBody = do    ((_, vars), (i,_)) <-@@ -106,10 +106,10 @@ than manual decrement, zero test and conditional branch. -} _arrayLoopWithExitDecLoop ::-   (Phi a, IsType b,+   (Tuple.Phi a, IsType b,     Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>-   Value i -> Value (Ptr b) -> a ->-   (Value (Ptr b) -> a -> CodeGenFunction r (Value Bool, a)) ->+   Value i -> Value (LLVM.Ptr b) -> a ->+   (Value (LLVM.Ptr b) -> a -> CodeGenFunction r (Value Bool, a)) ->    CodeGenFunction r (Value i, a) _arrayLoopWithExitDecLoop len ptr start loopBody = do    top <- getCurrentBasicBlock@@ -126,14 +126,14 @@    defineBasicBlock checkEnd    i <- phi [(len, top)]    p <- phi [(ptr, top)]-   vars <- phis top start+   vars <- Tuple.phi top start    t <- phi [(t0, top)]    condBr t loop exit     defineBasicBlock loop     (cont, vars') <- loopBody p vars-   addPhis next vars vars'+   Tuple.addPhi next vars vars'    condBr cont next exit     defineBasicBlock next@@ -152,10 +152,10 @@   arrayLoop2WithExit ::-   (Phi s, IsType a, IsType b,+   (Tuple.Phi s, IsType a, IsType b,     Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>-   Value i -> Value (Ptr a) -> Value (Ptr b) -> s ->-   (Value (Ptr a) -> Value (Ptr b) -> s -> CodeGenFunction r (Value Bool, s)) ->+   Value i -> Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s ->+   (Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s -> CodeGenFunction r (Value Bool, s)) ->    CodeGenFunction r (Value i, s) arrayLoop2WithExit len ptrA ptrB start loopBody =    fmap (mapSnd snd) $@@ -167,7 +167,7 @@   fixedLengthLoop ::-   (Phi s,+   (Tuple.Phi s,     Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>    Value i -> s ->    (s -> CodeGenFunction r s) ->@@ -180,7 +180,7 @@   whileLoop, _whileLoop ::-   Phi a =>+   Tuple.Phi a =>    a ->    (a -> CodeGenFunction r (Value Bool)) ->    (a -> CodeGenFunction r a) ->@@ -198,13 +198,13 @@    br loop     defineBasicBlock loop-   state <- phis top start+   state <- Tuple.phi top start    b <- check state    condBr b cont exit    defineBasicBlock cont    res <- body state    cont' <- getCurrentBasicBlock-   addPhis cont' state res+   Tuple.addPhi cont' state res    br loop     defineBasicBlock exit@@ -216,7 +216,7 @@ The @Bool@ value indicates whether the loop shall be continued. -} loopWithExit ::-   Phi a =>+   Tuple.Phi a =>    a ->    (a -> CodeGenFunction r (Value Bool, b)) ->    (b -> CodeGenFunction r a) ->@@ -229,13 +229,13 @@    br loop     defineBasicBlock loop-   state <- phis top start+   state <- Tuple.phi top start    (contB,b) <- check state    condBr contB cont exit    defineBasicBlock cont    a <- body b    cont' <- getCurrentBasicBlock-   addPhis cont' state a+   Tuple.addPhi cont' state a    br loop     defineBasicBlock exit@@ -248,7 +248,7 @@ for both loop condition and loop body. -} whileLoopShared ::-   Phi a =>+   Tuple.Phi a =>    a ->    (a ->       (CodeGenFunction r (Value Bool),@@ -264,7 +264,7 @@ so be prepared when continueing after an 'ifThenElse'. -} ifThenElse ::-   Phi a =>+   Tuple.Phi a =>    Value Bool ->    CodeGenFunction r a ->    CodeGenFunction r a ->@@ -286,13 +286,13 @@    br mergeBlock     defineBasicBlock mergeBlock-   a2 <- phis thenBlock' a0-   addPhis elseBlock' a2 a1+   a2 <- Tuple.phi thenBlock' a0+   Tuple.addPhi elseBlock' a2 a1    return a2   ifThen ::-   Phi a =>+   Tuple.Phi a =>    Value Bool ->    a ->    CodeGenFunction r a ->@@ -309,12 +309,12 @@    br mergeBlock     defineBasicBlock mergeBlock-   a1 <- phis defltBlock deflt-   addPhis thenBlock' a1 a0+   a1 <- Tuple.phi defltBlock deflt+   Tuple.addPhi thenBlock' a1 a0    return a1  -class Phi a => Select a where+class Tuple.Phi a => Select a where    select :: Value Bool -> a -> a -> CodeGenFunction r a  instance (CmpRet a, IsPrimitive a) => Select (Value a) where@@ -359,6 +359,20 @@ ifThenSelect cond deflt thenCode = do    thenResult <- thenCode    select cond thenResult deflt+++-- * return with better type inference++{- |+'ret' terminates a basic block which interferes badly+with other control structures in this module.+If you use the control structures then better use "LLVM.Extra.Function".+-}+ret :: Value a -> CodeGenFunction a ()+ret = LLVM.ret++retVoid :: CodeGenFunction () ()+retVoid = LLVM.ret ()   -- * debugging
src/LLVM/Extra/Either.hs view
@@ -13,11 +13,11 @@    ) where  import qualified LLVM.Extra.EitherPrivate as Either-import LLVM.Extra.Class (Undefined, undefTuple, )+import qualified LLVM.Extra.Tuple as Tuple  -left :: (Undefined b) => a -> Either.T a b-left = Either.left undefTuple+left :: (Tuple.Undefined b) => a -> Either.T a b+left = Either.left Tuple.undef -right :: (Undefined a) => b -> Either.T a b-right = Either.right undefTuple+right :: (Tuple.Undefined a) => b -> Either.T a b+right = Either.right Tuple.undef
src/LLVM/Extra/EitherPrivate.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE TypeFamilies #-} module LLVM.Extra.EitherPrivate where +import qualified LLVM.Extra.TuplePrivate as Tuple import LLVM.Extra.Control (ifThenElse, )  import qualified LLVM.Core as LLVM import LLVM.Core (Value, valueOf, CodeGenFunction, )-import LLVM.Util.Loop (Phi, phis, addPhis, )  import Control.Monad (liftM3, ) @@ -19,17 +19,23 @@ data T a b = Cons {isRight :: Value Bool, fromLeft :: a, fromRight :: b}  -instance (Phi a, Phi b) => Phi (T a b) where-   phis bb (Cons r a b) = liftM3 Cons (phis bb r) (phis bb a) (phis bb b)-   addPhis bb (Cons r0 a0 b0) (Cons r1 a1 b1) =-      addPhis bb r0 r1 >> addPhis bb a0 a1 >> addPhis bb b0 b1+instance+   (Tuple.Undefined a, Tuple.Undefined b) =>+      Tuple.Undefined (T a b) where+   undef = Cons Tuple.undef Tuple.undef Tuple.undef +instance (Tuple.Phi a, Tuple.Phi b) => Tuple.Phi (T a b) where+   phi bb (Cons r a b) =+      liftM3 Cons (Tuple.phi bb r) (Tuple.phi bb a) (Tuple.phi bb b)+   addPhi bb (Cons r0 a0 b0) (Cons r1 a1 b1) =+      Tuple.addPhi bb r0 r1 >> Tuple.addPhi bb a0 a1 >> Tuple.addPhi bb b0 b1 + {- | counterpart to 'either' -} run ::-   (Phi c) =>+   (Tuple.Phi c) =>    T a b ->    (a -> CodeGenFunction r c) ->    (b -> CodeGenFunction r c) ->
src/LLVM/Extra/FastMath.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module LLVM.Extra.FastMath ( @@ -11,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,@@ -33,10 +42,10 @@    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.Class as Class+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Core as LLVM import LLVM.Util.Proxy (Proxy(Proxy)) @@ -91,288 +100,324 @@ getNumber :: flags -> Number flags a -> a getNumber _ (Number a) = a -instance MultiValue a => MV.C (Number flags a) where-   type Repr f (Number flags a) = MV.Repr f a-   cons = mvNumber . MV.cons . deconsNumber-   undef = mvNumber MV.undef-   zero = mvNumber MV.zero-   phis bb = fmap mvNumber . MV.phis bb . mvDenumber-   addPhis bb a b = MV.addPhis 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-   cons = mvecNumber . MultiVector.cons . fmap deconsNumber-   undef = mvecNumber MultiVector.undef-   zero = mvecNumber MultiVector.zero-   phis bb = fmap mvecNumber . MultiVector.phis bb . mvecDenumber-   addPhis bb a b = MultiVector.addPhis 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)   @@ -390,9 +435,9 @@ proxyFromContext (Context _) = Proxy  instance-   (Flags flags, Class.Zero a, Tuple a) =>-      Class.Zero (Context flags a) where-   zeroTuple = Context Class.zeroTuple+   (Flags flags, Tuple.Zero a, Tuple a) =>+      Tuple.Zero (Context flags a) where+   zero = Context Tuple.zero  instance    (Flags flags, Tuple a, A.Additive a) =>
+ src/LLVM/Extra/Function.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TypeFamilies #-}+{- |+Alternative to 'LLVM.Core.defineFunction'+that creates the final 'LLVM.Core.ret' instruction for you.+-}+module LLVM.Extra.Function (+   C,+   CodeGen,+   define,+   create,+   createNamed,+   Return, Result, ret,+   ) where++import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM++import Foreign.StablePtr (StablePtr)+import Foreign.Ptr (Ptr, FunPtr)++import Control.Applicative ((<*>))++import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)+++define ::+   (C f) => LLVM.Function f -> CodeGen f -> LLVM.CodeGenModule ()+define fn body =+   LLVM.defineFunction fn (addRet (proxyFromElement2 fn) body)++proxyFromElement2 :: f (g a) -> LP.Proxy a+proxyFromElement2 _ = LP.Proxy+++create ::+   (C f) =>+   LLVM.Linkage -> CodeGen f -> LLVM.CodeGenModule (LLVM.Function f)+create linkage body = do+   f <- LLVM.newFunction linkage+   define f body+   return f++createNamed ::+   (C f) =>+   LLVM.Linkage -> String -> CodeGen f -> LLVM.CodeGenModule (LLVM.Function f)+createNamed linkage name body = do+   f <- LLVM.newNamedFunction linkage name+   define f body+   return f+++{- |+> CodeGen (a->b->...-> IO z) =+>    Value a -> Value b -> ... CodeGenFunction r (Value z)@.+-}+class LLVM.FunctionArgs f => C f where+   type CodeGen f+   addRet :: LP.Proxy f -> CodeGen f -> LLVM.FunctionCodeGen f++instance (C b, LLVM.IsFirstClass a) => C (a -> b) where+   type CodeGen (a -> b) = LLVM.Value a -> CodeGen b+   addRet proxy f a = addRet (proxy<*>LP.Proxy) (f a)++instance Return a => C (IO a) where+   type CodeGen (IO a) = LLVM.CodeGenFunction a (Result a)+   addRet LP.Proxy code = code >>= ret+++class (LLVM.IsFirstClass a) => Return a where+   type Result a+   ret :: Result a -> LLVM.CodeGenFunction a ()+instance Return () where+   type Result () = ()+   ret = LLVM.ret++instance Return Bool where+   type Result Bool = LLVM.Value Bool; ret = LLVM.ret+instance Return Int where+   type Result Int = LLVM.Value Int; ret = LLVM.ret+instance Return Int8 where+   type Result Int8 = LLVM.Value Int8; ret = LLVM.ret+instance Return Int16 where+   type Result Int16 = LLVM.Value Int16; ret = LLVM.ret+instance Return Int32 where+   type Result Int32 = LLVM.Value Int32; ret = LLVM.ret+instance Return Int64 where+   type Result Int64 = LLVM.Value Int64; ret = LLVM.ret+instance Return Word where+   type Result Word = LLVM.Value Word; ret = LLVM.ret+instance Return Word8 where+   type Result Word8 = LLVM.Value Word8; ret = LLVM.ret+instance Return Word16 where+   type Result Word16 = LLVM.Value Word16; ret = LLVM.ret+instance Return Word32 where+   type Result Word32 = LLVM.Value Word32; ret = LLVM.ret+instance Return Word64 where+   type Result Word64 = LLVM.Value Word64; ret = LLVM.ret++instance Return Float where+   type Result Float = LLVM.Value Float; ret = LLVM.ret+instance Return Double where+   type Result Double = LLVM.Value Double; ret = LLVM.ret++instance Return (Ptr a) where+   type Result (Ptr a) = LLVM.Value (Ptr a); ret = LLVM.ret+instance (LLVM.IsType a) => Return (LLVM.Ptr a) where+   type Result (LLVM.Ptr a) = LLVM.Value (LLVM.Ptr a); ret = LLVM.ret+instance (LLVM.IsFunction a) => Return (FunPtr a) where+   type Result (FunPtr a) = LLVM.Value (FunPtr a); ret = LLVM.ret+instance Return (StablePtr a) where+   type Result (StablePtr a) = LLVM.Value (StablePtr a); ret = LLVM.ret
src/LLVM/Extra/Iterator.hs view
@@ -15,6 +15,7 @@    iterate,    countDown,    arrayPtrs,+   storableArrayPtrs,    -- * modifiers    mapM,    mapMaybe,@@ -33,11 +34,11 @@ import qualified LLVM.Extra.MaybeContinuation as MaybeCont import qualified LLVM.Extra.Maybe as Maybe +import qualified LLVM.Extra.Storable as Storable import qualified LLVM.Extra.ArithmeticPrivate as A-import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Control as C import qualified LLVM.Core as LLVM-import LLVM.Util.Loop (Phi, ) import LLVM.Core    (CodeGenFunction, Value, value, valueOf,     CmpRet, IsInteger, IsType, IsConst, IsPrimitive)@@ -60,8 +61,8 @@ Simulates a non-strict list. -} data T r a =-   forall s. (Phi s, Class.Undefined s) =>-   Cons s (forall z. (Phi z) => s -> MaybeCont.T r z (a,s))+   forall s. (Tuple.Phi s, Tuple.Undefined s) =>+   Cons s (forall z. (Tuple.Phi z) => s -> MaybeCont.T r z (a,s))  mapM_ :: (a -> CodeGenFunction r ()) -> T r a -> CodeGenFunction r () mapM_ f (Cons s next) =@@ -74,7 +75,7 @@       return  mapState_ ::-   (Phi t) =>+   (Tuple.Phi t) =>    (a -> t -> CodeGenFunction r t) ->    T r a -> t -> CodeGenFunction r t mapState_ f (Cons s next) t =@@ -87,7 +88,7 @@       return  mapStateM_ ::-   (Phi t) =>+   (Tuple.Phi t) =>    (a -> MS.StateT t (CodeGenFunction r) ()) ->    T r a -> MS.StateT t (CodeGenFunction r) () mapStateM_ f xs =@@ -96,7 +97,7 @@   mapWhileState_ ::-   (Phi t) =>+   (Tuple.Phi t) =>    (a -> t -> CodeGenFunction r (Value Bool, t)) ->    T r a -> t -> CodeGenFunction r t mapWhileState_ f (Cons s next) t =@@ -118,7 +119,7 @@       (valueOf True)       (\running -> MaybeCont.guard running >> return (a, valueOf False)) -cons :: (Phi a, Class.Undefined a) => a -> T r a -> T r a+cons :: (Tuple.Phi a, Tuple.Undefined a) => a -> T r a -> T r a cons a0 (Cons s next) =    Cons Maybe.nothing       (fmap (mapSnd Maybe.just) .@@ -154,11 +155,11 @@ mapM f (Cons s next) = Cons s (MaybeCont.lift . FuncHT.mapFst f <=< next)  mapMaybe ::-   (Phi b, Class.Undefined b) =>+   (Tuple.Phi b, Tuple.Undefined b) =>    (a -> CodeGenFunction r (Maybe.T b)) -> T r a -> T r b mapMaybe f = catMaybes . mapM f -catMaybes :: (Phi a, Class.Undefined a) => T r (Maybe.T a) -> T r a+catMaybes :: (Tuple.Phi a, Tuple.Undefined a) => T r (Maybe.T a) -> T r a catMaybes (Cons s next) =    Cons s       (\s0 ->@@ -188,12 +189,12 @@ make sure that accessing one more pointer is legal. -} iterate ::-   (Phi a, Class.Undefined a) => (a -> CodeGenFunction r a) -> a -> T r a+   (Tuple.Phi a, Tuple.Undefined a) => (a -> CodeGenFunction r a) -> a -> T r a iterate f a = Cons a (\a0 -> MaybeCont.lift $ fmap ((,) a0) $ f a0)   cartesianAux ::-   (Phi a, Phi b, Class.Undefined a, Class.Undefined b) =>+   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined a, Tuple.Undefined b) =>    T r a -> T r b -> T r (Maybe.T (a,b)) cartesianAux (Cons sa nextA) (Cons sb nextB) =    Cons (Maybe.nothing,sa,sb)@@ -209,7 +210,7 @@                   return (Maybe.just (a1,b1), (Maybe.just a1, sa1, sb1))))  cartesian ::-   (Phi a, Phi b, Class.Undefined a, Class.Undefined b) =>+   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined a, Tuple.Undefined b) =>    T r a -> T r b -> T r (a,b) cartesian as bs = catMaybes $ cartesianAux as bs @@ -224,14 +225,17 @@    Value i -> T r a -> T r a take len xs = liftA2 const xs (countDown len) -arrayPtrs :: (IsType a) => Value (Ptr a) -> T r (Value (Ptr a))+arrayPtrs :: (IsType a) => Value (LLVM.Ptr a) -> T r (Value (LLVM.Ptr a)) arrayPtrs = iterate A.advanceArrayElementPtr +storableArrayPtrs :: (Storable.C a) => Value (Ptr a) -> T r (Value (Ptr a))+storableArrayPtrs = iterate Storable.incrementPtr + -- * examples  fixedLengthLoop ::-   (Phi s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   (Tuple.Phi s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>    Value i -> s ->    (s -> CodeGenFunction r s) ->    CodeGenFunction r s@@ -239,17 +243,17 @@    mapState_ (const loopBody) (countDown len) start  arrayLoop ::-   (Phi a, IsType b, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>-   Value i -> Value (Ptr b) -> a ->-   (Value (Ptr b) -> a -> CodeGenFunction r a) ->+   (Tuple.Phi a, IsType b, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr b) -> a ->+   (Value (LLVM.Ptr b) -> a -> CodeGenFunction r a) ->    CodeGenFunction r a arrayLoop len ptr start loopBody =    mapState_ loopBody (take len $ arrayPtrs ptr) start  arrayLoopWithExit ::-   (Phi s, IsType a, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>-   Value i -> Value (Ptr a) -> s ->-   (Value (Ptr a) -> s -> CodeGenFunction r (Value Bool, s)) ->+   (Tuple.Phi s, IsType a, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr a) -> s ->+   (Value (LLVM.Ptr a) -> s -> CodeGenFunction r (Value Bool, s)) ->    CodeGenFunction r (Value i, s) arrayLoopWithExit len ptr0 start loopBody = do    (i, end) <-@@ -261,9 +265,9 @@    return (pos, end)  arrayLoop2 ::-   (Phi s, IsType a, IsType b, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>-   Value i -> Value (Ptr a) -> Value (Ptr b) -> s ->-   (Value (Ptr a) -> Value (Ptr b) -> s -> CodeGenFunction r s) ->+   (Tuple.Phi s, IsType a, IsType b, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s ->+   (Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s -> CodeGenFunction r s) ->    CodeGenFunction r s arrayLoop2 len ptrA ptrB start loopBody =    mapState_ (uncurry loopBody)
src/LLVM/Extra/Marshal.hs view
@@ -1,180 +1,223 @@ {-# 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 Haskell tuples are stored as LLVM structs.+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.Marshal where+module LLVM.Extra.Marshal (+   C(..),+   Struct,+   peek,+   poke, -import qualified LLVM.Extra.Class as Class-import qualified LLVM.Util.Proxy as LP+   VectorStruct,+   Vector(..),++   with,+   EE.alloca,+   ) where++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, Value)  import qualified Type.Data.Num.Decimal as TypeNum +import qualified Control.Functor.HT as FuncHT import Control.Applicative (liftA2, liftA3, (<$>)) -import Foreign.Marshal.Alloc (allocaBytes)-import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable)+import Foreign.StablePtr (StablePtr)+import Foreign.Ptr (FunPtr, Ptr) -import Data.Tuple.HT (fst3, snd3, thd3)-import Data.Word (Word8, Word16, Word32, Word64, )-import Data.Int  (Int8,  Int16,  Int32,  Int64, )+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64)   -peek :: (C a, Struct a ~ struct, EE.Marshal struct) => Ptr struct -> IO a+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) => Ptr struct -> a -> IO ()+poke ::+   (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> a -> IO () poke ptr = EE.poke ptr . pack -load ::-   (C a, Struct a ~ struct, EE.Marshal struct) =>-   LP.Proxy a ->-   Value (Ptr struct) -> CodeGenFunction r (Class.ValueTuple a)-load proxy ptr  =  decompose proxy =<< LLVM.load ptr -store ::-   (C a, Struct a ~ struct, EE.Marshal struct) =>-   LP.Proxy a ->-   Class.ValueTuple a -> Value (Ptr struct) -> CodeGenFunction r ()-store proxy tuple ptr  =  flip LLVM.store ptr =<< compose proxy tuple-+type Struct a = Memory.Struct (Tuple.ValueOf a)  class-   (Class.MakeValueTuple a, EE.Marshal (Struct a), LLVM.IsSized (Struct a)) =>+   (Tuple.Value a, Memory.C (Tuple.ValueOf a),+    EE.Marshal (Struct a), LLVM.IsSized (Struct a)) =>       C a where-   type Struct a    pack :: a -> Struct a    unpack :: Struct a -> a-   compose ::-      LP.Proxy a ->-      Class.ValueTuple a -> CodeGenFunction r (Value (Struct a))-   decompose ::-      LP.Proxy a ->-      Value (Struct a) -> CodeGenFunction r (Class.ValueTuple a) -instance C Bool where-   type Struct Bool = Bool-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return+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 C Float where-   type Struct Float = Float-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return+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 Double where-   type Struct Double = Double-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return+instance C () where+   pack = LLVM.Struct+   unpack (LLVM.Struct unit) = unit -instance C Word8 where-   type Struct Word8 = Word8-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return+instance+   (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b), 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 Word16 where-   type Struct Word16 = Word16-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return+instance+   (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b), LLVM.IsSized (Struct c),+    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 Word32 where-   type Struct Word32 = Word32-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return+instance+   (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b),+    LLVM.IsSized (Struct c), LLVM.IsSized (Struct d),+    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 Word64 where-   type Struct Word64 = Word64-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return -instance C Int8 where-   type Struct Int8 = Int8-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return -instance C Int16 where-   type Struct Int16 = Int16-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return--instance C Int32 where-   type Struct Int32 = Int32-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return--instance C Int64 where-   type Struct Int64 = Int64-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return+type VectorStruct n a = Memory.Struct (Tuple.VectorValueOf n a) -instance (LLVM.IsType a) => C (Ptr a) where-   type Struct (Ptr a) = Ptr a-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return+class+   (TypeNum.Positive n,+    Tuple.VectorValue n a, Memory.C (Tuple.VectorValueOf n a),+    EE.Marshal (VectorStruct n a), LLVM.IsSized (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, TypeNum.Natural (n TypeNum.:*: LLVM.SizeOf a),-    EE.Marshal a, LLVM.IsConst a, LLVM.IsPrimitive a, LLVM.IsSized a) =>+    Vector n a) =>       C (LLVM.Vector n a) where-   type Struct (LLVM.Vector n a) = LLVM.Vector n a-   pack   = id; compose   LP.Proxy = return-   unpack = id; decompose LP.Proxy = return+   pack = packVector; unpack = unpackVector -instance C () where-   type Struct () = LLVM.Struct ()-   pack = LLVM.Struct-   unpack (LLVM.Struct unit) = unit-   compose LP.Proxy () = return $ LLVM.valueOf $ LLVM.Struct ()-   decompose LP.Proxy _ = return ()  instance-   (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b), C a, C b) =>-      C (a,b) where-   type Struct (a,b) = LLVM.Struct (Struct a, (Struct b, ()))-   pack (a,b) = LLVM.Struct (pack a, (pack b, ()))-   unpack (LLVM.Struct (a,(b,()))) = (unpack a, unpack b)-   compose proxy (a,b) = do-      ac <- compose (fst <$> proxy) a-      bc <- compose (snd <$> proxy) b-      struct0 <- LLVM.insertvalue (LLVM.value LLVM.undef) ac TypeNum.d0-      LLVM.insertvalue struct0 bc TypeNum.d1-   decompose proxy struct =-      liftA2 (,)-         (decompose (fst <$> proxy) =<< LLVM.extractvalue struct TypeNum.d0)-         (decompose (snd <$> proxy) =<< LLVM.extractvalue struct TypeNum.d1)+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D1)) =>+      Vector n Bool where+   packVector = id+   unpackVector = id  instance-   (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b), LLVM.IsSized (Struct c),-    C a, C b, C c) =>-      C (a,b,c) where-   type Struct (a,b,c) = LLVM.Struct (Struct a, (Struct b, (Struct c, ())))-   pack (a,b,c) = LLVM.Struct (pack a, (pack b, (pack c, ())))-   unpack (LLVM.Struct (a,(b,(c,())))) = (unpack a, unpack b, unpack c)-   compose proxy (a,b,c) = do-      ac <- compose (fst3 <$> proxy) a-      bc <- compose (snd3 <$> proxy) b-      cc <- compose (thd3 <$> proxy) c-      struct0 <- LLVM.insertvalue (LLVM.value LLVM.undef) ac TypeNum.d0-      struct1 <- LLVM.insertvalue struct0 bc TypeNum.d1-      LLVM.insertvalue struct1 cc TypeNum.d2-   decompose proxy struct =-      liftA3 (,,)-         (decompose (fst3 <$> proxy) =<< LLVM.extractvalue struct TypeNum.d0)-         (decompose (snd3 <$> proxy) =<< LLVM.extractvalue struct TypeNum.d1)-         (decompose (thd3 <$> proxy) =<< LLVM.extractvalue struct TypeNum.d2)+   (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 -with :: (C a) => a -> (Ptr (Struct a) -> IO b) -> IO b-with a act = alloca LP.Proxy $ \ptr -> poke ptr a >> act ptr+instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) =>+      Vector n Word where+   packVector = id+   unpackVector = id -alloca ::-   (LLVM.IsType struct) => LP.Proxy struct -> (Ptr struct -> IO b) -> IO b-alloca proxy = allocaBytes (EE.sizeOf proxy)+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/Maybe.hs view
@@ -21,20 +21,19 @@    loopWithExit,    ) where +import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.MaybePrivate as Maybe import qualified LLVM.Extra.Control as C-import LLVM.Extra.Class (Undefined, undefTuple, ) -import LLVM.Util.Loop (Phi, ) import LLVM.Core (CodeGenFunction, )  -nothing :: (Undefined a) => Maybe.T a-nothing = Maybe.nothing undefTuple+nothing :: (Tuple.Undefined a) => Maybe.T a+nothing = Maybe.nothing Tuple.undef   loopWithExit ::-   Phi a =>+   Tuple.Phi a =>    a ->    (a -> CodeGenFunction r (Maybe.T c, b)) ->    ((c,b) -> CodeGenFunction r a) ->
src/LLVM/Extra/MaybeContinuation.hs view
@@ -5,23 +5,21 @@ module LLVM.Extra.MaybeContinuation where  import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Control as C import LLVM.Extra.Control (ifThenElse, )-import LLVM.Extra.Class (Undefined, undefTuple, )  import qualified LLVM.Core as LLVM import LLVM.Core    (CodeGenFunction, Value, value, valueOf,     IsConst, IsType, IsPrimitive, IsInteger, CmpRet)-import LLVM.Util.Loop (Phi, ) -- (phis, addPhis, )  import qualified Control.Monad as M import qualified Control.Applicative as App import Control.Monad.IO.Class (MonadIO(liftIO), ) import Control.Monad.HT ((<=<), ) -import Foreign.Ptr (Ptr, ) import Data.Tuple.HT (mapSnd, )  import Prelude hiding (map, )@@ -48,11 +46,10 @@    fmap f (Cons m) = Cons $ \n j -> m n (j . f)  instance App.Applicative (T r z) where-   pure = return+   pure a = lift (pure a)    (<*>) = M.ap  instance Monad (T r z) where-   return a = lift (return a)    (>>=) = bind  instance MonadIO (T r z) where@@ -62,7 +59,7 @@ counterpart to Data.Maybe.HT.toMaybe -} withBool ::-   (Phi z) =>+   (Tuple.Phi z) =>    Value Bool -> CodeGenFunction r a -> T r z a withBool b a =    guard b >> lift a@@ -72,7 +69,7 @@ -}  fromBool ::-   (Phi z) =>+   (Tuple.Phi z) =>    CodeGenFunction r (Value Bool, a) ->    T r z a fromBool m = do@@ -81,20 +78,20 @@    return a  toBool ::-   (Undefined a) =>+   (Tuple.Undefined a) =>    T r (Value Bool, a) a -> CodeGenFunction r (Value Bool, a) toBool (Cons m) =-   m (return (valueOf False, undefTuple)) (return . (,) (valueOf True))+   m (return (valueOf False, Tuple.undef)) (return . (,) (valueOf True))  -fromPlainMaybe :: (Phi z) => Maybe.T a -> T r z a+fromPlainMaybe :: (Tuple.Phi z) => Maybe.T a -> T r z a fromPlainMaybe (Maybe.Cons b a) = guard b >> return a -fromMaybe :: (Phi z) => CodeGenFunction r (Maybe.T a) -> T r z a+fromMaybe :: (Tuple.Phi z) => CodeGenFunction r (Maybe.T a) -> T r z a fromMaybe m = lift m >>= fromPlainMaybe  toMaybe ::-   (Undefined a) =>+   (Tuple.Undefined a) =>    T r (Maybe.T a) a -> CodeGenFunction r (Maybe.T a) toMaybe (Cons m) =    m (return Maybe.nothing) (return . Maybe.just)@@ -109,7 +106,7 @@ lift a = Cons $ \ _n j -> j =<< a  guard ::-   (Phi z) =>+   (Tuple.Phi z) =>    Value Bool -> T r z () guard b = Cons $ \n j ->    ifThenElse b (j ()) n@@ -140,14 +137,14 @@ If both actions fail, then the composed action fails, too. -} alternative ::-   (Phi z, Undefined a) =>+   (Tuple.Phi z, Tuple.Undefined a) =>    T r (Maybe.T a) a -> T r (Maybe.T a) a -> T r z a alternative x y =    fromMaybe $ resolve x (toMaybe y) (return . Maybe.just)   fixedLengthLoop ::-   (Phi s, Undefined s,+   (Tuple.Phi s, Tuple.Undefined s,     Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>    Value i -> s ->    (s -> T r (Maybe.T s) s) ->@@ -172,11 +169,11 @@ then returned final state is 'Maybe.nothing'. -} arrayLoop ::-   (Phi s, Undefined s, IsType a,+   (Tuple.Phi s, Tuple.Undefined s, IsType a,     Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>    Value i ->-   Value (Ptr a) -> s ->-   (Value (Ptr a) -> s -> T r (Maybe.T (Value (Ptr a), s)) s) ->+   Value (LLVM.Ptr a) -> s ->+   (Value (LLVM.Ptr a) -> s -> T r (Maybe.T (Value (LLVM.Ptr a), s)) s) ->    CodeGenFunction r (Value i, Maybe.T s) arrayLoop len ptr start loopBody =    fmap (mapSnd (fmap snd)) $@@ -187,12 +184,12 @@   arrayLoop2 ::-   (Phi s, Undefined s, IsType a, IsType b,+   (Tuple.Phi s, Tuple.Undefined s, IsType a, IsType b,     Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>    Value i ->-   Value (Ptr a) -> Value (Ptr b) -> s ->-   (Value (Ptr a) -> Value (Ptr b) -> s ->-      T r (Maybe.T (Value (Ptr a), (Value (Ptr b), s))) s) ->+   Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s ->+   (Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s ->+      T r (Maybe.T (Value (LLVM.Ptr a), (Value (LLVM.Ptr b), s))) s) ->    CodeGenFunction r (Value i, Maybe.T s) arrayLoop2 len ptrA ptrB start loopBody =    fmap (mapSnd (fmap snd)) $@@ -208,7 +205,7 @@ and we could just propagate a Nothing.  whileLoop ::-   Phi a =>+   Tuple.Phi a =>    a ->    (a -> T r z a) ->    CodeGenFunction r a@@ -220,13 +217,13 @@    br loop     defineBasicBlock loop-   state <- phis top start+   state <- phi top start    b <- check state    condBr b cont exit    defineBasicBlock cont    res <- body state    cont' <- getCurrentBasicBlock-   addPhis cont' state res+   addPhi cont' state res    br loop     defineBasicBlock exit
src/LLVM/Extra/MaybePrivate.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE TypeFamilies #-} module LLVM.Extra.MaybePrivate where +import qualified LLVM.Extra.TuplePrivate as Tuple import qualified LLVM.Extra.Control as C import LLVM.Extra.Control (ifThenElse, )  import qualified LLVM.Core as LLVM import LLVM.Core (Value, valueOf, CodeGenFunction, )-import LLVM.Util.Loop (Phi, phis, addPhis, )  import qualified Control.Monad as Monad @@ -22,17 +22,20 @@ instance Functor T where    fmap f (Cons b a) = Cons b (f a) -instance (Phi a) => Phi (T a) where-   phis bb (Cons b a) = Monad.liftM2 Cons (phis bb b) (phis bb a)-   addPhis bb (Cons b0 a0) (Cons b1 a1) =-      addPhis bb b0 b1 >> addPhis bb a0 a1+instance (Tuple.Undefined a) => Tuple.Undefined (T a) where+   undef = Cons Tuple.undef Tuple.undef +instance (Tuple.Phi a) => Tuple.Phi (T a) where+   phi bb (Cons b a) = Monad.liftM2 Cons (Tuple.phi bb b) (Tuple.phi bb a)+   addPhi bb (Cons b0 a0) (Cons b1 a1) =+      Tuple.addPhi bb b0 b1 >> Tuple.addPhi bb a0 a1 + {- | counterpart to 'maybe' -} run ::-   (Phi b) =>+   (Tuple.Phi b) =>    T a ->    CodeGenFunction r b ->    (a -> CodeGenFunction r b) ->@@ -106,7 +109,7 @@   maybeArg ::-   (Phi b) =>+   (Tuple.Phi b) =>    b ->    (a -> CodeGenFunction r (T b)) ->    T a -> CodeGenFunction r (T b)
src/LLVM/Extra/Memory.hs view
@@ -1,88 +1,88 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} module LLVM.Extra.Memory (-   C(load, store, decompose, compose), modify, castStorablePtr, castTuplePtr,+   C(load, store, decompose, compose), modify,    Struct,    Record, Element, element,    loadRecord, storeRecord, decomposeRecord, composeRecord,    loadNewtype, storeNewtype, decomposeNewtype, composeNewtype,-   FirstClass, Stored,    ) where -import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, )-import LLVM.Extra.MemoryPrivate (decomposeFromLoad, composeFromStore, )--import qualified LLVM.Extra.Multi.Vector.Memory as MultiVectorMemory-import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-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.Extra.Vector as Vector+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.Array as Array+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Struct as Struct import qualified LLVM.Extra.Either as Either import qualified LLVM.Extra.Maybe as Maybe -import qualified LLVM.Util.Proxy as LP import qualified LLVM.Core as LLVM-import LLVM.Util.Loop (Phi, ) import LLVM.Core-   (getElementPtr0,-    extractvalue, insertvalue,-    Value, -- valueOf, Vector,-    IsType, IsSized,-    CodeGenFunction, )+   (CodeGenFunction, Value, IsType, IsSized,+    getElementPtr0, extractvalue, insertvalue)  import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal (d0, d1, d2, )-import Type.Base.Proxy (Proxy(Proxy), )--import Foreign.StablePtr (StablePtr, )-import Foreign.Ptr (FunPtr, Ptr, castPtr, )--import Data.Word (Word8, Word16, Word32, Word64, )-import Data.Int  (Int8,  Int16,  Int32,  Int64, )--import qualified Control.Applicative as App-import Control.Monad (ap, )-import Control.Applicative (pure, liftA2, liftA3, )+import qualified Type.Data.Num.Unary as Unary+import Type.Data.Num.Decimal (d0, d1, d2, d3)+import Type.Base.Proxy (Proxy(Proxy)) +import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.FixedLength as FixedLength+import qualified Data.Complex as Complex+import Data.Complex (Complex((:+))) import Data.Tuple.HT (fst3, snd3, thd3, )+import Data.Word (Word) +import qualified Control.Applicative.HT as App+import Control.Monad (ap, (<=<))+import Control.Applicative (Applicative, pure, liftA2, liftA3, (<*>))+ import Prelude2010 hiding (maybe, either, ) import Prelude ()  -{- |-An implementation of both 'MakeValueTuple' and 'Memory.C'-must ensure that @haskellValue@ is compatible-with @Stored (Struct haskellValue)@ (which we want to call @llvmStruct@).-That is, writing and reading @llvmStruct@ by LLVM-must be the same as accessing @haskellValue@ by 'Storable' methods.-ToDo: In future we may also require Storable constraint for @llvmStruct@.--We use a functional dependency in order to let type inference work nicely.--}-class (Phi llvmValue, Undefined llvmValue, IsType (Struct llvmValue), IsSized (Struct llvmValue)) =>+class+   (Tuple.Phi llvmValue, Tuple.Undefined llvmValue,+    IsType (Struct llvmValue), IsSized (Struct llvmValue)) =>       C llvmValue where-   {-# MINIMAL (load|decompose), (store|compose) #-}-   type Struct llvmValue :: *-   load :: Value (Ptr (Struct llvmValue)) -> CodeGenFunction r llvmValue+   type Struct llvmValue+   load :: Value (LLVM.Ptr (Struct llvmValue)) -> CodeGenFunction r llvmValue    load ptr  =  decompose =<< LLVM.load ptr-   store :: llvmValue -> Value (Ptr (Struct llvmValue)) -> CodeGenFunction r ()+   store ::+      llvmValue -> Value (LLVM.Ptr (Struct llvmValue)) -> CodeGenFunction r ()    store r ptr  =  flip LLVM.store ptr =<< compose r+   {- |+   In principle it holds:++   > decompose struct = do+   >   ptr <- LLVM.alloca+   >   LLVM.store struct ptr+   >   Memory.load ptr++   but 'LLVM.alloca' will blast your stack when used in a loop.+   -}    decompose :: Value (Struct llvmValue) -> CodeGenFunction r llvmValue-   decompose = decomposeFromLoad load+   {- |+   In principle it holds:++   > compose struct = do+   >   ptr <- LLVM.alloca+   >   Memory.store struct ptr+   >   LLVM.load ptr++   but 'LLVM.alloca' will blast your stack when used in a loop.+   -}    compose :: llvmValue -> CodeGenFunction r (Value (Struct llvmValue))-   compose = composeFromStore store  modify ::    (C llvmValue) =>    (llvmValue -> CodeGenFunction r llvmValue) ->-   Value (Ptr (Struct llvmValue)) -> CodeGenFunction r ()+   Value (LLVM.Ptr (Struct llvmValue)) -> CodeGenFunction r () modify f ptr =    flip store ptr =<< f =<< load ptr @@ -99,15 +99,15 @@  data Element r o v x =    Element {-      loadElement :: Value (Ptr o) -> CodeGenFunction r x,-      storeElement :: Value (Ptr o) -> v -> CodeGenFunction r (),+      loadElement :: Value (LLVM.Ptr o) -> CodeGenFunction r x,+      storeElement :: Value (LLVM.Ptr o) -> v -> CodeGenFunction r (),       extractElement :: Value o -> CodeGenFunction r x,       insertElement :: v -> Value o -> CodeGenFunction r (Value o)          -- State.Monoid    }  element ::-   (C x,+   (C x, IsType o,     LLVM.GetValue o n, LLVM.ValueType o n ~ Struct x,     LLVM.GetElementPtr o (n, ()), LLVM.ElementPtrType o (n, ()) ~ Struct x) =>    (v -> x) -> n -> Element r o v x@@ -128,7 +128,7 @@          insertElement = insertElement m       } -instance App.Applicative (Element r o v) where+instance Applicative (Element r o v) where    pure x =       Element {          loadElement = \ _ptr -> return x,@@ -147,12 +147,12 @@  loadRecord ::    Record r o llvmValue ->-   Value (Ptr o) -> CodeGenFunction r llvmValue+   Value (LLVM.Ptr o) -> CodeGenFunction r llvmValue loadRecord = loadElement  storeRecord ::    Record r o llvmValue ->-   llvmValue -> Value (Ptr o) -> CodeGenFunction r ()+   llvmValue -> Value (LLVM.Ptr o) -> CodeGenFunction r () storeRecord m y ptr = storeElement m ptr y  decomposeRecord ::@@ -204,16 +204,74 @@    compose = composeRecord triple  +quadruple ::+   (C a, C b, C c, C d) =>+   Record r+      (LLVM.Struct (Struct a, (Struct b, (Struct c, (Struct d, ())))))+      (a, b, c, d)+quadruple =+   App.lift4 (,,,)+      (element (\(x,_,_,_) -> x) d0)+      (element (\(_,x,_,_) -> x) d1)+      (element (\(_,_,x,_) -> x) d2)+      (element (\(_,_,_,x) -> x) d3)++instance (C a, C b, C c, C d) => C (a, b, c, d) where+   type Struct (a, b, c, d) =+           LLVM.Struct (Struct a, (Struct b, (Struct c, (Struct d, ()))))+   load = loadRecord quadruple+   store = storeRecord quadruple+   decompose = decomposeRecord quadruple+   compose = composeRecord quadruple+++complex ::+   (C a) =>+   Record r (LLVM.Struct (Struct a, (Struct a, ()))) (Complex a)+complex =+   liftA2 (:+)+      (element Complex.realPart d0)+      (element Complex.imagPart d1)++instance (C a) => C (Complex a) where+   type Struct (Complex a) = LLVM.Struct (Struct a, (Struct a, ()))+   load = loadRecord complex+   store = storeRecord complex+   decompose = decomposeRecord complex+   compose = composeRecord complex+++instance+   (Unary.Natural n, C a,+    TypeNum.Natural (TypeNum.FromUnary n),+    TypeNum.Natural (TypeNum.FromUnary n TypeNum.:*: LLVM.SizeOf (Struct a)),+    LLVM.IsFirstClass (Struct a)) =>+      C (FixedLength.T n a) where+   type Struct (FixedLength.T n a) =+            LLVM.Array (TypeNum.FromUnary n) (Struct a)+   compose xs =+      Fold.foldlM+         (\arr (x,i) -> compose x >>= \xc -> LLVM.insertvalue arr xc i)+         (LLVM.value LLVM.undef) $+      FixedLength.zipWith (,) xs $ iterateTrav (1+) (0::Word)+   decompose arr =+      Trav.mapM (decompose <=< LLVM.extractvalue arr) $+      iterateTrav (1+) (0::Word)++iterateTrav :: (Applicative t, Trav.Traversable t) => (a -> a) -> a -> t a+iterateTrav f a0 = snd $ Trav.mapAccumL (\a () -> (f a, a)) a0 $ pure ()++ maybe ::    (C a) =>-   Record r (LLVM.Struct (Word32, (Struct a, ()))) (Maybe.T a)+   Record r (LLVM.Struct (Bool, (Struct a, ()))) (Maybe.T a) maybe =    liftA2 Maybe.Cons       (element Maybe.isJust d0)       (element Maybe.fromJust d1)  instance (C a) => C (Maybe.T a) where-   type Struct (Maybe.T a) = LLVM.Struct (Word32, (Struct a, ()))+   type Struct (Maybe.T a) = LLVM.Struct (Bool, (Struct a, ()))    load = loadRecord maybe    store = storeRecord maybe    decompose = decomposeRecord maybe@@ -222,7 +280,7 @@  either ::    (C a, C b) =>-   Record r (LLVM.Struct (Word32, (Struct a, (Struct b, ())))) (Either.T a b)+   Record r (LLVM.Struct (Bool, (Struct a, (Struct b, ())))) (Either.T a b) either =    liftA3 Either.Cons       (element Either.isRight d0)@@ -230,7 +288,7 @@       (element Either.fromRight d2)  instance (C a, C b) => C (Either.T a b) where-   type Struct (Either.T a b) = LLVM.Struct (Word32, (Struct a, (Struct b, ())))+   type Struct (Either.T a b) = LLVM.Struct (Bool, (Struct a, (Struct b, ())))    load = loadRecord either    store = storeRecord either    decompose = decomposeRecord either@@ -246,169 +304,91 @@    compose = composeNewtype Scalar.decons  -{--This would not work for Booleans,-since on x86 LLVM's @i1@ type uses one byte in memory,-whereas Storable uses 4 byte and 4 byte alignment.--instance (LLVM.IsFirstClass a) => C (Value a) a where+instance (IsSized a) => C (Value a) where+   type Struct (Value a) = a    load = LLVM.load    store = LLVM.store    decompose = return    compose = return--}  -class (LLVM.IsFirstClass llvmType, IsType (Stored llvmType)) =>-      FirstClass llvmType where-   type Stored llvmType :: *-   fromStorable :: Value (Stored llvmType) -> CodeGenFunction r (Value llvmType)-   toStorable :: Value llvmType -> CodeGenFunction r (Value (Stored llvmType))--instance FirstClass Float  where type Stored Float  = Float  ; fromStorable = return; toStorable = return-instance FirstClass Double where type Stored Double = Double ; fromStorable = return; toStorable = return-instance FirstClass Int8   where type Stored Int8   = Int8   ; fromStorable = return; toStorable = return-instance FirstClass Int16  where type Stored Int16  = Int16  ; fromStorable = return; toStorable = return-instance FirstClass Int32  where type Stored Int32  = Int32  ; fromStorable = return; toStorable = return-instance FirstClass Int64  where type Stored Int64  = Int64  ; fromStorable = return; toStorable = return-instance FirstClass Word8  where type Stored Word8  = Word8  ; fromStorable = return; toStorable = return-instance FirstClass Word16 where type Stored Word16 = Word16 ; fromStorable = return; toStorable = return-instance FirstClass Word32 where type Stored Word32 = Word32 ; fromStorable = return; toStorable = return-instance FirstClass Word64 where type Stored Word64 = Word64 ; fromStorable = return; toStorable = return-instance FirstClass Bool   where-   type Stored Bool = Word32-   fromStorable = A.cmp LLVM.CmpNE (LLVM.value LLVM.zero)-   toStorable = LLVM.zext-instance-   (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsPrimitive (Stored a), FirstClass a) =>-      FirstClass (LLVM.Vector n a) where-   type Stored (LLVM.Vector n a) = LLVM.Vector n (Stored a)-   fromStorable = Vector.map fromStorable-   toStorable = Vector.map toStorable-instance-   (TypeNum.Natural n, LLVM.IsFirstClass (Stored a),-    FirstClass a, IsSized a, IsSized (Stored a)) =>-      FirstClass (LLVM.Array n a) where-   type Stored (LLVM.Array n a) = LLVM.Array n (Stored a)-   fromStorable = Array.map fromStorable-   toStorable = Array.map toStorable--instance (IsType a) => FirstClass (Ptr a) where-   type Stored (Ptr a) = Ptr a-   fromStorable = return; toStorable = return-instance (LLVM.IsFunction a) => FirstClass (FunPtr a) where-   type Stored (FunPtr a) = FunPtr a-   fromStorable = return; toStorable = return-instance FirstClass (StablePtr a) where-   type Stored (StablePtr a) = StablePtr a-   fromStorable = return; toStorable = return-+type family StructStruct s+type instance StructStruct (a,as) = (Struct a, StructStruct as)+type instance StructStruct () = ()  instance-   (LLVM.IsFirstClass (LLVM.Struct s),-    IsType (LLVM.Struct (StoredStruct s)),-    ConvertStruct s TypeNum.D0 s) =>-      FirstClass (LLVM.Struct s) where-   type Stored (LLVM.Struct s) = LLVM.Struct (StoredStruct s)-   fromStorable sm =-      case LP.Proxy of-         sfields -> do-            s <- decomposeField sfields d0 sm-            let _ = asTypeOf (fields s) sfields-            return s-   toStorable s =-      composeField (fields s) d0 s--fields :: Value (LLVM.Struct s) -> LP.Proxy s-fields _ = LP.Proxy---type family StoredStruct s :: *-type instance StoredStruct () = ()-type instance StoredStruct (s,rem) = (Stored s, StoredStruct rem)+   (Struct.Phi s, Struct.Undefined s,+    LLVM.StructFields (StructStruct s),+    ConvertStruct (StructStruct s) TypeNum.D0 s) =>+      C (Struct.T s) where+   type Struct (Struct.T s) = LLVM.Struct (StructStruct s)+   decompose = fmap Struct.Cons . decomposeFields TypeNum.d0+   compose (Struct.Cons s) = composeFields TypeNum.d0 s  class ConvertStruct s i rem where-   decomposeField ::-      LP.Proxy rem -> Proxy i -> Value (LLVM.Struct (StoredStruct s)) ->-      CodeGenFunction r (Value (LLVM.Struct s))-   composeField ::-      LP.Proxy rem -> Proxy i -> Value (LLVM.Struct s) ->-      CodeGenFunction r (Value (LLVM.Struct (StoredStruct s)))+   decomposeFields ::+      Proxy i -> Value (LLVM.Struct s) -> CodeGenFunction r rem+   composeFields ::+      Proxy i -> rem -> CodeGenFunction r (Value (LLVM.Struct s))  instance-   (sm ~ StoredStruct s,-    FirstClass a, am ~ Stored a,-    LLVM.GetValue (LLVM.Struct s) (Proxy i),-    LLVM.GetValue (LLVM.Struct sm) (Proxy i),-    LLVM.ValueType (LLVM.Struct s) (Proxy i) ~ a,-    LLVM.ValueType (LLVM.Struct sm) (Proxy i) ~ am,+   (TypeNum.Natural i, LLVM.GetField s i, LLVM.FieldType s i ~ Struct a, C a,     ConvertStruct s (TypeNum.Succ i) rem) =>       ConvertStruct s i (a,rem) where-   decomposeField flds i sm = do-      s <- decomposeField (fmap snd flds) (decSucc i) sm-      a <- fromStorable =<< LLVM.extractvalue sm i-      LLVM.insertvalue s a i-   composeField flds i s = do-      sm <- composeField (fmap snd flds) (decSucc i) s-      am <- toStorable =<< LLVM.extractvalue s i+   decomposeFields i sm =+      liftA2 (,)+         (decompose =<< LLVM.extractvalue sm i)+         (decomposeFields (decSucc i) sm)+   composeFields i (a,as) = do+      sm <- composeFields (decSucc i) as+      am <- compose a       LLVM.insertvalue sm am i  decSucc :: Proxy n -> Proxy (TypeNum.Succ n) decSucc Proxy = Proxy -instance-   (sm ~ StoredStruct s,-    IsType (LLVM.Struct s),-    IsType (LLVM.Struct sm)) =>-      ConvertStruct s i () where-   decomposeField _ _ _ =-      return (LLVM.value LLVM.undef)-   composeField _ _ _ =-      return (LLVM.value LLVM.undef)+instance (LLVM.StructFields s) => ConvertStruct s i () where+   decomposeFields _ _ = return ()+   composeFields _ _ = return (LLVM.value LLVM.undef)  -instance (FirstClass a, IsSized (Stored a)) => C (Value a) where-   type Struct (Value a) = Stored a-   decompose = fromStorable-   compose = toStorable --instance (MultiValueMemory.C a) => C (MultiValue.T a) where-   type Struct (MultiValue.T a) = MultiValueMemory.Struct a-   load      = MultiValueMemory.load-   store     = MultiValueMemory.store-   decompose = MultiValueMemory.decompose-   compose   = MultiValueMemory.compose---instance (MultiVectorMemory.C n a) => C (MultiVector.T n a) where-   type Struct (MultiVector.T n a) = MultiVectorMemory.Struct n a-   load      = MultiVectorMemory.load-   store     = MultiVectorMemory.store-   decompose = MultiVectorMemory.decompose-   compose   = MultiVectorMemory.compose-+-- redundant IsType and IsSized constraints required for loopy instance+instance+   (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 -{-# DEPRECATED castStorablePtr "use castTuplePtr instead" #-}-castStorablePtr, castTuplePtr ::-   (MakeValueTuple haskellValue, C (ValueTuple haskellValue)) =>-   Ptr haskellValue -> Ptr (Struct (ValueTuple haskellValue))-castStorablePtr = castPtr-castTuplePtr = castPtr+instance+   (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    loadNewtype ::    (C a) =>    (a -> llvmValue) ->-   Value (Ptr (Struct a)) -> CodeGenFunction r llvmValue+   Value (LLVM.Ptr (Struct a)) -> CodeGenFunction r llvmValue loadNewtype wrap ptr =    fmap wrap $ load ptr  storeNewtype ::    (C a) =>    (llvmValue -> a) ->-   llvmValue -> Value (Ptr (Struct a)) -> CodeGenFunction r ()+   llvmValue -> Value (LLVM.Ptr (Struct a)) -> CodeGenFunction r () storeNewtype unwrap y ptr =    store (unwrap y) ptr
− src/LLVM/Extra/MemoryPrivate.hs 
@@ -1,25 +0,0 @@-module LLVM.Extra.MemoryPrivate where--import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, Value, )--import Foreign.Ptr (Ptr, )---decomposeFromLoad ::-   LLVM.IsSized struct =>-   (Value (Ptr struct) -> CodeGenFunction r a) ->-   Value struct -> CodeGenFunction r a-decomposeFromLoad loadStruct struct = do-   ptr <- LLVM.alloca-   LLVM.store struct ptr-   loadStruct ptr--composeFromStore ::-   LLVM.IsSized struct =>-   (a -> Value (Ptr struct) -> CodeGenFunction r ()) ->-   a -> CodeGenFunction r (Value struct)-composeFromStore storeStruct x = do-   ptr <- LLVM.alloca-   storeStruct x ptr-   LLVM.load ptr
src/LLVM/Extra/Multi/Class.hs view
@@ -1,169 +1,5 @@-{-# LANGUAGE TypeFamilies #-}-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.MaybePrivate as Maybe-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C-import LLVM.Extra.Class (undefTuple)--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 undefTuple (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 undefTuple) $-      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,6 +1,5 @@-module LLVM.Extra.Multi.Value (-   module LLVM.Extra.Multi.Value.Private,-   ) 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.Private+import LLVM.Extra.Nice.Value
+ src/LLVM/Extra/Multi/Value/Marshal.hs view
@@ -0,0 +1,5 @@+module LLVM.Extra.Multi.Value.Marshal+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Marshal instead." #-}+   (module LLVM.Extra.Nice.Value.Marshal) where++import LLVM.Extra.Nice.Value.Marshal
− src/LLVM/Extra/Multi/Value/Memory.hs 
@@ -1,257 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-module LLVM.Extra.Multi.Value.Memory where--import qualified LLVM.Extra.Multi.Value as MultiValue-import LLVM.Extra.ArithmeticPrivate as A-import LLVM.Extra.MemoryPrivate (decomposeFromLoad, composeFromStore, )--import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, Value, )--import qualified Type.Data.Num.Decimal as TypeNum--import Foreign.StablePtr (StablePtr, )-import Foreign.Ptr (Ptr, FunPtr, castPtr, )--import Data.Tagged (Tagged)-import Data.Complex (Complex, )-import Data.Word (Word8, Word16, Word32, Word64, )-import Data.Int (Int8, Int16, Int32, Int64, )-import Data.Bool8 (Bool8)--import Control.Applicative (pure, liftA2, liftA3, (<*>), )--import Prelude2010-import Prelude ()--class (MultiValue.C a, LLVM.IsSized (Struct a)) => C a where-   {-# MINIMAL (load|decompose), (store|compose) #-}-   type Struct a :: *-   load :: Value (Ptr (Struct a)) -> CodeGenFunction r (MultiValue.T a)-   load ptr  =  decompose =<< LLVM.load ptr-   store :: MultiValue.T a -> Value (Ptr (Struct a)) -> CodeGenFunction r ()-   store r ptr  =  flip LLVM.store ptr =<< compose r-   decompose :: Value (Struct a) -> CodeGenFunction r (MultiValue.T a)-   decompose = decomposeFromLoad load-   compose :: MultiValue.T a -> CodeGenFunction r (Value (Struct a))-   compose = composeFromStore store--instance C Bool8 where-   type Struct Bool8 = Word8-   decompose = fmap MultiValue.Cons . A.cmp LLVM.CmpNE (LLVM.valueOf 0)-   compose (MultiValue.Cons b) = LLVM.select b (LLVM.valueOf 1) (LLVM.valueOf 0)--instance C Float where-   type Struct Float = Float-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance C Double where-   type Struct Double = Double-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance C Word8 where-   type Struct Word8 = Word8-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance C Word16 where-   type Struct Word16 = Word16-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance C Word32 where-   type Struct Word32 = Word32-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance C Word64 where-   type Struct Word64 = Word64-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance C Int8 where-   type Struct Int8 = Int8-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance C Int16 where-   type Struct Int16 = Int16-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance C Int32 where-   type Struct Int32 = Int32-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance C Int64 where-   type Struct Int64 = Int64-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance (LLVM.IsType a) => C (Ptr a) where-   type Struct (Ptr a) = Ptr a-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance (LLVM.IsFunction a) => C (FunPtr a) where-   type Struct (FunPtr a) = FunPtr a-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive--instance C (StablePtr a) where-   type Struct (StablePtr a) = StablePtr a-   load = loadPrimitive-   store = storePrimitive-   decompose = decomposePrimitive-   compose = composePrimitive---loadPrimitive ::-   (MultiValue.Repr Value a ~ Value al) =>-   Value (Ptr al) -> CodeGenFunction r (MultiValue.T a)-loadPrimitive = fmap MultiValue.Cons . LLVM.load--storePrimitive ::-   (MultiValue.Repr Value a ~ Value al) =>-   MultiValue.T a -> Value (Ptr al) -> CodeGenFunction r ()-storePrimitive (MultiValue.Cons a) = LLVM.store a--decomposePrimitive ::-   (MultiValue.Repr Value a ~ Value al) =>-   Value al -> CodeGenFunction r (MultiValue.T a)-decomposePrimitive = return . MultiValue.Cons--composePrimitive ::-   (MultiValue.Repr Value a ~ Value al) =>-   MultiValue.T a -> CodeGenFunction r (Value al)-composePrimitive (MultiValue.Cons a) = return a---instance C () where-   type Struct () = LLVM.Struct ()-   load = loadUnit-   store = storeUnit-   decompose = decomposeUnit-   compose = composeUnit--loadUnit ::-   (MultiValue.Repr Value a ~ ()) =>-   Value (Ptr (LLVM.Struct ())) -> CodeGenFunction r (MultiValue.T a)-loadUnit _ = return $ MultiValue.Cons ()--storeUnit ::-   MultiValue.T a -> Value (Ptr (LLVM.Struct ())) -> CodeGenFunction r ()-storeUnit _ _ = return ()--decomposeUnit ::-   (MultiValue.Repr Value a ~ ()) =>-   Value (LLVM.Struct ()) -> CodeGenFunction r (MultiValue.T a)-decomposeUnit _ = return $ MultiValue.Cons ()--composeUnit ::-   MultiValue.T a -> CodeGenFunction r (Value (LLVM.Struct ()))-composeUnit _ = return (LLVM.value $ LLVM.constStruct ())---instance (C a) => C (Tagged tag a) where-   type Struct (Tagged tag a) = Struct a-   decompose = fmap MultiValue.tag . decompose-   compose = compose . MultiValue.untag--instance (C a) => C (Complex a) where-   type Struct (Complex a) = LLVM.Struct (Struct a, (Struct a, ()))-   decompose c =-      liftA2 MultiValue.consComplex-         (decompose =<< LLVM.extractvalue c TypeNum.d0)-         (decompose =<< LLVM.extractvalue c TypeNum.d1)-   compose c =-      case MultiValue.deconsComplex c of-         (r,i) -> do-            sr <- compose r-            si <- compose i-            rr <- LLVM.insertvalue (LLVM.value LLVM.undef) sr TypeNum.d0-            LLVM.insertvalue rr si TypeNum.d1---instance (C a, C b) => C (a,b) where-   type Struct (a,b) = LLVM.Struct (Struct a, (Struct b, ()))-   decompose ab =-      liftA2 MultiValue.zip-         (decompose =<< LLVM.extractvalue ab TypeNum.d0)-         (decompose =<< LLVM.extractvalue ab TypeNum.d1)-   compose ab =-      case MultiValue.unzip ab of-         (a,b) -> do-            sa <- compose a-            sb <- compose b-            ra <- LLVM.insertvalue (LLVM.value LLVM.undef) sa TypeNum.d0-            LLVM.insertvalue ra sb TypeNum.d1--instance (C a, C b, C c) => C (a,b,c) where-   type Struct (a,b,c) = LLVM.Struct (Struct a, (Struct b, (Struct c, ())))-   decompose abc =-      liftA3 MultiValue.zip3-         (decompose =<< LLVM.extractvalue abc TypeNum.d0)-         (decompose =<< LLVM.extractvalue abc TypeNum.d1)-         (decompose =<< LLVM.extractvalue abc TypeNum.d2)-   compose abc =-      case MultiValue.unzip3 abc of-         (a,b,c) -> do-            sa <- compose a-            sb <- compose b-            sc <- compose c-            ra <- LLVM.insertvalue (LLVM.value LLVM.undef) sa TypeNum.d0-            rb <- LLVM.insertvalue ra sb TypeNum.d1-            LLVM.insertvalue rb sc TypeNum.d2--instance (C a, C b, C c, C d) => C (a,b,c,d) where-   type Struct (a,b,c,d) = LLVM.Struct (Struct a, (Struct b, (Struct c, (Struct d, ()))))-   decompose abcd =-      pure MultiValue.zip4-         <*> (decompose =<< LLVM.extractvalue abcd TypeNum.d0)-         <*> (decompose =<< LLVM.extractvalue abcd TypeNum.d1)-         <*> (decompose =<< LLVM.extractvalue abcd TypeNum.d2)-         <*> (decompose =<< LLVM.extractvalue abcd TypeNum.d3)-   compose abcd =-      case MultiValue.unzip4 abcd of-         (a,b,c,d) -> do-            sa <- compose a-            sb <- compose b-            sc <- compose c-            sd <- compose d-            ra <- LLVM.insertvalue (LLVM.value LLVM.undef) sa TypeNum.d0-            rb <- LLVM.insertvalue ra sb TypeNum.d1-            rc <- LLVM.insertvalue rb sc TypeNum.d2-            LLVM.insertvalue rc sd TypeNum.d3---castStructPtr :: Ptr a -> Ptr (Struct a)-castStructPtr = castPtr
− src/LLVM/Extra/Multi/Value/Private.hs 
@@ -1,1311 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# 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.Class as Class--import qualified LLVM.Core as LLVM-import qualified LLVM.Util.Loop as Loop-import LLVM.Util.Loop (Phi, )-import LLVM.Core (WordN, IntN, )--import qualified Type.Data.Num.Decimal.Number as Dec--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 Tuple-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.Tuple.HT (uncurry3, )-import Data.Maybe (Maybe(Nothing,Just), )-import Data.Bool (Bool(False,True), )-import Data.Word (Word8, Word16, Word32, Word64, )-import Data.Int (Int8, Int16, Int32, Int64, )-import Data.Bool8 (Bool8)--import qualified Prelude as P-import Prelude (Float, Double, Integer, Rational, )---newtype T a = Cons (Repr LLVM.Value a)---class C a where-   type Repr (f :: * -> *) a :: *-   cons :: a -> T a-   undef :: T a-   zero :: T a-   phis :: LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-   addPhis :: LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()--instance C Bool where-   type Repr f Bool = f Bool-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Float where-   type Repr f Float = f Float-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Double where-   type Repr f Double = f Double-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Word8 where-   type Repr f Word8 = f Word8-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Word16 where-   type Repr f Word16 = f Word16-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Word32 where-   type Repr f Word32 = f Word32-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Word64 where-   type Repr f Word64 = f Word64-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance (Dec.Positive n) => C (LLVM.WordN n) where-   type Repr f (LLVM.WordN n) = f (LLVM.WordN n)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Int8 where-   type Repr f Int8 = f Int8-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Int16 where-   type Repr f Int16 = f Int16-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Int32 where-   type Repr f Int32 = f Int32-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Int64 where-   type Repr f Int64 = f Int64-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance (Dec.Positive n) => C (LLVM.IntN n) where-   type Repr f (LLVM.IntN n) = f (LLVM.IntN n)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance (LLVM.IsType a) => C (Ptr a) where-   -- Do we also have to convert the pointer target type?-   type Repr f (Ptr a) = f (Ptr a)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance (LLVM.IsFunction a) => C (FunPtr a) where-   type Repr f (FunPtr a) = f (FunPtr a)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C (StablePtr a) where-   type Repr f (StablePtr a) = f (StablePtr a)-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive---consPrimitive ::-   (LLVM.IsConst al, LLVM.Value al ~ Repr LLVM.Value a) =>-   al -> T a-consPrimitive = Cons . LLVM.valueOf--undefPrimitive, zeroPrimitive ::-   (LLVM.IsType al, LLVM.Value al ~ Repr LLVM.Value a) =>-   T a-undefPrimitive = Cons $ LLVM.value LLVM.undef-zeroPrimitive = Cons $ LLVM.value LLVM.zero--phisPrimitive ::-   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr LLVM.Value a) =>-   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-phisPrimitive bb (Cons a) = fmap Cons $ Loop.phis bb a--addPhisPrimitive ::-   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr LLVM.Value a) =>-   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()-addPhisPrimitive bb (Cons a) (Cons b) = Loop.addPhis bb a b---instance C () where-   type Repr f () = ()-   cons = consUnit-   undef = undefUnit-   zero = zeroUnit-   phis = phisUnit-   addPhis = addPhisUnit--consUnit :: (Repr LLVM.Value a ~ ()) => a -> T a-consUnit _ = Cons ()--undefUnit :: (Repr LLVM.Value a ~ ()) => T a-undefUnit = Cons ()--zeroUnit :: (Repr LLVM.Value a ~ ()) => T a-zeroUnit = Cons ()--phisUnit ::-   (Repr LLVM.Value a ~ ()) =>-   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-phisUnit _bb (Cons ()) = return $ Cons ()--addPhisUnit ::-   (Repr LLVM.Value a ~ ()) =>-   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()-addPhisUnit _bb (Cons ()) (Cons ()) = return ()---instance C Bool8 where-   type Repr f Bool8 = f Bool-   cons = consPrimitive . Bool8.toBool-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--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 f (Enum.T w e) = f w-   cons = consPrimitive . P.fromIntegral . P.fromEnum . Enum.toPlain-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--toEnum ::-   (Repr LLVM.Value w ~ LLVM.Value w) =>-   T w -> T (Enum.T w e)-toEnum (Cons w) = Cons w--fromEnum ::-   (Repr LLVM.Value 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 f (EnumBitSet.T w i) = f w-   cons = consPrimitive . EnumBitSet.decons-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive---instance (C a) => C (Maybe a) where-   type Repr f (Maybe a) = (f Bool, Repr f a)-   cons Nothing = nothing-   cons (Just a) = just $ cons a-   undef = toMaybe undef undef-   zero = toMaybe (cons False) zero-   phis bb ma =-      case splitMaybe ma of-         (b,a) -> Monad.lift2 toMaybe (phis bb b) (phis bb a)-   addPhis bb x y =-      case (splitMaybe x, splitMaybe y) of-         ((xb,xa), (yb,ya)) ->-            addPhis bb xb yb >>-            addPhis 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 f (a, b) = (Repr f a, Repr f b)-   cons (a,b) = zip (cons a) (cons b)-   undef = zip undef undef-   zero = zip zero zero-   phis bb a =-      case unzip a of-         (a0,a1) ->-            Monad.lift2 zip (phis bb a0) (phis bb a1)-   addPhis bb a b =-      case (unzip a, unzip b) of-         ((a0,a1), (b0,b1)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1--instance (C a, C b, C c) => C (a,b,c) where-   type Repr f (a, b, c) = (Repr f a, Repr f b, Repr f c)-   cons (a,b,c) = zip3 (cons a) (cons b) (cons c)-   undef = zip3 undef undef undef-   zero = zip3 zero zero zero-   phis bb a =-      case unzip3 a of-         (a0,a1,a2) ->-            Monad.lift3 zip3 (phis bb a0) (phis bb a1) (phis bb a2)-   addPhis bb a b =-      case (unzip3 a, unzip3 b) of-         ((a0,a1,a2), (b0,b1,b2)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1 >>-            addPhis bb a2 b2--instance (C a, C b, C c, C d) => C (a,b,c,d) where-   type Repr f (a, b, c, d) = (Repr f a, Repr f b, Repr f c, Repr f 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-   phis bb a =-      case unzip4 a of-         (a0,a1,a2,a3) ->-            Monad.lift4 zip4 (phis bb a0) (phis bb a1) (phis bb a2) (phis bb a3)-   addPhis bb a b =-      case (unzip4 a, unzip4 b) of-         ((a0,a1,a2,a3), (b0,b1,b2,b3)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1 >>-            addPhis bb a2 b2 >>-            addPhis 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 = Tuple.uncurry f . unzip---mapFst :: (T a0 -> T a1) -> T (a0,b) -> T (a1,b)-mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip--mapSnd :: (T b0 -> T b1) -> T (a,b0) -> T (a,b1)-mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip--mapFstF :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b) -> f (T (a1,b))-mapFstF f = fmap (Tuple.uncurry zip) . FuncHT.mapFst f . unzip--mapSndF :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0) -> f (T (a,b1))-mapSndF f = fmap (Tuple.uncurry zip) . FuncHT.mapSnd f . unzip--swap :: T (a,b) -> T (b,a)-swap = Tuple.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---mapFst3 :: (T a0 -> T a1) -> T (a0,b,c) -> T (a1,b,c)-mapFst3 f = uncurry3 zip3 . TupleHT.mapFst3 f . unzip3--mapSnd3 :: (T b0 -> T b1) -> T (a,b0,c) -> T (a,b1,c)-mapSnd3 f = uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3--mapThd3 :: (T c0 -> T c1) -> T (a,b,c0) -> T (a,b,c1)-mapThd3 f = 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 (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 (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 (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 a => C (Tagged tag a) where-   type Repr f (Tagged tag a) = Repr f a-   cons = tag . cons . unTagged-   undef = tag undef-   zero = tag zero-   phis bb = fmap tag . phis bb . untag-   addPhis bb a b = addPhis bb (untag a) (untag b)--tag :: T a -> T (Tagged tag a)-tag (Cons a) = Cons a--untag :: T (Tagged tag a) -> T a-untag (Cons a) = Cons a--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 f (Complex a) = Complex (Repr f a)-   cons (a:+b) = consComplex (cons a) (cons b)-   undef = consComplex undef undef-   zero = consComplex zero zero-   phis bb a =-      case deconsComplex a of-         (a0,a1) ->-            Monad.lift2 consComplex (phis bb a0) (phis bb a1)-   addPhis bb a b =-      case (deconsComplex a, deconsComplex b) of-         ((a0,a1), (b0,b1)) ->-            addPhis bb a0 b0 >>-            addPhis 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 = Tuple.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 = 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 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) =-      Tuple.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 LLVM.Value a -> Repr LLVM.Value b) -> T a -> T b-lift1 f (Cons a) = Cons $ f a--liftM0 ::-   (Monad m) =>-   m (Repr LLVM.Value a) ->-   m (T a)-liftM0 f = Monad.lift Cons f--liftM ::-   (Monad m) =>-   (Repr LLVM.Value a -> m (Repr LLVM.Value b)) ->-   T a -> m (T b)-liftM f (Cons a) = Monad.lift Cons $ f a--liftM2 ::-   (Monad m) =>-   (Repr LLVM.Value a -> Repr LLVM.Value b -> m (Repr LLVM.Value c)) ->-   T a -> T b -> m (T c)-liftM2 f (Cons a) (Cons b) = Monad.lift Cons $ f a b--liftM3 ::-   (Monad m) =>-   (Repr LLVM.Value a -> Repr LLVM.Value b -> Repr LLVM.Value c ->-    m (Repr LLVM.Value 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) => Class.Zero (T a) where-   zeroTuple = zero--instance (C a) => Class.Undefined (T a) where-   undefTuple = undef--instance (C a) => Phi (T a) where-   phis = phis-   addPhis = addPhis---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 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 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 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 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 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 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 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 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 LLVM.Value i ~ LLVM.Value ir,-    LLVM.IsInteger ir, SoV.IntegerConstant ir,-    LLVM.CmpRet ir, LLVM.IsPrimitive ir) =>-      NativeInteger i ir where--instance NativeInteger Word8  Word8 where-instance NativeInteger Word16 Word16 where-instance NativeInteger Word32 Word32 where-instance NativeInteger Word64 Word64 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 LLVM.Value 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 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 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 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 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 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 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 Word32 where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem--instance Integral Word64 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
@@ -0,0 +1,5 @@+module LLVM.Extra.Multi.Value.Storable+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Storable instead." #-}+   (module LLVM.Extra.Nice.Value.Storable) where++import LLVM.Extra.Nice.Value.Storable
src/LLVM/Extra/Multi/Value/Vector.hs view
@@ -1,166 +1,5 @@-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,-   dissect,-   select,-   cmp,-   take, takeRev,-   ) 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.Core as LLVM--import qualified Type.Data.Num.Decimal as TypeNum--import qualified Data.Tuple.HT as TupleHT-import qualified Data.Tuple as Tuple-import Data.Word (Word32)--import Prelude (Bool, fmap, (.))---cons ::-   (TypeNum.Positive n, MultiVector.C a) =>-   LLVM.Vector n a -> MultiValue.T (LLVM.Vector n a)-cons = Inst.toMultiValue . MultiVector.cons--fst :: MultiValue.T (LLVM.Vector n (a,b)) -> MultiValue.T (LLVM.Vector n a)-fst = MultiValue.lift1 Tuple.fst--snd :: MultiValue.T (LLVM.Vector n (a,b)) -> MultiValue.T (LLVM.Vector n b)-snd = MultiValue.lift1 Tuple.snd--swap :: MultiValue.T (LLVM.Vector n (a,b)) -> MultiValue.T (LLVM.Vector n (b,a))-swap = MultiValue.lift1 TupleHT.swap--mapFst ::-   (MultiValue.T (LLVM.Vector n a0) -> MultiValue.T (LLVM.Vector n a1)) ->-   MultiValue.T (LLVM.Vector n (a0,b)) -> MultiValue.T (LLVM.Vector n (a1,b))-mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip--mapSnd ::-   (MultiValue.T (LLVM.Vector n b0) -> MultiValue.T (LLVM.Vector n b1)) ->-   MultiValue.T (LLVM.Vector n (a,b0)) -> MultiValue.T (LLVM.Vector n (a,b1))-mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip---fst3 :: MultiValue.T (LLVM.Vector n (a,b,c)) -> MultiValue.T (LLVM.Vector n a)-fst3 = MultiValue.lift1 TupleHT.fst3--snd3 :: MultiValue.T (LLVM.Vector n (a,b,c)) -> MultiValue.T (LLVM.Vector n b)-snd3 = MultiValue.lift1 TupleHT.snd3--thd3 :: MultiValue.T (LLVM.Vector n (a,b,c)) -> MultiValue.T (LLVM.Vector n c)-thd3 = MultiValue.lift1 TupleHT.thd3--mapFst3 ::-   (MultiValue.T (LLVM.Vector n a0) -> MultiValue.T (LLVM.Vector n a1)) ->-   MultiValue.T (LLVM.Vector n (a0,b,c)) ->-   MultiValue.T (LLVM.Vector n (a1,b,c))-mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3--mapSnd3 ::-   (MultiValue.T (LLVM.Vector n b0) -> MultiValue.T (LLVM.Vector n b1)) ->-   MultiValue.T (LLVM.Vector n (a,b0,c)) ->-   MultiValue.T (LLVM.Vector n (a,b1,c))-mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3--mapThd3 ::-   (MultiValue.T (LLVM.Vector n c0) -> MultiValue.T (LLVM.Vector n c1)) ->-   MultiValue.T (LLVM.Vector n (a,b,c0)) ->-   MultiValue.T (LLVM.Vector n (a,b,c1))-mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3---zip ::-   MultiValue.T (LLVM.Vector n a) ->-   MultiValue.T (LLVM.Vector n b) ->-   MultiValue.T (LLVM.Vector n (a,b))-zip (MultiValue.Cons a) (MultiValue.Cons b) = MultiValue.Cons (a,b)--zip3 ::-   MultiValue.T (LLVM.Vector n a) ->-   MultiValue.T (LLVM.Vector n b) ->-   MultiValue.T (LLVM.Vector n c) ->-   MultiValue.T (LLVM.Vector n (a,b,c))-zip3 (MultiValue.Cons a) (MultiValue.Cons b) (MultiValue.Cons c) =-   MultiValue.Cons (a,b,c)--unzip ::-   MultiValue.T (LLVM.Vector n (a,b)) ->-   (MultiValue.T (LLVM.Vector n a),-    MultiValue.T (LLVM.Vector n b))-unzip (MultiValue.Cons (a,b)) = (MultiValue.Cons a, MultiValue.Cons b)--unzip3 ::-   MultiValue.T (LLVM.Vector n (a,b,c)) ->-   (MultiValue.T (LLVM.Vector n a),-    MultiValue.T (LLVM.Vector n b),-    MultiValue.T (LLVM.Vector 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 -> MultiValue.T (LLVM.Vector 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 ->-   MultiValue.T (LLVM.Vector n a) ->-   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n a))-insert k a = Inst.liftMultiValueM (MultiVector.insert k a)---replicate ::-   (TypeNum.Positive n, MultiVector.C a) =>-   MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n a))-replicate = fmap Inst.toMultiValue . MultiVector.replicate--take ::-   (TypeNum.Positive n, TypeNum.Positive m, MultiVector.C a) =>-   MultiValue.T (LLVM.Vector n a) ->-   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector m a))-take = Inst.liftMultiValueM MultiVector.take--takeRev ::-   (TypeNum.Positive n, TypeNum.Positive m, MultiVector.C a) =>-   MultiValue.T (LLVM.Vector n a) ->-   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector m a))-takeRev = Inst.liftMultiValueM MultiVector.takeRev---dissect ::-   (TypeNum.Positive n, MultiVector.C a) =>-   MultiValue.T (LLVM.Vector n a) -> LLVM.CodeGenFunction r [MultiValue.T a]-dissect = MultiVector.dissect . Inst.fromMultiValue--select ::-   (TypeNum.Positive n, MultiVector.Select a) =>-   MultiValue.T (LLVM.Vector n Bool) ->-   MultiValue.T (LLVM.Vector n a) -> MultiValue.T (LLVM.Vector n a) ->-   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n a))-select = Inst.liftMultiValueM3 MultiVector.select+module LLVM.Extra.Multi.Value.Vector+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Vector instead." #-}+   (module LLVM.Extra.Nice.Value.Vector) where -cmp ::-   (TypeNum.Positive n, MultiVector.Comparison a) =>-   LLVM.CmpPredicate ->-   MultiValue.T (LLVM.Vector n a) -> MultiValue.T (LLVM.Vector n a) ->-   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n Bool))-cmp = Inst.liftMultiValueM2 . MultiVector.cmp+import LLVM.Extra.Nice.Value.Vector
src/LLVM/Extra/Multi/Vector.hs view
@@ -1,1066 +1,5 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-module LLVM.Extra.Multi.Vector (-   T(Cons), consPrim, deconsPrim,-   C(..),-   Value,-   map,-   zip, zip3, unzip, unzip3,-   replicate,-   iterate,-   take,-   takeRev,--   lift1,--   modify,-   assemble,-   dissect,-   dissectList,--   reverse,-   rotateUp,-   rotateDown,-   shiftUp,-   shiftDown,-   shiftUpMultiZero,-   shiftDownMultiZero,-   shiftUpMultiUndef,-   shiftDownMultiUndef,--   undefPrimitive,-   shufflePrimitive,-   extractPrimitive,-   insertPrimitive,--   shuffleMatchTraversable,-   insertTraversable,-   extractTraversable,--   IntegerConstant(..),-   RationalConstant(..),-   Additive(..),-   PseudoRing(..),-   Field(..),-   PseudoModule(..),-   Real(..),-   Fraction(..),-   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.Class as Class-import LLVM.Extra.Multi.Value.Private (Repr, )--import qualified LLVM.Util.Loop as Loop-import qualified LLVM.Core as LLVM-import LLVM.Util.Loop (Phi, )-import LLVM.Core (CodeGenFunction, IsPrimitive, valueOf, value, )--import qualified Type.Data.Num.Decimal as TypeNum--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.Functor.Compose (Compose(Compose), )-import Data.Traversable (mapM, sequence, )-import Data.Functor ((<$>), )-import Data.NonEmpty ((!:), )-import Data.Function (flip, (.), ($), )-import Data.Tuple.HT (fst3, snd3, thd3, )-import Data.Tuple (fst, snd, )-import Data.Maybe (maybe, )-import Data.Ord ((<), )-import Data.Word (Word8, Word16, Word32, Word64, )-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 Control.Monad.HT ((<=<), )-import Control.Monad (Monad, foldM, fmap, return, (>>), (=<<), )-import Control.Applicative (liftA2, )--import Prelude-         (Float, Double, Integer, Int, Rational,-          fromIntegral, asTypeOf, (-), (+), error, )---newtype T n a = Cons (Repr (Value n) a)--type Value n = Compose LLVM.Value (LLVM.Vector n)---consPrim ::-   (Repr (Value n) a ~ Value n a) =>-   LLVM.Value (LLVM.Vector n a) -> T n a-consPrim = Cons . Compose--deconsPrim ::-   (Repr (Value n) a ~ Value n a) =>-   T n a -> LLVM.Value (LLVM.Vector n a)-deconsPrim (Cons (Compose a)) = a---instance (TypeNum.Positive n, C a) => Class.Undefined (T n a) where-   undefTuple = undef--instance (TypeNum.Positive n, C a) => Class.Zero (T n a) where-   zeroTuple = zero--instance (TypeNum.Positive n, C a) => Phi (T n a) where-   phis = phis-   addPhis = addPhis---size :: TypeNum.Positive n => T n a -> Int-size =-   let sz :: TypeNum.Positive n => TypeNum.Singleton n -> T n a -> Int-       sz n _ = TypeNum.integralFromSingleton n-   in  sz TypeNum.singleton---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-   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-   phis ::-      (TypeNum.Positive n) =>-      LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)-   addPhis ::-      (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-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Bool8 where-   cons = consPrimitive . fmap Bool8.toBool-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Float where-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Double where-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Int8 where-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Int16 where-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Int32 where-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Int64 where-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Word8 where-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Word16 where-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Word32 where-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--instance C Word64 where-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive-   shuffle = shufflePrimitive-   extract = extractPrimitive-   insert = insertPrimitive--consPrimitive ::-   (TypeNum.Positive n, LLVM.IsConst al, IsPrimitive al,-    Repr (Value n) a ~ Value n al) =>-   LLVM.Vector n al -> T n a-consPrimitive = Cons . Compose . LLVM.valueOf--undefPrimitive ::-   (TypeNum.Positive n, IsPrimitive al,-    Repr (Value n) a ~ Value n al) =>-   T n a-undefPrimitive = Cons $ Compose $ LLVM.value LLVM.undef--zeroPrimitive ::-   (TypeNum.Positive n, IsPrimitive al,-    Repr (Value n) a ~ Value n al) =>-   T n a-zeroPrimitive = Cons $ Compose $ LLVM.value LLVM.zero--phisPrimitive ::-   (TypeNum.Positive n, IsPrimitive al, Repr (Value n) a ~ Value n al) =>-   LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)-phisPrimitive bb (Cons (Compose a)) = fmap (Cons . Compose) $ Loop.phis bb a--addPhisPrimitive ::-   (TypeNum.Positive n, IsPrimitive al, Repr (Value n) a ~ Value n al) =>-   LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r ()-addPhisPrimitive bb (Cons (Compose a)) (Cons (Compose b)) = Loop.addPhis bb a b---shufflePrimitive ::-   (TypeNum.Positive n, TypeNum.Positive m, IsPrimitive al,-    Repr LLVM.Value a ~ LLVM.Value al,-    Repr (Value n) a ~ Value n al,-    Repr (Value 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 (Compose u)) (Cons (Compose v)) =-   fmap (Cons . Compose) $ LLVM.shufflevector u v k--extractPrimitive ::-   (TypeNum.Positive n, IsPrimitive al,-    Repr LLVM.Value a ~ LLVM.Value al,-    Repr (Value n) a ~ Value n al) =>-   LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)-extractPrimitive k (Cons (Compose v)) =-   fmap MultiValue.Cons $ LLVM.extractelement v k--insertPrimitive ::-   (TypeNum.Positive n, IsPrimitive al,--- this constraint is accepted, but does not help---    Repr f a ~ f a,-    Repr LLVM.Value a ~ LLVM.Value al,-    Repr (Value 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 (Compose v)) =-   fmap (Cons . Compose) $ LLVM.insertelement v a k---instance (C a, C b) => C (a,b) where-   cons v = zip (cons (fst <$> v)) (cons (snd <$> v))-   undef = zip undef undef-   zero = zip zero zero--   phis bb a =-      case unzip a of-         (a0,a1) ->-            Monad.lift2 zip (phis bb a0) (phis bb a1)-   addPhis bb a b =-      case (unzip a, unzip b) of-         ((a0,a1), (b0,b1)) ->-            addPhis bb a0 b0 >>-            addPhis 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-   cons v = zip3 (cons (fst3 <$> v)) (cons (snd3 <$> v)) (cons (thd3 <$> v))-   undef = zip3 undef undef undef-   zero = zip3 zero zero zero--   phis bb a =-      case unzip3 a of-         (a0,a1,a2) ->-            Monad.lift3 zip3 (phis bb a0) (phis bb a1) (phis bb a2)-   addPhis bb a b =-      case (unzip3 a, unzip3 b) of-         ((a0,a1,a2), (b0,b1,b2)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1 >>-            addPhis 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)---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 Word8  where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Word16 where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Word32 where fromInteger' = fromIntegerPrimitive-instance IntegerConstant Word64 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 (Value n) a ~ Value n a) =>-   Integer -> T n a-fromIntegerPrimitive = Cons . Compose . 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 (Value n) a ~ Value n a) =>-   Rational -> T n a-fromRationalPrimitive = Cons . Compose . 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 =-   foldM (\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..])---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 Class.undefTuple--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 =-   foldM-      (\(x,v) k -> Monad.lift2 (,) (f x) (insert (valueOf k) x v))-      (x0,v0)-      (List.take (size v0) [0..])----- * 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 $-       (fromIntegral (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+) (fromIntegral (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 (,)-      (extract (LLVM.valueOf (fromIntegral (size x) - 1)) 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 (fromIntegral (size x) - 1)) x0 y)--shiftUpMultiIndices ::-   (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32)-shiftUpMultiIndices n sizev =-   constCyclicVector $ fmap 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 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---type PrimValue n a = LLVM.Value (LLVM.Vector n a)---lift1 :: (Repr (Value n) a -> Repr (Value n) b) -> T n a -> T n b-lift1 f (Cons a) = Cons $ f a--_liftM0 ::-   (Monad m) =>-   m (Repr (Value n) a) ->-   m (T n a)-_liftM0 f = Monad.lift Cons f--liftM0 ::-   (Monad m,-    Repr (Value n) a ~ Value n a) =>-   m (PrimValue n a) ->-   m (T n a)-liftM0 f = Monad.lift consPrim f--liftM ::-   (Monad m,-    Repr (Value n) a ~ Value n a,-    Repr (Value n) b ~ Value n b) =>-   (PrimValue n a -> m (PrimValue n b)) ->-   T n a -> m (T n b)-liftM f a = Monad.lift consPrim $ f (deconsPrim a)--liftM2 ::-   (Monad m,-    Repr (Value n) a ~ Value n a,-    Repr (Value n) b ~ Value n b,-    Repr (Value n) c ~ Value n c) =>-   (PrimValue n a -> PrimValue n b -> m (PrimValue n c)) ->-   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 (Value n) a ~ Value n a,-    Repr (Value n) b ~ Value n b,-    Repr (Value n) c ~ Value n c,-    Repr (Value n) d ~ Value n d) =>-   (PrimValue n a -> PrimValue n b -> PrimValue n c -> m (PrimValue n d)) ->-   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 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 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---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-   scale ::-      (TypeNum.Positive n) =>-      T n (MultiValue.Scalar v) -> T n v -> LLVM.CodeGenFunction r (T n v)--instance PseudoModule Float where-   scale = liftM2 A.mul--instance PseudoModule Double where-   scale = liftM2 A.mul--instance (TypeNum.Positive n, PseudoModule a) => A.PseudoModule (T n a) where-   scale = scale---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 (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 (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 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 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, C 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 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 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 :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)-   or :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)-   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 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 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,89 +1,36 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# 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.Compose (Compose, )-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 f (LLVM.Vector n a) = Repr (Compose f (LLVM.Vector n)) a-   cons = toMultiValue . Vector.cons-   undef = toMultiValue Vector.undef-   zero = toMultiValue Vector.zero-   phis = liftMultiValueM . Vector.phis-   addPhis bb x y = Vector.addPhis 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.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/Multi/Vector/Memory.hs 
@@ -1,172 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module LLVM.Extra.Multi.Vector.Memory where--import qualified LLVM.Extra.Multi.Vector as MultiVector-import qualified LLVM.Extra.Multi.Vector.Instance as Inst-import qualified LLVM.Extra.Multi.Value.Memory as MultiMem-import LLVM.Extra.MemoryPrivate (decomposeFromLoad, composeFromStore, )--import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, Value, )--import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal ((:*:), )--import Foreign.Ptr (Ptr, )--import Control.Applicative (liftA2, liftA3, )--import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int8, Int16, Int32, Int64)---class-   (TypeNum.Positive n, MultiVector.C a, LLVM.IsSized (Struct n a)) =>-      C n a where-   {-# MINIMAL (load|decompose), (store|compose) #-}-   type Struct n a :: *-   load :: Value (Ptr (Struct n a)) -> CodeGenFunction r (MultiVector.T n a)-   load ptr  =  decompose =<< LLVM.load ptr-   store :: MultiVector.T n a -> Value (Ptr (Struct n a)) -> CodeGenFunction r ()-   store r ptr  =  flip LLVM.store ptr =<< compose r-   decompose :: Value (Struct n a) -> CodeGenFunction r (MultiVector.T n a)-   decompose = decomposeFromLoad load-   compose :: MultiVector.T n a -> CodeGenFunction r (Value (Struct n a))-   compose = composeFromStore store--instance-   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D8)) =>-      C n Word8 where-   type Struct n Word8 = LLVM.Vector n Word8-   load = fmap MultiVector.consPrim . LLVM.load-   store = LLVM.store . MultiVector.deconsPrim-   decompose = return . MultiVector.consPrim-   compose = return . MultiVector.deconsPrim--instance-   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D16)) =>-      C n Word16 where-   type Struct n Word16 = LLVM.Vector n Word16-   load = fmap MultiVector.consPrim . LLVM.load-   store = LLVM.store . MultiVector.deconsPrim-   decompose = return . MultiVector.consPrim-   compose = return . MultiVector.deconsPrim--instance-   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>-      C n Word32 where-   type Struct n Word32 = LLVM.Vector n Word32-   load = fmap MultiVector.consPrim . LLVM.load-   store = LLVM.store . MultiVector.deconsPrim-   decompose = return . MultiVector.consPrim-   compose = return . MultiVector.deconsPrim--instance-   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D64)) =>-      C n Word64 where-   type Struct n Word64 = LLVM.Vector n Word64-   load = fmap MultiVector.consPrim . LLVM.load-   store = LLVM.store . MultiVector.deconsPrim-   decompose = return . MultiVector.consPrim-   compose = return . MultiVector.deconsPrim--instance-   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D8)) =>-      C n Int8 where-   type Struct n Int8 = LLVM.Vector n Int8-   load = fmap MultiVector.consPrim . LLVM.load-   store = LLVM.store . MultiVector.deconsPrim-   decompose = return . MultiVector.consPrim-   compose = return . MultiVector.deconsPrim--instance-   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D16)) =>-      C n Int16 where-   type Struct n Int16 = LLVM.Vector n Int16-   load = fmap MultiVector.consPrim . LLVM.load-   store = LLVM.store . MultiVector.deconsPrim-   decompose = return . MultiVector.consPrim-   compose = return . MultiVector.deconsPrim--instance-   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>-      C n Int32 where-   type Struct n Int32 = LLVM.Vector n Int32-   load = fmap MultiVector.consPrim . LLVM.load-   store = LLVM.store . MultiVector.deconsPrim-   decompose = return . MultiVector.consPrim-   compose = return . MultiVector.deconsPrim--instance-   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D64)) =>-      C n Int64 where-   type Struct n Int64 = LLVM.Vector n Int64-   load = fmap MultiVector.consPrim . LLVM.load-   store = LLVM.store . MultiVector.deconsPrim-   decompose = return . MultiVector.consPrim-   compose = return . MultiVector.deconsPrim--instance-   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>-      C n Float where-   type Struct n Float = LLVM.Vector n Float-   load = fmap MultiVector.consPrim . LLVM.load-   store = LLVM.store . MultiVector.deconsPrim-   decompose = return . MultiVector.consPrim-   compose = return . MultiVector.deconsPrim--instance-   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D64)) =>-      C n Double where-   type Struct n Double = LLVM.Vector n Double-   load = fmap MultiVector.consPrim . LLVM.load-   store = LLVM.store . MultiVector.deconsPrim-   decompose = return . MultiVector.consPrim-   compose = return . MultiVector.deconsPrim--instance (C n a, C n b) => C n (a,b) where-   type Struct n (a,b) = (LLVM.Struct (Struct n a, (Struct n b, ())))-   decompose ab =-      liftA2 MultiVector.zip-         (decompose =<< LLVM.extractvalue ab TypeNum.d0)-         (decompose =<< LLVM.extractvalue ab TypeNum.d1)-   compose ab =-      case MultiVector.unzip ab of-         (a,b) -> do-            sa <- compose a-            sb <- compose b-            ra <- LLVM.insertvalue (LLVM.value LLVM.undef) sa TypeNum.d0-            LLVM.insertvalue ra sb TypeNum.d1--instance (C n a, C n b, C n c) => C n (a,b,c) where-   type Struct n (a,b,c) =-         (LLVM.Struct (Struct n a, (Struct n b, (Struct n c, ()))))-   decompose abc =-      liftA3 MultiVector.zip3-         (decompose =<< LLVM.extractvalue abc TypeNum.d0)-         (decompose =<< LLVM.extractvalue abc TypeNum.d1)-         (decompose =<< LLVM.extractvalue abc TypeNum.d2)-   compose abc =-      case MultiVector.unzip3 abc of-         (a,b,c) -> do-            sa <- compose a-            sb <- compose b-            sc <- compose c-            ra <- LLVM.insertvalue (LLVM.value LLVM.undef) sa TypeNum.d0-            rb <- LLVM.insertvalue ra sb TypeNum.d1-            LLVM.insertvalue rb sc TypeNum.d2----- orphan-instance (C n a) => MultiMem.C (LLVM.Vector n a) where-   type Struct (LLVM.Vector n a) = Struct n a-   load = fmap Inst.toMultiValue . load-   store = store . Inst.fromMultiValue-   decompose = fmap Inst.toMultiValue . decompose-   compose = compose . Inst.fromMultiValue
+ 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/Scalar.hs view
@@ -1,12 +1,9 @@ {-# LANGUAGE TypeFamilies #-} module LLVM.Extra.Scalar where -import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Util.Loop as Loop-import LLVM.Util.Loop (Phi, )- import qualified Control.Monad as Monad  @@ -66,15 +63,15 @@    Monad.liftM decons $ f (Cons a) (Cons b) (Cons c) (Cons d) (Cons e)  -instance (Class.Zero a) => Class.Zero (T a) where-   zeroTuple = Cons Class.zeroTuple+instance (Tuple.Zero a) => Tuple.Zero (T a) where+   zero = Cons Tuple.zero -instance (Class.Undefined a) => Class.Undefined (T a) where-   undefTuple = Cons Class.undefTuple+instance (Tuple.Undefined a) => Tuple.Undefined (T a) where+   undef = Cons Tuple.undef -instance (Phi a) => Phi (T a) where-   phis bb = fmap Cons . Loop.phis bb . decons-   addPhis bb (Cons a) (Cons b) = Loop.addPhis bb a b+instance (Tuple.Phi a) => Tuple.Phi (T a) where+   phi bb = fmap Cons . Tuple.phi bb . decons+   addPhi bb (Cons a) (Cons b) = Tuple.addPhi bb a b  instance (A.IntegerConstant a) => A.IntegerConstant (T a) where    fromInteger' = Cons . A.fromInteger'
src/LLVM/Extra/ScalarOrVector.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {- | Support for unified handling of scalars and vectors.@@ -25,7 +26,7 @@    replicateOf,    Real (min, max, abs, signum),    Saturated(addSat, subSat),-   PseudoModule (scale, scaleConst),+   PseudoModule (scale),    IntegerConstant(constFromInteger),    RationalConstant(constFromRational),    TranscendentalConstant(constPi),@@ -49,7 +50,7 @@  import qualified Type.Data.Num.Decimal as TypeNum -import Data.Word (Word8, Word16, Word32, Word64, )+import Data.Word (Word8, Word16, Word32, Word64, Word) import Data.Int  (Int8,  Int16,  Int32,  Int64, ) import Data.Maybe (fromMaybe) @@ -228,10 +229,12 @@       A.signumGen minusOne one x  +instance Real Int    where min = A.min; max = A.max; signum = A.signum; abs = A.abs; instance Real Int8   where min = A.min; max = A.max; signum = A.signum; abs = A.abs; instance Real Int16  where min = A.min; max = A.max; signum = A.signum; abs = A.abs; instance Real Int32  where min = A.min; max = A.max; signum = A.signum; abs = A.abs; instance Real Int64  where min = A.min; max = A.max; signum = A.signum; abs = A.abs;+instance Real Word   where min = A.min; max = A.max; signum = A.signum; abs = return; instance Real Word8  where min = A.min; max = A.max; signum = A.signum; abs = return; instance Real Word16 where min = A.min; max = A.max; signum = A.signum; abs = return; instance Real Word32 where min = A.min; max = A.max; signum = A.signum; abs = return;@@ -254,6 +257,8 @@ class (IsInteger a) => Saturated a where    addSat, subSat :: Value a -> Value a -> CodeGenFunction r (Value a) +instance Saturated Int    where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy; instance Saturated Int8   where    addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy; instance Saturated Int16  where@@ -262,6 +267,8 @@    addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy; instance Saturated Int64  where    addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance Saturated Word   where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy; instance Saturated Word8  where    addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy; instance Saturated Word16 where@@ -300,32 +307,34 @@    (LLVM.IsArithmetic (Scalar v), LLVM.IsArithmetic v) =>       PseudoModule v where    scale :: (a ~ Scalar v) => Value a -> Value v -> CodeGenFunction r (Value v)-   scaleConst :: (a ~ Scalar v) => ConstValue a -> ConstValue v -> CodeGenFunction r (ConstValue v) -instance PseudoModule Word8  where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Word16 where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Word32 where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Word64 where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Int8   where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Int16  where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Int32  where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Int64  where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Float  where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Double where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Word   where scale = LLVM.mul+instance PseudoModule Word8  where scale = LLVM.mul+instance PseudoModule Word16 where scale = LLVM.mul+instance PseudoModule Word32 where scale = LLVM.mul+instance PseudoModule Word64 where scale = LLVM.mul+instance PseudoModule Int    where scale = LLVM.mul+instance PseudoModule Int8   where scale = LLVM.mul+instance PseudoModule Int16  where scale = LLVM.mul+instance PseudoModule Int32  where scale = LLVM.mul+instance PseudoModule Int64  where scale = LLVM.mul+instance PseudoModule Float  where scale = LLVM.mul+instance PseudoModule Double where scale = LLVM.mul instance (LLVM.IsArithmetic a, LLVM.IsPrimitive a, TypeNum.Positive n) =>          PseudoModule (Vector n a) where    scale a v = flip A.mul v =<< replicate a-   scaleConst a v = LLVM.mul (replicateConst a `asTypeOf` v) v    class (LLVM.IsConst a) => IntegerConstant a where    constFromInteger :: Integer -> ConstValue a +instance IntegerConstant Word   where constFromInteger = constOf . fromInteger instance IntegerConstant Word8  where constFromInteger = constOf . fromInteger instance IntegerConstant Word16 where constFromInteger = constOf . fromInteger instance IntegerConstant Word32 where constFromInteger = constOf . fromInteger instance IntegerConstant Word64 where constFromInteger = constOf . fromInteger+instance IntegerConstant Int    where constFromInteger = constOf . fromInteger instance IntegerConstant Int8   where constFromInteger = constOf . fromInteger instance IntegerConstant Int16  where constFromInteger = constOf . fromInteger instance IntegerConstant Int32  where constFromInteger = constOf . fromInteger
+ src/LLVM/Extra/Storable.hs view
@@ -0,0 +1,41 @@+{- |+Transfer values between Haskell and JIT generated code+in a Haskell-compatible format as dictated by the 'Foreign.Storable' class.+E.g. instance 'Bool' may use more than a byte (e.g. Word32).+For tuples, you may use the @Tuple@ wrapper from the @storable-record@ package.+The 'Storable' instance for 'Vector's is compatible with arrays,+i.e. indices always count upwards irrespective of machine endianess+and tuple elements are interleaved.+-}+module LLVM.Extra.Storable (+   -- * Basic class+   Store.C(..),+   Store.storeNext,+   Store.modify,++   -- * Classes for tuples and vectors+   Store.Tuple(..),+   Store.Vector(..),+   Store.TupleVector(..),++   -- * Standard method implementations+   Store.loadNewtype,+   Store.storeNewtype,+   Store.loadTraversable,+   Store.loadApplicative,+   Store.storeFoldable,++   -- * Pointer handling+   Store.advancePtr,+   Store.incrementPtr,+   Store.decrementPtr,++   -- * Loops over Storable arrays+   Array.arrayLoop,+   Array.arrayLoop2,+   Array.arrayLoopMaybeCont,+   Array.arrayLoopMaybeCont2,+   ) where++import qualified LLVM.Extra.Storable.Private as Store+import qualified LLVM.Extra.Storable.Array as Array
+ src/LLVM/Extra/Storable/Array.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{- |+Loops over Storable arrays.+-}+module LLVM.Extra.Storable.Array where++import qualified LLVM.Extra.Storable.Private as Storable+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Control as C+import LLVM.Core+   (CodeGenFunction, Value, CmpRet, IsInteger, IsConst, IsPrimitive)++import Foreign.Storable (Storable)+import Foreign.Ptr (Ptr)++import Control.Monad (liftM2)++import Data.Tuple.HT (mapSnd)+++arrayLoop ::+   (Tuple.Phi s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,+    Storable a, Value (Ptr a) ~ ptrA) =>+   Value i -> ptrA -> s ->+   (ptrA -> s -> CodeGenFunction r s) ->+   CodeGenFunction r s+arrayLoop len ptr start body =+   fmap snd $+   C.fixedLengthLoop len (ptr, start) $ \(p,s) ->+      liftM2 (,) (Storable.incrementPtr p) (body p s)++arrayLoop2 ::+   (Tuple.Phi s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,+    Storable a, Value (Ptr a) ~ ptrA,+    Storable b, Value (Ptr b) ~ ptrB) =>+   Value i -> ptrA -> ptrB -> s ->+   (ptrA -> ptrB -> s -> CodeGenFunction r s) ->+   CodeGenFunction r s+arrayLoop2 len ptrA ptrB start body =+   fmap snd $+   arrayLoop len ptrA (ptrB,start) $ \pa (pb,s) ->+      liftM2 (,) (Storable.incrementPtr pb) (body pa pb s)+++arrayLoopMaybeCont ::+   (Tuple.Phi s, Tuple.Undefined s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,+    Storable a, Value (Ptr a) ~ ptrA,+    Maybe.T (ptrA, s) ~ z) =>+   Value i ->+   ptrA -> s ->+   (ptrA -> s -> MaybeCont.T r z s) ->+   CodeGenFunction r (Value i, Maybe.T s)+arrayLoopMaybeCont len ptr start body =+   fmap (mapSnd (fmap snd)) $+   MaybeCont.fixedLengthLoop len (ptr,start) $ \(ptr0,s0) ->+      liftM2 (,)+         (MaybeCont.lift $ Storable.incrementPtr ptr0)+         (body ptr0 s0)++arrayLoopMaybeCont2 ::+   (Tuple.Phi s, Tuple.Undefined s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,+    Storable a, Value (Ptr a) ~ ptrA,+    Storable b, Value (Ptr b) ~ ptrB,+    Maybe.T (ptrA, (ptrB, s)) ~ z) =>+   Value i ->+   ptrA -> ptrB -> s ->+   (ptrA -> ptrB -> s -> MaybeCont.T r z s) ->+   CodeGenFunction r (Value i, Maybe.T s)+arrayLoopMaybeCont2 len ptrA ptrB start body =+   fmap (mapSnd (fmap snd)) $+   arrayLoopMaybeCont len ptrA (ptrB,start) $ \ptrAi (ptrB0,s0) ->+      liftM2 (,)+         (MaybeCont.lift $ Storable.incrementPtr ptrB0)+         (body ptrAi ptrB0 s0)
+ src/LLVM/Extra/Storable/Private.hs view
@@ -0,0 +1,477 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module LLVM.Extra.Storable.Private where++import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.ArithmeticPrivate as A+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.Storable.FixedArray (roundUp)+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.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, Tuple.Value a,+    Tuple.Phi (Tuple.ValueOf a), Tuple.Undefined (Tuple.ValueOf 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 (Tuple.ValueOf a)+   store :: Tuple.ValueOf a -> Value (Ptr a) -> CodeGenFunction r ()++storeNext ::+   (C a, Tuple.ValueOf a ~ al, Value (Ptr a) ~ ptr) =>+   al -> ptr -> CodeGenFunction r ptr+storeNext a ptr  =  store a ptr >> incrementPtr ptr++modify ::+   (C a, Tuple.ValueOf a ~ al) =>+   (al -> CodeGenFunction r al) ->+   Value (Ptr a) -> CodeGenFunction r ()+modify f ptr  =  flip store ptr =<< f =<< load ptr+++loadPrimitive ::+   (LLVM.Storable a) => Value (Ptr a) -> CodeGenFunction r (Value a)+loadPrimitive ptr = LLVM.load =<< LLVM.bitcast ptr++storePrimitive ::+   (LLVM.Storable a) => Value a -> Value (Ptr a) -> CodeGenFunction r ()+storePrimitive 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+      A.cmp LLVM.CmpNE mask zero+   store 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)++incPtrState :: MS.StateT BytePtr (CodeGenFunction r) BytePtr+incPtrState = update A.advanceArrayElementPtr++instance C Bool8 where+   load ptr =+      A.cmp LLVM.CmpNE (LLVM.valueOf 0) =<< LLVM.load =<< castToBytePtr ptr+   store 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 = loadTuple+   store = storeTuple++class+   (StoreTuple.Storable tuple, Tuple.Value tuple,+    Tuple.Phi (Tuple.ValueOf tuple), Tuple.Undefined (Tuple.ValueOf tuple)) =>+      Tuple tuple where+   loadTuple ::+      Value (Ptr (StoreTuple.Tuple tuple)) ->+      CodeGenFunction r (Tuple.ValueOf tuple)+   storeTuple ::+      Tuple.ValueOf tuple ->+      Value (Ptr (StoreTuple.Tuple tuple)) ->+      CodeGenFunction r ()++instance (C a, C b) => Tuple (a,b) where+   loadTuple ptr =+      runElements ptr $+         App.mapPair (loadElement, loadElement) $+         FuncHT.unzip $ proxyFromElement3 ptr+   storeTuple (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 $+         App.mapTriple (loadElement, loadElement, loadElement) $+         FuncHT.unzip3 $ proxyFromElement3 ptr+   storeTuple (a,b,c) ptr =+      case FuncHT.unzip3 $ proxyFromElement3 ptr of+         (pa,pb,pc) ->+            runElements ptr $+               storeElement pa a >> storeElement pb b >> storeElement pc c++runElements ::+   Value (Ptr a) ->+   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) c ->+   CodeGenFunction r c+runElements ptr act = do+   bytePtr <- castToBytePtr ptr+   flip MS.evalStateT 0 $ flip MR.runReaderT bytePtr act++loadElement ::+   (C a) =>+   LP.Proxy a ->+   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) (Tuple.ValueOf a)+loadElement proxy =+   MT.lift . MT.lift . load =<< elementPtr proxy++storeElement ::+   (C a) =>+   LP.Proxy a -> Tuple.ValueOf 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, ())++elementOffset ::+   (Monad m, Store.Storable a) => LP.Proxy a -> MS.StateT Int m Int+elementOffset proxy = do+   let dummy = elementFromProxy proxy+   MS.modify (roundUp $ Store.alignment dummy)+   offset <- MS.get+   MS.modify (+ Store.sizeOf dummy)+   return offset+++instance+   (TypeNum.Positive n, Vector a, Tuple.VectorValue n a,+    Tuple.Phi (Tuple.VectorValueOf n a)) =>+      C (LLVM.Vector n a) where+   load ptr =+      assembleVector (proxyFromElement3 ptr) =<< loadApplicative ptr+   store a ptr =+      flip storeFoldable ptr+         =<< disassembleVector (proxyFromElement3 ptr) a++class (C a) => Vector a where+   assembleVector ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> LLVM.Vector n (Tuple.ValueOf a) ->+      CodeGenFunction r (Tuple.VectorValueOf n a)+   disassembleVector ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> Tuple.VectorValueOf n a ->+      CodeGenFunction r (LLVM.Vector n (Tuple.ValueOf a))++assemblePrimitive ::+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>+   LLVM.Vector n (Value a) -> CodeGenFunction r (Value (LLVM.Vector n a))+assemblePrimitive =+   foldM+      (\v (i,x) -> LLVM.insertelement v x (LLVM.valueOf i))+      (LLVM.value LLVM.undef)+    . zip [0..] . Fold.toList++disassemblePrimitive ::+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>+   Value (LLVM.Vector n a) -> CodeGenFunction r (LLVM.Vector n (Value a))+disassemblePrimitive v =+   Trav.mapM (LLVM.extractelement v . LLVM.valueOf) indices++indices :: (Applicative f, Trav.Traversable f) => f Word32+indices =+   flip MS.evalState 0 $ Trav.sequenceA $ pure $ MS.state (\k -> (k,k+1))++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 TupleVector a where+   deinterleave ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> LLVM.Vector n (Tuple.ValueOf a) ->+      CodeGenFunction r (Tuple.VectorValueOf n a)+   interleave ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> Tuple.VectorValueOf n a ->+      CodeGenFunction r (LLVM.Vector n (Tuple.ValueOf 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 ()+   store () _ptr = return ()+++loadNewtype ::+   (C a, Tuple.ValueOf a ~ al) =>+   (a -> wrapped) ->+   (al -> wrappedl) ->+   Value (Ptr wrapped) -> CodeGenFunction r wrappedl+loadNewtype wrap wrapl =+   fmap wrapl . load <=< rmapPtr wrap++storeNewtype ::+   (C a, Tuple.ValueOf a ~ al) =>+   (a -> wrapped) ->+   (wrappedl -> al) ->+   wrappedl -> Value (Ptr wrapped) -> CodeGenFunction r ()+storeNewtype wrap unwrapl y =+   store (unwrapl y) <=< rmapPtr wrap++rmapPtr :: (a -> b) -> Value (Ptr b) -> CodeGenFunction r (Value (Ptr a))+rmapPtr _f = LLVM.bitcast+++loadTraversable ::+   (NonEmptyC.Repeat f, Trav.Traversable f, C a, Tuple.ValueOf a ~ al) =>+   Value (Ptr (f a)) -> CodeGenFunction r (f al)+loadTraversable =+   (MS.evalStateT $ Trav.sequence $ NonEmptyC.repeat $ loadState)+      <=< castElementPtr++loadApplicative ::+   (Applicative f, Trav.Traversable f, C a, Tuple.ValueOf a ~ al) =>+   Value (Ptr (f a)) -> CodeGenFunction r (f al)+loadApplicative =+   (MS.evalStateT $ Trav.sequence $ pure loadState) <=< castElementPtr++loadState ::+   (C a, Tuple.ValueOf a ~ al) =>+   MS.StateT (Value (Ptr a)) (CodeGenFunction r) al+loadState = MT.lift . load =<< advancePtrState+++storeFoldable ::+   (Fold.Foldable f, C a, Tuple.ValueOf a ~ al) =>+   f al -> Value (Ptr (f a)) -> CodeGenFunction r ()+storeFoldable xs = MS.evalStateT (Fold.mapM_ storeState xs) <=< castElementPtr++storeState ::+   (C a, Tuple.ValueOf a ~ al) =>+   al -> MS.StateT (Value (Ptr a)) (CodeGenFunction r) ()+storeState a = MT.lift . store a =<< advancePtrState+++update :: (Monad m) => (a -> m a) -> MS.StateT a m a+update f = MS.StateT $ \a0 -> do a1 <- f a0; return (a0,a1)++advancePtrState ::+   (C a, Value (Ptr a) ~ ptr) =>+   MS.StateT ptr (CodeGenFunction r) ptr+advancePtrState = update $ advancePtrStatic 1++advancePtr ::+   (Store.Storable a, Value (Ptr a) ~ ptr) =>+   Value Int -> ptr -> CodeGenFunction r ptr+advancePtr n ptr = do+   size <- A.mul n $ LLVM.valueOf $ Store.sizeOf (elementFromPtr ptr)+   addPointer size ptr++advancePtrStatic ::+   (Store.Storable a, Value (Ptr a) ~ ptr) =>+   Int -> ptr -> CodeGenFunction r ptr+advancePtrStatic n ptr =+   addPointer (LLVM.valueOf (Store.sizeOf (elementFromPtr ptr) * n)) ptr++incrementPtr ::+   (Store.Storable a, Value (Ptr a) ~ ptr) =>+   ptr -> CodeGenFunction r ptr+incrementPtr = advancePtrStatic 1++decrementPtr ::+   (Store.Storable a, Value (Ptr a) ~ ptr) =>+   ptr -> CodeGenFunction r ptr+decrementPtr = advancePtrStatic (-1)++addPointer :: Value Int -> Value (Ptr a) -> CodeGenFunction r (Value (Ptr a))+addPointer k ptr = do+   bytePtr <- castToBytePtr ptr+   castFromBytePtr =<< LLVM.getElementPtr bytePtr (k, ())++type BytePtr = Value (LLVM.Ptr Word8)++castToBytePtr :: Value (Ptr a) -> CodeGenFunction r BytePtr+castToBytePtr = LLVM.bitcast++castFromBytePtr :: BytePtr -> CodeGenFunction r (Value (Ptr a))+castFromBytePtr = LLVM.bitcast++castElementPtr :: Value (Ptr (f a)) -> CodeGenFunction r (Value (Ptr a))+castElementPtr = LLVM.bitcast+++sizeOf :: (Store.Storable a) => LP.Proxy a -> Int+sizeOf = Store.sizeOf . elementFromProxy++elementFromPtr :: LLVM.Value (Ptr a) -> a+elementFromPtr _ = error "elementFromProxy"++elementFromProxy :: LP.Proxy a -> a+elementFromProxy LP.Proxy = error "elementFromProxy"++proxyFromElement2 :: f (g a) -> LP.Proxy a+proxyFromElement2 _ = LP.Proxy++proxyFromElement3 :: f (g (h a)) -> LP.Proxy a+proxyFromElement3 _ = LP.Proxy
+ src/LLVM/Extra/Struct.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+In contrast to 'LLVM.Struct' it allows to store high-level values+and thus allows to implement arbitrary-sized tuples of NiceValue's.+-}+module LLVM.Extra.Struct where++import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM++import qualified Control.Applicative.HT as App+import Control.Applicative ((<$>))+++newtype T struct = Cons struct+++class Undefined struct where+   undef :: struct++instance (Undefined struct) => Tuple.Undefined (T struct) where+   undef = Cons undef++instance+   (Tuple.Undefined a, Undefined as) =>+      Undefined (a,as) where+   undef = (Tuple.undef, undef)++instance Undefined () where+   undef = ()+++class Zero struct where+   zero :: struct++instance (Zero struct) => Tuple.Zero (T struct) where+   zero = Cons zero++instance (Tuple.Zero a, Zero as) => Zero (a,as) where+   zero = (Tuple.zero, zero)++instance Zero () where+   zero = ()+++class Phi struct where+   phi :: LLVM.BasicBlock -> struct -> LLVM.CodeGenFunction r struct+   addPhi :: LLVM.BasicBlock -> struct -> struct -> LLVM.CodeGenFunction r ()++instance (Phi struct) => Tuple.Phi (T struct) where+   phi bb (Cons s) = Cons <$> phi bb s+   addPhi bb (Cons a) (Cons b) = addPhi bb a b++instance (Tuple.Phi a, Phi as) => Phi (a,as) where+   phi bb (a,as) = App.lift2 (,) (Tuple.phi bb a) (phi bb as)+   addPhi bb (a,as) (b,bs) = Tuple.addPhi bb a b >> addPhi bb as bs++instance Phi () where+   phi _bb = return+   addPhi _bb () () = return ()+++class (Undefined (ValueOf struct)) => Value struct where+   type ValueOf struct+   valueOf :: struct -> ValueOf struct++instance (Value struct) => Tuple.Value (T struct) where+   type ValueOf (T struct) = T (ValueOf struct)+   valueOf (Cons struct) = Cons $ valueOf struct++instance (Tuple.Value a, Value as) => Value (a,as) where+   type ValueOf (a,as) = (Tuple.ValueOf a, ValueOf as)+   valueOf (a,as) = (Tuple.valueOf a, valueOf as)++instance Value () where+   type ValueOf () = ()+   valueOf () = ()
+ src/LLVM/Extra/Tuple.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module LLVM.Extra.Tuple (+   Phi(..), phiTraversable, addPhiFoldable,+   Undefined(..), undefPointed,+   Zero(..), zeroPointed,+   Value(..), valueOfFunctor,+   VectorValue(..),+   ) where++import LLVM.Extra.TuplePrivate (+   Phi(..), phiTraversable, addPhiFoldable,+   Undefined(..), undefPointed,+   Zero(..), zeroPointed,+   )+import qualified LLVM.Extra.EitherPrivate as Either+import qualified LLVM.Extra.MaybePrivate as Maybe+import qualified LLVM.Core as LLVM+import LLVM.Core (IsType, Vector)++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal ((:*:))++import qualified Control.Monad.Trans.State as MS+import qualified Control.Applicative as App+import qualified Control.Functor.HT as FuncHT++import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav++import qualified Foreign.Storable.Record.Tuple as StoreTuple+import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (FunPtr, Ptr, )++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(unTagged))+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64, )+import Data.Bool8 (Bool8)++import Prelude2010+import Prelude ()+++-- * class for creating tuples of constant values++class (Undefined (ValueOf a)) => Value a where+   type ValueOf a+   valueOf :: a -> ValueOf a++instance (Value a, Value b) => Value (a,b) where+   type ValueOf (a,b) = (ValueOf a, ValueOf b)+   valueOf ~(a,b) = (valueOf a, valueOf b)++instance (Value a, Value b, Value c) => Value (a,b,c) where+   type ValueOf (a,b,c) = (ValueOf a, ValueOf b, ValueOf c)+   valueOf ~(a,b,c) = (valueOf a, valueOf b, valueOf c)++instance (Value a, Value b, Value c, Value d) => Value (a,b,c,d) where+   type ValueOf (a,b,c,d) = (ValueOf a, ValueOf b, ValueOf c, ValueOf d)+   valueOf ~(a,b,c,d) = (valueOf a, valueOf b, valueOf c, valueOf d)++instance (Value tuple) => Value (StoreTuple.Tuple tuple) where+   type ValueOf (StoreTuple.Tuple tuple) = ValueOf tuple+   valueOf (StoreTuple.Tuple a) = valueOf a++instance (Value a) => Value (Maybe a) where+   type ValueOf (Maybe a) = Maybe.T (ValueOf a)+   valueOf = maybe (Maybe.nothing undef) (Maybe.just . valueOf)++instance (Value a, Value b) => Value (Either a b) where+   type ValueOf (Either a b) = Either.T (ValueOf a) (ValueOf b)+   valueOf =+      either+         (Either.left undef . valueOf)+         (Either.right undef . valueOf)++instance Value Float  where type ValueOf Float  = LLVM.Value Float  ; valueOf = LLVM.valueOf+instance Value Double where type ValueOf Double = LLVM.Value Double ; valueOf = LLVM.valueOf+-- instance Value FP128  where type ValueOf FP128  = LLVM.Value FP128  ; valueOf = LLVM.valueOf+instance Value Bool   where type ValueOf Bool   = LLVM.Value Bool   ; valueOf = LLVM.valueOf+instance Value Bool8  where type ValueOf Bool8  = LLVM.Value Bool   ; valueOf = LLVM.valueOf . Bool8.toBool+instance Value Int    where type ValueOf Int    = LLVM.Value Int    ; valueOf = LLVM.valueOf+instance Value Int8   where type ValueOf Int8   = LLVM.Value Int8   ; valueOf = LLVM.valueOf+instance Value Int16  where type ValueOf Int16  = LLVM.Value Int16  ; valueOf = LLVM.valueOf+instance Value Int32  where type ValueOf Int32  = LLVM.Value Int32  ; valueOf = LLVM.valueOf+instance Value Int64  where type ValueOf Int64  = LLVM.Value Int64  ; valueOf = LLVM.valueOf+instance Value Word   where type ValueOf Word   = LLVM.Value Word   ; valueOf = LLVM.valueOf+instance Value Word8  where type ValueOf Word8  = LLVM.Value Word8  ; valueOf = LLVM.valueOf+instance Value Word16 where type ValueOf Word16 = LLVM.Value Word16 ; valueOf = LLVM.valueOf+instance Value Word32 where type ValueOf Word32 = LLVM.Value Word32 ; valueOf = LLVM.valueOf+instance Value Word64 where type ValueOf Word64 = LLVM.Value Word64 ; valueOf = LLVM.valueOf+instance Value ()     where type ValueOf ()     = ()           ; valueOf = id+++instance (TypeNum.Positive n) => Value (LLVM.IntN n) where+   type ValueOf (LLVM.IntN n) = LLVM.Value (LLVM.IntN n)+   valueOf = LLVM.valueOf++instance (TypeNum.Positive n) => Value (LLVM.WordN n) where+   type ValueOf (LLVM.WordN n) = LLVM.Value (LLVM.WordN n)+   valueOf = LLVM.valueOf+++instance Value (Ptr a) where+   type ValueOf (Ptr a) = LLVM.Value (Ptr a)+   valueOf = LLVM.valueOf++instance IsType a => Value (LLVM.Ptr a) where+   type ValueOf (LLVM.Ptr a) = LLVM.Value (LLVM.Ptr a)+   valueOf = LLVM.valueOf++instance LLVM.IsFunction a => Value (FunPtr a) where+   type ValueOf (FunPtr a) = LLVM.Value (FunPtr a)+   valueOf = LLVM.valueOf++instance Value (StablePtr a) where+   type ValueOf (StablePtr a) = LLVM.Value (StablePtr a)+   valueOf = LLVM.valueOf++instance+   (TypeNum.Positive n, VectorValue n a, Undefined (VectorValueOf n a)) =>+      Value (Vector n a) where+   type ValueOf (Vector n a) = VectorValueOf n a+   valueOf = vectorValueOf+++instance Value a => Value (Tagged tag a) where+   type ValueOf (Tagged tag a) = ValueOf a+   valueOf = valueOf . unTagged++instance+   (LLVM.IsInteger w, LLVM.IsConst w, Num w, Enum e) =>+      Value (Enum.T w e) where+   type ValueOf (Enum.T w e) = LLVM.Value w+   valueOf = LLVM.valueOf . fromIntegral . fromEnum . Enum.toPlain++instance (LLVM.IsInteger w, LLVM.IsConst w) => Value (EnumBitSet.T w i) where+   type ValueOf (EnumBitSet.T w i) = LLVM.Value w+   valueOf = LLVM.valueOf . EnumBitSet.decons++instance (Value a) => Value (Complex a) where+   type ValueOf (Complex a) = Complex (ValueOf a)+   valueOf (a:+b) = valueOf a :+ valueOf b+++-- * class for vectors of tuples and other complex types++class+   (TypeNum.Positive n, Undefined (VectorValueOf n a)) =>+      VectorValue n a where+   type VectorValueOf n a+   vectorValueOf :: Vector n a -> VectorValueOf n a++-- may be simplified using a fake proof of TypeNum.Positive (n :*: m)+instance+   (TypeNum.Positive n, TypeNum.Positive m, TypeNum.Positive (n :*: m),+    Undefined (Vector (n :*: m) a)) =>+      VectorValue n (Vector m a) where+   type VectorValueOf n (Vector m a) = Vector (n :*: m) a+   vectorValueOf = vectorFromList . Fold.foldMap Fold.toList++vectorFromList :: (TypeNum.Positive n) => [a] -> Vector n a+vectorFromList =+   MS.evalState $ Trav.sequence $ App.pure $ MS.state $ \(y:ys) -> (y,ys)++instance (VectorValue n a, VectorValue n b) => VectorValue n (a,b) where+   type VectorValueOf n (a,b) = (VectorValueOf n a, VectorValueOf n b)+   vectorValueOf v =+      case FuncHT.unzip v of+         (a,b) -> (vectorValueOf a, vectorValueOf b)++instance+   (VectorValue n a, VectorValue n b, VectorValue n c) =>+      VectorValue n (a,b,c) where+   type VectorValueOf n (a,b,c) =+         (VectorValueOf n a, VectorValueOf n b, VectorValueOf n c)+   vectorValueOf v =+      case FuncHT.unzip3 v of+         (a,b,c) -> (vectorValueOf a, vectorValueOf b, vectorValueOf c)++instance (VectorValue n tuple) => VectorValue n (StoreTuple.Tuple tuple) where+   type VectorValueOf n (StoreTuple.Tuple tuple) = VectorValueOf n tuple+   vectorValueOf = vectorValueOf . fmap StoreTuple.getTuple++instance (TypeNum.Positive n) => VectorValue n Float where+   type VectorValueOf n Float  = LLVM.Value (Vector n Float)+   vectorValueOf = LLVM.valueOf++instance (TypeNum.Positive n) => VectorValue n Double where+   type VectorValueOf n Double = LLVM.Value (Vector n Double)+   vectorValueOf = LLVM.valueOf+{-+instance (TypeNum.Positive n) => VectorValue n FP128  where+   type VectorValueOf n FP128  = LLVM.Value (Vector n FP128)+   vectorValueOf = LLVM.valueOf+-}+instance (TypeNum.Positive n) => VectorValue n Bool   where+   type VectorValueOf n Bool   = LLVM.Value (Vector n Bool)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Bool8  where+   type VectorValueOf n Bool8  = LLVM.Value (Vector n Bool)+   vectorValueOf = LLVM.valueOf . fmap Bool8.toBool+instance (TypeNum.Positive n) => VectorValue n Int  where+   type VectorValueOf n Int    = LLVM.Value (Vector n Int)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Int8   where+   type VectorValueOf n Int8   = LLVM.Value (Vector n Int8)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Int16  where+   type VectorValueOf n Int16  = LLVM.Value (Vector n Int16)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Int32  where+   type VectorValueOf n Int32  = LLVM.Value (Vector n Int32)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Int64  where+   type VectorValueOf n Int64  = LLVM.Value (Vector n Int64)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Word   where+   type VectorValueOf n Word   = LLVM.Value (Vector n Word)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Word8  where+   type VectorValueOf n Word8  = LLVM.Value (Vector n Word8)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Word16 where+   type VectorValueOf n Word16 = LLVM.Value (Vector n Word16)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Word32 where+   type VectorValueOf n Word32 = LLVM.Value (Vector n Word32)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Word64 where+   type VectorValueOf n Word64 = LLVM.Value (Vector n Word64)+   vectorValueOf = LLVM.valueOf+++-- * default methods for LLVM classes++valueOfFunctor :: (Value h, Functor f) => f h -> f (ValueOf h)+valueOfFunctor = fmap valueOf
+ src/LLVM/Extra/TuplePrivate.hs view
@@ -0,0 +1,140 @@+module LLVM.Extra.TuplePrivate where++import qualified LLVM.Core as LLVM++import qualified Data.FixedLength as FixedLength+import Data.Complex (Complex)++import qualified Type.Data.Num.Unary as Unary++import qualified Control.Applicative.HT as App+import Control.Applicative (Applicative, liftA2, pure)++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold++import Data.Orphans ()++++-- * class for phi operating on value tuples++class Phi a where+   phi :: LLVM.BasicBlock -> a -> LLVM.CodeGenFunction r a+   addPhi :: LLVM.BasicBlock -> a -> a -> LLVM.CodeGenFunction r ()++instance Phi () where+   phi _ _ = return ()+   addPhi _ _ _ = return ()++instance (LLVM.IsFirstClass a) => Phi (LLVM.Value a) where+   phi bb a = LLVM.phi [(a, bb)]+   addPhi bb a a' = LLVM.addPhiInputs a [(a', bb)]++instance (Phi a, Phi b) => Phi (a, b) where+   phi bb = App.mapPair (phi bb, phi bb)+   addPhi bb (a0,b0) (a1,b1) = do+      addPhi bb a0 a1+      addPhi bb b0 b1++instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where+   phi bb = App.mapTriple (phi bb, phi bb, phi bb)+   addPhi bb (a0,b0,c0) (a1,b1,c1) = do+      addPhi bb a0 a1+      addPhi bb b0 b1+      addPhi bb c0 c1++instance (Phi a, Phi b, Phi c, Phi d) => Phi (a, b, c, d) where+   phi bb (a,b,c,d) =+      App.lift4 (,,,) (phi bb a) (phi bb b) (phi bb c) (phi bb d)+   addPhi bb (a0,b0,c0,d0) (a1,b1,c1,d1) = do+      addPhi bb a0 a1+      addPhi bb b0 b1+      addPhi bb c0 c1+      addPhi bb d0 d1++instance (Phi a) => Phi (Complex a) where+   phi = phiTraversable+   addPhi = addPhiFoldable++instance (Unary.Natural n, Phi a) => Phi (FixedLength.T n a) where+   phi = phiTraversable+   addPhi = addPhiFoldable++phiTraversable ::+   (Phi a, Trav.Traversable f) =>+   LLVM.BasicBlock -> f a -> LLVM.CodeGenFunction r (f a)+phiTraversable bb x = Trav.mapM (phi bb) x++addPhiFoldable ::+   (Phi a, Fold.Foldable f, Applicative f) =>+   LLVM.BasicBlock -> f a -> f a -> LLVM.CodeGenFunction r ()+addPhiFoldable bb x y = Fold.sequence_ (liftA2 (addPhi bb) x y)+++-- * class for tuples of undefined values++class Undefined a where+   undef :: a++instance Undefined () where+   undef = ()++instance (LLVM.IsFirstClass a) => Undefined (LLVM.Value a) where+   undef = LLVM.value LLVM.undef++instance (LLVM.IsFirstClass a) => Undefined (LLVM.ConstValue a) where+   undef = LLVM.undef++instance (Undefined a, Undefined b) => Undefined (a, b) where+   undef = (undef, undef)++instance (Undefined a, Undefined b, Undefined c) => Undefined (a, b, c) where+   undef = (undef, undef, undef)++instance+   (Undefined a, Undefined b, Undefined c, Undefined d) =>+      Undefined (a, b, c, d) where+   undef = (undef, undef, undef, undef)++instance (Undefined a) => Undefined (Complex a) where+   undef = undefPointed++instance (Unary.Natural n, Undefined a) => Undefined (FixedLength.T n a) where+   undef = undefPointed++undefPointed :: (Undefined a, Applicative f) => f a+undefPointed = pure undef+++-- * class for tuples of zero values++class Zero a where+   zero :: a++instance Zero () where+   zero = ()++instance (LLVM.IsFirstClass a) => Zero (LLVM.Value a) where+   zero = LLVM.value LLVM.zero++instance (LLVM.IsFirstClass a) => Zero (LLVM.ConstValue a) where+   zero = LLVM.zero++instance (Zero a, Zero b) => Zero (a, b) where+   zero = (zero, zero)++instance (Zero a, Zero b, Zero c) => Zero (a, b, c) where+   zero = (zero, zero, zero)++instance (Zero a, Zero b, Zero c, Zero d) => Zero (a, b, c, d) where+   zero = (zero, zero, zero, zero)++instance (Zero a) => Zero (Complex a) where+   zero = zeroPointed++instance (Unary.Natural n, Zero a) => Zero (FixedLength.T n a) where+   zero = zeroPointed++zeroPointed :: (Zero a, Applicative f) => f a+zeroPointed = pure zero
src/LLVM/Extra/Vector.hs view
@@ -40,12 +40,11 @@        truncate, floor, fraction),    ) where -import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.ArithmeticPrivate as A import qualified LLVM.Util.Intrinsic as Intrinsic  import qualified LLVM.Core as LLVM-import LLVM.Util.Loop (Phi(phis, addPhis), ) import LLVM.Core    (Value, ConstValue, valueOf, value, constOf, undef,     Vector, insertelement, extractelement,@@ -70,9 +69,8 @@ import qualified Data.List as List import Data.NonEmpty ((!:), ) --- import qualified Data.Bits as Bit import Data.Int  (Int8, Int16, Int32, Int64, )-import Data.Word (Word8, Word16, Word32, Word64, )+import Data.Word (Word8, Word16, Word32, Word64, Word)  import Prelude hiding           (Real, truncate, floor, round,@@ -101,11 +99,11 @@    insert :: Value Word32 -> Element v -> v -> CodeGenFunction r v  class-   (TypeNum.Positive (Size v), Phi v, Class.Undefined v) =>+   (TypeNum.Positive (Size v), Tuple.Phi v, Tuple.Undefined v) =>       Simple v where -   type Element v :: *-   type Size v :: *+   type Element v+   type Size v     shuffleMatch ::       ConstValue (Vector (Size v) Word32) -> v -> CodeGenFunction r v@@ -210,14 +208,14 @@    {-# INLINE sequenceA #-}    sequenceA (Constant a) = fmap Constant a -instance (Phi a) => Phi (Constant n a) where-   phis = Class.phisTraversable-   addPhis = Class.addPhisFoldable+instance (Tuple.Phi a) => Tuple.Phi (Constant n a) where+   phi = Tuple.phiTraversable+   addPhi = Tuple.addPhiFoldable -instance (Class.Undefined a) => Class.Undefined (Constant n a) where-   undefTuple = Class.undefTuplePointed+instance (Tuple.Undefined a) => Tuple.Undefined (Constant n a) where+   undef = Tuple.undefPointed -instance (TypeNum.Positive n, Phi a, Class.Undefined a) => Simple (Constant n a) where+instance (TypeNum.Positive n, Tuple.Phi a, Tuple.Undefined a) => Simple (Constant n a) where     type Element (Constant n a) = a    type Size (Constant n a) = n@@ -229,7 +227,7 @@ class (n ~ Size (Construct n a), a ~ Element (Construct n a),        C (Construct n a)) =>          Canonical n a where-   type Construct n a :: *+   type Construct n a  instance    (TypeNum.Positive n, LLVM.IsPrimitive a) =>@@ -277,10 +275,10 @@    (C v) =>    [Element v] -> CodeGenFunction r v assemble =-   foldM (\v (k,x) -> insert (valueOf k) x v) Class.undefTuple .+   foldM (\v (k,x) -> insert (valueOf k) x v) Tuple.undef .    List.zip [0..] {- sends GHC into an infinite loop-   foldM (\(k,x) -> insert (valueOf k) x) Class.undefTuple .+   foldM (\(k,x) -> insert (valueOf k) x) Tuple.undef .    List.zip [0..] -} @@ -303,7 +301,7 @@    Element v -> CodeGenFunction r v iterate f x =    fmap snd $-   iterateCore f x Class.undefTuple+   iterateCore f x Tuple.undef  iterateCore ::    (C v) =>@@ -413,18 +411,18 @@       (insert (LLVM.valueOf (fromIntegral (sizeInTuple x) - 1)) x0 y)  shiftUpMultiZero ::-   (C v, Class.Zero (Element v)) =>+   (C v, Tuple.Zero (Element v)) =>    Int -> v -> LLVM.CodeGenFunction r v shiftUpMultiZero n v =    assemble . take (sizeInTuple v) .-   (List.replicate n Class.zeroTuple ++) =<< extractAll v+   (List.replicate n Tuple.zero ++) =<< extractAll v  shiftDownMultiZero ::-   (C v, Class.Zero (Element v)) =>+   (C v, Tuple.Zero (Element v)) =>    Int -> v -> LLVM.CodeGenFunction r v shiftDownMultiZero n v =    assemble . take (sizeInTuple v) .-   (++ List.repeat Class.zeroTuple) . List.drop n+   (++ List.repeat Tuple.zero) . List.drop n       =<< extractAll v  @@ -522,7 +520,7 @@          extract (valueOf n) a >>=          f >>=          flip (insert (valueOf n)) b)-      Class.undefTuple+      Tuple.undef       (take (sizeInTuple a) [0..])  mapChunks ::@@ -537,7 +535,7 @@          am >>= \ac ->          f ac >>= \bc ->          insertChunk (k * sizeInTuple ac) bc b)-      Class.undefTuple $+      Tuple.undef $    List.zip (chop a) [0..]  zipChunksWith ::@@ -653,7 +651,7 @@                insert (valueOf j) x v)             v0 $          List.zip [0..] js)-      Class.undefTuple $+      Tuple.undef $    List.zip       (ListHT.sliceVertical (sizeInTuple (head xs)) [0..])       xs@@ -754,7 +752,7 @@          a1 <- A.add a0 =<< extract (valueOf k) x          y1 <- insert (valueOf k) a0 y0          return (a1,y1))-      (a, Class.undefTuple)+      (a, Tuple.undef)       (take (sizeInTuple x) $ [0..])  cumulateGeneric =@@ -929,10 +927,12 @@ instance Arithmetic Float where instance Arithmetic Double where +instance Arithmetic Int    where instance Arithmetic Int8   where instance Arithmetic Int16  where instance Arithmetic Int32  where instance Arithmetic Int64  where+instance Arithmetic Word   where instance Arithmetic Word8  where instance Arithmetic Word16 where instance Arithmetic Word32 where@@ -981,6 +981,15 @@    floor = Intrinsic.floor    fraction = A.fraction +instance Real Int where+   min = A.min+   max = A.max+   abs = A.abs+   signum = signumIntGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)+ instance Real Int8 where    min = A.min    max = A.max@@ -1013,6 +1022,15 @@    max = A.max    abs = A.abs    signum = signumIntGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Word where+   min = A.min+   max = A.max+   abs = return+   signum = signumWordGeneric    truncate = return    floor = return    fraction = const $ return (value LLVM.zero)
test/LLVM/Extra/VectorAlt.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {- | This maintains old code for LLVM-2.6
test/Main.hs view
@@ -1,17 +1,25 @@ module Main where +import qualified Test.Storable as Storable import qualified Test.Vector as Vector  import qualified LLVM.Core as LLVM  import Data.Tuple.HT (mapFst) -import qualified Test.QuickCheck as QC+import Control.Monad.IO.Class (liftIO) +import qualified Test.DocTest.Driver as DocTest + main :: IO () main = do    LLVM.initializeNativeTarget -   mapM_ (\(msg,prop) -> putStr (msg++": ") >> prop >>= QC.quickCheck) $-      map (mapFst ("Vector."++)) Vector.tests+   DocTest.run $ mapM_+      (\(msg,prop) -> do+         DocTest.printPrefix (msg++": ")+         DocTest.property =<< liftIO prop) $+      map (mapFst ("Storable."++)) Storable.tests +++      map (mapFst ("Vector."++)) Vector.tests +++      []
+ test/Test/Storable.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Test.Storable (tests) where++import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Foreign+import Foreign.Storable.Record.Tuple (Tuple(Tuple))+import Foreign.Ptr (FunPtr, Ptr)++import Data.Complex (Complex)+import Data.Word (Word16, Word32)+import Data.Int (Int8, Int16, Int32)+import Data.Tuple.HT (mapFst)++import qualified Test.QuickCheck.Monadic as QCMon+import qualified Test.QuickCheck as QC++++type Importer func = FunPtr func -> func++generateFunction ::+   EE.ExecutionFunction f =>+   Importer f -> LLVM.CodeGenModule (LLVM.Function f) -> IO f+generateFunction imprt code = do+   m <- LLVM.newModule+   fn <- do+      func <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> code+      EE.runEngineAccessWithModule m $ EE.getExecutionFunction imprt func+   LLVM.writeBitcodeToFile "test-storable.bc" m+   return fn+++foreign import ccall safe "dynamic" derefTestCasePtr ::+   Importer (Ptr inp -> Ptr out -> IO ())++modul ::+   (Storable.C a, Tuple.ValueOf a ~ al) =>+   (Storable.C b, Tuple.ValueOf b ~ bl) =>+   (al -> LLVM.CodeGenFunction () bl) ->+   LLVM.CodeGenModule (LLVM.Function (Ptr a -> Ptr b -> IO ()))+modul codegen =+   LLVM.createFunction LLVM.ExternalLinkage $ \aPtr bPtr -> do+      flip Storable.store bPtr =<< codegen =<< Storable.load aPtr+      LLVM.ret ()++run ::+   (Show a) =>+   (Storable.C a, Tuple.ValueOf a ~ al) =>+   (Storable.C b, Tuple.ValueOf b ~ bl) =>+   QC.Gen a ->+   (al -> LLVM.CodeGenFunction () bl) ->+   (a -> b -> Bool) ->+   IO QC.Property+run qcgen codegen predicate = do+   funIO <- generateFunction derefTestCasePtr $ modul codegen+   return $ QC.forAll qcgen $ \a ->+      QCMon.monadicIO $ do+         b <-+            QCMon.run $+               Foreign.with a $ \aPtr ->+               Foreign.alloca $ \bPtr -> do+                  funIO aPtr bPtr+                  Foreign.peek bPtr+         QCMon.assert $ predicate a b+++roundTrip ::+   (Show a, Eq a, Storable.C a) =>+   QC.Gen a -> IO QC.Property+roundTrip qcgen = run qcgen return (==)+++tests :: [(String, IO QC.Property)]+tests =+   map (mapFst ("RoundTrip." ++)) $+   ("()",+      roundTrip (QC.arbitrary :: QC.Gen ())) :+   ("Float",+      roundTrip (QC.arbitrary :: QC.Gen Float)) :+   ("(Word16,Float)",+      roundTrip (fmap Tuple (QC.arbitrary :: QC.Gen (Word16,Float)))) :+   ("(Int8,Bool,Double)",+      roundTrip (fmap Tuple (QC.arbitrary :: QC.Gen (Int8,Bool,Double)))) :+   ("Complex Float",+      roundTrip (QC.arbitrary :: QC.Gen (Complex Float))) :+   ("Vector D3 Int32",+      roundTrip (QC.arbitrary :: QC.Gen (LLVM.Vector TypeNum.D3 Int32))) :+   ("Vector D7 (Int16,Word32)",+      roundTrip (fmap (fmap Tuple)+         (QC.arbitrary :: QC.Gen (LLVM.Vector TypeNum.D7 (Int16,Word32))))) :+   []
test/Test/Vector.hs view
@@ -1,23 +1,23 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} module Test.Vector where  import qualified LLVM.Extra.ScalarOrVectorPrivate as SoVPriv import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.VectorAlt as VectorAlt import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.ExecutionEngine as EE-import qualified LLVM.Util.Proxy as LP import qualified LLVM.Core as LLVM  import qualified Type.Data.Num.Decimal as TypeNum import Type.Base.Proxy (Proxy(Proxy)) -import qualified Foreign.Marshal as Marsh-import Foreign.Ptr (FunPtr, Ptr)+import Foreign.Ptr (FunPtr)  import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold@@ -50,49 +50,39 @@    fn <- do       func <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> code       EE.runEngineAccessWithModule m $ EE.getExecutionFunction imprt func-   LLVM.writeBitcodeToFile "test.bc" m+   LLVM.writeBitcodeToFile "test-vector.bc" m    return fn   foreign import ccall safe "dynamic" derefTestCasePtr ::-   Importer (Ptr inp -> Ptr out -> IO ())+   Importer (LLVM.Ptr inp -> LLVM.Ptr out -> IO ())  modul ::-   (Marshal.C inp, Marshal.Struct inp ~ minp, LLVM.IsType minp,-    Marshal.C out, Marshal.Struct out ~ mout, LLVM.IsType mout,-    Class.ValueTuple inp ~ linp, Class.ValueTuple out ~ lout) =>-   (LP.Proxy inp, LP.Proxy out) ->+   (Memory.C linp, Memory.Struct linp ~ minp, LLVM.IsType minp,+    Memory.C lout, Memory.Struct lout ~ mout, LLVM.IsType mout) =>    (linp -> LLVM.CodeGenFunction () lout) ->-   LLVM.CodeGenModule (LLVM.Function (Ptr minp -> Ptr mout -> IO ()))-modul (xProxy,yProxy) codegen =+   LLVM.CodeGenModule (LLVM.Function (LLVM.Ptr minp -> LLVM.Ptr mout -> IO ()))+modul codegen =    LLVM.createFunction LLVM.ExternalLinkage $ \xPtr yPtr -> do-      flip (Marshal.store yProxy) yPtr =<< codegen =<< Marshal.load xProxy xPtr+      flip Memory.store yPtr =<< codegen =<< Memory.load xPtr       LLVM.ret () -proxies :: (inp -> out -> Bool) -> (LP.Proxy inp, LP.Proxy out)-proxies _ = (LP.Proxy, LP.Proxy)--alloca :: (LLVM.IsType a) => LP.Proxy a -> (Ptr a -> IO b) -> IO b-alloca proxy = Marsh.allocaBytes (EE.sizeOf proxy)- run ::    (Marshal.C inp, Marshal.Struct inp ~ minp, LLVM.IsType minp,     Marshal.C out, Marshal.Struct out ~ mout, LLVM.IsType mout,-    Class.ValueTuple inp ~ linp, Class.ValueTuple out ~ lout) =>+    Tuple.ValueOf inp ~ linp, Tuple.ValueOf out ~ lout) =>    (Show inp, QC.Arbitrary inp) =>    (linp -> LLVM.CodeGenFunction () lout) ->    (inp -> out -> Bool) ->    IO QC.Property run codegen predicate = do-   funIO <--      generateFunction derefTestCasePtr $ modul (proxies predicate) codegen+   funIO <- generateFunction derefTestCasePtr $ modul codegen    return $ QC.property $ \x ->       QCMon.monadicIO $ do          y <-             QCMon.run $-               alloca LP.Proxy $ \xPtr ->-               alloca LP.Proxy $ \yPtr -> do-                  Marshal.poke xPtr x+               Marshal.with x $ \xPtr ->+               Marshal.alloca $ \yPtr -> do                   funIO xPtr yPtr                   Marshal.peek yPtr          QCMon.assert $ predicate x y@@ -119,10 +109,9 @@  binop ::    ((TypeNum.D4 TypeNum.:*: LLVM.SizeOf a) ~ size, TypeNum.Natural size,-    QC.Arbitrary a, Show a, Eq a, EE.Marshal a,-    LLVM.IsConst a, LLVM.IsSized a, LLVM.IsPrimitive a) =>-   (LLVM.Value (V4 a) -> LLVM.Value (V4 a) ->-    LLVM.CodeGenFunction () (LLVM.Value (V4 a))) ->+    QC.Arbitrary a, Show a, Eq a,+    Marshal.Vector TypeNum.D4 a, Tuple.VectorValueOf TypeNum.D4 a ~ v) =>+   (v -> v -> LLVM.CodeGenFunction () v) ->    (a -> a -> a) ->    IO QC.Property binop codegen fun =@@ -130,8 +119,8 @@       (\(x,y) z -> liftA2 fun (vec4 x) (vec4 y)  ==  vec4 z)  binopInt ::-   (LLVM.Value V4Int32 -> LLVM.Value V4Int32 ->-    LLVM.CodeGenFunction () (LLVM.Value V4Int32)) ->+   (LLVM.Value V4Int32 ~ v) =>+   (v -> v -> LLVM.CodeGenFunction () v) ->    (Int32 -> Int32 -> Int32) ->    IO QC.Property binopInt = binop@@ -179,10 +168,10 @@ unpackWord3 = unpackWords 8  binopV4I2 ::-   (Eq a, LLVM.IsPrimitive a, LLVM.IsSized a, LLVM.SizeOf a ~ TypeNum.D2) =>+   (Eq a, LLVM.IsPrimitive a, LLVM.IsSized a, LLVM.SizeOf a ~ TypeNum.D2,+    LLVM.Value (V4 a) ~ v) =>    (Word8 -> V4 a) ->-   (LLVM.Value (V4 a) -> LLVM.Value (V4 a) ->-    LLVM.CodeGenFunction () (LLVM.Value (V4 a))) ->+   (v -> v -> LLVM.CodeGenFunction () v) ->    (a -> a -> a) ->    IO QC.Property binopV4I2 unpackBits codegen fun =@@ -198,10 +187,10 @@ type Code15 r = LLVM.CodeGenFunction r (LLVM.Value (LLVM.WordN TypeNum.D15))  binopV5I3 ::-   (Eq a, LLVM.IsPrimitive a, LLVM.IsSized a, LLVM.SizeOf a ~ TypeNum.D3) =>+   (Eq a, LLVM.IsPrimitive a, LLVM.IsSized a, LLVM.SizeOf a ~ TypeNum.D3,+    LLVM.Value (V5 a) ~ v) =>    (Word16 -> V5 a) ->-   (LLVM.Value (V5 a) -> LLVM.Value (V5 a) ->-    LLVM.CodeGenFunction () (LLVM.Value (V5 a))) ->+   (v -> v -> LLVM.CodeGenFunction () v) ->    (a -> a -> a) ->    IO QC.Property binopV5I3 unpackBits codegen fun =@@ -215,15 +204,15 @@          liftA2 fun (unpackBits x) (unpackBits y)  ==  unpackBits z)  binopInt8 ::-   (LLVM.Value (V4 Int8) -> LLVM.Value (V4 Int8) ->-    LLVM.CodeGenFunction () (LLVM.Value (V4 Int8))) ->+   (LLVM.Value (V4 Int8) ~ v) =>+   (v -> v -> LLVM.CodeGenFunction () v) ->    (Int8 -> Int8 -> Int8) ->    IO QC.Property binopInt8 = binop  binopWord8 ::-   (LLVM.Value (V4 Word8) -> LLVM.Value (V4 Word8) ->-    LLVM.CodeGenFunction () (LLVM.Value (V4 Word8))) ->+   (LLVM.Value (V4 Word8) ~ v) =>+   (v -> v -> LLVM.CodeGenFunction () v) ->    (Word8 -> Word8 -> Word8) ->    IO QC.Property binopWord8 = binop