packages feed

llvm-dsl (empty) → 0.1.2

raw patch · 20 files changed

Files

+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2020, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The names of contributors may not be used to endorse or promote+      products derived from this software without specific prior+      written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Makefile view
@@ -0,0 +1,5 @@+run-test:+	runhaskell Setup.lhs configure --user -f-debug+	runhaskell Setup.lhs build+	runhaskell Setup.lhs configure --user -fdebug+	runhaskell Setup.lhs build
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ llvm-dsl.cabal view
@@ -0,0 +1,100 @@+Cabal-Version:  2.2+Name:           llvm-dsl+Version:        0.1.2+License:        BSD-3-Clause+License-File:   LICENSE+Author:         Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:     Henning Thielemann <haskell@henning-thielemann.de>+Homepage:       https://wiki.haskell.org/LLVM+Category:       Compilers/Interpreters, Code Generation+Synopsis:       Support for writing an EDSL with LLVM-JIT as target+Description:+  Support for writing an EDSL with LLVM-JIT as target.+  .+  * "LLVM.DSL.Expression":+    Code snippets that represent arithmetics+    and support arithmetic operators.+  .+  * "LLVM.DSL.Parameter":+    Parameterize LLVM-generated code.+  .+  * "LLVM.DSL.Execution":+    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.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: https://hub.darcs.net/thielema/llvm-dsl/++Source-Repository this+  Tag:      0.1.2+  Type:     darcs+  Location: https://hub.darcs.net/thielema/llvm-dsl/++Flag debug+  Description: Automatically dump LLVM Bitcode files for debugging+  Default: False+  Manual: True++Library+  Build-Depends:+    llvm-extra >=0.11 && <0.13,+    llvm-tf >=9.0 && <17.1,+    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,+    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++  Default-Language: Haskell98+  GHC-Options: -Wall+  Hs-source-dirs: src+  If flag(debug)+    Hs-source-dirs: src/debug-on+  Else+    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.Render.Run+    LLVM.DSL.Render.Argument+    LLVM.DSL.Debug.Counter+    LLVM.DSL.Debug.StablePtr+    LLVM.DSL.Debug.Marshal+    LLVM.DSL.Example.Median+  Other-Modules:+    LLVM.DSL.Dump++Test-Suite llvm-dsl-test+  Type: exitcode-stdio-1.0+  Build-Depends:+    doctest-exitcode-stdio >=0.0 && <0.1,+    llvm-dsl,+    llvm-extra,+    llvm-tf,+    tfp,+    transformers,+    base >=3 && <5++  Default-Language: Haskell98+  GHC-Options: -Wall+  Hs-source-dirs: test+  Main-Is: Main.hs+  Other-Modules:+    Test.LLVM.DSL.Example.Median
+ src/LLVM/DSL/Debug/Counter.hs view
@@ -0,0 +1,24 @@+module LLVM.DSL.Debug.Counter where++import qualified Data.IORef as IORef+import qualified Data.List.HT as ListHT+++newtype T ident = Cons Int+   deriving (Eq, Ord)++instance Enum (T ident) where+   fromEnum (Cons n) = n+   toEnum n = (Cons n)++format :: Int -> T ident -> String+format pad (Cons n) = ListHT.padLeft '0' pad (show n)++new :: IO (IORef.IORef (T ident))+new = IORef.newIORef (Cons 0)++next :: IORef.IORef (T ident) -> IO (T ident)+next cnt = do+   a <- IORef.readIORef cnt+   IORef.modifyIORef cnt succ+   return a
+ src/LLVM/DSL/Debug/Marshal.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE Rank2Types #-}+module LLVM.DSL.Debug.Marshal where++import qualified LLVM.DSL.Debug.Counter as Counter++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Base.Proxy (Proxy)++import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM+import LLVM.Core (Array, ConstValue, constOf)++import qualified System.IO as IO+import Numeric (showHex)++import qualified Data.IORef as IORef+import qualified Data.List as List++import qualified Foreign.Storable as Store+import Foreign.Marshal.Array (advancePtr)+import Foreign.Storable (peek, peekByteOff)+import Foreign.Ptr (Ptr, castPtr)+import Data.Word (Word8, Word32)+import System.IO.Unsafe (unsafePerformIO)++import Control.Monad (when)+import Data.Maybe (fromMaybe)+++data Dump = Dump++dumpCounter :: IORef.IORef (Counter.T Dump)+dumpCounter = unsafePerformIO Counter.new++toBytePtr :: LLVM.Ptr a -> Ptr Word8+toBytePtr = castPtr . LLVM.uncheckedToPtr++format :: Marshal.C a => a -> IO String+format a =+   Marshal.with a $ \ptr ->+      fmap (concatMap (\byte ->+               (if byte<16 then ('0':) else id) (showHex byte ""))) $+      mapM peek+         (List.take (sizeOf a) $+          List.iterate (flip advancePtr 1) $+          toBytePtr ptr)++dump :: Marshal.C a => FilePath -> a -> Counter.T Dump -> IO ()+dump path a cnt =+   IO.withBinaryFile+      (path ++ Counter.format 3 cnt ++ ".dump")+      IO.WriteMode $ \h ->+   Marshal.with a $ \ptr ->+   IO.hPutBuf h (toBytePtr ptr) (sizeOf a)+++type ArrayElem = Word32++{-+Unfortunately, you cannot 'alloca' or 'malloc' the constructed array,+because an IsSized instance is missing.+We may employ a specialised reifyIntegral for this purpose.+-}+withConstArray ::+   Marshal.C a =>+   a ->+   (forall n. TypeNum.Natural n => ConstValue (Array n ArrayElem) -> b) ->+   IO b+withConstArray a f =+   Marshal.with a $ \ptr -> do+      content <-+         mapM+            (peekByteOff $ toBytePtr ptr)+            (takeWhile (< sizeOf a)+               [0, Store.sizeOf (undefined :: ArrayElem) ..])+          :: IO [ArrayElem]+      return $+         fromMaybe (error "Debug.Storable.withConstArray: length must always be non-negative") $+         TypeNum.reifyNatural (fromIntegral (length content))+            (\n ->+               let makeArray ::+                      TypeNum.Natural n =>+                      Proxy n -> [ConstValue ArrayElem] ->+                      ConstValue (Array n ArrayElem)+                   makeArray _ = LLVM.constArray+               in  f (makeArray n (map constOf content)))+++traceMalloc :: Marshal.C a => a -> Int -> Ptr a -> IO (Ptr a)+traceMalloc a size ptr = do+   when False $ putStrLn $+      showString "%addr" . shows ptr .+      showString " = call float* @malloc(i8* getelementptr (i8* null, i32 " .+      shows size .+      showString "))   ; alignment " . shows (alignment a) $+      ""+   return ptr++proxyFromData :: a -> LP.Proxy (Marshal.Struct a)+proxyFromData _ = LP.Proxy++sizeOf, alignment :: (Marshal.C a) => a -> Int+sizeOf = EE.sizeOf . proxyFromData++alignment = EE.alignment . proxyFromData
+ src/LLVM/DSL/Debug/StablePtr.hs view
@@ -0,0 +1,12 @@+module LLVM.DSL.Debug.StablePtr where++import Foreign.StablePtr (StablePtr, castStablePtrToPtr)+import Control.Monad (when)+++{-# INLINE trace #-}+trace :: String -> StablePtr a -> IO (StablePtr a)+trace name s = do+   when False $+      putStrLn $ "EventIterator." ++ name ++ ": " ++ (show $ castStablePtrToPtr $ s)+   return s
+ src/LLVM/DSL/Example/Median.hs view
@@ -0,0 +1,98 @@+module LLVM.DSL.Example.Median where++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp, (==*), (<=*), (&&*), (||*))++import qualified LLVM.Extra.Multi.Vector as MVec+import qualified LLVM.Extra.Multi.Value as MV++import qualified LLVM.Core as LLVM++import Data.Tuple.HT (uncurry3)+import Data.Word (Word8)++++median3IfThen :: (MV.Comparison a) => Exp a -> Exp a -> Exp a -> Exp a+median3IfThen a b c =+   Expr.ifThenElse (a<=*b)+      (Expr.ifThenElse (b<=*c)+         b+         (Expr.ifThenElse (a<=*c) c a))+      (Expr.ifThenElse (a<=*c)+         a+         (Expr.ifThenElse (b<=*c) c b))++median3Select ::+   (MV.Comparison a, MV.Select a) => Exp a -> Exp a -> Exp a -> Exp a+median3Select a b c =+   Expr.select (a<=*b)+      (Expr.select (b<=*c)+         b+         (Expr.select (a<=*c) c a))+      (Expr.select (a<=*c)+         a+         (Expr.select (b<=*c) c b))++median3SelectShared ::+   (MV.Comparison a, MV.Select a) => Exp a -> Exp a -> Exp a -> Exp a+median3SelectShared a b c =+   Expr.with (a<=*b) $ \a_le_b ->+   Expr.with (b<=*c) $ \b_le_c ->+   Expr.with (a<=*c) $ \a_le_c ->+   Expr.select a_le_b+      (Expr.select b_le_c b (Expr.select a_le_c c a))+      (Expr.select a_le_c a (Expr.select b_le_c c b))++median3MinMax ::+   (MV.Comparison a, MV.Select a) => Exp a -> Exp a -> Exp a -> Exp a+median3MinMax a b c =+   let minab = Expr.min a b in+   let maxab = Expr.max a b in+   Expr.select (maxab <=* c) maxab $ Expr.select (minab <=* c) c minab++median3MinMaxVector ::+   (LLVM.Positive n, MVec.C a) =>+   (MV.Comparison a, MV.Select a) =>+   MVec.T n a -> MVec.T n a -> MVec.T n a ->+   LLVM.CodeGenFunction r (MVec.T n a)+median3MinMaxVector a b c =+   MVec.map (uncurry3 (Expr.unliftM3 median3MinMax) . MV.unzip3) $+   MVec.zip3 a b c+++type MV = MV.T++median3Case ::+   (MV.Comparison a, MV.Select a) =>+   MV a -> MV a -> MV a -> LLVM.CodeGenFunction r (MV a)+median3Case a b c = do+   a_le_b <- MV.cmp LLVM.CmpLE a b+   a_le_c <- MV.cmp LLVM.CmpLE a c+   b_le_c <- MV.cmp LLVM.CmpLE b c+   let mask = MV.fromInteger'+   a_le_b_mask <- MV.select a_le_b (mask 1) (mask 0)+   a_le_c_mask <- MV.select a_le_c (mask 2) (mask 0)+   b_le_c_mask <- MV.select b_le_c (mask 4) (mask 0)+   maskMV <- MV.or a_le_b_mask =<< MV.or a_le_c_mask b_le_c_mask+   let maskE = Expr.lift0 (maskMV :: MV Word8)+   selectB <- Expr.unExp (maskE ==* 0 ||* maskE ==* 7)+   selectA <- Expr.unExp (maskE ==* 1 ||* maskE ==* 6)+   MV.select selectA a =<< MV.select selectB b c++median3CaseVec ::+   (MV.Comparison a, MV.Select a) =>+   MV a -> MV a -> MV a -> LLVM.CodeGenFunction r (MV a)+median3CaseVec a b c = do+   a_le_b <- MV.cmp LLVM.CmpLE a b+   a_le_c <- MV.cmp LLVM.CmpLE a c+   b_le_c <- MV.cmp LLVM.CmpLE b c+   let check ab ac bc =+         Expr.select (Expr.lift0 a_le_b) 1 0 ==* (ab :: Exp Word8)+         &&*+         Expr.select (Expr.lift0 a_le_c) 1 0 ==* (ac :: Exp Word8)+         &&*+         Expr.select (Expr.lift0 b_le_c) 1 0 ==* (bc :: Exp Word8)+   selectB <- Expr.unExp (check 0 0 0 ||* check 1 1 1)+   selectA <- Expr.unExp (check 1 0 0 ||* check 0 1 1)+   MV.select selectA a =<< MV.select selectB b c
+ src/LLVM/DSL/Execution.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.DSL.Execution where++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++import Foreign.Ptr (FunPtr)++import Control.Monad (void, liftM2, when)+import Control.Applicative (liftA2, pure, (<$>))++import Data.Functor.Compose (Compose(Compose))++import Prelude2010+import Prelude ()+++dumper :: String -> IO (String -> LLVM.Module -> IO ())+dumper = Dump.writer++compile :: String -> Exec funcs -> IO funcs+compile name (Compose bld) = do+   LLVM.initializeNativeTarget+   td <- EE.getTargetData+   m <- LLVM.newNamedModule name+   (funcs, mappings) <-+      LLVM.defineModule m $ do+         LLVM.setTarget LLVM.hostTriple+         LLVM.setDataLayout $ EE.dataLayoutStr td+         liftM2 (,) bld LLVM.getGlobalMappings+   writeBitcodeToFile <- dumper name+   writeBitcodeToFile "" m+   when True $ do+      void $ Opt.optimizeModule 3 m+      writeBitcodeToFile "-opt" m+   EE.runEngineAccessWithModule m $+      EE.addGlobalMappings mappings >> funcs+++type Exec = Compose LLVM.CodeGenModule EE.EngineAccess+type Importer f = FunPtr f -> f++createLLVMFunction ::+   (LLVMFunction.C f) =>+   String -> LLVMFunction.CodeGen f -> LLVM.CodeGenModule (LLVM.Function f)+createLLVMFunction = LLVMFunction.createNamed LLVM.ExternalLinkage++createFunction ::+   (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+++type Finalizer a = (EE.ExecutionEngine, LLVM.Ptr a -> IO ())++createFinalizer ::+   (EE.ExecutionFunction f, LLVMFunction.C f) =>+   Importer f -> String -> LLVMFunction.CodeGen f ->+   Exec (EE.ExecutionEngine, f)+createFinalizer importer name f =+   liftA2 (,)+      (Compose $ pure EE.getEngine)+      (createFunction importer name f)
+ src/LLVM/DSL/Expression.hs view
@@ -0,0 +1,839 @@+{-# 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.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+import LLVM.Extra.Multi.Value (PatternTuple, Decomposed, Atom)++import qualified Control.Monad.HT as Monad+import Control.Monad.IO.Class (liftIO)++import qualified Data.Enum.Storable as Enum+import qualified Data.Tuple.HT as TupleHT+import qualified Data.Tuple as Tuple+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Complex (Complex((:+)))+import Data.Bool8 (Bool8)++import qualified Foreign.Storable.Record.Tuple as StTuple++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 System.IO.Unsafe (unsafePerformIO)++import qualified Prelude as P+import Prelude hiding+   (fst, snd, min, max, zip, unzip, zip3, unzip3,+    curry, uncurry, recip, pi, sqrt, maybe, toEnum, fromEnum, pred, succ)+++newtype Exp a = Exp {unExp :: forall r. LLVM.CodeGenFunction r (MultiValue.T a)}+++{-+Using IORef should be thread-safe here,+because you cannot fork within CodeGenFunction.+-}+unique :: (forall r. LLVM.CodeGenFunction r (MultiValue.T a)) -> Exp a+unique = Exp++_unique :: (forall r. LLVM.CodeGenFunction r (MultiValue.T a)) -> Exp a+_unique code = unsafePerformIO $ fmap (withKey code) $ newIORef Nothing++withKey ::+   (forall r. LLVM.CodeGenFunction r (MultiValue.T a)) ->+   IORef (Maybe (MultiValue.T a)) -> Exp a+withKey code ref =+   Exp (do+      ma <- liftIO $ readIORef ref+      case ma of+         Just a -> return a+         Nothing -> do+            a <- code+            liftIO $ writeIORef ref $ Just a+            return a)+++with :: Exp a -> (Exp a -> Exp b) -> Exp b+with (Exp code) f =+   Exp (do+      a <- code+      unExp (f (Exp (return a))))+++class Value val where+   lift0 :: MultiValue.T a -> val a+   lift1 ::+      (MultiValue.T a -> MultiValue.T b) ->+      val a -> val b+   lift2 ::+      (MultiValue.T a -> MultiValue.T b -> MultiValue.T c) ->+      val a -> val b -> val c++instance Value MultiValue.T where+   lift0 = id+   lift1 = id+   lift2 = id++instance Value Exp where+   lift0 a = unique (return a)+   lift1 f (Exp a) = unique (Monad.lift f a)+   lift2 f (Exp a) (Exp b) = unique (Monad.lift2 f a b)++lift3 ::+   (Value val) =>+   (MultiValue.T a -> MultiValue.T b -> MultiValue.T c -> MultiValue.T d) ->+   val a -> val b -> val c -> val d+lift3 f a b = lift2 (MultiValue.uncurry f) (zip a b)++lift4 ::+   (Value val) =>+   (MultiValue.T a -> MultiValue.T b -> MultiValue.T c -> MultiValue.T d ->+    MultiValue.T e) ->+   val a -> val b -> val c -> val d -> val e+lift4 f a b = lift3 (MultiValue.uncurry f) (zip a b)++++liftM ::+   (Aggregate ae am) =>+   (forall r.+    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.+    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.+    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 ::+   (Aggregate ae am) =>+   (Aggregate be bm) =>+   (ae -> be) ->+   am -> LLVM.CodeGenFunction r bm+unliftM1 f ix = bundle (f (dissect ix))++unliftM2 ::+   (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 ::+   (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))+++liftReprM ::+   (forall r.+    MultiValue.Repr a ->+    LLVM.CodeGenFunction r (MultiValue.Repr b)) ->+   (Exp a -> Exp b)+liftReprM f = liftM (MultiValue.liftM f)++liftReprM2 ::+   (forall r.+    MultiValue.Repr a -> MultiValue.Repr b ->+    LLVM.CodeGenFunction r (MultiValue.Repr c)) ->+   (Exp a -> Exp b -> Exp c)+liftReprM2 f = liftM2 (MultiValue.liftM2 f)++liftReprM3 ::+   (forall r.+    MultiValue.Repr a -> MultiValue.Repr b -> MultiValue.Repr c ->+    LLVM.CodeGenFunction r (MultiValue.Repr d)) ->+   (Exp a -> Exp b -> Exp c -> Exp d)+liftReprM3 f = liftM3 (MultiValue.liftM3 f)++++zip :: (Value val) => val a -> val b -> val (a, b)+zip = lift2 MultiValue.zip++zip3 :: (Value val) => val a -> val b -> val c -> val (a, b, c)+zip3 = lift3 MultiValue.zip3++zip4 :: (Value val) => val a -> val b -> val c -> val d -> val (a, b, c, d)+zip4 = lift4 MultiValue.zip4++unzip :: (Value val) => val (a, b) -> (val a, val b)+unzip ab = (fst ab, snd ab)++unzip3 :: (Value val) => val (a, b, c) -> (val a, val b, val c)+unzip3 abc = (fst3 abc, snd3 abc, thd3 abc)++unzip4 :: (Value val) => val (a, b, c, d) -> (val a, val b, val c, val d)+unzip4 abcd =+   (lift1 (\(MultiValue.Cons (a,_,_,_)) -> MultiValue.Cons a) abcd,+    lift1 (\(MultiValue.Cons (_,b,_,_)) -> MultiValue.Cons b) abcd,+    lift1 (\(MultiValue.Cons (_,_,c,_)) -> MultiValue.Cons c) abcd,+    lift1 (\(MultiValue.Cons (_,_,_,d)) -> MultiValue.Cons d) abcd)+++fst :: (Value val) => val (a, b) -> val a+fst = lift1 MultiValue.fst++snd :: (Value val) => val (a, b) -> val b+snd = lift1 MultiValue.snd++mapFst :: (Exp a -> Exp b) -> Exp (a, c) -> Exp (b, c)+mapFst f = liftM (MultiValue.mapFstF (unliftM1 f))++mapSnd :: (Exp b -> Exp c) -> Exp (a, b) -> Exp (a, c)+mapSnd f = liftM (MultiValue.mapSndF (unliftM1 f))++mapPair :: (Exp a0 -> Exp a1, Exp b0 -> Exp b1) -> Exp (a0, b0) -> Exp (a1, b1)+mapPair (f,g) = mapFst f . mapSnd g++swap :: (Value val) => val (a, b) -> val (b, a)+swap = lift1 MultiValue.swap++curry :: (Exp (a,b) -> c) -> (Exp a -> Exp b -> c)+curry f = Tuple.curry (f . Tuple.uncurry zip)++uncurry :: (Exp a -> Exp b -> c) -> (Exp (a,b) -> c)+uncurry f = Tuple.uncurry f . unzip+++fst3 :: (Value val) => val (a,b,c) -> val a+fst3 = lift1 MultiValue.fst3++snd3 :: (Value val) => val (a,b,c) -> val b+snd3 = lift1 MultiValue.snd3++thd3 :: (Value val) => val (a,b,c) -> val c+thd3 = lift1 MultiValue.thd3++mapFst3 :: (Exp a0 -> Exp a1) -> Exp (a0,b,c) -> Exp (a1,b,c)+mapFst3 f = liftM (MultiValue.mapFst3F (unliftM1 f))++mapSnd3 :: (Exp b0 -> Exp b1) -> Exp (a,b0,c) -> Exp (a,b1,c)+mapSnd3 f = liftM (MultiValue.mapSnd3F (unliftM1 f))++mapThd3 :: (Exp c0 -> Exp c1) -> Exp (a,b,c0) -> Exp (a,b,c1)+mapThd3 f = liftM (MultiValue.mapThd3F (unliftM1 f))++mapTriple ::+   (Exp a0 -> Exp a1, Exp b0 -> Exp b1, Exp c0 -> Exp c1) ->+   Exp (a0,b0,c0) -> Exp (a1,b1,c1)+mapTriple (f,g,h) = mapFst3 f . mapSnd3 g . mapThd3 h+++tuple :: Exp tuple -> Exp (StTuple.Tuple tuple)+tuple = lift1 MultiValue.tuple++untuple :: Exp (StTuple.Tuple tuple) -> Exp tuple+untuple = lift1 MultiValue.untuple+++modifyMultiValue ::+   (Value val,+    MultiValue.Compose a,+    MultiValue.Decompose pattern,+    MultiValue.PatternTuple pattern ~ tuple) =>+   pattern ->+   (Decomposed MultiValue.T pattern -> a) ->+   val tuple -> val (MultiValue.Composed a)+modifyMultiValue p f = lift1 $ MultiValue.modify p f++modifyMultiValue2 ::+   (Value val,+    MultiValue.Compose a,+    MultiValue.Decompose patternA,+    MultiValue.Decompose patternB,+    MultiValue.PatternTuple patternA ~ tupleA,+    MultiValue.PatternTuple patternB ~ tupleB) =>+   patternA ->+   patternB ->+   (Decomposed MultiValue.T patternA ->+    Decomposed MultiValue.T patternB -> a) ->+   val tupleA -> val tupleB -> val (MultiValue.Composed a)+modifyMultiValue2 pa pb f = lift2 $ MultiValue.modify2 pa pb f++modifyMultiValueM ::+   (MultiValue.Compose a,+    MultiValue.Decompose pattern,+    MultiValue.PatternTuple pattern ~ tuple) =>+   pattern ->+   (forall r.+    Decomposed MultiValue.T pattern ->+    LLVM.CodeGenFunction r a) ->+   Exp tuple -> Exp (MultiValue.Composed a)+modifyMultiValueM p f = liftM (MultiValue.modifyF p f)++modifyMultiValueM2 ::+   (MultiValue.Compose a,+    MultiValue.Decompose patternA,+    MultiValue.Decompose patternB,+    MultiValue.PatternTuple patternA ~ tupleA,+    MultiValue.PatternTuple patternB ~ tupleB) =>+   patternA ->+   patternB ->+   (forall r.+    Decomposed MultiValue.T patternA ->+    Decomposed MultiValue.T patternB ->+    LLVM.CodeGenFunction r a) ->+   Exp tupleA -> Exp tupleB -> Exp (MultiValue.Composed a)+modifyMultiValueM2 pa pb f = liftM2 (MultiValue.modifyF2 pa pb f)+++class Compose multituple where+   type Composed multituple+   {- |+   A nested 'zip'.+   -}+   compose :: multituple -> Exp (Composed multituple)++class+   (Composed (Decomposed Exp pattern) ~ PatternTuple pattern) =>+      Decompose pattern where+   {- |+   Analogous to 'MultiValue.decompose'.+   -}+   decompose :: pattern -> Exp (PatternTuple pattern) -> Decomposed Exp pattern+++{- |+Analogus to 'MultiValue.modifyMultiValue'.+-}+modify ::+   (Compose a, Decompose pattern) =>+   pattern ->+   (Decomposed Exp pattern -> a) ->+   Exp (PatternTuple pattern) -> Exp (Composed a)+modify p f = compose . f . decompose p++modify2 ::+   (Compose a, Decompose patternA, Decompose patternB) =>+   patternA ->+   patternB ->+   (Decomposed Exp patternA -> Decomposed Exp patternB -> a) ->+   Exp (PatternTuple patternA) ->+   Exp (PatternTuple patternB) -> Exp (Composed a)+modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b)++++instance Compose (Exp a) where+   type Composed (Exp a) = a+   compose = id++instance Decompose (Atom a) where+   decompose _ = id++++instance Compose () where+   type Composed () = ()+   compose = cons++instance Decompose () where+   decompose _ _ = ()+++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+++instance (Compose a, Compose b, Compose c) => Compose (a,b,c) where+   type Composed (a,b,c) = (Composed a, Composed b, Composed c)+   compose =+      TupleHT.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+++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)+++instance (Compose tuple) => Compose (StTuple.Tuple tuple) where+   type Composed (StTuple.Tuple tuple) = StTuple.Tuple (Composed tuple)+   compose (StTuple.Tuple tup) = tuple $ compose tup++instance (Decompose p) => Decompose (StTuple.Tuple p) where+   decompose (StTuple.Tuple p) = StTuple.Tuple . decompose p . untuple+++instance (Compose a) => Compose (Complex a) where+   type Composed (Complex a) = Complex (Composed a)+   compose (r:+i) = consComplex (compose r) (compose i)++instance (Decompose p) => Decompose (Complex p) where+   decompose (pr:+pi) =+      Tuple.uncurry (:+) .+      TupleHT.mapPair (decompose pr, decompose pi) . deconsComplex++{- |+You can construct complex numbers this way,+but they will not make you happy,+because the numeric operations require a RealFloat instance+that we could only provide with lots of undefined methods+(also in its superclasses).+You may either define your own arithmetic+or use the NumericPrelude type classes.+-}+consComplex :: Exp a -> Exp a -> Exp (Complex a)+consComplex = lift2 MultiValue.consComplex++deconsComplex :: Exp (Complex a) -> (Exp a, Exp a)+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++unit :: Exp ()+unit = cons ()++zero :: (MultiValue.C a) => Exp a+zero = lift0 MultiValue.zero++add :: (MultiValue.Additive a) => Exp a -> Exp a -> Exp a+add = liftM2 MultiValue.add++sub :: (MultiValue.Additive a) => Exp a -> Exp a -> Exp a+sub = liftM2 MultiValue.sub++neg :: (MultiValue.Additive a) => Exp a -> Exp a+neg = liftM MultiValue.neg++one :: (MultiValue.IntegerConstant a) => Exp a+one = fromInteger' 1++mul :: (MultiValue.PseudoRing a) => Exp a -> Exp a -> Exp a+mul = liftM2 MultiValue.mul++sqr :: (MultiValue.PseudoRing a) => Exp a -> Exp a+sqr = liftM $ \x -> MultiValue.mul x x++recip :: (MultiValue.Field a, MultiValue.IntegerConstant a) => Exp a -> Exp a+recip = fdiv one++fdiv :: (MultiValue.Field a) => Exp a -> Exp a -> Exp a+fdiv = liftM2 MultiValue.fdiv++sqrt :: (MultiValue.Algebraic a) => Exp a -> Exp a+sqrt = liftM MultiValue.sqrt++pow :: (MultiValue.Transcendental a) => Exp a -> Exp a -> Exp a+pow = liftM2 MultiValue.pow++idiv :: (MultiValue.Integral a) => Exp a -> Exp a -> Exp a+idiv = liftM2 MultiValue.idiv++irem :: (MultiValue.Integral a) => Exp a -> Exp a -> Exp a+irem = liftM2 MultiValue.irem++shl :: (MultiValue.BitShift a) => Exp a -> Exp a -> Exp a+shl = liftM2 MultiValue.shl++shr :: (MultiValue.BitShift a) => Exp a -> Exp a -> Exp a+shr = liftM2 MultiValue.shr++fromInteger' :: (MultiValue.IntegerConstant a) => Integer -> Exp a+fromInteger' = lift0 . MultiValue.fromInteger'++fromRational' :: (MultiValue.RationalConstant a) => Rational -> Exp a+fromRational' = lift0 . MultiValue.fromRational'+++boolPFrom8 :: Exp Bool8 -> Exp Bool+boolPFrom8 = lift1 MultiValue.boolPFrom8++bool8FromP :: Exp Bool -> Exp Bool8+bool8FromP = lift1 MultiValue.bool8FromP++intFromBool8 :: (MultiValue.NativeInteger i ir) => Exp Bool8 -> Exp i+intFromBool8 = liftM MultiValue.intFromBool8++floatFromBool8 :: (MultiValue.NativeFloating a ar) => Exp Bool8 -> Exp a+floatFromBool8 = liftM MultiValue.floatFromBool8+++toEnum ::+   (MultiValue.Repr w ~ LLVM.Value w) =>+   Exp w -> Exp (Enum.T w e)+toEnum = lift1 MultiValue.toEnum++fromEnum ::+   (MultiValue.Repr w ~ LLVM.Value w) =>+   Exp (Enum.T w e) -> Exp w+fromEnum = lift1 MultiValue.fromEnum++succ, pred ::+   (LLVM.IsArithmetic w, SoV.IntegerConstant w) =>+   Exp (Enum.T w e) -> Exp (Enum.T w e)+succ = liftM MultiValue.succ+pred = liftM MultiValue.pred+++fromFastMath :: Exp (FastMath.Number flags a) -> Exp a+fromFastMath = lift1 FastMath.mvDenumber++toFastMath :: Exp a -> Exp (FastMath.Number flags a)+toFastMath = lift1 FastMath.mvNumber+++minBound, maxBound :: (MultiValue.Bounded a) => Exp a+minBound = lift0 MultiValue.minBound+maxBound = lift0 MultiValue.maxBound+++cmp ::+   (MultiValue.Comparison a) =>+   LLVM.CmpPredicate -> Exp a -> Exp a -> Exp Bool+cmp ord = liftM2 (MultiValue.cmp ord)++infix 4 ==*, /=*, <*, <=*, >*, >=*++(==*), (/=*), (<*), (>=*), (>*), (<=*) ::+   (MultiValue.Comparison a) => Exp a -> Exp a -> Exp Bool+(==*) = cmp LLVM.CmpEQ+(/=*) = cmp LLVM.CmpNE+(<*)  = cmp LLVM.CmpLT+(>=*) = cmp LLVM.CmpGE+(>*)  = cmp LLVM.CmpGT+(<=*) = cmp LLVM.CmpLE+++min, max :: (MultiValue.Real a) => Exp a -> Exp a -> Exp a+min = liftM2 A.min+max = liftM2 A.max++limit :: (MultiValue.Real a) => (Exp a, Exp a) -> Exp a -> Exp a+limit (l,u) = max l . min u++fraction :: (MultiValue.Fraction a) => Exp a -> Exp a+fraction = liftM MultiValue.fraction+++true, false :: Exp Bool+true = cons True+false = cons False++infixr 3 &&*+(&&*) :: Exp Bool -> Exp Bool -> Exp Bool+(&&*) = liftM2 MultiValue.and++infixr 2 ||*+(||*) :: Exp Bool -> Exp Bool -> Exp Bool+(||*) = liftM2 MultiValue.or++not :: Exp Bool -> Exp Bool+not = liftM MultiValue.inv++{- |+Like 'ifThenElse' but computes both alternative expressions+and then uses LLVM's efficient @select@ instruction.+-}+select :: (MultiValue.Select a) => Exp Bool -> Exp a -> Exp a -> Exp a+select = liftM3 MultiValue.select++ifThenElse :: (MultiValue.C a) => Exp Bool -> Exp a -> Exp a -> Exp a+ifThenElse ec ex ey =+   unique (do+      MultiValue.Cons c <- unExp ec+      C.ifThenElse c (unExp ex) (unExp ey))+++complement :: (MultiValue.Logic a) => Exp a -> Exp a+complement = liftM MultiValue.inv++infixl 7 .&.*+(.&.*) :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a+(.&.*) = liftM2 MultiValue.and++infixl 5 .|.*+(.|.*) :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a+(.|.*) = liftM2 MultiValue.or++infixl 6 `xor`+xor :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a+xor = liftM2 MultiValue.xor+++toMaybe :: Exp Bool -> Exp a -> Exp (Maybe a)+toMaybe = lift2 MultiValue.toMaybe++maybe :: (MultiValue.C b) => Exp b -> (Exp a -> Exp b) -> Exp (Maybe a) -> Exp b+maybe n j = liftM $ \m -> do+   let (MultiValue.Cons b, a) = MultiValue.splitMaybe m+   C.ifThenElse b (unliftM1 j a) (unExp n)+++instance+   (MultiValue.PseudoRing a, MultiValue.Real a, MultiValue.IntegerConstant a) =>+      Num (Exp a) where+   fromInteger = fromInteger'+   (+) = add+   (-) = sub+   negate = neg+   (*) = mul+   abs = liftM MultiValue.abs+   signum = liftM MultiValue.signum++instance+   (MultiValue.Field a, MultiValue.Real a, MultiValue.RationalConstant a) =>+      Fractional (Exp a) where+   fromRational = fromRational'+   (/) = fdiv++instance+   (MultiValue.Transcendental a, MultiValue.Real a,+    MultiValue.RationalConstant a) =>+      Floating (Exp a) where+   pi = unique MultiValue.pi+   sin = liftM MultiValue.sin+   cos = liftM MultiValue.cos+   sqrt = sqrt+   (**) = pow+   exp = liftM MultiValue.exp+   log = liftM MultiValue.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+++{- |+We do not require a numeric prelude superclass,+thus also LLVM only types like vectors are instances.+-}+instance (MultiValue.Additive a) => Additive.C (Exp a) where+   zero = zero+   (+) = add+   (-) = sub+   negate = neg++instance+   (MultiValue.PseudoRing a, MultiValue.IntegerConstant a) =>+      Ring.C (Exp a) where+   one = one+   (*) = 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 ~ MultiValue.Scalar v,+    MultiValue.PseudoModule v, MultiValue.IntegerConstant a) =>+      Module.C (Exp a) (Exp v) where+   (*>) = liftM2 MultiValue.scale++instance+   (MultiValue.Field a, MultiValue.RationalConstant a) =>+      Field.C (Exp a) where+   (/) = fdiv+   fromRational' = fromRational' . Field.fromRational'++instance+   (MultiValue.Transcendental a, MultiValue.RationalConstant a) =>+      Algebraic.C (Exp a) where+   sqrt = sqrt+   root n x = pow x (recip $ fromInteger' n)+   x^/r = pow x (Field.fromRational' r)+++tau :: (MultiValue.Transcendental a, MultiValue.RationalConstant a) => Exp a+tau = mul (fromInteger' 2) Trans.pi++instance+   (MultiValue.Transcendental a, MultiValue.RationalConstant a) =>+      Trans.C (Exp a) where+   pi = unique MultiValue.pi+   sin = liftM MultiValue.sin+   cos = liftM MultiValue.cos+   (**) = pow+   exp = liftM MultiValue.exp+   log = liftM MultiValue.log++   asin _ = error "LLVM missing intrinsic: asin"+   acos _ = error "LLVM missing intrinsic: acos"+   atan _ = error "LLVM missing intrinsic: atan"+++instance+   (MultiValue.Real a, MultiValue.PseudoRing a, MultiValue.IntegerConstant a) =>+      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
@@ -0,0 +1,363 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+module LLVM.DSL.Parameter (+   T,+   ($#),+   get,+   valueTuple,+   multiValue,++   with,+   withValue,+   withMulti,++   Tunnel(..),+   tunnel,++   Tuple(..),+   withTuple,+   withTuple1,+   withTuple2,++   -- * for implementation of new processes+   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++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Control.Category as Cat+import qualified Control.Arrow as Arr+import qualified Control.Applicative as App+import qualified Control.Functor.HT as FuncHT+import Control.Applicative (pure, liftA2)++import Data.Tuple.HT (mapFst, mapPair, mapTriple)+import Data.Word (Word)++import Prelude2010+import Prelude ()+++{- |+This data type is for parameters of parameterized LLVM code.+It is better than using plain functions of type @p -> a@+since it allows for numeric instances+and we can make explicit,+whether a parameter is constant.++We recommend to use parameters for atomic types.+Although a parameter of type @T p (a,b)@ is possible,+it means that the whole parameter is variable+if only one of the pair elements is variable.+This way you may miss opportunities for constant folding.+-}+data T p a =+   Constant a |+   Variable (p -> a)+++get :: T p a -> (p -> a)+get (Constant a) = const a+get (Variable f) = f+++{- |+The call @value param v@ requires+that @v@ represents the same value as @valueTupleOf (get param p)@ for some @p@.+However @v@ might be the result of a load operation+and @param@ might be a constant.+In this case it is more efficient to use @valueTupleOf (get param undefined)@+since the constant is translated to an LLVM constant+that allows for certain optimizations.++This is the main function for taking advantage of a constant parameter+in low-level implementations.+For simplicity we do not omit constant parameters in the parameter struct+since this would mean to construct types at runtime and might become ugly.+Instead we just check using 'value' at the according places in LLVM code+whether a parameter is constant+and ignore the parameter from the struct in this case.+In many cases there will be no speed benefit+because the parameter will be loaded to a register anyway.+It can only lead to speed-up if subsequent optimizations+can precompute constant expressions.+Another example is 'drop' where a loop with constant loop count can be generated.+For small loop counts and simple loop bodies the loop might get unrolled.+-}+valueTuple ::+   (Tuple.Value tuple, Tuple.ValueOf tuple ~ value) =>+   T p tuple -> value -> value+valueTuple = genericValue Tuple.valueOf++multiValue ::+   (MultiValue.C a) =>+   T p a -> MultiValue.T a -> MultiValue.T a+multiValue = genericValue MultiValue.cons++genericValue ::+   (a -> value) ->+   T p a -> value -> value+genericValue cons p v =+   case p of+      Constant a -> cons a+      Variable _ -> v+++{- |+This function provides specialised variants of 'get' and 'value',+that use the unit type for constants+and thus save space in parameter structures.+-}+{-# INLINE withValue #-}+withValue ::+   (Marshal.C tuple, Tuple.ValueOf tuple ~ value) =>+   T p tuple ->+   (forall parameters.+    (Marshal.C parameters) =>+    (p -> parameters) ->+    (Tuple.ValueOf parameters -> value) ->+    a) ->+   a+withValue (Constant a) f = f (const ()) (\() -> Tuple.valueOf a)+withValue (Variable v) f = f v id++{-# INLINE withMulti #-}+withMulti ::+   (MarshalMV.C b) =>+   T p b ->+   (forall parameters.+    (MarshalMV.C parameters) =>+    (p -> parameters) ->+    (MultiValue.T parameters -> MultiValue.T b) ->+    a) ->+   a+withMulti = with MultiValue.cons++{-# INLINE with #-}+with ::+   (MarshalMV.C b) =>+   (b -> MultiValue.T b) ->+   T p b ->+   (forall parameters.+    (MarshalMV.C parameters) =>+    (p -> parameters) ->+    (MultiValue.T parameters -> MultiValue.T b) ->+    a) ->+   a+with cons p f =+   case p of+      Constant b -> f (const ()) (\_ -> cons b)+      Variable v -> f v id+++data Tunnel p a =+   forall t.+   (MarshalMV.C t) => Tunnel (p -> t) (MultiValue.T t -> MultiValue.T 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)+      Variable v -> Tunnel v id+++wordInt :: T p Int -> T p Word+wordInt = fmap fromIntegral+++infixl 0 $#++($#) :: (T p a -> b) -> (a -> b)+($#) f a = f (pure a)++++class Tuple tuple where+   type Composed tuple+   type Source tuple+   decompose :: T (Source tuple) (Composed tuple) -> tuple++instance Tuple (T p a) where+   type Composed (T p a) = a+   type Source (T p a) = p+   decompose = id++instance (Tuple a, Tuple b, Source a ~ Source b) => Tuple (a,b) where+   type Composed (a,b) = (Composed a, Composed b)+   type Source (a,b) = Source a+   decompose = mapPair (decompose, decompose) . FuncHT.unzip++instance+   (Tuple a, Tuple b, Tuple c, Source a ~ Source b, Source b ~ Source c) =>+      Tuple (a,b,c) where+   type Composed (a,b,c) = (Composed a, Composed b, Composed c)+   type Source (a,b,c) = Source a+   decompose = mapTriple (decompose, decompose, decompose) . FuncHT.unzip3++{- |+Provide all elements of a nested tuple as separate parameters.++If you do not use one of the tuple elements,+you will get a type error like+@Couldn't match type `Param.Composed t0' with `Int'@.+The problem is that the type checker cannot infer+that an element is a @Parameter.T@ if it remains unused.+-}+withTuple ::+   (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>+   (tuple -> f p) -> f p+withTuple f = idFromFunctor $ f . decompose++idFromFunctor :: (T p p -> f p) -> f p+idFromFunctor f = f Cat.id++withTuple1 ::+   (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>+   (tuple -> f p a) -> f p a+withTuple1 f = idFromFunctor1 $ f . decompose++idFromFunctor1 :: (T p p -> f p a) -> f p a+idFromFunctor1 f = f Cat.id++withTuple2 ::+   (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>+   (tuple -> f p a b) -> f p a b+withTuple2 f = idFromFunctor2 $ f . decompose++idFromFunctor2 :: (T p p -> f p a b) -> f p a b+idFromFunctor2 f = f Cat.id++++{- |+@.@ can be used for fetching a parameter from a super-parameter.+-}+instance Cat.Category T where+   id = Variable id+   Constant f . _ = Constant f+   Variable f . Constant a = Constant (f a)+   Variable f . Variable g = Variable (f . g)++{- |+@arr@ is useful for lifting parameter selectors to our parameter type+without relying on the constructor.+-}+instance Arr.Arrow T where+   arr = Variable+   first f = Variable (mapFst (get f))++++{- |+Useful for splitting @T p (a,b)@ into @T p a@ and @T p b@+using @fmap fst@ and @fmap snd@.+-}+instance Functor (T p) where+   fmap f (Constant a) = Constant (f a)+   fmap f (Variable g) = Variable (f . g)++{- |+Useful for combining @T p a@ and @T p b@ to @T p (a,b)@+using @liftA2 (,)@.+However, we do not recommend to do so+because the result parameter can only be constant+if both operands are constant.+-}+instance App.Applicative (T p) where+   pure a = Constant a+   Constant f <*> Constant a = Constant (f a)+   f <*> a = Variable (\p -> get f p (get a p))++instance Monad (T p) where+   return = pure+   Constant x >>= f = f x+   Variable x >>= f =+      Variable (\p -> get (f (x p)) p)+++instance Num a => Num (T p a) where+   (+) = liftA2 (+)+   (-) = liftA2 (-)+   (*) = liftA2 (*)+   negate = fmap negate+   abs = fmap abs+   signum = fmap signum+   fromInteger = pure . fromInteger++instance Fractional a => Fractional (T p a) where+   (/) = liftA2 (/)+   fromRational = pure . fromRational++instance Floating a => Floating (T p a) where+   pi = pure pi+   sqrt = fmap sqrt+   (**) = liftA2 (**)+   exp = fmap exp+   log = fmap log+   logBase = liftA2 logBase+   sin = fmap sin+   tan = fmap tan+   cos = fmap cos+   asin = fmap asin+   atan = fmap atan+   acos = fmap acos+   sinh = fmap sinh+   tanh = fmap tanh+   cosh = fmap cosh+   asinh = fmap asinh+   atanh = fmap atanh+   acosh = fmap acosh+++instance Additive.C a => Additive.C (T p a) where+   zero = pure Additive.zero+   negate = fmap Additive.negate+   (+) = liftA2 (Additive.+)+   (-) = liftA2 (Additive.-)++instance Ring.C a => Ring.C (T p a) where+   one = pure Ring.one+   (*) = liftA2 (Ring.*)+   x^n = fmap (Ring.^n) x+   fromInteger = pure . Ring.fromInteger++instance Field.C a => Field.C (T p a) where+   (/) = liftA2 (Field./)+   recip = fmap Field.recip+   fromRational' = pure . Field.fromRational'++instance Algebraic.C a => Algebraic.C (T p a) where+   x ^/ r = fmap (Algebraic.^/ r) x+   sqrt = fmap Algebraic.sqrt+   root n = fmap (Algebraic.root n)++instance Trans.C a => Trans.C (T p a) where+   pi      = pure   Trans.pi+   exp     = fmap   Trans.exp+   log     = fmap   Trans.log+   logBase = liftA2 Trans.logBase+   (**)    = liftA2 (Trans.**)+   sin     = fmap   Trans.sin+   tan     = fmap   Trans.tan+   cos     = fmap   Trans.cos+   asin    = fmap   Trans.asin+   atan    = fmap   Trans.atan+   acos    = fmap   Trans.acos+   sinh    = fmap   Trans.sinh+   tanh    = fmap   Trans.tanh+   cosh    = fmap   Trans.cosh+   asinh   = fmap   Trans.asinh+   atanh   = fmap   Trans.atanh+   acosh   = fmap   Trans.acosh
+ src/LLVM/DSL/Render/Argument.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+module LLVM.DSL.Render.Argument (+   T(Cons),+   Creator,+   unit,+   primitive,+   wrap,+   pair,+   triple,+   newDispose,+   ) where++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal++import Data.Tuple.Strict (mapPair, mapTriple)++import Prelude2010+import Prelude ()++++type Creator p = IO (p, IO ())+++{- |+Transfer 'a' to 'adsl' with 'al' as transit stop.+-}+data T a adsl =+   forall al. Marshal.C al =>+   Cons (Exp al -> adsl) (a -> Creator al)+++primitiveCreator :: a -> Creator a+primitiveCreator a = return (a, return ())++unit :: T () ()+unit = Cons (\ _unit -> ()) primitiveCreator++primitive :: (Marshal.C a) => T a (Exp a)+primitive = Cons id primitiveCreator++wrap :: (Marshal.C a) => (b -> a) -> (adsl -> bdsl) -> T a adsl -> T b bdsl+wrap unwrp wrp (Cons pass create) = Cons (wrp . pass) (create . unwrp)+++pair :: T a ad -> T b bd -> T (a,b) (ad,bd)+pair (Cons passA createA) (Cons passB createB) =+   Cons+      (mapPair (passA,passB) . Expr.unzip)+      (\(a,b) -> do+         (pa,finalA) <- createA a+         (pb,finalB) <- createB b+         return ((pa,pb), finalB>>finalA))++triple :: T a ad -> T b bd -> T c cd -> T (a,b,c) (ad,bd,cd)+triple (Cons passA createA) (Cons passB createB) (Cons passC createC) =+   Cons+      (mapTriple (passA,passB,passC) . Expr.unzip3)+      (\(a,b,c) -> do+         (pa,finalA) <- createA a+         (pb,finalB) <- createB b+         (pc,finalC) <- createC c+         return ((pa,pb,pc), finalC>>finalB>>finalA))+++newDispose ::+   (Marshal.C handle) =>+   (a -> IO handle) -> (handle -> IO ()) ->+   (Exp handle -> ad) -> T a ad+newDispose new dispose fetch =+   Cons fetch+      (\x -> do+         it <- new x+         return (it, dispose it))
+ src/LLVM/DSL/Render/Run.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{- |+This is an approach with no pre-defined direction of type dependencies.+-}+module LLVM.DSL.Render.Run (+   T(Cons, decons),+   postmapPlain,+   premapDSL,+   Creator,+   run,+   (*->),+   ) where++import qualified LLVM.DSL.Render.Argument as Arg+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Render.Argument (Creator)+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal++import Prelude2010+import Prelude ()++++{-+Type order of 'f' and 'fdsl' is consistent with 'run',+but inconsistent with 'Arg.T'.+-}+newtype T m p fdsl f =+   Cons {decons :: (Exp p -> fdsl) -> m (Creator p -> f)}++{-+We could turn this into an 'Functor'/'fmap' instance,+however this is less descriptive and+would require to keep the current type parameter order.+-}+postmapPlain :: Functor m => (f -> g) -> T m p fdsl f -> T m p fdsl g+postmapPlain f build = Cons $ fmap (f .) . decons build++premapDSL :: (gdsl -> fdsl) -> T m p fdsl f -> T m p gdsl f+premapDSL f build = Cons $ decons build . fmap f+++-- ToDo: duplicate of Argument+primitiveCreator :: a -> Creator a+primitiveCreator a = return (a, return ())++run :: (Functor m) => T m () fdsl f -> fdsl -> m f+run (Cons build) f = fmap ($ primitiveCreator ()) $ build $ const f+++-- precedence like Applicative.<*>, but different associativity+infixr 4 *->++(*->) ::+   (Functor m) =>+   Arg.T a adsl ->+   (forall al. Marshal.C al => T m (p, al) fdsl f) ->+   T m p (adsl -> fdsl) (a -> f)+(*->) arg build = Cons $ \f ->+   case arg of+      Arg.Cons pass createA ->+         fmap+            (\g createP av ->+               g (do (p,finalP) <- createP+                     (pa,finalA) <- createA av+                     return ((p,pa), finalA >> finalP)))+            (decons build (Expr.uncurry $ \p -> f p . pass))
+ 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 _ = ()
+ src/debug-off/LLVM/DSL/Dump.hs view
@@ -0,0 +1,6 @@+module LLVM.DSL.Dump (writer) where++import qualified LLVM.Core as LLVM++writer :: String -> IO (String -> LLVM.Module -> IO ())+writer _name = return $ const $ const $ return ()
+ src/debug-on/LLVM/DSL/Dump.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE EmptyDataDecls #-}+module LLVM.DSL.Dump (writer) where++import qualified LLVM.DSL.Debug.Counter as Counter++import qualified LLVM.Core as LLVM++import qualified Data.IORef as IORef++import System.IO.Unsafe (unsafePerformIO)+++data BitCodeCnt++{- |+This is only for debugging purposes+and thus I felt free to use unsafePerformIO.+-}+counter :: IORef.IORef (Counter.T BitCodeCnt)+counter = unsafePerformIO Counter.new+++bitcodeToFile :: String -> Counter.T ident -> String -> LLVM.Module -> IO ()+bitcodeToFile name cnt ext =+   LLVM.writeBitcodeToFile+      ("llvm" ++ Counter.format 3 cnt ++ name ++ ext ++ ".bc")++writer :: String -> IO (String -> LLVM.Module -> IO ())+writer name = fmap (bitcodeToFile name) $ Counter.next counter
+ test/Main.hs view
@@ -0,0 +1,12 @@+module Main where++import qualified Test.LLVM.DSL.Example.Median as Median+import qualified LLVM.Core as LLVM++import qualified Test.DocTest.Driver as DocTest+++main :: IO ()+main = do+   LLVM.initializeNativeTarget+   DocTest.run Median.run
+ test/Test/LLVM/DSL/Example/Median.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Test.LLVM.DSL.Example.Median where++import qualified LLVM.DSL.Example.Median as Median+import LLVM.DSL.Example.Median (MV)++import qualified LLVM.DSL.Execution as Exec+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Storable as Memory+import qualified LLVM.Extra.Multi.Vector as MVec+import qualified LLVM.Extra.Multi.Value as MV++import qualified LLVM.Core as LLVM++import Type.Data.Num.Decimal (D4)++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.List as List+import Data.Int (Int32)++import Control.Monad.IO.Class (liftIO)+import Control.Applicative (liftA3)++import Foreign (Ptr, peek, with, alloca)++import qualified Test.DocTest.Driver as DocTest+import System.IO.Unsafe (unsafePerformIO)++++unliftM3ExprFloat ::+   (Exp Float -> Exp Float -> Exp Float -> Exp Float) ->+   LLVM.Value Float -> LLVM.Value Float -> LLVM.Value Float ->+   LLVM.CodeGenFunction Float (LLVM.Value Float)+unliftM3ExprFloat f a b c = do+   MV.Cons m <- Expr.unliftM3 f (MV.Cons a) (MV.Cons b) (MV.Cons c)+   return m++unliftM3ExprInt32 ::+   (Exp Int32 -> Exp Int32 -> Exp Int32 -> Exp Int32) ->+   LLVM.Value Int32 -> LLVM.Value Int32 -> LLVM.Value Int32 ->+   LLVM.CodeGenFunction Int32 (LLVM.Value Int32)+unliftM3ExprInt32 f a b c = do+   MV.Cons m <- Expr.unliftM3 f (MV.Cons a) (MV.Cons b) (MV.Cons c)+   return m++unliftM3MVInt32 ::+   (MV Int32 -> MV Int32 -> MV Int32 ->+    LLVM.CodeGenFunction Int32 (MV Int32)) ->+   LLVM.Value Int32 -> LLVM.Value Int32 -> LLVM.Value Int32 ->+   LLVM.CodeGenFunction Int32 (LLVM.Value Int32)+unliftM3MVInt32 f a b c = do+   MV.Cons m <- f (MV.Cons a) (MV.Cons b) (MV.Cons c)+   return m+++type ValPtrV4Int32 = LLVM.Value (Ptr (LLVM.Vector D4 Int32))++unliftM3MVV4Int32 ::+   (MVec.T D4 Int32 -> MVec.T D4 Int32 -> MVec.T D4 Int32 ->+    LLVM.CodeGenFunction r (MVec.T D4 Int32)) ->+   ValPtrV4Int32 -> ValPtrV4Int32 -> ValPtrV4Int32 ->+   ValPtrV4Int32 -> LLVM.CodeGenFunction r ()+unliftM3MVV4Int32 f aPtr bPtr cPtr mPtr = do+   a <- MVec.Cons <$> Memory.load aPtr+   b <- MVec.Cons <$> Memory.load bPtr+   c <- MVec.Cons <$> Memory.load cPtr+   MVec.Cons m <- f a b c+   Memory.store m mPtr+++foreign import ccall safe "dynamic" derefMedian3Ptr ::+   Exec.Importer (Int32 -> Int32 -> Int32 -> IO Int32)++foreign import ccall safe "dynamic" derefMedian3V4Ptr ::+   Exec.Importer+      (Ptr (LLVM.Vector D4 Int32) ->+       Ptr (LLVM.Vector D4 Int32) ->+       Ptr (LLVM.Vector D4 Int32) ->+       Ptr (LLVM.Vector D4 Int32) ->+       IO ())++foreign import ccall safe "dynamic" derefMedian3FloatPtr ::+   Exec.Importer (Float -> Float -> Float -> IO Float)++run :: DocTest.T ()+run = do+   let (funcNames, funcs) = unzip $++         let func name f =+               (name, Exec.createFunction derefMedian3Ptr name f) in++         func "median3IfThen"  (unliftM3ExprInt32 Median.median3IfThen) :+         func "median3Select"  (unliftM3ExprInt32 Median.median3Select) :+         func "median3SelectS" (unliftM3ExprInt32 Median.median3SelectShared) :+         func "median3MinMax"  (unliftM3ExprInt32 Median.median3MinMax) :+         func "median3Case"    (unliftM3MVInt32 Median.median3Case) :+         func "median3CaseVec" (unliftM3MVInt32 Median.median3CaseVec) :+         []++   (medianFloat, medianVector, medianFuncs) <-+      liftIO $ Exec.compile "median" $+      liftA3 (,,)+         (Exec.createFunction derefMedian3FloatPtr "median3MinMaxFloat"+            (unliftM3ExprFloat Median.median3MinMax))+         (Exec.createFunction derefMedian3V4Ptr "median3MinMaxVector"+            (unliftM3MVV4Int32 Median.median3MinMaxVector))+         (Trav.sequenceA funcs)++   let check expected m = do+         DocTest.printPrefix (show m ++ "  ")+         DocTest.property $ m == expected++   do check 3 =<< liftIO (medianFloat 3 1 4)+      DocTest.printPrefix "medianFloat: "+      DocTest.property $ \a b c ->+         unsafePerformIO (medianFloat a b c) == List.sort [a,b,c] !! 1++   liftIO $ alloca $ \mv ->+      with (LLVM.consVector 3 1 4 1) $ \av ->+      with (LLVM.consVector 2 7 1 8) $ \bv ->+      with (LLVM.consVector 5 7 7 2) $ \cv -> do+         medianVector av bv cv mv+         print =<< peek mv++   Fold.for_ (zip funcNames medianFuncs) $ \(name, medianFunc) -> do+      check 3 =<< liftIO (medianFunc 3 1 4)+      DocTest.printPrefix (name ++ ": ")+      DocTest.property $ \a b c ->+         unsafePerformIO (medianFunc a b c) == List.sort [a,b,c] !! 1