packages feed

llvm-extra 0.7.3 → 0.8

raw patch · 15 files changed

+1953/−1210 lines, 15 filesdep +bool8dep ~containersdep ~llvm-tfdep ~utility-ht

Dependencies added: bool8

Dependency ranges changed: containers, llvm-tf, utility-ht

Files

llvm-extra.cabal view
@@ -1,5 +1,5 @@ Name:           llvm-extra-Version:        0.7.3+Version:        0.8 License:        BSD3 License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -52,9 +52,9 @@   * a Makefile and a description     of how to run LLVM code from within GHCi. Stability:      Experimental-Tested-With:    GHC==6.10.4, GHC==6.12.3-Tested-With:    GHC==7.0.4, GHC==7.4.1, GHC==7.6.3-Cabal-Version:  >=1.14+Tested-With:    GHC==7.0.4, GHC==7.4.2, GHC==7.8.2+Tested-With:    GHC==8.4.3, GHC==8.6.1+Cabal-Version:  1.14 Build-Type:     Simple Extra-Source-Files:   Makefile@@ -75,7 +75,7 @@   default:     True  Source-Repository this-  Tag:         0.7.3+  Tag:         0.8   Type:        darcs   Location:    http://code.haskell.org/~thielema/llvm-extra/ @@ -87,13 +87,14 @@   Build-Depends:     -- llvm must be imported with restrictive version bounds,     -- because we import implicitly and unqualified-    llvm-tf >=3.0.3 && <3.2,+    llvm-tf >=3.1.1 && <3.2,     tfp >=1.0 && <1.1,     non-empty >=0.2.1 && <0.4,-    containers >=0.1 && <0.6,+    containers >=0.1 && <0.7,+    bool8 >=0.0 && <0.1,     bifunctors >=5.4 && <6,     transformers >=0.1.1 && <0.6,-    utility-ht >=0.0.1 && <0.1+    utility-ht >=0.0.11 && <0.1    Build-Depends:     base >=3 && <5@@ -133,8 +134,10 @@     LLVM.Extra.Multi.Iterator     LLVM.Extra.Multi.Value     LLVM.Extra.Multi.Value.Memory+    LLVM.Extra.Multi.Value.Vector     LLVM.Extra.Multi.Vector     LLVM.Extra.Multi.Vector.Memory+    LLVM.Extra.Multi.Vector.Instance     LLVM.Extra.Multi.Class   Other-Modules:     LLVM.Extra.ArithmeticPrivate@@ -142,6 +145,7 @@     LLVM.Extra.EitherPrivate     LLVM.Extra.MemoryPrivate     LLVM.Extra.Extension.X86Auto+    LLVM.Extra.Multi.Value.Private  Executable tone-llvm   If flag(buildExamples)@@ -150,7 +154,7 @@       llvm-tf,       tfp,       non-empty,-      containers >=0.1 && <0.6,+      containers >=0.1 && <0.7,       transformers,       utility-ht >=0.0.1 && <0.1,       base >=3 && <5@@ -164,7 +168,7 @@   If flag(buildTools)     Build-Depends:       parsec >=2.1 && <3.2,-      containers >=0.1 && <0.6,+      containers >=0.1 && <0.7,       transformers,       utility-ht >=0.0.1 && <0.1,       base >=3 && <5
src/LLVM/Extra/Class.hs view
@@ -146,7 +146,7 @@ {- instance (MakeValueTuple haskellValue llvmValue, Memory llvmValue llvmStruct) =>          MakeValueTuple (Ptr haskellValue) (Value (Ptr llvmStruct)) where-   valueTupleOf = valueOf . castStorablePtr+   valueTupleOf = valueOf . castTuplePtr  instance (Pos n) => MakeValueTuple (IntN n) where    type ValueTuple (IntN n) = (Value (IntN n))
src/LLVM/Extra/Extension/X86.hs view
@@ -33,6 +33,11 @@    X86.haddps, X86.haddpd, X86.dpps, X86.dppd,    roundss, X86.roundps, roundsd, X86.roundpd,    absss, abssd, absps, abspd,+   X86.psllw128, X86.pslld128, X86.psllq128,+   X86.psrlw128, X86.psrld128, X86.psrlq128,+   X86.psraw128, X86.psrad128,+   X86.paddsb128, X86.paddsw128, X86.paddusb128, X86.paddusw128,+   X86.psubsb128, X86.psubsw128, X86.psubusb128, X86.psubusw128,    ) where  import qualified LLVM.Extra.Extension.X86Auto as X86@@ -47,7 +52,6 @@ import LLVM.Extra.ExtensionCheck.X86           (sse1, sse2, sse41, sse42, ) -import qualified LLVM.Extra.Monad as M import qualified LLVM.Extra.ArithmeticPrivate as A import qualified LLVM.Core as LLVM import LLVM.Core@@ -63,6 +67,7 @@ import Data.Bits (clearBit, complement, ) import Data.Word (Word8, Word32, Word64, ) +import qualified Control.Monad.HT as M import Control.Monad.HT ((<=<), ) import Control.Applicative (pure, ) @@ -86,10 +91,10 @@           LLVM.FPOGE   -> f 2 y x           LLVM.FPOLT   -> f 1 x y           LLVM.FPOLE   -> f 2 x y-          LLVM.FPONE   -> M.liftR2 A.and (f 7 x y) (f 4 x y)+          LLVM.FPONE   -> M.liftJoin2 A.and (f 7 x y) (f 4 x y)           LLVM.FPORD   -> f 7 x y           LLVM.FPUNO   -> f 3 x y-          LLVM.FPUEQ   -> M.liftR2 A.or (f 3 x y) (f 0 x y)+          LLVM.FPUEQ   -> M.liftJoin2 A.or (f 3 x y) (f 0 x y)           LLVM.FPUGT   -> f 6 x y           LLVM.FPUGE   -> f 5 x y           LLVM.FPULT   -> f 6 y x
src/LLVM/Extra/Iterator.hs view
@@ -32,7 +32,7 @@ Simulates a non-strict list. -} data T r a =-   forall s. (Phi s) =>+   forall s. (Phi s, Class.Undefined s) =>    Cons s (forall z. (Phi z) => s -> MaybeCont.T r z (a,s))  mapM_ :: (a -> CodeGenFunction r ()) -> T r a -> CodeGenFunction r ()@@ -151,20 +151,10 @@ I.e. if 'f' reads from or writes to memory make sure that accessing one more pointer is legal. -}-iterate :: (Phi a) => (a -> CodeGenFunction r a) -> a -> T r a+iterate ::+   (Phi a, Class.Undefined a) => (a -> CodeGenFunction r a) -> a -> T r a iterate f a = Cons a (\a0 -> MaybeCont.lift $ fmap ((,) a0) $ f a0) -{- |-This is MaybeCont.toMaybe' where @('Undefined' a)@ constraint-is replaced by a custom value.-This way, we do not need 'Undefined' constraint in 'T'.-On the other hand, an LLVM-undefined value would enable more LLVM optimizations.--}-maybeFromCont ::-   a -> MaybeCont.T r (Maybe.T a) a -> CodeGenFunction r (Maybe.T a)-maybeFromCont undef (MaybeCont.Cons m) =-   m (return $ Maybe.Cons (valueOf False) undef) (return . Maybe.just)- cartesianAux ::    (Phi a, Phi b, Class.Undefined a, Class.Undefined b) =>    T r a -> T r b -> T r (Maybe.T (a,b))@@ -172,10 +162,9 @@    Cons (Maybe.nothing,sa,sb)       (\(ma0,sa0,sb0) -> do          (a1,sa1) <--            MaybeCont.fromMaybe $-            Maybe.run ma0-               (maybeFromCont (Class.undefTuple,sa0) $ nextA sa0)-               (\a0 -> return (Maybe.just (a0,sa0)))+            MaybeCont.alternative+               (MaybeCont.fromMaybe $ return $ fmap (flip (,) sa0) ma0)+               (nextA sa0)          MaybeCont.lift $             MaybeCont.resolve (nextB sb0)                (return (Maybe.nothing,(Maybe.nothing,sa1,sb)))
src/LLVM/Extra/Memory.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} module LLVM.Extra.Memory (-   C(load, store, decompose, compose), modify, castStorablePtr,+   C(load, store, decompose, compose), modify, castStorablePtr, castTuplePtr,    Struct,    Record, Element, element,    loadRecord, storeRecord, decomposeRecord, composeRecord,@@ -388,10 +388,12 @@    compose   = MultiVectorMemory.compose  -castStorablePtr ::+{-# DEPRECATED castStorablePtr "use castTuplePtr instead" #-}+castStorablePtr, castTuplePtr ::    (MakeValueTuple haskellValue, C (ValueTuple haskellValue)) =>    Ptr haskellValue -> Ptr (Struct (ValueTuple haskellValue)) castStorablePtr = castPtr+castTuplePtr = castPtr
src/LLVM/Extra/Monad.hs view
@@ -1,20 +1,24 @@ {- | These functions work in arbitrary monads-but are especially helpful when working with the CodeGenFunction monad.+but are especially helpful when working with the @CodeGenFunction@ monad. -}-module LLVM.Extra.Monad where+module LLVM.Extra.Monad+   {-# DEPRECATED "use utility-ht:Control.Monad.HT" #-} where  import Control.Monad (liftM2, liftM3, join, (<=<), )  +{-# DEPRECATED chain "use utility-ht:Control.Monad.HT.chain" #-} chain :: (Monad m) => [a -> m a] -> (a -> m a) chain =    foldr (flip (<=<)) return +{-# DEPRECATED liftR2 "use utility-ht:Control.Monad.HT.liftJoin2" #-} liftR2 :: (Monad m) => (a -> b -> m c) -> m a -> m b -> m c liftR2 f ma mb =    join (liftM2 f ma mb) +{-# DEPRECATED liftR3 "use utility-ht:Control.Monad.HT.liftJoin3" #-} liftR3 :: (Monad m) => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d liftR3 f ma mb mc =    join (liftM3 f ma mb mc)
src/LLVM/Extra/Multi/Value.hs view
@@ -1,1057 +1,6 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-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 qualified LLVM.Core as LLVM-import qualified LLVM.Util.Loop as Loop-import LLVM.Util.Loop (Phi, )--import Type.Data.Num.Decimal (D1)--import Foreign.StablePtr (StablePtr, )-import Foreign.Ptr (Ptr, FunPtr, )--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.Complex (Complex((:+)))-import Data.Function (id, (.), ($), )-import Data.Tuple.HT (uncurry3, )-import Data.Maybe (Maybe(Nothing,Just), )-import Data.Bool (Bool(False,True), )-import Data.Word (Word8, Word16, Word32, Word64, )-import Data.Int (Int8, Int16, Int32, Int64, )--import Prelude (Float, Double, Integer, Rational, )---newtype T a = Cons (Repr LLVM.Value a)---class C a where-   type Repr (f :: * -> *) a :: *-   cons :: a -> T a-   undef :: T a-   zero :: T a-   phis :: LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)-   addPhis :: LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()--instance C Bool where-   type Repr f Bool = f Bool-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Float where-   type Repr f Float = f Float-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Double where-   type Repr f Double = f Double-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Word8 where-   type Repr f Word8 = f Word8-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Word16 where-   type Repr f Word16 = f Word16-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Word32 where-   type Repr f Word32 = f Word32-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance C Word64 where-   type Repr f Word64 = f Word64-   cons = consPrimitive-   undef = undefPrimitive-   zero = zeroPrimitive-   phis = phisPrimitive-   addPhis = addPhisPrimitive--instance 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 (Maybe a) where-   type Repr f (Maybe a) = (f Bool, Repr f a)-   cons Nothing = nothing-   cons (Just a) = just $ cons a-   undef = toMaybe undef undef-   zero = toMaybe (cons False) zero-   phis bb ma =-      case splitMaybe ma of-         (b,a) -> Monad.lift2 toMaybe (phis bb b) (phis bb a)-   addPhis bb x y =-      case (splitMaybe x, splitMaybe y) of-         ((xb,xa), (yb,ya)) ->-            addPhis bb xb yb >>-            addPhis bb xa ya--splitMaybe :: T (Maybe a) -> (T Bool, T a)-splitMaybe (Cons (b,a)) = (Cons b, Cons a)--toMaybe :: T Bool -> T a -> T (Maybe a)-toMaybe (Cons b) (Cons a) = Cons (b,a)--nothing :: (C a) => T (Maybe a)-nothing = toMaybe (cons False) undef--just :: T a -> T (Maybe a)-just = toMaybe (cons True)---instance (C a, C b) => C (a,b) where-   type Repr f (a, b) = (Repr f a, Repr f b)-   cons (a,b) = zip (cons a) (cons b)-   undef = zip undef undef-   zero = zip zero zero-   phis bb a =-      case unzip a of-         (a0,a1) ->-            Monad.lift2 zip (phis bb a0) (phis bb a1)-   addPhis bb a b =-      case (unzip a, unzip b) of-         ((a0,a1), (b0,b1)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1--instance (C a, C b, C c) => C (a,b,c) where-   type Repr f (a, b, c) = (Repr f a, Repr f b, Repr f c)-   cons (a,b,c) = zip3 (cons a) (cons b) (cons c)-   undef = zip3 undef undef undef-   zero = zip3 zero zero zero-   phis bb a =-      case unzip3 a of-         (a0,a1,a2) ->-            Monad.lift3 zip3 (phis bb a0) (phis bb a1) (phis bb a2)-   addPhis bb a b =-      case (unzip3 a, unzip3 b) of-         ((a0,a1,a2), (b0,b1,b2)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1 >>-            addPhis bb a2 b2--instance (C a, C b, C c, C d) => C (a,b,c,d) where-   type Repr f (a, b, c, d) = (Repr f a, Repr f b, Repr f c, Repr f d)-   cons (a,b,c,d) = zip4 (cons a) (cons b) (cons c) (cons d)-   undef = zip4 undef undef undef undef-   zero = zip4 zero zero zero zero-   phis bb a =-      case unzip4 a of-         (a0,a1,a2,a3) ->-            Monad.lift4 zip4 (phis bb a0) (phis bb a1) (phis bb a2) (phis bb a3)-   addPhis bb a b =-      case (unzip4 a, unzip4 b) of-         ((a0,a1,a2,a3), (b0,b1,b2,b3)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1 >>-            addPhis bb a2 b2 >>-            addPhis bb a3 b3---fst :: T (a,b) -> T a-fst (Cons (a,_b)) = Cons a--snd :: T (a,b) -> T b-snd (Cons (_a,b)) = Cons b--curry :: (T (a,b) -> c) -> (T a -> T b -> c)-curry f a b = f $ zip a b--uncurry :: (T a -> T b -> c) -> (T (a,b) -> c)-uncurry f = Tuple.uncurry f . unzip---mapFst :: (T a0 -> T a1) -> T (a0,b) -> T (a1,b)-mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip--mapSnd :: (T b0 -> T b1) -> T (a,b0) -> T (a,b1)-mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip--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)---instance (C a) => C (Complex a) where-   type Repr f (Complex a) = Complex (Repr f a)-   cons (a:+b) = consComplex (cons a) (cons b)-   undef = consComplex undef undef-   zero = consComplex zero zero-   phis bb a =-      case deconsComplex a of-         (a0,a1) ->-            Monad.lift2 consComplex (phis bb a0) (phis bb a1)-   addPhis bb a b =-      case (deconsComplex a, deconsComplex b) of-         ((a0,a1), (b0,b1)) ->-            addPhis bb a0 b0 >>-            addPhis bb a1 b1--consComplex :: T a -> T a -> T (Complex a)-consComplex (Cons a) (Cons b) = Cons (a:+b)--deconsComplex :: T (Complex a) -> (T a, T a)-deconsComplex (Cons (a:+b)) = (Cons a, Cons b)----class Compose multituple where-   type Composed multituple-   {- |-   A nested 'zip'.-   -}-   compose :: multituple -> T (Composed multituple)--class-   (Composed (Decomposed T pattern) ~ PatternTuple pattern) =>-      Decompose pattern where-   {- |-   A nested 'unzip'.-   Since it is not obvious how deep to decompose nested tuples,-   you must provide a pattern of the decomposed tuple.-   E.g.--   > f :: MultiValue ((a,b),(c,d)) ->-   >      ((MultiValue a, MultiValue b), MultiValue (c,d))-   > f = decompose ((atom,atom),atom)-   -}-   decompose :: pattern -> T (PatternTuple pattern) -> Decomposed T pattern--type family Decomposed (f :: * -> *) pattern-type family PatternTuple pattern---{- |-A combination of 'compose' and 'decompose'-that let you operate on tuple multivalues as Haskell tuples.--}-modify ::-   (Compose a, Decompose pattern) =>-   pattern ->-   (Decomposed T pattern -> a) ->-   T (PatternTuple pattern) -> T (Composed a)-modify p f = compose . f . decompose p--modify2 ::-   (Compose a, Decompose patternA, Decompose patternB) =>-   patternA ->-   patternB ->-   (Decomposed T patternA -> Decomposed T patternB -> a) ->-   T (PatternTuple patternA) -> T (PatternTuple patternB) -> T (Composed a)-modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b)--modifyF ::-   (Compose a, Decompose pattern, Functor f) =>-   pattern ->-   (Decomposed T pattern -> f a) ->-   T (PatternTuple pattern) -> f (T (Composed a))-modifyF p f = fmap compose . f . decompose p--modifyF2 ::-   (Compose a, Decompose patternA, Decompose patternB,-    Functor f) =>-   patternA ->-   patternB ->-   (Decomposed T patternA -> Decomposed T patternB -> f a) ->-   T (PatternTuple patternA) -> T (PatternTuple patternB) -> f (T (Composed a))-modifyF2 pa pb f a b = fmap compose $ f (decompose pa a) (decompose pb b)----instance Compose (T a) where-   type Composed (T a) = a-   compose = id--instance Decompose (Atom a) where-   decompose _ = id--type instance Decomposed f (Atom a) = f a-type instance PatternTuple (Atom a) = a--data Atom a = Atom--atom :: Atom a-atom = Atom---instance Compose () where-   type Composed () = ()-   compose = cons--instance () => Decompose () where-   decompose () _ = ()--type instance Decomposed f () = ()-type instance PatternTuple () = ()---instance (Compose a, Compose b) => Compose (a,b) where-   type Composed (a,b) = (Composed a, Composed b)-   compose = Tuple.uncurry zip . TupleHT.mapPair (compose, compose)--instance (Decompose pa, Decompose pb) => Decompose (pa,pb) where-   decompose (pa,pb) =-      TupleHT.mapPair (decompose pa, decompose pb) . unzip--type instance Decomposed f (pa,pb) = (Decomposed f pa, Decomposed f pb)-type instance PatternTuple (pa,pb) = (PatternTuple pa, PatternTuple pb)---instance (Compose a, Compose b, Compose c) => Compose (a,b,c) where-   type Composed (a,b,c) = (Composed a, Composed b, Composed c)-   compose = uncurry3 zip3 . TupleHT.mapTriple (compose, compose, compose)--instance-   (Decompose pa, Decompose pb, Decompose pc) =>-      Decompose (pa,pb,pc) where-   decompose (pa,pb,pc) =-      TupleHT.mapTriple (decompose pa, decompose pb, decompose pc) . unzip3--type instance Decomposed f (pa,pb,pc) =-        (Decomposed f pa, Decomposed f pb, Decomposed f pc)-type instance PatternTuple (pa,pb,pc) =-        (PatternTuple pa, PatternTuple pb, PatternTuple pc)---instance (Compose a, Compose b, Compose c, Compose d) => Compose (a,b,c,d) where-   type Composed (a,b,c,d) = (Composed a, Composed b, Composed c, Composed d)-   compose (a,b,c,d) = zip4 (compose a) (compose b) (compose c) (compose d)--instance-   (Decompose pa, Decompose pb, Decompose pc, Decompose pd) =>-      Decompose (pa,pb,pc,pd) where-   decompose (pa,pb,pc,pd) x =-      case unzip4 x of-         (a,b,c,d) ->-            (decompose pa a, decompose pb b, decompose pc c, decompose pd d)-type instance Decomposed f (pa,pb,pc,pd) =-        (Decomposed f pa, Decomposed f pb, Decomposed f pc, Decomposed f pd)-type instance PatternTuple (pa,pb,pc,pd) =-        (PatternTuple pa, PatternTuple pb, PatternTuple pc, PatternTuple pd)---instance (Compose a) => Compose (Complex a) where-   type Composed (Complex a) = Complex (Composed a)-   compose (a:+b) = consComplex (compose a) (compose b)--instance (Decompose pa) => Decompose (Complex pa) where-   decompose (pa:+pb) =-      Tuple.uncurry (:+) .-      TupleHT.mapPair (decompose pa, decompose pb) . deconsComplex--type instance Decomposed f (Complex pa) = Complex (Decomposed f pa)-type instance PatternTuple (Complex pa) = Complex (PatternTuple pa)--realPart, imagPart :: T (Complex a) -> T a-realPart (Cons (a:+_)) = Cons a-imagPart (Cons (_:+b)) = Cons b----lift1 :: (Repr LLVM.Value a -> Repr LLVM.Value b) -> T a -> T b-lift1 f (Cons a) = Cons $ f a--liftM0 ::-   (Monad m) =>-   m (Repr LLVM.Value a) ->-   m (T a)-liftM0 f = Monad.lift Cons f--liftM ::-   (Monad m) =>-   (Repr LLVM.Value a -> m (Repr LLVM.Value b)) ->-   T a -> m (T b)-liftM f (Cons a) = Monad.lift Cons $ f a--liftM2 ::-   (Monad m) =>-   (Repr LLVM.Value a -> Repr LLVM.Value b -> m (Repr LLVM.Value c)) ->-   T a -> T b -> m (T c)-liftM2 f (Cons a) (Cons b) = Monad.lift Cons $ f a b--liftM3 ::-   (Monad m) =>-   (Repr LLVM.Value a -> Repr LLVM.Value b -> Repr LLVM.Value c ->-    m (Repr LLVM.Value d)) ->-   T a -> T b -> T c -> m (T d)-liftM3 f (Cons a) (Cons b) (Cons c) = Monad.lift Cons $ f a b c---instance (C a) => Class.Zero (T a) where-   zeroTuple = zero--instance (C a) => Class.Undefined (T a) where-   undefTuple = undef--instance (C a) => Phi (T a) where-   phis = phis-   addPhis = addPhis---class (C a) => IntegerConstant a where-   fromInteger' :: Integer -> T a--class (IntegerConstant a) => RationalConstant a where-   fromRational' :: Rational -> T a--instance IntegerConstant Float  where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Double where fromInteger' = Cons . LLVM.value . SoV.constFromInteger--instance IntegerConstant Word8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Word16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Word32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Word64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger--instance IntegerConstant Int8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Int16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Int32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger-instance IntegerConstant Int64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger--instance 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 Word8 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Word16 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Word32 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Word64 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Int8 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Int16 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Int32 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance Additive Int64 where-   add = liftM2 LLVM.add-   sub = liftM2 LLVM.sub-   neg = liftM LLVM.neg--instance (Additive a) => A.Additive (T a) where-   zero = zero-   add = add-   sub = sub-   neg = neg--inc, dec ::-   (Additive i, IntegerConstant i) => T i -> LLVM.CodeGenFunction r (T i)-inc = add (fromInteger' 1)-dec = sub (fromInteger' 1)---class (Additive a) => PseudoRing a where-   mul :: T a -> T a -> LLVM.CodeGenFunction r (T a)--instance PseudoRing Float where mul = liftM2 LLVM.mul-instance PseudoRing Double where mul = liftM2 LLVM.mul-instance PseudoRing Word8 where mul = liftM2 LLVM.mul-instance PseudoRing Word16 where mul = liftM2 LLVM.mul-instance PseudoRing Word32 where mul = liftM2 LLVM.mul-instance PseudoRing Word64 where mul = liftM2 LLVM.mul-instance PseudoRing Int8 where mul = liftM2 LLVM.mul-instance PseudoRing Int16 where mul = liftM2 LLVM.mul-instance PseudoRing Int32 where mul = liftM2 LLVM.mul-instance PseudoRing Int64 where mul = liftM2 LLVM.mul--instance (PseudoRing a) => 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 Word8 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word16 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word32 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Word64 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int8 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int16 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int32 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance Real Int64 where-   min = liftM2 A.min-   max = liftM2 A.max-   abs = liftM A.abs-   signum = liftM A.signum--instance (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-   (Repr LLVM.Value i ~ LLVM.Value ir,-    LLVM.IsInteger ir, SoV.IntegerConstant ir, LLVM.CmpRet ir,-    LLVM.NumberOfElements ir ~ D1, LLVM.CmpResult ir ~ Bool) =>-      NativeInteger i ir where--instance NativeInteger Word8  Word8 where-instance NativeInteger Word16 Word16 where-instance NativeInteger Word32 Word32 where-instance NativeInteger Word64 Word64 where--instance NativeInteger Int8  Int8 where-instance NativeInteger Int16 Int16 where-instance NativeInteger Int32 Int32 where-instance NativeInteger Int64 Int64 where---class-   (Repr LLVM.Value a ~ LLVM.Value ar,-    LLVM.IsFloating ar, SoV.RationalConstant ar, LLVM.CmpRet ar,-    LLVM.NumberOfElements ar ~ D1, LLVM.CmpResult ar ~ Bool) =>-      NativeFloating a ar where--instance NativeFloating Float  Float where-instance NativeFloating Double Double where---truncateToInt, floorToInt, ceilingToInt, roundToIntFast ::-   (NativeInteger i ir, NativeFloating a ar) =>-   T a -> LLVM.CodeGenFunction r (T i)-truncateToInt  = liftM SoV.truncateToInt-floorToInt     = liftM SoV.floorToInt-ceilingToInt   = liftM SoV.ceilingToInt-roundToIntFast = liftM SoV.roundToIntFast--splitFractionToInt ::-   (NativeInteger i ir, NativeFloating a ar) =>-   T a -> LLVM.CodeGenFunction r (T (i,a))-splitFractionToInt = liftM SoV.splitFractionToInt---class Field a => Algebraic a where-   sqrt :: T a -> LLVM.CodeGenFunction r (T a)--instance Algebraic Float where-   sqrt = liftM A.sqrt--instance Algebraic Double where-   sqrt = liftM A.sqrt--instance (Algebraic a) => 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 Word8 where select = liftM3 LLVM.select-instance Select Word16 where select = liftM3 LLVM.select-instance Select Word32 where select = liftM3 LLVM.select-instance Select Word64 where select = liftM3 LLVM.select-instance Select Int8 where select = liftM3 LLVM.select-instance Select Int16 where select = liftM3 LLVM.select-instance Select Int32 where select = liftM3 LLVM.select-instance Select Int64 where select = liftM3 LLVM.select--instance (Select a, Select b) => Select (a,b) where-   select b =-      modifyF2 (atom,atom) (atom,atom) $-      \(a0,b0) (a1,b1) ->-         Monad.lift2 (,)-            (select b a0 a1)-            (select b b0 b1)--instance (Select a, Select b, Select c) => Select (a,b,c) where-   select b =-      modifyF2 (atom,atom,atom) (atom,atom,atom) $-      \(a0,b0,c0) (a1,b1,c1) ->-         Monad.lift3 (,,)-            (select b a0 a1)-            (select b b0 b1)-            (select b c0 c1)--instance (Select a) => C.Select (T a) where-   select b = select (Cons b)----class (Real a) => Comparison a where-   {- |-   It must hold--   > max x y  ==  do gt <- cmp CmpGT x y; select gt x y-   -}-   cmp ::-      LLVM.CmpPredicate -> T a -> T a ->-      LLVM.CodeGenFunction r (T Bool)--instance Comparison Float where cmp = liftM2 . LLVM.cmp-instance Comparison Double where cmp = liftM2 . LLVM.cmp--instance Comparison Int8 where cmp = liftM2 . LLVM.cmp-instance Comparison Int16 where cmp = liftM2 . LLVM.cmp-instance Comparison Int32 where cmp = liftM2 . LLVM.cmp-instance Comparison Int64 where cmp = liftM2 . LLVM.cmp--instance Comparison Word8 where cmp = liftM2 . LLVM.cmp-instance Comparison Word16 where cmp = liftM2 . LLVM.cmp-instance Comparison Word32 where cmp = liftM2 . LLVM.cmp-instance Comparison Word64 where cmp = liftM2 . LLVM.cmp--instance (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 Word8 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word16 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word32 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv--instance Logic Word64 where-   and = liftM2 LLVM.and; or = liftM2 LLVM.or-   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv---instance Logic a => A.Logic (T a) where-   and = and-   or = or-   xor = xor-   inv = inv----class BitShift a where-   shl :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   shr :: T a -> T a -> LLVM.CodeGenFunction r (T a)--instance BitShift Word8 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word16 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word32 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Word64 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr--instance BitShift Int8 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int16 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int32 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr--instance BitShift Int64 where-   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr----class (PseudoRing a) => Integral a where-   idiv :: T a -> T a -> LLVM.CodeGenFunction r (T a)-   irem :: T a -> T a -> LLVM.CodeGenFunction r (T a)--instance Integral Word32 where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem--instance Integral Word64 where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem--instance Integral Int32 where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem--instance Integral Int64 where-   idiv = liftM2 LLVM.idiv-   irem = liftM2 LLVM.irem---fromIntegral ::-   (NativeInteger i ir, NativeFloating a ar) =>-   T i -> LLVM.CodeGenFunction r (T a)-fromIntegral = liftM LLVM.inttofp+module LLVM.Extra.Multi.Value (+   module LLVM.Extra.Multi.Value.Private,+   ) where++import LLVM.Extra.Multi.Vector.Instance ()+import LLVM.Extra.Multi.Value.Private
src/LLVM/Extra/Multi/Value/Memory.hs view
@@ -3,6 +3,7 @@ module LLVM.Extra.Multi.Value.Memory where  import qualified LLVM.Extra.Multi.Value as MultiValue+import LLVM.Extra.ArithmeticPrivate as A import LLVM.Extra.MemoryPrivate (decomposeFromLoad, composeFromStore, )  import qualified LLVM.Core as LLVM@@ -16,6 +17,7 @@ import Data.Complex (Complex, ) import Data.Word (Word8, Word16, Word32, Word64, ) import Data.Int (Int8, Int16, Int32, Int64, )+import Data.Bool8 (Bool8)  import Control.Applicative (pure, liftA2, liftA3, (<*>), ) @@ -32,6 +34,11 @@    compose :: MultiValue.T a -> CodeGenFunction r (Value (Struct a))    compose = composeFromStore store +instance C Bool8 where+   type Struct Bool8 = Word8+   decompose = fmap MultiValue.Cons . A.cmp LLVM.CmpNE (LLVM.valueOf 0)+   compose (MultiValue.Cons b) = LLVM.select b (LLVM.valueOf 1) (LLVM.valueOf 0)+ instance C Float where    type Struct Float = Float    load = loadPrimitive@@ -125,23 +132,23 @@   loadPrimitive ::-   (MultiValue.Repr Value a ~ Value a) =>-   Value (Ptr a) -> CodeGenFunction r (MultiValue.T a)+   (MultiValue.Repr Value a ~ Value al) =>+   Value (Ptr al) -> CodeGenFunction r (MultiValue.T a) loadPrimitive = fmap MultiValue.Cons . LLVM.load  storePrimitive ::-   (MultiValue.Repr Value a ~ Value a) =>-   MultiValue.T a -> Value (Ptr a) -> CodeGenFunction r ()+   (MultiValue.Repr Value a ~ Value al) =>+   MultiValue.T a -> Value (Ptr al) -> CodeGenFunction r () storePrimitive (MultiValue.Cons a) = LLVM.store a  decomposePrimitive ::-   (MultiValue.Repr Value a ~ Value a) =>-   Value a -> CodeGenFunction r (MultiValue.T a)+   (MultiValue.Repr Value a ~ Value al) =>+   Value al -> CodeGenFunction r (MultiValue.T a) decomposePrimitive = return . MultiValue.Cons  composePrimitive ::-   (MultiValue.Repr Value a ~ Value a) =>-   MultiValue.T a -> CodeGenFunction r (Value a)+   (MultiValue.Repr Value a ~ Value al) =>+   MultiValue.T a -> CodeGenFunction r (Value al) composePrimitive (MultiValue.Cons a) = return a
+ src/LLVM/Extra/Multi/Value/Private.hs view
@@ -0,0 +1,1153 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module LLVM.Extra.Multi.Value.Private where++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Class as Class++import qualified LLVM.Core as LLVM+import qualified LLVM.Util.Loop as Loop+import LLVM.Util.Loop (Phi, )+import LLVM.Core (WordN, IntN, )++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal (D1)++import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (Ptr, FunPtr, )++import qualified Control.Monad.HT as Monad+import qualified Control.Functor.HT as FuncHT+import Control.Monad (Monad, return, fmap, (>>), )+import Data.Functor (Functor, )++import qualified Data.Tuple.HT as TupleHT+import qualified Data.Tuple as Tuple+import qualified Data.Bool8 as Bool8+import Data.Complex (Complex((:+)))+import Data.Function (id, (.), ($), )+import Data.Tuple.HT (uncurry3, )+import Data.Maybe (Maybe(Nothing,Just), )+import Data.Bool (Bool(False,True), )+import Data.Word (Word8, Word16, Word32, Word64, )+import Data.Int (Int8, Int16, Int32, Int64, )+import Data.Bool8 (Bool8)++import Prelude (Float, Double, Integer, Rational, )+++newtype T a = Cons (Repr LLVM.Value a)+++class C a where+   type Repr (f :: * -> *) a :: *+   cons :: a -> T a+   undef :: T a+   zero :: T a+   phis :: LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+   addPhis :: LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()++instance C Bool where+   type Repr f Bool = f Bool+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Float where+   type Repr f Float = f Float+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Double where+   type Repr f Double = f Double+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Word8 where+   type Repr f Word8 = f Word8+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Word16 where+   type Repr f Word16 = f Word16+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Word32 where+   type Repr f Word32 = f Word32+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Word64 where+   type Repr f Word64 = f Word64+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance (Dec.Positive n) => C (LLVM.WordN n) where+   type Repr f (LLVM.WordN n) = f (LLVM.WordN n)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Int8 where+   type Repr f Int8 = f Int8+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Int16 where+   type Repr f Int16 = f Int16+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Int32 where+   type Repr f Int32 = f Int32+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C Int64 where+   type Repr f Int64 = f Int64+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance (Dec.Positive n) => C (LLVM.IntN n) where+   type Repr f (LLVM.IntN n) = f (LLVM.IntN n)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance (LLVM.IsType a) => C (Ptr a) where+   -- Do we also have to convert the pointer target type?+   type Repr f (Ptr a) = f (Ptr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance (LLVM.IsFunction a) => C (FunPtr a) where+   type Repr f (FunPtr a) = f (FunPtr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++instance C (StablePtr a) where+   type Repr f (StablePtr a) = f (StablePtr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+++consPrimitive ::+   (LLVM.IsConst al, LLVM.Value al ~ Repr LLVM.Value a) =>+   al -> T a+consPrimitive = Cons . LLVM.valueOf++undefPrimitive, zeroPrimitive ::+   (LLVM.IsType al, LLVM.Value al ~ Repr LLVM.Value a) =>+   T a+undefPrimitive = Cons $ LLVM.value LLVM.undef+zeroPrimitive = Cons $ LLVM.value LLVM.zero++phisPrimitive ::+   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr LLVM.Value a) =>+   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+phisPrimitive bb (Cons a) = fmap Cons $ Loop.phis bb a++addPhisPrimitive ::+   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr LLVM.Value a) =>+   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()+addPhisPrimitive bb (Cons a) (Cons b) = Loop.addPhis bb a b+++instance C () where+   type Repr f () = ()+   cons = consUnit+   undef = undefUnit+   zero = zeroUnit+   phis = phisUnit+   addPhis = addPhisUnit++consUnit :: (Repr LLVM.Value a ~ ()) => a -> T a+consUnit _ = Cons ()++undefUnit :: (Repr LLVM.Value a ~ ()) => T a+undefUnit = Cons ()++zeroUnit :: (Repr LLVM.Value a ~ ()) => T a+zeroUnit = Cons ()++phisUnit ::+   (Repr LLVM.Value a ~ ()) =>+   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+phisUnit _bb (Cons ()) = return $ Cons ()++addPhisUnit ::+   (Repr LLVM.Value a ~ ()) =>+   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()+addPhisUnit _bb (Cons ()) (Cons ()) = return ()+++instance C Bool8 where+   type Repr f Bool8 = f Bool+   cons = consPrimitive . Bool8.toBool+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++boolPFrom8 :: T Bool8 -> T Bool+boolPFrom8 (Cons b) = Cons b++bool8FromP :: T Bool -> T Bool8+bool8FromP (Cons b) = Cons b++intFromBool8 :: (NativeInteger i ir) => T Bool8 -> LLVM.CodeGenFunction r (T i)+intFromBool8 = liftM LLVM.zadapt++floatFromBool8 ::+   (NativeFloating a ar) => T Bool8 -> LLVM.CodeGenFunction r (T a)+floatFromBool8 = liftM LLVM.uitofp+++instance (C a) => C (Maybe a) where+   type Repr f (Maybe a) = (f Bool, Repr f a)+   cons Nothing = nothing+   cons (Just a) = just $ cons a+   undef = toMaybe undef undef+   zero = toMaybe (cons False) zero+   phis bb ma =+      case splitMaybe ma of+         (b,a) -> Monad.lift2 toMaybe (phis bb b) (phis bb a)+   addPhis bb x y =+      case (splitMaybe x, splitMaybe y) of+         ((xb,xa), (yb,ya)) ->+            addPhis bb xb yb >>+            addPhis bb xa ya++splitMaybe :: T (Maybe a) -> (T Bool, T a)+splitMaybe (Cons (b,a)) = (Cons b, Cons a)++toMaybe :: T Bool -> T a -> T (Maybe a)+toMaybe (Cons b) (Cons a) = Cons (b,a)++nothing :: (C a) => T (Maybe a)+nothing = toMaybe (cons False) undef++just :: T a -> T (Maybe a)+just = toMaybe (cons True)+++instance (C a, C b) => C (a,b) where+   type Repr f (a, b) = (Repr f a, Repr f b)+   cons (a,b) = zip (cons a) (cons b)+   undef = zip undef undef+   zero = zip zero zero+   phis bb a =+      case unzip a of+         (a0,a1) ->+            Monad.lift2 zip (phis bb a0) (phis bb a1)+   addPhis bb a b =+      case (unzip a, unzip b) of+         ((a0,a1), (b0,b1)) ->+            addPhis bb a0 b0 >>+            addPhis bb a1 b1++instance (C a, C b, C c) => C (a,b,c) where+   type Repr f (a, b, c) = (Repr f a, Repr f b, Repr f c)+   cons (a,b,c) = zip3 (cons a) (cons b) (cons c)+   undef = zip3 undef undef undef+   zero = zip3 zero zero zero+   phis bb a =+      case unzip3 a of+         (a0,a1,a2) ->+            Monad.lift3 zip3 (phis bb a0) (phis bb a1) (phis bb a2)+   addPhis bb a b =+      case (unzip3 a, unzip3 b) of+         ((a0,a1,a2), (b0,b1,b2)) ->+            addPhis bb a0 b0 >>+            addPhis bb a1 b1 >>+            addPhis bb a2 b2++instance (C a, C b, C c, C d) => C (a,b,c,d) where+   type Repr f (a, b, c, d) = (Repr f a, Repr f b, Repr f c, Repr f d)+   cons (a,b,c,d) = zip4 (cons a) (cons b) (cons c) (cons d)+   undef = zip4 undef undef undef undef+   zero = zip4 zero zero zero zero+   phis bb a =+      case unzip4 a of+         (a0,a1,a2,a3) ->+            Monad.lift4 zip4 (phis bb a0) (phis bb a1) (phis bb a2) (phis bb a3)+   addPhis bb a b =+      case (unzip4 a, unzip4 b) of+         ((a0,a1,a2,a3), (b0,b1,b2,b3)) ->+            addPhis bb a0 b0 >>+            addPhis bb a1 b1 >>+            addPhis bb a2 b2 >>+            addPhis bb a3 b3+++fst :: T (a,b) -> T a+fst (Cons (a,_b)) = Cons a++snd :: T (a,b) -> T b+snd (Cons (_a,b)) = Cons b++curry :: (T (a,b) -> c) -> (T a -> T b -> c)+curry f a b = f $ zip a b++uncurry :: (T a -> T b -> c) -> (T (a,b) -> c)+uncurry f = Tuple.uncurry f . unzip+++mapFst :: (T a0 -> T a1) -> T (a0,b) -> T (a1,b)+mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip++mapSnd :: (T b0 -> T b1) -> T (a,b0) -> T (a,b1)+mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip++mapFstF :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b) -> f (T (a1,b))+mapFstF f = fmap (Tuple.uncurry zip) . FuncHT.mapFst f . unzip++mapSndF :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0) -> f (T (a,b1))+mapSndF f = fmap (Tuple.uncurry zip) . FuncHT.mapSnd f . unzip++swap :: T (a,b) -> T (b,a)+swap = Tuple.uncurry zip . TupleHT.swap . unzip+++fst3 :: T (a,b,c) -> T a+fst3 (Cons (a,_b,_c)) = Cons a++snd3 :: T (a,b,c) -> T b+snd3 (Cons (_a,b,_c)) = Cons b++thd3 :: T (a,b,c) -> T c+thd3 (Cons (_a,_b,c)) = Cons c+++mapFst3 :: (T a0 -> T a1) -> T (a0,b,c) -> T (a1,b,c)+mapFst3 f = uncurry3 zip3 . TupleHT.mapFst3 f . unzip3++mapSnd3 :: (T b0 -> T b1) -> T (a,b0,c) -> T (a,b1,c)+mapSnd3 f = uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3++mapThd3 :: (T c0 -> T c1) -> T (a,b,c0) -> T (a,b,c1)+mapThd3 f = uncurry3 zip3 . TupleHT.mapThd3 f . unzip3++mapFst3F :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b,c) -> f (T (a1,b,c))+mapFst3F f = fmap (uncurry3 zip3) . FuncHT.mapFst3 f . unzip3++mapSnd3F :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0,c) -> f (T (a,b1,c))+mapSnd3F f = fmap (uncurry3 zip3) . FuncHT.mapSnd3 f . unzip3++mapThd3F :: (Functor f) => (T c0 -> f (T c1)) -> T (a,b,c0) -> f (T (a,b,c1))+mapThd3F f = fmap (uncurry3 zip3) . FuncHT.mapThd3 f . unzip3+++zip :: T a -> T b -> T (a,b)+zip (Cons a) (Cons b) = Cons (a,b)++zip3 :: T a -> T b -> T c -> T (a,b,c)+zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c)++zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)+zip4 (Cons a) (Cons b) (Cons c) (Cons d) = Cons (a,b,c,d)++unzip :: T (a,b) -> (T a, T b)+unzip (Cons (a,b)) = (Cons a, Cons b)++unzip3 :: T (a,b,c) -> (T a, T b, T c)+unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c)++unzip4 :: T (a,b,c,d) -> (T a, T b, T c, T d)+unzip4 (Cons (a,b,c,d)) = (Cons a, Cons b, Cons c, Cons d)+++instance (C a) => C (Complex a) where+   type Repr f (Complex a) = Complex (Repr f a)+   cons (a:+b) = consComplex (cons a) (cons b)+   undef = consComplex undef undef+   zero = consComplex zero zero+   phis bb a =+      case deconsComplex a of+         (a0,a1) ->+            Monad.lift2 consComplex (phis bb a0) (phis bb a1)+   addPhis bb a b =+      case (deconsComplex a, deconsComplex b) of+         ((a0,a1), (b0,b1)) ->+            addPhis bb a0 b0 >>+            addPhis bb a1 b1++consComplex :: T a -> T a -> T (Complex a)+consComplex (Cons a) (Cons b) = Cons (a:+b)++deconsComplex :: T (Complex a) -> (T a, T a)+deconsComplex (Cons (a:+b)) = (Cons a, Cons b)++++class Compose multituple where+   type Composed multituple+   {- |+   A nested 'zip'.+   -}+   compose :: multituple -> T (Composed multituple)++class+   (Composed (Decomposed T pattern) ~ PatternTuple pattern) =>+      Decompose pattern where+   {- |+   A nested 'unzip'.+   Since it is not obvious how deep to decompose nested tuples,+   you must provide a pattern of the decomposed tuple.+   E.g.++   > f :: MultiValue ((a,b),(c,d)) ->+   >      ((MultiValue a, MultiValue b), MultiValue (c,d))+   > f = decompose ((atom,atom),atom)+   -}+   decompose :: pattern -> T (PatternTuple pattern) -> Decomposed T pattern++type family Decomposed (f :: * -> *) pattern+type family PatternTuple pattern+++{- |+A combination of 'compose' and 'decompose'+that let you operate on tuple multivalues as Haskell tuples.+-}+modify ::+   (Compose a, Decompose pattern) =>+   pattern ->+   (Decomposed T pattern -> a) ->+   T (PatternTuple pattern) -> T (Composed a)+modify p f = compose . f . decompose p++modify2 ::+   (Compose a, Decompose patternA, Decompose patternB) =>+   patternA ->+   patternB ->+   (Decomposed T patternA -> Decomposed T patternB -> a) ->+   T (PatternTuple patternA) -> T (PatternTuple patternB) -> T (Composed a)+modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b)++modifyF ::+   (Compose a, Decompose pattern, Functor f) =>+   pattern ->+   (Decomposed T pattern -> f a) ->+   T (PatternTuple pattern) -> f (T (Composed a))+modifyF p f = fmap compose . f . decompose p++modifyF2 ::+   (Compose a, Decompose patternA, Decompose patternB,+    Functor f) =>+   patternA ->+   patternB ->+   (Decomposed T patternA -> Decomposed T patternB -> f a) ->+   T (PatternTuple patternA) -> T (PatternTuple patternB) -> f (T (Composed a))+modifyF2 pa pb f a b = fmap compose $ f (decompose pa a) (decompose pb b)++++instance Compose (T a) where+   type Composed (T a) = a+   compose = id++instance Decompose (Atom a) where+   decompose _ = id++type instance Decomposed f (Atom a) = f a+type instance PatternTuple (Atom a) = a++data Atom a = Atom++atom :: Atom a+atom = Atom+++instance Compose () where+   type Composed () = ()+   compose = cons++instance () => Decompose () where+   decompose () _ = ()++type instance Decomposed f () = ()+type instance PatternTuple () = ()+++instance (Compose a, Compose b) => Compose (a,b) where+   type Composed (a,b) = (Composed a, Composed b)+   compose = Tuple.uncurry zip . TupleHT.mapPair (compose, compose)++instance (Decompose pa, Decompose pb) => Decompose (pa,pb) where+   decompose (pa,pb) =+      TupleHT.mapPair (decompose pa, decompose pb) . unzip++type instance Decomposed f (pa,pb) = (Decomposed f pa, Decomposed f pb)+type instance PatternTuple (pa,pb) = (PatternTuple pa, PatternTuple pb)+++instance (Compose a, Compose b, Compose c) => Compose (a,b,c) where+   type Composed (a,b,c) = (Composed a, Composed b, Composed c)+   compose = uncurry3 zip3 . TupleHT.mapTriple (compose, compose, compose)++instance+   (Decompose pa, Decompose pb, Decompose pc) =>+      Decompose (pa,pb,pc) where+   decompose (pa,pb,pc) =+      TupleHT.mapTriple (decompose pa, decompose pb, decompose pc) . unzip3++type instance Decomposed f (pa,pb,pc) =+        (Decomposed f pa, Decomposed f pb, Decomposed f pc)+type instance PatternTuple (pa,pb,pc) =+        (PatternTuple pa, PatternTuple pb, PatternTuple pc)+++instance (Compose a, Compose b, Compose c, Compose d) => Compose (a,b,c,d) where+   type Composed (a,b,c,d) = (Composed a, Composed b, Composed c, Composed d)+   compose (a,b,c,d) = zip4 (compose a) (compose b) (compose c) (compose d)++instance+   (Decompose pa, Decompose pb, Decompose pc, Decompose pd) =>+      Decompose (pa,pb,pc,pd) where+   decompose (pa,pb,pc,pd) x =+      case unzip4 x of+         (a,b,c,d) ->+            (decompose pa a, decompose pb b, decompose pc c, decompose pd d)+type instance Decomposed f (pa,pb,pc,pd) =+        (Decomposed f pa, Decomposed f pb, Decomposed f pc, Decomposed f pd)+type instance PatternTuple (pa,pb,pc,pd) =+        (PatternTuple pa, PatternTuple pb, PatternTuple pc, PatternTuple pd)+++instance (Compose a) => Compose (Complex a) where+   type Composed (Complex a) = Complex (Composed a)+   compose (a:+b) = consComplex (compose a) (compose b)++instance (Decompose pa) => Decompose (Complex pa) where+   decompose (pa:+pb) =+      Tuple.uncurry (:+) .+      TupleHT.mapPair (decompose pa, decompose pb) . deconsComplex++type instance Decomposed f (Complex pa) = Complex (Decomposed f pa)+type instance PatternTuple (Complex pa) = Complex (PatternTuple pa)++realPart, imagPart :: T (Complex a) -> T a+realPart (Cons (a:+_)) = Cons a+imagPart (Cons (_:+b)) = Cons b++++lift1 :: (Repr LLVM.Value a -> Repr LLVM.Value b) -> T a -> T b+lift1 f (Cons a) = Cons $ f a++liftM0 ::+   (Monad m) =>+   m (Repr LLVM.Value a) ->+   m (T a)+liftM0 f = Monad.lift Cons f++liftM ::+   (Monad m) =>+   (Repr LLVM.Value a -> m (Repr LLVM.Value b)) ->+   T a -> m (T b)+liftM f (Cons a) = Monad.lift Cons $ f a++liftM2 ::+   (Monad m) =>+   (Repr LLVM.Value a -> Repr LLVM.Value b -> m (Repr LLVM.Value c)) ->+   T a -> T b -> m (T c)+liftM2 f (Cons a) (Cons b) = Monad.lift Cons $ f a b++liftM3 ::+   (Monad m) =>+   (Repr LLVM.Value a -> Repr LLVM.Value b -> Repr LLVM.Value c ->+    m (Repr LLVM.Value d)) ->+   T a -> T b -> T c -> m (T d)+liftM3 f (Cons a) (Cons b) (Cons c) = Monad.lift Cons $ f a b c+++instance (C a) => Class.Zero (T a) where+   zeroTuple = zero++instance (C a) => Class.Undefined (T a) where+   undefTuple = undef++instance (C a) => Phi (T a) where+   phis = phis+   addPhis = addPhis+++class (C a) => IntegerConstant a where+   fromInteger' :: Integer -> T a++class (IntegerConstant a) => RationalConstant a where+   fromRational' :: Rational -> T a++instance IntegerConstant Float  where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Double where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance IntegerConstant Word8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance IntegerConstant Int8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance (Dec.Positive n) => IntegerConstant (WordN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance (Dec.Positive n) => IntegerConstant (IntN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance 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 Word8 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word16 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word32 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word64 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int8 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int16 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int32 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int64 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance (Dec.Positive n) => Additive (WordN n) where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance (Dec.Positive n) => Additive (IntN n) where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance (Additive a) => A.Additive (T a) where+   zero = zero+   add = add+   sub = sub+   neg = neg++inc, dec ::+   (Additive i, IntegerConstant i) => T i -> LLVM.CodeGenFunction r (T i)+inc = add (fromInteger' 1)+dec = sub (fromInteger' 1)+++class (Additive a) => PseudoRing a where+   mul :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance PseudoRing Float where mul = liftM2 LLVM.mul+instance PseudoRing Double where mul = liftM2 LLVM.mul+instance PseudoRing Word8 where mul = liftM2 LLVM.mul+instance PseudoRing Word16 where mul = liftM2 LLVM.mul+instance PseudoRing Word32 where mul = liftM2 LLVM.mul+instance PseudoRing Word64 where mul = liftM2 LLVM.mul+instance PseudoRing Int8 where mul = liftM2 LLVM.mul+instance PseudoRing Int16 where mul = liftM2 LLVM.mul+instance PseudoRing Int32 where mul = liftM2 LLVM.mul+instance PseudoRing Int64 where mul = liftM2 LLVM.mul++instance (PseudoRing a) => 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 Word8 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word16 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int8 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int16 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (Dec.Positive n) => Real (WordN n) where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (Dec.Positive n) => Real (IntN n) where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (Real a) => 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+   (Repr LLVM.Value i ~ LLVM.Value ir,+    LLVM.IsInteger ir, SoV.IntegerConstant ir, LLVM.CmpRet ir,+    LLVM.NumberOfElements ir ~ D1, LLVM.CmpResult ir ~ Bool) =>+      NativeInteger i ir where++instance NativeInteger Word8  Word8 where+instance NativeInteger Word16 Word16 where+instance NativeInteger Word32 Word32 where+instance NativeInteger Word64 Word64 where++instance NativeInteger Int8  Int8 where+instance NativeInteger Int16 Int16 where+instance NativeInteger Int32 Int32 where+instance NativeInteger Int64 Int64 where+++class+   (Repr LLVM.Value a ~ LLVM.Value ar,+    LLVM.IsFloating ar, SoV.RationalConstant ar, LLVM.CmpRet ar,+    LLVM.NumberOfElements ar ~ D1, LLVM.CmpResult ar ~ Bool) =>+      NativeFloating a ar where++instance NativeFloating Float  Float where+instance NativeFloating Double Double where+++truncateToInt, floorToInt, ceilingToInt, roundToIntFast ::+   (NativeInteger i ir, NativeFloating a ar) =>+   T a -> LLVM.CodeGenFunction r (T i)+truncateToInt  = liftM SoV.truncateToInt+floorToInt     = liftM SoV.floorToInt+ceilingToInt   = liftM SoV.ceilingToInt+roundToIntFast = liftM SoV.roundToIntFast++splitFractionToInt ::+   (NativeInteger i ir, NativeFloating a ar) =>+   T a -> LLVM.CodeGenFunction r (T (i,a))+splitFractionToInt = liftM SoV.splitFractionToInt+++class Field a => Algebraic a where+   sqrt :: T a -> LLVM.CodeGenFunction r (T a)++instance Algebraic Float where+   sqrt = liftM A.sqrt++instance Algebraic Double where+   sqrt = liftM A.sqrt++instance (Algebraic a) => 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 Bool where select = liftM3 LLVM.select+instance Select Bool8 where select = liftM3 LLVM.select+instance Select Float where select = liftM3 LLVM.select+instance Select Double where select = liftM3 LLVM.select+instance Select Word8 where select = liftM3 LLVM.select+instance Select Word16 where select = liftM3 LLVM.select+instance Select Word32 where select = liftM3 LLVM.select+instance Select Word64 where select = liftM3 LLVM.select+instance Select Int8 where select = liftM3 LLVM.select+instance Select Int16 where select = liftM3 LLVM.select+instance Select Int32 where select = liftM3 LLVM.select+instance Select Int64 where select = liftM3 LLVM.select++instance (Select a, Select b) => Select (a,b) where+   select b =+      modifyF2 (atom,atom) (atom,atom) $+      \(a0,b0) (a1,b1) ->+         Monad.lift2 (,)+            (select b a0 a1)+            (select b b0 b1)++instance (Select a, Select b, Select c) => Select (a,b,c) where+   select b =+      modifyF2 (atom,atom,atom) (atom,atom,atom) $+      \(a0,b0,c0) (a1,b1,c1) ->+         Monad.lift3 (,,)+            (select b a0 a1)+            (select b b0 b1)+            (select b c0 c1)++instance (Select a) => C.Select (T a) where+   select b = select (Cons b)++++class (Real a) => Comparison a where+   {- |+   It must hold++   > max x y  ==  do gt <- cmp CmpGT x y; select gt x y+   -}+   cmp ::+      LLVM.CmpPredicate -> T a -> T a ->+      LLVM.CodeGenFunction r (T Bool)++instance Comparison Float where cmp = liftM2 . LLVM.cmp+instance Comparison Double where cmp = liftM2 . LLVM.cmp++instance Comparison Int8 where cmp = liftM2 . LLVM.cmp+instance Comparison Int16 where cmp = liftM2 . LLVM.cmp+instance Comparison Int32 where cmp = liftM2 . LLVM.cmp+instance Comparison Int64 where cmp = liftM2 . LLVM.cmp++instance Comparison Word8 where cmp = liftM2 . LLVM.cmp+instance Comparison Word16 where cmp = liftM2 . LLVM.cmp+instance Comparison Word32 where cmp = liftM2 . LLVM.cmp+instance Comparison Word64 where cmp = liftM2 . LLVM.cmp++instance (Dec.Positive n) => Comparison (IntN n) where cmp = liftM2 . LLVM.cmp+instance (Dec.Positive n) => Comparison (WordN n) where cmp = liftM2 . LLVM.cmp++instance (Comparison a) => 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 (C a) => Logic a where+   and :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   or :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   xor :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   inv :: T a -> LLVM.CodeGenFunction r (T a)++instance Logic Bool where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Bool8 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word8 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word16 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word32 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word64 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance (Dec.Positive n) => Logic (WordN n) where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv+++instance Logic a => A.Logic (T a) where+   and = and+   or = or+   xor = xor+   inv = inv++++class BitShift a where+   shl :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   shr :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance BitShift Word8 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word16 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word32 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word64 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Int8 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int16 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int32 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int64 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++++class (PseudoRing a) => Integral a where+   idiv :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   irem :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance Integral Word32 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Word64 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Int32 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Int64 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem+++fromIntegral ::+   (NativeInteger i ir, NativeFloating a ar) =>+   T i -> LLVM.CodeGenFunction r (T a)+fromIntegral = liftM LLVM.inttofp
+ src/LLVM/Extra/Multi/Value/Vector.hs view
@@ -0,0 +1,166 @@+module LLVM.Extra.Multi.Value.Vector (+   cons,+   fst, snd,+   fst3, snd3, thd3,+   zip, zip3,+   unzip, unzip3,++   swap,+   mapFst, mapSnd,+   mapFst3, mapSnd3, mapThd3,++   extract, insert,+   replicate,+   dissect,+   select,+   cmp,+   take, takeRev,+   ) where++import qualified LLVM.Extra.Multi.Vector.Instance as Inst+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value.Private as MultiValue++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Data.Tuple.HT as TupleHT+import qualified Data.Tuple as Tuple+import Data.Word (Word32)++import Prelude (Bool, fmap, (.))+++cons ::+   (TypeNum.Positive n, MultiVector.C a) =>+   LLVM.Vector n a -> MultiValue.T (LLVM.Vector n a)+cons = Inst.toMultiValue . MultiVector.cons++fst :: MultiValue.T (LLVM.Vector n (a,b)) -> MultiValue.T (LLVM.Vector n a)+fst = MultiValue.lift1 Tuple.fst++snd :: MultiValue.T (LLVM.Vector n (a,b)) -> MultiValue.T (LLVM.Vector n b)+snd = MultiValue.lift1 Tuple.snd++swap :: MultiValue.T (LLVM.Vector n (a,b)) -> MultiValue.T (LLVM.Vector n (b,a))+swap = MultiValue.lift1 TupleHT.swap++mapFst ::+   (MultiValue.T (LLVM.Vector n a0) -> MultiValue.T (LLVM.Vector n a1)) ->+   MultiValue.T (LLVM.Vector n (a0,b)) -> MultiValue.T (LLVM.Vector n (a1,b))+mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip++mapSnd ::+   (MultiValue.T (LLVM.Vector n b0) -> MultiValue.T (LLVM.Vector n b1)) ->+   MultiValue.T (LLVM.Vector n (a,b0)) -> MultiValue.T (LLVM.Vector n (a,b1))+mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip+++fst3 :: MultiValue.T (LLVM.Vector n (a,b,c)) -> MultiValue.T (LLVM.Vector n a)+fst3 = MultiValue.lift1 TupleHT.fst3++snd3 :: MultiValue.T (LLVM.Vector n (a,b,c)) -> MultiValue.T (LLVM.Vector n b)+snd3 = MultiValue.lift1 TupleHT.snd3++thd3 :: MultiValue.T (LLVM.Vector n (a,b,c)) -> MultiValue.T (LLVM.Vector n c)+thd3 = MultiValue.lift1 TupleHT.thd3++mapFst3 ::+   (MultiValue.T (LLVM.Vector n a0) -> MultiValue.T (LLVM.Vector n a1)) ->+   MultiValue.T (LLVM.Vector n (a0,b,c)) ->+   MultiValue.T (LLVM.Vector n (a1,b,c))+mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3++mapSnd3 ::+   (MultiValue.T (LLVM.Vector n b0) -> MultiValue.T (LLVM.Vector n b1)) ->+   MultiValue.T (LLVM.Vector n (a,b0,c)) ->+   MultiValue.T (LLVM.Vector n (a,b1,c))+mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3++mapThd3 ::+   (MultiValue.T (LLVM.Vector n c0) -> MultiValue.T (LLVM.Vector n c1)) ->+   MultiValue.T (LLVM.Vector n (a,b,c0)) ->+   MultiValue.T (LLVM.Vector n (a,b,c1))+mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3+++zip ::+   MultiValue.T (LLVM.Vector n a) ->+   MultiValue.T (LLVM.Vector n b) ->+   MultiValue.T (LLVM.Vector n (a,b))+zip (MultiValue.Cons a) (MultiValue.Cons b) = MultiValue.Cons (a,b)++zip3 ::+   MultiValue.T (LLVM.Vector n a) ->+   MultiValue.T (LLVM.Vector n b) ->+   MultiValue.T (LLVM.Vector n c) ->+   MultiValue.T (LLVM.Vector n (a,b,c))+zip3 (MultiValue.Cons a) (MultiValue.Cons b) (MultiValue.Cons c) =+   MultiValue.Cons (a,b,c)++unzip ::+   MultiValue.T (LLVM.Vector n (a,b)) ->+   (MultiValue.T (LLVM.Vector n a),+    MultiValue.T (LLVM.Vector n b))+unzip (MultiValue.Cons (a,b)) = (MultiValue.Cons a, MultiValue.Cons b)++unzip3 ::+   MultiValue.T (LLVM.Vector n (a,b,c)) ->+   (MultiValue.T (LLVM.Vector n a),+    MultiValue.T (LLVM.Vector n b),+    MultiValue.T (LLVM.Vector n c))+unzip3 (MultiValue.Cons (a,b,c)) =+   (MultiValue.Cons a, MultiValue.Cons b, MultiValue.Cons c)+++extract ::+   (TypeNum.Positive n, MultiVector.C a) =>+   LLVM.Value Word32 -> MultiValue.T (LLVM.Vector n a) ->+   LLVM.CodeGenFunction r (MultiValue.T a)+extract k v = MultiVector.extract k (Inst.fromMultiValue v)++insert ::+   (TypeNum.Positive n, MultiVector.C a) =>+   LLVM.Value Word32 -> MultiValue.T a ->+   MultiValue.T (LLVM.Vector n a) ->+   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n a))+insert k a = Inst.liftMultiValueM (MultiVector.insert k a)+++replicate ::+   (TypeNum.Positive n, MultiVector.C a) =>+   MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n a))+replicate = fmap Inst.toMultiValue . MultiVector.replicate++take ::+   (TypeNum.Positive n, TypeNum.Positive m, MultiVector.C a) =>+   MultiValue.T (LLVM.Vector n a) ->+   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector m a))+take = Inst.liftMultiValueM MultiVector.take++takeRev ::+   (TypeNum.Positive n, TypeNum.Positive m, MultiVector.C a) =>+   MultiValue.T (LLVM.Vector n a) ->+   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector m a))+takeRev = Inst.liftMultiValueM MultiVector.takeRev+++dissect ::+   (TypeNum.Positive n, MultiVector.C a) =>+   MultiValue.T (LLVM.Vector n a) -> LLVM.CodeGenFunction r [MultiValue.T a]+dissect = MultiVector.dissect . Inst.fromMultiValue++select ::+   (TypeNum.Positive n, MultiVector.Select a) =>+   MultiValue.T (LLVM.Vector n Bool) ->+   MultiValue.T (LLVM.Vector n a) -> MultiValue.T (LLVM.Vector n a) ->+   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n a))+select = Inst.liftMultiValueM3 MultiVector.select++cmp ::+   (TypeNum.Positive n, MultiVector.Comparison a) =>+   LLVM.CmpPredicate ->+   MultiValue.T (LLVM.Vector n a) -> MultiValue.T (LLVM.Vector n a) ->+   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n Bool))+cmp = Inst.liftMultiValueM2 . MultiVector.cmp
src/LLVM/Extra/Multi/Vector.hs view
@@ -3,11 +3,13 @@ module LLVM.Extra.Multi.Vector (    T(Cons), consPrim, deconsPrim,    C(..),-   Value(Value),+   Value,    map,    zip, zip3, unzip, unzip3,    replicate,    iterate,+   take,+   takeRev,     lift1, @@ -23,9 +25,11 @@    shiftDown,    shiftUpMultiZero,    shiftDownMultiZero,+   shiftUpMultiUndef,+   shiftDownMultiUndef,     undefPrimitive,-   shuffleMatchPrimitive,+   shufflePrimitive,    extractPrimitive,    insertPrimitive, @@ -33,6 +37,8 @@    insertTraversable,    extractTraversable, +   IntegerConstant(..),+   RationalConstant(..),    Additive(..),    PseudoRing(..),    Field(..),@@ -42,63 +48,69 @@    Algebraic(..),    Transcendental(..),    FloatingComparison(..),+   Select(..),    Comparison(..),    Logic(..),    BitShift(..),    ) where -import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Multi.Value.Private as MultiValue import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Class as Class-import LLVM.Extra.Multi.Value (Repr, )+import LLVM.Extra.Multi.Value.Private (Repr, )  import qualified LLVM.Util.Loop as Loop import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, )-import LLVM.Core-   (valueOf, value,-    IsPrimitive,-    CodeGenFunction, )+import LLVM.Core (CodeGenFunction, IsPrimitive, valueOf, value, )  import qualified Type.Data.Num.Decimal as TypeNum  import qualified Data.Traversable as Trav+import qualified Data.NonEmpty.Class as NonEmptyC import qualified Data.NonEmpty as NonEmpty import qualified Data.List as List+import qualified Data.Bool8 as Bool8+import Data.Functor.Compose (Compose(Compose), ) import Data.Traversable (mapM, sequence, )+import Data.Functor ((<$>), ) import Data.NonEmpty ((!:), ) import Data.Function (flip, (.), ($), )-import Data.Tuple (snd, )+import Data.Tuple.HT (fst3, snd3, thd3, )+import Data.Tuple (fst, snd, ) import Data.Maybe (maybe, )-import Data.List (take, (++), )+import Data.Ord ((<), ) import Data.Word (Word8, Word16, Word32, Word64, ) import Data.Int (Int8, Int16, Int32, Int64, )+import Data.Bool8 (Bool8) import Data.Bool (Bool, ) -import qualified Control.Applicative as App import qualified Control.Monad.HT as Monad+import qualified Control.Applicative as App import Control.Monad.HT ((<=<), )-import Control.Monad (Monad, foldM, fmap, (>>), (=<<), )+import Control.Monad (Monad, foldM, fmap, return, (>>), (=<<), ) import Control.Applicative (liftA2, ) -import Prelude (Float, Double, Integer, Int, Rational, fromIntegral, (-), error, )+import Prelude+         (Float, Double, Integer, Int, Rational,+          fromIntegral, asTypeOf, (-), (+), error, )   newtype T n a = Cons (Repr (Value n) a) -newtype Value n a = Value (PrimValue n a)+type Value n = Compose LLVM.Value (LLVM.Vector n)   consPrim ::    (Repr (Value n) a ~ Value n a) =>    LLVM.Value (LLVM.Vector n a) -> T n a-consPrim = Cons . Value+consPrim = Cons . Compose  deconsPrim ::    (Repr (Value n) a ~ Value n a) =>    T n a -> LLVM.Value (LLVM.Vector n a)-deconsPrim (Cons (Value a)) = a+deconsPrim (Cons (Compose a)) = a   instance (TypeNum.Positive n, C a) => Class.Undefined (T n a) where@@ -133,6 +145,7 @@   class (MultiValue.C a) => C a where+   cons :: (TypeNum.Positive n) => LLVM.Vector n a -> T n a    undef :: (TypeNum.Positive n) => T n a    zero :: (TypeNum.Positive n) => T n a    phis ::@@ -142,9 +155,10 @@       (TypeNum.Positive n) =>       LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r () -   shuffleMatch ::-      (TypeNum.Positive n) =>-      LLVM.ConstValue (LLVM.Vector n Word32) -> T n a -> CodeGenFunction r (T n a)+   shuffle ::+      (TypeNum.Positive n, TypeNum.Positive m) =>+      LLVM.ConstValue (LLVM.Vector m Word32) -> T n a -> T n a ->+      CodeGenFunction r (T m a)    extract ::       (TypeNum.Positive n) =>       LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)@@ -154,84 +168,186 @@       T n a -> CodeGenFunction r (T n a)  instance C Bool where+   cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive    phis = phisPrimitive    addPhis = addPhisPrimitive-   shuffleMatch = shuffleMatchPrimitive+   shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive +instance C Bool8 where+   cons = consPrimitive . fmap Bool8.toBool+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive+ instance C Float where+   cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive    phis = phisPrimitive    addPhis = addPhisPrimitive-   shuffleMatch = shuffleMatchPrimitive+   shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive  instance C Double where+   cons = consPrimitive    undef = undefPrimitive    zero = zeroPrimitive    phis = phisPrimitive    addPhis = addPhisPrimitive-   shuffleMatch = shuffleMatchPrimitive+   shuffle = shufflePrimitive    extract = extractPrimitive    insert = insertPrimitive +instance C Int8 where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int16 where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int32 where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int64 where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word8 where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word16 where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word32 where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word64 where+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++consPrimitive ::+   (TypeNum.Positive n, LLVM.IsConst al, IsPrimitive al,+    Repr (Value n) a ~ Value n al) =>+   LLVM.Vector n al -> T n a+consPrimitive = Cons . Compose . LLVM.valueOf+ undefPrimitive ::-   (TypeNum.Positive n, IsPrimitive a,-    Repr (Value n) a ~ Value n a) =>+   (TypeNum.Positive n, IsPrimitive al,+    Repr (Value n) a ~ Value n al) =>    T n a-undefPrimitive = Cons $ Value $ LLVM.value LLVM.undef+undefPrimitive = Cons $ Compose $ LLVM.value LLVM.undef  zeroPrimitive ::-   (TypeNum.Positive n, IsPrimitive a,-    Repr (Value n) a ~ Value n a) =>+   (TypeNum.Positive n, IsPrimitive al,+    Repr (Value n) a ~ Value n al) =>    T n a-zeroPrimitive = Cons $ Value $ LLVM.value LLVM.zero+zeroPrimitive = Cons $ Compose $ LLVM.value LLVM.zero  phisPrimitive ::-   (TypeNum.Positive n, IsPrimitive a, Repr (Value n) a ~ Value n a) =>+   (TypeNum.Positive n, IsPrimitive al, Repr (Value n) a ~ Value n al) =>    LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)-phisPrimitive bb (Cons (Value a)) = fmap (Cons . Value) $ Loop.phis bb a+phisPrimitive bb (Cons (Compose a)) = fmap (Cons . Compose) $ Loop.phis bb a  addPhisPrimitive ::-   (TypeNum.Positive n, IsPrimitive a, Repr (Value n) a ~ Value n a) =>+   (TypeNum.Positive n, IsPrimitive al, Repr (Value n) a ~ Value n al) =>    LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r ()-addPhisPrimitive bb (Cons (Value a)) (Cons (Value b)) = Loop.addPhis bb a b+addPhisPrimitive bb (Cons (Compose a)) (Cons (Compose b)) = Loop.addPhis bb a b  -shuffleMatchPrimitive ::-   (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+shufflePrimitive ::+   (TypeNum.Positive n, TypeNum.Positive m, IsPrimitive al,+    Repr LLVM.Value a ~ LLVM.Value al,+    Repr (Value n) a ~ Value n al,+    Repr (Value m) a ~ Value m al) =>+   LLVM.ConstValue (LLVM.Vector m Word32) ->+   T n a -> T n a -> CodeGenFunction r (T m a)+shufflePrimitive k (Cons (Compose u)) (Cons (Compose v)) =+   fmap (Cons . Compose) $ LLVM.shufflevector u v k  extractPrimitive ::-   (TypeNum.Positive n, IsPrimitive a,-    Repr LLVM.Value a ~ LLVM.Value a,-    Repr (Value n) a ~ Value n a) =>+   (TypeNum.Positive n, IsPrimitive al,+    Repr LLVM.Value a ~ LLVM.Value al,+    Repr (Value n) a ~ Value n al) =>    LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a)-extractPrimitive k (Cons (Value v)) =+extractPrimitive k (Cons (Compose v)) =    fmap MultiValue.Cons $ LLVM.extractelement v k  insertPrimitive ::-   (TypeNum.Positive n, IsPrimitive a,+   (TypeNum.Positive n, IsPrimitive al, -- 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) =>+    Repr LLVM.Value a ~ LLVM.Value al,+    Repr (Value n) a ~ Value n al) =>    LLVM.Value Word32 ->    MultiValue.T a -> T n a -> CodeGenFunction r (T n a)-insertPrimitive k (MultiValue.Cons a) (Cons (Value v)) =-   fmap (Cons . Value) $ LLVM.insertelement v a k+insertPrimitive k (MultiValue.Cons a) (Cons (Compose v)) =+   fmap (Cons . Compose) $ LLVM.insertelement v a k   instance (C a, C b) => C (a,b) where+   cons v = zip (cons (fst <$> v)) (cons (snd <$> v))    undef = zip undef undef    zero = zip zero zero @@ -245,12 +361,12 @@             addPhis bb a0 b0 >>             addPhis bb a1 b1 -   shuffleMatch is v =-      case unzip v of-         (v0,v1) ->+   shuffle is u v =+      case (unzip u, unzip v) of+         ((u0,u1), (v0,v1)) ->             Monad.lift2 zip-               (shuffleMatch is v0)-               (shuffleMatch is v1)+               (shuffle is u0 v0)+               (shuffle is u1 v1)     extract k v =       case unzip v of@@ -268,6 +384,7 @@   instance (C a, C b, C c) => C (a,b,c) where+   cons v = zip3 (cons (fst3 <$> v)) (cons (snd3 <$> v)) (cons (thd3 <$> v))    undef = zip3 undef undef undef    zero = zip3 zero zero zero @@ -282,13 +399,13 @@             addPhis bb a1 b1 >>             addPhis bb a2 b2 -   shuffleMatch is v =-      case unzip3 v of-         (v0,v1,v2) ->+   shuffle is u v =+      case (unzip3 u, unzip3 v) of+         ((u0,u1,u2), (v0,v1,v2)) ->             Monad.lift3 zip3-               (shuffleMatch is v0)-               (shuffleMatch is v1)-               (shuffleMatch is v2)+               (shuffle is u0 v0)+               (shuffle is u1 v1)+               (shuffle is u2 v2)     extract k v =       case unzip3 v of@@ -313,13 +430,32 @@ 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 IntegerConstant Float  where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Double where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word8  where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word16 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word32 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word64 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int8  where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int16 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int32 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int64 where fromInteger' = fromIntegerPrimitive -instance RationalConstant Float  where fromRational' = Cons . Value . LLVM.value . SoV.constFromRational-instance RationalConstant Double where fromRational' = Cons . Value . LLVM.value . SoV.constFromRational+fromIntegerPrimitive ::+   (TypeNum.Positive n, IsPrimitive a, SoV.IntegerConstant a,+    Repr (Value n) a ~ Value n a) =>+   Integer -> T n a+fromIntegerPrimitive = Cons . Compose . LLVM.value . SoV.constFromInteger +instance RationalConstant Float  where fromRational' = fromRationalPrimitive+instance RationalConstant Double where fromRational' = fromRationalPrimitive +fromRationalPrimitive ::+   (TypeNum.Positive n, IsPrimitive a, SoV.RationalConstant a,+    Repr (Value n) a ~ Value n a) =>+   Rational -> T n a+fromRationalPrimitive = Cons . Compose . LLVM.value . SoV.constFromRational+ instance    (TypeNum.Positive n, IntegerConstant a) =>       A.IntegerConstant (T n a) where@@ -358,7 +494,7 @@ dissectList x =    List.map       (flip extract x . LLVM.valueOf)-      (take (size x) [0..])+      (List.take (size x) [0..])   map ::@@ -368,25 +504,21 @@ map f  =  assemble <=< mapM f <=< dissect  +singleton :: (C a) => MultiValue.T a -> CodeGenFunction r (T TypeNum.D1 a)+singleton x = insert (LLVM.value LLVM.zero) x undef+ replicate ::    (TypeNum.Positive n, C a) =>    MultiValue.T a -> CodeGenFunction r (T n a)-replicate = 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)-+replicate x = do+   single <- singleton x+   shuffle (constCyclicVector $ NonEmpty.singleton 0) single undef  iterate ::    (TypeNum.Positive n, C a) =>    (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) ->    MultiValue.T a -> CodeGenFunction r (T n a)-iterate f x =-   fmap snd $-   iterateCore f x Class.undefTuple+iterate f x = fmap snd $ iterateCore f x Class.undefTuple  iterateCore ::    (TypeNum.Positive n, C a) =>@@ -395,11 +527,9 @@    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))+      (\(x,v) k -> Monad.lift2 (,) (f x) (insert (valueOf k) x v))       (x0,v0)-      (take (size v0) [0..])+      (List.take (size v0) [0..])   -- * re-ordering of elements@@ -410,6 +540,12 @@ constCyclicVector =    LLVM.constCyclicVector . fmap LLVM.constOf +shuffleMatch ::+   (TypeNum.Positive n, C a) =>+   LLVM.ConstValue (LLVM.Vector n Word32) -> T n a ->+   CodeGenFunction r (T n a)+shuffleMatch k v = shuffle k v undef+ {- | Rotate one element towards the higher elements. @@ -448,6 +584,23 @@        List.take (size x) [0..])       x +take ::+   (TypeNum.Positive n, TypeNum.Positive m, C a) =>+   T n a -> CodeGenFunction r (T m a)+take u = shuffle (constCyclicVector $ NonEmptyC.iterate (1+) 0) u undef++takeRev ::+   (TypeNum.Positive n, TypeNum.Positive m, C a) =>+   T n a -> CodeGenFunction r (T m a)+takeRev u = do+   let v0 = zero+   v <-+      shuffle+         (constCyclicVector $+          NonEmptyC.iterate (1+) (fromIntegral (size u - size v0)))+         u undef+   return $ v `asTypeOf` v0+ shiftUp ::    (TypeNum.Positive n, C a) =>    MultiValue.T a -> T n a -> CodeGenFunction r (MultiValue.T a, T n a)@@ -473,22 +626,45 @@       (extract (value LLVM.zero) x)       (insert (LLVM.valueOf (fromIntegral (size x) - 1)) x0 y) +shiftUpMultiIndices ::+   (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32)+shiftUpMultiIndices n sizev =+   constCyclicVector $ fmap fromIntegral $+   NonEmpty.appendLeft (List.replicate n sizev) (NonEmptyC.iterate (1+) 0)++shiftDownMultiIndices ::+   (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32)+shiftDownMultiIndices n sizev =+   constCyclicVector $ fmap fromIntegral $+   NonEmpty.appendLeft+      (List.takeWhile (< sizev) $ List.iterate (1+) n)+      (NonEmptyC.repeat sizev)+ shiftUpMultiZero ::-   (TypeNum.Positive n, C a, Class.ValueTuple a ~ al, Class.Zero al) =>+   (TypeNum.Positive n, C a) =>    Int -> T n a -> LLVM.CodeGenFunction r (T n a) shiftUpMultiZero n v =-   assemble . take (size v) .-   (List.replicate n MultiValue.zero ++) =<< dissect v+   shuffle (shiftUpMultiIndices n (size v)) v zero  shiftDownMultiZero ::-   (TypeNum.Positive n, C a, Class.ValueTuple a ~ al, Class.Zero al) =>+   (TypeNum.Positive n, C a) =>    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+   shuffle (shiftDownMultiIndices n (size v)) v zero +shiftUpMultiUndef ::+   (TypeNum.Positive n, C a) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftUpMultiUndef n v =+   shuffle (shiftUpMultiIndices n (size v)) v undef +shiftDownMultiUndef ::+   (TypeNum.Positive n, C a) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftDownMultiUndef n v =+   shuffle (shiftDownMultiIndices n (size v)) v undef++ -- * method implementations based on Traversable  shuffleMatchTraversable ::@@ -549,8 +725,19 @@    T n a -> T n b -> m (T n c) liftM2 f a b = Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b) +liftM3 ::+   (Monad m,+    Repr (Value n) a ~ Value n a,+    Repr (Value n) b ~ Value n b,+    Repr (Value n) c ~ Value n c,+    Repr (Value n) d ~ Value n d) =>+   (PrimValue n a -> PrimValue n b -> PrimValue n c -> m (PrimValue n d)) ->+   T n a -> T n b -> T n c -> m (T n d)+liftM3 f a b c =+   Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b) (deconsPrim c)  + class (MultiValue.Additive a, C a) => Additive a where    add ::       (TypeNum.Positive n) =>@@ -563,15 +750,35 @@       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+   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+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg +instance Additive Int8 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int16 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int32 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int64 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word8 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word16 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word32 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word64 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg+ instance (TypeNum.Positive n, Additive a) => A.Additive (T n a) where    zero = zero    add = add@@ -715,17 +922,59 @@   +class (C a) => Select a where+   select ::+      (TypeNum.Positive n) =>+      T n Bool -> T n a -> T n a ->+      LLVM.CodeGenFunction r (T n a)++instance Select Float where select = liftM3 LLVM.select+instance Select Double where select = liftM3 LLVM.select+instance Select Bool where select = liftM3 LLVM.select+instance Select Word8 where select = liftM3 LLVM.select+instance Select Word16 where select = liftM3 LLVM.select+instance Select Word32 where select = liftM3 LLVM.select+instance Select Word64 where select = liftM3 LLVM.select+instance Select Int8 where select = liftM3 LLVM.select+instance Select Int16 where select = liftM3 LLVM.select+instance Select Int32 where select = liftM3 LLVM.select+instance Select Int64 where select = liftM3 LLVM.select++instance (Select a, Select b) => Select (a,b) where+   select x y0 y1 =+      case (unzip y0, unzip y1) of+         ((a0,b0), (a1,b1)) ->+            Monad.lift2 zip+               (select x a0 a1)+               (select x b0 b1)++instance (Select a, Select b, Select c) => Select (a,b,c) where+   select x y0 y1 =+      case (unzip3 y0, unzip3 y1) of+         ((a0,b0,c0), (a1,b1,c1)) ->+            Monad.lift3 zip3+               (select x a0 a1)+               (select x b0 b1)+               (select x c0 c1)+++ class (MultiValue.Comparison a, C a) => Comparison a where    cmp ::       (TypeNum.Positive n) =>       LLVM.CmpPredicate -> T n a -> T n a ->       LLVM.CodeGenFunction r (T n Bool) -instance Comparison Float where-   cmp = liftM2 . LLVM.cmp--instance Comparison Double where-   cmp = liftM2 . LLVM.cmp+instance Comparison Float where cmp = liftM2 . LLVM.cmp+instance Comparison Double where cmp = liftM2 . LLVM.cmp+instance Comparison Word8 where cmp = liftM2 . LLVM.cmp+instance Comparison Word16 where cmp = liftM2 . LLVM.cmp+instance Comparison Word32 where cmp = liftM2 . LLVM.cmp+instance Comparison Word64 where cmp = liftM2 . LLVM.cmp+instance Comparison Int8 where cmp = liftM2 . LLVM.cmp+instance Comparison Int16 where cmp = liftM2 . LLVM.cmp+instance Comparison Int32 where cmp = liftM2 . LLVM.cmp+instance Comparison Int64 where cmp = liftM2 . LLVM.cmp  instance (TypeNum.Positive n, Comparison a) => A.Comparison (T n a) where    type CmpResult (T n a) = T n Bool@@ -758,10 +1007,24 @@    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+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word8 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word16 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word32 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word64 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv   instance (TypeNum.Positive n, Logic a) => A.Logic (T n a) where
+ src/LLVM/Extra/Multi/Vector/Instance.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module LLVM.Extra.Multi.Vector.Instance where++import qualified LLVM.Extra.Multi.Vector as Vector+import qualified LLVM.Extra.Multi.Value.Private as MultiValue+import LLVM.Extra.Multi.Value.Private (Repr, )++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import Data.Functor.Compose (Compose, )+import Data.Functor ((<$>), )+++type MVVector n a = MultiValue.T (LLVM.Vector n a)++toMultiValue :: Vector.T n a -> MVVector n a+toMultiValue (Vector.Cons x) = MultiValue.Cons x++fromMultiValue :: MVVector n a -> Vector.T n a+fromMultiValue (MultiValue.Cons x) = Vector.Cons x++liftMultiValueM ::+   (Functor f) =>+   (Vector.T n a -> f (Vector.T m b)) ->+   (MVVector n a -> f (MVVector m b))+liftMultiValueM f a =+   toMultiValue <$> f (fromMultiValue a)++liftMultiValueM2 ::+   (Functor f) =>+   (Vector.T n a -> Vector.T m b -> f (Vector.T k c)) ->+   (MVVector n a -> MVVector m b -> f (MVVector k c))+liftMultiValueM2 f a b =+   toMultiValue <$> f (fromMultiValue a) (fromMultiValue b)++liftMultiValueM3 ::+   (Functor f) =>+   (Vector.T n a -> Vector.T m b -> Vector.T m c -> f (Vector.T k d)) ->+   (MVVector n a -> MVVector m b -> MVVector m c -> f (MVVector k d))+liftMultiValueM3 f a b c =+   toMultiValue <$> f (fromMultiValue a) (fromMultiValue b) (fromMultiValue c)++instance+   (TypeNum.Positive n, Vector.C a) =>+      MultiValue.C (LLVM.Vector n a) where+   type Repr f (LLVM.Vector n a) = Repr (Compose f (LLVM.Vector n)) a+   cons = toMultiValue . Vector.cons+   undef = toMultiValue Vector.undef+   zero = toMultiValue Vector.zero+   phis = liftMultiValueM . Vector.phis+   addPhis bb x y = Vector.addPhis bb (fromMultiValue x) (fromMultiValue y)++instance+   (TypeNum.Positive n, Vector.IntegerConstant a) =>+      MultiValue.IntegerConstant (LLVM.Vector n a) where+   fromInteger' = toMultiValue . Vector.fromInteger'++instance+   (TypeNum.Positive n, Vector.RationalConstant a) =>+      MultiValue.RationalConstant (LLVM.Vector n a) where+   fromRational' = toMultiValue . Vector.fromRational'++instance+   (TypeNum.Positive n, Vector.Additive a) =>+      MultiValue.Additive (LLVM.Vector n a) where+   add = liftMultiValueM2 Vector.add+   sub = liftMultiValueM2 Vector.sub+   neg = liftMultiValueM Vector.neg++instance+   (TypeNum.Positive n, Vector.Logic a) =>+      MultiValue.Logic (LLVM.Vector n a) where+   and = liftMultiValueM2 Vector.and+   or = liftMultiValueM2 Vector.or+   xor = liftMultiValueM2 Vector.xor+   inv = liftMultiValueM Vector.inv++instance+   (TypeNum.Positive n, Vector.BitShift a) =>+      MultiValue.BitShift (LLVM.Vector n a) where+   shl = liftMultiValueM2 Vector.shl+   shr = liftMultiValueM2 Vector.shr
src/LLVM/Extra/Multi/Vector/Memory.hs view
@@ -4,9 +4,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module LLVM.Extra.Multi.Vector.Memory where  import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Vector.Instance as Inst+import qualified LLVM.Extra.Multi.Value.Memory as MultiMem import LLVM.Extra.MemoryPrivate (decomposeFromLoad, composeFromStore, )  import qualified LLVM.Core as LLVM@@ -17,9 +20,12 @@  import Foreign.Ptr (Ptr, ) -import Control.Applicative (liftA2, )+import Control.Applicative (liftA2, liftA3, ) +import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int8, Int16, Int32, Int64) + class    (TypeNum.Positive n, MultiVector.C a, LLVM.IsSized (Struct n a)) =>       C n a where@@ -35,7 +41,79 @@    compose = composeFromStore store  instance+   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D8)) =>+      C n Word8 where+   type Struct n Word8 = LLVM.Vector n Word8+   load = fmap MultiVector.consPrim . LLVM.load+   store = LLVM.store . MultiVector.deconsPrim+   decompose = return . MultiVector.consPrim+   compose = return . MultiVector.deconsPrim++instance+   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D16)) =>+      C n Word16 where+   type Struct n Word16 = LLVM.Vector n Word16+   load = fmap MultiVector.consPrim . LLVM.load+   store = LLVM.store . MultiVector.deconsPrim+   decompose = return . MultiVector.consPrim+   compose = return . MultiVector.deconsPrim++instance    (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>+      C n Word32 where+   type Struct n Word32 = LLVM.Vector n Word32+   load = fmap MultiVector.consPrim . LLVM.load+   store = LLVM.store . MultiVector.deconsPrim+   decompose = return . MultiVector.consPrim+   compose = return . MultiVector.deconsPrim++instance+   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D64)) =>+      C n Word64 where+   type Struct n Word64 = LLVM.Vector n Word64+   load = fmap MultiVector.consPrim . LLVM.load+   store = LLVM.store . MultiVector.deconsPrim+   decompose = return . MultiVector.consPrim+   compose = return . MultiVector.deconsPrim++instance+   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D8)) =>+      C n Int8 where+   type Struct n Int8 = LLVM.Vector n Int8+   load = fmap MultiVector.consPrim . LLVM.load+   store = LLVM.store . MultiVector.deconsPrim+   decompose = return . MultiVector.consPrim+   compose = return . MultiVector.deconsPrim++instance+   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D16)) =>+      C n Int16 where+   type Struct n Int16 = LLVM.Vector n Int16+   load = fmap MultiVector.consPrim . LLVM.load+   store = LLVM.store . MultiVector.deconsPrim+   decompose = return . MultiVector.consPrim+   compose = return . MultiVector.deconsPrim++instance+   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>+      C n Int32 where+   type Struct n Int32 = LLVM.Vector n Int32+   load = fmap MultiVector.consPrim . LLVM.load+   store = LLVM.store . MultiVector.deconsPrim+   decompose = return . MultiVector.consPrim+   compose = return . MultiVector.deconsPrim++instance+   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D64)) =>+      C n Int64 where+   type Struct n Int64 = LLVM.Vector n Int64+   load = fmap MultiVector.consPrim . LLVM.load+   store = LLVM.store . MultiVector.deconsPrim+   decompose = return . MultiVector.consPrim+   compose = return . MultiVector.deconsPrim++instance+   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>       C n Float where    type Struct n Float = LLVM.Vector n Float    load = fmap MultiVector.consPrim . LLVM.load@@ -65,3 +143,30 @@             sb <- compose b             ra <- LLVM.insertvalue (LLVM.value LLVM.undef) sa TypeNum.d0             LLVM.insertvalue ra sb TypeNum.d1++instance (C n a, C n b, C n c) => C n (a,b,c) where+   type Struct n (a,b,c) =+         (LLVM.Struct (Struct n a, (Struct n b, (Struct n c, ()))))+   decompose abc =+      liftA3 MultiVector.zip3+         (decompose =<< LLVM.extractvalue abc TypeNum.d0)+         (decompose =<< LLVM.extractvalue abc TypeNum.d1)+         (decompose =<< LLVM.extractvalue abc TypeNum.d2)+   compose abc =+      case MultiVector.unzip3 abc of+         (a,b,c) -> do+            sa <- compose a+            sb <- compose b+            sc <- compose c+            ra <- LLVM.insertvalue (LLVM.value LLVM.undef) sa TypeNum.d0+            rb <- LLVM.insertvalue ra sb TypeNum.d1+            LLVM.insertvalue rb sc TypeNum.d2+++-- orphan+instance (C n a) => MultiMem.C (LLVM.Vector n a) where+   type Struct (LLVM.Vector n a) = Struct n a+   load = fmap Inst.toMultiValue . load+   store = store . Inst.fromMultiValue+   decompose = fmap Inst.toMultiValue . decompose+   compose = compose . Inst.fromMultiValue
src/LLVM/Extra/ScalarOrVector.hs view
@@ -46,7 +46,7 @@ import LLVM.Core    (Value, ConstValue, valueOf, constOf,     CmpRet, CmpResult, NumberOfElements,-    Vector, FP128,+    Vector, WordN(WordN), IntN(IntN), FP128,     IsConst, IsInteger, IsFloating,     CodeGenFunction, ) @@ -368,8 +368,14 @@ 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.Positive n, Vector.Real a) =>-         Real (Vector n a) where+instance (TypeNum.Positive n) => Real (IntN n) where+   min = A.min; max = A.max; abs = A.abs+   signum = A.signumGen (LLVM.valueOf $ IntN (-1)) (LLVM.valueOf $ IntN 1)+instance (TypeNum.Positive n) => Real (WordN n) where+   min = A.min; max = A.max; abs = return+   signum = A.signumGen (LLVM.value LLVM.undef) (LLVM.valueOf $ WordN 1)++instance (TypeNum.Positive n, Vector.Real a) => Real (Vector n a) where    min = Vector.min    max = Vector.max    abs = Vector.abs@@ -413,6 +419,10 @@ instance IntegerConstant Int64  where constFromInteger = constOf . fromInteger instance IntegerConstant Float  where constFromInteger = constOf . fromInteger instance IntegerConstant Double where constFromInteger = constOf . fromInteger+instance (TypeNum.Positive n) => IntegerConstant (WordN n) where+   constFromInteger = constOf . WordN+instance (TypeNum.Positive n) => IntegerConstant (IntN n)  where+   constFromInteger = constOf . IntN instance (IntegerConstant a, LLVM.IsPrimitive a, TypeNum.Positive n) =>          IntegerConstant (Vector n a) where    constFromInteger = replicateConst . constFromInteger
src/LLVM/Extra/Vector.hs view
@@ -46,7 +46,6 @@ import qualified LLVM.Extra.Extension as Ext  import qualified LLVM.Extra.Class as Class-import qualified LLVM.Extra.Monad as M import qualified LLVM.Extra.ArithmeticPrivate as A  import qualified LLVM.Core as LLVM@@ -62,6 +61,7 @@ import Type.Data.Num.Decimal (D4, (:+:), )  import qualified Control.Applicative as App+import qualified Control.Monad.HT as M import Control.Monad.HT ((<=<), ) import Control.Monad (liftM2, liftM3, foldM, ) import Control.Applicative (liftA2, )@@ -644,7 +644,7 @@    foldl1       {- quite the same as (+) using LLVM.Arithmetic instances,          but requires less type constraints -}-      (M.liftR2 A.add)+      (M.liftJoin2 A.add)       (List.map (LLVM.extractelement x . valueOf) $ take n $ [0..])  @@ -1199,7 +1199,7 @@           there is an instruction for horizontal add.           -}           do chunkSum <--                foldl1 (M.liftR2 A.add) $ chop x+                foldl1 (M.liftJoin2 A.add) $ chop x              y <- haddp chunkSum (value undef)              z <- haddp y        (value undef) {-@@ -1219,7 +1219,7 @@               reduce [] = []               reduce [_] = error "vector must have size power of two"               reduce (x0:x1:xs) =-                 M.liftR2 haddp x0 x1 : reduce xs+                 M.liftJoin2 haddp x0 x1 : reduce xs               go []  = error "vector must not be empty"               go [c] =                  getLowestPair@@ -1251,7 +1251,7 @@    dotProduct x y =       Ext.run (sum =<< A.mul x y) $       Ext.with X86A.dpps $ \dpp ->-         foldl1 (M.liftR2 A.add) $+         foldl1 (M.liftJoin2 A.add) $          List.zipWith             (\mx my -> do                cx <- mx