Remove EngineAccess wrapper

Author: NathanHowell

LLVM/Core/Vector.hs

@@ -5,6 +5,7 @@ import Data.Function
 import Data.TypeLevel hiding (Eq, (+), (==), (-), (*), succ, pred, div, mod, divMod, logBase)
 import LLVM.Core.Type
 import LLVM.Core.Data
+import LLVM.ExecutionEngine (ExecutionEngine)
 import LLVM.ExecutionEngine.Target
 import Foreign.Ptr(castPtr)
 import Foreign.Storable(Storable(..))
@@ -36,15 +37,17 @@ instance (IsPrimitive a) => MkVector (a, a, a, a, a, a, a, a) D8 a where
     fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8)
     fromVector _ = error "fromVector: impossible"
 
+{-
 instance (Storable a, Pos n, IsPrimitive a) => Storable (Vector n a) where
     sizeOf a = storeSizeOfType ourTargetData (typeRef a)
     alignment a = aBIAlignmentOfType ourTargetData (typeRef a)
     peek p = fmap Vector $ peekArray (toNum (undefined :: n)) (castPtr p :: Ptr a)
     poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs
+-}
 
 -- XXX The JITer target data.  This isn't really right.
-ourTargetData :: TargetData
-ourTargetData = unsafePerformIO getTargetData
+ourTargetData :: ExecutionEngine -> TargetData
+ourTargetData = unsafePerformIO . getTargetData
 
 --------------------------------------
 

LLVM/ExecutionEngine.hs

@@ -2,14 +2,14 @@
  -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module.
 module LLVM.ExecutionEngine(
     -- * Execution engine
-    EngineAccess,
-    runEngineAccess,
+    ExecutionEngine,
+    createExecutionEngine,
+    destroyExecutionEngine,
+    touchExecutionEngine,
     addModule,
     removeModule,
-{-
     runStaticConstructors,
     runStaticDestructors,
--}
     getPointerToFunction,
     addFunctionValue,
     addGlobalMappings,
@@ -31,11 +31,11 @@ import System.IO.Unsafe (unsafePerformIO)
 
 import LLVM.ExecutionEngine.Engine
 import LLVM.FFI.Core(ValueRef)
-import LLVM.Core.CodeGen(Value(..))
-import LLVM.Core
+import LLVM.Core.CodeGen
+import LLVM.Core.CodeGenMonad
 import LLVM.ExecutionEngine.Target
---import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager)
 import Control.Monad (liftM2, )
+import Foreign.Ptr (Ptr)
 
 -- |Class of LLVM function types that can be translated to the corresponding
 -- Haskell type.
@@ -54,9 +54,10 @@ instance (Generic a) => Translatable (IO a) where
 -- If you want to compile the function once and call it a lot of times
 -- then you should better use 'getPointerToFunction'.
 generateFunction :: (Translatable f) =>
-                    Value (Ptr f) -> EngineAccess f
-generateFunction (Value f) = do
-    run <- getRunFunction
+                    ExecutionEngine ->
+                    Value (Ptr f) -> IO f
+generateFunction ee (Value f) = do
+    run <- getRunFunction ee
     return $ translate run [] f
 
 class Unsafe a b | a -> b where
@@ -71,14 +72,13 @@ instance Unsafe (IO a) a where
 -- |Translate a function to Haskell code.  This is a simplified interface to
 -- the execution engine and module mechanism.
 -- It is based on 'generateFunction', so see there for limitations.
-simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f
-simpleFunction bld = do
+simpleFunction :: (Translatable f) => ExecutionEngine -> CodeGenModule (Function f) -> IO f
+simpleFunction ee bld = do
     m <- newModule
     (func, mappings) <- defineModule m (liftM2 (,) bld getGlobalMappings)
