diff --git a/knead.cabal b/knead.cabal --- a/knead.cabal +++ b/knead.cabal @@ -1,5 +1,5 @@ Name: knead -Version: 0.2 +Version: 0.2.0.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -47,7 +47,7 @@ Build-Type: Simple Source-Repository this - Tag: 0.2 + Tag: 0.2.0.1 Type: darcs Location: http://hub.darcs.net/thielema/knead/ @@ -57,10 +57,11 @@ Library Build-Depends: - llvm-extra >=0.6 && <0.7, - llvm-tf >=3.0.3 && <3.0.4, + llvm-extra >=0.6 && <0.8, + llvm-tf >=3.1 && <3.2, storable-tuple >=0.0 && <0.1, storable-record >=0.0.3 && <0.1, + transformers >=0.3 && <0.6, utility-ht >=0.0.1 && <0.1, base >=4 && <5 diff --git a/src/Data/Array/Knead/Code.hs b/src/Data/Array/Knead/Code.hs --- a/src/Data/Array/Knead/Code.hs +++ b/src/Data/Array/Knead/Code.hs @@ -4,17 +4,19 @@ import qualified Data.Array.Knead.Index.Nested.Shape as Shape import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Execution as Exec import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Util.Optimize as Opt import qualified LLVM.Core as LLVM -import Foreign.Ptr (Ptr, ) +import Foreign.Ptr (Ptr, FunPtr, ) import Control.Monad (void, liftM2, when, ) +import Control.Applicative ((<$>), ) +import Data.Functor.Compose (Compose(Compose)) + getElementPtr :: (Shape.C sh, Shape.Index sh ~ ix) => MultiValue.T sh -> LLVM.Value (Ptr a) -> @@ -25,22 +27,30 @@ LLVM.getElementPtr ptr (n, ()) -compile :: - (Exec.Compile funcs) => - String -> - LLVM.CodeGenModule (Exec.LLVMFunction funcs) -> - IO funcs -compile name bld = do +compile :: String -> Exec funcs -> IO funcs +compile name (Compose bld) = do LLVM.initializeNativeTarget m <- LLVM.newModule (funcs, mappings) <- - LLVM.defineModule m $ - liftM2 (,) bld LLVM.getGlobalMappings + LLVM.defineModule m $ do + LLVM.setTarget LLVM.hostTriple + liftM2 (,) bld LLVM.getGlobalMappings LLVM.writeBitcodeToFile (name ++ ".bc") m when False $ do void $ Opt.optimizeModule 3 m LLVM.writeBitcodeToFile (name ++ "-opt.bc") m - EE.runEngineAccess $ - EE.addModule m >> - EE.addGlobalMappings mappings >> - Exec.compile funcs + EE.runEngineAccessWithModule m $ + EE.addGlobalMappings mappings >> funcs + + +type Exec = Compose LLVM.CodeGenModule EE.EngineAccess +type Importer f = FunPtr f -> f + +createFunction :: + (EE.ExecutionFunction f, LLVM.FunctionArgs f) => + Importer f -> String -> LLVM.FunctionCodeGen f -> Exec f +createFunction importer name f = + Compose $ + EE.getExecutionFunction importer + <$> + LLVM.createNamedFunction LLVM.ExternalLinkage name f diff --git a/src/Data/Array/Knead/Parameterized/Physical.hs b/src/Data/Array/Knead/Parameterized/Physical.hs --- a/src/Data/Array/Knead/Parameterized/Physical.hs +++ b/src/Data/Array/Knead/Parameterized/Physical.hs @@ -18,6 +18,7 @@ import qualified Data.Array.Knead.Parameter as Param import qualified Data.Array.Knead.Index.Nested.Shape as Shape import qualified Data.Array.Knead.Expression as Expr +import qualified Data.Array.Knead.Code as Code import Data.Array.Knead.Expression (Exp, unExp, ) import Data.Array.Knead.Code (getElementPtr, compile, ) @@ -36,7 +37,7 @@ import Control.Exception (bracket, ) import Control.Monad.HT (void, (<=<), ) -import Control.Monad (liftM2, ) +import Control.Applicative (liftA2, ) import Data.Tuple.HT (mapFst, ) import Data.Word (Word32, ) @@ -75,7 +76,7 @@ the (Sym.Array arr create delete) = do func <- compile "the" $ - LLVM.createNamedFunction LLVM.ExternalLinkage "eval" $ + Code.createFunction callThe "eval" $ \paramPtr resultPtr -> do param <- Memory.load paramPtr case arr param of @@ -85,7 +86,7 @@ bracket (create p) (delete . fst) $ \(_ctx, param) -> with param $ \pptr -> alloca $ \aptr -> - callThe func (MultiValueMemory.castStructPtr pptr) (MultiValueMemory.castStructPtr aptr) >> + func (MultiValueMemory.castStructPtr pptr) (MultiValueMemory.castStructPtr aptr) >> peek aptr @@ -103,7 +104,7 @@ renderShape (Sym.Array arr create delete) = do fsh <- compile "renderShape" $ - LLVM.createNamedFunction LLVM.ExternalLinkage "shape" $ + Code.createFunction callShaper "shape" $ \paramPtr resultPtr -> do param <- Memory.load paramPtr case arr param of @@ -117,7 +118,7 @@ with param $ \pptr -> do let lpptr = MultiValueMemory.castStructPtr pptr let lshptr = MultiValueMemory.castStructPtr shptr - n <- callShaper fsh lpptr lshptr + n <- fsh lpptr lshptr sh <- peek shptr return (sh, n) @@ -129,8 +130,8 @@ render (Sym.Array arr create delete) = do (fsh, farr) <- compile "render" $ - liftM2 (,) - (LLVM.createNamedFunction LLVM.ExternalLinkage "shape" $ + liftA2 (,) + (Code.createFunction callShaper "shape" $ \paramPtr resultPtr -> do param <- Memory.load paramPtr case arr param of @@ -138,7 +139,7 @@ sh <- unExp esh MultiValueMemory.store sh resultPtr Shape.sizeCode sh >>= LLVM.ret) - (LLVM.createNamedFunction LLVM.ExternalLinkage "fill" $ + (Code.createFunction callRenderer "fill" $ \paramPtr shapePtr bufferPtr -> do param <- Memory.load paramPtr case arr param of @@ -154,10 +155,10 @@ with param $ \pptr -> do let lpptr = MultiValueMemory.castStructPtr pptr let lshptr = MultiValueMemory.castStructPtr shptr - n <- callShaper fsh lpptr lshptr + n <- fsh lpptr lshptr fptr <- mallocForeignPtrArray (fromIntegral n) withForeignPtr fptr $ - callRenderer farr lpptr lshptr . MultiValueMemory.castStructPtr + farr lpptr lshptr . MultiValueMemory.castStructPtr sh <- peek shptr return (Phys.Array sh fptr) @@ -180,8 +181,8 @@ (fsh, farr) <- compile "scatter" $ - liftM2 (,) - (LLVM.createNamedFunction LLVM.ExternalLinkage "shape" $ + liftA2 (,) + (Code.createFunction callShaper "shape" $ \paramPtr resultPtr -> do param <- Memory.load paramPtr case arrBase param of @@ -189,7 +190,7 @@ sh <- unExp esh MultiValueMemory.store sh resultPtr Shape.sizeCode sh >>= LLVM.ret) - (LLVM.createNamedFunction LLVM.ExternalLinkage "fill" $ + (Code.createFunction callScatterer "fill" $ \paramBasePtr paramMapPtr shapePtr bufferPtr -> do paramBase <- Memory.load paramBasePtr paramMap <- Memory.load paramMapPtr @@ -219,10 +220,10 @@ let paramBaseMVPtr = MultiValueMemory.castStructPtr paramBasePtr let paramMapMVPtr = MultiValueMemory.castStructPtr paramMapPtr let shapeMVPtr = MultiValueMemory.castStructPtr shptr - n <- callShaper fsh paramBaseMVPtr shapeMVPtr + n <- fsh paramBaseMVPtr shapeMVPtr fptr <- mallocForeignPtrArray (fromIntegral n) withForeignPtr fptr $ - callScatterer farr paramBaseMVPtr paramMapMVPtr shapeMVPtr . + farr paramBaseMVPtr paramMapMVPtr shapeMVPtr . MultiValueMemory.castStructPtr sh <- peek shptr return (Phys.Array sh fptr) diff --git a/src/Data/Array/Knead/Simple/Physical.hs b/src/Data/Array/Knead/Simple/Physical.hs --- a/src/Data/Array/Knead/Simple/Physical.hs +++ b/src/Data/Array/Knead/Simple/Physical.hs @@ -16,6 +16,7 @@ import qualified Data.Array.Knead.Simple.Private as Sym import qualified Data.Array.Knead.Index.Nested.Shape as Shape import qualified Data.Array.Knead.Expression as Expr +import qualified Data.Array.Knead.Code as Code import Data.Array.Knead.Expression (Exp, unExp, ) import Data.Array.Knead.Code (getElementPtr, compile, ) @@ -35,7 +36,7 @@ import Foreign.Ptr (FunPtr, Ptr, ) import Control.Monad.HT (void, ) -import Control.Monad (liftM2, ) +import Control.Applicative (liftA2, ) import Data.Word (Word32, ) import Prelude hiding (scanl1, ) @@ -110,17 +111,16 @@ alloca $ \shptr -> do (fsh, farr) <- compile name $ - liftM2 (,) - (LLVM.createNamedFunction LLVM.ExternalLinkage "shape" $ \ptr -> do + liftA2 (,) + (Code.createFunction callShaper "shape" $ \ptr -> do sh <- unExp esh MultiValueMemory.store sh ptr Shape.sizeCode sh >>= LLVM.ret) - (LLVM.createNamedFunction LLVM.ExternalLinkage "fill" code) + (Code.createFunction callRenderer "fill" code) let lshptr = MultiValueMemory.castStructPtr shptr - n <- callShaper fsh lshptr + n <- fsh lshptr fptr <- mallocForeignPtrArray (fromIntegral n) - withForeignPtr fptr $ - callRenderer farr lshptr . MultiValueMemory.castStructPtr + withForeignPtr fptr $ farr lshptr . MultiValueMemory.castStructPtr sh <- peek shptr return (Array sh fptr) @@ -152,7 +152,7 @@ acc1 <- Maybe.run macc0 (return a) (flip (Expr.unliftM2 f) a) flip Memory.store ptr0 acc1 ptrK1 <- - liftM2 (,) + liftA2 (,) (A.advanceArrayElementPtr ptr0) (A.inc k0) return (ptrK1, Maybe.just acc1)