packages feed

llvm-extra 0.9.1 → 0.10

raw patch · 37 files changed

+2133/−1389 lines, 37 filesdep +base-orphansdep +fixed-lengthdep +storable-recorddep ~llvm-tfdep ~utility-ht

Dependencies added: base-orphans, fixed-length, storable-record

Dependency ranges changed: llvm-tf, utility-ht

Files

Changes.md view
@@ -1,5 +1,22 @@ # Change log for the `llvm-extra` package +## 0.10++* `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.10 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"   .@@ -55,7 +61,7 @@   default:     False  Source-Repository this-  Tag:         0.9.1+  Tag:         0.10   Type:        darcs   Location:    http://code.haskell.org/~thielema/llvm-extra/ @@ -66,17 +72,20 @@ Library   Build-Depends:     private,-    llvm-tf >=9.1 && <9.2,+    llvm-tf >=9.2 && <9.3,     tfp >=1.0 && <1.1,     non-empty >=0.2.1 && <0.4,+    fixed-length >=0.2.1 && <0.3,     containers >=0.1 && <0.7,     enumset >=0.0.5 && <0.1,+    storable-record >=0.0.5 && <0.1,     storable-enum >=0.0 && <0.1,     bool8 >=0.0 && <0.1,     transformers >=0.1.1 && <0.6,     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-orphans >= 0.5 && <1,     base >=3 && <5    Default-Language: Haskell98@@ -87,10 +96,11 @@     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.Control     LLVM.Extra.Array     LLVM.Extra.Scalar@@ -100,13 +110,14 @@     LLVM.Extra.Iterator     LLVM.Extra.Multi.Iterator     LLVM.Extra.Multi.Value-    LLVM.Extra.Multi.Value.Memory     LLVM.Extra.Multi.Value.Vector     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@@ -152,6 +163,7 @@     llvm-extra,     llvm-tf,     tfp,+    storable-record,     utility-ht >=0.0.1 && <0.1,     base >=3 && <5   Default-Language: Haskell98@@ -159,5 +171,6 @@   Hs-Source-Dirs: test   Main-Is: Main.hs   Other-Modules:+    Test.Storable     Test.Vector     LLVM.Extra.VectorAlt
private/LLVM/Extra/ArithmeticPrivate.hs view
@@ -10,7 +10,6 @@     IsConst, IsPrimitive, IsArithmetic, IsInteger, IsFloating,     getElementPtr, ) -import Foreign.Ptr (Ptr, ) import Data.Word (Word32, ) import Data.Int (Int32, ) @@ -39,14 +38,14 @@ dec x = sub x (valueOf 1)  advanceArrayElementPtr ::-   Value (Ptr a) ->-   CodeGenFunction r (Value (Ptr 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))+   Value (LLVM.Ptr a) ->+   CodeGenFunction r (Value (LLVM.Ptr a)) decreaseArrayElementPtr p =    getElementPtr p (valueOf (-1) :: Value Int32, ())
private/LLVM/Extra/ScalarOrVectorPrivate.hs view
@@ -14,7 +14,7 @@     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)@@ -26,10 +26,12 @@ 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 +50,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
@@ -29,7 +29,7 @@ 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 +58,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
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, )@@ -44,7 +44,7 @@    (TypeNum.Natural n, LLVM.IsFirstClass a, 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..]  {- |
− 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,15 @@ ifThenSelect cond deflt thenCode = do    thenResult <- thenCode    select cond thenResult deflt+++-- * return with better type inference++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,6 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module LLVM.Extra.FastMath ( @@ -36,7 +38,7 @@ import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Multi.Value.Private as MV 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,13 +93,16 @@ getNumber :: flags -> Number flags a -> a getNumber _ (Number a) = a +instance (Tuple.Value a) => Tuple.Value (Number flags a) where+   type ValueOf (Number flags a) = Tuple.ValueOf a+   valueOf = Tuple.valueOf . deconsNumber+ 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)+   phi bb = fmap mvNumber . MV.phi bb . mvDenumber+   addPhi bb a b = MV.addPhi bb (mvDenumber a) (mvDenumber b)  mvNumber :: MV.T a -> MV.T (Number flags a) mvNumber (MV.Cons a) = MV.Cons a@@ -281,12 +286,16 @@    attachMultiVectorFlags $       Monad.lift mvecNumber $ f (mvecDenumber a) (mvecDenumber b) +instance (Tuple.VectorValue n a) => Tuple.VectorValue n (Number flags a) where+   type VectorValueOf n (Number flags a) = Tuple.VectorValueOf n a+   vectorValueOf = Tuple.vectorValueOf . fmap deconsNumber+ 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)+   phi bb = fmap mvecNumber . MultiVector.phi bb . mvecDenumber+   addPhi bb a b = MultiVector.addPhi bb (mvecDenumber a) (mvecDenumber b)    shuffle ks a b =       fmap mvecNumber $ MultiVector.shuffle ks (mvecDenumber a) (mvecDenumber b)    extract k = fmap mvNumber . MultiVector.extract k . mvecDenumber@@ -390,9 +399,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/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,264 @@ {-# 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,+   MV, -import qualified LLVM.Extra.Class as Class-import qualified LLVM.Util.Proxy as LP+   VectorStruct,+   Vector(..),++   with,+   EE.alloca,+   ) where++import qualified LLVM.Extra.Multi.Value as MultiValue+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+   (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)++++class (C a, MultiValue.C a) => MV a where++instance MV Float  where+instance MV Double where+instance MV Word   where+instance MV Word8  where+instance MV Word16 where+instance MV Word32 where+instance MV Word64 where+instance MV Int    where+instance MV Int8   where+instance MV Int16  where+instance MV Int32  where+instance MV Int64  where++instance (Storable a)        => MV (Ptr a)       where+instance (LLVM.IsType a)     => MV (LLVM.Ptr a)  where+instance (LLVM.IsFunction a) => MV (FunPtr a)    where+instance                        MV (StablePtr a) where++instance MV () where++instance+   (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b), MV a, MV b) =>+      MV (a,b) where++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)+    MV a, MV b, MV c) =>+      MV (a,b,c) where +instance+   (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b),+    LLVM.IsSized (Struct c), LLVM.IsSized (Struct d),+    MV a, MV b, MV c, MV d) =>+      MV (a,b,c,d) where -with :: (C a) => a -> (Ptr (Struct a) -> IO b) -> IO b-with a act = alloca LP.Proxy $ \ptr -> poke ptr a >> act ptr -alloca ::-   (LLVM.IsType struct) => LP.Proxy struct -> (Ptr struct -> IO b) -> IO b-alloca proxy = allocaBytes (EE.sizeOf proxy)+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, )@@ -62,7 +60,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 +70,7 @@ -}  fromBool ::-   (Phi z) =>+   (Tuple.Phi z) =>    CodeGenFunction r (Value Bool, a) ->    T r z a fromBool m = do@@ -81,20 +79,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 +107,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 +138,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 +170,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 +185,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 +206,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 +218,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,34 +1,31 @@ {-# 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.Scalar as Scalar import qualified LLVM.Extra.Array as Array+import qualified LLVM.Extra.Tuple as Tuple 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,@@ -37,27 +34,30 @@     CodeGenFunction, )  import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal (d0, d1, d2, )+import qualified Type.Data.Num.Unary as Unary+import Type.Data.Num.Decimal (d0, d1, d2, d3) import Type.Base.Proxy (Proxy(Proxy), )  import Foreign.StablePtr (StablePtr, )-import Foreign.Ptr (FunPtr, Ptr, castPtr, )+import Foreign.Ptr (FunPtr) -import Data.Word (Word8, Word16, Word32, Word64, )+import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.FixedLength as FixedLength+import Data.Tuple.HT (fst3, snd3, thd3, )+import Data.Word (Word8, Word16, Word32, Word64, Word) import Data.Int  (Int8,  Int16,  Int32,  Int64, ) -import qualified Control.Applicative as App-import Control.Monad (ap, )-import Control.Applicative (pure, liftA2, liftA3, )--import Data.Tuple.HT (fst3, snd3, thd3, )+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'+An implementation of both 'Tuple.Value' 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@@ -66,13 +66,13 @@  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+   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    decompose :: Value (Struct llvmValue) -> CodeGenFunction r llvmValue    decompose = decomposeFromLoad load@@ -82,7 +82,7 @@ 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,8 +99,8 @@  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@@ -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,58 @@    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+++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::Word64)+   decompose arr =+      Trav.mapM (decompose <=< LLVM.extractvalue arr) $+      iterateTrav (1+) (0::Word64)++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 +264,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 +272,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,17 +288,12 @@    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, LLVM.IsFirstClass 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)) =>@@ -267,10 +304,12 @@  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 Int    where type Stored Int    = Int    ; 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 Word   where type Stored Word   = Word   ; 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@@ -293,8 +332,8 @@    fromStorable = Array.map fromStorable    toStorable = Array.map toStorable -instance (IsType a) => FirstClass (Ptr a) where-   type Stored (Ptr a) = Ptr a+instance (IsType a) => FirstClass (LLVM.Ptr a) where+   type Stored (LLVM.Ptr a) = LLVM.Ptr a    fromStorable = return; toStorable = return instance (LLVM.IsFunction a) => FirstClass (FunPtr a) where    type Stored (FunPtr a) = FunPtr a@@ -367,48 +406,35 @@       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-+instance (MultiValue.C a, C (Tuple.ValueOf a)) => C (MultiValue.T a) where+   type Struct (MultiValue.T a) = Struct (Tuple.ValueOf a)+   load = fmap MultiValue.Cons . load+   store (MultiValue.Cons a) = store a+   decompose = fmap MultiValue.Cons . decompose+   compose (MultiValue.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+   (TypeNum.Positive n, MultiVector.C a, C (Tuple.VectorValueOf n a)) =>+      C (MultiVector.T n a) where+   type Struct (MultiVector.T n a) = Struct (Tuple.VectorValueOf n a)+   load = fmap MultiVector.Cons . load+   store (MultiVector.Cons a) = store a+   decompose = fmap MultiVector.Cons . decompose+   compose (MultiVector.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 view
@@ -3,12 +3,10 @@ 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 (LLVM.Ptr struct) -> CodeGenFunction r a) ->    Value struct -> CodeGenFunction r a decomposeFromLoad loadStruct struct = do    ptr <- LLVM.alloca@@ -17,7 +15,7 @@  composeFromStore ::    LLVM.IsSized struct =>-   (a -> Value (Ptr struct) -> CodeGenFunction r ()) ->+   (a -> Value (LLVM.Ptr struct) -> CodeGenFunction r ()) ->    a -> CodeGenFunction r (Value struct) composeFromStore storeStruct x = do    ptr <- LLVM.alloca
src/LLVM/Extra/Multi/Iterator.hs view
@@ -9,10 +9,10 @@ import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Iterator as Iter import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.MaybePrivate as Maybe import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Control as C-import LLVM.Extra.Class (undefTuple)  import qualified LLVM.Core as LLVM import LLVM.Core (CodeGenFunction)@@ -67,7 +67,7 @@    -}    enumFromTo from to =       Iter.takeWhileJust $-      Iter.iterate (Maybe.maybeArg undefTuple (succMax to)) (Maybe.just from)+      Iter.iterate (Maybe.maybeArg Tuple.undef (succMax to)) (Maybe.just from)  succMax ::    (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,@@ -77,7 +77,7 @@    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) $+   C.ifThen less (Maybe.nothing Tuple.undef) $       fmap Maybe.just $ MultiValue.succ e  {- |
− 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 view
@@ -7,15 +7,15 @@ 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.Extra.Tuple as Tuple+import qualified LLVM.Extra.MaybePrivate as Maybe  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 qualified Foreign.Storable.Record.Tuple as StoreTuple import Foreign.StablePtr (StablePtr, ) import Foreign.Ptr (Ptr, FunPtr, ) @@ -25,7 +25,7 @@ import Data.Functor (Functor, )  import qualified Data.Tuple.HT as TupleHT-import qualified Data.Tuple as Tuple+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@@ -35,212 +35,239 @@ 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.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 LLVM.Value a)+newtype T a = Cons (Tuple.ValueOf 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 ()+   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 f Bool = f Bool    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive  instance C Float where-   type Repr f Float = f Float    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive  instance C Double where-   type Repr f Double = f Double    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive +instance C Word where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+ instance C Word8 where-   type Repr f Word8 = f Word8    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive  instance C Word16 where-   type Repr f Word16 = f Word16    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive  instance C Word32 where-   type Repr f Word32 = f Word32    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive  instance C Word64 where-   type Repr f Word64 = f Word64    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive  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+   phi = phiPrimitive+   addPhi = addPhiPrimitive +instance C Int where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+ instance C Int8 where-   type Repr f Int8 = f Int8    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive  instance C Int16 where-   type Repr f Int16 = f Int16    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive  instance C Int32 where-   type Repr f Int32 = f Int32    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive  instance C Int64 where-   type Repr f Int64 = f Int64    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive  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+   phi = phiPrimitive+   addPhi = addPhiPrimitive -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)+instance (LLVM.IsType a) => C (LLVM.Ptr a) where    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive +instance C (Ptr a) where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+ 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+   phi = phiPrimitive+   addPhi = addPhiPrimitive  instance C (StablePtr a) where-   type Repr f (StablePtr a) = f (StablePtr a)    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive   consPrimitive ::-   (LLVM.IsConst al, LLVM.Value al ~ Repr LLVM.Value a) =>+   (LLVM.IsConst al, LLVM.Value al ~ Tuple.ValueOf a) =>    al -> T a consPrimitive = Cons . LLVM.valueOf  undefPrimitive, zeroPrimitive ::-   (LLVM.IsType al, LLVM.Value al ~ Repr LLVM.Value a) =>+   (LLVM.IsType al, LLVM.Value al ~ Tuple.ValueOf 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) =>+phiPrimitive ::+   (LLVM.IsFirstClass al, LLVM.Value al ~ Tuple.ValueOf a) =>    LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-phisPrimitive bb (Cons a) = fmap Cons $ Loop.phis bb a+phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a -addPhisPrimitive ::-   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr LLVM.Value a) =>+addPhiPrimitive ::+   (LLVM.IsFirstClass al, LLVM.Value al ~ Tuple.ValueOf a) =>    LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()-addPhisPrimitive bb (Cons a) (Cons b) = Loop.addPhis bb a b+addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b  +consTuple ::+   (Tuple.Value a) =>+   a -> T a+consTuple = Cons . Tuple.valueOf++undefTuple ::+   (Tuple.Value a, Tuple.ValueOf a ~ al, Tuple.Undefined al) =>+   T a+undefTuple = Cons Tuple.undef++zeroTuple ::+   (Tuple.Value a, Tuple.ValueOf a ~ al, Tuple.Zero al) =>+   T a+zeroTuple = Cons Tuple.zero++phiTuple ::+   (Tuple.Value a, Tuple.ValueOf 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 ::+   (Tuple.Value a, Tuple.ValueOf 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 f () = ()    cons = consUnit    undef = undefUnit    zero = zeroUnit-   phis = phisUnit-   addPhis = addPhisUnit+   phi = phiUnit+   addPhi = addPhiUnit -consUnit :: (Repr LLVM.Value a ~ ()) => a -> T a+consUnit :: (Tuple.ValueOf a ~ ()) => a -> T a consUnit _ = Cons () -undefUnit :: (Repr LLVM.Value a ~ ()) => T a+undefUnit :: (Tuple.ValueOf a ~ ()) => T a undefUnit = Cons () -zeroUnit :: (Repr LLVM.Value a ~ ()) => T a+zeroUnit :: (Tuple.ValueOf a ~ ()) => T a zeroUnit = Cons () -phisUnit ::-   (Repr LLVM.Value a ~ ()) =>+phiUnit ::+   (Tuple.ValueOf a ~ ()) =>    LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-phisUnit _bb (Cons ()) = return $ Cons ()+phiUnit _bb (Cons ()) = return $ Cons () -addPhisUnit ::-   (Repr LLVM.Value a ~ ()) =>+addPhiUnit ::+   (Tuple.ValueOf a ~ ()) =>    LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()-addPhisUnit _bb (Cons ()) (Cons ()) = return ()+addPhiUnit _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+   phi = phiPrimitive+   addPhi = addPhiPrimitive  boolPFrom8 :: T Bool8 -> T Bool boolPFrom8 (Cons b) = Cons b@@ -259,20 +286,19 @@ 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+   phi = phiPrimitive+   addPhi = addPhiPrimitive  toEnum ::-   (Repr LLVM.Value w ~ LLVM.Value w) =>+   (Tuple.ValueOf w ~ LLVM.Value w) =>    T w -> T (Enum.T w e) toEnum (Cons w) = Cons w  fromEnum ::-   (Repr LLVM.Value w ~ LLVM.Value w) =>+   (Tuple.ValueOf w ~ LLVM.Value w) =>    T (Enum.T w e) -> T w fromEnum (Cons w) = Cons w @@ -301,34 +327,32 @@   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+   phi = phiPrimitive+   addPhi = addPhiPrimitive   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 =+   phi bb ma =       case splitMaybe ma of-         (b,a) -> Monad.lift2 toMaybe (phis bb b) (phis bb a)-   addPhis bb x y =+         (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)) ->-            addPhis bb xb yb >>-            addPhis bb xa 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)+splitMaybe (Cons (Maybe.Cons b a)) = (Cons b, Cons a)  toMaybe :: T Bool -> T a -> T (Maybe a)-toMaybe (Cons b) (Cons a) = Cons (b,a)+toMaybe (Cons b) (Cons a) = Cons (Maybe.Cons b a)  nothing :: (C a) => T (Maybe a) nothing = toMaybe (cons False) undef@@ -338,52 +362,49 @@   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 =+   phi bb a =       case unzip a of          (a0,a1) ->-            Monad.lift2 zip (phis bb a0) (phis bb a1)-   addPhis bb a b =+            Monad.lift2 zip (phi bb a0) (phi bb a1)+   addPhi bb a b =       case (unzip a, unzip b) of          ((a0,a1), (b0,b1)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1+            addPhi bb a0 b0 >>+            addPhi 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 =+   phi 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 =+            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)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1 >>-            addPhis bb a2 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 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 =+   phi 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 =+            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)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1 >>-            addPhis bb a2 b2 >>-            addPhis bb a3 b3+            addPhi bb a0 b0 >>+            addPhi bb a1 b1 >>+            addPhi bb a2 b2 >>+            addPhi bb a3 b3   fst :: T (a,b) -> T a@@ -396,23 +417,23 @@ curry f a b = f $ zip a b  uncurry :: (T a -> T b -> c) -> (T (a,b) -> c)-uncurry f = Tuple.uncurry f . unzip+uncurry f = Tup.uncurry f . unzip   mapFst :: (T a0 -> T a1) -> T (a0,b) -> T (a1,b)-mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip+mapFst f = Tup.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+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 (Tuple.uncurry zip) . FuncHT.mapFst f . unzip+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 (Tuple.uncurry zip) . FuncHT.mapSnd f . unzip+mapSndF f = fmap (Tup.uncurry zip) . FuncHT.mapSnd f . unzip  swap :: T (a,b) -> T (b,a)-swap = Tuple.uncurry zip . TupleHT.swap . unzip+swap = Tup.uncurry zip . TupleHT.swap . unzip   fst3 :: T (a,b,c) -> T a@@ -463,13 +484,26 @@ unzip4 (Cons (a,b,c,d)) = (Cons a, Cons b, Cons c, Cons d)  +instance (C tuple) => C (StoreTuple.Tuple tuple) where+   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++ 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)+   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 (Cons a) = Cons a@@ -489,19 +523,18 @@   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 =+   phi bb a =       case deconsComplex a of          (a0,a1) ->-            Monad.lift2 consComplex (phis bb a0) (phis bb a1)-   addPhis bb a b =+            Monad.lift2 consComplex (phi bb a0) (phi bb a1)+   addPhi bb a b =       case (deconsComplex a, deconsComplex b) of          ((a0,a1), (b0,b1)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 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)@@ -603,7 +636,7 @@  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)+   compose = Tup.uncurry zip . TupleHT.mapPair (compose, compose)  instance (Decompose pa, Decompose pb) => Decompose (pa,pb) where    decompose (pa,pb) =@@ -646,6 +679,19 @@         (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@@ -663,7 +709,7 @@  instance (Decompose pa) => Decompose (Complex pa) where    decompose (pa:+pb) =-      Tuple.uncurry (:+) .+      Tup.uncurry (:+) .       TupleHT.mapPair (decompose pa, decompose pb) . deconsComplex  type instance Decomposed f (Complex pa) = Complex (Decomposed f pa)@@ -675,44 +721,44 @@   -lift1 :: (Repr LLVM.Value a -> Repr LLVM.Value b) -> T a -> T b+lift1 :: (Tuple.ValueOf a -> Tuple.ValueOf b) -> T a -> T b lift1 f (Cons a) = Cons $ f a  liftM0 ::    (Monad m) =>-   m (Repr LLVM.Value a) ->+   m (Tuple.ValueOf a) ->    m (T a) liftM0 f = Monad.lift Cons f  liftM ::    (Monad m) =>-   (Repr LLVM.Value a -> m (Repr LLVM.Value b)) ->+   (Tuple.ValueOf a -> m (Tuple.ValueOf 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)) ->+   (Tuple.ValueOf a -> Tuple.ValueOf b -> m (Tuple.ValueOf 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)) ->+   (Tuple.ValueOf a -> Tuple.ValueOf b -> Tuple.ValueOf c ->+    m (Tuple.ValueOf 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) => Tuple.Zero (T a) where+   zero = zero -instance (C a) => Class.Undefined (T a) where-   undefTuple = undef+instance (C a) => Tuple.Undefined (T a) where+   undef = undef -instance (C a) => Phi (T a) where-   phis = phis-   addPhis = addPhis+instance (C a) => Tuple.Phi (T a) where+   phi = phi+   addPhi = addPhi   class (C a) => IntegerConstant a where@@ -724,11 +770,13 @@ 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@@ -769,6 +817,11 @@    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@@ -789,6 +842,11 @@    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@@ -841,10 +899,12 @@  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@@ -913,6 +973,12 @@    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@@ -937,6 +1003,12 @@    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@@ -1008,17 +1080,19 @@   class-   (Repr LLVM.Value i ~ LLVM.Value ir,+   (Tuple.ValueOf 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 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 Int8  Int8 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@@ -1027,7 +1101,7 @@   class-   (Repr LLVM.Value a ~ LLVM.Value ar,+   (Tuple.ValueOf a ~ LLVM.Value ar,     LLVM.IsFloating ar, SoV.RationalConstant ar,     LLVM.CmpRet ar, LLVM.IsPrimitive ar) =>       NativeFloating a ar where@@ -1114,10 +1188,12 @@ 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@@ -1161,11 +1237,13 @@ 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@@ -1254,6 +1332,9 @@    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 @@ -1266,6 +1347,9 @@ 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 @@ -1284,11 +1368,19 @@    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
src/LLVM/Extra/Multi/Value/Vector.hs view
@@ -20,6 +20,7 @@ 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 LLVM.Extra.Multi.Vector.Instance (MVVector)  import qualified LLVM.Core as LLVM @@ -34,133 +35,113 @@  cons ::    (TypeNum.Positive n, MultiVector.C a) =>-   LLVM.Vector n a -> MultiValue.T (LLVM.Vector n a)+   LLVM.Vector n a -> MVVector n a cons = Inst.toMultiValue . MultiVector.cons -fst :: MultiValue.T (LLVM.Vector n (a,b)) -> MultiValue.T (LLVM.Vector n a)+fst :: MVVector n (a,b) -> MVVector n a fst = MultiValue.lift1 Tuple.fst -snd :: MultiValue.T (LLVM.Vector n (a,b)) -> MultiValue.T (LLVM.Vector n b)+snd :: MVVector n (a,b) -> MVVector n b snd = MultiValue.lift1 Tuple.snd -swap :: MultiValue.T (LLVM.Vector n (a,b)) -> MultiValue.T (LLVM.Vector n (b,a))+swap :: MVVector n (a,b) -> MVVector 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))+   (MVVector n a0 -> MVVector n a1) ->+   MVVector n (a0,b) -> MVVector 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))+   (MVVector n b0 -> MVVector n b1) ->+   MVVector n (a,b0) -> MVVector 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 :: MVVector n (a,b,c) -> MVVector n a fst3 = MultiValue.lift1 TupleHT.fst3 -snd3 :: MultiValue.T (LLVM.Vector n (a,b,c)) -> MultiValue.T (LLVM.Vector n b)+snd3 :: MVVector n (a,b,c) -> MVVector n b snd3 = MultiValue.lift1 TupleHT.snd3 -thd3 :: MultiValue.T (LLVM.Vector n (a,b,c)) -> MultiValue.T (LLVM.Vector n c)+thd3 :: MVVector n (a,b,c) -> MVVector 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))+   (MVVector n a0 -> MVVector n a1) ->+   MVVector n (a0,b,c) -> MVVector n (a1,b,c) mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3  mapSnd3 ::-   (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))+   (MVVector n b0 -> MVVector n b1) ->+   MVVector n (a,b0,c) -> MVVector n (a,b1,c) mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3  mapThd3 ::-   (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))+   (MVVector n c0 -> MVVector n c1) ->+   MVVector n (a,b,c0) -> MVVector n (a,b,c1) mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3  -zip ::-   MultiValue.T (LLVM.Vector n a) ->-   MultiValue.T (LLVM.Vector n b) ->-   MultiValue.T (LLVM.Vector n (a,b))+zip :: MVVector n a -> MVVector n b -> MVVector 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 :: MVVector n a -> MVVector n b -> MVVector n c -> MVVector n (a,b,c) zip3 (MultiValue.Cons a) (MultiValue.Cons b) (MultiValue.Cons c) =    MultiValue.Cons (a,b,c) -unzip ::-   MultiValue.T (LLVM.Vector n (a,b)) ->-   (MultiValue.T (LLVM.Vector n a),-    MultiValue.T (LLVM.Vector n b))+unzip :: MVVector n (a,b) -> (MVVector n a, MVVector 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 :: MVVector n (a,b,c) -> (MVVector n a, MVVector n b, MVVector n c) unzip3 (MultiValue.Cons (a,b,c)) =    (MultiValue.Cons a, MultiValue.Cons b, MultiValue.Cons c)   extract ::    (TypeNum.Positive n, MultiVector.C a) =>-   LLVM.Value Word32 -> MultiValue.T (LLVM.Vector n a) ->+   LLVM.Value Word32 -> MVVector n a ->    LLVM.CodeGenFunction r (MultiValue.T a) extract k v = MultiVector.extract k (Inst.fromMultiValue v)  insert ::    (TypeNum.Positive n, MultiVector.C a) =>    LLVM.Value Word32 -> MultiValue.T a ->-   MultiValue.T (LLVM.Vector n a) ->-   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n a))+   MVVector n a -> LLVM.CodeGenFunction r (MVVector n a) insert k a = Inst.liftMultiValueM (MultiVector.insert k a)   replicate ::    (TypeNum.Positive n, MultiVector.C a) =>-   MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n a))+   MultiValue.T a -> LLVM.CodeGenFunction r (MVVector 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))+   MVVector n a -> LLVM.CodeGenFunction r (MVVector 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))+   MVVector n a -> LLVM.CodeGenFunction r (MVVector 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]+   MVVector 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))+   MVVector n Bool ->+   MVVector n a -> MVVector n a ->+   LLVM.CodeGenFunction r (MVVector n a) select = Inst.liftMultiValueM3 MultiVector.select  cmp ::    (TypeNum.Positive n, MultiVector.Comparison a) =>    LLVM.CmpPredicate ->-   MultiValue.T (LLVM.Vector n a) -> MultiValue.T (LLVM.Vector n a) ->-   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n Bool))+   MVVector n a -> MVVector n a ->+   LLVM.CodeGenFunction r (MVVector n Bool) cmp = Inst.liftMultiValueM2 . MultiVector.cmp
src/LLVM/Extra/Multi/Vector.hs view
@@ -57,12 +57,9 @@ 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.Extra.Tuple as Tuple -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@@ -72,22 +69,20 @@ 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.Tuple (snd, ) import Data.Maybe (maybe, ) import Data.Ord ((<), )-import Data.Word (Word8, Word16, Word32, Word64, )+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, foldM, fmap, return, (>>), (=<<), ) import Control.Applicative (liftA2, )@@ -97,31 +92,31 @@           fromIntegral, asTypeOf, (-), (+), error, )  -newtype T n a = Cons (Repr (Value n) a)+newtype T n a = Cons (Tuple.VectorValueOf n a) -type Value n = Compose LLVM.Value (LLVM.Vector n)+type Value n a = LLVM.Value (LLVM.Vector n a)   consPrim ::-   (Repr (Value n) a ~ Value n a) =>+   (Tuple.VectorValueOf n a ~ Value n a) =>    LLVM.Value (LLVM.Vector n a) -> T n a-consPrim = Cons . Compose+consPrim = Cons  deconsPrim ::-   (Repr (Value n) a ~ Value n a) =>+   (Tuple.VectorValueOf n a ~ Value n a) =>    T n a -> LLVM.Value (LLVM.Vector n a)-deconsPrim (Cons (Compose a)) = a+deconsPrim (Cons a) = a  -instance (TypeNum.Positive n, C a) => Class.Undefined (T n a) where-   undefTuple = undef+instance (TypeNum.Positive n, C a) => Tuple.Undefined (T n a) where+   undef = undef -instance (TypeNum.Positive n, C a) => Class.Zero (T n a) where-   zeroTuple = zero+instance (TypeNum.Positive n, C a) => Tuple.Zero (T n a) where+   zero = zero -instance (TypeNum.Positive n, C a) => Phi (T n a) where-   phis = phis-   addPhis = addPhis+instance (TypeNum.Positive n, C a) => Tuple.Phi (T n a) where+   phi = phi+   addPhi = addPhi   size :: TypeNum.Positive n => T n a -> Int@@ -148,10 +143,10 @@    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 ::+   phi ::       (TypeNum.Positive n) =>       LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)-   addPhis ::+   addPhi ::       (TypeNum.Positive n) =>       LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r () @@ -171,8 +166,8 @@    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive@@ -181,8 +176,8 @@    cons = consPrimitive . fmap Bool8.toBool    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive@@ -191,8 +186,8 @@    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive@@ -201,18 +196,28 @@    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive +instance C Int where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive+ instance C Int8 where    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive@@ -221,8 +226,8 @@    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive@@ -231,8 +236,8 @@    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive@@ -241,18 +246,28 @@    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive +instance C Word where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive+ instance C Word8 where    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive@@ -261,8 +276,8 @@    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive@@ -271,8 +286,8 @@    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive@@ -281,85 +296,81 @@    cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive    shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive  consPrimitive ::-   (TypeNum.Positive n, LLVM.IsConst al, IsPrimitive al,-    Repr (Value n) a ~ Value n al) =>+   (TypeNum.Positive n,+    LLVM.IsConst al, IsPrimitive al, Tuple.VectorValueOf n a ~ Value n al) =>    LLVM.Vector n al -> T n a-consPrimitive = Cons . Compose . LLVM.valueOf+consPrimitive = Cons . LLVM.valueOf  undefPrimitive ::-   (TypeNum.Positive n, IsPrimitive al,-    Repr (Value n) a ~ Value n al) =>+   (TypeNum.Positive n, IsPrimitive al, Tuple.VectorValueOf n a ~ Value n al) =>    T n a-undefPrimitive = Cons $ Compose $ LLVM.value LLVM.undef+undefPrimitive = Cons $ LLVM.value LLVM.undef  zeroPrimitive ::-   (TypeNum.Positive n, IsPrimitive al,-    Repr (Value n) a ~ Value n al) =>+   (TypeNum.Positive n, IsPrimitive al, Tuple.VectorValueOf n a ~ Value n al) =>    T n a-zeroPrimitive = Cons $ Compose $ LLVM.value LLVM.zero+zeroPrimitive = Cons $ LLVM.value LLVM.zero -phisPrimitive ::-   (TypeNum.Positive n, IsPrimitive al, Repr (Value n) a ~ Value n al) =>+phiPrimitive ::+   (TypeNum.Positive n, IsPrimitive al, Tuple.VectorValueOf 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+phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a -addPhisPrimitive ::-   (TypeNum.Positive n, IsPrimitive al, Repr (Value n) a ~ Value n al) =>+addPhiPrimitive ::+   (TypeNum.Positive n, IsPrimitive al, Tuple.VectorValueOf 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+addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi 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) =>+    Tuple.ValueOf a ~ LLVM.Value al,+    Tuple.VectorValueOf n a ~ Value n al,+    Tuple.VectorValueOf 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+shufflePrimitive k (Cons u) (Cons v) =+   fmap Cons $ 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) =>+    Tuple.ValueOf a ~ LLVM.Value al,+    Tuple.VectorValueOf n a ~ Value n al) =>    LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)-extractPrimitive k (Cons (Compose v)) =+extractPrimitive k (Cons 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) =>+    Tuple.ValueOf a ~ LLVM.Value al,+    Tuple.VectorValueOf 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+insertPrimitive k (MultiValue.Cons a) (Cons v) =+   fmap Cons $ LLVM.insertelement v a k   instance (C a, C b) => C (a,b) where-   cons v = zip (cons (fst <$> v)) (cons (snd <$> v))+   cons v = case FuncHT.unzip v of (a,b) -> zip (cons a) (cons b)    undef = zip undef undef    zero = zip zero zero -   phis bb a =+   phi bb a =       case unzip a of          (a0,a1) ->-            Monad.lift2 zip (phis bb a0) (phis bb a1)-   addPhis bb a b =+            Monad.lift2 zip (phi bb a0) (phi bb a1)+   addPhi bb a b =       case (unzip a, unzip b) of          ((a0,a1), (b0,b1)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1+            addPhi bb a0 b0 >>+            addPhi bb a1 b1     shuffle is u v =       case (unzip u, unzip v) of@@ -384,20 +395,20 @@   instance (C a, C b, C c) => C (a,b,c) where-   cons v = zip3 (cons (fst3 <$> v)) (cons (snd3 <$> v)) (cons (thd3 <$> v))+   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 -   phis bb a =+   phi 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 =+            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)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1 >>-            addPhis bb a2 b2+            addPhi bb a0 b0 >>+            addPhi bb a1 b1 >>+            addPhi bb a2 b2     shuffle is u v =       case (unzip3 u, unzip3 v) of@@ -434,10 +445,12 @@  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@@ -445,18 +458,18 @@  fromIntegerPrimitive ::    (TypeNum.Positive n, IsPrimitive a, SoV.IntegerConstant a,-    Repr (Value n) a ~ Value n a) =>+    Tuple.VectorValueOf n a ~ Value n a) =>    Integer -> T n a-fromIntegerPrimitive = Cons . Compose . LLVM.value . SoV.constFromInteger+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 (Value n) a ~ Value n a) =>+    Tuple.VectorValueOf n a ~ Value n a) =>    Rational -> T n a-fromRationalPrimitive = Cons . Compose . LLVM.value . SoV.constFromRational+fromRationalPrimitive = Cons . LLVM.value . SoV.constFromRational  instance    (TypeNum.Positive n, IntegerConstant a) =>@@ -520,7 +533,7 @@    (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+iterate f x = fmap snd $ iterateCore f x Tuple.undef  iterateCore ::    (TypeNum.Positive n, C a) =>@@ -694,45 +707,45 @@ 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 :: (Tuple.VectorValueOf n a -> Tuple.VectorValueOf n b) -> T n a -> T n b lift1 f (Cons a) = Cons $ f a  _liftM0 ::    (Monad m) =>-   m (Repr (Value n) a) ->+   m (Tuple.VectorValueOf n a) ->    m (T n a) _liftM0 f = Monad.lift Cons f  liftM0 ::    (Monad m,-    Repr (Value n) a ~ Value n a) =>+    Tuple.VectorValueOf 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) =>+    Tuple.VectorValueOf n a ~ Value n a,+    Tuple.VectorValueOf 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) =>+    Tuple.VectorValueOf n a ~ Value n a,+    Tuple.VectorValueOf n b ~ Value n b,+    Tuple.VectorValueOf 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) =>+    Tuple.VectorValueOf n a ~ Value n a,+    Tuple.VectorValueOf n b ~ Value n b,+    Tuple.VectorValueOf n c ~ Value n c,+    Tuple.VectorValueOf 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 =@@ -757,6 +770,9 @@ 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 @@ -769,6 +785,9 @@ 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 @@ -933,10 +952,12 @@ 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@@ -969,10 +990,12 @@  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@@ -1041,6 +1064,9 @@    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 @@ -1052,6 +1078,9 @@  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
src/LLVM/Extra/Multi/Vector/Instance.hs view
@@ -5,13 +5,11 @@  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 -import Data.Functor.Compose (Compose, ) import Data.Functor ((<$>), )  import Prelude2010@@ -50,12 +48,11 @@ 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)+   phi = liftMultiValueM . Vector.phi+   addPhi bb x y = Vector.addPhi bb (fromMultiValue x) (fromMultiValue y)  instance    (TypeNum.Positive n, Vector.IntegerConstant a) =>
− 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/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
@@ -49,7 +49,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 +228,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 +256,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 +266,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@@ -302,10 +308,12 @@    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 Word   where scale = LLVM.mul; scaleConst = LLVM.mul 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 Int    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@@ -322,10 +330,12 @@ 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,47 @@+{- |+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(..),++   -- * MultiValue support+   Store.loadMultiValue,+   Store.storeMultiValue,+   Store.storeNextMultiValue,+   Store.modifyMultiValue,++   -- * 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,75 @@+{-# LANGUAGE TypeFamilies #-}+{- |+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.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.C 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.C a, Value (Ptr a) ~ ptrA,+    Storable.C 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.C 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.C a, Value (Ptr a) ~ ptrA,+    Storable.C 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,499 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module LLVM.Extra.Storable.Private where++import qualified LLVM.Extra.Multi.Value as MultiValue+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+++loadMultiValue ::+   (C a) => Value (Ptr a) -> CodeGenFunction r (MultiValue.T a)+loadMultiValue ptr = fmap MultiValue.Cons $ load ptr++storeMultiValue ::+   (C a) => MultiValue.T a -> Value (Ptr a) -> CodeGenFunction r ()+storeMultiValue (MultiValue.Cons a) ptr = store a ptr++storeNextMultiValue ::+   (C a) => MultiValue.T a -> Value (Ptr a) -> CodeGenFunction r (Value (Ptr a))+storeNextMultiValue (MultiValue.Cons a) ptr =+   store a ptr >> incrementPtr ptr++modifyMultiValue ::+   (C a) =>+   (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) ->+   Value (Ptr a) -> CodeGenFunction r ()+modifyMultiValue f ptr =+   flip storeMultiValue ptr =<< f =<< loadMultiValue 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, Tuple.ValueOf a ~ al, 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/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,7 +99,7 @@    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 :: *@@ -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@@ -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/Main.hs view
@@ -1,5 +1,6 @@ module Main where +import qualified Test.Storable as Storable import qualified Test.Vector as Vector  import qualified LLVM.Core as LLVM@@ -14,4 +15,6 @@    LLVM.initializeNativeTarget     mapM_ (\(msg,prop) -> putStr (msg++": ") >> prop >>= QC.quickCheck) $-      map (mapFst ("Vector."++)) Vector.tests+      map (mapFst ("Storable."++)) Storable.tests +++      map (mapFst ("Vector."++)) Vector.tests +++      []
+ test/Test/Storable.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TypeFamilies #-}+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