packages feed

llvm-dsl 0.0 → 0.1

raw patch · 7 files changed

+954/−61 lines, 7 filesdep +unsafedep +vaultdep ~llvm-extradep ~llvm-tfdep ~transformers

Dependencies added: unsafe, vault

Dependency ranges changed: llvm-extra, llvm-tf, transformers

Files

llvm-dsl.cabal view
@@ -1,6 +1,6 @@ Cabal-Version:  2.2 Name:           llvm-dsl-Version:        0.0+Version:        0.1 License:        BSD-3-Clause License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -22,19 +22,20 @@     Assemble functions to modules and run them. Stability:      Experimental Tested-With:    GHC==7.0.4, GHC==7.4.2, GHC==7.8.4-Tested-With:    GHC==8.4.4, GHC==8.6.5, GHC==8.8.2+Tested-With:    GHC==8.4.4, GHC==8.6.5, GHC==8.8.4+Tested-With:    GHC==9.0.2, GHC==9.2.8, GHC==9.4.6 Build-Type:     Simple Extra-Source-Files:   Makefile  Source-Repository head   Type:     darcs-  Location: http://hub.darcs.net/thielema/llvm-dsl/+  Location: https://hub.darcs.net/thielema/llvm-dsl/  Source-Repository this-  Tag:      0.0+  Tag:      0.1   Type:     darcs-  Location: http://hub.darcs.net/thielema/llvm-dsl/+  Location: https://hub.darcs.net/thielema/llvm-dsl/  Flag debug   Description: Automatically dump LLVM Bitcode files for debugging@@ -43,15 +44,17 @@  Library   Build-Depends:-    llvm-extra >=0.10 && <0.11,-    llvm-tf >=9.2 && <9.3,+    llvm-extra >=0.11 && <0.12,+    llvm-tf >=9.2 && <13.0,     tfp >=1.0 && <1.1,     numeric-prelude >=0.4.3 && <0.5,     storable-record >=0.0.5 && <0.1,     storable-enum >=0.0 && <0.1,     bool8 >=0.0 && <0.1,-    transformers >=0.1.1 && <0.6,+    vault >=0.3 && <0.4,+    transformers >=0.1.1 && <0.7,     utility-ht >=0.0.15 && <0.1,+    unsafe >=0.0 && <0.1,     prelude-compat >=0.0 && <0.0.1,     base >=3 && <5 @@ -64,6 +67,9 @@     Hs-source-dirs: src/debug-off   Exposed-Modules:     LLVM.DSL.Expression+    LLVM.DSL.Expression.Vector+    LLVM.DSL.Expression.Maybe+    LLVM.DSL.Value     LLVM.DSL.Parameter     LLVM.DSL.Execution     LLVM.DSL.Debug.Counter
src/LLVM/DSL/Execution.hs view
@@ -3,6 +3,8 @@  import qualified LLVM.DSL.Dump as Dump +import qualified LLVM.Extra.Function as LLVMFunction+ import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Util.Optimize as Opt import qualified LLVM.Core as LLVM@@ -44,13 +46,13 @@ type Importer f = FunPtr f -> f  createLLVMFunction ::-   (LLVM.FunctionArgs f) =>-   String -> LLVM.FunctionCodeGen f -> LLVM.CodeGenModule (LLVM.Function f)-createLLVMFunction = LLVM.createNamedFunction LLVM.ExternalLinkage+   (LLVMFunction.C f) =>+   String -> LLVMFunction.CodeGen f -> LLVM.CodeGenModule (LLVM.Function f)+createLLVMFunction = LLVMFunction.createNamed LLVM.ExternalLinkage  createFunction ::-   (EE.ExecutionFunction f, LLVM.FunctionArgs f) =>-   Importer f -> String -> LLVM.FunctionCodeGen f -> Exec f+   (EE.ExecutionFunction f, LLVMFunction.C f) =>+   Importer f -> String -> LLVMFunction.CodeGen f -> Exec f createFunction importer name f =    Compose $ EE.getExecutionFunction importer <$> createLLVMFunction name f @@ -58,8 +60,8 @@ type Finalizer a = (EE.ExecutionEngine, LLVM.Ptr a -> IO ())  createFinalizer ::-   (EE.ExecutionFunction f, LLVM.FunctionArgs f) =>-   Importer f -> String -> LLVM.FunctionCodeGen f ->+   (EE.ExecutionFunction f, LLVMFunction.C f) =>+   Importer f -> String -> LLVMFunction.CodeGen f ->    Exec (EE.ExecutionEngine, f) createFinalizer importer name f =    liftA2 (,)
src/LLVM/DSL/Expression.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} module LLVM.DSL.Expression where  import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Tuple as LLTuple import qualified LLVM.Extra.FastMath as FastMath+import qualified LLVM.Extra.Scalar as Scalar import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Control as C import qualified LLVM.Core as LLVM@@ -32,6 +33,8 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive +import qualified Number.Complex as Complex+ import System.IO.Unsafe (unsafePerformIO)  import qualified Prelude as P@@ -102,65 +105,86 @@   liftM ::+   (Aggregate ae am) =>    (forall r.-    MultiValue.T a ->-    LLVM.CodeGenFunction r (MultiValue.T b)) ->-   (Exp a -> Exp b)-liftM f (Exp a) = unique (f =<< a)+    am -> LLVM.CodeGenFunction r (MultiValue.T b)) ->+   (ae -> Exp b)+liftM f a = unique (f =<< bundle a)  liftM2 ::+   (Aggregate ae am) =>+   (Aggregate be bm) =>    (forall r.-    MultiValue.T a -> MultiValue.T b ->-    LLVM.CodeGenFunction r (MultiValue.T c)) ->-   (Exp a -> Exp b -> Exp c)-liftM2 f (Exp a) (Exp b) = unique (Monad.liftJoin2 f a b)+    am -> bm -> LLVM.CodeGenFunction r (MultiValue.T c)) ->+   (ae -> be -> Exp c)+liftM2 f a b = unique (Monad.liftJoin2 f (bundle a) (bundle b))  liftM3 ::+   (Aggregate ae am) =>+   (Aggregate be bm) =>+   (Aggregate ce cm) =>    (forall r.-    MultiValue.T a -> MultiValue.T b -> MultiValue.T c ->-    LLVM.CodeGenFunction r (MultiValue.T d)) ->-   (Exp a -> Exp b -> Exp c -> Exp d)-liftM3 f (Exp a) (Exp b) (Exp c) = unique (Monad.liftJoin3 f a b c)+    am -> bm -> cm -> LLVM.CodeGenFunction r (MultiValue.T d)) ->+   (ae -> be -> ce -> Exp d)+liftM3 f a b c = unique (Monad.liftJoin3 f (bundle a) (bundle b) (bundle c))   unliftM1 ::-   (Exp a -> Exp b) ->-   MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T b)-unliftM1 f ix = unExp (f (lift0 ix))+   (Aggregate ae am) =>+   (Aggregate be bm) =>+   (ae -> be) ->+   am -> LLVM.CodeGenFunction r bm+unliftM1 f ix = bundle (f (dissect ix))  unliftM2 ::-   (Exp a -> Exp b -> Exp c) ->-   MultiValue.T a -> MultiValue.T b ->-   LLVM.CodeGenFunction r (MultiValue.T c)-unliftM2 f ix jx = unExp (f (lift0 ix) (lift0 jx))+   (Aggregate ae am) =>+   (Aggregate be bm) =>+   (Aggregate ce cm) =>+   (ae -> be -> ce) ->+   am -> bm -> LLVM.CodeGenFunction r cm+unliftM2 f ix jx = bundle (f (dissect ix) (dissect jx))  unliftM3 ::-   (Exp a -> Exp b -> Exp c -> Exp d) ->-   MultiValue.T a -> MultiValue.T b -> MultiValue.T c ->-   LLVM.CodeGenFunction r (MultiValue.T d)-unliftM3 f ix jx kx = unExp (f (lift0 ix) (lift0 jx) (lift0 kx))+   (Aggregate ae am) =>+   (Aggregate be bm) =>+   (Aggregate ce cm) =>+   (Aggregate de dm) =>+   (ae -> be -> ce -> de) ->+   am -> bm -> cm -> LLVM.CodeGenFunction r dm+unliftM3 f ix jx kx = bundle (f (dissect ix) (dissect jx) (dissect kx)) +unliftM4 ::+   (Aggregate ae am) =>+   (Aggregate be bm) =>+   (Aggregate ce cm) =>+   (Aggregate de dm) =>+   (Aggregate ee em) =>+   (ae -> be -> ce -> de -> ee) ->+   am -> bm -> cm -> dm -> LLVM.CodeGenFunction r em+unliftM4 f ix jx kx lx =+   bundle (f (dissect ix) (dissect jx) (dissect kx) (dissect lx)) -liftTupleM ::++liftReprM ::    (forall r.-    LLTuple.ValueOf a ->-    LLVM.CodeGenFunction r (LLTuple.ValueOf b)) ->+    MultiValue.Repr a ->+    LLVM.CodeGenFunction r (MultiValue.Repr b)) ->    (Exp a -> Exp b)-liftTupleM f = liftM (MultiValue.liftM f)+liftReprM f = liftM (MultiValue.liftM f) -liftTupleM2 ::+liftReprM2 ::    (forall r.-    LLTuple.ValueOf a -> LLTuple.ValueOf b ->-    LLVM.CodeGenFunction r (LLTuple.ValueOf c)) ->+    MultiValue.Repr a -> MultiValue.Repr b ->+    LLVM.CodeGenFunction r (MultiValue.Repr c)) ->    (Exp a -> Exp b -> Exp c)-liftTupleM2 f = liftM2 (MultiValue.liftM2 f)+liftReprM2 f = liftM2 (MultiValue.liftM2 f) -liftTupleM3 ::+liftReprM3 ::    (forall r.-    LLTuple.ValueOf a -> LLTuple.ValueOf b -> LLTuple.ValueOf c ->-    LLVM.CodeGenFunction r (LLTuple.ValueOf d)) ->+    MultiValue.Repr a -> MultiValue.Repr b -> MultiValue.Repr c ->+    LLVM.CodeGenFunction r (MultiValue.Repr d)) ->    (Exp a -> Exp b -> Exp c -> Exp d)-liftTupleM3 f = liftM3 (MultiValue.liftM3 f)+liftReprM3 f = liftM3 (MultiValue.liftM3 f)   @@ -415,7 +439,79 @@ deconsComplex c = (lift1 MultiValue.realPart c, lift1 MultiValue.imagPart c)  +class (MultiValuesOf exp ~ mv, ExpressionsOf mv ~ exp) => Aggregate exp mv where+   type MultiValuesOf exp+   type ExpressionsOf mv+   bundle :: exp -> LLVM.CodeGenFunction r mv+   dissect :: mv -> exp +instance Aggregate (Exp a) (MultiValue.T a) where+   type MultiValuesOf (Exp a) = MultiValue.T a+   type ExpressionsOf (MultiValue.T a) = Exp a+   bundle (Exp x) = x+   dissect x = Exp (return x)++instance (Aggregate ae al, Aggregate be bl) => Aggregate (ae,be) (al,bl) where+   type MultiValuesOf (ae,be) = (MultiValuesOf ae, MultiValuesOf be)+   type ExpressionsOf (al,bl) = (ExpressionsOf al, ExpressionsOf bl)+   bundle (a,b) = Monad.lift2 (,) (bundle a) (bundle b)+   dissect (a,b) = (dissect a, dissect b)++instance+   (Aggregate ae al, Aggregate be bl, Aggregate ce cl) =>+      Aggregate (ae,be,ce) (al,bl,cl) where+   type MultiValuesOf (ae,be,ce) =+            (MultiValuesOf ae, MultiValuesOf be, MultiValuesOf ce)+   type ExpressionsOf (al,bl,cl) =+            (ExpressionsOf al, ExpressionsOf bl, ExpressionsOf cl)+   bundle (a,b,c) = Monad.lift3 (,,) (bundle a) (bundle b) (bundle c)+   dissect (a,b,c) = (dissect a, dissect b, dissect c)++instance+   (Aggregate ae al, Aggregate be bl, Aggregate ce cl, Aggregate de dl) =>+      Aggregate (ae,be,ce,de) (al,bl,cl,dl) where+   type MultiValuesOf (ae,be,ce,de) =+            (MultiValuesOf ae, MultiValuesOf be,+             MultiValuesOf ce, MultiValuesOf de)+   type ExpressionsOf (al,bl,cl,dl) =+            (ExpressionsOf al, ExpressionsOf bl,+             ExpressionsOf cl, ExpressionsOf dl)+   bundle (a,b,c,d) =+      Monad.lift4 (,,,) (bundle a) (bundle b) (bundle c) (bundle d)+   dissect (a,b,c,d) = (dissect a, dissect b, dissect c, dissect d)++instance (Aggregate ae al) => Aggregate (Complex.T ae) (Complex.T al) where+   type MultiValuesOf (Complex.T ae) = Complex.T (MultiValuesOf ae)+   type ExpressionsOf (Complex.T al) = Complex.T (ExpressionsOf al)+   dissect = fmap dissect+   bundle c =+      Monad.lift2 (Complex.+:)+         (bundle $ Complex.real c) (bundle $ Complex.imag c)+++-- ToDo: move to numericprelude?+newtype Scalar a = Scalar a++instance (Aggregate exp mv) => Aggregate (Scalar exp) (Scalar.T mv) where+   type MultiValuesOf (Scalar exp) = Scalar.T (MultiValuesOf exp)+   type ExpressionsOf (Scalar.T mv)  = Scalar (ExpressionsOf mv)+   bundle (Scalar x) = Scalar.Cons <$> bundle x+   dissect (Scalar.Cons x) = Scalar $ dissect x++instance (Additive.C a) => Additive.C (Scalar a) where+   zero = Scalar Additive.zero+   Scalar a + Scalar b = Scalar (a Additive.+ b)+   Scalar a - Scalar b = Scalar (a Additive.- b)+   negate (Scalar a) = Scalar $ Additive.negate a++instance (Ring.C a) => Ring.C (Scalar a) where+   Scalar a * Scalar b = Scalar (a Ring.* b)+   fromInteger = Scalar . Ring.fromInteger++instance (Ring.C a, a~b) => Module.C (Scalar a) (Scalar b) where+   Scalar a *> Scalar b = Scalar (a Ring.* b)++ cons :: (MultiValue.C a) => a -> Exp a cons = lift0 . MultiValue.cons @@ -488,12 +584,12 @@   toEnum ::-   (LLTuple.ValueOf w ~ LLVM.Value w) =>+   (MultiValue.Repr w ~ LLVM.Value w) =>    Exp w -> Exp (Enum.T w e) toEnum = lift1 MultiValue.toEnum  fromEnum ::-   (LLTuple.ValueOf w ~ LLVM.Value w) =>+   (MultiValue.Repr w ~ LLVM.Value w) =>    Exp (Enum.T w e) -> Exp w fromEnum = lift1 MultiValue.fromEnum @@ -703,3 +799,34 @@       Absolute.C (Exp a) where    abs = liftM MultiValue.abs    signum = liftM MultiValue.signum+++fromIntegral ::+   (MultiValue.NativeInteger i ir, MultiValue.NativeFloating a ar) =>+   Exp i -> Exp a+fromIntegral = liftM MultiValue.fromIntegral++truncateToInt ::+   (MultiValue.NativeInteger i ir, MultiValue.NativeFloating a ar) =>+   Exp a -> Exp i+truncateToInt = liftM MultiValue.truncateToInt++floorToInt ::+   (MultiValue.NativeInteger i ir, MultiValue.NativeFloating a ar) =>+   Exp a -> Exp i+floorToInt = liftM MultiValue.floorToInt++ceilingToInt ::+   (MultiValue.NativeInteger i ir, MultiValue.NativeFloating a ar) =>+   Exp a -> Exp i+ceilingToInt = liftM MultiValue.ceilingToInt++roundToIntFast ::+   (MultiValue.NativeInteger i ir, MultiValue.NativeFloating a ar) =>+   Exp a -> Exp i+roundToIntFast = liftM MultiValue.roundToIntFast++splitFractionToInt ::+   (MultiValue.NativeInteger i ir, MultiValue.NativeFloating a ar) =>+   Exp a -> (Exp i, Exp a)+splitFractionToInt = unzip . liftM MultiValue.splitFractionToInt
+ src/LLVM/DSL/Expression/Maybe.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module LLVM.DSL.Expression.Maybe (+   T(Cons),+   select,+   ) where++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Maybe as Maybe++import qualified LLVM.Core as LLVM++import qualified Control.Monad.HT as Monad+++data T a = Cons (Exp Bool) a+++{- |+counterpart to 'Data.Maybe.fromMaybe' with swapped arguments+-}+select :: (MultiValue.Select a) => T (Exp a) -> Exp a -> Exp a+select (Cons b a) d = Expr.select b a d+++instance (Expr.Aggregate exp mv) => Expr.Aggregate (T exp) (Maybe.T mv) where+   type MultiValuesOf (T exp) = Maybe.T (Expr.MultiValuesOf exp)+   type ExpressionsOf (Maybe.T mv) = T (Expr.ExpressionsOf mv)+   bundle (Cons b a) =+      Monad.lift2 Maybe.Cons (fmap unbool $ Expr.bundle b) (Expr.bundle a)+   dissect (Maybe.Cons b a) =+      Cons (Expr.dissect (MultiValue.Cons b)) (Expr.dissect a)++unbool :: MultiValue.T Bool -> LLVM.Value Bool+unbool (MultiValue.Cons b) = b
+ src/LLVM/DSL/Expression/Vector.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.DSL.Expression.Vector where++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Multi.Vector.Instance as MultiVectorInst+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Core as LLVM++import qualified Data.Tuple.HT as Tuple++import Prelude hiding (replicate, take, zip, fst, snd, min, max)+++cons ::+   (LLVM.Positive n, MultiVector.C a) =>+   LLVM.Vector n a -> Exp (LLVM.Vector n a)+cons = Expr.lift0 . MultiValueVec.cons++fst ::+   (LLVM.Positive n, MultiVector.C a, MultiVector.C b) =>+   Exp (LLVM.Vector n (a,b)) -> Exp (LLVM.Vector n a)+fst = Expr.lift1 MultiValueVec.fst++snd ::+   (LLVM.Positive n, MultiVector.C a, MultiVector.C b) =>+   Exp (LLVM.Vector n (a,b)) -> Exp (LLVM.Vector n b)+snd = Expr.lift1 MultiValueVec.snd++swap ::+   (LLVM.Positive n, MultiVector.C a, MultiVector.C b) =>+   Exp (LLVM.Vector n (a,b)) -> Exp (LLVM.Vector n (b,a))+swap = Expr.lift1 MultiValueVec.swap++mapFst ::+   (Exp (LLVM.Vector n a0) -> Exp (LLVM.Vector n a1)) ->+   Exp (LLVM.Vector n (a0,b)) -> Exp (LLVM.Vector n (a1,b))+mapFst f =+   Expr.liftReprM+      (\(a0,b) -> do+         MultiValue.Cons a1 <- Expr.unliftM1 f $ MultiValue.Cons a0+         return (a1,b))++mapSnd ::+   (Exp (LLVM.Vector n b0) -> Exp (LLVM.Vector n b1)) ->+   Exp (LLVM.Vector n (a,b0)) -> Exp (LLVM.Vector n (a,b1))+mapSnd f =+   Expr.liftReprM+      (\(a,b0) -> do+         MultiValue.Cons b1 <- Expr.unliftM1 f $ MultiValue.Cons b0+         return (a,b1))+++fst3 ::+   (LLVM.Positive n, MultiVector.C a, MultiVector.C b, MultiVector.C c) =>+   Exp (LLVM.Vector n (a,b,c)) -> Exp (LLVM.Vector n a)+fst3 = Expr.lift1 MultiValueVec.fst3++snd3 ::+   (LLVM.Positive n, MultiVector.C a, MultiVector.C b, MultiVector.C c) =>+   Exp (LLVM.Vector n (a,b,c)) -> Exp (LLVM.Vector n b)+snd3 = Expr.lift1 MultiValueVec.snd3++thd3 ::+   (LLVM.Positive n, MultiVector.C a, MultiVector.C b, MultiVector.C c) =>+   Exp (LLVM.Vector n (a,b,c)) -> Exp (LLVM.Vector n c)+thd3 = Expr.lift1 MultiValueVec.thd3+++zip ::+   (LLVM.Positive n, MultiVector.C a, MultiVector.C b) =>+   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n b) ->+   Exp (LLVM.Vector n (a,b))+zip = Expr.lift2 MultiValueVec.zip++zip3 ::+   (LLVM.Positive n, MultiVector.C a, MultiVector.C b, MultiVector.C c) =>+   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n b) -> Exp (LLVM.Vector n c) ->+   Exp (LLVM.Vector n (a,b,c))+zip3 = Expr.lift3 MultiValueVec.zip3+++replicate ::+   (LLVM.Positive n, MultiVector.C a) =>+   Exp a -> Exp (LLVM.Vector n a)+replicate = Expr.liftM MultiValueVec.replicate++iterate ::+   (LLVM.Positive n, MultiVector.C a) =>+   (Exp a -> Exp a) -> Exp a -> Exp (LLVM.Vector n a)+iterate f = Expr.liftM (MultiValueVec.iterate (Expr.unliftM1 f))++take ::+   (LLVM.Positive n, LLVM.Positive m, MultiVector.Select a) =>+   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector m a)+take = Expr.liftM MultiValueVec.take++takeRev ::+   (LLVM.Positive n, LLVM.Positive m, MultiVector.Select a) =>+   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector m a)+takeRev = Expr.liftM MultiValueVec.takeRev+++cumulate ::+   (LLVM.Positive n, MultiVector.Additive a) =>+   Exp a -> Exp (LLVM.Vector n a) -> (Exp a, Exp (LLVM.Vector n a))+cumulate a0 v0 =+   Expr.unzip $+   Expr.liftM2+      (\a v ->+         fmap (uncurry MultiValue.zip .+               Tuple.mapSnd MultiVectorInst.toMultiValue) $+         MultiVector.cumulate a $ MultiVectorInst.fromMultiValue v)+      a0 v0+++cmp ::+   (LLVM.Positive n, MultiVector.Comparison a) =>+   LLVM.CmpPredicate ->+   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n Bool)+cmp ord = Expr.liftM2 (MultiValueVec.cmp ord)++select ::+   (LLVM.Positive n, MultiVector.Select a) =>+   Exp (LLVM.Vector n Bool) ->+   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n a)+select = Expr.liftM3 MultiValueVec.select+++min, max ::+   (LLVM.Positive n, MultiVector.Real a) =>+   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n a)+min = Expr.liftM2 A.min+max = Expr.liftM2 A.max++limit ::+   (LLVM.Positive n, MultiVector.Real a) =>+   (Exp (LLVM.Vector n a), Exp (LLVM.Vector n a)) ->+   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n a)+limit (l,u) = max l . min u+++fromIntegral ::+   (MultiValueVec.NativeInteger i ir, MultiValueVec.NativeFloating a ar,+    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>+   Exp i -> Exp a+fromIntegral = Expr.liftM MultiValueVec.fromIntegral++truncateToInt ::+   (MultiValueVec.NativeInteger i ir, MultiValueVec.NativeFloating a ar,+    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>+   Exp a -> Exp i+truncateToInt = Expr.liftM MultiValueVec.truncateToInt++splitFractionToInt ::+   (MultiValueVec.NativeInteger i ir, MultiValueVec.NativeFloating a ar,+    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>+   Exp a -> (Exp i, Exp a)+splitFractionToInt = Expr.unzip . Expr.liftM MultiValueVec.splitFractionToInt
src/LLVM/DSL/Parameter.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-}@@ -25,6 +26,7 @@    wordInt,    ) where +import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Marshal as Marshal@@ -133,10 +135,10 @@  {-# INLINE withMulti #-} withMulti ::-   (Marshal.MV b) =>+   (MarshalMV.C b) =>    T p b ->    (forall parameters.-    (Marshal.MV parameters) =>+    (MarshalMV.C parameters) =>     (p -> parameters) ->     (MultiValue.T parameters -> MultiValue.T b) ->     a) ->@@ -145,11 +147,11 @@  {-# INLINE with #-} with ::-   (Marshal.MV b) =>+   (MarshalMV.C b) =>    (b -> MultiValue.T b) ->    T p b ->    (forall parameters.-    (Marshal.MV parameters) =>+    (MarshalMV.C parameters) =>     (p -> parameters) ->     (MultiValue.T parameters -> MultiValue.T b) ->     a) ->@@ -162,9 +164,9 @@  data Tunnel p a =    forall t.-   (Marshal.MV t) => Tunnel (p -> t) (MultiValue.T t -> MultiValue.T a)+   (MarshalMV.C t) => Tunnel (p -> t) (MultiValue.T t -> MultiValue.T a) -tunnel :: (Marshal.MV a) => (a -> MultiValue.T a) -> T p a -> Tunnel p a+tunnel :: (MarshalMV.C a) => (a -> MultiValue.T a) -> T p a -> Tunnel p a tunnel cons p =    case p of       Constant b -> Tunnel (const ()) (\_ -> cons b)@@ -183,8 +185,8 @@   class Tuple tuple where-   type Composed tuple :: *-   type Source tuple :: *+   type Composed tuple+   type Source tuple    decompose :: T (Source tuple) (Composed tuple) -> tuple  instance Tuple (T p a) where
+ src/LLVM/DSL/Value.hs view
@@ -0,0 +1,554 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+Wrap LLVM code for arithmetic computations.+Similar to "LLVM.DSL.Expression" but not based on 'MultiValue'+but on "LLVM.Extra.Arithmetic" methods.+Detects sharing using a 'Vault'.+-}+module LLVM.DSL.Value (+   T, decons,+   tau, square, sqrt,+   max, min, limit, fraction,++   (%==), (%/=), (%<), (%<=), (%>), (%>=), not,+   (%&&), (%||),+   (?), (??),++   lift0, lift1, lift2, lift3,+   unlift0, unlift1, unlift2, unlift3, unlift4, unlift5,+   constantValue, constant,+   fromInteger', fromRational',++   Flatten(flattenCode, unfoldCode), Registers,+   flatten, unfold,+   flattenCodeTraversable, unfoldCodeTraversable,+   flattenFunction,+   ) where++import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM++import qualified Data.Vault.Lazy as Vault+import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import Control.Monad (liftM2, liftM3)+import Control.Applicative (Applicative, pure, (<*>))+import Control.Functor.HT (unzip, unzip3)++-- import qualified Algebra.NormedSpace.Maximum   as NormedMax+import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.NormedSpace.Sum       as NormedSum++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.Absolute as Absolute+import qualified Algebra.Module as Module+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Number.Complex as Complex++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold++import qualified System.Unsafe as Unsafe++import qualified Prelude as P+import NumericPrelude.Numeric hiding (pi, sqrt, fromRational', fraction)+import NumericPrelude.Base hiding (min, max, unzip, unzip3, not)+++{-+The @r@ type parameter must be hidden and forall-quantified+because otherwise we would need an impossible type+where we have to quantify for @r@ and @t@ in different scopes+while having a class constraint that involves both of them.++> osci ::+>    (RealRing.C (Value.T r t),+>     IsFirstClass t, IsFloating t,+>     IsPrimitive t, IsConst t) =>+>    (forall r. Wave.T (Value.T r t) (Value.T r y)) ->+>    t -> t -> T (Value y)++-}+newtype T a = Cons {code :: forall r. Compute r a}++decons :: T a -> (forall r. LLVM.CodeGenFunction r a)+decons value =+   MS.evalStateT (code value) Vault.empty++instance Functor T where+   fmap f x = consUnique (fmap f (code x))++instance Applicative T where+   pure = constantValue+   f <*> x = consUnique (code f <*> code x)+++type Compute r a =+   MS.StateT Vault.Vault (LLVM.CodeGenFunction r) a++consUnique :: (forall r. Compute r a) -> T a+consUnique code0 =+   Unsafe.performIO $+   fmap (consKey code0) Vault.newKey++consKey :: (forall r. Compute r a) -> Vault.Key a -> T a+consKey code0 key =+   Cons (do+      ma <- MS.gets (Vault.lookup key)+      case ma of+         Just a -> return a+         Nothing -> do+            a <- code0+            MS.modify (Vault.insert key a)+            return a)++{- |+We do not require a numeric prelude superclass,+thus also LLVM only types like vectors are instances.+-}+instance (A.Additive a) => Additive.C (T a) where+   zero = constantValue A.zero+   (+) = lift2 A.add+   (-) = lift2 A.sub+   negate = lift1 A.neg++instance (A.PseudoRing a, A.IntegerConstant a) => Ring.C (T a) where+   one = constantValue A.one+   (*) = lift2 A.mul+   fromInteger = fromInteger'++{-+This instance is enough for Module here.+The difference to Module instances on Haskell tuples is,+that LLVM vectors cannot be nested.+-}+instance (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>+      Module.C (T a) (T v) where+   (*>) = lift2 A.scale++instance (A.Additive a, A.IntegerConstant a) => Enum (T a) where+   succ x = x + constantValue A.one+   pred x = x - constantValue A.one+   fromEnum _ = error "CodeGenFunction Value: fromEnum"+   toEnum = constantValue . A.fromInteger' . fromIntegral++{-+instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (T a) where+   toRational _ = error "CodeGenFunction Value: toRational"++instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (T a) where+   quot = lift2 idiv+   rem  = lift2 irem+   quotRem x y = (quot x y, rem x y)+   toInteger _ = error "CodeGenFunction Value: toInteger"+-}++instance (A.Field a, A.RationalConstant a) => Field.C (T a) where+   (/) = lift2 A.fdiv+   fromRational' = fromRational' . Field.fromRational'++{-+instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (T a) where+   properFraction _ = error "CodeGenFunction Value: properFraction"+-}++instance (A.Transcendental a, A.RationalConstant a) => Algebraic.C (T a) where+   sqrt = lift1 A.sqrt+   root n x = lift2 A.pow x (one / fromInteger n)+   x^/r = lift2 A.pow x (Field.fromRational' r)++instance (A.Transcendental a, A.RationalConstant a) => Trans.C (T a) where+   pi = lift0 A.pi+   sin = lift1 A.sin+   cos = lift1 A.cos+   (**) = lift2 A.pow+   exp = lift1 A.exp+   log = lift1 A.log++   asin _ = error "LLVM missing intrinsic: asin"+   acos _ = error "LLVM missing intrinsic: acos"+   atan _ = error "LLVM missing intrinsic: atan"+++instance+   (A.PseudoRing a, A.Real a, A.IntegerConstant a) =>+      P.Num (T a) where+   fromInteger = fromInteger'+   (+) = lift2 A.add+   (-) = lift2 A.sub+   (*) = lift2 A.mul+   negate = lift1 A.neg+   abs = lift1 A.abs+   signum = lift1 A.signum++instance+   (A.Field a, A.Real a, A.RationalConstant a) =>+      P.Fractional (T a) where+   fromRational = fromRational'+   (/) = lift2 A.fdiv++instance+   (A.Transcendental a, A.Real a, A.RationalConstant a) =>+      P.Floating (T a) where+   pi = lift0 A.pi+   sin = lift1 A.sin+   cos = lift1 A.cos+   (**) = lift2 A.pow+   exp = lift1 A.exp+   log = lift1 A.log++   asin _ = error "LLVM missing intrinsic: asin"+   acos _ = error "LLVM missing intrinsic: acos"+   atan _ = error "LLVM missing intrinsic: atan"++   sinh x  = (exp x - exp (-x)) / 2+   cosh x  = (exp x + exp (-x)) / 2+   asinh x = log (x + sqrt (x*x + 1))+   acosh x = log (x + sqrt (x*x - 1))+   atanh x = (log (1 + x) - log (1 - x)) / 2+++tau ::+   (A.Transcendental a, A.RationalConstant a) =>+   T a+tau = fromInteger 2 * Trans.pi++square :: (A.PseudoRing a) => T a -> T a+square = lift1 A.square++{- |+The same as 'Algebraic.sqrt',+but needs only Algebraic constraint, not Transcendental.+-}+sqrt ::+   (A.Algebraic a) =>+   T a -> T a+sqrt = lift1 A.sqrt+++min, max :: (A.Real a) => T a -> T a -> T a+min = lift2 A.min+max = lift2 A.max++limit :: (A.Real a) => (T a, T a) -> T a -> T a+limit (l,u) = max l . min u++fraction :: (A.Fraction a) => T a -> T a+fraction = lift1 A.fraction+++instance (A.Real a, A.PseudoRing a, A.IntegerConstant a) =>+      Absolute.C (T a) where+   abs = lift1 A.abs+   signum = lift1 A.signum++{-+For useful instances with different scalar and vector type,+we would need a more flexible superclass.+-}+instance (A.Real a, A.IntegerConstant a, a ~ A.Scalar a, A.PseudoModule a) =>+      NormedSum.C (T a) (T a) where+   norm = lift1 A.abs++instance (A.Real a, A.IntegerConstant a, a ~ A.Scalar a, A.PseudoModule a) =>+      NormedEuc.Sqr (T a) (T a) where+   normSqr = lift1 A.square++instance+   (NormedEuc.Sqr (T a) (T v),+    A.RationalConstant a, A.Algebraic a) =>+      NormedEuc.C (T a) (T v) where+   norm = lift1 A.sqrt . NormedEuc.normSqr++{-+instance (A.Real a, A.IntegerConstant a, A.PseudoModule a a) =>+      NormedMax.C (T a) (T a) where+   norm = lift1 A.abs+-}+++infix  4  %==, %/=, %<, %<=, %>=, %>++(%==), (%/=), (%<), (%<=), (%>), (%>=) ::+   (LLVM.CmpRet a) =>+   T (LLVM.Value a) -> T (LLVM.Value a) -> T (LLVM.Value (LLVM.CmpResult a))+(%==) = lift2 $ LLVM.cmp LLVM.CmpEQ+(%/=) = lift2 $ LLVM.cmp LLVM.CmpNE+(%>)  = lift2 $ LLVM.cmp LLVM.CmpGT+(%>=) = lift2 $ LLVM.cmp LLVM.CmpGE+(%<)  = lift2 $ LLVM.cmp LLVM.CmpLT+(%<=) = lift2 $ LLVM.cmp LLVM.CmpLE++infixr 3  %&&+infixr 2  %||++-- | Lazy AND+(%&&) :: T (LLVM.Value Bool) -> T (LLVM.Value Bool) -> T (LLVM.Value Bool)+a %&& b = a ? (b, constant False)++-- | Lazy OR+(%||) :: T (LLVM.Value Bool) -> T (LLVM.Value Bool) -> T (LLVM.Value Bool)+a %|| b = a ? (constant True, b)++not :: T (LLVM.Value Bool) -> T (LLVM.Value Bool)+not = lift1 LLVM.inv+++infix  0 ?+{- |+@true ? (t,f)@ evaluates @t@,+@false ? (t,f)@ evaluates @f@.+@t@ and @f@ can reuse interim results,+but they cannot contribute shared results,+since only one of them will be run.+Cf. '(??)'+-}+(?) ::+   (Flatten value, Registers value ~ a, Tuple.Phi a) =>+   T (LLVM.Value Bool) -> (value, value) -> value+c ? (t, f) =+   unfoldCode $ consUnique $ do+      b <- code c+      shared <- MS.get+      MT.lift $+         C.ifThenElse b+            (MS.evalStateT (flattenCode t) shared)+            (MS.evalStateT (flattenCode f) shared)++infix 0 ??+{- |+The expression @c ?? (t,f)@ evaluates both @t@ and @f@+and selects components from @t@ and @f@ according to @c@.+It is useful for vector values and+for sharing @t@ or @f@ with other branches of an expression.+-}+(??) ::+   (LLVM.IsFirstClass a, LLVM.CmpRet a) =>+   T (LLVM.Value (LLVM.CmpResult a)) ->+   (T (LLVM.Value a), T (LLVM.Value a)) ->+   T (LLVM.Value a)+c ?? (t, f) = lift3 LLVM.select c t f++++lift0 ::+   (forall r. LLVM.CodeGenFunction r a) ->+   T a+lift0 f =+   consUnique $ MT.lift $ f++lift1 ::+   (forall r. a -> LLVM.CodeGenFunction r b) ->+   T a -> T b+lift1 f x =+   consUnique $ MT.lift . f =<< code x++lift2 ::+   (forall r. a -> b -> LLVM.CodeGenFunction r c) ->+   T a -> T b -> T c+lift2 f x y =+   consUnique $ do+      xv <- code x+      yv <- code y+      MT.lift $ f xv yv++lift3 ::+   (forall r. a -> b -> c -> LLVM.CodeGenFunction r d) ->+   T a -> T b -> T c -> T d+lift3 f x y z =+   consUnique $ do+      xv <- code x+      yv <- code y+      zv <- code z+      MT.lift $ f xv yv zv+++_unlift0 ::+   T a ->+   (forall r. LLVM.CodeGenFunction r a)+_unlift0 = decons++unlift0 ::+   (Flatten value) =>+   value ->+   (forall r. LLVM.CodeGenFunction r (Registers value))+unlift0 x = flatten x++_unlift1 ::+   (T a -> T b) ->+   (forall r. a -> LLVM.CodeGenFunction r b)+_unlift1 = unlift1++{-+Better type inference than flattenFunction.+-}+unlift1 ::+   (Flatten value) =>+   (T a -> value) ->+   (forall r. a -> LLVM.CodeGenFunction r (Registers value))+unlift1 f a =+   flatten (f (constantValue a))++_unlift2 ::+   (T a -> T b -> T c) ->+   (forall r. a -> b -> LLVM.CodeGenFunction r c)+_unlift2 = unlift2++unlift2 ::+   (Flatten value) =>+   (T a -> T b -> value) ->+   (forall r. a -> b -> LLVM.CodeGenFunction r (Registers value))+unlift2 f a b =+   flatten (f (constantValue a) (constantValue b))++unlift3 ::+   (Flatten value) =>+   (T a -> T b -> T c -> value) ->+   (forall r. a -> b -> c -> LLVM.CodeGenFunction r (Registers value))+unlift3 f a b c =+   flatten (f (constantValue a) (constantValue b) (constantValue c))++unlift4 ::+   (Flatten value) =>+   (T a -> T b -> T c -> T d -> value) ->+   (forall r. a -> b -> c -> d -> LLVM.CodeGenFunction r (Registers value))+unlift4 f a b c d =+   flatten $+   f (constantValue a) (constantValue b) (constantValue c) (constantValue d)++unlift5 ::+   (Flatten value) =>+   (T a -> T b -> T c -> T d -> T e -> value) ->+   (forall r. a -> b -> c -> d -> e -> LLVM.CodeGenFunction r (Registers value))+unlift5 f a b c d e =+   flatten $+   f (constantValue a) (constantValue b) (constantValue c)+      (constantValue d) (constantValue e)+++constantValue :: a -> T a+constantValue x =+   consUnique (return x)++constant :: (LLVM.IsConst a) => a -> T (LLVM.Value a)+constant = constantValue . LLVM.valueOf++fromInteger' :: (A.IntegerConstant a) => Integer -> T a+fromInteger' = constantValue . A.fromInteger'++fromRational' :: (A.RationalConstant a) => P.Rational -> T a+fromRational' = constantValue . A.fromRational'+++class Flatten value where+   type Registers value+   flattenCode :: value -> Compute r (Registers value)+   unfoldCode :: T (Registers value) -> value++flatten ::+   (Flatten value) =>+   value -> LLVM.CodeGenFunction r (Registers value)+flatten x = MS.evalStateT (flattenCode x) Vault.empty++unfold ::+   (Flatten value) =>+   (Registers value) -> value+unfold x = unfoldCode $ pure x++flattenCodeTraversable ::+   (Flatten value, Trav.Traversable f) =>+   f value -> Compute r (f (Registers value))+flattenCodeTraversable =+   Trav.mapM flattenCode++unfoldCodeTraversable ::+   (Flatten value, Trav.Traversable f, Applicative f) =>+   T (f (Registers value)) -> f value+unfoldCodeTraversable =+   unfoldFromGetters getters++unfoldFromGetters ::+   (Functor f, Flatten b) =>+   f (a -> Registers b) -> T a -> f b+unfoldFromGetters g x =+   fmap (unfoldCode . flip fmap x) g++getters ::+   (Trav.Traversable f, Applicative f) =>+   f (f a -> a)+getters =+   fmap (\n x -> Fold.toList x !! n) $+   MS.evalState (Trav.sequenceA (pure (MS.state $ \n -> (n, succ n)))) 0+++flattenFunction ::+   (Flatten a, Flatten b) =>+   (a -> b) -> (Registers a -> LLVM.CodeGenFunction r (Registers b))+flattenFunction f =+   flatten . f . unfold++{-+This function is hardly useful,+since most functions are not of type+@(Registers a -> (forall r. CodeGenFunction r (Registers b)))@+but of type+@(forall r. Registers a -> CodeGenFunction r (Registers b))@.+We would also need a method unfoldF.+See ValueUnfoldF for some implementations.++unfoldFunction ::+   (Flatten a, Flatten b) =>+   (Registers a -> (forall r. LLVM.CodeGenFunction r (Registers b))) -> (a -> b)+unfoldFunction f x =+   unfoldF (f =<< flatten x)+-}+++instance (Flatten a, Flatten b) => Flatten (a,b) where+   type Registers (a,b) = (Registers a, Registers b)+   flattenCode (a,b) =+      liftM2 (,) (flattenCode a) (flattenCode b)+   unfoldCode x =+      case unzip x of+         (a,b) -> (unfoldCode a, unfoldCode b)++instance (Flatten a, Flatten b, Flatten c) => Flatten (a,b,c) where+   type Registers (a,b,c) = (Registers a, Registers b, Registers c)+   flattenCode (a,b,c) =+      liftM3 (,,) (flattenCode a) (flattenCode b) (flattenCode c)+   unfoldCode x =+      case unzip3 x of+         (a,b,c) -> (unfoldCode a, unfoldCode b, unfoldCode c)++instance Flatten a => Flatten (Complex.T a) where+   type Registers (Complex.T a) = Complex.T (Registers a)+--   flattenCode = flattenCodeTraversable+   flattenCode s =+      liftM2 (Complex.+:)+         (flattenCode $ Complex.real s)+         (flattenCode $ Complex.imag s)+   unfoldCode =+      unfoldFromGetters $ Complex.real Complex.+: Complex.imag+++instance Flatten (T a) where+   type Registers (T a) = a+   flattenCode x = code x+   unfoldCode = id++instance Flatten () where+   type Registers () = ()+   flattenCode = return+   unfoldCode _ = ()