packages feed

llvm-extra 0.2.0.2 → 0.3

raw patch · 12 files changed

+576/−215 lines, 12 filesdep ~llvm

Dependency ranges changed: llvm

Files

llvm-extra.cabal view
@@ -1,5 +1,5 @@ Name:           llvm-extra-Version:        0.2.0.2+Version:        0.3 License:        BSD3 License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -69,7 +69,7 @@   Build-Depends:     -- llvm must be imported with restrictive version bounds,     -- because we import implicitly and unqualified-    llvm >=0.9.1 && <0.9.2,+    llvm >=0.10 && <0.10.1,     type-level >=0.2.3 && <0.3,     containers >=0.1 && <0.5,     transformers >=0.1.1 && <0.3,@@ -103,8 +103,11 @@     LLVM.Extra.Extension     LLVM.Extra.Extension.X86     LLVM.Extra.ExtensionCheck.X86+    LLVM.Extra.Array     LLVM.Extra.Vector     LLVM.Extra.ScalarOrVector+  Other-Modules:+    LLVM.Extra.ArithmeticPrivate  Executable tone-llvm   If !flag(buildExamples)
src/Array.hs view
@@ -2,12 +2,13 @@ module Main where  import LLVM.Extra.Control (arrayLoop, )-import qualified LLVM.Extra.ScalarOrVector as SV+import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector  import qualified LLVM.Extra.Extension.X86 as X86 import qualified LLVM.Extra.Extension as Ext +import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A  import LLVM.Core@@ -16,7 +17,6 @@  import Data.TypeLevel.Num(D4, ) import Data.Word (Word32, )-import Data.Int (Int32, ) import Foreign.Storable (Storable, sizeOf, ) import Foreign.Marshal.Array (allocaArray, ) @@ -52,25 +52,7 @@ fractionVector0 x =    frem x =<< constVec 1 -{--Works only when Floating point number is in the range-that is representable by Int32.--}-fraction :: Value Float -> CodeGenFunction r (Value Float)-fraction x =-   A.sub x =<<-   sitofp . flip asTypeOf (undefined :: Value Int32) =<<-   fptosi x -fractionVector ::-   Value (Vector D4 Float) ->-   CodeGenFunction r (Value (Vector D4 Float))-fractionVector x =-   A.sub x =<<-   sitofp . flip asTypeOf (undefined :: Value (Vector D4 Int32)) =<<-   fptosi x-- {- This call @@ -93,8 +75,8 @@       s01 <- add s0 s1       s23 <- add s2 s3       s0123 <- add s01 s23-      flip store ptri =<< mul (valueOf 0.25 :: Value Float) s0123-      fractionVector =<< add phase freq+      flip store ptri =<< A.mul (valueOf 0.25) s0123+      Vector.fraction =<< add phase freq     ss <- extractelement s (valueOf 0)     ret (ss :: Value Float) @@ -124,7 +106,7 @@ mixGeneric y = do     -- that is translated to movhlps     y23 <- shufflevector y (value undef) (constVector [constOf 2, constOf 3, undef, undef])-    z <- add y (y23 :: Value (Vector D4 Float))+    z <- A.add y y23     s0 <- extractelement z (valueOf 0)     s1 <- extractelement z (valueOf 1)     mul (0.25 :: Float) =<< add s0 s1@@ -144,7 +126,7 @@ -} mixDotProduct :: Value (Vector D4 Float) -> CodeGenFunction r (Value Float) mixDotProduct y = do-    x <- SV.replicate (valueOf 0.25)+    x <- SoV.replicate (valueOf 0.25)     z <- Ext.runUnsafe X86.dpps x y (valueOf 0xF1)     extractelement z (valueOf 0) @@ -156,38 +138,32 @@     const2 <- constVec (-2)     s <- arrayLoop size ptr (value (zero :: Vec)) $ \ ptri phase -> do       flip store ptri =<< mixHorizontal =<< add const1 =<< mul const2 phase-      fractionVector =<< add phase (freq :: Value (Vector D4 Float))+      Vector.fraction =<< A.add phase freq     ss <- extractelement s (valueOf 0)-    ret (ss :: Value Float)+    ret ss  waveSaw :: Value Float -> CodeGenFunction r (Value Float) waveSaw t =-  sub (valueOf 1 :: Value Float) =<<-  mul (valueOf 2 :: Value Float) t--incPhase :: Value Float -> Value Float -> CodeGenFunction r (Value Float)-incPhase d p =-  fraction =<< add d p+  sub (1 :: Float) =<<+  mul (2 :: Float) t  osciSaw :: Value Float -> Value Float -> CodeGenFunction r (Value Float, Value Float) osciSaw freq phase =-  liftM2 (,) (waveSaw phase) (incPhase freq phase)+  liftM2 (,) (waveSaw phase) (SoV.incPhase freq phase)  mChorus :: CodeGenModule (Function (Word32 -> Ptr Float -> Float -> Float -> Float -> Float -> IO Float)) mChorus =   createFunction ExternalLinkage $ \ size ptr f0 f1 f2 f3 -> do-    s <- arrayLoop size ptr-            ((valueOf 0 :: Value Float, valueOf 0 :: Value Float),-             (valueOf 0 :: Value Float, valueOf 0 :: Value Float)) $+    s <- arrayLoop size ptr Class.zeroTuple $          \ ptri ((phase0, phase1), (phase2, phase3)) -> do       (y0, phase0') <- osciSaw f0 phase0       (y1, phase1') <- osciSaw f1 phase1       (y2, phase2') <- osciSaw f2 phase2       (y3, phase3') <- osciSaw f3 phase3-      y01 <- add y0 y1-      y23 <- add y2 y3-      y0123 <- add y01 y23-      flip store ptri =<< mul (valueOf 0.25 :: Value Float) y0123+      y01 <- A.add y0 y1+      y23 <- A.add y2 y3+      y0123 <- A.add y01 y23+      flip store ptri =<< mul (0.25 :: Float) y0123       return ((phase0', phase1'), (phase2', phase3'))     ret (fst (fst s) :: Value Float) @@ -221,17 +197,15 @@ mChorusMonadic :: CodeGenModule (Function (Word32 -> Ptr Float -> Float -> Float -> Float -> Float -> IO Float)) mChorusMonadic =   createFunction ExternalLinkage $ \ size ptr f0 f1 f2 f3 -> do-    s <- arrayLoop size ptr-            ((valueOf 0 :: Value Float, valueOf 0 :: Value Float),-             (valueOf 0 :: Value Float, valueOf 0 :: Value Float)) $+    s <- arrayLoop size ptr Class.zeroTuple $          \ ptri phases -> do       (y, phases') <-          flip runStateT phases $             (sawOsciAction f0 =+= sawOsciAction f1) =+=             (sawOsciAction f2 =+= sawOsciAction f3)-      flip store ptri =<< mul (valueOf 0.25 :: Value Float) y+      flip store ptri =<< mul (0.25 :: Float) y       return phases'-    ret (fst (fst s) :: Value Float)+    ret (fst (fst s))  renderChorus :: IO () renderChorus = do
src/LLVM/Extra/Arithmetic.hs view
@@ -1,80 +1,175 @@+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} module LLVM.Extra.Arithmetic (-   add, sub, inc, dec,-   mul, square, fdiv,+   -- * arithmetic: generalized and improved type inference+   Additive (zero, add, sub, neg), one, inc, dec,+   PseudoRing (mul), square,+   PseudoModule (scale),+   Field (fdiv),+   IntegerConstant(fromInteger'),+   RationalConstant(fromRational'),    idiv, irem,    fcmp, cmp,    and, or,-   min, max, abs,+   Real (min, max, abs),+   Fraction (truncate, fraction),+   signedFraction, addToPhase, incPhase,+   -- * pointer arithmetic    advanceArrayElementPtr,-   sqrt, sin, cos, exp, log, pow,+   -- * transcendental functions+   Algebraic (sqrt),+   Transcendental (sin, cos, exp, log, pow),    ) where +import LLVM.Extra.ArithmeticPrivate+   (cmp, fcmp, and, or,+    inc, dec, advanceArrayElementPtr, )++import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Core as LLVM import LLVM.Core-   (Ptr, getElementPtr, value, valueOf, Value,-    CmpPredicate(CmpLE, CmpGE), CmpRet,-    FPPredicate,-    IsType, IsConst, IsInteger, IsFloating, IsArithmetic, IsFirstClass,-    CodeGenFunction, )+   (CodeGenFunction, value, Value, ConstValue,+    IsType, IsInteger, IsFloating, IsArithmetic, IsFirstClass, ) -import Data.Word (Word32, )+import Control.Monad (liftM2, liftM3, ) +import Prelude hiding+   (Real, and, or, sqrt, sin, cos, exp, log, abs, min, max, truncate, ) -import Prelude hiding (and, or, sqrt, sin, cos, exp, log, abs, min, max, )  +{- |+This and the following type classes+are intended for arithmetic operations on wrappers around LLVM types.+E.g. you might define a fixed point fraction type by --- * arithmetic with better type inference+> newtype Fixed = Fixed Int32 -add ::-   (IsArithmetic a) =>-   Value a -> Value a -> CodeGenFunction r (Value a)-add = LLVM.add+and then use the same methods for floating point and fixed point arithmetic. -sub ::-   (IsArithmetic a) =>-   Value a -> Value a -> CodeGenFunction r (Value a)-sub = LLVM.sub+In contrast to the arithmetic methods in the @llvm@ wrapper,+in our methods the types of operands and result match.+Advantage: Type inference determines most of the types automatically.+Disadvantage: You cannot use constant values directly,+but you have to convert them all to 'Value'.+-}+class Additive a where+   zero :: a+   add :: a -> a -> CodeGenFunction r a+   sub :: a -> a -> CodeGenFunction r a+   neg :: a -> CodeGenFunction r a -inc ::-   (IsArithmetic a, IsConst a, Num a) =>-   Value a -> CodeGenFunction r (Value a)-inc x = add x (valueOf 1)+instance (IsArithmetic a) => Additive (Value a) where+   zero = LLVM.value LLVM.zero+   add = LLVM.add+   sub = LLVM.sub+   neg = LLVM.neg -dec ::-   (IsArithmetic a, IsConst a, Num a) =>-   Value a -> CodeGenFunction r (Value a)-dec x = sub x (valueOf 1)+instance (IsArithmetic a) => Additive (ConstValue a) where+   zero = LLVM.zero+   add = LLVM.add+   sub = LLVM.sub+   neg = sub LLVM.zero +instance (Additive a, Additive b) => Additive (a,b) where+   zero = (zero, zero)+   add (x0,x1) (y0,y1) =+      liftM2 (,) (add x0 y0) (add x1 y1)+   sub (x0,x1) (y0,y1) =+      liftM2 (,) (sub x0 y0) (sub x1 y1)+   neg (x0,x1) =+      liftM2 (,) (neg x0)    (neg x1) -mul ::-   (IsArithmetic a) =>-   Value a -> Value a -> CodeGenFunction r (Value a)-mul = LLVM.mul+instance (Additive a, Additive b, Additive c) => Additive (a,b,c) where+   zero = (zero, zero, zero)+   add (x0,x1,x2) (y0,y1,y2) =+      liftM3 (,,) (add x0 y0) (add x1 y1) (add x2 y2)+   sub (x0,x1,x2) (y0,y1,y2) =+      liftM3 (,,) (sub x0 y0) (sub x1 y1) (sub x2 y2)+   neg (x0,x1,x2) =+      liftM3 (,,) (neg x0)    (neg x1)    (neg x2) ++class (Additive a) => PseudoRing a where+   mul :: a -> a -> CodeGenFunction r a++instance (IsArithmetic v) => PseudoRing (Value v) where+   mul = LLVM.mul++instance (IsArithmetic v) => PseudoRing (ConstValue v) where+   mul = LLVM.mul+++class (PseudoRing a, Additive v) => PseudoModule a v where+   scale :: a -> v -> CodeGenFunction r v++instance+   (SoV.PseudoModule a v) =>+      PseudoModule (Value a) (Value v) where+   scale = SoV.scale++instance+   (SoV.PseudoModule a v) =>+      PseudoModule (ConstValue a) (ConstValue v) where+   scale = SoV.scaleConst+++class IntegerConstant a where+   fromInteger' :: Integer -> a++instance SoV.IntegerConstant a => IntegerConstant (ConstValue a) where+   fromInteger' = SoV.constFromInteger++instance SoV.IntegerConstant a => IntegerConstant (Value a) where+   fromInteger' = value . SoV.constFromInteger+++one :: (IntegerConstant a) => a+one = fromInteger' 1+++{-+more general alternative to 'inc',+but you may not like the resulting type constraints+-}+_inc ::+   (PseudoRing a, IntegerConstant a) =>+   a -> CodeGenFunction r a+_inc x = add x one++_dec ::+   (PseudoRing a, IntegerConstant a) =>+   a -> CodeGenFunction r a+_dec x = sub x one++ square ::-   (IsArithmetic a) =>-   Value a -> CodeGenFunction r (Value a)+   (PseudoRing a) =>+   a -> CodeGenFunction r a square x = mul x x  -fdiv ::-   (IsFloating a) =>-   Value a -> Value a -> CodeGenFunction r (Value a)-fdiv = LLVM.fdiv+class (PseudoRing a) => Field a where+   fdiv :: a -> a -> CodeGenFunction r a -fcmp ::-   (IsFloating a, CmpRet a b) =>-   FPPredicate -> Value a -> Value a -> CodeGenFunction r (Value b)-fcmp = LLVM.fcmp+instance (LLVM.IsFloating v) => Field (Value v) where+   fdiv = LLVM.fdiv +instance (LLVM.IsFloating v) => Field (ConstValue v) where+   fdiv = LLVM.fdiv -cmp ::-   (CmpRet a b) =>-   CmpPredicate -> Value a -> Value a -> CodeGenFunction r (Value b)-cmp = LLVM.cmp +class (IntegerConstant a) => RationalConstant a where+   fromRational' :: Rational -> a++instance SoV.RationalConstant a => RationalConstant (ConstValue a) where+   fromRational' = SoV.constFromRational++instance SoV.RationalConstant a => RationalConstant (Value a) where+   fromRational' = value . SoV.constFromRational+++ idiv ::    (IsInteger a) =>    Value a -> Value a -> CodeGenFunction r (Value a)@@ -86,59 +181,49 @@ irem = LLVM.irem  -and ::-   (IsInteger a) =>-   Value a -> Value a -> CodeGenFunction r (Value a)-and = LLVM.and -or ::-   (IsInteger a) =>-   Value a -> Value a -> CodeGenFunction r (Value a)-or = LLVM.or----{- |-This would also work for vectors,-if LLVM would support 'select' with bool vectors as condition.--}-min :: (IsFirstClass a, CmpRet a Bool) =>-   Value a -> Value a -> CodeGenFunction r (Value a)-min = cmpSelect (cmp CmpLE)--max :: (IsFirstClass a, CmpRet a Bool) =>-   Value a -> Value a -> CodeGenFunction r (Value a)-max = cmpSelect (cmp CmpGE)+class (Additive a) => Real a where+   min :: a -> a -> CodeGenFunction r a+   max :: a -> a -> CodeGenFunction r a+   abs :: a -> CodeGenFunction r a -abs :: (IsArithmetic a, CmpRet a Bool) =>-   Value a -> CodeGenFunction r (Value a)-abs x = do-   b <- cmp CmpGE x (value LLVM.zero)-   LLVM.select b x =<< LLVM.neg x+instance (SoV.Real a) => Real (Value a) where+   min = SoV.min+   max = SoV.max+   abs = SoV.abs  -cmpSelect ::-   (IsFirstClass a, CmpRet a Bool) =>-   (Value a -> Value a -> CodeGenFunction r (Value Bool)) ->-   (Value a -> Value a -> CodeGenFunction r (Value a))-cmpSelect f x y =-   f x y >>= \b -> LLVM.select b x y+class (Real a) => Fraction a where+   truncate :: a -> CodeGenFunction r a+   fraction :: a -> CodeGenFunction r a +instance (SoV.Fraction a) => Fraction (Value a) where+   truncate = SoV.truncate+   fraction = SoV.fraction +signedFraction ::+   (Fraction a) =>+   a -> CodeGenFunction r a+signedFraction x =+   sub x =<< truncate x --- * pointers+addToPhase ::+   (Fraction a) =>+   a -> a -> CodeGenFunction r a+addToPhase d p =+   fraction =<< add d p -advanceArrayElementPtr ::-   Value (Ptr o) ->-   CodeGenFunction r (Value (Ptr o))-advanceArrayElementPtr p =-   getElementPtr p (valueOf 1 :: Value Word32, ())+{- |+both increment and phase must be non-negative+-}+incPhase ::+   (Fraction a) =>+   a -> a -> CodeGenFunction r a+incPhase d p =+   signedFraction =<< add d p   --- * transcendental functions-- valueTypeName ::    (IsType a) =>    Value a -> String@@ -183,17 +268,20 @@    return x  +class Field a => Algebraic a where+   sqrt :: a -> CodeGenFunction r a -sqrt, sin, cos, exp, log ::-   (IsFloating a) =>-   Value a -> CodeGenFunction r (Value a)-sqrt = callIntrinsic1 "sqrt"-sin = callIntrinsic1 "sin"-cos = callIntrinsic1 "cos"-exp = callIntrinsic1 "exp"-log = callIntrinsic1 "log"+instance (IsFloating a) => Algebraic (Value a) where+   sqrt = callIntrinsic1 "sqrt" -pow ::-   (IsFloating a) =>-   Value a -> Value a -> CodeGenFunction r (Value a)-pow = callIntrinsic2 "pow"++class Algebraic a => Transcendental a where+   sin, cos, exp, log :: a -> CodeGenFunction r a+   pow :: a -> a -> CodeGenFunction r a++instance (IsFloating a) => Transcendental (Value a) where+   sin = callIntrinsic1 "sin"+   cos = callIntrinsic1 "cos"+   exp = callIntrinsic1 "exp"+   log = callIntrinsic1 "log"+   pow = callIntrinsic2 "pow"
+ src/LLVM/Extra/ArithmeticPrivate.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.ArithmeticPrivate where++import qualified LLVM.Core as LLVM+import LLVM.Core+   (CodeGenFunction, value, valueOf, Value,+    CmpPredicate(CmpLE, CmpGE), FPPredicate, CmpRet,+    IsConst, IsFirstClass, IsArithmetic, IsInteger, IsFloating,+    Ptr, getElementPtr, )++import Data.Word (Word32, )++import Prelude hiding (and, or, sqrt, sin, cos, exp, log, abs, min, max, )+++add ::+   (IsArithmetic a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+add = LLVM.add++sub ::+   (IsArithmetic a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+sub = LLVM.sub+++inc ::+   (IsArithmetic a, IsConst a, Num a) =>+   Value a -> CodeGenFunction r (Value a)+inc x = add x (valueOf 1)++dec ::+   (IsArithmetic a, IsConst a, Num a) =>+   Value a -> CodeGenFunction r (Value a)+dec x = sub x (valueOf 1)++advanceArrayElementPtr ::+   Value (Ptr a) ->+   CodeGenFunction r (Value (Ptr a))+advanceArrayElementPtr p =+   getElementPtr p (valueOf 1 :: Value Word32, ())++++mul ::+   (IsArithmetic a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+mul = LLVM.mul+++{- |+This would also work for vectors,+if LLVM would support 'select' with bool vectors as condition.+-}+min :: (IsFirstClass a, CmpRet a Bool) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+min = cmpSelect (cmp CmpLE)++max :: (IsFirstClass a, CmpRet a Bool) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+max = cmpSelect (cmp CmpGE)++abs :: (IsArithmetic a, CmpRet a Bool) =>+   Value a -> CodeGenFunction r (Value a)+abs x = do+   b <- cmp CmpGE x (value LLVM.zero)+   LLVM.select b x =<< LLVM.neg x+++cmpSelect ::+   (IsFirstClass a, CmpRet a Bool) =>+   (Value a -> Value a -> CodeGenFunction r (Value Bool)) ->+   (Value a -> Value a -> CodeGenFunction r (Value a))+cmpSelect f x y =+   f x y >>= \b -> LLVM.select b x y+++fcmp ::+   (IsFloating a, CmpRet a b) =>+   FPPredicate -> Value a -> Value a -> CodeGenFunction r (Value b)+fcmp = LLVM.fcmp++cmp ::+   (CmpRet a b) =>+   CmpPredicate -> Value a -> Value a -> CodeGenFunction r (Value b)+cmp = LLVM.cmp++++and ::+   (IsInteger a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+and = LLVM.and++or ::+   (IsInteger a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+or = LLVM.or
+ src/LLVM/Extra/Array.hs view
@@ -0,0 +1,73 @@+module LLVM.Extra.Array (+   size,+   assemble,+   extractAll,+   map,+   ) where++import qualified LLVM.Extra.Class as Class++import qualified LLVM.Core as LLVM+import LLVM.Core (Value, Array, CodeGenFunction, )++import qualified Data.TypeLevel.Num as TypeNum+import Control.Monad.HT ((<=<), )+import Control.Monad (foldM, )+import qualified Data.List as List++import Data.Word (Word32, )++import Prelude hiding+          (Real, truncate, floor, round,+           map, zipWith, iterate, replicate, reverse, concat, sum, )+++-- * target independent functions++size ::+   (TypeNum.Nat n) =>+   Value (Array n a) -> Int+size =+   let sz :: (TypeNum.Nat n) => n -> Value (Array n a) -> Int+       sz n _ = TypeNum.toInt n+   in  sz undefined++{- |+construct an array out of single elements++You must assert that the length of the list matches the array size.++This can be considered the inverse of 'extractAll'.+-}+assemble ::+   (TypeNum.Nat n, LLVM.IsFirstClass a, LLVM.IsSized a s) =>+   [Value a] -> CodeGenFunction r (Value (Array n a))+assemble =+   foldM (\v (k,x) -> LLVM.insertvalue v x (k::Word32)) Class.undefTuple .+   List.zip [0..]++{- |+provide the elements of an array as a list of individual virtual registers++This can be considered the inverse of 'assemble'.+-}+extractAll ::+   (TypeNum.Nat n, LLVM.IsFirstClass a, LLVM.IsSized a s) =>+   Value (Array n a) -> LLVM.CodeGenFunction r [Value a]+extractAll x =+   mapM+      (LLVM.extractvalue x)+      (take (size x) [(0::Word32)..])++{- |+The loop is unrolled,+since 'LLVM.insertvalue' and 'LLVM.extractvalue' expect constant indices.+-}+map ::+   (TypeNum.Nat n,+    LLVM.IsFirstClass a, LLVM.IsSized a asize,+    LLVM.IsFirstClass b, LLVM.IsSized b bsize) =>+   (Value a -> CodeGenFunction r (Value b)) ->+   (Value (Array n a) -> CodeGenFunction r (Value (Array n b)))+map f =+   assemble <=< mapM f <=< extractAll
src/LLVM/Extra/Control.hs view
@@ -20,9 +20,9 @@    ifThenSelect,    ) where -import LLVM.Extra.Arithmetic+import LLVM.Extra.ArithmeticPrivate    (cmp, sub, dec, advanceArrayElementPtr, )-import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.ArithmeticPrivate as A import qualified LLVM.Core as LLVM import LLVM.Core    (getCurrentBasicBlock, newBasicBlock, defineBasicBlock,
src/LLVM/Extra/Extension.hs view
@@ -102,13 +102,13 @@ and it also checks the signature. -} intrinsic ::-   (LLVM.IsFunction f, LLVM.CallArgs f g, CallArgs g r) =>+   (LLVM.IsFunction f, LLVM.CallArgs f g r, CallArgs g r) =>    Subtarget -> String -> T g intrinsic =    intrinsicAttr [{- ReadNoneAttribute -}]  intrinsicAttr ::-   (LLVM.IsFunction f, LLVM.CallArgs f g, CallArgs g r) =>+   (LLVM.IsFunction f, LLVM.CallArgs f g r, CallArgs g r) =>    [Attribute] -> Subtarget -> String -> T g intrinsicAttr attrs tar intr =    wrap tar $
src/LLVM/Extra/Extension/X86.hs view
@@ -37,7 +37,7 @@           (sse1, sse2, sse3, ssse3, sse41, sse42, )  import qualified LLVM.Extra.Monad as M-import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.ArithmeticPrivate as A import qualified LLVM.Core as LLVM import LLVM.Core    (Value, Vector, value, valueOf, constOf, constVector,
src/LLVM/Extra/MaybeContinuation.hs view
@@ -15,6 +15,7 @@ import LLVM.Core as LLVM import LLVM.Util.Loop (Phi, ) -- (phis, addPhis, ) +import Control.Monad.IO.Class (MonadIO(liftIO), ) import qualified Control.Applicative as App import qualified Control.Monad as M @@ -22,7 +23,6 @@ import Data.Tuple.HT (mapSnd, )  import Prelude hiding (and, iterate, map, zip, zipWith, writeFile, )-import qualified Prelude as P   {- |@@ -52,6 +52,9 @@ instance Monad (T r z) where    return a = lift (return a)    (>>=) = bind++instance MonadIO (T r z) where+   liftIO = lift . liftIO  {- | counterpart to Data.Maybe.HT.toMaybe
src/LLVM/Extra/Memory.hs view
@@ -8,9 +8,13 @@    Record, Element, element,    loadRecord, storeRecord, decomposeRecord, composeRecord,    loadNewtype, storeNewtype, decomposeNewtype, composeNewtype,+   FirstClass,    ) where  import LLVM.Extra.Class (MakeValueTuple, Undefined, )+import qualified LLVM.Extra.ArithmeticPrivate as A+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Array as Array  import qualified LLVM.Core as LLVM import LLVM.Core@@ -21,11 +25,15 @@     CodeGenFunction, ) import LLVM.Util.Loop (Phi, ) --- import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num as TypeNum import Data.TypeLevel.Num (d0, d1, d2, ) +import Foreign.StablePtr (StablePtr, ) import Foreign.Ptr (Ptr, castPtr, ) +import Data.Word (Word8, Word16, Word32, Word64, )+import Data.Int  (Int8,  Int16,  Int32,  Int64, )+ import Control.Monad (ap, ) import Control.Applicative (pure, liftA2, liftA3, ) import qualified Control.Applicative as App@@ -173,19 +181,117 @@    compose = composeRecord triple  -{- |-ToDo:-This is dangerous because LLVM uses one bit for Bool representation,-and I think one byte in memory,+{-+This would not work for Booleans,+since on x86 LLVM's @i1@ type uses one byte in memory, whereas Storable uses 4 byte and 4 byte alignment.-We should define a sub-class of IsFirstClass for all compatible types,-and make this a super-class of this instance.--}+ instance (LLVM.IsFirstClass a) => C (Value a) a where    load = LLVM.load    store = LLVM.store    decompose = return    compose = return+-}+++class (LLVM.IsFirstClass llvmType, IsType llvmStruct) =>+      FirstClass llvmType llvmStruct | llvmType -> llvmStruct where+   fromStorable :: Value llvmStruct -> CodeGenFunction r (Value llvmType)+   toStorable :: Value llvmType -> CodeGenFunction r (Value llvmStruct)++instance FirstClass Float  Float  where fromStorable = return; toStorable = return+instance FirstClass Double Double where fromStorable = return; toStorable = return+instance FirstClass Int8   Int8   where fromStorable = return; toStorable = return+instance FirstClass Int16  Int16  where fromStorable = return; toStorable = return+instance FirstClass Int32  Int32  where fromStorable = return; toStorable = return+instance FirstClass Int64  Int64  where fromStorable = return; toStorable = return+instance FirstClass Word8  Word8  where fromStorable = return; toStorable = return+instance FirstClass Word16 Word16 where fromStorable = return; toStorable = return+instance FirstClass Word32 Word32 where fromStorable = return; toStorable = return+instance FirstClass Word64 Word64 where fromStorable = return; toStorable = return+instance FirstClass Bool   Word32 where+   fromStorable = A.cmp LLVM.CmpNE (LLVM.value LLVM.zero)+   toStorable = LLVM.zext+instance+   (LLVM.Pos n, LLVM.IsPrimitive a, LLVM.IsPrimitive am, FirstClass a am) =>+      FirstClass (LLVM.Vector n a) (LLVM.Vector n am) where+   fromStorable = Vector.map fromStorable+   toStorable = Vector.map toStorable+instance+   (LLVM.Nat n, LLVM.IsFirstClass am,+    FirstClass a am, IsSized a asize, IsSized am amsize) =>+      FirstClass (LLVM.Array n a) (LLVM.Array n am) where+   fromStorable = Array.map fromStorable+   toStorable = Array.map toStorable++instance (IsType a) => FirstClass (Ptr a) (Ptr a) where+   fromStorable = return; toStorable = return+instance FirstClass (StablePtr a) (StablePtr a) where+   fromStorable = return; toStorable = return+++instance+   (LLVM.IsFirstClass (Struct s),+    IsType (Struct sm),+    ConvertStruct s sm TypeNum.D0 s sm) =>+      FirstClass (Struct s) (Struct sm) where+   fromStorable sm =+      case undefined of+         sfields -> do+            s <- decomposeField sfields (fields sm) d0 sm+            let _ = asTypeOf (fields s) sfields+            return s+   toStorable s =+      case undefined of+         smfields -> do+            sm <- composeField (fields s) smfields d0 s+            let _ = asTypeOf (fields sm) smfields+            return sm++fields :: Value (Struct s) -> s+fields _ = undefined++class+   ConvertStruct s sm i rem remm |+      s -> sm, rem -> remm, s rem -> i, sm remm -> i where+   decomposeField ::+      rem -> remm ->+      i -> Value (Struct sm) ->+      CodeGenFunction r (Value (Struct s))+   composeField ::+      rem -> remm ->+      i -> Value (Struct s) ->+      CodeGenFunction r (Value (Struct sm))++instance+   (LLVM.GetValue (Struct s) i a,+    LLVM.GetValue (Struct sm) i am,+    FirstClass a am,+    ConvertStruct s sm i' rem remm,+    TypeNum.Succ i i') =>+      ConvertStruct s sm i (a,rem) (am,remm) where+   decomposeField ~(_,rem_) ~(_,remm) i sm = do+      s <- decomposeField rem_ remm (TypeNum.succ i) sm+      a <- fromStorable =<< LLVM.extractvalue sm i+      LLVM.insertvalue s a i+   composeField ~(_,rem_) ~(_,remm) i s = do+      sm <- composeField rem_ remm (TypeNum.succ i) s+      am <- toStorable =<< LLVM.extractvalue s i+      LLVM.insertvalue sm am i++instance+   (IsType (Struct s),+    IsType (Struct sm)) =>+      ConvertStruct s sm i () () where+   decomposeField _ _ _ _ =+      return (LLVM.value LLVM.undef)+   composeField _ _ _ _ =+      return (LLVM.value LLVM.undef)++instance (FirstClass a am) => C (Value a) am where+   decompose = fromStorable+   compose = toStorable+  instance C () (Struct ()) where    load _ = return ()
src/LLVM/Extra/ScalarOrVector.hs view
@@ -18,6 +18,9 @@    Replicate (replicate, replicateConst),    replicateOf,    Real (min, max, abs),+   PseudoModule (scale, scaleConst),+   IntegerConstant(constFromInteger),+   RationalConstant(constFromRational),    ) where  import qualified LLVM.Extra.Vector as Vector@@ -25,14 +28,14 @@ import qualified LLVM.Extra.Extension as Ext  import qualified LLVM.Extra.Class as Class-import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.ArithmeticPrivate as A  import qualified Data.TypeLevel.Num as TypeNum import Data.TypeLevel.Num (D1, ) import qualified LLVM.Core as LLVM import LLVM.Core-   (Value, ConstValue, valueOf,-    Vector, FP128,+   (Value, ConstValue, valueOf, constOf,+    Vector, constVector, FP128,     IsConst, IsFloating,     CodeGenFunction, ) @@ -44,46 +47,7 @@ import Prelude hiding (Real, replicate, min, max, abs, truncate, floor, round, )  -{--class-   (IsFloating frac,-    IsInteger int,-    LLVM.NumberOfElements n frac,-    LLVM.NumberOfElements n int) =>-      Fraction n int frac | frac -> int, frac -> n, int -> n where-   fptosi :: Value frac -> CodeGenFunction r (Value int)-   fptosi = LLVM.fptosi-   sitofp :: Value int -> CodeGenFunction r (Value frac)-   sitofp = LLVM.sitofp--} -{--class-   (IsFloating frac) =>-      Fraction int frac | frac -> int where-   fptosi :: Value frac -> CodeGenFunction r (Value int)-   sitofp :: Value int -> CodeGenFunction r (Value frac)--instance Fraction Int32 Float where-   fptosi = LLVM.fptosi-   sitofp = LLVM.sitofp--instance Fraction Int64 Double where-   fptosi = LLVM.fptosi-   sitofp = LLVM.sitofp--instance (TypeNum.Pos n) =>-      Fraction (Vector n Int32) (Vector n Float) where-   fptosi = LLVM.fptosi-   sitofp = LLVM.sitofp--instance (TypeNum.Pos n) =>-      Fraction (Vector n Int64) (Vector n Double) where-   fptosi = LLVM.fptosi-   sitofp = LLVM.sitofp--}-- class (Real a, IsFloating a) => Fraction a where    truncate :: Value a -> CodeGenFunction r (Value a)    fraction :: Value a -> CodeGenFunction r (Value a)@@ -91,7 +55,7 @@ instance Fraction Float where    truncate =       mapAuto-         (LLVM.sitofp . flip asTypeOf (undefined :: Value Int32) <=< LLVM.fptosi)+         (LLVM.inttofp . flip asTypeOf (undefined :: Value Int32) <=< LLVM.fptoint)          (Ext.with X86.roundss $ \round x -> round x (valueOf 3))    fraction =       (\x ->@@ -107,7 +71,7 @@    truncate =       mapAuto          -- X86 only converts Double to Int32, it cannot target Int64-         (LLVM.sitofp . flip asTypeOf (undefined :: Value Int32) <=< LLVM.fptosi)+         (LLVM.inttofp . flip asTypeOf (undefined :: Value Int32) <=< LLVM.fptoint)          (Ext.with X86.roundsd $ \round x -> round x (valueOf 3))    fraction =       (\x ->@@ -159,7 +123,7 @@ fractionLogical cmp x =    do xf <- signedFraction x       b <- cmp LLVM.FPOLT xf (LLVM.value LLVM.zero)-      A.sub xf =<< LLVM.sitofp b+      A.sub xf =<< LLVM.inttofp b  {- | increment (first operand) may be negative,@@ -299,3 +263,55 @@    min = Vector.min    max = Vector.max    abs = Vector.abs++++class+   (Replicate a v, LLVM.IsArithmetic a, LLVM.IsArithmetic v) =>+      PseudoModule a v where+   scale :: Value a -> Value v -> CodeGenFunction r (Value v)+   scaleConst :: ConstValue a -> ConstValue v -> CodeGenFunction r (ConstValue v)++instance PseudoModule Word8  Word8  where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Word16 Word16 where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Word32 Word32 where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Word64 Word64 where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Int8   Int8   where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Int16  Int16  where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Int32  Int32  where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Int64  Int64  where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Float  Float  where scale = LLVM.mul; scaleConst = LLVM.mul+instance PseudoModule Double Double where scale = LLVM.mul; scaleConst = LLVM.mul+instance (LLVM.IsArithmetic a, LLVM.IsPrimitive a, TypeNum.Pos n) =>+         PseudoModule a (Vector n a) where+   scale a v = flip LLVM.mul v . flip asTypeOf v =<< replicate a+   scaleConst a v = LLVM.mul (replicateConst a `asTypeOf` v) v++++class (LLVM.IsConst a) => IntegerConstant a where+   constFromInteger :: Integer -> ConstValue a++instance IntegerConstant Word8  where constFromInteger = constOf . fromInteger+instance IntegerConstant Word16 where constFromInteger = constOf . fromInteger+instance IntegerConstant Word32 where constFromInteger = constOf . fromInteger+instance IntegerConstant Word64 where constFromInteger = constOf . fromInteger+instance IntegerConstant Int8   where constFromInteger = constOf . fromInteger+instance IntegerConstant Int16  where constFromInteger = constOf . fromInteger+instance IntegerConstant Int32  where constFromInteger = constOf . fromInteger+instance IntegerConstant Int64  where constFromInteger = constOf . fromInteger+instance IntegerConstant Float  where constFromInteger = constOf . fromInteger+instance IntegerConstant Double where constFromInteger = constOf . fromInteger+instance (IntegerConstant a, LLVM.IsPrimitive a, TypeNum.Pos n) =>+         IntegerConstant (Vector n a) where+   constFromInteger x = constVector [constFromInteger x]+++class (IntegerConstant a) => RationalConstant a where+   constFromRational :: Rational -> ConstValue a++instance RationalConstant Float  where constFromRational = constOf . fromRational+instance RationalConstant Double where constFromRational = constOf . fromRational+instance (RationalConstant a, LLVM.IsPrimitive a, TypeNum.Pos n) =>+         RationalConstant (Vector n a) where+   constFromRational x = constVector [constFromRational x]
src/LLVM/Extra/Vector.hs view
@@ -40,7 +40,7 @@  import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Monad as M-import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.ArithmeticPrivate as A  import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, )@@ -770,7 +770,7 @@ floorLogical cmp x =    do xr <- truncate x       b <- cmp LLVM.FPOGT xr x-      A.add xr =<< LLVM.sitofp b+      A.add xr =<< LLVM.inttofp b  fractionLogical ::    (IsFloating a, IsConst a, Real a,@@ -784,7 +784,7 @@ fractionLogical cmp x =    do xf <- signedFraction x       b <- cmp LLVM.FPOLT xf (value LLVM.zero)-      A.sub xf =<< LLVM.sitofp b+      A.sub xf =<< LLVM.inttofp b   orderBy ::@@ -1090,9 +1090,9 @@    than that for the rounding via Int32.    -}    truncate x =-      (LLVM.sitofp .+      (LLVM.inttofp .        (id :: Value (Vector n Int32) -> Value (Vector n Int32))-       <=< LLVM.fptosi) x+       <=< LLVM.fptoint) x       `Ext.run`       (Ext.with X86.roundps $ \round ->           mapChunks (flip round (valueOf 3)) x)@@ -1105,7 +1105,7 @@       `Ext.run`       (Ext.with2 (X86.withMXCSR (Bit.shiftL 1 13)) X86.cvtps2dq $           \ with cvtps2dq -> with $-             LLVM.sitofp =<< mapChunks cvtps2dq x)+             LLVM.inttofp =<< mapChunks cvtps2dq x) -}       `Ext.run`       (Ext.with X86.roundps $ \round ->@@ -1119,7 +1119,7 @@       `Ext.run`       (Ext.with2 (X86.withMXCSR (Bit.shiftL 1 13)) X86.cvtps2dq $           \ with cvtps2dq -> with $-             A.sub x =<< LLVM.sitofp =<< mapChunks cvtps2dq x)+             A.sub x =<< LLVM.inttofp =<< mapChunks cvtps2dq x) -}       `Ext.run`       (Ext.with X86.roundps $ \round ->@@ -1130,9 +1130,9 @@    max = zipAutoWith A.max X86.maxpd    abs = mapAuto A.abs X86.abspd    truncate x =-      (LLVM.sitofp .+      (LLVM.inttofp .        (id :: Value (Vector n Int64) -> Value (Vector n Int64))-       <=< LLVM.fptosi) x+       <=< LLVM.fptoint) x       `Ext.run`       (Ext.with X86.roundpd $ \round ->           mapChunks (flip round (valueOf 3)) x)