packages feed

llvm-dsl (empty) → 0.0

raw patch · 12 files changed

+1423/−0 lines, 12 filesdep +basedep +bool8dep +llvm-extrasetup-changed

Dependencies added: base, bool8, llvm-extra, llvm-tf, numeric-prelude, prelude-compat, storable-enum, storable-record, tfp, transformers, utility-ht

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,73 @@+Cabal-Version:  2.2+Name:           llvm-dsl+Version:        0.0+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.2+Build-Type:     Simple+Extra-Source-Files:+  Makefile++Source-Repository head+  Type:     darcs+  Location: http://hub.darcs.net/thielema/llvm-dsl/++Source-Repository this+  Tag:      0.0+  Type:     darcs+  Location: http://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.10 && <0.11,+    llvm-tf >=9.2 && <9.3,+    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,+    utility-ht >=0.0.15 && <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.Parameter+    LLVM.DSL.Execution+    LLVM.DSL.Debug.Counter+    LLVM.DSL.Debug.StablePtr+    LLVM.DSL.Debug.Marshal+  Other-Modules:+    LLVM.DSL.Dump
+ 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/Execution.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.DSL.Execution where++import qualified LLVM.DSL.Dump as Dump++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 ::+   (LLVM.FunctionArgs f) =>+   String -> LLVM.FunctionCodeGen f -> LLVM.CodeGenModule (LLVM.Function f)+createLLVMFunction = LLVM.createNamedFunction LLVM.ExternalLinkage++createFunction ::+   (EE.ExecutionFunction f, LLVM.FunctionArgs f) =>+   Importer f -> String -> LLVM.FunctionCodeGen 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, LLVM.FunctionArgs f) =>+   Importer f -> String -> LLVM.FunctionCodeGen 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,705 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# 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.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 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)+++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 ::+   (forall r.+    MultiValue.T a ->+    LLVM.CodeGenFunction r (MultiValue.T b)) ->+   (Exp a -> Exp b)+liftM f (Exp a) = unique (f =<< a)++liftM2 ::+   (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)++liftM3 ::+   (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)+++unliftM1 ::+   (Exp a -> Exp b) ->+   MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T b)+unliftM1 f ix = unExp (f (lift0 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))++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))+++liftTupleM ::+   (forall r.+    LLTuple.ValueOf a ->+    LLVM.CodeGenFunction r (LLTuple.ValueOf b)) ->+   (Exp a -> Exp b)+liftTupleM f = liftM (MultiValue.liftM f)++liftTupleM2 ::+   (forall r.+    LLTuple.ValueOf a -> LLTuple.ValueOf b ->+    LLVM.CodeGenFunction r (LLTuple.ValueOf c)) ->+   (Exp a -> Exp b -> Exp c)+liftTupleM2 f = liftM2 (MultiValue.liftM2 f)++liftTupleM3 ::+   (forall r.+    LLTuple.ValueOf a -> LLTuple.ValueOf b -> LLTuple.ValueOf c ->+    LLVM.CodeGenFunction r (LLTuple.ValueOf d)) ->+   (Exp a -> Exp b -> Exp c -> Exp d)+liftTupleM3 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)++++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 ::+   (LLTuple.ValueOf w ~ LLVM.Value w) =>+   Exp w -> Exp (Enum.T w e)+toEnum = lift1 MultiValue.toEnum++fromEnum ::+   (LLTuple.ValueOf 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
+ src/LLVM/DSL/Parameter.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE TypeFamilies #-}+{-# 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 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 ::+   (Marshal.MV b) =>+   T p b ->+   (forall parameters.+    (Marshal.MV parameters) =>+    (p -> parameters) ->+    (MultiValue.T parameters -> MultiValue.T b) ->+    a) ->+   a+withMulti = with MultiValue.cons++{-# INLINE with #-}+with ::+   (Marshal.MV b) =>+   (b -> MultiValue.T b) ->+   T p b ->+   (forall parameters.+    (Marshal.MV 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.+   (Marshal.MV 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 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/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