llvm-tf 3.0.3.3 → 3.1
raw patch · 15 files changed
+213/−231 lines, 15 filesdep −processdep ~llvm-ffidep ~transformers
Dependencies removed: process
Dependency ranges changed: llvm-ffi, transformers
Files
- Changes.md +19/−0
- example/Align.hs +5/−5
- example/Intrinsic.hs +4/−3
- example/Vector.hs +38/−34
- llvm-tf.cabal +13/−11
- src/LLVM/Core.hs +0/−1
- src/LLVM/Core/CodeGen.hs +9/−0
- src/LLVM/Core/CodeGenMonad.hs +0/−2
- src/LLVM/Core/Instructions.hs +1/−0
- src/LLVM/Core/Util.hs +4/−28
- src/LLVM/Core/Vector.hs +1/−1
- src/LLVM/ExecutionEngine.hs +4/−2
- src/LLVM/ExecutionEngine/Engine.hs +68/−67
- src/LLVM/ExecutionEngine/Target.hs +40/−20
- src/LLVM/Util/File.hs +7/−57
+ Changes.md view
@@ -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.
example/Align.hs view
@@ -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 )
example/Intrinsic.hs view
@@ -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
example/Vector.hs view
@@ -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
llvm-tf.cabal view
@@ -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 <llvm@henning-thielemann.de> 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
src/LLVM/Core.hs view
@@ -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,
src/LLVM/Core/CodeGen.hs view
@@ -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
src/LLVM/Core/CodeGenMonad.hs view
@@ -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)
src/LLVM/Core/Instructions.hs view
@@ -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)
src/LLVM/Core/Util.hs view
@@ -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.
src/LLVM/Core/Vector.hs view
@@ -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
src/LLVM/ExecutionEngine.hs view
@@ -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,
src/LLVM/ExecutionEngine/Engine.hs view
@@ -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
src/LLVM/ExecutionEngine/Target.hs view
@@ -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
src/LLVM/Util/File.hs view
@@ -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