-    runEngineAccess $ do
-        addModule m
-        addGlobalMappings mappings
-        generateFunction func
+    addModule ee m
+    addGlobalMappings ee mappings
+    generateFunction ee func
 
 {-
     m <- newModule
@@ -106,7 +106,7 @@ simpleFunction bld = do
 
 -- | Combine 'simpleFunction' and 'unsafePurify'.
 unsafeGenerateFunction :: (Unsafe t a, Translatable t) =>
-                          CodeGenModule (Function t) -> a
-unsafeGenerateFunction bld = unsafePerformIO $ do
-    fun <- simpleFunction bld
+                          ExecutionEngine -> CodeGenModule (Function t) -> a
+unsafeGenerateFunction ee bld = unsafePerformIO $ do
+    fun <- simpleFunction ee bld
     return $ unsafePurify fun

LLVM/ExecutionEngine/Engine.hs

@@ -1,12 +1,9 @@
-{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
+{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}
 module LLVM.ExecutionEngine.Engine(
-       EngineAccess,
-       runEngineAccess,
-{-
        ExecutionEngine,
--}
-       createExecutionEngine, addModule, removeModule,
-       {- runStaticConstructors, runStaticDestructors, -}
+       createExecutionEngine, destroyExecutionEngine, touchExecutionEngine,
+       addModule, removeModule,
+       runStaticConstructors, runStaticDestructors,
        getExecutionEngineTargetData,
        getPointerToFunction,
        addFunctionValue, addGlobalMappings,
@@ -16,14 +13,11 @@ module LLVM.ExecutionEngine.Engine(
        GenericValue, Generic(..)
        ) where
 import Control.Monad.State
-import Control.Applicative (Applicative, )
-import Control.Concurrent.MVar
-import Data.Typeable
 import Data.Int
 import Data.Word
 import Foreign.Marshal.Alloc (alloca, free)
 import Foreign.Marshal.Array (withArrayLen)
-import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)
+import Foreign.ForeignPtr (ForeignPtr, finalizeForeignPtr, newForeignPtr, touchForeignPtr, withForeignPtr)
 import Foreign.Marshal.Utils (fromBool)
 import Foreign.C.String (peekCString)
 import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr)
@@ -33,14 +27,13 @@ import Foreign.Storable (peek)
 import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, )
 import System.IO.Unsafe (unsafePerformIO)
 
-import LLVM.Core.Util(Module, createModule)
+import LLVM.Core.Util (Module)
 import qualified LLVM.FFI.ExecutionEngine as FFI
 import qualified LLVM.FFI.Target as FFI
 import qualified LLVM.FFI.Core as FFI(ValueRef)
 import qualified LLVM.Core.Util as U
 import LLVM.Core.Type(IsFirstClass, typeRef)
 
