module LLVM.ExecutionEngine.Engine(
EngineAccess,
runEngineAccess,
createExecutionEngine, addModuleProvider, addModule,
getExecutionEngineTargetData,
getPointerToFunction,
addFunctionValue, addGlobalMappings,
getFreePointers, FreePointers,
runFunction, getRunFunction,
GenericValue, Generic(..), GenericTuple(..),
) where
import Control.Monad.State
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.Marshal.Utils (fromBool)
import Foreign.C.String (peekCString)
import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr, )
import LLVM.Core.CodeGen(Value(..), Function)
import LLVM.Core.CodeGenMonad(GlobalMappings(..))
import Foreign.Storable (peek)
import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, )
import System.IO.Unsafe (unsafePerformIO)
import LLVM.Core.Util(Module, ModuleProvider, withModuleProvider, createModule, createModuleProviderForExistingModule)
import qualified LLVM.FFI.ExecutionEngine as FFI
import qualified LLVM.FFI.Target as FFI
import qualified LLVM.Core.Util as U
import qualified LLVM.FFI.Core as FFI(ModuleProviderRef, ValueRef)
import LLVM.Core.Type(IsFirstClass, typeRef)
theEngine :: MVar (Maybe (Ptr FFI.ExecutionEngine))
theEngine = unsafePerformIO $ newMVar Nothing
createExecutionEngine :: ModuleProvider -> IO (Ptr FFI.ExecutionEngine)
createExecutionEngine prov =
withModuleProvider prov $ \provPtr ->
alloca $ \eePtr ->
alloca $ \errPtr -> do
ret <- FFI.createExecutionEngine eePtr provPtr errPtr
if ret == 1
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__"
mp <- createModuleProviderForExistingModule m
ee <- createExecutionEngine mp
putMVar theEngine (Just ee)
return ee
data EAState = EAState {
ea_engine :: Ptr FFI.ExecutionEngine,
ea_providers :: [ModuleProvider]
}
deriving (Show, Typeable)
newtype EngineAccess a = EA (StateT EAState IO a)
deriving (Functor, Monad, MonadState EAState, MonadIO)
runEngineAccess :: EngineAccess a -> IO a
runEngineAccess (EA body) = do
eePtr <- getTheEngine
let ea = EAState { ea_engine = eePtr, ea_providers = [] }
(a, _ea') <- runStateT body ea
return a
addModuleProvider :: ModuleProvider -> EngineAccess ()
addModuleProvider prov = do
ea <- get
put ea{ ea_providers = prov : ea_providers ea }
liftIO $ withModuleProvider prov $ \ provPtr ->
FFI.addModuleProvider (ea_engine ea) provPtr
getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef
getExecutionEngineTargetData = do
eePtr <- gets ea_engine
liftIO $ FFI.getExecutionEngineTargetData eePtr
getPointerToFunction :: Function f -> EngineAccess (FunPtr f)
getPointerToFunction (Value f) = do
eePtr <- gets ea_engine
liftIO $ FFI.getPointerToGlobal eePtr f
addFunctionValue :: Function f -> FunPtr f -> EngineAccess ()
addFunctionValue (Value g) f =
addFunctionValueCore g (castFunPtrToPtr f)
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
mp <- liftIO $ createModuleProviderForExistingModule m
addModuleProvider mp
type FreePointers = (Ptr FFI.ExecutionEngine, FFI.ModuleProviderRef, FFI.ValueRef)
getFreePointers :: Function f -> EngineAccess FreePointers
getFreePointers (Value f) = do
ea <- get
liftIO $ withModuleProvider (head $ ea_providers ea) $ \ mpp ->
return (ea_engine ea, mpp, f)
newtype GenericValue = GenericValue {
fromGenericValue :: ForeignPtr FFI.GenericValue
}
withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a
withGenericValue = withForeignPtr . fromGenericValue
createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue
createGenericValueWith f = do
ptr <- f
liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr
withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a
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
(fromIntegral argLen) argPtr
getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue)
getRunFunction = do
eePtr <- gets ea_engine
return $ \ func args ->
withAll args $ \argLen argPtr ->
createGenericValueWith $ FFI.runFunction eePtr func
(fromIntegral argLen) argPtr
class Generic a where
toGeneric :: a -> GenericValue
fromGeneric :: GenericValue -> a
instance Generic () where
toGeneric _ = error "toGeneric ()"
fromGeneric _ = ()
toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue
toGenericInt signed val = unsafePerformIO $ createGenericValueWith $
FFI.createGenericValueOfInt (typeRef val) (fromIntegral val) (fromBool signed)
fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a
fromGenericInt signed val = unsafePerformIO $
withGenericValue val $ \ref ->
return . fromIntegral $ FFI.genericValueToInt ref (fromBool signed)
instance Generic Int8 where
toGeneric = toGenericInt True
fromGeneric = fromGenericInt True
instance Generic Int16 where
toGeneric = toGenericInt True
fromGeneric = fromGenericInt True
instance Generic Int32 where
toGeneric = toGenericInt True
fromGeneric = fromGenericInt True
instance Generic Int64 where
toGeneric = toGenericInt True
fromGeneric = fromGenericInt True
instance Generic Word8 where
toGeneric = toGenericInt False
fromGeneric = fromGenericInt False
instance Generic Word16 where
toGeneric = toGenericInt False
fromGeneric = fromGenericInt False
instance Generic Word32 where
toGeneric = toGenericInt False
fromGeneric = fromGenericInt False
instance Generic Word64 where
toGeneric = toGenericInt False
fromGeneric = fromGenericInt False
toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue
toGenericReal val = unsafePerformIO $ createGenericValueWith $
FFI.createGenericValueOfFloat (typeRef val) (realToFrac val)
fromGenericReal :: forall a . (Fractional a, IsFirstClass a) => GenericValue -> a
fromGenericReal val = unsafePerformIO $
withGenericValue val $ \ ref ->
return . realToFrac $ FFI.genericValueToFloat (typeRef (undefined :: a)) ref
instance Generic Float where
toGeneric = toGenericReal
fromGeneric = fromGenericReal
instance Generic Double where
toGeneric = toGenericReal
fromGeneric = fromGenericReal
instance Generic (Ptr a) where
toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer
fromGeneric val = unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer
instance Generic (StablePtr a) where
toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer . castStablePtrToPtr
fromGeneric val = unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $ FFI.genericValueToPointer
class GenericTuple a where
toGenericTuple :: a -> [GenericValue]
fromGenericTuple :: State [GenericValue] a
toGenericAtom :: Generic a => a -> [GenericValue]
toGenericAtom = (:[]) . toGeneric
fromGenericAtom :: Generic a => State [GenericValue] a
fromGenericAtom =
State $ \gt ->
case gt of
[] -> error "too few generic values for tuple"
g:gs -> (fromGeneric g, gs)
instance GenericTuple () where
toGenericTuple _ = []
fromGenericTuple = return ()
instance (GenericTuple a, GenericTuple b) => GenericTuple (a,b) where
toGenericTuple ~(a,b) = toGenericTuple a ++ toGenericTuple b
fromGenericTuple =
liftM2 (,) fromGenericTuple fromGenericTuple
instance (GenericTuple a, GenericTuple b, GenericTuple c) =>
GenericTuple (a,b,c) where
toGenericTuple ~(a,b,c) = toGenericTuple a ++ toGenericTuple b ++ toGenericTuple c
fromGenericTuple =
liftM3 (,,) fromGenericTuple fromGenericTuple fromGenericTuple
instance GenericTuple Int8 where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple Int16 where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple Int32 where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple Int64 where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple Word8 where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple Word16 where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple Word32 where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple Word64 where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple Float where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple Double where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple (Ptr a) where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom
instance GenericTuple (StablePtr a) where
toGenericTuple = toGenericAtom
fromGenericTuple = fromGenericAtom