diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/llvm-dsl.cabal b/llvm-dsl.cabal new file mode 100644 --- /dev/null +++ b/llvm-dsl.cabal @@ -0,0 +1,73 @@ +Cabal-Version: 2.2 +Name: llvm-dsl +Version: 0.0 +License: BSD-3-Clause +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +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 diff --git a/src/LLVM/DSL/Debug/Counter.hs b/src/LLVM/DSL/Debug/Counter.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/DSL/Debug/Counter.hs @@ -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 diff --git a/src/LLVM/DSL/Debug/Marshal.hs b/src/LLVM/DSL/Debug/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/DSL/Debug/Marshal.hs @@ -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 diff --git a/src/LLVM/DSL/Debug/StablePtr.hs b/src/LLVM/DSL/Debug/StablePtr.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/DSL/Debug/StablePtr.hs @@ -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 diff --git a/src/LLVM/DSL/Execution.hs b/src/LLVM/DSL/Execution.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/DSL/Execution.hs @@ -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) diff --git a/src/LLVM/DSL/Expression.hs b/src/LLVM/DSL/Expression.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/DSL/Expression.hs @@ -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 diff --git a/src/LLVM/DSL/Parameter.hs b/src/LLVM/DSL/Parameter.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/DSL/Parameter.hs @@ -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 diff --git a/src/debug-off/LLVM/DSL/Dump.hs b/src/debug-off/LLVM/DSL/Dump.hs new file mode 100644 --- /dev/null +++ b/src/debug-off/LLVM/DSL/Dump.hs @@ -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 () diff --git a/src/debug-on/LLVM/DSL/Dump.hs b/src/debug-on/LLVM/DSL/Dump.hs new file mode 100644 --- /dev/null +++ b/src/debug-on/LLVM/DSL/Dump.hs @@ -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