-{-
 -- |The type of the JITer.
 newtype ExecutionEngine = ExecutionEngine {
       fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine
@@ -52,20 +45,26 @@ withExecutionEngine = withForeignPtr . fromExecutionEngine
 
 -- |Create an execution engine for a module provider.
 -- Warning, do not call this function more than once.
-createExecutionEngine :: ModuleProvider -> IO ExecutionEngine
-createExecutionEngine prov =
-    withModuleProvider prov $ \provPtr ->
+createExecutionEngine :: Module -> IO ExecutionEngine
+createExecutionEngine m =
+    U.withModule m $ \mPtr ->
       alloca $ \eePtr ->
         alloca $ \errPtr -> do
-          ret <- FFI.createExecutionEngine eePtr provPtr errPtr
-          if ret == 1
+          ret <- FFI.createExecutionEngineForModule eePtr mPtr errPtr
+          if ret
             then do err <- peek errPtr
                     errStr <- peekCString err
                     free err
                     ioError . userError $ errStr
             else do ptr <- peek eePtr
                     liftM ExecutionEngine $ newForeignPtr FFI.ptrDisposeExecutionEngine ptr
 
+destroyExecutionEngine :: ExecutionEngine -> IO ()
+destroyExecutionEngine = finalizeForeignPtr . fromExecutionEngine
+
+touchExecutionEngine :: ExecutionEngine -> IO ()
+touchExecutionEngine = touchForeignPtr . fromExecutionEngine
+
 runStaticConstructors :: ExecutionEngine -> IO ()
 runStaticConstructors ee = withExecutionEngine ee FFI.runStaticConstructors
 
@@ -75,70 +74,6 @@ runStaticDestructors ee = withExecutionEngine ee FFI.runStaticDestructors
 getExecutionEngineTargetData :: ExecutionEngine -> IO FFI.TargetDataRef
 getExecutionEngineTargetData ee = withExecutionEngine ee FFI.getExecutionEngineTargetData
 
-getPointerToFunction :: ExecutionEngine -> Function f -> IO (FunPtr f)
-getPointerToFunction ee (Value f) =
-    withExecutionEngine ee $ \ eePtr ->
-      FFI.getPointerToGlobal eePtr f
--}
-
--- This global variable holds the one and only execution engine.
--- It may be missing, but it never dies.
--- XXX We could provide a destructor, what about functions obtained by runFunction?
-{-# NOINLINE theEngine #-}
-theEngine :: MVar (Maybe (Ptr FFI.ExecutionEngine))
-theEngine = unsafePerformIO $ newMVar Nothing
-
-createExecutionEngine :: Module -> IO (Ptr FFI.ExecutionEngine)
-createExecutionEngine m =
-    U.withModule m $ \ mPtr ->
-      alloca $ \eePtr ->
-        alloca $ \errPtr -> do
-          failed <- FFI.createJITCompilerForModule eePtr mPtr 2 errPtr
-          if failed
-            then do
-                err <- peek errPtr
-                errStr <- peekCString err
-                free err
-                ioError . userError $ errStr
-            else
-                peek eePtr
-
-getTheEngine :: IO (Ptr FFI.ExecutionEngine)
-getTheEngine = do
-    mee <- takeMVar theEngine
-    case mee of
-        Just ee -> do putMVar theEngine mee; return ee
-        Nothing -> do
-            m <- createModule "__empty__"
-            ee <- createExecutionEngine m
-            putMVar theEngine (Just ee)
-            return ee
-
-data EAState = EAState {
-    ea_engine :: Ptr FFI.ExecutionEngine,
-    ea_modules :: [Module]
-    }
-    deriving (Show, Typeable)
-
-newtype EngineAccess a = EA (StateT EAState IO a)
-    deriving (Functor, Applicative, Monad, MonadState EAState, MonadIO)
-
--- |The LLVM execution engine is encapsulated so it cannot be accessed directly.
--- The reason is that (currently) there must only ever be one engine,
--- so access to it is wrapped in a monad.
-runEngineAccess :: EngineAccess a -> IO a
-runEngineAccess (EA body) = do
-    eePtr <- getTheEngine
-    let ea = EAState { ea_engine = eePtr, ea_modules = [] }
-    (a, _ea') <- runStateT body ea
-    -- XXX should remove module providers again
-    return a
-
-getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef
-getExecutionEngineTargetData = do
-    eePtr <- gets ea_engine
-    liftIO $ FFI.getExecutionEngineTargetData eePtr
-
 {- |
 In contrast to 'generateFunction' this compiles a function once.
 Thus it is faster for many calls to the same function.
@@ -148,43 +83,40 @@ If the function calls back into Haskell code,
 you also have to set the function addresses
 using 'addFunctionValue' or 'addGlobalMappings'.
 -}
-getPointerToFunction :: Function f -> EngineAccess (FunPtr f)
-getPointerToFunction (Value f) = do
-    eePtr <- gets ea_engine
-    liftIO $ FFI.getPointerToGlobal eePtr f
+getPointerToFunction :: ExecutionEngine -> Function f -> IO (FunPtr f)
+getPointerToFunction ee (Value f) =
+    withExecutionEngine ee $ \ eePtr ->
+      FFI.getPointerToGlobal eePtr f
 
 {- |
 Tell LLVM the address of an external function
 if it cannot resolve a name automatically.
 Alternatively you may declare the function
 with 'staticFunction' instead of 'externFunction'.
 -}
-addFunctionValue :: Function f -> FunPtr f -> EngineAccess ()
-addFunctionValue (Value g) f =
-    addFunctionValueCore g (castFunPtrToPtr f)
+addFunctionValue :: ExecutionEngine -> Function f -> FunPtr f -> IO ()
+addFunctionValue ee (Value g) f =
+    addFunctionValueCore ee g (castFunPtrToPtr f)
 
 {- |
 Pass a list of global mappings to LLVM
 that can be obtained from 'LLVM.Core.getGlobalMappings'.
 -}
-addGlobalMappings :: GlobalMappings -> EngineAccess ()
-addGlobalMappings (GlobalMappings gms) =
-    mapM_ (uncurry addFunctionValueCore) gms
-
-addFunctionValueCore :: U.Function -> Ptr () -> EngineAccess ()
-addFunctionValueCore g f = do
-    eePtr <- gets ea_engine
-    liftIO $ FFI.addGlobalMapping eePtr g f
-
-addModule :: Module -> EngineAccess ()
-addModule m = do
-    eePtr <- gets ea_engine
+addGlobalMappings :: ExecutionEngine -> GlobalMappings -> IO ()
+addGlobalMappings ee (GlobalMappings gms) =
+    mapM_ (uncurry (addFunctionValueCore ee)) gms
+
+addFunctionValueCore :: ExecutionEngine -> U.Function -> Ptr () -> IO ()
+addFunctionValueCore ee g f = withExecutionEngine ee $ \eePtr ->
+    FFI.addGlobalMapping eePtr g f
+
+addModule :: ExecutionEngine -> Module -> IO ()
+addModule ee m = withExecutionEngine ee $ \eePtr ->
     liftIO $ U.withModule m $ \ mPtr -> do
         FFI.addModule eePtr mPtr
 
-removeModule :: Module -> EngineAccess ()
-removeModule m = do
-    eePtr <- gets ea_engine
+removeModule :: ExecutionEngine -> Module -> IO ()
+removeModule ee m = withExecutionEngine ee $ \eePtr ->
     liftIO $ U.withModule m $ \ mPtr ->
         alloca $ \ unused1 ->
             alloca $ \ unused2 -> do
@@ -195,10 +127,9 @@ removeModule m = do
 -- 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 = (Ptr FFI.ExecutionEngine, FFI.ValueRef)
-getFreePointers :: Function f -> EngineAccess FreePointers
-getFreePointers (Value f) = do
-    ea <- get
-    return (ea_engine ea, f)
+getFreePointers :: ExecutionEngine -> Function f -> IO FreePointers
+getFreePointers ee (Value f) = withExecutionEngine ee $ \eePtr ->
+    return (eePtr, f)
 
 foreign import ccall c_freeFunctionObject :: Ptr FFI.ExecutionEngine -> FFI.ValueRef -> IO ()
 
@@ -221,15 +152,13 @@ withAll ps a = go [] ps
     where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs
           go ptrs _ = withArrayLen (reverse ptrs) a
 
-runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue
-runFunction func args = do
-    eePtr <- gets ea_engine
-    liftIO $ withAll args $ \argLen argPtr ->
-                 createGenericValueWith $ FFI.runFunction eePtr func
+runFunction :: ExecutionEngine -> U.Function -> [GenericValue] -> IO GenericValue
+runFunction ee func args = withExecutionEngine ee $ \eePtr ->
+    withAll args $ \argLen argPtr ->
+        createGenericValueWith $ FFI.runFunction eePtr func
                                               (fromIntegral argLen) argPtr
-getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue)
-getRunFunction = do
-    eePtr <- gets ea_engine
+getRunFunction :: ExecutionEngine -> IO (U.Function -> [GenericValue] -> IO GenericValue)
+getRunFunction ee = withExecutionEngine ee $ \eePtr -> do
     return $ \ func args ->
              withAll args $ \argLen argPtr ->
                  createGenericValueWith $ FFI.runFunction eePtr func

LLVM/ExecutionEngine/Target.hs

@@ -6,7 +6,7 @@ import Foreign.C.String
 import System.IO.Unsafe(unsafePerformIO)
 
 import LLVM.Core.Data(WordN)
-import LLVM.ExecutionEngine.Engine(runEngineAccess, getExecutionEngineTargetData)
+import LLVM.ExecutionEngine.Engine(ExecutionEngine, getExecutionEngineTargetData)
 
 import qualified LLVM.FFI.Core as FFI
 import qualified LLVM.FFI.Target as FFI
@@ -29,15 +29,15 @@ data TargetData = TargetData {
     }
     deriving (Typeable)
 
-withIntPtrType :: (forall n . (Nat n) => WordN n -> a) -> a
-withIntPtrType f = reifyIntegral sz (\ n -> f (g n))
+withIntPtrType :: ExecutionEngine -> (forall n . (Nat n) => WordN n -> a) -> a
+withIntPtrType ee f = reifyIntegral sz (\ n -> f (g n))
   where g :: n -> WordN n
         g _ = error "withIntPtrType: argument used"
-        sz = pointerSize $ unsafePerformIO getTargetData
+        sz = pointerSize $ unsafePerformIO (getTargetData ee)
 
 -- Gets the target data for the JIT target.
-getEngineTargetDataRef :: IO FFI.TargetDataRef
-getEngineTargetDataRef = runEngineAccess getExecutionEngineTargetData
+getEngineTargetDataRef :: ExecutionEngine -> IO FFI.TargetDataRef
+getEngineTargetDataRef = getExecutionEngineTargetData
 
 -- Normally the TargetDataRef never changes, so the operation
 -- are really pure functions.
@@ -54,8 +54,8 @@ makeTargetData r = TargetData {
     storeSizeOfType          = fromIntegral . FFI.storeSizeOfType r
     }
 
-getTargetData :: IO TargetData
-getTargetData = fmap makeTargetData getEngineTargetDataRef
+getTargetData :: ExecutionEngine -> IO TargetData
+getTargetData ee = fmap makeTargetData (getEngineTargetDataRef ee)
 
 targetDataFromString :: String -> TargetData
 targetDataFromString s = makeTargetData $ unsafePerformIO $ withCString s FFI.createTargetData