diff --git a/Changes.md b/Changes.md new file mode 100644 --- /dev/null +++ b/Changes.md @@ -0,0 +1,19 @@ +# Change log for the `llvm-tf` package + +## 3.1 + +* `ExecutionEngine` is now managed by a `ForeignPtr` with a finalizer. + That is, you must keep the `ExecutionEngine` alive + as long as you call compiled functions. + + `FreePointers` and `getFreePointers` are gone. + +## 3.0.3 + +* `constVector`, `constArray`, `vector` do no longer cycle the vector + Instead they check for the appropriate static length. + +* `FFI.constVector`, `FFI.constArray` must be in IO + in order to proper sequence actions in `Core.Util.constVector`, `Core.Util.constArray`. + Currently, in `Util.constVector` it is possible that `FFI.constArray` + is called too late and thus operates on a released pointer. diff --git a/example/Align.hs b/example/Align.hs --- a/example/Align.hs +++ b/example/Align.hs @@ -1,7 +1,7 @@ module Main (main) where import LLVM.ExecutionEngine - (getTargetData, aBIAlignmentOfType, + (getTargetData, abiAlignmentOfType, storeSizeOfType, intPtrType, littleEndian) import LLVM.Util.Proxy (Proxy(Proxy)) import LLVM.Core (Vector, unsafeTypeRef, initializeNativeTarget) @@ -18,10 +18,10 @@ td <- getTargetData print (littleEndian td, - aBIAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy Word32), - aBIAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy Word64), - aBIAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D4 Float)), - aBIAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D1 Double)), + abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy Word32), + abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy Word64), + abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D4 Float)), + abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D1 Double)), storeSizeOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D4 Float)), intPtrType td ) diff --git a/example/Intrinsic.hs b/example/Intrinsic.hs --- a/example/Intrinsic.hs +++ b/example/Intrinsic.hs @@ -6,7 +6,7 @@ import qualified Foreign.Marshal.Utils as MU import Foreign.Marshal.Alloc (alloca, ) -import Foreign.Storable (Storable, peek, ) +import Foreign.Storable (peek, ) import Foreign.Ptr (Ptr, FunPtr, ) import qualified Type.Data.Num.Decimal as TypeNum @@ -58,13 +58,14 @@ m <- LLVM.newModule floorFunc <- do func <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> modul - EE.runEngineAccessWithModule m $ EE.getPointerToFunction func + EE.runEngineAccessWithModule m $ + EE.getExecutionFunction derefFloorPtr func LLVM.writeBitcodeToFile "floor.bc" m print vector MU.with vector $ \ptr0 -> alloca $ \ptr1 -> do - derefFloorPtr floorFunc ptr0 ptr1 + floorFunc ptr0 ptr1 print =<< peek ptr1 diff --git a/example/Vector.hs b/example/Vector.hs --- a/example/Vector.hs +++ b/example/Vector.hs @@ -4,7 +4,7 @@ import Convert import LLVM.ExecutionEngine - (runEngineAccessWithModule, generateFunction, getPointerToFunction) + (runEngineAccessWithModule, generateFunction, getExecutionFunction) import LLVM.Util.Optimize (optimizeModule, ) import LLVM.Util.Loop (forLoop, ) import LLVM.Core @@ -12,7 +12,8 @@ import qualified Type.Data.Num.Decimal.Number as Dec import Type.Data.Num.Decimal.Literal (D16, ) -import Control.Monad (liftM2, ) +import Control.Monad.IO.Class (liftIO, ) +import Control.Monad (liftM2, when, ) import Data.Word (Word32, ) -- Type of vector elements. @@ -40,22 +41,21 @@ f <- createNamedFunction ExternalLinkage fName $ \ x -> do let v = value (zero :: ConstValue (Vector N T)) - n = Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton N) :: Word32 + n = Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton N) :: Word32 -- Fill the vector with x, x+1, x+2, ... (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do x1' <- add x1 (valueOf (1::T)) - v1' <- insertelement v1 x1 i - return (x1', v1') + v1' <- insertelement v1 x1 i + return (x1', v1') - -- Elementwise cubing of the vector. - vsq <- mul v1 v1 - vcb <- mul vsq v1 + -- Elementwise cubing of the vector. + vcb <- mul v1 =<< mul v1 v1 -- Sum the elements of the vector. s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do y <- extractelement vcb i - add s (y :: Value T) + add s (y :: Value T) -- Update the global variable. vacc <- load acc @@ -64,43 +64,47 @@ ret (s :: Value T) --- liftIO $ dumpValue f + when False $ liftIO $ dumpValue f return f +createFuncModule :: IO (Module, Function (T -> IO T)) +createFuncModule = do + m <- newModule + iovec <- defineModule m $ setTarget hostTriple >> cgvec + return (m, iovec) + main :: IO () main = do -- Initialize jitter initializeNativeTarget - -- First run standard code. - m <- newModule - iovec <- defineModule m $ setTarget hostTriple >> cgvec - fptr <- runEngineAccessWithModule m $ getPointerToFunction iovec - let fvec = convert fptr - - fvec 10 >>= print - - vec <- runEngineAccessWithModule m $ generateFunction iovec + -- First run standard code. + do (m, iovec) <- createFuncModule + fvec <- runEngineAccessWithModule m $ getExecutionFunction convert iovec + fvec 10 >>= print - vec 10 >>= print + do (m, iovec) <- createFuncModule + vec <- runEngineAccessWithModule m $ generateFunction iovec + vec 10 >>= print -- And then optimize and run. - _ <- optimizeModule 1 m + do m <- fmap fst createFuncModule + _ <- optimizeModule 1 m - funcs <- getModuleValues m - print $ map fst funcs + funcs <- getModuleValues m + print $ map fst funcs - let iovec' :: Function (T -> IO T) - Just iovec' = castModuleValue =<< lookup fName funcs - ioretacc' :: Function (IO T) - Just ioretacc' = castModuleValue =<< lookup retAccName funcs + let iovec' :: Function (T -> IO T) + Just iovec' = castModuleValue =<< lookup fName funcs + ioretacc' :: Function (IO T) + Just ioretacc' = castModuleValue =<< lookup retAccName funcs - (vec', retacc') <- - runEngineAccessWithModule m $ - liftM2 (,) (generateFunction iovec') (generateFunction ioretacc') + (vec', retacc') <- + runEngineAccessWithModule m $ + liftM2 (,) (generateFunction iovec') (generateFunction ioretacc') - dumpValue iovec' + when False $ dumpValue iovec' - vec' 10 >>= print - vec' 0 >>= print - retacc' >>= print + vec' 10 >>= print + vec' 0 >>= print + retacc' >>= print diff --git a/llvm-tf.cabal b/llvm-tf.cabal --- a/llvm-tf.cabal +++ b/llvm-tf.cabal @@ -1,5 +1,5 @@ Name: llvm-tf -Version: 3.0.3.3 +Version: 3.1 License: BSD3 License-File: LICENSE Synopsis: Bindings to the LLVM compiler toolkit using type families. @@ -13,13 +13,14 @@ We may change the module names later. . A note on versioning: - The first two version numbers match the version of LLVM. - In order to be able to improve the Haskell API for the same version of LLVM, - I use the first three numbers of the Cabal package version - as the major version in the sense of the Package Versioning Policy PVP. - That is, a bump from 3.0.0 to 3.0.1 may contain substantial API changes, - a bump from 3.0.0.0 to 3.0.0.1 may contain API extensions, - and a bump from 3.0.0.0.0 to 3.0.0.0.1 may contain API-preserving bugfixes. + The versions of this package are loosely based on the LLVM version. + However, we depend on a relatively stable part of LLVM + and provide a relatively stable API for it. + We conform to the Package Versioning Policy PVP, + i.e. we increase the version of this package when its API changes, + but not necessarily when we add support for a new LLVM version. + We support all those LLVM versions + that are supported by our @llvm-ffi@ dependency. Author: Henning Thielemann, Bryan O'Sullivan, Lennart Augustsson Maintainer: Henning Thielemann Stability: experimental @@ -31,13 +32,14 @@ Extra-Source-Files: test/*.hs test/Makefile + Changes.md Source-Repository head Type: darcs Location: http://code.haskell.org/~thielema/llvm-tf/ Source-Repository this - Tag: 3.0.3.3 + Tag: 3.1 Type: darcs Location: http://code.haskell.org/~thielema/llvm-tf/ @@ -53,10 +55,9 @@ Library Default-Language: Haskell98 Build-Depends: - llvm-ffi >= 3.6 && <3.7, + llvm-ffi >= 3.8.1 && <3.9, tfp >=1.0 && <1.1, transformers >=0.3 && <0.6, - process >=1.1 && <1.5, storable-record >=0.0.2 && <0.1, enumset >=0.0.4 && <0.1, fixed-length >=0.2 && <0.3, @@ -267,6 +268,7 @@ Build-Depends: llvm-tf, tfp, + transformers, base Else Buildable: False diff --git a/src/LLVM/Core.hs b/src/LLVM/Core.hs --- a/src/LLVM/Core.hs +++ b/src/LLVM/Core.hs @@ -32,7 +32,6 @@ -- * Modules Module, newModule, newNamedModule, defineModule, destroyModule, createModule, setTarget, FFI.hostTriple, - ModuleProvider, createModuleProviderForExistingModule, PassManager, createPassManager, createFunctionPassManager, writeBitcodeToFile, readBitcodeFromFile, getModuleValues, getFunctions, getGlobalVariables, ModuleValue, castModuleValue, diff --git a/src/LLVM/Core/CodeGen.hs b/src/LLVM/Core/CodeGen.hs --- a/src/LLVM/Core/CodeGen.hs +++ b/src/LLVM/Core/CodeGen.hs @@ -56,6 +56,7 @@ import Foreign.Ptr (Ptr, minusPtr, nullPtr, FunPtr, castFunPtrToPtr) import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.IO.Class (liftIO) import Control.Monad (liftM, when) import qualified Data.NonEmpty as NonEmpty @@ -66,6 +67,8 @@ import Data.Maybe.HT (toMaybe) import Data.Maybe (fromMaybe) +import Text.Printf (printf) + -------------------------------------- -- | Create a new module. @@ -599,6 +602,12 @@ forall a n . (IsSized a, Dec.Natural n) => [ConstValue a] -> ConstValue (Array n a) constArray xs = unsafeConstValue $ do + let m = length xs + n = Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n) + when (m /= n) $ + error $ + printf "LLVM.constArray: number of array elements (%d) mismatches typed array length (%d)" + m n typ <- typeRef (LP.Proxy :: LP.Proxy a) U.constArray typ $ map unConstValue xs diff --git a/src/LLVM/Core/CodeGenMonad.hs b/src/LLVM/Core/CodeGenMonad.hs --- a/src/LLVM/Core/CodeGenMonad.hs +++ b/src/LLVM/Core/CodeGenMonad.hs @@ -7,8 +7,6 @@ addFunctionMapping, -- * Function code generation CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns, - -- * Reexport - liftIO ) where import LLVM.Core.Util (Module, Builder, Function) diff --git a/src/LLVM/Core/Instructions.hs b/src/LLVM/Core/Instructions.hs --- a/src/LLVM/Core/Instructions.hs +++ b/src/LLVM/Core/Instructions.hs @@ -89,6 +89,7 @@ import Foreign.Ptr (Ptr, FunPtr, ) import Foreign.C (CInt, CUInt) +import Control.Monad.IO.Class (liftIO) import Control.Monad (liftM) import Data.Typeable (Typeable) diff --git a/src/LLVM/Core/Util.hs b/src/LLVM/Core/Util.hs --- a/src/LLVM/Core/Util.hs +++ b/src/LLVM/Core/Util.hs @@ -5,8 +5,6 @@ -- * Module handling Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile, getModuleValues, getFunctions, getGlobalVariables, valueHasType, - -- * Module provider handling - ModuleProvider(..), withModuleProvider, createModuleProviderForExistingModule, -- * Pass manager handling PassManager(..), withPassManager, createPassManager, createFunctionPassManager, runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager, @@ -48,7 +46,7 @@ import qualified LLVM.FFI.Transforms.Scalar as FFI import Foreign.C.String (withCString, withCStringLen, CString, peekCString) -import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_, withForeignPtr) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray) import Foreign.Marshal.Alloc (alloca) @@ -188,28 +186,6 @@ FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")" -------------------------------------- --- Handle module providers - --- | A module provider is used by the code generator to get access to a module. -newtype ModuleProvider = ModuleProvider { - fromModuleProvider :: ForeignPtr FFI.ModuleProvider - } - deriving (Show, Typeable) - -withModuleProvider :: ModuleProvider -> (FFI.ModuleProviderRef -> IO a) - -> IO a -withModuleProvider = withForeignPtr . fromModuleProvider - --- | Turn a module into a module provider. -createModuleProviderForExistingModule :: Module -> IO ModuleProvider -createModuleProviderForExistingModule modul = - withModule modul $ \modulPtr -> do - ptr <- FFI.createModuleProviderForExistingModule modulPtr - -- MPs given to the EE get taken over, so we should not GC them. - liftM ModuleProvider $ newForeignPtr_ {-FFI.ptrDisposeModuleProvider-} ptr - - --------------------------------------- -- Handle instruction builders newtype Builder = Builder { @@ -379,10 +355,10 @@ liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr -- | Create a pass manager for a module. -createFunctionPassManager :: ModuleProvider -> IO PassManager +createFunctionPassManager :: Module -> IO PassManager createFunctionPassManager modul = - withModuleProvider modul $ \modulPtr -> do - ptr <- FFI.createFunctionPassManager modulPtr + withModule modul $ \modulPtr -> do + ptr <- FFI.createFunctionPassManagerForModule modulPtr liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr -- | Add a control flow graph simplification pass to the manager. diff --git a/src/LLVM/Core/Vector.hs b/src/LLVM/Core/Vector.hs --- a/src/LLVM/Core/Vector.hs +++ b/src/LLVM/Core/Vector.hs @@ -121,7 +121,7 @@ Target.storeSizeOfType ourTargetData $ unsafeTypeRef $ Proxy.fromValue a alignment a = - Target.aBIAlignmentOfType ourTargetData $ + Target.abiAlignmentOfType ourTargetData $ unsafeTypeRef $ Proxy.fromValue a peek = Store.peekApplicative poke = Store.poke diff --git a/src/LLVM/ExecutionEngine.hs b/src/LLVM/ExecutionEngine.hs --- a/src/LLVM/ExecutionEngine.hs +++ b/src/LLVM/ExecutionEngine.hs @@ -3,14 +3,16 @@ module LLVM.ExecutionEngine( -- * Execution engine EngineAccess, + ExecutionEngine, + getEngine, runEngineAccess, runEngineAccessWithModule, - addModuleProvider, addModule, + ExecutionFunction, + getExecutionFunction, getPointerToFunction, addFunctionValue, addGlobalMappings, - getFreePointers, FreePointers, -- * Translation Translatable, Generic, generateFunction, diff --git a/src/LLVM/ExecutionEngine/Engine.hs b/src/LLVM/ExecutionEngine/Engine.hs --- a/src/LLVM/ExecutionEngine/Engine.hs +++ b/src/LLVM/ExecutionEngine/Engine.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} module LLVM.ExecutionEngine.Engine( EngineAccess, + ExecutionEngine(..), + getEngine, runEngineAccess, runEngineAccessWithModule, - addModuleProvider, addModule, runEngineAccessInterpreterWithModule, getExecutionEngineTargetData, + ExecutionFunction, + getExecutionFunction, getPointerToFunction, + addModule, addFunctionValue, addGlobalMappings, - getFreePointers, FreePointers, runFunction, getRunFunction, GenericValue, Generic(..) ) where @@ -22,30 +22,27 @@ import LLVM.Core.CodeGen (Value(..), Function) import LLVM.Core.CodeGenMonad (GlobalMappings(..)) -import LLVM.Core.Util - (Module, withModule, - ModuleProvider, withModuleProvider, createModule) +import LLVM.Core.Util (Module, withModule, createModule) import LLVM.Core.Type (IsFirstClass, typeRef) import LLVM.Util.Proxy (Proxy(Proxy)) import qualified LLVM.FFI.ExecutionEngine as FFI import qualified LLVM.FFI.Target as FFI -import qualified LLVM.FFI.Core as FFI - (ModuleProviderRef, ValueRef, consBool, deconsBool, ) +import qualified LLVM.FFI.Core as FFI (consBool, deconsBool, ) -import qualified Control.Monad.Trans.State as MS +import qualified Control.Monad.Trans.Reader as MR import Control.Monad.IO.Class (MonadIO, liftIO, ) import Control.Monad (liftM, ) -import Control.Applicative (Applicative, pure, (<*>), ) +import Control.Applicative (Applicative, pure, (<*>), (<$>), ) import qualified Data.EnumSet as EnumSet -import Data.Typeable (Typeable) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) import Foreign.Marshal.Alloc (alloca, free) import Foreign.Marshal.Array (withArrayLen) -import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) +import Foreign.ForeignPtr + (ForeignPtr, newForeignPtr, withForeignPtr, touchForeignPtr) import Foreign.C.String (peekCString) import Foreign.Ptr (Ptr, FunPtr, ) import Foreign.Storable (peek) @@ -53,8 +50,16 @@ import System.IO.Unsafe (unsafePerformIO) +newtype + ExecutionEngine = ExecutionEngine { + fromEngine :: ForeignPtr FFI.ExecutionEngine + } + +withEngine :: ExecutionEngine -> (FFI.ExecutionEngineRef -> IO a) -> IO a +withEngine = withForeignPtr . fromEngine + createExecutionEngineForModule :: - Bool -> FFI.EngineKindSet -> Module -> IO FFI.ExecutionEngineRef + Bool -> FFI.EngineKindSet -> Module -> IO ExecutionEngine createExecutionEngineForModule hostCPU kind m = alloca $ \eePtr -> alloca $ \errPtr -> do @@ -75,18 +80,14 @@ free err ioError . userError $ errStr else - peek eePtr + liftM ExecutionEngine $ + newForeignPtr FFI.ptrDisposeExecutionEngine =<< + peek eePtr -getTheEngine :: FFI.EngineKindSet -> Module -> IO FFI.ExecutionEngineRef +getTheEngine :: FFI.EngineKindSet -> Module -> IO ExecutionEngine getTheEngine = createExecutionEngineForModule True -data EAState = EAState { - ea_engine :: FFI.ExecutionEngineRef, - ea_providers :: [ModuleProvider] - } - deriving (Show, Typeable) - -newtype EngineAccess a = EA (MS.StateT EAState IO a) +newtype EngineAccess a = EA (MR.ReaderT ExecutionEngine IO a) deriving (Functor, Applicative, Monad, MonadIO) -- |The LLVM execution engine is encapsulated so it cannot be accessed directly. @@ -94,35 +95,28 @@ -- so access to it is wrapped in a monad. runEngineAccess :: EngineAccess a -> IO a runEngineAccess (EA body) = do - eePtr <- getTheEngine FFI.kindEither =<< createModule "__empty__" - MS.evalStateT body $ EAState { ea_engine = eePtr, ea_providers = [] } - -- XXX should remove module providers again + MR.runReaderT body =<< getTheEngine FFI.kindEither =<< createModule "__empty__" runEngineAccessWithModule :: Module -> EngineAccess a -> IO a runEngineAccessWithModule m (EA body) = do - eePtr <- getTheEngine FFI.kindEither m - MS.evalStateT body $ EAState { ea_engine = eePtr, ea_providers = [] } + MR.runReaderT body =<< getTheEngine FFI.kindEither m runEngineAccessInterpreterWithModule :: Module -> EngineAccess a -> IO a runEngineAccessInterpreterWithModule m (EA body) = do - eePtr <- getTheEngine FFI.kindInterpreter m - MS.evalStateT body $ EAState { ea_engine = eePtr, ea_providers = [] } + MR.runReaderT body =<< getTheEngine FFI.kindInterpreter m -addModuleProvider :: ModuleProvider -> EngineAccess () -addModuleProvider prov = do - ea <- EA MS.get - EA $ MS.put ea{ ea_providers = prov : ea_providers ea } - liftIO $ withModuleProvider prov $ \ provPtr -> - FFI.addModuleProvider (ea_engine ea) provPtr +getEngine :: EngineAccess ExecutionEngine +getEngine = EA MR.ask -getEngine :: EngineAccess FFI.ExecutionEngineRef -getEngine = EA $ MS.gets ea_engine +accessEngine :: (FFI.ExecutionEngineRef -> IO a) -> EngineAccess a +accessEngine act = do + engine <- getEngine + liftIO $ withEngine engine act getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef -getExecutionEngineTargetData = do - eePtr <- getEngine - liftIO $ FFI.getExecutionEngineTargetData eePtr +getExecutionEngineTargetData = + accessEngine FFI.getExecutionEngineTargetData {- | In contrast to 'generateFunction' this compiles a function once. @@ -132,12 +126,34 @@ If the function calls back into Haskell code, you also have to set the function addresses using 'addFunctionValue' or 'addGlobalMappings'. + +You must keep the execution engine alive +as long as you want to call the function. +Better use 'getExecutionFunction' which handles this for you. -} getPointerToFunction :: Function f -> EngineAccess (FunPtr f) -getPointerToFunction (Value f) = do - eePtr <- getEngine - liftIO $ FFI.getPointerToGlobal eePtr f +getPointerToFunction (Value f) = + accessEngine $ \eePtr -> FFI.getPointerToFunction eePtr f +class ExecutionFunction f where + keepAlive :: ExecutionEngine -> f -> f + +instance ExecutionFunction (IO a) where + keepAlive engine act = do + a <- act + touchForeignPtr (fromEngine engine) + return a + +instance ExecutionFunction f => ExecutionFunction (a -> f) where + keepAlive engine act = keepAlive engine . act + +getExecutionFunction :: + (ExecutionFunction f) => (FunPtr f -> f) -> Function f -> EngineAccess f +getExecutionFunction importer (Value f) = do + engine <- getEngine + liftIO $ withEngine engine $ \eePtr -> + keepAlive engine . importer <$> FFI.getPointerToFunction eePtr f + {- | Tell LLVM the address of an external function if it cannot resolve a name automatically. @@ -145,36 +161,20 @@ with 'staticFunction' instead of 'externFunction'. -} addFunctionValue :: Function f -> FunPtr f -> EngineAccess () -addFunctionValue (Value g) f = do - eePtr <- getEngine - liftIO $ FFI.addFunctionMapping eePtr g f +addFunctionValue (Value g) f = + accessEngine $ \eePtr -> FFI.addFunctionMapping eePtr g f {- | Pass a list of global mappings to LLVM that can be obtained from 'LLVM.Core.getGlobalMappings'. -} addGlobalMappings :: GlobalMappings -> EngineAccess () -addGlobalMappings (GlobalMappings gms) = - liftIO . gms =<< getEngine +addGlobalMappings (GlobalMappings gms) = accessEngine gms addModule :: Module -> EngineAccess () -addModule m = do - eePtr <- getEngine - liftIO $ U.withModule m $ FFI.addModule eePtr +addModule m = + accessEngine $ \eePtr -> U.withModule m $ FFI.addModule eePtr --- | Get all the information needed to free a function. --- Freeing code might have to be done from a (C) finalizer, so it has to done from C. --- The function c_freeFunctionObject take these pointers as arguments and frees the function. -type FreePointers = (FFI.ExecutionEngineRef, FFI.ModuleProviderRef, FFI.ValueRef) -{-# WARNING getFreePointers "Function returns undefined ModuleProviderRef if there is no module provider" #-} -getFreePointers :: Function f -> EngineAccess FreePointers -getFreePointers (Value f) = do - ea <- EA MS.get - liftIO $ do - let ret mpp = return (ea_engine ea, mpp, f) - case ea_providers ea of - prov : _ -> withModuleProvider prov ret - [] -> ret $ error "getFreePointers: no module provider" -------------------------------------- @@ -201,9 +201,10 @@ getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue) getRunFunction = do - eePtr <- getEngine + engine <- getEngine return $ \ func args -> withAll args $ \argLen argPtr -> + withEngine engine $ \eePtr -> createGenericValueWith $ FFI.runFunction eePtr func (fromIntegral argLen) argPtr diff --git a/src/LLVM/ExecutionEngine/Target.hs b/src/LLVM/ExecutionEngine/Target.hs --- a/src/LLVM/ExecutionEngine/Target.hs +++ b/src/LLVM/ExecutionEngine/Target.hs @@ -2,9 +2,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where +import qualified LLVM.ExecutionEngine.Engine as EE import LLVM.Core.Data (WordN) -import LLVM.ExecutionEngine.Engine - (runEngineAccess, getExecutionEngineTargetData) import qualified LLVM.FFI.Core as FFI import qualified LLVM.FFI.Target as FFI @@ -12,7 +11,12 @@ import qualified Type.Data.Num.Decimal.Number as Dec import Type.Base.Proxy (Proxy) +import Foreign.ForeignPtr + (ForeignPtr, newForeignPtr, withForeignPtr, touchForeignPtr) import Foreign.C.String (withCString) + +import Control.Monad (liftM2) +import Control.Applicative ((<$>)) import Data.Typeable (Typeable) import Data.Maybe (fromMaybe) import System.IO.Unsafe (unsafePerformIO) @@ -21,8 +25,8 @@ type Type = FFI.TypeRef data TargetData = TargetData { - aBIAlignmentOfType :: Type -> Int, - aBISizeOfType :: Type -> Int, + abiAlignmentOfType :: Type -> Int, + abiSizeOfType :: Type -> Int, littleEndian :: Bool, callFrameAlignmentOfType :: Type -> Int, -- elementAtOffset :: Type -> Word64 -> Int, @@ -44,27 +48,43 @@ g _ = error "withIntPtrType: argument used" sz = pointerSize $ unsafePerformIO getTargetData --- Gets the target data for the JIT target. -getEngineTargetDataRef :: IO FFI.TargetDataRef -getEngineTargetDataRef = runEngineAccess getExecutionEngineTargetData +unsafeIO :: ForeignPtr a -> IO b -> b +unsafeIO fptr act = + unsafePerformIO $ do x <- act; touchForeignPtr fptr; return x + +unsafeIntIO :: (Integral i, Num j) => ForeignPtr a -> IO i -> j +unsafeIntIO fptr = fromIntegral . unsafeIO fptr + -- Normally the TargetDataRef never changes, so the operation -- are really pure functions. -makeTargetData :: FFI.TargetDataRef -> TargetData -makeTargetData r = TargetData { - aBIAlignmentOfType = fromIntegral . unsafePerformIO . FFI.aBIAlignmentOfType r, - aBISizeOfType = fromIntegral . unsafePerformIO . FFI.aBISizeOfType r, - littleEndian = unsafePerformIO (FFI.byteOrder r) /= FFI.bigEndian, - callFrameAlignmentOfType = fromIntegral . unsafePerformIO . FFI.callFrameAlignmentOfType r, - intPtrType = unsafePerformIO $ FFI.intPtrType r, - pointerSize = fromIntegral $ unsafePerformIO $ FFI.pointerSize r, - preferredAlignmentOfType = fromIntegral . unsafePerformIO . FFI.preferredAlignmentOfType r, - sizeOfTypeInBits = fromIntegral . unsafePerformIO . FFI.sizeOfTypeInBits r, - storeSizeOfType = fromIntegral . unsafePerformIO . FFI.storeSizeOfType r +makeTargetData :: ForeignPtr a -> FFI.TargetDataRef -> TargetData +makeTargetData fptr r = TargetData { + abiAlignmentOfType = unsafeIntIO fptr . FFI.abiAlignmentOfType r, + abiSizeOfType = unsafeIntIO fptr . FFI.abiSizeOfType r, + littleEndian = unsafeIO fptr (FFI.byteOrder r) /= FFI.bigEndian, + callFrameAlignmentOfType = unsafeIntIO fptr . FFI.callFrameAlignmentOfType r, + intPtrType = unsafeIO fptr $ FFI.intPtrType r, + pointerSize = unsafeIntIO fptr $ FFI.pointerSize r, + preferredAlignmentOfType = unsafeIntIO fptr . FFI.preferredAlignmentOfType r, + sizeOfTypeInBits = unsafeIntIO fptr . FFI.sizeOfTypeInBits r, + storeSizeOfType = unsafeIntIO fptr . FFI.storeSizeOfType r } +-- Gets the target data for the JIT target. getTargetData :: IO TargetData -getTargetData = fmap makeTargetData getEngineTargetDataRef +getTargetData = + EE.runEngineAccess $ + liftM2 makeTargetData + (EE.fromEngine <$> EE.getEngine) + EE.getExecutionEngineTargetData +createTargetData :: String -> IO (ForeignPtr FFI.TargetData) +createTargetData s = + newForeignPtr FFI.ptrDisposeTargetData =<< + withCString s FFI.createTargetData + targetDataFromString :: String -> TargetData -targetDataFromString s = makeTargetData $ unsafePerformIO $ withCString s FFI.createTargetData +targetDataFromString s = unsafePerformIO $ do + td <- createTargetData s + withForeignPtr td $ return . makeTargetData td diff --git a/src/LLVM/Util/File.hs b/src/LLVM/Util/File.hs --- a/src/LLVM/Util/File.hs +++ b/src/LLVM/Util/File.hs @@ -1,60 +1,10 @@ -module LLVM.Util.File (writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where - -import qualified LLVM.ExecutionEngine as EE -import LLVM.ExecutionEngine (Translatable) -import LLVM.Core - (CodeGenModule, IsFunction, Module, Function, - newModule, defineModule, - getValueName, getModuleValues, castModuleValue, - writeBitcodeToFile, readBitcodeFromFile) - -import System.Process (system) +module LLVM.Util.File (writeCodeGenModule) where +import qualified LLVM.Core as LLVM -writeCodeGenModule :: FilePath -> CodeGenModule a -> IO () -writeCodeGenModule name f = do - m <- newModule - _ <- defineModule m f - writeBitcodeToFile name m - -optimize :: FilePath -> IO () -optimize name = do - _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name - return () - -optimizeFunction :: - (IsFunction t, Translatable t) => - CodeGenModule (Function t) -> IO (Function t) -optimizeFunction = fmap snd . optimizeFunction' - -optimizeFunction' :: - (IsFunction t, Translatable t) => - CodeGenModule (Function t) -> IO (Module, Function t) -optimizeFunction' mdl = do - m <- newModule - mf <- defineModule m mdl - fName <- getValueName mf - - let name = "__tmp__" ++ fName ++ ".bc" - writeBitcodeToFile name m - - optimize name - - m' <- readBitcodeFromFile name - funcs <- getModuleValues m' - --- removeFile name - - let Just mf' = castModuleValue =<< lookup fName funcs - - return (m', mf') - -optimizeFunctionCG :: - (IsFunction t, Translatable t) => - CodeGenModule (Function t) -> IO t -optimizeFunctionCG mdl = do - (m', mf') <- optimizeFunction' mdl - EE.runEngineAccess $ do - EE.addModule m' - EE.generateFunction mf' +writeCodeGenModule :: FilePath -> LLVM.CodeGenModule a -> IO () +writeCodeGenModule path f = do + m <- LLVM.newModule + _ <- LLVM.defineModule m f + LLVM.writeBitcodeToFile path m