packages feed

llvm-extra 0.5 → 0.6

raw patch · 22 files changed

+2303/−309 lines, 22 filesdep +non-emptydep ~llvm-tfdep ~tfpdep ~transformers

Dependencies added: non-empty

Dependency ranges changed: llvm-tf, tfp, transformers

Files

llvm-extra.cabal view
@@ -1,5 +1,5 @@ Name:           llvm-extra-Version:        0.5+Version:        0.6 License:        BSD3 License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -72,7 +72,7 @@   default:     True  Source-Repository this-  Tag:         0.5+  Tag:         0.6   Type:        darcs   Location:    http://code.haskell.org/~thielema/llvm-extra/ @@ -84,10 +84,11 @@   Build-Depends:     -- llvm must be imported with restrictive version bounds,     -- because we import implicitly and unqualified-    llvm-tf >=3.0 && <3.0.2,-    tfp >=0.7 && <0.9,+    llvm-tf >=3.0.3 && <3.0.4,+    tfp >=1.0 && <1.1,+    non-empty >=0.2.1 && <0.3,     containers >=0.1 && <0.6,-    transformers >=0.1.1 && <0.4,+    transformers >=0.1.1 && <0.5,     utility-ht >=0.0.1 && <0.1    Build-Depends:@@ -118,6 +119,7 @@     LLVM.Extra.Either     LLVM.Extra.Class     LLVM.Extra.Control+    LLVM.Extra.Execution     LLVM.Extra.Extension     LLVM.Extra.Extension.X86     LLVM.Extra.ExtensionCheck.X86@@ -126,12 +128,15 @@     LLVM.Extra.Vector     LLVM.Extra.ScalarOrVector     LLVM.Extra.Multi.Value+    LLVM.Extra.Multi.Value.Memory     LLVM.Extra.Multi.Vector+    LLVM.Extra.Multi.Vector.Memory     LLVM.Extra.Multi.Class   Other-Modules:     LLVM.Extra.ArithmeticPrivate     LLVM.Extra.MaybePrivate     LLVM.Extra.EitherPrivate+    LLVM.Extra.MemoryPrivate     LLVM.Extra.Extension.X86Auto  Executable tone-llvm@@ -140,8 +145,9 @@       llvm-extra,       llvm-tf,       tfp,+      non-empty,       containers >=0.1 && <0.6,-      transformers >=0.1.1 && <0.4,+      transformers,       utility-ht >=0.0.1 && <0.1,       base >=3 && <5   Else@@ -155,7 +161,7 @@     Build-Depends:       parsec >=2.1 && <3.2,       containers >=0.1 && <0.6,-      transformers >=0.1.1 && <0.4,+      transformers,       utility-ht >=0.0.1 && <0.1,       base >=3 && <5   Else
src/Array.hs view
@@ -16,11 +16,15 @@ import LLVM.ExecutionEngine (simpleFunction, ) import qualified System.IO as IO -import Types.Data.Num(D4, )+import Type.Data.Num.Decimal(D4, ) import Data.Word (Word32, ) import qualified Foreign.Storable as St import Foreign.Marshal.Array (allocaArray, )+import Foreign.Ptr (Ptr, ) +import qualified Data.Empty as Empty+import Data.NonEmpty ((!:), )+ import Control.Monad.Trans.State (StateT(StateT), runStateT, ) import Control.Monad (liftM2, ) @@ -107,7 +111,9 @@ mixGeneric :: Value (Vector D4 Float) -> CodeGenFunction r (Value Float) mixGeneric y = do     -- that is translated to movhlps-    y23 <- shufflevector y (value undef) (constVector [constOf 2, constOf 3, undef, undef])+    y23 <-+       shufflevector y (value undef)+          (constVector $ constOf 2 !: constOf 3 !: undef !: undef !: Empty.Cons)     z <- A.add y y23     s0 <- extractelement z (valueOf 0)     s1 <- extractelement z (valueOf 1)
src/LLVM/Extra/Arithmetic.hs view
@@ -10,24 +10,26 @@    IntegerConstant(fromInteger'),    RationalConstant(fromRational'),    idiv, irem,-   fcmp, cmp, LLVM.CmpPredicate(..),-   and, or,+   FloatingComparison(fcmp), Comparison(cmp),+   CmpResult, LLVM.CmpPredicate(..),+   Logic (and, or, xor, inv),    Real (min, max, abs, signum),    Fraction (truncate, fraction),    signedFraction, addToPhase, incPhase,    -- * pointer arithmetic    advanceArrayElementPtr,+   decreaseArrayElementPtr,    -- * transcendental functions    Algebraic (sqrt),    Transcendental (pi, sin, cos, exp, log, pow),    ) where  import LLVM.Extra.ArithmeticPrivate-   (cmp, fcmp, and, or,-    inc, dec, advanceArrayElementPtr, )+   (inc, dec, advanceArrayElementPtr, decreaseArrayElementPtr, )  import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Util.Proxy as LP import qualified LLVM.Core as LLVM import LLVM.Core    (CodeGenFunction, value, Value, ConstValue,@@ -227,12 +229,54 @@    signedFraction =<< add d p  +class Comparison a where+   type CmpResult a :: *+   cmp :: LLVM.CmpPredicate -> a -> a -> CodeGenFunction r (CmpResult a) +instance (LLVM.CmpRet a) => Comparison (Value a) where+   type CmpResult (Value a) = Value (LLVM.CmpResult a)+   cmp = LLVM.cmp++instance (LLVM.CmpRet a) => Comparison (ConstValue a) where+   type CmpResult (ConstValue a) = ConstValue (LLVM.CmpResult a)+   cmp = LLVM.cmp+++class (Comparison a) => FloatingComparison a where+   fcmp :: LLVM.FPPredicate -> a -> a -> CodeGenFunction r (CmpResult a)++instance (IsFloating a, LLVM.CmpRet a) => FloatingComparison (Value a) where+   fcmp = LLVM.fcmp++instance (IsFloating a, LLVM.CmpRet a) => FloatingComparison (ConstValue a) where+   fcmp = LLVM.fcmp++++class Logic a where+   and :: a -> a -> CodeGenFunction r a+   or :: a -> a -> CodeGenFunction r a+   xor :: a -> a -> CodeGenFunction r a+   inv :: a -> CodeGenFunction r a++instance (LLVM.IsInteger a) => Logic (Value a) where+   and = LLVM.and+   or = LLVM.or+   xor = LLVM.xor+   inv = LLVM.inv++instance (LLVM.IsInteger a) => Logic (ConstValue a) where+   and = LLVM.and+   or = LLVM.or+   xor = LLVM.xor+   inv = LLVM.inv++ valueTypeName ::    (IsType a) =>    Value a -> String valueTypeName =-   LLVM.intrinsicTypeName . (undefined :: Value a -> a)+   LLVM.intrinsicTypeName . ((\_ -> LP.Proxy) :: Value a -> LP.Proxy a)   callIntrinsic1 ::
src/LLVM/Extra/ArithmeticPrivate.hs view
@@ -6,9 +6,11 @@    (CodeGenFunction, valueOf, Value,     CmpPredicate(CmpLE, CmpGE), FPPredicate, CmpRet, CmpResult,     IsConst, IsFirstClass, IsArithmetic, IsInteger, IsFloating,-    Ptr, getElementPtr, )+    getElementPtr, ) +import Foreign.Ptr (Ptr, ) import Data.Word (Word32, )+import Data.Int (Int32, )  import Prelude hiding (and, or, sqrt, sin, cos, exp, log, abs, min, max, ) @@ -39,6 +41,12 @@    CodeGenFunction r (Value (Ptr a)) advanceArrayElementPtr p =    getElementPtr p (valueOf 1 :: Value Word32, ())++decreaseArrayElementPtr ::+   Value (Ptr a) ->+   CodeGenFunction r (Value (Ptr a))+decreaseArrayElementPtr p =+   getElementPtr p (valueOf (-1) :: Value Int32, ())
src/LLVM/Extra/Array.hs view
@@ -10,9 +10,10 @@ import qualified LLVM.Core as LLVM import LLVM.Core (Value, Array, CodeGenFunction, ) -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import Control.Monad.HT ((<=<), ) import Control.Monad (foldM, )+ import qualified Data.List as List  import Data.Word (Word32, )@@ -25,12 +26,12 @@ -- * target independent functions  size ::-   (TypeNum.NaturalT n) =>+   (TypeNum.Natural n) =>    Value (Array n a) -> Int size =-   let sz :: (TypeNum.NaturalT n) => n -> Value (Array n a) -> Int-       sz n _ = TypeNum.fromIntegerT n-   in  sz undefined+   let sz :: (TypeNum.Natural n) => TypeNum.Singleton n -> Value (Array n a) -> Int+       sz n _ = TypeNum.integralFromSingleton n+   in  sz TypeNum.singleton  {- | construct an array out of single elements@@ -40,7 +41,7 @@ This can be considered the inverse of 'extractAll'. -} assemble ::-   (TypeNum.NaturalT n, LLVM.IsFirstClass a, LLVM.IsSized a) =>+   (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 .@@ -52,7 +53,7 @@ This can be considered the inverse of 'assemble'. -} extractAll ::-   (TypeNum.NaturalT n, LLVM.IsFirstClass a, LLVM.IsSized a) =>+   (TypeNum.Natural n, LLVM.IsFirstClass a, LLVM.IsSized a) =>    Value (Array n a) -> LLVM.CodeGenFunction r [Value a] extractAll x =    mapM@@ -64,7 +65,7 @@ since 'LLVM.insertvalue' and 'LLVM.extractvalue' expect constant indices. -} map ::-   (TypeNum.NaturalT n,+   (TypeNum.Natural n,     LLVM.IsFirstClass a, LLVM.IsSized a,     LLVM.IsFirstClass b, LLVM.IsSized b) =>    (Value a -> CodeGenFunction r (Value b)) ->
src/LLVM/Extra/Class.hs view
@@ -12,7 +12,7 @@     IsConst, IsType, IsFirstClass, IsPrimitive,     CodeGenFunction, BasicBlock, ) import LLVM.Util.Loop (Phi, phis, addPhis, )-import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum  import Control.Applicative (pure, liftA2, ) import qualified Control.Applicative as App@@ -20,7 +20,7 @@ import qualified Data.Traversable as Trav  import Foreign.StablePtr (StablePtr, )-import Foreign.Ptr (Ptr, )+import Foreign.Ptr (FunPtr, Ptr, )  import Data.Word (Word8, Word16, Word32, Word64, ) import Data.Int  (Int8,  Int16,  Int32,  Int64, )@@ -132,9 +132,13 @@ 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))+   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@@ -149,7 +153,7 @@ instance (Pos n) => MakeValueTuple (WordN n) where    type ValueTuple (WordN n) = (Value (WordN n)) -}-instance (TypeNum.PositiveT n, IsPrimitive a, IsConst a) =>+instance (TypeNum.Positive n, IsPrimitive a, IsConst a) =>          MakeValueTuple (Vector n a) where    type ValueTuple (Vector n a) = Value (Vector n a)    valueTupleOf = valueOf
src/LLVM/Extra/Control.hs view
@@ -22,16 +22,18 @@    (cmp, sub, dec, advanceArrayElementPtr, ) import qualified LLVM.Extra.ArithmeticPrivate as A import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (Phi, phis, addPhis, ) import LLVM.Core    (getCurrentBasicBlock, newBasicBlock, defineBasicBlock,     br, condBr,-    Ptr, Value, value, valueOf,+    Value, value, valueOf,     phi, addPhiInputs,     CmpPredicate(CmpGT), CmpRet, CmpResult,     IsInteger, IsType, IsConst, IsFirstClass,     CodeGenFunction,     CodeGenModule, newModule, defineModule, writeBitcodeToFile, )-import LLVM.Util.Loop (Phi, phis, addPhis, )++import Foreign.Ptr (Ptr, )  import qualified Control.Applicative as App import qualified Data.Traversable as Trav
+ src/LLVM/Extra/Execution.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.Execution where++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM++import Foreign.Ptr (FunPtr, )++import Control.Monad (liftM2, liftM3, )+++class Compile externFunction where+   type LLVMFunction externFunction :: *+   compile :: LLVMFunction externFunction -> EE.EngineAccess externFunction++instance Compile (FunPtr f) where+   type LLVMFunction (FunPtr f) = (LLVM.Function f)+   compile = EE.getPointerToFunction++instance (Compile fa, Compile fb) => Compile (fa,fb) where+   type LLVMFunction (fa,fb) = (LLVMFunction fa, LLVMFunction fb)+   compile (fa,fb) =+      liftM2 (,)+         (compile fa)+         (compile fb)++instance (Compile fa, Compile fb, Compile fc) => Compile (fa,fb,fc) where+   type LLVMFunction (fa,fb,fc) = (LLVMFunction fa, LLVMFunction fb, LLVMFunction fc)+   compile (fa,fb,fc) =+      liftM3 (,,)+         (compile fa)+         (compile fb)+         (compile fc)
src/LLVM/Extra/Extension/X86.hs view
@@ -51,16 +51,20 @@ import qualified LLVM.Extra.ArithmeticPrivate as A import qualified LLVM.Core as LLVM import LLVM.Core-   (Value, Vector, value, valueOf, constOf, constVector,+   (Value, Vector, valueOf, constOf, vector,     CodeGenFunction, FPPredicate, ) -import qualified Types.Data.Bool as TypeBool-import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum +import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.Empty as Empty+import Data.NonEmpty ((!:), )+ import Data.Bits (clearBit, complement, ) import Data.Word (Word8, Word32, Word64, )  import Control.Monad.HT ((<=<), )+import Control.Applicative (pure, )  import Foreign.Ptr (Ptr, ) @@ -68,7 +72,7 @@ switchFPPred ::    (Num i, LLVM.IsConst i, LLVM.IsInteger i, LLVM.IsPrimitive i,     LLVM.IsFirstClass v,-    TypeNum.PositiveT n,+    TypeNum.Positive n,     LLVM.IsSized v, LLVM.IsSized (Vector n i),     LLVM.SizeOf v ~ LLVM.SizeOf (Vector n i)) =>    (Value v -> Value v -> Value Word8 -> CodeGenFunction r (Value v)) ->@@ -91,7 +95,7 @@           LLVM.FPULT   -> f 6 y x           LLVM.FPULE   -> f 5 y x           LLVM.FPUNE   -> f 4 x y-          LLVM.FPT     -> return (LLVM.value (LLVM.constVector [LLVM.constOf (-1)]))+          LLVM.FPT     -> return (valueOf $ pure (-1))  cmpss :: Ext.T (FPPredicate -> V4Float -> V4Float -> CodeGenFunction r V4Int32) cmpss = fmap switchFPPred X86.cmpss@@ -126,7 +130,7 @@   pcmpuFromPcmp ::-   (TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True,+   (TypeNum.Positive n,     LLVM.IsPrimitive s,     LLVM.IsPrimitive u, LLVM.IsArithmetic u, LLVM.IsConst u,     Bounded u, Integral u,@@ -136,7 +140,7 @@    Ext.T (Value (Vector n u) -> Value (Vector n u) -> CodeGenFunction r (Value (Vector n u))) pcmpuFromPcmp pcmp =    Ext.with pcmp $ \cmp x y -> do-      let offset = value (constVector [constOf (1 + div maxBound 2)])+      let offset = valueOf $ pure (1 + div maxBound 2)       xa <- LLVM.bitcast =<< A.sub x offset       ya <- LLVM.bitcast =<< A.sub y offset       LLVM.bitcast =<< cmp xa ya@@ -276,7 +280,8 @@ absss =    Ext.wrap sse1 $    LLVM.bitcast-     <=< A.and (LLVM.value $ constVector $ map constOf $ (flip clearBit 31 $ complement 0) : repeat (complement 0)+     <=< A.and (LLVM.valueOf $ vector $+           (flip clearBit 31 $ complement 0) !: NonEmptyC.repeat (complement 0)             :: V4Word32)      <=< LLVM.bitcast @@ -307,19 +312,20 @@ abssd =    Ext.wrap sse2 $    LLVM.bitcast-     <=< A.and (LLVM.value $ constVector $ map constOf $ (flip clearBit 63 $ complement 0) : repeat (complement 0)+     <=< A.and (LLVM.valueOf $ vector $+            (flip clearBit 63 $ complement 0) !: complement 0 !: Empty.Cons             :: V2Word64)      <=< LLVM.bitcast   mask ::-   (TypeNum.PositiveT n, LLVM.IsConst w, LLVM.IsPrimitive w, LLVM.IsInteger w) =>+   (TypeNum.Positive n, LLVM.IsConst w, LLVM.IsPrimitive w, LLVM.IsInteger w) =>    w -> Value (Vector n w) -> CodeGenFunction r (Value (Vector n w)) mask x =-   A.and (LLVM.value $ constVector [constOf x])+   A.and (LLVM.valueOf $ pure x)  absps ::-   (TypeNum.PositiveT n) =>+   (TypeNum.Positive n) =>    Ext.T (Value (Vector n Float) -> CodeGenFunction r (Value (Vector n Float))) absps =    Ext.wrap sse1 $@@ -328,7 +334,7 @@      <=< LLVM.bitcastElements  abspd ::-   (TypeNum.PositiveT n) =>+   (TypeNum.Positive n) =>    Ext.T (Value (Vector n Double) -> CodeGenFunction r (Value (Vector n Double))) abspd =    Ext.wrap sse2 $@@ -347,7 +353,7 @@ _cumulate1s = Ext.with X86.haddps $ \haddp x -> do    y <- haddp x (LLVM.value LLVM.undef)    z <- LLVM.shufflevector x y $-      constVector $ map constOf [0,4,2,5]+      constOf $ vector $ 0!:4!:2!:5!:Empty.Cons    offset <- LLVM.shufflevector y (LLVM.value LLVM.zero) $-      constVector $ map constOf [4,5,0,0]+      constOf $ vector $ 4!:5!:0!:0!:Empty.Cons    A.add z offset
src/LLVM/Extra/Extension/X86Auto.hs view
@@ -4,7 +4,7 @@ import qualified LLVM.Extra.Extension as Ext import qualified LLVM.Extra.ExtensionCheck.X86 as ExtX86 import qualified LLVM.Core as LLVM-import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import qualified Data.Int as I import qualified Data.Word as W import Foreign.Ptr (Ptr, )
src/LLVM/Extra/MaybeContinuation.hs view
@@ -13,16 +13,17 @@ import qualified LLVM.Core as LLVM import LLVM.Core    (Value, value, valueOf,-    CodeGenFunction, Ptr,+    CodeGenFunction,     IsConst, IsType, IsFirstClass, IsInteger,     CmpRet, CmpResult, ) import LLVM.Util.Loop (Phi, ) -- (phis, addPhis, ) -import Control.Monad.IO.Class (MonadIO(liftIO), )-import qualified Control.Applicative as App 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, )
src/LLVM/Extra/Memory.hs view
@@ -13,26 +13,35 @@    ) 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.Either as Either import qualified LLVM.Extra.Maybe as Maybe +import qualified LLVM.Util.Proxy as LP import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (Phi, ) import LLVM.Core    (getElementPtr0,     extractvalue, insertvalue,     Value, -- valueOf, Vector,     IsType, IsSized,     CodeGenFunction, )-import LLVM.Util.Loop (Phi, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num (d0, d1, d2, )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (d0, d1, d2, )+import Type.Base.Proxy (Proxy(Proxy), )  import Foreign.StablePtr (StablePtr, )-import Foreign.Ptr (Ptr, castPtr, )+import Foreign.Ptr (FunPtr, Ptr, castPtr, )  import Data.Word (Word8, Word16, Word32, Word64, ) import Data.Int  (Int8,  Int16,  Int32,  Int64, )@@ -58,13 +67,16 @@ -} class (Phi llvmValue, 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 ptr  =  decompose =<< LLVM.load ptr    store :: llvmValue -> Value (Ptr (Struct llvmValue)) -> CodeGenFunction r ()    store r ptr  =  flip LLVM.store ptr =<< compose r    decompose :: Value (Struct llvmValue) -> CodeGenFunction r llvmValue+   decompose = decomposeFromLoad load    compose :: llvmValue -> CodeGenFunction r (Value (Struct llvmValue))+   compose = composeFromStore store  modify ::    (C llvmValue) =>@@ -74,6 +86,14 @@    flip store ptr =<< f =<< load ptr  +instance C () where+   type Struct () = LLVM.Struct ()+   load _ = return ()+   store _ _ = return ()+   decompose _ = return ()+   compose _ = return (LLVM.value $ LLVM.constStruct ())++ type Record r o v = Element r o v v  data Element r o v x =@@ -217,6 +237,14 @@   +instance (C a) => C (Scalar.T a) where+   type Struct (Scalar.T a) = Struct a+   load = loadNewtype Scalar.Cons+   store = storeNewtype Scalar.decons+   decompose = decomposeNewtype Scalar.Cons+   compose = composeNewtype Scalar.decons++ {- This would not work for Booleans, since on x86 LLVM's @i1@ type uses one byte in memory,@@ -251,13 +279,13 @@    fromStorable = A.cmp LLVM.CmpNE (LLVM.value LLVM.zero)    toStorable = LLVM.zext instance-   (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsPrimitive (Stored a), FirstClass a) =>+   (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsPrimitive (Stored a), FirstClass a) =>       FirstClass (LLVM.Vector n a) where    type Stored (LLVM.Vector n a) = LLVM.Vector n (Stored a)    fromStorable = Vector.map fromStorable    toStorable = Vector.map toStorable instance-   (TypeNum.NaturalT n, LLVM.IsFirstClass (Stored a),+   (TypeNum.Natural n, LLVM.IsFirstClass (Stored a),     FirstClass a, IsSized a, IsSized (Stored a)) =>       FirstClass (LLVM.Array n a) where    type Stored (LLVM.Array n a) = LLVM.Array n (Stored a)@@ -267,6 +295,9 @@ instance (IsType a) => FirstClass (Ptr a) where    type Stored (Ptr a) = Ptr a    fromStorable = return; toStorable = return+instance (LLVM.IsFunction a) => FirstClass (FunPtr a) where+   type Stored (FunPtr a) = FunPtr a+   fromStorable = return; toStorable = return instance FirstClass (StablePtr a) where    type Stored (StablePtr a) = StablePtr a    fromStorable = return; toStorable = return@@ -279,7 +310,7 @@       FirstClass (LLVM.Struct s) where    type Stored (LLVM.Struct s) = LLVM.Struct (StoredStruct s)    fromStorable sm =-      case undefined of+      case LP.Proxy of          sfields -> do             s <- decomposeField sfields d0 sm             let _ = asTypeOf (fields s) sfields@@ -287,39 +318,43 @@    toStorable s =       composeField (fields s) d0 s -fields :: Value (LLVM.Struct s) -> s-fields _ = undefined+fields :: Value (LLVM.Struct s) -> LP.Proxy s+fields _ = LP.Proxy   type family StoredStruct s :: * type instance StoredStruct () = () type instance StoredStruct (s,rem) = (Stored s, StoredStruct rem) -class-   ConvertStruct s i rem where+class ConvertStruct s i rem where    decomposeField ::-      rem -> i -> Value (LLVM.Struct (StoredStruct s)) ->+      LP.Proxy rem -> Proxy i -> Value (LLVM.Struct (StoredStruct s)) ->       CodeGenFunction r (Value (LLVM.Struct s))    composeField ::-      rem -> i -> Value (LLVM.Struct s) ->+      LP.Proxy rem -> Proxy i -> Value (LLVM.Struct s) ->       CodeGenFunction r (Value (LLVM.Struct (StoredStruct s)))  instance    (sm ~ StoredStruct s,-    LLVM.GetValue (LLVM.Struct s) i, LLVM.ValueType (LLVM.Struct s) i ~ a,-    LLVM.GetValue (LLVM.Struct sm) i, LLVM.ValueType (LLVM.Struct sm) i ~ am,     FirstClass a, am ~ Stored a,+    LLVM.GetValue (LLVM.Struct s) (Proxy i),+    LLVM.GetValue (LLVM.Struct sm) (Proxy i),+    LLVM.ValueType (LLVM.Struct s) (Proxy i) ~ a,+    LLVM.ValueType (LLVM.Struct sm) (Proxy i) ~ am,     ConvertStruct s (TypeNum.Succ i) rem) =>       ConvertStruct s i (a,rem) where-   decomposeField ~(_,rem_) i sm = do-      s <- decomposeField rem_ (TypeNum.succT i) sm+   decomposeField flds i sm = do+      s <- decomposeField (fmap snd flds) (decSucc i) sm       a <- fromStorable =<< LLVM.extractvalue sm i       LLVM.insertvalue s a i-   composeField ~(_,rem_) i s = do-      sm <- composeField rem_ (TypeNum.succT i) s+   composeField flds i s = do+      sm <- composeField (fmap snd flds) (decSucc i) s       am <- toStorable =<< LLVM.extractvalue s i       LLVM.insertvalue sm am i +decSucc :: Proxy n -> Proxy (TypeNum.Succ n)+decSucc Proxy = Proxy+ instance    (sm ~ StoredStruct s,     IsType (LLVM.Struct s),@@ -337,12 +372,21 @@    compose = toStorable  -instance C () where-   type Struct () = LLVM.Struct ()-   load _ = return ()-   store _ _ = return ()-   decompose _ = return ()-   compose _ = return (LLVM.value LLVM.undef)+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+  castStorablePtr ::    (MakeValueTuple haskellValue, C (ValueTuple haskellValue)) =>
+ src/LLVM/Extra/MemoryPrivate.hs view
@@ -0,0 +1,25 @@+module LLVM.Extra.MemoryPrivate where++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, Value, )++import Foreign.Ptr (Ptr, )+++decomposeFromLoad ::+   LLVM.IsSized struct =>+   (Value (Ptr struct) -> CodeGenFunction r a) ->+   Value struct -> CodeGenFunction r a+decomposeFromLoad loadStruct struct = do+   ptr <- LLVM.alloca+   LLVM.store struct ptr+   loadStruct ptr++composeFromStore ::+   LLVM.IsSized struct =>+   (a -> Value (Ptr struct) -> CodeGenFunction r ()) ->+   a -> CodeGenFunction r (Value struct)+composeFromStore storeStruct x = do+   ptr <- LLVM.alloca+   storeStruct x ptr+   LLVM.load ptr
src/LLVM/Extra/Multi/Class.hs view
@@ -4,11 +4,10 @@ import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Class as Class  import qualified LLVM.Core as LLVM -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum   class C value where@@ -22,37 +21,149 @@    type Size MultiValue.T = TypeNum.D1    switch x _ = x -instance (TypeNum.PositiveT n) => C (MultiVector.T n) where+instance (TypeNum.Positive n) => C (MultiVector.T n) where    type Size (MultiVector.T n) = n    switch _ x = x  -newtype Undef a value = Undef {getUndef :: value a}+newtype Const a value = Const {getConst :: value a}  undef ::-   (C value, Size value ~ n, TypeNum.PositiveT n,-    Class.MakeValueTuple a, MultiVector.C a) =>+   (C value, Size value ~ n, TypeNum.Positive n, MultiVector.C a) =>    value a undef =-   getUndef $+   getConst $    switch-      (Undef MultiValue.undef)-      (Undef MultiVector.undef)+      (Const MultiValue.undef)+      (Const MultiVector.undef) +zero ::+   (C value, Size value ~ n, TypeNum.Positive n, MultiVector.C a) =>+   value a+zero =+   getConst $+   switch+      (Const MultiValue.zero)+      (Const MultiVector.zero) + newtype-   Add r a value =-      Add {runAdd :: value a -> value a -> LLVM.CodeGenFunction r (value a)}+   Op0 r a value =+      Op0 {runOp0 :: LLVM.CodeGenFunction r (value a)} -add ::-   (C value,-    A.Additive al, al ~ Class.ValueTuple a,-    A.Additive vl, vl ~ MultiVector.Vector n a, n ~ Size value) =>+newtype+   Op1 r a b value =+      Op1 {runOp1 :: value a -> LLVM.CodeGenFunction r (value b)}++newtype+   Op2 r a b c value =+      Op2 {runOp2 :: value a -> value b -> LLVM.CodeGenFunction r (value c)}++add, sub ::+   (TypeNum.Positive n, MultiVector.Additive a,+    n ~ Size value, C value) =>    value a -> value a -> LLVM.CodeGenFunction r (value a)-add =-   runAdd $-   switch-      (Add $ \(MultiValue.Cons x) (MultiValue.Cons y) ->-          fmap MultiValue.Cons $ A.add x y)-      (Add $ \(MultiVector.Cons x) (MultiVector.Cons y) ->-          fmap MultiVector.Cons $ A.add x y)+add = runOp2 $ switch (Op2 A.add) (Op2 A.add)+sub = runOp2 $ switch (Op2 A.sub) (Op2 A.sub)++neg ::+   (TypeNum.Positive n, MultiVector.Additive a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+neg = runOp1 $ switch (Op1 A.neg) (Op1 A.neg)+++mul ::+   (TypeNum.Positive n, MultiVector.PseudoRing a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+mul = runOp2 $ switch (Op2 A.mul) (Op2 A.mul)+fdiv ::+   (TypeNum.Positive n, MultiVector.Field a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+fdiv = runOp2 $ switch (Op2 A.fdiv) (Op2 A.fdiv)++scale ::+   (TypeNum.Positive n, MultiVector.PseudoModule v,+    n ~ Size value, C value) =>+   value (MultiValue.Scalar v) -> value v -> LLVM.CodeGenFunction r (value v)+scale = runOp2 $ switch (Op2 A.scale) (Op2 A.scale)++min, max ::+   (TypeNum.Positive n, MultiVector.Real a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+min = runOp2 $ switch (Op2 A.min) (Op2 A.min)+max = runOp2 $ switch (Op2 A.max) (Op2 A.max)++abs, signum ::+   (TypeNum.Positive n, MultiVector.Real a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+abs = runOp1 $ switch (Op1 A.abs) (Op1 A.abs)+signum = runOp1 $ switch (Op1 A.signum) (Op1 A.signum)++truncate, fraction ::+   (TypeNum.Positive n, MultiVector.Fraction a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+truncate = runOp1 $ switch (Op1 A.truncate) (Op1 A.truncate)+fraction = runOp1 $ switch (Op1 A.fraction) (Op1 A.fraction)++sqrt ::+   (TypeNum.Positive n, MultiVector.Algebraic a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+sqrt = runOp1 $ switch (Op1 A.sqrt) (Op1 A.sqrt)++pi ::+   (TypeNum.Positive n, MultiVector.Transcendental a,+    n ~ Size value, C value) =>+   LLVM.CodeGenFunction r (value a)+pi = runOp0 $ switch (Op0 A.pi) (Op0 A.pi)++sin, cos, exp, log ::+   (TypeNum.Positive n, MultiVector.Transcendental a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+sin = runOp1 $ switch (Op1 A.sin) (Op1 A.sin)+cos = runOp1 $ switch (Op1 A.cos) (Op1 A.cos)+exp = runOp1 $ switch (Op1 A.exp) (Op1 A.exp)+log = runOp1 $ switch (Op1 A.log) (Op1 A.log)++pow ::+   (TypeNum.Positive n, MultiVector.Transcendental a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+pow = runOp2 $ switch (Op2 A.pow) (Op2 A.pow)+++cmp ::+   (TypeNum.Positive n, MultiVector.Comparison a,+    n ~ Size value, C value) =>+   LLVM.CmpPredicate ->+   value a -> value a -> LLVM.CodeGenFunction r (value Bool)+cmp p = runOp2 $ switch (Op2 $ A.cmp p) (Op2 $ A.cmp p)++fcmp ::+   (TypeNum.Positive n, MultiVector.FloatingComparison a,+    n ~ Size value, C value) =>+   LLVM.FPPredicate ->+   value a -> value a -> LLVM.CodeGenFunction r (value Bool)+fcmp p = runOp2 $ switch (Op2 $ A.fcmp p) (Op2 $ A.fcmp p)+++and, or, xor ::+   (TypeNum.Positive n, MultiVector.Logic a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+and = runOp2 $ switch (Op2 A.and) (Op2 A.and)+or = runOp2 $ switch (Op2 A.or) (Op2 A.or)+xor = runOp2 $ switch (Op2 A.xor) (Op2 A.xor)++inv ::+   (TypeNum.Positive n, MultiVector.Logic a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+inv = runOp1 $ switch (Op1 A.inv) (Op1 A.inv)
src/LLVM/Extra/Multi/Value.hs view
@@ -1,29 +1,831 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} module LLVM.Extra.Multi.Value where +import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Class as Class -import Prelude hiding (zip, zip3, unzip, unzip3, )+import qualified LLVM.Core as LLVM+import qualified LLVM.Util.Loop as Loop+import LLVM.Util.Loop (Phi, ) +import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (Ptr, FunPtr, ) -newtype T a = Cons (Class.ValueTuple a)+import qualified Control.Monad.HT as Monad+import Control.Monad (Monad, return, fmap, (>>), )+import Data.Functor (Functor, ) +import qualified Data.Tuple.HT as TupleHT+import qualified Data.Tuple as Tuple+import Data.Function (id, (.), ($), )+import Data.Tuple.HT (uncurry3, )+import Data.Bool (Bool, )+import Data.Word (Word8, Word16, Word32, Word64, )+import Data.Int (Int8, Int16, Int32, Int64, ) -valueOf :: (Class.MakeValueTuple a) => a -> T a-valueOf = Cons . Class.valueTupleOf+import Prelude (Float, Double, Integer, Rational, ) -undef :: (Class.Undefined al, al ~ Class.ValueTuple a) => T a-undef = Cons Class.undefTuple +newtype T a = Cons (Repr LLVM.Value a) ++class C a where+   type Repr (f :: * -> *) a :: *+   cons :: a -> T a+   undef :: T a+   zero :: T a+   phis :: LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+   addPhis :: LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()++instance C Bool where+   type Repr f Bool = f Bool+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Float where+   type Repr f Float = f Float+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Double where+   type Repr f Double = f Double+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Word8 where+   type Repr f Word8 = f Word8+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Word16 where+   type Repr f Word16 = f Word16+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Word32 where+   type Repr f Word32 = f Word32+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Word64 where+   type Repr f Word64 = f Word64+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Int8 where+   type Repr f Int8 = f Int8+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Int16 where+   type Repr f Int16 = f Int16+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Int32 where+   type Repr f Int32 = f Int32+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Int64 where+   type Repr f Int64 = f Int64+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance (LLVM.IsType a) => C (Ptr a) where+   -- Do we also have to convert the pointer target type?+   type Repr f (Ptr a) = f (Ptr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance (LLVM.IsFunction a) => C (FunPtr a) where+   type Repr f (FunPtr a) = f (FunPtr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C (StablePtr a) where+   type Repr f (StablePtr a) = f (StablePtr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+++consPrimitive ::+   (LLVM.IsConst al, LLVM.Value al ~ Repr LLVM.Value a) =>+   al -> T a+consPrimitive = Cons . LLVM.valueOf++undefPrimitive, zeroPrimitive ::+   (LLVM.IsType al, LLVM.Value al ~ Repr LLVM.Value a) =>+   T a+undefPrimitive = Cons $ LLVM.value LLVM.undef+zeroPrimitive = Cons $ LLVM.value LLVM.zero++phisPrimitive ::+   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr LLVM.Value a) =>+   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+phisPrimitive bb (Cons a) = fmap Cons $ Loop.phis bb a++addPhisPrimitive ::+   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr LLVM.Value a) =>+   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()+addPhisPrimitive bb (Cons a) (Cons b) = Loop.addPhis bb a b+++instance C () where+   type Repr f () = ()+   cons = consUnit+   undef = undefUnit+   zero = zeroUnit+   phis = phisUnit+   addPhis = addPhisUnit++consUnit :: (Repr LLVM.Value a ~ ()) => a -> T a+consUnit _ = Cons ()++undefUnit :: (Repr LLVM.Value a ~ ()) => T a+undefUnit = Cons ()++zeroUnit :: (Repr LLVM.Value a ~ ()) => T a+zeroUnit = Cons ()++phisUnit ::+   (Repr LLVM.Value a ~ ()) =>+   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+phisUnit _bb (Cons ()) = return $ Cons ()++addPhisUnit ::+   (Repr LLVM.Value a ~ ()) =>+   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()+addPhisUnit _bb (Cons ()) (Cons ()) = return ()+++instance (C a, C b) => C (a,b) where+   type Repr f (a, b) = (Repr f a, Repr f b)+   cons (a,b) = zip (cons a) (cons b)+   undef = zip undef undef+   zero = zip zero zero+   phis bb a =+      case unzip a of+         (a0,a1) ->+            Monad.lift2 zip (phis bb a0) (phis bb a1)+   addPhis bb a b =+      case (unzip a, unzip b) of+         ((a0,a1), (b0,b1)) ->+            addPhis bb a0 b0 >>+            addPhis bb a1 b1++instance (C a, C b, C c) => C (a,b,c) where+   type Repr f (a, b, c) = (Repr f a, Repr f b, Repr f c)+   cons (a,b,c) = zip3 (cons a) (cons b) (cons c)+   undef = zip3 undef undef undef+   zero = zip3 zero zero zero+   phis bb a =+      case unzip3 a of+         (a0,a1,a2) ->+            Monad.lift3 zip3 (phis bb a0) (phis bb a1) (phis bb a2)+   addPhis bb a b =+      case (unzip3 a, unzip3 b) of+         ((a0,a1,a2), (b0,b1,b2)) ->+            addPhis bb a0 b0 >>+            addPhis bb a1 b1 >>+            addPhis bb a2 b2++instance (C a, C b, C c, C d) => C (a,b,c,d) where+   type Repr f (a, b, c, d) = (Repr f a, Repr f b, Repr f c, Repr f d)+   cons (a,b,c,d) = zip4 (cons a) (cons b) (cons c) (cons d)+   undef = zip4 undef undef undef undef+   zero = zip4 zero zero zero zero+   phis bb a =+      case unzip4 a of+         (a0,a1,a2,a3) ->+            Monad.lift4 zip4 (phis bb a0) (phis bb a1) (phis bb a2) (phis bb a3)+   addPhis bb a b =+      case (unzip4 a, unzip4 b) of+         ((a0,a1,a2,a3), (b0,b1,b2,b3)) ->+            addPhis bb a0 b0 >>+            addPhis bb a1 b1 >>+            addPhis bb a2 b2 >>+            addPhis bb a3 b3+++fst :: T (a,b) -> T a+fst (Cons (a,_b)) = Cons a++snd :: T (a,b) -> T b+snd (Cons (_a,b)) = Cons b++curry :: (T (a,b) -> c) -> (T a -> T b -> c)+curry f a b = f $ zip a b++uncurry :: (T a -> T b -> c) -> (T (a,b) -> c)+uncurry f = Tuple.uncurry f . unzip+++mapFst :: (T a0 -> T a1) -> T (a0,b) -> T (a1,b)+mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip++mapSnd :: (T b0 -> T b1) -> T (a,b0) -> T (a,b1)+mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip++swap :: T (a,b) -> T (b,a)+swap = Tuple.uncurry zip . TupleHT.swap . unzip+++fst3 :: T (a,b,c) -> T a+fst3 (Cons (a,_b,_c)) = Cons a++snd3 :: T (a,b,c) -> T b+snd3 (Cons (_a,b,_c)) = Cons b++thd3 :: T (a,b,c) -> T c+thd3 (Cons (_a,_b,c)) = Cons c+++mapFst3 :: (T a0 -> T a1) -> T (a0,b,c) -> T (a1,b,c)+mapFst3 f = uncurry3 zip3 . TupleHT.mapFst3 f . unzip3++mapSnd3 :: (T b0 -> T b1) -> T (a,b0,c) -> T (a,b1,c)+mapSnd3 f = uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3++mapThd3 :: (T c0 -> T c1) -> T (a,b,c0) -> T (a,b,c1)+mapThd3 f = uncurry3 zip3 . TupleHT.mapThd3 f . unzip3++ zip :: T a -> T b -> T (a,b) zip (Cons a) (Cons b) = Cons (a,b)  zip3 :: T a -> T b -> T c -> T (a,b,c) zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c) +zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)+zip4 (Cons a) (Cons b) (Cons c) (Cons d) = Cons (a,b,c,d)+ unzip :: T (a,b) -> (T a, T b) unzip (Cons (a,b)) = (Cons a, Cons b)  unzip3 :: T (a,b,c) -> (T a, T b, T c) unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c)++unzip4 :: T (a,b,c,d) -> (T a, T b, T c, T d)+unzip4 (Cons (a,b,c,d)) = (Cons a, Cons b, Cons c, Cons d)++++class Compose multituple where+   type Composed multituple+   {- |+   A nested 'zip'.+   -}+   compose :: multituple -> T (Composed multituple)++class+   (Composed (Decomposed T pattern) ~ PatternTuple pattern) =>+      Decompose pattern where+   {- |+   A nested 'unzip'.+   Since it is not obvious how deep to decompose nested tuples,+   you must provide a pattern of the decomposed tuple.+   E.g.++   > f :: MultiValue ((a,b),(c,d)) ->+   >      ((MultiValue a, MultiValue b), MultiValue (c,d))+   > f = decompose ((atom,atom),atom)+   -}+   decompose :: pattern -> T (PatternTuple pattern) -> Decomposed T pattern++type family Decomposed (f :: * -> *) pattern+type family PatternTuple pattern+++{- |+A combination of 'compose' and 'decompose'+that let you operate on tuple multivalues as Haskell tuples.+-}+modify ::+   (Compose a, Decompose pattern) =>+   pattern ->+   (Decomposed T pattern -> a) ->+   T (PatternTuple pattern) -> T (Composed a)+modify p f = compose . f . decompose p++modify2 ::+   (Compose a, Decompose patternA, Decompose patternB) =>+   patternA ->+   patternB ->+   (Decomposed T patternA -> Decomposed T patternB -> a) ->+   T (PatternTuple patternA) -> T (PatternTuple patternB) -> T (Composed a)+modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b)++modifyF ::+   (Compose a, Decompose pattern, Functor f) =>+   pattern ->+   (Decomposed T pattern -> f a) ->+   T (PatternTuple pattern) -> f (T (Composed a))+modifyF p f = fmap compose . f . decompose p++modifyF2 ::+   (Compose a, Decompose patternA, Decompose patternB,+    Functor f) =>+   patternA ->+   patternB ->+   (Decomposed T patternA -> Decomposed T patternB -> f a) ->+   T (PatternTuple patternA) -> T (PatternTuple patternB) -> f (T (Composed a))+modifyF2 pa pb f a b = fmap compose $ f (decompose pa a) (decompose pb b)++++instance Compose (T a) where+   type Composed (T a) = a+   compose = id++instance Decompose (Atom a) where+   decompose _ = id++type instance Decomposed f (Atom a) = f a+type instance PatternTuple (Atom a) = a++data Atom a = Atom++atom :: Atom a+atom = Atom+++instance (Compose a, Compose b) => Compose (a,b) where+   type Composed (a,b) = (Composed a, Composed b)+   compose = Tuple.uncurry zip . TupleHT.mapPair (compose, compose)++instance (Decompose pa, Decompose pb) => Decompose (pa,pb) where+   decompose (pa,pb) =+      TupleHT.mapPair (decompose pa, decompose pb) . unzip++type instance Decomposed f (pa,pb) = (Decomposed f pa, Decomposed f pb)+type instance PatternTuple (pa,pb) = (PatternTuple pa, PatternTuple pb)+++instance (Compose a, Compose b, Compose c) => Compose (a,b,c) where+   type Composed (a,b,c) = (Composed a, Composed b, Composed c)+   compose = uncurry3 zip3 . TupleHT.mapTriple (compose, compose, compose)++instance+   (Decompose pa, Decompose pb, Decompose pc) =>+      Decompose (pa,pb,pc) where+   decompose (pa,pb,pc) =+      TupleHT.mapTriple (decompose pa, decompose pb, decompose pc) . unzip3++type instance Decomposed f (pa,pb,pc) =+        (Decomposed f pa, Decomposed f pb, Decomposed f pc)+type instance PatternTuple (pa,pb,pc) =+        (PatternTuple pa, PatternTuple pb, PatternTuple pc)+++instance (Compose a, Compose b, Compose c, Compose d) => Compose (a,b,c,d) where+   type Composed (a,b,c,d) = (Composed a, Composed b, Composed c, Composed d)+   compose (a,b,c,d) = zip4 (compose a) (compose b) (compose c) (compose d)++instance+   (Decompose pa, Decompose pb, Decompose pc, Decompose pd) =>+      Decompose (pa,pb,pc,pd) where+   decompose (pa,pb,pc,pd) x =+      case unzip4 x of+         (a,b,c,d) ->+            (decompose pa a, decompose pb b, decompose pc c, decompose pd d)+type instance Decomposed f (pa,pb,pc,pd) =+        (Decomposed f pa, Decomposed f pb, Decomposed f pc, Decomposed f pd)+type instance PatternTuple (pa,pb,pc,pd) =+        (PatternTuple pa, PatternTuple pb, PatternTuple pc, PatternTuple pd)++++lift1 :: (Repr LLVM.Value a -> Repr LLVM.Value b) -> T a -> T b+lift1 f (Cons a) = Cons $ f a++liftM0 ::+   (Monad m) =>+   m (Repr LLVM.Value a) ->+   m (T a)+liftM0 f = Monad.lift Cons f++liftM ::+   (Monad m) =>+   (Repr LLVM.Value a -> m (Repr LLVM.Value b)) ->+   T a -> m (T b)+liftM f (Cons a) = Monad.lift Cons $ f a++liftM2 ::+   (Monad m) =>+   (Repr LLVM.Value a -> Repr LLVM.Value b -> m (Repr LLVM.Value c)) ->+   T a -> T b -> m (T c)+liftM2 f (Cons a) (Cons b) = Monad.lift Cons $ f a b++liftM3 ::+   (Monad m) =>+   (Repr LLVM.Value a -> Repr LLVM.Value b -> Repr LLVM.Value c ->+    m (Repr LLVM.Value d)) ->+   T a -> T b -> T c -> m (T d)+liftM3 f (Cons a) (Cons b) (Cons c) = Monad.lift Cons $ f a b c+++instance (C a) => Class.Zero (T a) where+   zeroTuple = zero++instance (C a) => Class.Undefined (T a) where+   undefTuple = undef++instance (C a) => Phi (T a) where+   phis = phis+   addPhis = addPhis+++class (C a) => IntegerConstant a where+   fromInteger' :: Integer -> T a++class (IntegerConstant a) => RationalConstant a where+   fromRational' :: Rational -> T a++instance IntegerConstant Float  where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Double where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance RationalConstant Float  where fromRational' = Cons . LLVM.value . SoV.constFromRational+instance RationalConstant Double where fromRational' = Cons . LLVM.value . SoV.constFromRational+++instance (IntegerConstant a) => A.IntegerConstant (T a) where+   fromInteger' = fromInteger'++instance (RationalConstant a) => A.RationalConstant (T a) where+   fromRational' = fromRational'+++class (C a) => Additive a where+   add :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   sub :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   neg :: T a -> LLVM.CodeGenFunction r (T a)++instance Additive Float where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Double where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word32 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word64 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int32 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int64 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance (Additive a) => A.Additive (T a) where+   zero = zero+   add = add+   sub = sub+   neg = neg+++class (Additive a) => PseudoRing a where+   mul :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance PseudoRing Float where+   mul = liftM2 LLVM.mul++instance PseudoRing Double where+   mul = liftM2 LLVM.mul++instance PseudoRing Word32 where+   mul = liftM2 LLVM.mul++instance PseudoRing Word64 where+   mul = liftM2 LLVM.mul++instance PseudoRing Int32 where+   mul = liftM2 LLVM.mul++instance PseudoRing Int64 where+   mul = liftM2 LLVM.mul++instance (PseudoRing a) => A.PseudoRing (T a) where+   mul = mul+++class (PseudoRing a) => Field a where+   fdiv :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance Field Float where+   fdiv = liftM2 LLVM.fdiv++instance Field Double where+   fdiv = liftM2 LLVM.fdiv++instance (Field a) => A.Field (T a) where+   fdiv = fdiv+++type family Scalar vector :: *+type instance Scalar Float = Float+type instance Scalar Double = Double+type instance A.Scalar (T a) = T (Scalar a)++class (PseudoRing (Scalar v), Additive v) => PseudoModule v where+   scale :: T (Scalar v) -> T v -> LLVM.CodeGenFunction r (T v)++instance PseudoModule Float where+   scale = liftM2 A.mul++instance PseudoModule Double where+   scale = liftM2 A.mul++instance (PseudoModule a) => A.PseudoModule (T a) where+   scale = scale+++class (Additive a) => Real a where+   min :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   max :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   abs :: T a -> LLVM.CodeGenFunction r (T a)+   signum :: T a -> LLVM.CodeGenFunction r (T a)++instance Real Float where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Double where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (Real a) => A.Real (T a) where+   min = min+   max = max+   abs = abs+   signum = signum+++class (Real a) => Fraction a where+   truncate :: T a -> LLVM.CodeGenFunction r (T a)+   fraction :: T a -> LLVM.CodeGenFunction r (T a)++instance Fraction Float where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance Fraction Double where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance (Fraction a) => A.Fraction (T a) where+   truncate = truncate+   fraction = fraction+++class Field a => Algebraic a where+   sqrt :: T a -> LLVM.CodeGenFunction r (T a)++instance Algebraic Float where+   sqrt = liftM A.sqrt++instance Algebraic Double where+   sqrt = liftM A.sqrt++instance (Algebraic a) => A.Algebraic (T a) where+   sqrt = sqrt+++class Algebraic a => Transcendental a where+   pi :: LLVM.CodeGenFunction r (T a)+   sin, cos, exp, log :: T a -> LLVM.CodeGenFunction r (T a)+   pow :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance Transcendental Float where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance Transcendental Double where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance (Transcendental a) => A.Transcendental (T a) where+   pi = pi+   sin = sin+   cos = cos+   exp = exp+   log = log+   pow = pow++++class (C a) => Select a where+   select ::+      T Bool -> T a -> T a ->+      LLVM.CodeGenFunction r (T a)++instance Select Float where+   select = liftM3 LLVM.select++instance Select Double where+   select = liftM3 LLVM.select++instance Select Word32 where+   select = liftM3 LLVM.select++instance Select Word64 where+   select = liftM3 LLVM.select++instance Select Int32 where+   select = liftM3 LLVM.select++instance Select Int64 where+   select = liftM3 LLVM.select++instance (Select a, Select b) => Select (a,b) where+   select b =+      modifyF2 (atom,atom) (atom,atom) $+      \(a0,b0) (a1,b1) ->+         Monad.lift2 (,)+            (select b a0 a1)+            (select b b0 b1)++instance (Select a, Select b, Select c) => Select (a,b,c) where+   select b =+      modifyF2 (atom,atom,atom) (atom,atom,atom) $+      \(a0,b0,c0) (a1,b1,c1) ->+         Monad.lift3 (,,)+            (select b a0 a1)+            (select b b0 b1)+            (select b c0 c1)++instance (Select a) => C.Select (T a) where+   select b = select (Cons b)++++class (Real a) => Comparison a where+   {- |+   It must hold++   > max x y  ==  do gt <- cmp CmpGT x y; select gt x y+   -}+   cmp ::+      LLVM.CmpPredicate -> T a -> T a ->+      LLVM.CodeGenFunction r (T Bool)++instance Comparison Float where+   cmp = liftM2 . LLVM.cmp++instance Comparison Double where+   cmp = liftM2 . LLVM.cmp++instance (Comparison a) => A.Comparison (T a) where+   type CmpResult (T a) = T Bool+   cmp = cmp++++class (Comparison a) => FloatingComparison a where+   fcmp ::+      LLVM.FPPredicate -> T a -> T a ->+      LLVM.CodeGenFunction r (T Bool)++instance FloatingComparison Float where+   fcmp = liftM2 . LLVM.fcmp++instance (FloatingComparison a) => A.FloatingComparison (T a) where+   fcmp = fcmp++++class Logic a where+   and :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   or :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   xor :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   inv :: T a -> LLVM.CodeGenFunction r (T a)++instance Logic Bool where+   and = liftM2 LLVM.and+   or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor+   inv = liftM LLVM.inv+++instance Logic a => A.Logic (T a) where+   and = and+   or = or+   xor = xor+   inv = inv++++class (PseudoRing a) => Integral a where+   idiv :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   irem :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance Integral Word32 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Word64 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Int32 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Int64 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem
+ src/LLVM/Extra/Multi/Value/Memory.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.Multi.Value.Memory where++import qualified LLVM.Extra.Multi.Value as MultiValue+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.Word (Word8, Word16, Word32, Word64, )+import Data.Int (Int8, Int16, Int32, Int64, )++import Control.Applicative (pure, liftA2, liftA3, (<*>), )+++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 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 a) =>+   Value (Ptr a) -> CodeGenFunction r (MultiValue.T a)+loadPrimitive = fmap MultiValue.Cons . LLVM.load++storePrimitive ::+   (MultiValue.Repr Value a ~ Value a) =>+   MultiValue.T a -> Value (Ptr a) -> CodeGenFunction r ()+storePrimitive (MultiValue.Cons a) = LLVM.store a++decomposePrimitive ::+   (MultiValue.Repr Value a ~ Value a) =>+   Value a -> CodeGenFunction r (MultiValue.T a)+decomposePrimitive = return . MultiValue.Cons++composePrimitive ::+   (MultiValue.Repr Value a ~ Value a) =>+   MultiValue.T a -> CodeGenFunction r (Value a)+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 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/Vector.hs view
@@ -1,37 +1,120 @@ {-# LANGUAGE TypeFamilies #-}-module LLVM.Extra.Multi.Vector where+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.Multi.Vector (+   T(Cons), consPrim, deconsPrim,+   C(..),+   Value(Value),+   map,+   zip, zip3, unzip, unzip3,+   replicate,+   iterate, +   lift1,++   modify,+   assemble,+   dissect,+   dissectList,++   reverse,+   rotateUp,+   rotateDown,+   shiftUp,+   shiftDown,+   shiftUpMultiZero,+   shiftDownMultiZero,++   undefPrimitive,+   shuffleMatchPrimitive,+   extractPrimitive,+   insertPrimitive,++   shuffleMatchTraversable,+   insertTraversable,+   extractTraversable,++   Additive(..),+   PseudoRing(..),+   Field(..),+   PseudoModule(..),+   Real(..),+   Fraction(..),+   Algebraic(..),+   Transcendental(..),+   FloatingComparison(..),+   Comparison(..),+   Logic(..),+   ) where+ import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Vector as Vector+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 (Repr, ) +import qualified LLVM.Util.Loop as Loop import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (Phi, ) import LLVM.Core-   (Value, ConstValue, valueOf, value,+   (valueOf, value,     IsPrimitive,     CodeGenFunction, ) -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum +import qualified Data.Traversable as Trav+import qualified Data.NonEmpty as NonEmpty import qualified Data.List as List+import Data.Traversable (mapM, sequence, )+import Data.NonEmpty ((!:), )+import Data.Function (flip, (.), ($), )+import Data.Tuple (snd, )+import Data.Maybe (maybe, )+import Data.List (take, (++), ) import Data.Word (Word32, )+import Data.Bool (Bool, ) -import Control.Monad (liftM2, liftM3, foldM, )+import qualified Control.Applicative as App+import qualified Control.Monad.HT as Monad+import Control.Monad.HT ((<=<), )+import Control.Monad (Monad, foldM, fmap, (>>), (=<<), )+import Control.Applicative (liftA2, ) -import Prelude hiding (zip, zip3, unzip, unzip3, )+import Prelude (Float, Double, Integer, Int, Rational, fromIntegral, (-), error, )  -newtype T n a = Cons (Vector n a)+newtype T n a = Cons (Repr (Value n) a) -instance (TypeNum.PositiveT n, C a) => Class.Undefined (T n a) where+newtype Value n a = Value (PrimValue n a)+++consPrim ::+   (Repr (Value n) a ~ Value n a) =>+   LLVM.Value (LLVM.Vector n a) -> T n a+consPrim = Cons . Value++deconsPrim ::+   (Repr (Value n) a ~ Value n a) =>+   T n a -> LLVM.Value (LLVM.Vector n a)+deconsPrim (Cons (Value a)) = a+++instance (TypeNum.Positive n, C a) => Class.Undefined (T n a) where    undefTuple = undef +instance (TypeNum.Positive n, C a) => Class.Zero (T n a) where+   zeroTuple = zero -size :: TypeNum.PositiveT n => T n a -> Int+instance (TypeNum.Positive n, C a) => Phi (T n a) where+   phis = phis+   addPhis = addPhis+++size :: TypeNum.Positive n => T n a -> Int size =-   let sz :: TypeNum.PositiveT n => n -> T n a -> Int-       sz n _ = TypeNum.fromIntegerT n-   in  sz undefined+   let sz :: TypeNum.Positive n => TypeNum.Singleton n -> T n a -> Int+       sz n _ = TypeNum.integralFromSingleton n+   in  sz TypeNum.singleton   zip :: T n a -> T n b -> T n (a,b)@@ -47,102 +130,160 @@ unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c)  -class C a where-   type Vector n a :: *-   undef :: (TypeNum.PositiveT n) => T n a+class (MultiValue.C a) => C a where+   undef :: (TypeNum.Positive n) => T n a+   zero :: (TypeNum.Positive n) => T n a+   phis ::+      (TypeNum.Positive n) =>+      LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)+   addPhis ::+      (TypeNum.Positive n) =>+      LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r ()+    shuffleMatch ::-      (TypeNum.PositiveT n) =>-      ConstValue (LLVM.Vector n Word32) -> T n a -> CodeGenFunction r (T n a)+      (TypeNum.Positive n) =>+      LLVM.ConstValue (LLVM.Vector n Word32) -> T n a -> CodeGenFunction r (T n a)    extract ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)    insert ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       LLVM.Value Word32 -> MultiValue.T a ->       T n a -> CodeGenFunction r (T n a) +instance C Bool where+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+   shuffleMatch = shuffleMatchPrimitive+   extract = extractPrimitive+   insert = insertPrimitive+ instance C Float where-   type Vector n Float = LLVM.Value (LLVM.Vector n Float)    undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive    shuffleMatch = shuffleMatchPrimitive    extract = extractPrimitive    insert = insertPrimitive  instance C Double where-   type Vector n Double = LLVM.Value (LLVM.Vector n Double)    undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive    shuffleMatch = shuffleMatchPrimitive    extract = extractPrimitive    insert = insertPrimitive  undefPrimitive ::-   (TypeNum.PositiveT n, IsPrimitive a,-    Vector n a ~ Value (LLVM.Vector n a)) =>+   (TypeNum.Positive n, IsPrimitive a,+    Repr (Value n) a ~ Value n a) =>    T n a-undefPrimitive = Cons $ LLVM.value LLVM.undef+undefPrimitive = Cons $ Value $ LLVM.value LLVM.undef +zeroPrimitive ::+   (TypeNum.Positive n, IsPrimitive a,+    Repr (Value n) a ~ Value n a) =>+   T n a+zeroPrimitive = Cons $ Value $ LLVM.value LLVM.zero++phisPrimitive ::+   (TypeNum.Positive n, IsPrimitive a, Repr (Value n) a ~ Value n a) =>+   LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)+phisPrimitive bb (Cons (Value a)) = fmap (Cons . Value) $ Loop.phis bb a++addPhisPrimitive ::+   (TypeNum.Positive n, IsPrimitive a, Repr (Value n) a ~ Value n a) =>+   LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r ()+addPhisPrimitive bb (Cons (Value a)) (Cons (Value b)) = Loop.addPhis bb a b++ shuffleMatchPrimitive ::-   (TypeNum.PositiveT n, IsPrimitive a,-    Vector n a ~ Value (LLVM.Vector n a),-    Class.ValueTuple a ~ Value a) =>-   ConstValue (LLVM.Vector n Word32) -> T n a -> CodeGenFunction r (T n a)-shuffleMatchPrimitive k (Cons v) =-   fmap Cons $ LLVM.shufflevector v (value LLVM.undef) k+   (TypeNum.Positive n, IsPrimitive a,+    Repr LLVM.Value a ~ LLVM.Value a,+    Repr (Value n) a ~ Value n a) =>+   LLVM.ConstValue (LLVM.Vector n Word32) -> T n a -> CodeGenFunction r (T n a)+shuffleMatchPrimitive k (Cons (Value v)) =+   fmap (Cons . Value) $ LLVM.shufflevector v (value LLVM.undef) k  extractPrimitive ::-   (TypeNum.PositiveT n, IsPrimitive a,-    Vector n a ~ Value (LLVM.Vector n a),-    Class.ValueTuple a ~ Value a) =>-   Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)-extractPrimitive k (Cons v) =+   (TypeNum.Positive n, IsPrimitive a,+    Repr LLVM.Value a ~ LLVM.Value a,+    Repr (Value n) a ~ Value n a) =>+   LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)+extractPrimitive k (Cons (Value v)) =    fmap MultiValue.Cons $ LLVM.extractelement v k  insertPrimitive ::-   (TypeNum.PositiveT n, IsPrimitive a,-    Vector n a ~ Value (LLVM.Vector n a),-    Class.ValueTuple a ~ Value a) =>-   Value Word32 ->+   (TypeNum.Positive n, IsPrimitive a,+-- this constraint is accepted, but does not help+--    Repr f a ~ f a,+    Repr LLVM.Value a ~ LLVM.Value a,+    Repr (Value n) a ~ Value n a) =>+   LLVM.Value Word32 ->    MultiValue.T a -> T n a -> CodeGenFunction r (T n a)-insertPrimitive k (MultiValue.Cons a) (Cons v) =-   fmap Cons $ LLVM.insertelement v a k+insertPrimitive k (MultiValue.Cons a) (Cons (Value v)) =+   fmap (Cons . Value) $ LLVM.insertelement v a k   instance (C a, C b) => C (a,b) where-   type Vector n (a,b) = (Vector n a, Vector n b)-    undef = zip undef undef+   zero = zip zero zero +   phis bb a =+      case unzip a of+         (a0,a1) ->+            Monad.lift2 zip (phis bb a0) (phis bb a1)+   addPhis bb a b =+      case (unzip a, unzip b) of+         ((a0,a1), (b0,b1)) ->+            addPhis bb a0 b0 >>+            addPhis bb a1 b1+    shuffleMatch is v =       case unzip v of          (v0,v1) ->-            liftM2 zip+            Monad.lift2 zip                (shuffleMatch is v0)                (shuffleMatch is v1)     extract k v =       case unzip v of          (v0,v1) ->-            liftM2 MultiValue.zip+            Monad.lift2 MultiValue.zip                (extract k v0)                (extract k v1)     insert k a v =       case (MultiValue.unzip a, unzip v) of          ((a0,a1), (v0,v1)) ->-            liftM2 zip+            Monad.lift2 zip                (insert k a0 v0)                (insert k a1 v1)   instance (C a, C b, C c) => C (a,b,c) where-   type Vector n (a,b,c) = (Vector n a, Vector n b, Vector n c)-    undef = zip3 undef undef undef+   zero = zip3 zero zero zero +   phis bb a =+      case unzip3 a of+         (a0,a1,a2) ->+            Monad.lift3 zip3 (phis bb a0) (phis bb a1) (phis bb a2)+   addPhis bb a b =+      case (unzip3 a, unzip3 b) of+         ((a0,a1,a2), (b0,b1,b2)) ->+            addPhis bb a0 b0 >>+            addPhis bb a1 b1 >>+            addPhis bb a2 b2+    shuffleMatch is v =       case unzip3 v of          (v0,v1,v2) ->-            liftM3 zip3+            Monad.lift3 zip3                (shuffleMatch is v0)                (shuffleMatch is v1)                (shuffleMatch is v2)@@ -150,7 +291,7 @@    extract k v =       case unzip3 v of          (v0,v1,v2) ->-            liftM3 MultiValue.zip3+            Monad.lift3 MultiValue.zip3                (extract k v0)                (extract k v1)                (extract k v2)@@ -158,46 +299,471 @@    insert k a v =       case (MultiValue.unzip3 a, unzip3 v) of          ((a0,a1,a2), (v0,v1,v2)) ->-            liftM3 zip3+            Monad.lift3 zip3                (insert k a0 v0)                (insert k a1 v1)                (insert k a2 v2)  +class (C a) => IntegerConstant a where+   fromInteger' :: (TypeNum.Positive n) => Integer -> T n a++class (IntegerConstant a) => RationalConstant a where+   fromRational' :: (TypeNum.Positive n) => Rational -> T n a++instance IntegerConstant Float  where fromInteger' = Cons . Value . LLVM.value . SoV.constFromInteger+instance IntegerConstant Double where fromInteger' = Cons . Value . LLVM.value . SoV.constFromInteger++instance RationalConstant Float  where fromRational' = Cons . Value . LLVM.value . SoV.constFromRational+instance RationalConstant Double where fromRational' = Cons . Value . LLVM.value . SoV.constFromRational+++instance+   (TypeNum.Positive n, IntegerConstant a) =>+      A.IntegerConstant (T n a) where+   fromInteger' = fromInteger'++instance+   (TypeNum.Positive n, RationalConstant a) =>+      A.RationalConstant (T n a) where+   fromRational' = fromRational'+++modify ::+   (TypeNum.Positive n, C a) =>+   LLVM.Value Word32 ->+   (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) ->+   (T n a -> CodeGenFunction r (T n a))+modify k f v =+   flip (insert k) v =<< f =<< extract k v++ assemble ::-   (TypeNum.PositiveT n, C a) =>+   (TypeNum.Positive n, C a) =>    [MultiValue.T a] -> CodeGenFunction r (T n a) assemble =    foldM (\v (k,x) -> insert (valueOf k) x v) undef .    List.zip [0..]  dissect ::-   (TypeNum.PositiveT n, C a) =>+   (TypeNum.Positive n, C a) =>    T n a -> LLVM.CodeGenFunction r [MultiValue.T a]-dissect x =-   mapM+dissect = sequence . dissectList++dissectList ::+   (TypeNum.Positive n, C a) =>+   T n a -> [LLVM.CodeGenFunction r (MultiValue.T a)]+dissectList x =+   List.map       (flip extract x . LLVM.valueOf)       (take (size x) [0..])  --- * function based on classes from Vector module+map ::+   (TypeNum.Positive n, C a, C b) =>+   (MultiValue.T a -> CodeGenFunction r (MultiValue.T b)) ->+   (T n a -> CodeGenFunction r (T n b))+map f  =  assemble <=< mapM f <=< dissect -shuffleMatchGen ::-   (Vector n a ~ v, Vector.Simple v, n ~ Vector.Size v) =>-   ConstValue (LLVM.Vector n Word32) ->++replicate ::+   (TypeNum.Positive n, C a) =>+   MultiValue.T a -> CodeGenFunction r (T n a)+replicate = replicateCore TypeNum.singleton++replicateCore ::+   (TypeNum.Positive n, C a) =>+   TypeNum.Singleton n -> MultiValue.T a -> CodeGenFunction r (T n a)+replicateCore n =+   assemble . List.replicate (TypeNum.integralFromSingleton n)+++iterate ::+   (TypeNum.Positive n, C a) =>+   (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) ->+   MultiValue.T a -> CodeGenFunction r (T n a)+iterate f x =+   fmap snd $+   iterateCore f x Class.undefTuple++iterateCore ::+   (TypeNum.Positive n, C a) =>+   (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) ->+   MultiValue.T a -> T n a ->+   CodeGenFunction r (MultiValue.T a, T n a)+iterateCore f x0 v0 =+   foldM+      (\(x,v) k ->+         Monad.lift2 (,) (f x)+            (insert (valueOf k) x v))+      (x0,v0)+      (take (size v0) [0..])+++-- * re-ordering of elements++constCyclicVector ::+   (LLVM.IsConst a, TypeNum.Positive n) =>+   NonEmpty.T [] a -> LLVM.ConstValue (LLVM.Vector n a)+constCyclicVector =+   LLVM.constCyclicVector . fmap LLVM.constOf++{- |+Rotate one element towards the higher elements.++I don't want to call it rotateLeft or rotateRight,+because there is no prefered layout for the vector elements.+In Intel's instruction manual vector+elements are indexed like the bits,+that is from right to left.+However, when working with Haskell list and enumeration syntax,+the start index is left.+-}+rotateUp ::+   (TypeNum.Positive n, C a) =>    T n a -> CodeGenFunction r (T n a)-shuffleMatchGen is (Cons v) =-   fmap Cons $ Vector.shuffleMatch is v+rotateUp x =+   shuffleMatch+      (constCyclicVector $+       (fromIntegral (size x) - 1) !: [0..]) x -extractGen ::-   (Vector n a ~ v, Vector.Simple v, Class.ValueTuple a ~ Vector.Element v) =>-   LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)-extractGen n (Cons v) =-   fmap MultiValue.Cons $ Vector.extract n v+rotateDown ::+   (TypeNum.Positive n, C a) =>+   T n a -> CodeGenFunction r (T n a)+rotateDown x =+   shuffleMatch+      (constCyclicVector $+       NonEmpty.snoc (List.take (size x - 1) [1..]) 0) x -insertGen ::-   (Vector n a ~ v, Vector.C v, Class.ValueTuple a ~ Vector.Element v) =>-   LLVM.Value Word32 -> MultiValue.T a ->+reverse ::+   (TypeNum.Positive n, C a) =>    T n a -> CodeGenFunction r (T n a)-insertGen n (MultiValue.Cons a) (Cons v) =-   fmap Cons $ Vector.insert n a v+reverse x =+   shuffleMatch+      (constCyclicVector $+       maybe (error "vector size must be positive") NonEmpty.reverse $+       NonEmpty.fetch $+       List.take (size x) [0..])+      x++shiftUp ::+   (TypeNum.Positive n, C a) =>+   MultiValue.T a -> T n a -> CodeGenFunction r (MultiValue.T a, T n a)+shiftUp x0 x = do+   y <-+      shuffleMatch+         (LLVM.constCyclicVector $ LLVM.undef !: List.map LLVM.constOf [0..]) x+   Monad.lift2 (,)+      (extract (LLVM.valueOf (fromIntegral (size x) - 1)) x)+      (insert (value LLVM.zero) x0 y)++shiftDown ::+   (TypeNum.Positive n, C a) =>+   MultiValue.T a -> T n a -> CodeGenFunction r (MultiValue.T a, T n a)+shiftDown x0 x = do+   y <-+      shuffleMatch+         (LLVM.constCyclicVector $+          NonEmpty.snoc+             (List.map LLVM.constOf $ List.take (size x - 1) [1..])+             LLVM.undef) x+   Monad.lift2 (,)+      (extract (value LLVM.zero) x)+      (insert (LLVM.valueOf (fromIntegral (size x) - 1)) x0 y)++shiftUpMultiZero ::+   (TypeNum.Positive n, C a, Class.ValueTuple a ~ al, Class.Zero al) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftUpMultiZero n v =+   assemble . take (size v) .+   (List.replicate n MultiValue.zero ++) =<< dissect v++shiftDownMultiZero ::+   (TypeNum.Positive n, C a, Class.ValueTuple a ~ al, Class.Zero al) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftDownMultiZero n v =+   assemble . take (size v) .+   (++ List.repeat MultiValue.zero) . List.drop n+      =<< dissect v+++-- * method implementations based on Traversable++shuffleMatchTraversable ::+   (TypeNum.Positive n, C a, Trav.Traversable f) =>+   LLVM.ConstValue (LLVM.Vector n Word32) ->+   f (T n a) -> CodeGenFunction r (f (T n a))+shuffleMatchTraversable is v =+   Trav.mapM (shuffleMatch is) v++insertTraversable ::+   (TypeNum.Positive n, C a, Trav.Traversable f, App.Applicative f) =>+   LLVM.Value Word32 -> f (MultiValue.T a) ->+   f (T n a) -> CodeGenFunction r (f (T n a))+insertTraversable n a v =+   Trav.sequence (liftA2 (insert n) a v)++extractTraversable ::+   (TypeNum.Positive n, C a, Trav.Traversable f) =>+   LLVM.Value Word32 -> f (T n a) ->+   CodeGenFunction r (f (MultiValue.T a))+extractTraversable n v =+   Trav.mapM (extract n) v+++type PrimValue n a = LLVM.Value (LLVM.Vector n a)+++lift1 :: (Repr (Value n) a -> Repr (Value n) b) -> T n a -> T n b+lift1 f (Cons a) = Cons $ f a++_liftM0 ::+   (Monad m) =>+   m (Repr (Value n) a) ->+   m (T n a)+_liftM0 f = Monad.lift Cons f++liftM0 ::+   (Monad m,+    Repr (Value n) a ~ Value n a) =>+   m (PrimValue n a) ->+   m (T n a)+liftM0 f = Monad.lift consPrim f++liftM ::+   (Monad m,+    Repr (Value n) a ~ Value n a,+    Repr (Value n) b ~ Value n b) =>+   (PrimValue n a -> m (PrimValue n b)) ->+   T n a -> m (T n b)+liftM f a = Monad.lift consPrim $ f (deconsPrim a)++liftM2 ::+   (Monad m,+    Repr (Value n) a ~ Value n a,+    Repr (Value n) b ~ Value n b,+    Repr (Value n) c ~ Value n c) =>+   (PrimValue n a -> PrimValue n b -> m (PrimValue n c)) ->+   T n a -> T n b -> m (T n c)+liftM2 f a b = Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b)++++class (MultiValue.Additive a, C a) => Additive a where+   add ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   sub ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   neg ::+      (TypeNum.Positive n) =>+      T n a -> LLVM.CodeGenFunction r (T n a)++instance Additive Float where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Double where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance (TypeNum.Positive n, Additive a) => A.Additive (T n a) where+   zero = zero+   add = add+   sub = sub+   neg = neg+++class (MultiValue.PseudoRing a, Additive a) => PseudoRing a where+   mul ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance PseudoRing Float where+   mul = liftM2 LLVM.mul++instance PseudoRing Double where+   mul = liftM2 LLVM.mul++instance (TypeNum.Positive n, PseudoRing a) => A.PseudoRing (T n a) where+   mul = mul+++class (MultiValue.Field a, PseudoRing a) => Field a where+   fdiv ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance Field Float where+   fdiv = liftM2 LLVM.fdiv++instance Field Double where+   fdiv = liftM2 LLVM.fdiv++instance (TypeNum.Positive n, Field a) => A.Field (T n a) where+   fdiv = fdiv+++type instance A.Scalar (T n a) = T n (MultiValue.Scalar a)++class+   (MultiValue.PseudoModule v, PseudoRing (MultiValue.Scalar v), Additive v) =>+      PseudoModule v where+   scale ::+      (TypeNum.Positive n) =>+      T n (MultiValue.Scalar v) -> T n v -> LLVM.CodeGenFunction r (T n v)++instance PseudoModule Float where+   scale = liftM2 A.mul++instance PseudoModule Double where+   scale = liftM2 A.mul++instance (TypeNum.Positive n, PseudoModule a) => A.PseudoModule (T n a) where+   scale = scale+++class (MultiValue.Real a, Additive a) => Real a where+   min :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   max :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   abs :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)+   signum :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Real Float where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Double where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (TypeNum.Positive n, Real a) => A.Real (T n a) where+   min = min+   max = max+   abs = abs+   signum = signum+++class (MultiValue.Fraction a, Real a) => Fraction a where+   truncate :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)+   fraction :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Fraction Float where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance Fraction Double where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance (TypeNum.Positive n, Fraction a) => A.Fraction (T n a) where+   truncate = truncate+   fraction = fraction+++class (MultiValue.Algebraic a, Field a) => Algebraic a where+   sqrt :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Algebraic Float where+   sqrt = liftM A.sqrt++instance Algebraic Double where+   sqrt = liftM A.sqrt++instance (TypeNum.Positive n, Algebraic a) => A.Algebraic (T n a) where+   sqrt = sqrt+++class (MultiValue.Transcendental a, Algebraic a) => Transcendental a where+   pi :: (TypeNum.Positive n) => LLVM.CodeGenFunction r (T n a)+   sin, cos, exp, log ::+      (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)+   pow :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance Transcendental Float where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance Transcendental Double where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance (TypeNum.Positive n, Transcendental a) => A.Transcendental (T n a) where+   pi = pi+   sin = sin+   cos = cos+   exp = exp+   log = log+   pow = pow++++class (MultiValue.Comparison a, C a) => Comparison a where+   cmp ::+      (TypeNum.Positive n) =>+      LLVM.CmpPredicate -> T n a -> T n a ->+      LLVM.CodeGenFunction r (T n Bool)++instance Comparison Float where+   cmp = liftM2 . LLVM.cmp++instance Comparison Double where+   cmp = liftM2 . LLVM.cmp++instance (TypeNum.Positive n, Comparison a) => A.Comparison (T n a) where+   type CmpResult (T n a) = T n Bool+   cmp = cmp++++class+   (MultiValue.FloatingComparison a, Comparison a) =>+      FloatingComparison a where+   fcmp ::+      (TypeNum.Positive n) =>+      LLVM.FPPredicate -> T n a -> T n a ->+      LLVM.CodeGenFunction r (T n Bool)++instance FloatingComparison Float where+   fcmp = liftM2 . LLVM.fcmp++instance+   (TypeNum.Positive n, FloatingComparison a) =>+      A.FloatingComparison (T n a) where+   fcmp = fcmp++++class (MultiValue.Logic a, C a) => Logic a where+   and :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   or :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   xor :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   inv :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Logic Bool where+   and = liftM2 LLVM.and+   or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor+   inv = liftM LLVM.inv+++instance (TypeNum.Positive n, Logic a) => A.Logic (T n a) where+   and = and+   or = or+   xor = xor+   inv = inv
+ src/LLVM/Extra/Multi/Vector/Memory.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.Extra.Multi.Vector.Memory where++import qualified LLVM.Extra.Multi.Vector as MultiVector+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, )+++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.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
src/LLVM/Extra/Scalar.hs view
@@ -4,6 +4,9 @@ import qualified LLVM.Extra.Class as Class 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  @@ -65,6 +68,13 @@  instance (Class.Zero a) => Class.Zero (T a) where    zeroTuple = Cons Class.zeroTuple++instance (Class.Undefined a) => Class.Undefined (T a) where+   undefTuple = Cons Class.undefTuple++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 (A.IntegerConstant a) => A.IntegerConstant (T a) where    fromInteger' = Cons . A.fromInteger'
src/LLVM/Extra/ScalarOrVector.hs view
@@ -32,17 +32,19 @@ import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.ArithmeticPrivate as A -import qualified Types.Data.Num as TypeNum-import Types.Data.Num (D1, )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D1, )+ import qualified LLVM.Core as LLVM import LLVM.Core    (Value, ConstValue, valueOf, constOf,-    Vector, constVector, FP128,+    Vector, FP128,     IsConst, IsFloating,     CodeGenFunction, )  import Control.Monad.HT ((<=<), ) +import qualified Data.NonEmpty as NonEmpty import Data.Word (Word8, Word16, Word32, Word64, ) import Data.Int  (Int8,  Int16,  Int32,  Int64, ) @@ -92,7 +94,7 @@       (Ext.with X86.roundsd $ \round x ->          A.sub x =<< round x (valueOf 1)) -instance (TypeNum.PositiveT n, Vector.Real a, IsFloating a, IsConst a) =>+instance (TypeNum.Positive n, Vector.Real a, IsFloating a, IsConst a) =>       Fraction (Vector n a) where    truncate = Vector.truncate    fraction = Vector.fraction@@ -183,7 +185,7 @@ instance Replicate Word16 where replicate = return; replicateConst = id; instance Replicate Word32 where replicate = return; replicateConst = id; instance Replicate Word64 where replicate = return; replicateConst = id;-instance (TypeNum.PositiveT n, LLVM.IsPrimitive a) => Replicate (Vector n a) where+instance (TypeNum.Positive n, LLVM.IsPrimitive a) => Replicate (Vector n a) where {- crashes LLVM-2.5, seems to be fixed in LLVM-2.6 -}    replicate x = do       v <- singleton x@@ -200,7 +202,7 @@ {-    replicate = Vector.replicate -}-   replicateConst x = LLVM.constVector [x];+   replicateConst x = LLVM.constCyclicVector $ NonEmpty.Cons x []  singleton ::    (LLVM.IsPrimitive a) =>@@ -211,8 +213,8 @@ replicateOf ::    (IsConst (Scalar v), Replicate v) =>    Scalar v -> Value v-replicateOf a =-   LLVM.value (replicateConst (LLVM.constOf a))+replicateOf =+   LLVM.value . replicateConst . LLVM.constOf   class (LLVM.IsArithmetic a) => Real a where@@ -291,7 +293,7 @@ instance Real Word32 where min = A.min; max = A.max; signum = A.signum; abs = return; instance Real Word64 where min = A.min; max = A.max; signum = A.signum; abs = return; -instance (TypeNum.PositiveT n, Vector.Real a) =>+instance (TypeNum.Positive n, Vector.Real a) =>          Real (Vector n a) where    min = Vector.min    max = Vector.max@@ -316,7 +318,7 @@ instance PseudoModule Int64  where scale = LLVM.mul; scaleConst = LLVM.mul instance PseudoModule Float  where scale = LLVM.mul; scaleConst = LLVM.mul instance PseudoModule Double where scale = LLVM.mul; scaleConst = LLVM.mul-instance (LLVM.IsArithmetic a, LLVM.IsPrimitive a, TypeNum.PositiveT n) =>+instance (LLVM.IsArithmetic a, LLVM.IsPrimitive a, TypeNum.Positive n) =>          PseudoModule (Vector n a) where    scale a v = flip LLVM.mul v . flip asTypeOf v =<< replicate a    scaleConst a v = LLVM.mul (replicateConst a `asTypeOf` v) v@@ -336,9 +338,9 @@ instance IntegerConstant Int64  where constFromInteger = constOf . fromInteger instance IntegerConstant Float  where constFromInteger = constOf . fromInteger instance IntegerConstant Double where constFromInteger = constOf . fromInteger-instance (IntegerConstant a, LLVM.IsPrimitive a, TypeNum.PositiveT n) =>+instance (IntegerConstant a, LLVM.IsPrimitive a, TypeNum.Positive n) =>          IntegerConstant (Vector n a) where-   constFromInteger x = constVector [constFromInteger x]+   constFromInteger = replicateConst . constFromInteger   class (IntegerConstant a) => RationalConstant a where@@ -346,9 +348,9 @@  instance RationalConstant Float  where constFromRational = constOf . fromRational instance RationalConstant Double where constFromRational = constOf . fromRational-instance (RationalConstant a, LLVM.IsPrimitive a, TypeNum.PositiveT n) =>+instance (RationalConstant a, LLVM.IsPrimitive a, TypeNum.Positive n) =>          RationalConstant (Vector n a) where-   constFromRational x = constVector [constFromRational x]+   constFromRational = replicateConst . constFromRational   class (RationalConstant a) => TranscendentalConstant a where@@ -356,6 +358,6 @@  instance TranscendentalConstant Float  where constPi = constOf pi instance TranscendentalConstant Double where constPi = constOf pi-instance (TranscendentalConstant a, LLVM.IsPrimitive a, TypeNum.PositiveT n) =>+instance (TranscendentalConstant a, LLVM.IsPrimitive a, TypeNum.Positive n) =>          TranscendentalConstant (Vector n a) where-   constPi = constVector [constPi]+   constPi = replicateConst constPi
src/LLVM/Extra/Vector.hs view
@@ -53,23 +53,28 @@ import LLVM.Util.Loop (Phi(phis, addPhis), ) import LLVM.Core    (Value, ConstValue, valueOf, value, constOf, undef,-    Vector, insertelement, extractelement, constVector,+    Vector, insertelement, extractelement,     IsConst, IsArithmetic, IsFloating,     IsPrimitive,     CodeGenFunction, ) -import Types.Data.Num (D4, (:+:), )-import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D4, (:+:), )++import qualified Control.Applicative as App import Control.Monad.HT ((<=<), ) import Control.Monad (liftM2, liftM3, foldM, )-import Data.Tuple.HT (uncurry3, )-import qualified Data.List.HT as ListHT-import qualified Data.List as List- import Control.Applicative (liftA2, )-import qualified Control.Applicative as App+ import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Empty as Empty+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.NonEmpty ((!:), )+import Data.Tuple.HT (uncurry3, )  -- import qualified Data.Bits as Bit import Data.Int  (Int8, Int16, Int32, Int64, )@@ -102,7 +107,7 @@    insert :: Value Word32 -> Element v -> v -> CodeGenFunction r v  class-   (TypeNum.PositiveT (Size v), Phi v, Class.Undefined v) =>+   (TypeNum.Positive (Size v), Phi v, Class.Undefined v) =>       Simple v where     type Element v :: *@@ -115,7 +120,7 @@   instance-   (TypeNum.PositiveT n, LLVM.IsPrimitive a) =>+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>       Simple (Value (Vector n a)) where     type Element (Value (Vector n a)) = Value a@@ -125,7 +130,7 @@    extract k v = extractelement v k  instance-   (TypeNum.PositiveT n, LLVM.IsPrimitive a) =>+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>       C (Value (Vector n a)) where     insert k a v = insertelement v a k@@ -190,7 +195,7 @@  newtype Constant n a = Constant a -constant :: (TypeNum.PositiveT n) => a -> Constant n a+constant :: (TypeNum.Positive n) => a -> Constant n a constant = Constant  instance Functor (Constant n) where@@ -218,7 +223,7 @@ instance (Class.Undefined a) => Class.Undefined (Constant n a) where    undefTuple = Class.undefTuplePointed -instance (TypeNum.PositiveT n, Phi a, Class.Undefined a) => Simple (Constant n a) where+instance (TypeNum.Positive n, Phi a, Class.Undefined a) => Simple (Constant n a) where     type Element (Constant n a) = a    type Size (Constant n a) = n@@ -233,7 +238,7 @@    type Construct n a :: *  instance-   (TypeNum.PositiveT n, LLVM.IsPrimitive a) =>+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>       Canonical n (Value a) where    type Construct n (Value a) = Value (Vector n a) @@ -245,12 +250,12 @@   size ::-   (TypeNum.PositiveT n) =>+   (TypeNum.Positive n) =>    Value (Vector n a) -> Int size =-   let sz :: (TypeNum.PositiveT n) => n -> Value (Vector n a) -> Int-       sz n _ = TypeNum.fromIntegerT n-   in  sz undefined+   let sz :: (TypeNum.Positive n) => TypeNum.Singleton n -> Value (Vector n a) -> Int+       sz n _ = TypeNum.integralFromSingleton n+   in  sz TypeNum.singleton  {- | Manually assemble a vector of equal values.@@ -259,13 +264,13 @@ replicate ::    (C v) =>    Element v -> CodeGenFunction r v-replicate = replicateCore undefined+replicate = replicateCore TypeNum.singleton  replicateCore ::    (C v) =>-   Size v -> Element v -> CodeGenFunction r v+   TypeNum.Singleton (Size v) -> Element v -> CodeGenFunction r v replicateCore n =-   assemble . List.replicate (TypeNum.fromIntegerT n)+   assemble . List.replicate (TypeNum.integralFromSingleton n)  {- | construct a vector out of single elements@@ -340,10 +345,16 @@  sizeInTuple :: Simple v => v -> Int sizeInTuple =-   let sz :: Simple v => Size v -> v -> Int-       sz n _ = TypeNum.fromIntegerT n-   in  sz undefined+   let sz :: Simple v => TypeNum.Singleton (Size v) -> v -> Int+       sz n _ = TypeNum.integralFromSingleton n+   in  sz TypeNum.singleton +constCyclicVector ::+   (IsConst a, TypeNum.Positive n) =>+   NonEmpty.T [] a -> ConstValue (Vector n a)+constCyclicVector =+   LLVM.constCyclicVector . fmap constOf+ {- | Rotate one element towards the higher elements. @@ -360,25 +371,27 @@    v -> CodeGenFunction r v rotateUp x =    shuffleMatch-      (constVector $ List.map constOf $-       (fromIntegral (sizeInTuple x) - 1) : [0..]) x+      (constCyclicVector $+       (fromIntegral (sizeInTuple x) - 1) !: [0..]) x  rotateDown ::    (Simple v) =>    v -> CodeGenFunction r v rotateDown x =    shuffleMatch-      (constVector $ List.map constOf $-       List.take (sizeInTuple x - 1) [1..] ++ [0]) x+      (constCyclicVector $+       NonEmpty.snoc (List.take (sizeInTuple x - 1) [1..]) 0) x  reverse ::    (Simple v) =>    v -> CodeGenFunction r v reverse x =    shuffleMatch-      (constVector $ List.map constOf $-       List.reverse $-       List.take (sizeInTuple x) [0..]) x+      (constCyclicVector $+       maybe (error "vector size must be positive") NonEmpty.reverse $+       NonEmpty.fetch $+       List.take (sizeInTuple x) [0..])+      x  shiftUp ::    (C v) =>@@ -386,7 +399,7 @@ shiftUp x0 x = do    y <-       shuffleMatch-         (constVector $ undef : List.map constOf [0..]) x+         (LLVM.constCyclicVector $ undef !: List.map constOf [0..]) x    liftM2 (,)       (extract (LLVM.valueOf (fromIntegral (sizeInTuple x) - 1)) x)       (insert (value LLVM.zero) x0 y)@@ -397,8 +410,10 @@ shiftDown x0 x = do    y <-       shuffleMatch-         (constVector $-          List.map constOf (List.take (sizeInTuple x - 1) [1..]) ++ [undef]) x+         (LLVM.constCyclicVector $+          NonEmpty.snoc+             (List.map constOf $ List.take (sizeInTuple x - 1) [1..])+             undef) x    liftM2 (,)       (extract (value LLVM.zero) x)       (insert (LLVM.valueOf (fromIntegral (sizeInTuple x) - 1)) x0 y)@@ -440,7 +455,7 @@   shuffleMatchPlain1 ::-   (TypeNum.PositiveT n, IsPrimitive a) =>+   (TypeNum.Positive n, IsPrimitive a) =>    Value (Vector n a) ->    ConstValue (Vector n Word32) ->    CodeGenFunction r (Value (Vector n a))@@ -448,7 +463,7 @@    shuffleMatchPlain2 x (value undef)  shuffleMatchPlain2 ::-   (TypeNum.PositiveT n, IsPrimitive a) =>+   (TypeNum.Positive n, IsPrimitive a) =>    Value (Vector n a) ->    Value (Vector n a) ->    ConstValue (Vector n Word32) ->@@ -477,8 +492,13 @@ extractAll ::    (Simple v) =>    v -> LLVM.CodeGenFunction r [Element v]-extractAll x =-   mapM+extractAll = sequence . extractList++extractList ::+   (Simple v) =>+   v -> [LLVM.CodeGenFunction r (Element v)]+extractList x =+   List.map       (flip extract x . LLVM.valueOf)       (take (sizeInTuple x) [0..]) @@ -546,19 +566,19 @@    (la -> CodeGenFunction r lb) ->    (va -> CodeGenFunction r vb) mapChunks2 f g a = do-   let chunkSize :: C ca => (ca -> cgf) -> Size ca -> Int-       chunkSize _ = TypeNum.fromIntegerT+   let chunkSize :: C ca => (ca -> cgf) -> TypeNum.Singleton (Size ca) -> Int+       chunkSize _ = TypeNum.integralFromSingleton    xs <- extractAll a    case ListHT.viewR $-        ListHT.sliceVertical (chunkSize g undefined) xs of+        ListHT.sliceVertical (chunkSize g TypeNum.singleton) xs of       Nothing -> assemble []       Just (cs,c) -> do          ds <- mapM (extractAll <=< g <=< assemble) cs          d <--            if List.length c <= chunkSize f undefined+            if List.length c <= chunkSize f TypeNum.singleton               then fmap List.concat $                    mapM (extractAll <=< f <=< assemble) $-                   ListHT.sliceVertical (chunkSize f undefined) c+                   ListHT.sliceVertical (chunkSize f TypeNum.singleton) c               else extractAll =<< g =<< assemble c          assemble $ List.concat ds ++ d @@ -580,7 +600,7 @@  withRound ::    (IsPrimitive a, IsPrimitive b,-    TypeNum.PositiveT k, TypeNum.PositiveT m, TypeNum.PositiveT n) =>+    TypeNum.Positive k, TypeNum.Positive m, TypeNum.Positive n) =>    CodeGenFunction r x ->    Ext.T (Value (Vector m a) -> Value Word32 -> CodeGenFunction r (Value (Vector m b))) ->    Ext.T (Value (Vector k a) -> Value Word32 -> CodeGenFunction r (Value (Vector k b))) ->@@ -607,7 +627,7 @@ Ideally on ix86 with SSE41 this would be translated to 'dpps'. -} dotProductPartial ::-   (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>+   (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>    Int ->    Value (Vector n a) ->    Value (Vector n a) ->@@ -616,7 +636,7 @@    sumPartial n =<< A.mul x y  sumPartial ::-   (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>+   (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>    Int ->    Value (Vector n a) ->    CodeGenFunction r (Value a)@@ -637,16 +657,15 @@ chop ::    (C c, C v, Element c ~ Element v) =>    v -> [CodeGenFunction r c]-chop = chopCore undefined+chop = chopCore TypeNum.singleton  chopCore ::    (C c, C v, Element c ~ Element v) =>-   Size c -> v -> [CodeGenFunction r c]+   TypeNum.Singleton (Size c) -> v -> [CodeGenFunction r c] chopCore m x =-   List.map (shuffle x . constVector) $-   ListHT.sliceVertical (TypeNum.fromIntegerT m) $-   List.map constOf $-   take (sizeInTuple x) [0..]+   List.map (assemble <=< sequence) $+   ListHT.sliceVertical (TypeNum.integralFromSingleton m) $+   extractList x  {- | The target size is determined by the type.@@ -673,7 +692,7 @@   getLowestPair ::-   (TypeNum.PositiveT n) =>+   (TypeNum.Positive n) =>    Value (Vector n a) ->    CodeGenFunction r (Value a, Value a) getLowestPair x =@@ -684,18 +703,18 @@  _reduceAddInterleaved ::    (IsArithmetic a, IsPrimitive a,-    TypeNum.PositiveT n, TypeNum.PositiveT m, (m :+: m) ~ n) =>-   m ->+    TypeNum.Positive n, TypeNum.Positive m, (m :+: m) ~ n) =>+   TypeNum.Singleton m ->    Value (Vector n a) ->    CodeGenFunction r (Value (Vector m a)) _reduceAddInterleaved tm v = do-   let m = TypeNum.fromIntegerT tm-   x <- shuffle v (constVector $ List.map constOf $ take m [0..])-   y <- shuffle v (constVector $ List.map constOf $ take m [fromIntegral m ..])+   let m = TypeNum.integralFromSingleton tm+   x <- shuffle v (constCyclicVector $ NonEmptyC.iterate succ 0)+   y <- shuffle v (constCyclicVector $ NonEmptyC.iterate succ m)    A.add x y  sumGeneric ::-   (IsArithmetic a, IsPrimitive a, TypeNum.PositiveT n) =>+   (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>    Value (Vector n a) ->    CodeGenFunction r (Value a) sumGeneric =@@ -703,17 +722,17 @@    reduceSumInterleaved 1  sumToPairGeneric ::-   (Arithmetic a, TypeNum.PositiveT n) =>+   (Arithmetic a, TypeNum.Positive n) =>    Value (Vector n a) ->    CodeGenFunction r (Value a, Value a) sumToPairGeneric v =    let n2 = div (size v) 2    in  sumInterleavedToPair =<<        shuffleMatchPlain1 v-          (constVector $+          (maybe (error "vector size must be positive") LLVM.constCyclicVector $+           NonEmpty.fetch $            List.map (constOf . fromIntegral) $-           concatMap (\k -> [k, k+n2]) $-           take n2 [0..])+           concatMap (\k -> [k, k+n2]) [0..])  {- | We partition a vector of size n into chunks of size m@@ -732,13 +751,13 @@ LLVM actually treats the vectors like vectors of smaller size. -} reduceSumInterleaved ::-   (IsArithmetic a, IsPrimitive a, TypeNum.PositiveT n) =>+   (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>    Int ->    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) reduceSumInterleaved m x0 =    let go ::-          (IsArithmetic a, IsPrimitive a, TypeNum.PositiveT n) =>+          (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>           Int ->           Value (Vector n a) ->           CodeGenFunction r (Value (Vector n a))@@ -750,12 +769,15 @@                in  go n2                       =<< A.add x                       =<< shuffleMatchPlain1 x-                             (constVector $ List.map constOf (take n2 [fromIntegral n2 ..])-                                 ++ List.repeat undef)+                             (LLVM.constCyclicVector $+                              NonEmpty.appendLeft+                                 (List.map constOf $+                                  take n2 [fromIntegral n2 ..])+                                 (NonEmptyC.repeat undef))    in  go (size x0) x0  cumulateGeneric, _cumulateSimple ::-   (IsArithmetic a, IsPrimitive a, TypeNum.PositiveT n) =>+   (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>    Value a -> Value (Vector n a) ->    CodeGenFunction r (Value a, Value (Vector n a)) _cumulateSimple a x =@@ -771,7 +793,7 @@    cumulateFrom1 cumulate1  cumulateFrom1 ::-   (IsArithmetic a, IsPrimitive a, TypeNum.PositiveT n) =>+   (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>    (Value (Vector n a) ->     CodeGenFunction r (Value (Vector n a))) ->    Value a -> Value (Vector n a) ->@@ -787,7 +809,7 @@ Needs (log n) vector additions -} cumulate1 ::-   (IsArithmetic a, IsPrimitive a, TypeNum.PositiveT n) =>+   (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) cumulate1 x =@@ -799,7 +821,7 @@   inttofp ::-   (LLVM.PositiveT n,+   (TypeNum.Positive n,     IsPrimitive a, IsPrimitive b,     LLVM.IsInteger a, IsFloating b) =>    Value (Vector n a) -> CodeGenFunction r (Value (Vector n b))@@ -811,7 +833,7 @@ because LLVM produces ugly code for Float and even more ugly code for Double. -} signumLogical ::-   (TypeNum.PositiveT n,+   (TypeNum.Positive n,     IsPrimitive a, IsPrimitive b, IsArithmetic b) =>    (Value (Vector n a) ->     Value (Vector n a) ->@@ -831,7 +853,7 @@ Cf. the outcommented signumInt. -} signumInt ::-   (TypeNum.PositiveT n,+   (TypeNum.Positive n,     IsPrimitive a, IsArithmetic a, IsConst a, Num a,     LLVM.CmpRet a, LLVM.CmpResult a ~ b,     IsPrimitive b, LLVM.IsInteger b) =>@@ -848,7 +870,7 @@       (negative, positive)  signumWord ::-   (TypeNum.PositiveT n,+   (TypeNum.Positive n,     IsPrimitive a, IsArithmetic a, IsConst a, Num a,     LLVM.CmpRet a, LLVM.CmpResult a ~ b,     IsPrimitive b, LLVM.IsInteger b) =>@@ -862,8 +884,8 @@ -}  signumIntGeneric ::-   (TypeNum.PositiveT n,-    {- TypeNum.PositiveT (n :*: LLVM.SizeOf a), -}+   (TypeNum.Positive n,+    {- TypeNum.Positive (n :*: LLVM.SizeOf a), -}     IsPrimitive a, LLVM.IsInteger a,     LLVM.CmpRet a, LLVM.CmpResult a ~ b,     IsPrimitive b, LLVM.IsInteger b) =>@@ -876,7 +898,7 @@    A.sub positive negative  signumWordGeneric ::-   (TypeNum.PositiveT n,+   (TypeNum.Positive n,     IsPrimitive a, LLVM.IsInteger a,     LLVM.CmpRet a, LLVM.CmpResult a ~ b,     IsPrimitive b, LLVM.IsInteger b) =>@@ -886,7 +908,7 @@    LLVM.zadapt =<< A.cmp LLVM.CmpGT x (LLVM.value LLVM.zero)  signumFloatGeneric ::-   (TypeNum.PositiveT n,+   (TypeNum.Positive n,     IsPrimitive a, IsArithmetic a, IsFloating a,     LLVM.CmpRet a, LLVM.CmpResult a ~ b,     IsPrimitive b, LLVM.IsInteger b) =>@@ -900,14 +922,14 @@   signedFraction ::-   (IsFloating a, IsConst a, Real a, TypeNum.PositiveT n) =>+   (IsFloating a, IsConst a, Real a, TypeNum.Positive n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) signedFraction x =    A.sub x =<< truncate x  floorGeneric ::-   (IsFloating a, IsConst a, Real a, TypeNum.PositiveT n) =>+   (IsFloating a, IsConst a, Real a, TypeNum.Positive n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) floorGeneric = floorLogical A.fcmp@@ -921,7 +943,7 @@ and then to a floating point number. -} fractionGeneric ::-   (IsFloating a, IsConst a, Real a, TypeNum.PositiveT n) =>+   (IsFloating a, IsConst a, Real a, TypeNum.Positive n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) fractionGeneric = fractionLogical A.fcmp@@ -950,7 +972,7 @@ instance Maskable Double where type Mask Double = Int64  makeMask ::-   (Maskable a, TypeNum.PositiveT n) =>+   (Maskable a, TypeNum.Positive n) =>    Value (Vector n a) ->    Value (Vector n Bool) ->    CodeGenFunction r (Value (Vector n (Mask a)))@@ -958,7 +980,7 @@   minGeneric, maxGeneric ::-   (IsConst a, Real a, Maskable a, TypeNum.PositiveT n) =>+   (IsConst a, Real a, Maskable a, TypeNum.Positive n) =>    Value (Vector n a) ->    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a))@@ -972,14 +994,14 @@    selectLogical b x y  absGeneric ::-   (IsConst a, Real a, Maskable a, TypeNum.PositiveT n) =>+   (IsConst a, Real a, Maskable a, TypeNum.Positive n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) absGeneric x =    maxGeneric x =<< LLVM.neg x  absAuto ::-   (TypeNum.PositiveT n, TypeNum.PositiveT m, TypeNum.PositiveT k,+   (TypeNum.Positive n, TypeNum.Positive m, TypeNum.Positive k,     IsConst a, Real a, Maskable a) =>    Ext.T (Value (Vector m a) -> CodeGenFunction r (Value (Vector m a))) ->    Ext.T (Value (Vector k a) -> CodeGenFunction r (Value (Vector k a))) ->@@ -1001,7 +1023,7 @@ When this issue is fixed, this function will be replaced by LLVM.select. -} select ::-   (LLVM.IsFirstClass a, IsPrimitive a, TypeNum.PositiveT n,+   (LLVM.IsFirstClass a, IsPrimitive a, TypeNum.Positive n,     LLVM.CmpRet a, LLVM.CmpResult a ~ Bool) =>    Value (Vector n Bool) ->    Value (Vector n a) ->@@ -1015,7 +1037,7 @@ This will need jumps. -} _floorSelect ::-   (Num a, IsFloating a, IsConst a, Real a, TypeNum.PositiveT n) =>+   (Num a, IsFloating a, IsConst a, Real a, TypeNum.Positive n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) _floorSelect x =@@ -1028,7 +1050,7 @@ This will need jumps. -} _fractionSelect ::-   (Num a, IsFloating a, IsConst a, Real a, TypeNum.PositiveT n) =>+   (Num a, IsFloating a, IsConst a, Real a, TypeNum.Positive n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) _fractionSelect x =@@ -1052,7 +1074,7 @@     LLVM.IsInteger i, IsPrimitive i,     LLVM.IsSized a, LLVM.IsSized i,     LLVM.SizeOf a ~ LLVM.SizeOf i,-    TypeNum.PositiveT n) =>+    TypeNum.Positive n) =>    Value (Vector n i) ->    Value (Vector n a) ->    Value (Vector n a) ->@@ -1067,7 +1089,7 @@  floorLogical ::    (IsFloating a, IsConst a, Real a,-    IsPrimitive i, LLVM.IsInteger i, TypeNum.PositiveT n) =>+    IsPrimitive i, LLVM.IsInteger i, TypeNum.Positive n) =>    (LLVM.FPPredicate ->     Value (Vector n a) ->     Value (Vector n a) ->@@ -1081,7 +1103,7 @@  fractionLogical ::    (IsFloating a, IsConst a, Real a,-    IsPrimitive i, LLVM.IsInteger i, TypeNum.PositiveT n) =>+    IsPrimitive i, LLVM.IsInteger i, TypeNum.Positive n) =>    (LLVM.FPPredicate ->     Value (Vector n a) ->     Value (Vector n a) ->@@ -1095,7 +1117,7 @@   order ::-   (TypeNum.PositiveT n, TypeNum.PositiveT m, TypeNum.PositiveT k,+   (TypeNum.Positive n, TypeNum.Positive m, TypeNum.Positive k,     LLVM.IsFirstClass a, IsPrimitive a) =>    (Value (Vector n a) -> Value (Vector n a) -> CodeGenFunction r (Value (Vector n a))) ->    Ext.T (Value (Vector m a) -> Value (Vector m a) -> CodeGenFunction r (Value (Vector m a))) ->@@ -1118,7 +1140,7 @@ -} class (IsArithmetic a, IsPrimitive a) => Arithmetic a where    sum ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       Value (Vector n a) ->       CodeGenFunction r (Value a)    sum = sumGeneric@@ -1129,7 +1151,7 @@    n must be at least D2.    -}    sumToPair ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       Value (Vector n a) ->       CodeGenFunction r (Value a, Value a)    sumToPair = sumToPairGeneric@@ -1140,20 +1162,20 @@    n must be at least D2.    -}    sumInterleavedToPair ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       Value (Vector n a) ->       CodeGenFunction r (Value a, Value a)    sumInterleavedToPair v =       getLowestPair =<< reduceSumInterleaved 2 v     cumulate ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       Value a -> Value (Vector n a) ->       CodeGenFunction r (Value a, Value (Vector n a))    cumulate = cumulateGeneric     dotProduct ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       Value (Vector n a) ->       Value (Vector n a) ->       CodeGenFunction r (Value a)@@ -1161,7 +1183,7 @@       dotProductPartial (size x) x y     mul ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       Value (Vector n a) ->       Value (Vector n a) ->       CodeGenFunction r (Value (Vector n a))@@ -1257,26 +1279,26 @@          zipChunksWith             (\cx cy -> do                evenX <- shuffleMatchPlain1 cx-                  (constVector [constOf 0, undef, constOf 2, undef])+                  (constVector4 (constOf 0, undef, constOf 2, undef))                evenY <- shuffleMatchPlain1 cy-                  (constVector [constOf 0, undef, constOf 2, undef])+                  (constVector4 (constOf 0, undef, constOf 2, undef))                evenZ64 <- pmul evenX evenY                evenZ <- LLVM.bitcast evenZ64                oddX <- shuffleMatchPlain1 cx-                  (constVector [constOf 1, undef, constOf 3, undef])+                  (constVector4 (constOf 1, undef, constOf 3, undef))                oddY <- shuffleMatchPlain1 cy-                  (constVector [constOf 1, undef, constOf 3, undef])+                  (constVector4 (constOf 1, undef, constOf 3, undef))                oddZ64 <- pmul oddX oddY                oddZ <- LLVM.bitcast oddZ64                shuffleMatchPlain2 evenZ oddZ-                  (constVector [constOf 0, constOf 4, constOf 2, constOf 6]))+                  (constVector4 (constOf 0, constOf 4, constOf 2, constOf 6)))             x y)       `Ext.run`       Ext.wrap X86C.sse41 (A.mul x y)   umul32to64 ::-   (TypeNum.PositiveT n) =>+   (TypeNum.Positive n) =>    Value (Vector n Word32) ->    Value (Vector n Word32) ->    CodeGenFunction r (Value (Vector n Word64))@@ -1290,18 +1312,18 @@          -- save an initial shuffle          (\cx cy -> do             evenX <- shuffleMatchPlain1 cx-               (constVector [constOf 0, undef, constOf 2, undef])+               (constVector4 (constOf 0, undef, constOf 2, undef))             evenY <- shuffleMatchPlain1 cy-               (constVector [constOf 0, undef, constOf 2, undef])+               (constVector4 (constOf 0, undef, constOf 2, undef))             evenZ <- pmul evenX evenY             oddX <- shuffleMatchPlain1 cx-               (constVector [constOf 1, undef, constOf 3, undef])+               (constVector4 (constOf 1, undef, constOf 3, undef))             oddY <- shuffleMatchPlain1 cy-               (constVector [constOf 1, undef, constOf 3, undef])+               (constVector4 (constOf 1, undef, constOf 3, undef))             oddZ <- pmul oddX oddY {-             shuffleMatchPlain2 evenZ oddZ-               (constVector [constOf 0, constOf 2, constOf 1, constOf 3])+               (constVector4 (constOf 0, constOf 2, constOf 1, constOf 3)) -}             assemble =<< (sequence $                extract (valueOf 0) evenZ :@@ -1313,50 +1335,58 @@          -- save the final shuffle          (\cx cy -> do             lowerX <- shuffleMatchPlain1 cx-               (constVector [constOf 0, undef, constOf 1, undef])+               (constVector4 (constOf 0, undef, constOf 1, undef))             lowerY <- shuffleMatchPlain1 cy-               (constVector [constOf 0, undef, constOf 1, undef])+               (constVector4 (constOf 0, undef, constOf 1, undef))             lowerZ <- pmul lowerX lowerY             upperX <- shuffleMatchPlain1 cx-               (constVector [constOf 2, undef, constOf 3, undef])+               (constVector4 (constOf 2, undef, constOf 3, undef))             upperY <- shuffleMatchPlain1 cy-               (constVector [constOf 2, undef, constOf 3, undef])+               (constVector4 (constOf 2, undef, constOf 3, undef))             upperZ <- pmul upperX upperY {-             shuffleMatchPlain2 lowerZ upperZ-               (constVector [constOf 0, constOf 1, constOf 2, constOf 3])+               (constVector4 (constOf 0, constOf 1, constOf 2, constOf 3)) -}             concat [lowerZ, upperZ]) -}          x y)  +constVector4 ::+   (IsConst a) =>+   (ConstValue a, ConstValue a, ConstValue a, ConstValue a) ->+   ConstValue (Vector D4 a)+constVector4 (a,b,c,d) =+   LLVM.constVector $ a!:b!:c!:d!:Empty.Cons++ {- | Attention: The rounding and fraction functions only work for floating point values with maximum magnitude of @maxBound :: Int32@.-This way we safe expensive handling of possibly seldom cases.+This way we save expensive handling of possibly seldom cases. -} class (Arithmetic a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool, IsConst a) =>          Real a where    min, max ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       Value (Vector n a) ->       Value (Vector n a) ->       CodeGenFunction r (Value (Vector n a))     abs ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       Value (Vector n a) ->       CodeGenFunction r (Value (Vector n a))     signum ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       Value (Vector n a) ->       CodeGenFunction r (Value (Vector n a))     truncate, floor, fraction ::-      (TypeNum.PositiveT n) =>+      (TypeNum.Positive n) =>       Value (Vector n a) ->       CodeGenFunction r (Value (Vector n a))
src/PrepareIntrinsics.hs view
@@ -233,7 +233,7 @@    "import qualified LLVM.Extra.Extension as Ext" :    "import qualified LLVM.Extra.ExtensionCheck.X86 as ExtX86" :    "import qualified LLVM.Core as LLVM" :-   "import qualified Types.Data.Num as TypeNum" :+   "import qualified Type.Data.Num.Decimal as TypeNum" :    "import qualified Data.Int as I" :    "import qualified Data.Word as W" :    "import Foreign.Ptr (Ptr, )" :