packages feed

llvm-extra 0.4.2 → 0.5

raw patch · 16 files changed

+606/−71 lines, 16 filesdep ~llvm-tf

Dependency ranges changed: llvm-tf

Files

llvm-extra.cabal view
@@ -1,5 +1,5 @@ Name:           llvm-extra-Version:        0.4.2+Version:        0.5 License:        BSD3 License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -72,7 +72,7 @@   default:     True  Source-Repository this-  Tag:         0.4.2+  Tag:         0.5   Type:        darcs   Location:    http://code.haskell.org/~thielema/llvm-extra/ @@ -84,7 +84,7 @@   Build-Depends:     -- llvm must be imported with restrictive version bounds,     -- because we import implicitly and unqualified-    llvm-tf >=3.0 && <3.0.1,+    llvm-tf >=3.0 && <3.0.2,     tfp >=0.7 && <0.9,     containers >=0.1 && <0.6,     transformers >=0.1.1 && <0.4,@@ -115,6 +115,7 @@     LLVM.Extra.ForeignPtr     LLVM.Extra.Maybe     LLVM.Extra.MaybeContinuation+    LLVM.Extra.Either     LLVM.Extra.Class     LLVM.Extra.Control     LLVM.Extra.Extension@@ -124,9 +125,13 @@     LLVM.Extra.Scalar     LLVM.Extra.Vector     LLVM.Extra.ScalarOrVector+    LLVM.Extra.Multi.Value+    LLVM.Extra.Multi.Vector+    LLVM.Extra.Multi.Class   Other-Modules:     LLVM.Extra.ArithmeticPrivate     LLVM.Extra.MaybePrivate+    LLVM.Extra.EitherPrivate     LLVM.Extra.Extension.X86Auto  Executable tone-llvm
src/Array.hs view
@@ -96,7 +96,7 @@        (y23 :: Value (Vector D2 Float))     s0 <- extractelement z (valueOf 0)     s1 <- extractelement z (valueOf 1)-    mul (0.25 :: Float) =<< add s0 s1+    A.mul (valueOf 0.25) =<< add s0 s1 -}  {-@@ -111,7 +111,7 @@     z <- A.add y y23     s0 <- extractelement z (valueOf 0)     s1 <- extractelement z (valueOf 1)-    mul (0.25 :: Float) =<< add s0 s1+    A.mul (valueOf 0.25) =<< A.add s0 s1   {-@@ -121,7 +121,7 @@ mixHorizontal y = do     z <- Ext.runUnsafe X86.haddps (value undef) y     s <- Ext.runUnsafe X86.haddps (value undef) z-    mul (0.25 :: Float) =<< extractelement s (valueOf 0)+    A.mul (valueOf 0.25) =<< extractelement s (valueOf 0)  {- Needs the dot product instruction from the SSE4 extension in ix86 CPUs.@@ -146,8 +146,8 @@  waveSaw :: Value Float -> CodeGenFunction r (Value Float) waveSaw t =-  sub (1 :: Float) =<<-  mul (2 :: Float) t+  A.sub (valueOf 1) =<<+  A.mul (valueOf 2) t  osciSaw :: Value Float -> Value Float -> CodeGenFunction r (Value Float, Value Float) osciSaw freq phase =@@ -165,7 +165,7 @@       y01 <- A.add y0 y1       y23 <- A.add y2 y3       y0123 <- A.add y01 y23-      flip store ptri =<< mul (0.25 :: Float) y0123+      flip store ptri =<< A.mul (valueOf 0.25) y0123       return ((phase0', phase1'), (phase2', phase3'))     ret (fst (fst s) :: Value Float) @@ -205,7 +205,7 @@          flip runStateT phases $             (sawOsciAction f0 =+= sawOsciAction f1) =+=             (sawOsciAction f2 =+= sawOsciAction f3)-      flip store ptri =<< mul (0.25 :: Float) y+      flip store ptri =<< A.mul (valueOf 0.25) y       return phases'     ret (fst (fst s))
src/LLVM/Extra/Arithmetic.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} module LLVM.Extra.Arithmetic (    -- * arithmetic: generalized and improved type inference    Additive (zero, add, sub, neg), one, inc, dec,    PseudoRing (mul), square,+   Scalar,    PseudoModule (scale),    Field (fdiv),    IntegerConstant(fromInteger'),@@ -100,17 +102,17 @@    mul = LLVM.mul  -class (PseudoRing a, Additive v) => PseudoModule a v where-   scale :: a -> v -> CodeGenFunction r v+type family Scalar vector :: *+type instance Scalar (Value a) = Value (SoV.Scalar a)+type instance Scalar (ConstValue a) = ConstValue (SoV.Scalar a) -instance-   (SoV.PseudoModule a v) =>-      PseudoModule (Value a) (Value v) where+class (PseudoRing (Scalar v), Additive v) => PseudoModule v where+   scale :: Scalar v -> v -> CodeGenFunction r v++instance (SoV.PseudoModule v) => PseudoModule (Value v) where    scale = SoV.scale -instance-   (SoV.PseudoModule a v) =>-      PseudoModule (ConstValue a) (ConstValue v) where+instance (SoV.PseudoModule v) => PseudoModule (ConstValue v) where    scale = SoV.scaleConst
src/LLVM/Extra/Class.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} module LLVM.Extra.Class where +import qualified LLVM.Extra.EitherPrivate as Either import qualified LLVM.Extra.MaybePrivate as Maybe import qualified LLVM.Core as LLVM import LLVM.Core@@ -50,7 +51,10 @@ instance (Undefined a) => Undefined (Maybe.T a) where    undefTuple = Maybe.Cons undefTuple undefTuple +instance (Undefined a, Undefined b) => Undefined (Either.T a b) where+   undefTuple = Either.Cons undefTuple undefTuple undefTuple + -- * class for tuples of zero values  class Zero a where@@ -98,6 +102,15 @@ instance (MakeValueTuple a) => MakeValueTuple (Maybe a) where    type ValueTuple (Maybe a) = Maybe.T (ValueTuple a)    valueTupleOf = maybe (Maybe.nothing undefTuple) (Maybe.just . valueTupleOf)++instance+   (MakeValueTuple a, MakeValueTuple b) =>+      MakeValueTuple (Either a b) where+   type ValueTuple (Either a b) = Either.T (ValueTuple a) (ValueTuple b)+   valueTupleOf =+      either+         (Either.left undefTuple . valueTupleOf)+         (Either.right undefTuple . valueTupleOf)  instance MakeValueTuple Float  where type ValueTuple Float  = Value Float  ; valueTupleOf = valueOf instance MakeValueTuple Double where type ValueTuple Double = Value Double ; valueTupleOf = valueOf
src/LLVM/Extra/Control.hs view
@@ -4,6 +4,7 @@ -} module LLVM.Extra.Control (    arrayLoop,+   arrayLoop2,    arrayLoopWithExit,    arrayLoop2WithExit,    fixedLengthLoop,@@ -58,6 +59,20 @@       liftM2 (,)          (advanceArrayElementPtr p)          (loopBody p s)++arrayLoop2 ::+   (Phi s, IsType a, IsType b,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>+   Value i -> Value (Ptr a) -> Value (Ptr b) -> s ->+   (Value (Ptr a) -> Value (Ptr b) -> s -> CodeGenFunction r s) ->+   CodeGenFunction r s+arrayLoop2 len ptrA ptrB start loopBody =+   fmap snd $+   arrayLoop len ptrA (ptrB,start)+      (\pa (pb,s) ->+         liftM2 (,)+            (advanceArrayElementPtr pb)+            (loopBody pa pb s))   arrayLoopWithExit ::
+ src/LLVM/Extra/Either.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TypeFamilies #-}+{- |+LLVM counterpart to 'Either' datatype.+-}+module LLVM.Extra.Either (+   Either.T(..),+   Either.run,+   Either.getIsLeft,+   Either.mapLeft,+   Either.mapRight,+   left,+   right,+   ) where++import qualified LLVM.Extra.EitherPrivate as Either+import LLVM.Extra.Class (Undefined, undefTuple, )+++left :: (Undefined b) => a -> Either.T a b+left = Either.left undefTuple++right :: (Undefined a) => b -> Either.T a b+right = Either.right undefTuple
+ src/LLVM/Extra/EitherPrivate.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.EitherPrivate where++import LLVM.Extra.Control (ifThenElse, )++import qualified LLVM.Core as LLVM+import LLVM.Core (Value, valueOf, CodeGenFunction, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import Control.Monad (liftM3, )+++{- |+If @isRight@, then @fromLeft@ is an @undefTuple@.+If @not isRight@, then @fromRight@ is an @undefTuple@.+I would prefer a union type,+but it was temporarily removed in LLVM-2.8 and did not return since then.+-}+data T a b = Cons {isRight :: Value Bool, fromLeft :: a, fromRight :: b}+++instance (Phi a, Phi b) => Phi (T a b) where+   phis bb (Cons r a b) = liftM3 Cons (phis bb r) (phis bb a) (phis bb b)+   addPhis bb (Cons r0 a0 b0) (Cons r1 a1 b1) =+      addPhis bb r0 r1 >> addPhis bb a0 a1 >> addPhis bb b0 b1+++{- |+counterpart to 'either'+-}+run ::+   (Phi c) =>+   T a b ->+   (a -> CodeGenFunction r c) ->+   (b -> CodeGenFunction r c) ->+   CodeGenFunction r c+run (Cons r a b) fa fb =+   ifThenElse r (fb b) (fa a)+++mapLeft :: (a0 -> a1) -> T a0 b -> T a1 b+mapLeft f (Cons r a b) = Cons r (f a) b++mapRight :: (b0 -> b1) -> T a b0 -> T a b1+mapRight f (Cons r a b) = Cons r a (f b)+++getIsLeft :: T a b -> CodeGenFunction r (Value Bool)+getIsLeft (Cons r _ _) = LLVM.inv r++left :: b -> a -> T a b+left undef a =+   Cons {isRight = valueOf False, fromLeft = a, fromRight = undef}++right :: a -> b -> T a b+right undef b =+   Cons {isRight = valueOf True, fromLeft = undef, fromRight = b}
src/LLVM/Extra/Maybe.hs view
@@ -5,15 +5,45 @@ module LLVM.Extra.Maybe (    Maybe.T(..),    Maybe.run,+   Maybe.for,+   Maybe.select,+   Maybe.alternative,    Maybe.fromBool,    Maybe.toBool,+   Maybe.getIsNothing,    Maybe.just,    nothing,+   Maybe.sequence,+   Maybe.traverse,+   Maybe.lift2,+   Maybe.liftM2,++   loopWithExit,    ) where  import qualified LLVM.Extra.MaybePrivate as Maybe+import qualified LLVM.Extra.Control as C import LLVM.Extra.Class (Undefined, undefTuple, ) +import LLVM.Util.Loop (Phi, )+import LLVM.Core (CodeGenFunction, ) + nothing :: (Undefined a) => Maybe.T a nothing = Maybe.nothing undefTuple+++loopWithExit ::+   Phi a =>+   a ->+   (a -> CodeGenFunction r (Maybe.T c, b)) ->+   ((c,b) -> CodeGenFunction r a) ->+   CodeGenFunction r b+loopWithExit start check body =+   fmap snd $+   C.loopWithExit start+      (\a -> do+         (mc,b) <- check a+         let (j,c) = Maybe.toBool mc+         return (j, (c,b)))+      body
src/LLVM/Extra/MaybeContinuation.hs view
@@ -140,54 +140,71 @@ onFail :: CodeGenFunction r () -> T r z a -> T r z a onFail handler m = Cons $ \n j -> resolve m (handler >> n) j +{- |+Run the first action and if that fails run the second action.+If both actions fail, then the composed action fails, too.+-}+alternative ::+   (Phi z, Undefined a) =>+   T r (Maybe.T a) a -> T r (Maybe.T a) a -> T r z a+alternative x y =+   fromMaybe $ resolve x (toMaybe y) (return . Maybe.just) ++fixedLengthLoop ::+   (Phi s, Undefined s,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>+   Value i -> s ->+   (s -> T r (Maybe.T s) s) ->+   CodeGenFunction r (Value i, Maybe.T s)+fixedLengthLoop len start loopBody = do+   (vars, i) <-+      C.loopWithExit (start, len)+         (\(s0, i) -> do+            counterRunning <- A.cmp LLVM.CmpGT i (value LLVM.zero)+            (running, ms1) <-+               C.ifThen counterRunning (valueOf False, Maybe.just s0) $+               fmap (\m -> (Maybe.isJust m, m)) $ toMaybe $ loopBody s0+            return (running, (ms1, i)))+         (\(ms, i) ->+            fmap ((,) (Maybe.fromJust ms)) $ A.dec i)+   pos <- A.sub len i+   return (pos, vars)++ {- | If the returned position is smaller than the array size,-then returned final state is undefined.+then returned final state is 'Maybe.nothing'. -} arrayLoop ::    (Phi s, Undefined s, IsType a,     Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>    Value i ->    Value (Ptr a) -> s ->-   (Value (Ptr a) -> s -> T r (Value Bool, s) s) ->-   CodeGenFunction r (Value i, s)+   (Value (Ptr a) -> s -> T r (Maybe.T (Value (Ptr a), s)) s) ->+   CodeGenFunction r (Value i, Maybe.T s) arrayLoop len ptr start loopBody =-   C.arrayLoopWithExit len ptr start $ \ptri s0 ->-      toBool (loopBody ptri s0)+   fmap (mapSnd (fmap snd)) $+   fixedLengthLoop len (ptr,start) $ \(ptr0,s0) -> do+      s1 <- loopBody ptr0 s0+      ptr1 <- lift $ A.advanceArrayElementPtr ptr0+      return (ptr1,s1) + arrayLoop2 ::    (Phi s, Undefined s, IsType a, IsType b,     Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>    Value i ->    Value (Ptr a) -> Value (Ptr b) -> s ->    (Value (Ptr a) -> Value (Ptr b) -> s ->-      T r (Value Bool, (Value (Ptr b), s)) s) ->-   CodeGenFunction r (Value i, s)+      T r (Maybe.T (Value (Ptr a), (Value (Ptr b), s))) s) ->+   CodeGenFunction r (Value i, Maybe.T s) arrayLoop2 len ptrA ptrB start loopBody =-   fmap (mapSnd snd) $+   fmap (mapSnd (fmap snd)) $    arrayLoop len ptrA (ptrB,start) $ \ptrAi (ptrB0,s0) -> do       s1 <- loopBody ptrAi ptrB0 s0       ptrB1 <- lift $ A.advanceArrayElementPtr ptrB0       return (ptrB1,s1)---fixedLengthLoop ::-   (Phi s, Undefined s,-    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>-   Value i -> s ->-   (s -> T r (Value Bool, (Value i, s)) s) ->-   CodeGenFunction r (Value i, s)-fixedLengthLoop len start loopBody = do-   (_,(lastI,lastS)) <--      C.whileLoopShared (valueOf True, (len, start)) $ \(cont,(i,s)) ->-         (A.and cont =<< A.cmp LLVM.CmpGT i (value LLVM.zero),-          resolve (loopBody s)-             (return (valueOf False, undefTuple))-             (\newS -> do-                newI <- A.dec i-                return (valueOf True, (newI, newS))))-   fmap (flip (,) lastS) $ A.sub len lastI   {-
src/LLVM/Extra/MaybePrivate.hs view
@@ -1,14 +1,18 @@ {-# LANGUAGE TypeFamilies #-} module LLVM.Extra.MaybePrivate where +import qualified LLVM.Extra.Control as C import LLVM.Extra.Control (ifThenElse, ) +import qualified LLVM.Core as LLVM import LLVM.Core (Value, valueOf, CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Control.Monad (liftM2, )+import qualified Control.Monad as Monad +import Prelude hiding (map, sequence) + {- | If @isJust = False@, then @fromJust@ is an @undefTuple@. -}@@ -19,7 +23,7 @@    fmap f (Cons b a) = Cons b (f a)  instance (Phi a) => Phi (T a) where-   phis bb (Cons b a) = liftM2 Cons (phis bb b) (phis bb a)+   phis bb (Cons b a) = Monad.liftM2 Cons (phis bb b) (phis bb a)    addPhis bb (Cons b0 a0) (Cons b1 a1) =       addPhis bb b0 b1 >> addPhis bb a0 a1 @@ -36,8 +40,32 @@ run (Cons b a) n j =    ifThenElse b (j a) n +for ::+   T a ->+   (a -> CodeGenFunction r ()) ->+   CodeGenFunction r ()+for = flip run (return ())  {- |+counterpart to 'Data.Maybe.fromMaybe' with swapped arguments+-}+select ::+   (C.Select a) =>+   T a ->+   a ->+   CodeGenFunction r a+select (Cons b a) d = C.select b a d++alternative ::+   (C.Select a) =>+   T a -> T a -> CodeGenFunction r (T a)+alternative (Cons b0 a0) (Cons b1 a1) =+   Monad.liftM2 Cons+      (LLVM.or b0 b1)+      (C.select b0 a0 a1)+++{- | counterpart to Data.Maybe.HT.toMaybe -} fromBool :: Value Bool -> a -> T a@@ -51,3 +79,28 @@  nothing :: a -> T a nothing undef = Cons (valueOf False) undef++getIsNothing :: T a -> CodeGenFunction r (Value Bool)+getIsNothing (Cons b _a) = LLVM.inv b+++lift2 ::+   (a -> b -> c) ->+   T a -> T b -> CodeGenFunction r (T c)+lift2 f (Cons b0 a0) (Cons b1 a1) =+   Monad.liftM (flip Cons (f a0 a1)) (LLVM.and b0 b1)++sequence ::+   T (CodeGenFunction r a) -> CodeGenFunction r (T a)+sequence (Cons b0 a0) =+   Monad.liftM (Cons b0) a0++traverse ::+   (a -> CodeGenFunction r b) ->+   T a -> CodeGenFunction r (T b)+traverse f = sequence . fmap f++liftM2 ::+   (a -> b -> CodeGenFunction r c) ->+   T a -> T b -> CodeGenFunction r (T c)+liftM2 f ma mb = Monad.join $ fmap sequence $ lift2 f ma mb
src/LLVM/Extra/Memory.hs view
@@ -16,6 +16,7 @@ import qualified LLVM.Extra.ArithmeticPrivate as A import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Array as Array+import qualified LLVM.Extra.Either as Either import qualified LLVM.Extra.Maybe as Maybe  import qualified LLVM.Core as LLVM@@ -42,7 +43,7 @@  import Data.Tuple.HT (fst3, snd3, thd3, ) -import Prelude hiding (maybe, )+import Prelude hiding (maybe, either, )   {- |@@ -196,6 +197,23 @@    store = storeRecord maybe    decompose = decomposeRecord maybe    compose = composeRecord maybe+++either ::+   (C a, C b) =>+   Record r (LLVM.Struct (Word32, (Struct a, (Struct b, ())))) (Either.T a b)+either =+   liftA3 Either.Cons+      (element Either.isRight d0)+      (element Either.fromLeft d1)+      (element Either.fromRight d2)++instance (C a, C b) => C (Either.T a b) where+   type Struct (Either.T a b) = LLVM.Struct (Word32, (Struct a, (Struct b, ())))+   load = loadRecord either+   store = storeRecord either+   decompose = decomposeRecord either+   compose = composeRecord either
+ src/LLVM/Extra/Multi/Class.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.Multi.Class where++import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Class as Class++import qualified LLVM.Core as LLVM++import qualified Types.Data.Num as TypeNum+++class C value where+   type Size value :: *+   switch ::+      f MultiValue.T ->+      f (MultiVector.T (Size value)) ->+      f value++instance C MultiValue.T where+   type Size MultiValue.T = TypeNum.D1+   switch x _ = x++instance (TypeNum.PositiveT n) => C (MultiVector.T n) where+   type Size (MultiVector.T n) = n+   switch _ x = x+++newtype Undef a value = Undef {getUndef :: value a}++undef ::+   (C value, Size value ~ n, TypeNum.PositiveT n,+    Class.MakeValueTuple a, MultiVector.C a) =>+   value a+undef =+   getUndef $+   switch+      (Undef MultiValue.undef)+      (Undef MultiVector.undef)+++newtype+   Add r a value =+      Add {runAdd :: value a -> value a -> 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) =>+   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)
+ src/LLVM/Extra/Multi/Value.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.Multi.Value where++import qualified LLVM.Extra.Class as Class++import Prelude hiding (zip, zip3, unzip, unzip3, )+++newtype T a = Cons (Class.ValueTuple a)+++valueOf :: (Class.MakeValueTuple a) => a -> T a+valueOf = Cons . Class.valueTupleOf++undef :: (Class.Undefined al, al ~ Class.ValueTuple a) => T a+undef = Cons Class.undefTuple+++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)++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)
+ src/LLVM/Extra/Multi/Vector.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.Multi.Vector where++import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Class as Class++import qualified LLVM.Core as LLVM+import LLVM.Core+   (Value, ConstValue, valueOf, value,+    IsPrimitive,+    CodeGenFunction, )++import qualified Types.Data.Num as TypeNum++import qualified Data.List as List+import Data.Word (Word32, )++import Control.Monad (liftM2, liftM3, foldM, )++import Prelude hiding (zip, zip3, unzip, unzip3, )+++newtype T n a = Cons (Vector n a)++instance (TypeNum.PositiveT n, C a) => Class.Undefined (T n a) where+   undefTuple = undef+++size :: TypeNum.PositiveT n => T n a -> Int+size =+   let sz :: TypeNum.PositiveT n => n -> T n a -> Int+       sz n _ = TypeNum.fromIntegerT n+   in  sz undefined+++zip :: T n a -> T n b -> T n (a,b)+zip (Cons a) (Cons b) = Cons (a,b)++zip3 :: T n a -> T n b -> T n c -> T n (a,b,c)+zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c)++unzip :: T n (a,b) -> (T n a, T n b)+unzip (Cons (a,b)) = (Cons a, Cons b)++unzip3 :: T n (a,b,c) -> (T n a, T n b, T n c)+unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c)+++class C a where+   type Vector n a :: *+   undef :: (TypeNum.PositiveT n) => T n a+   shuffleMatch ::+      (TypeNum.PositiveT n) =>+      ConstValue (LLVM.Vector n Word32) -> T n a -> CodeGenFunction r (T n a)+   extract ::+      (TypeNum.PositiveT n) =>+      LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)+   insert ::+      (TypeNum.PositiveT n) =>+      LLVM.Value Word32 -> MultiValue.T a ->+      T n a -> CodeGenFunction r (T n a)++instance C Float where+   type Vector n Float = LLVM.Value (LLVM.Vector n Float)+   undef = undefPrimitive+   shuffleMatch = shuffleMatchPrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Double where+   type Vector n Double = LLVM.Value (LLVM.Vector n Double)+   undef = undefPrimitive+   shuffleMatch = shuffleMatchPrimitive+   extract = extractPrimitive+   insert = insertPrimitive++undefPrimitive ::+   (TypeNum.PositiveT n, IsPrimitive a,+    Vector n a ~ Value (LLVM.Vector n a)) =>+   T n a+undefPrimitive = Cons $ LLVM.value LLVM.undef++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++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) =+   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 ->+   MultiValue.T a -> T n a -> CodeGenFunction r (T n a)+insertPrimitive k (MultiValue.Cons a) (Cons v) =+   fmap Cons $ LLVM.insertelement v a k+++instance (C a, C b) => C (a,b) where+   type Vector n (a,b) = (Vector n a, Vector n b)++   undef = zip undef undef++   shuffleMatch is v =+      case unzip v of+         (v0,v1) ->+            liftM2 zip+               (shuffleMatch is v0)+               (shuffleMatch is v1)++   extract k v =+      case unzip v of+         (v0,v1) ->+            liftM2 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+               (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++   shuffleMatch is v =+      case unzip3 v of+         (v0,v1,v2) ->+            liftM3 zip3+               (shuffleMatch is v0)+               (shuffleMatch is v1)+               (shuffleMatch is v2)++   extract k v =+      case unzip3 v of+         (v0,v1,v2) ->+            liftM3 MultiValue.zip3+               (extract k v0)+               (extract k v1)+               (extract k v2)++   insert k a v =+      case (MultiValue.unzip3 a, unzip3 v) of+         ((a0,a1,a2), (v0,v1,v2)) ->+            liftM3 zip3+               (insert k a0 v0)+               (insert k a1 v1)+               (insert k a2 v2)+++assemble ::+   (TypeNum.PositiveT 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) =>+   T n a -> LLVM.CodeGenFunction r [MultiValue.T a]+dissect x =+   mapM+      (flip extract x . LLVM.valueOf)+      (take (size x) [0..])+++-- * function based on classes from Vector module++shuffleMatchGen ::+   (Vector n a ~ v, Vector.Simple v, n ~ Vector.Size v) =>+   ConstValue (LLVM.Vector n Word32) ->+   T n a -> CodeGenFunction r (T n a)+shuffleMatchGen is (Cons v) =+   fmap Cons $ Vector.shuffleMatch is v++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++insertGen ::+   (Vector n a ~ v, Vector.C v, Class.ValueTuple a ~ Vector.Element v) =>+   LLVM.Value Word32 -> MultiValue.T a ->+   T n a -> CodeGenFunction r (T n a)+insertGen n (MultiValue.Cons a) (Cons v) =+   fmap Cons $ Vector.insert n a v
src/LLVM/Extra/Scalar.hs view
@@ -29,24 +29,38 @@  unliftM ::    (Monad m) =>-   (T a -> m (T b)) ->-   a -> m b+   (T a -> m (T r)) ->+   a -> m r unliftM f a =    Monad.liftM decons $ f (Cons a)  unliftM2 ::    (Monad m) =>-   (T a -> T b -> m (T c)) ->-   a -> b -> m c+   (T a -> T b -> m (T r)) ->+   a -> b -> m r unliftM2 f a b =    Monad.liftM decons $ f (Cons a) (Cons b)  unliftM3 ::    (Monad m) =>-   (T a -> T b -> T c -> m (T d)) ->-   a -> b -> c -> m d+   (T a -> T b -> T c -> m (T r)) ->+   a -> b -> c -> m r unliftM3 f a b c =    Monad.liftM decons $ f (Cons a) (Cons b) (Cons c)++unliftM4 ::+   (Monad m) =>+   (T a -> T b -> T c -> T d -> m (T r)) ->+   a -> b -> c -> d -> m r+unliftM4 f a b c d =+   Monad.liftM decons $ f (Cons a) (Cons b) (Cons c) (Cons d)++unliftM5 ::+   (Monad m) =>+   (T a -> T b -> T c -> T d -> T e -> m (T r)) ->+   a -> b -> c -> d -> e -> m r+unliftM5 f a b c d e =+   Monad.liftM decons $ f (Cons a) (Cons b) (Cons c) (Cons d) (Cons e)   instance (Class.Zero a) => Class.Zero (T a) where
src/LLVM/Extra/ScalarOrVector.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {- | Support for unified handling of scalars and vectors.@@ -303,23 +301,23 @@   class-   (LLVM.IsArithmetic a, LLVM.IsArithmetic v) =>-      PseudoModule a v where-   scale :: Value a -> Value v -> CodeGenFunction r (Value v)-   scaleConst :: ConstValue a -> ConstValue v -> CodeGenFunction r (ConstValue v)+   (LLVM.IsArithmetic (Scalar v), LLVM.IsArithmetic v) =>+      PseudoModule v where+   scale :: (a ~ Scalar v) => Value a -> Value v -> CodeGenFunction r (Value v)+   scaleConst :: (a ~ Scalar v) => ConstValue a -> ConstValue v -> CodeGenFunction r (ConstValue v) -instance PseudoModule Word8  Word8  where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Word16 Word16 where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Word32 Word32 where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Word64 Word64 where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Int8   Int8   where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Int16  Int16  where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Int32  Int32  where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Int64  Int64  where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Float  Float  where scale = LLVM.mul; scaleConst = LLVM.mul-instance PseudoModule Double Double where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Word8  where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Word16 where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Word32 where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Word64 where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Int8   where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Int16  where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Int32  where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Int64  where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Float  where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Double where scale = LLVM.mul; scaleConst = LLVM.mul instance (LLVM.IsArithmetic a, LLVM.IsPrimitive a, TypeNum.PositiveT n) =>-         PseudoModule a (Vector n a) where+         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