{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module LLVM.Internal.OrcJIT where

import LLVM.Prelude

import Control.Exception
import Control.Monad.AnyCont
import Control.Monad.IO.Class
import Data.Bits
import Data.IORef
import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr

import LLVM.Internal.Coding
import LLVM.Internal.Module (Module, readModule)
import LLVM.Internal.Target (TargetMachine(..))

import qualified LLVM.Internal.FFI.LLVMCTypes as FFI
import qualified LLVM.Internal.FFI.ShortByteString as SBS
import qualified LLVM.Internal.FFI.DataLayout as FFI
import qualified LLVM.Internal.FFI.OrcJIT as FFI
import qualified LLVM.Internal.FFI.Target as FFI

--------------------------------------------------------------------------------
-- ExecutionSession
--------------------------------------------------------------------------------

data ExecutionSession = ExecutionSession {
    ExecutionSession -> Ptr ExecutionSession
sessionPtr :: !(Ptr FFI.ExecutionSession),
    ExecutionSession -> IORef [IO ()]
sessionCleanups :: !(IORef [IO ()])
  }

-- | Create a new `ExecutionSession`.
createExecutionSession :: IO ExecutionSession
createExecutionSession :: IO ExecutionSession
createExecutionSession = Ptr ExecutionSession -> IORef [IO ()] -> ExecutionSession
ExecutionSession (Ptr ExecutionSession -> IORef [IO ()] -> ExecutionSession)
-> IO (Ptr ExecutionSession)
-> IO (IORef [IO ()] -> ExecutionSession)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ExecutionSession)
FFI.createExecutionSession IO (IORef [IO ()] -> ExecutionSession)
-> IO (IORef [IO ()]) -> IO ExecutionSession
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []

-- | Dispose of an `ExecutionSession`. This should be called when the
-- `ExecutionSession` is not needed anymore.
disposeExecutionSession :: ExecutionSession -> IO ()
disposeExecutionSession :: ExecutionSession -> IO ()
disposeExecutionSession (ExecutionSession Ptr ExecutionSession
es IORef [IO ()]
cleanups) = do
  Ptr ExecutionSession -> IO ()
FFI.endSession Ptr ExecutionSession
es
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> IO [IO ()] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef [IO ()] -> IO [IO ()]
forall a. IORef a -> IO a
readIORef IORef [IO ()]
cleanups
  Ptr ExecutionSession -> IO ()
FFI.disposeExecutionSession Ptr ExecutionSession
es

-- | `bracket`-style wrapper around `createExecutionSession` and
-- `disposeExecutionSession`.
withExecutionSession :: (ExecutionSession -> IO a) -> IO a
withExecutionSession :: forall a. (ExecutionSession -> IO a) -> IO a
withExecutionSession = IO ExecutionSession
-> (ExecutionSession -> IO ())
-> (ExecutionSession -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO ExecutionSession
createExecutionSession ExecutionSession -> IO ()
disposeExecutionSession

--------------------------------------------------------------------------------
-- JITSymbol
--------------------------------------------------------------------------------

-- | Contrary to the C++ interface, we do not store the HasError flag
-- here. Instead decoding a JITSymbol produces a sumtype based on
-- whether that flag is set or not.
data JITSymbolFlags =
  JITSymbolFlags {
    JITSymbolFlags -> Bool
jitSymbolWeak :: !Bool -- ^ Is this a weak symbol?
  , JITSymbolFlags -> Bool
jitSymbolCommon :: !Bool -- ^ Is this a common symbol?
  , JITSymbolFlags -> Bool
jitSymbolAbsolute :: !Bool
    -- ^ Is this an absolute symbol? This will cause LLVM to use
    -- absolute relocations for the symbol even in position
    -- independent code.
  , JITSymbolFlags -> Bool
jitSymbolExported :: !Bool -- ^ Is this symbol exported?
  , JITSymbolFlags -> Bool
jitSymbolCallable :: !Bool
  , JITSymbolFlags -> Bool
jitSymbolMaterializationSideEffectsOnly :: !Bool
  }
  deriving (Int -> JITSymbolFlags -> ShowS
[JITSymbolFlags] -> ShowS
JITSymbolFlags -> String
(Int -> JITSymbolFlags -> ShowS)
-> (JITSymbolFlags -> String)
-> ([JITSymbolFlags] -> ShowS)
-> Show JITSymbolFlags
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JITSymbolFlags -> ShowS
showsPrec :: Int -> JITSymbolFlags -> ShowS
$cshow :: JITSymbolFlags -> String
show :: JITSymbolFlags -> String
$cshowList :: [JITSymbolFlags] -> ShowS
showList :: [JITSymbolFlags] -> ShowS
Show, JITSymbolFlags -> JITSymbolFlags -> Bool
(JITSymbolFlags -> JITSymbolFlags -> Bool)
-> (JITSymbolFlags -> JITSymbolFlags -> Bool) -> Eq JITSymbolFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JITSymbolFlags -> JITSymbolFlags -> Bool
== :: JITSymbolFlags -> JITSymbolFlags -> Bool
$c/= :: JITSymbolFlags -> JITSymbolFlags -> Bool
/= :: JITSymbolFlags -> JITSymbolFlags -> Bool
Eq, Eq JITSymbolFlags
Eq JITSymbolFlags
-> (JITSymbolFlags -> JITSymbolFlags -> Ordering)
-> (JITSymbolFlags -> JITSymbolFlags -> Bool)
-> (JITSymbolFlags -> JITSymbolFlags -> Bool)
-> (JITSymbolFlags -> JITSymbolFlags -> Bool)
-> (JITSymbolFlags -> JITSymbolFlags -> Bool)
-> (JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags)
-> (JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags)
-> Ord JITSymbolFlags
JITSymbolFlags -> JITSymbolFlags -> Bool
JITSymbolFlags -> JITSymbolFlags -> Ordering
JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: JITSymbolFlags -> JITSymbolFlags -> Ordering
compare :: JITSymbolFlags -> JITSymbolFlags -> Ordering
$c< :: JITSymbolFlags -> JITSymbolFlags -> Bool
< :: JITSymbolFlags -> JITSymbolFlags -> Bool
$c<= :: JITSymbolFlags -> JITSymbolFlags -> Bool
<= :: JITSymbolFlags -> JITSymbolFlags -> Bool
$c> :: JITSymbolFlags -> JITSymbolFlags -> Bool
> :: JITSymbolFlags -> JITSymbolFlags -> Bool
$c>= :: JITSymbolFlags -> JITSymbolFlags -> Bool
>= :: JITSymbolFlags -> JITSymbolFlags -> Bool
$cmax :: JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
max :: JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
$cmin :: JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
min :: JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
Ord)

defaultJITSymbolFlags :: JITSymbolFlags
defaultJITSymbolFlags :: JITSymbolFlags
defaultJITSymbolFlags = Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> JITSymbolFlags
JITSymbolFlags Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False

data JITSymbol =
  JITSymbol {
    JITSymbol -> WordPtr
jitSymbolAddress :: !WordPtr, -- ^ The address of the symbol. If
                                  -- you’ve looked up a function, you
                                  -- need to cast this to a 'FunPtr'.
    JITSymbol -> JITSymbolFlags
jitSymbolFlags :: !JITSymbolFlags -- ^ The flags of this symbol.
  }
  deriving (Int -> JITSymbol -> ShowS
[JITSymbol] -> ShowS
JITSymbol -> String
(Int -> JITSymbol -> ShowS)
-> (JITSymbol -> String)
-> ([JITSymbol] -> ShowS)
-> Show JITSymbol
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JITSymbol -> ShowS
showsPrec :: Int -> JITSymbol -> ShowS
$cshow :: JITSymbol -> String
show :: JITSymbol -> String
$cshowList :: [JITSymbol] -> ShowS
showList :: [JITSymbol] -> ShowS
Show, JITSymbol -> JITSymbol -> Bool
(JITSymbol -> JITSymbol -> Bool)
-> (JITSymbol -> JITSymbol -> Bool) -> Eq JITSymbol
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JITSymbol -> JITSymbol -> Bool
== :: JITSymbol -> JITSymbol -> Bool
$c/= :: JITSymbol -> JITSymbol -> Bool
/= :: JITSymbol -> JITSymbol -> Bool
Eq, Eq JITSymbol
Eq JITSymbol
-> (JITSymbol -> JITSymbol -> Ordering)
-> (JITSymbol -> JITSymbol -> Bool)
-> (JITSymbol -> JITSymbol -> Bool)
-> (JITSymbol -> JITSymbol -> Bool)
-> (JITSymbol -> JITSymbol -> Bool)
-> (JITSymbol -> JITSymbol -> JITSymbol)
-> (JITSymbol -> JITSymbol -> JITSymbol)
-> Ord JITSymbol
JITSymbol -> JITSymbol -> Bool
JITSymbol -> JITSymbol -> Ordering
JITSymbol -> JITSymbol -> JITSymbol
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: JITSymbol -> JITSymbol -> Ordering
compare :: JITSymbol -> JITSymbol -> Ordering
$c< :: JITSymbol -> JITSymbol -> Bool
< :: JITSymbol -> JITSymbol -> Bool
$c<= :: JITSymbol -> JITSymbol -> Bool
<= :: JITSymbol -> JITSymbol -> Bool
$c> :: JITSymbol -> JITSymbol -> Bool
> :: JITSymbol -> JITSymbol -> Bool
$c>= :: JITSymbol -> JITSymbol -> Bool
>= :: JITSymbol -> JITSymbol -> Bool
$cmax :: JITSymbol -> JITSymbol -> JITSymbol
max :: JITSymbol -> JITSymbol -> JITSymbol
$cmin :: JITSymbol -> JITSymbol -> JITSymbol
min :: JITSymbol -> JITSymbol -> JITSymbol
Ord)

data JITSymbolError = JITSymbolError ShortByteString
  deriving (Int -> JITSymbolError -> ShowS
[JITSymbolError] -> ShowS
JITSymbolError -> String
(Int -> JITSymbolError -> ShowS)
-> (JITSymbolError -> String)
-> ([JITSymbolError] -> ShowS)
-> Show JITSymbolError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JITSymbolError -> ShowS
showsPrec :: Int -> JITSymbolError -> ShowS
$cshow :: JITSymbolError -> String
show :: JITSymbolError -> String
$cshowList :: [JITSymbolError] -> ShowS
showList :: [JITSymbolError] -> ShowS
Show, JITSymbolError -> JITSymbolError -> Bool
(JITSymbolError -> JITSymbolError -> Bool)
-> (JITSymbolError -> JITSymbolError -> Bool) -> Eq JITSymbolError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JITSymbolError -> JITSymbolError -> Bool
== :: JITSymbolError -> JITSymbolError -> Bool
$c/= :: JITSymbolError -> JITSymbolError -> Bool
/= :: JITSymbolError -> JITSymbolError -> Bool
Eq)

instance Monad m => EncodeM m JITSymbolFlags FFI.JITSymbolFlags where
  encodeM :: HasCallStack => JITSymbolFlags -> m JITSymbolFlags
encodeM JITSymbolFlags
f = JITSymbolFlags -> m JITSymbolFlags
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JITSymbolFlags -> m JITSymbolFlags)
-> JITSymbolFlags -> m JITSymbolFlags
forall a b. (a -> b) -> a -> b
$ (JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags)
-> [JITSymbolFlags] -> JITSymbolFlags
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
forall a. Bits a => a -> a -> a
(.|.) [
      if JITSymbolFlags -> Bool
a JITSymbolFlags
f
         then JITSymbolFlags
b
         else JITSymbolFlags
0
    | (JITSymbolFlags -> Bool
a,JITSymbolFlags
b) <- [
          (JITSymbolFlags -> Bool
jitSymbolWeak, JITSymbolFlags
FFI.jitSymbolFlagsWeak),
          (JITSymbolFlags -> Bool
jitSymbolCommon, JITSymbolFlags
FFI.jitSymbolFlagsCommon),
          (JITSymbolFlags -> Bool
jitSymbolAbsolute, JITSymbolFlags
FFI.jitSymbolFlagsAbsolute),
          (JITSymbolFlags -> Bool
jitSymbolExported, JITSymbolFlags
FFI.jitSymbolFlagsExported),
          (JITSymbolFlags -> Bool
jitSymbolCallable, JITSymbolFlags
FFI.jitSymbolFlagsCallable),
          (JITSymbolFlags -> Bool
jitSymbolMaterializationSideEffectsOnly, JITSymbolFlags
FFI.jitSymbolFlagsMaterializationSideEffectsOnly)
        ]
    ]

instance Monad m => DecodeM m JITSymbolFlags FFI.JITSymbolFlags where
  decodeM :: HasCallStack => JITSymbolFlags -> m JITSymbolFlags
decodeM JITSymbolFlags
f =
    JITSymbolFlags -> m JITSymbolFlags
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JITSymbolFlags -> m JITSymbolFlags)
-> JITSymbolFlags -> m JITSymbolFlags
forall a b. (a -> b) -> a -> b
$ JITSymbolFlags {
      jitSymbolWeak :: Bool
jitSymbolWeak = JITSymbolFlags
FFI.jitSymbolFlagsWeak JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
forall a. Bits a => a -> a -> a
.&. JITSymbolFlags
f JITSymbolFlags -> JITSymbolFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= JITSymbolFlags
0,
      jitSymbolCommon :: Bool
jitSymbolCommon = JITSymbolFlags
FFI.jitSymbolFlagsCommon JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
forall a. Bits a => a -> a -> a
.&. JITSymbolFlags
f JITSymbolFlags -> JITSymbolFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= JITSymbolFlags
0,
      jitSymbolAbsolute :: Bool
jitSymbolAbsolute = JITSymbolFlags
FFI.jitSymbolFlagsAbsolute JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
forall a. Bits a => a -> a -> a
.&. JITSymbolFlags
f JITSymbolFlags -> JITSymbolFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= JITSymbolFlags
0,
      jitSymbolExported :: Bool
jitSymbolExported = JITSymbolFlags
FFI.jitSymbolFlagsExported JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
forall a. Bits a => a -> a -> a
.&. JITSymbolFlags
f JITSymbolFlags -> JITSymbolFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= JITSymbolFlags
0,
      jitSymbolCallable :: Bool
jitSymbolCallable = JITSymbolFlags
FFI.jitSymbolFlagsCallable JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
forall a. Bits a => a -> a -> a
.&. JITSymbolFlags
f JITSymbolFlags -> JITSymbolFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= JITSymbolFlags
0,
      jitSymbolMaterializationSideEffectsOnly :: Bool
jitSymbolMaterializationSideEffectsOnly = JITSymbolFlags
FFI.jitSymbolFlagsMaterializationSideEffectsOnly JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
forall a. Bits a => a -> a -> a
.&. JITSymbolFlags
f JITSymbolFlags -> JITSymbolFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= JITSymbolFlags
0
    }

instance Monad m => EncodeM m MangledSymbol (Ptr FFI.SymbolStringPtr) where
  encodeM :: HasCallStack => MangledSymbol -> m (Ptr SymbolStringPtr)
encodeM (MangledSymbol Ptr SymbolStringPtr
p) = Ptr SymbolStringPtr -> m (Ptr SymbolStringPtr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr SymbolStringPtr
p

instance (Monad m, MonadIO m, MonadAnyCont IO m) => EncodeM m JITSymbol (Ptr FFI.JITEvaluatedSymbol) where
  encodeM :: HasCallStack => JITSymbol -> m (Ptr JITEvaluatedSymbol)
encodeM (JITSymbol WordPtr
addr JITSymbolFlags
flags) = do
    JITSymbolFlags
flags' <- JITSymbolFlags -> m JITSymbolFlags
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM JITSymbolFlags
flags
    (forall r. (Ptr JITEvaluatedSymbol -> IO r) -> IO r)
-> m (Ptr JITEvaluatedSymbol)
forall a. (forall r. (a -> IO r) -> IO r) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadAnyCont b m =>
(forall r. (a -> b r) -> b r) -> m a
anyContToM ((forall r. (Ptr JITEvaluatedSymbol -> IO r) -> IO r)
 -> m (Ptr JITEvaluatedSymbol))
-> (forall r. (Ptr JITEvaluatedSymbol -> IO r) -> IO r)
-> m (Ptr JITEvaluatedSymbol)
forall a b. (a -> b) -> a -> b
$ IO (Ptr JITEvaluatedSymbol)
-> (Ptr JITEvaluatedSymbol -> IO ())
-> (Ptr JITEvaluatedSymbol -> IO r)
-> IO r
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (TargetAddress -> JITSymbolFlags -> IO (Ptr JITEvaluatedSymbol)
FFI.createJITEvaluatedSymbol (Word64 -> TargetAddress
FFI.TargetAddress (Word64 -> TargetAddress) -> Word64 -> TargetAddress
forall a b. (a -> b) -> a -> b
$ WordPtr -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordPtr
addr) JITSymbolFlags
flags')
      Ptr JITEvaluatedSymbol -> IO ()
FFI.disposeJITEvaluatedSymbol

instance (MonadIO m, MonadAnyCont IO m) =>
         DecodeM m (Either JITSymbolError JITSymbol) (Ptr FFI.ExpectedJITEvaluatedSymbol) where
  decodeM :: HasCallStack =>
Ptr ExpectedJITEvaluatedSymbol
-> m (Either JITSymbolError JITSymbol)
decodeM Ptr ExpectedJITEvaluatedSymbol
expectedSym = do
    Ptr (OwnerTransfered CString)
errMsg <- m (Ptr (OwnerTransfered CString))
forall a (m :: * -> *).
(Storable a, MonadAnyCont IO m) =>
m (Ptr a)
alloca
    FFI.TargetAddress Word64
addr <- IO TargetAddress -> m TargetAddress
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TargetAddress -> m TargetAddress)
-> IO TargetAddress -> m TargetAddress
forall a b. (a -> b) -> a -> b
$ Ptr ExpectedJITEvaluatedSymbol
-> Ptr (OwnerTransfered CString) -> IO TargetAddress
FFI.getExpectedSymbolAddress Ptr ExpectedJITEvaluatedSymbol
expectedSym Ptr (OwnerTransfered CString)
errMsg
    JITSymbolFlags
rawFlags <- IO JITSymbolFlags -> m JITSymbolFlags
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr ExpectedJITEvaluatedSymbol -> IO JITSymbolFlags
FFI.getExpectedSymbolFlags Ptr ExpectedJITEvaluatedSymbol
expectedSym)
    if Word64
addr Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 Bool -> Bool -> Bool
|| (JITSymbolFlags
rawFlags JITSymbolFlags -> JITSymbolFlags -> JITSymbolFlags
forall a. Bits a => a -> a -> a
.&. JITSymbolFlags
FFI.jitSymbolFlagsHasError JITSymbolFlags -> JITSymbolFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= JITSymbolFlags
0)
      then do
        ShortByteString
errMsg <- Ptr (OwnerTransfered CString) -> m ShortByteString
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM Ptr (OwnerTransfered CString)
errMsg
        Either JITSymbolError JITSymbol
-> m (Either JITSymbolError JITSymbol)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JITSymbolError -> Either JITSymbolError JITSymbol
forall a b. a -> Either a b
Left (ShortByteString -> JITSymbolError
JITSymbolError ShortByteString
errMsg))
      else do
        JITSymbolFlags
flags <- JITSymbolFlags -> m JITSymbolFlags
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM JITSymbolFlags
rawFlags
        Either JITSymbolError JITSymbol
-> m (Either JITSymbolError JITSymbol)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JITSymbol -> Either JITSymbolError JITSymbol
forall a b. b -> Either a b
Right (WordPtr -> JITSymbolFlags -> JITSymbol
JITSymbol (Word64 -> WordPtr
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
addr) JITSymbolFlags
flags))

--------------------------------------------------------------------------------
-- JITDylib
--------------------------------------------------------------------------------

newtype JITDylib = JITDylib (Ptr FFI.JITDylib)

-- | Create a new 'JITDylib' with the given name.
createJITDylib :: ExecutionSession -> ShortByteString -> IO JITDylib
createJITDylib :: ExecutionSession -> ShortByteString -> IO JITDylib
createJITDylib (ExecutionSession Ptr ExecutionSession
es IORef [IO ()]
_) ShortByteString
name =
  ShortByteString -> (CString -> IO JITDylib) -> IO JITDylib
forall a. ShortByteString -> (CString -> IO a) -> IO a
SBS.useAsCString ShortByteString
name ((CString -> IO JITDylib) -> IO JITDylib)
-> (CString -> IO JITDylib) -> IO JITDylib
forall a b. (a -> b) -> a -> b
$ (Ptr JITDylib -> JITDylib) -> IO (Ptr JITDylib) -> IO JITDylib
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ptr JITDylib -> JITDylib
JITDylib (IO (Ptr JITDylib) -> IO JITDylib)
-> (CString -> IO (Ptr JITDylib)) -> CString -> IO JITDylib
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr ExecutionSession -> CString -> IO (Ptr JITDylib)
FFI.createJITDylib Ptr ExecutionSession
es

-- NB: JITDylib unloading is WIP (at least according to some old-looking docs)

-- | Adds a 'JITDylib' definition generator that looks up missing symbols in
-- the namespace of the current process.
addDynamicLibrarySearchGeneratorForCurrentProcess :: IRLayer l => l -> JITDylib -> IO ()
addDynamicLibrarySearchGeneratorForCurrentProcess :: forall l. IRLayer l => l -> JITDylib -> IO ()
addDynamicLibrarySearchGeneratorForCurrentProcess l
compileLayer (JITDylib Ptr JITDylib
dylib) =
  Ptr JITDylib -> Ptr DataLayout -> IO ()
FFI.addDynamicLibrarySearchGeneratorForCurrentProcess Ptr JITDylib
dylib (l -> Ptr DataLayout
forall l. IRLayer l => l -> Ptr DataLayout
getDataLayout l
compileLayer)

-- | Adds a 'JITDylib' definition generator that looks up missing symbols in
-- the namespace of a shared library located at the specified 'FilePath'.
addDynamicLibrarySearchGenerator :: IRLayer l => l -> JITDylib -> FilePath -> IO ()
addDynamicLibrarySearchGenerator :: forall l. IRLayer l => l -> JITDylib -> String -> IO ()
addDynamicLibrarySearchGenerator l
compileLayer (JITDylib Ptr JITDylib
dylib) String
s = String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
s ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cStr ->
  Ptr JITDylib -> Ptr DataLayout -> CString -> IO ()
FFI.addDynamicLibrarySearchGenerator Ptr JITDylib
dylib (l -> Ptr DataLayout
forall l. IRLayer l => l -> Ptr DataLayout
getDataLayout l
compileLayer) CString
cStr

defineAbsoluteSymbols :: JITDylib -> [(MangledSymbol, JITSymbol)] -> IO ()
defineAbsoluteSymbols :: JITDylib -> [(MangledSymbol, JITSymbol)] -> IO ()
defineAbsoluteSymbols (JITDylib Ptr JITDylib
dylib) [(MangledSymbol, JITSymbol)]
symList =
  (() -> IO ()) -> AnyContT IO () -> IO ()
forall a (m :: * -> *) r. (a -> m r) -> AnyContT m a -> m r
runAnyContT' () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyContT IO () -> IO ()) -> AnyContT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (CUInt
nsyms, Ptr (Ptr SymbolStringPtr)
symStrPtrPtr) :: (CUInt, Ptr (Ptr FFI.SymbolStringPtr)) <- [MangledSymbol] -> AnyContT IO (CUInt, Ptr (Ptr SymbolStringPtr))
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM [MangledSymbol]
symNames
    (CUInt
_, Ptr (Ptr JITEvaluatedSymbol)
symValPtrPtr) :: (CUInt, Ptr (Ptr FFI.JITEvaluatedSymbol)) <- [JITSymbol] -> AnyContT IO (CUInt, Ptr (Ptr JITEvaluatedSymbol))
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM [JITSymbol]
symVals
    IO () -> AnyContT IO ()
forall a. IO a -> AnyContT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AnyContT IO ()) -> IO () -> AnyContT IO ()
forall a b. (a -> b) -> a -> b
$ Ptr JITDylib
-> CUInt
-> Ptr (Ptr SymbolStringPtr)
-> Ptr (Ptr JITEvaluatedSymbol)
-> IO ()
FFI.defineAbsoluteSymbols Ptr JITDylib
dylib CUInt
nsyms Ptr (Ptr SymbolStringPtr)
symStrPtrPtr Ptr (Ptr JITEvaluatedSymbol)
symValPtrPtr
  where ([MangledSymbol]
symNames, [JITSymbol]
symVals) = [(MangledSymbol, JITSymbol)] -> ([MangledSymbol], [JITSymbol])
forall a b. [(a, b)] -> ([a], [b])
unzip [(MangledSymbol, JITSymbol)]
symList

-- | Looks up an (unmangled) symbol name in the given 'JITDylib'.
--
-- The symbol is expected to have been added to the 'JITDylib' by the same 'IRLayer'
-- as specified in this function. Using a different 'IRLayer' can cause the lookup
-- to fail due to differences in mangling schemes.
lookupSymbol :: IRLayer l => ExecutionSession -> l -> JITDylib -> ShortByteString -> IO (Either JITSymbolError JITSymbol)
lookupSymbol :: forall l.
IRLayer l =>
ExecutionSession
-> l
-> JITDylib
-> ShortByteString
-> IO (Either JITSymbolError JITSymbol)
lookupSymbol (ExecutionSession Ptr ExecutionSession
es IORef [IO ()]
_) l
irl (JITDylib Ptr JITDylib
dylib) ShortByteString
name = ShortByteString
-> (CString -> IO (Either JITSymbolError JITSymbol))
-> IO (Either JITSymbolError JITSymbol)
forall a. ShortByteString -> (CString -> IO a) -> IO a
SBS.useAsCString ShortByteString
name ((CString -> IO (Either JITSymbolError JITSymbol))
 -> IO (Either JITSymbolError JITSymbol))
-> (CString -> IO (Either JITSymbolError JITSymbol))
-> IO (Either JITSymbolError JITSymbol)
forall a b. (a -> b) -> a -> b
$ \CString
nameStr ->
  (Either JITSymbolError JITSymbol
 -> IO (Either JITSymbolError JITSymbol))
-> AnyContT IO (Either JITSymbolError JITSymbol)
-> IO (Either JITSymbolError JITSymbol)
forall a (m :: * -> *) r. (a -> m r) -> AnyContT m a -> m r
runAnyContT' Either JITSymbolError JITSymbol
-> IO (Either JITSymbolError JITSymbol)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyContT IO (Either JITSymbolError JITSymbol)
 -> IO (Either JITSymbolError JITSymbol))
-> AnyContT IO (Either JITSymbolError JITSymbol)
-> IO (Either JITSymbolError JITSymbol)
forall a b. (a -> b) -> a -> b
$ do
    Ptr ExpectedJITEvaluatedSymbol
symbol <- (forall r. (Ptr ExpectedJITEvaluatedSymbol -> IO r) -> IO r)
-> AnyContT IO (Ptr ExpectedJITEvaluatedSymbol)
forall a. (forall r. (a -> IO r) -> IO r) -> AnyContT IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadAnyCont b m =>
(forall r. (a -> b r) -> b r) -> m a
anyContToM ((forall r. (Ptr ExpectedJITEvaluatedSymbol -> IO r) -> IO r)
 -> AnyContT IO (Ptr ExpectedJITEvaluatedSymbol))
-> (forall r. (Ptr ExpectedJITEvaluatedSymbol -> IO r) -> IO r)
-> AnyContT IO (Ptr ExpectedJITEvaluatedSymbol)
forall a b. (a -> b) -> a -> b
$ IO (Ptr ExpectedJITEvaluatedSymbol)
-> (Ptr ExpectedJITEvaluatedSymbol -> IO ())
-> (Ptr ExpectedJITEvaluatedSymbol -> IO r)
-> IO r
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (Ptr ExecutionSession
-> Ptr JITDylib
-> Ptr MangleAndInterner
-> CString
-> IO (Ptr ExpectedJITEvaluatedSymbol)
FFI.lookupSymbol Ptr ExecutionSession
es Ptr JITDylib
dylib (l -> Ptr MangleAndInterner
forall l. IRLayer l => l -> Ptr MangleAndInterner
getMangler l
irl) CString
nameStr) Ptr ExpectedJITEvaluatedSymbol -> IO ()
FFI.disposeExpectedJITEvaluatedSymbol
    Ptr ExpectedJITEvaluatedSymbol
-> AnyContT IO (Either JITSymbolError JITSymbol)
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM Ptr ExpectedJITEvaluatedSymbol
symbol

--------------------------------------------------------------------------------
-- ThreadSafeContext
--------------------------------------------------------------------------------

newtype ThreadSafeContext = ThreadSafeContext (Ptr FFI.ThreadSafeContext)

-- | Create a 'ThreadSafeContext'
createThreadSafeContext :: IO ThreadSafeContext
createThreadSafeContext :: IO ThreadSafeContext
createThreadSafeContext = Ptr ThreadSafeContext -> ThreadSafeContext
ThreadSafeContext (Ptr ThreadSafeContext -> ThreadSafeContext)
-> IO (Ptr ThreadSafeContext) -> IO ThreadSafeContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ThreadSafeContext)
FFI.createThreadSafeContext

-- | Dispose of a 'ThreadSafeContext'
disposeThreadSafeContext :: ThreadSafeContext -> IO ()
disposeThreadSafeContext :: ThreadSafeContext -> IO ()
disposeThreadSafeContext (ThreadSafeContext Ptr ThreadSafeContext
ctx) = Ptr ThreadSafeContext -> IO ()
FFI.disposeThreadSafeContext Ptr ThreadSafeContext
ctx

-- | 'bracket'-style wrapper around 'createThreadSafeContext'
-- and 'disposeThreadSafeContext'.
withThreadSafeContext :: (ThreadSafeContext -> IO a) -> IO a
withThreadSafeContext :: forall a. (ThreadSafeContext -> IO a) -> IO a
withThreadSafeContext = IO ThreadSafeContext
-> (ThreadSafeContext -> IO ())
-> (ThreadSafeContext -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO ThreadSafeContext
createThreadSafeContext ThreadSafeContext -> IO ()
disposeThreadSafeContext

--------------------------------------------------------------------------------
-- ThreadSafeModule
--------------------------------------------------------------------------------

newtype ThreadSafeModule = ThreadSafeModule (Ptr FFI.ThreadSafeModule)

-- | Create a 'ThreadSafeModule' with the same content as the input 'Module'.
--
-- The module will get cloned into a fresh LLVM context. The lifetime of the
-- new context is bound to the lifetime of the returned 'ThreadSafeModule'.
cloneAsThreadSafeModule :: Module -> IO ThreadSafeModule
cloneAsThreadSafeModule :: Module -> IO ThreadSafeModule
cloneAsThreadSafeModule Module
m = do
  Ptr Module
mPtr <- Module -> IO (Ptr Module)
forall (m :: * -> *). MonadIO m => Module -> m (Ptr Module)
readModule Module
m
  Ptr ThreadSafeModule -> ThreadSafeModule
ThreadSafeModule (Ptr ThreadSafeModule -> ThreadSafeModule)
-> IO (Ptr ThreadSafeModule) -> IO ThreadSafeModule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Module -> IO (Ptr ThreadSafeModule)
FFI.cloneAsThreadSafeModule Ptr Module
mPtr

-- | Dispose of a 'ThreadSafeModule'.
disposeThreadSafeModule :: ThreadSafeModule -> IO ()
disposeThreadSafeModule :: ThreadSafeModule -> IO ()
disposeThreadSafeModule (ThreadSafeModule Ptr ThreadSafeModule
m) = Ptr ThreadSafeModule -> IO ()
FFI.disposeThreadSafeModule Ptr ThreadSafeModule
m

-- | 'bracket'-style wrapper around 'cloneAsThreadSafeModule'
-- and 'disposeThreadSafeModule'.
withClonedThreadSafeModule :: Module -> (ThreadSafeModule -> IO a) -> IO a
withClonedThreadSafeModule :: forall a. Module -> (ThreadSafeModule -> IO a) -> IO a
withClonedThreadSafeModule Module
m = IO ThreadSafeModule
-> (ThreadSafeModule -> IO ())
-> (ThreadSafeModule -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Module -> IO ThreadSafeModule
cloneAsThreadSafeModule Module
m) ThreadSafeModule -> IO ()
disposeThreadSafeModule

--------------------------------------------------------------------------------
-- ObjectLayer + RTDyldObjectLinkingLayer
--------------------------------------------------------------------------------

-- | A type class implemented by the different OrcJIT object layers.
--
-- See e.g. 'RTDyldObjectLinkingLayer'.
class ObjectLayer l where
  getObjectLayer :: l -> Ptr FFI.ObjectLayer


data RTDyldObjectLinkingLayer = RTDyldObjectLinkingLayer !(Ptr FFI.ObjectLayer)

instance ObjectLayer RTDyldObjectLinkingLayer where
  getObjectLayer :: RTDyldObjectLinkingLayer -> Ptr ObjectLayer
getObjectLayer (RTDyldObjectLinkingLayer Ptr ObjectLayer
ol) = Ptr ObjectLayer
ol

-- | Create a new 'RTDyldObjectLinkingLayer'.
--
-- The layer will get automatically disposed along with its ExecutionSession.
createRTDyldObjectLinkingLayer :: ExecutionSession -> IO RTDyldObjectLinkingLayer
createRTDyldObjectLinkingLayer :: ExecutionSession -> IO RTDyldObjectLinkingLayer
createRTDyldObjectLinkingLayer (ExecutionSession Ptr ExecutionSession
es IORef [IO ()]
cleanups) = do
  Ptr ObjectLayer
ol <- Ptr ExecutionSession -> IO (Ptr ObjectLayer)
FFI.createRTDyldObjectLinkingLayer Ptr ExecutionSession
es
  IORef [IO ()] -> ([IO ()] -> [IO ()]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [IO ()]
cleanups (Ptr ObjectLayer -> IO ()
FFI.disposeObjectLayer Ptr ObjectLayer
ol IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
:)
  RTDyldObjectLinkingLayer -> IO RTDyldObjectLinkingLayer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RTDyldObjectLinkingLayer -> IO RTDyldObjectLinkingLayer)
-> RTDyldObjectLinkingLayer -> IO RTDyldObjectLinkingLayer
forall a b. (a -> b) -> a -> b
$ Ptr ObjectLayer -> RTDyldObjectLinkingLayer
RTDyldObjectLinkingLayer Ptr ObjectLayer
ol

data ObjectLinkingLayer = ObjectLinkingLayer !(Ptr FFI.ObjectLayer)

instance ObjectLayer ObjectLinkingLayer where
  getObjectLayer :: ObjectLinkingLayer -> Ptr ObjectLayer
getObjectLayer (ObjectLinkingLayer Ptr ObjectLayer
ol) = Ptr ObjectLayer
ol

createObjectLinkingLayer :: ExecutionSession -> IO ObjectLinkingLayer
createObjectLinkingLayer :: ExecutionSession -> IO ObjectLinkingLayer
createObjectLinkingLayer (ExecutionSession Ptr ExecutionSession
es IORef [IO ()]
cleanups) = do
  Ptr ObjectLayer
ol <- Ptr ExecutionSession -> IO (Ptr ObjectLayer)
FFI.createObjectLinkingLayer Ptr ExecutionSession
es
  IORef [IO ()] -> ([IO ()] -> [IO ()]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [IO ()]
cleanups (Ptr ObjectLayer -> IO ()
FFI.disposeObjectLayer Ptr ObjectLayer
ol IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
:)
  ObjectLinkingLayer -> IO ObjectLinkingLayer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ObjectLinkingLayer -> IO ObjectLinkingLayer)
-> ObjectLinkingLayer -> IO ObjectLinkingLayer
forall a b. (a -> b) -> a -> b
$ Ptr ObjectLayer -> ObjectLinkingLayer
ObjectLinkingLayer Ptr ObjectLayer
ol

addObjectFile :: ObjectLayer l => l -> JITDylib -> FilePath -> IO ()
addObjectFile :: forall l. ObjectLayer l => l -> JITDylib -> String -> IO ()
addObjectFile l
ol (JITDylib Ptr JITDylib
dylib) String
path = do
  String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
path ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cStr ->
    Ptr ObjectLayer -> Ptr JITDylib -> CString -> IO ()
FFI.objectLayerAddObjectFile (l -> Ptr ObjectLayer
forall l. ObjectLayer l => l -> Ptr ObjectLayer
getObjectLayer l
ol) Ptr JITDylib
dylib CString
cStr

--------------------------------------------------------------------------------
-- IRLayer + IRCompileLayer
--------------------------------------------------------------------------------

-- | A mangled symbol name. Valid only for as long as the IRLayer that created it.
newtype MangledSymbol = MangledSymbol (Ptr FFI.SymbolStringPtr)

-- | A type class implemented by the different OrcJIT IR layers.
--
-- See e.g. 'IRCompileLayer'.
class IRLayer l where
  getIRLayer :: l -> Ptr FFI.IRLayer
  getDataLayout :: l -> Ptr FFI.DataLayout
  getMangler :: l -> Ptr FFI.MangleAndInterner

-- | Add a 'Module' to the specified 'JITDylib'.
--
-- The specified 'IRLayer' will be responsible for compiling the symbols
-- present in the module. The module itself is consumed and __should not be used again__.
addModule :: IRLayer l => ThreadSafeModule -> JITDylib -> l -> IO ()
addModule :: forall l. IRLayer l => ThreadSafeModule -> JITDylib -> l -> IO ()
addModule (ThreadSafeModule Ptr ThreadSafeModule
m) (JITDylib Ptr JITDylib
dylib) l
irl =
  Ptr ThreadSafeModule
-> Ptr JITDylib -> Ptr DataLayout -> Ptr IRLayer -> IO ()
FFI.irLayerAddModule Ptr ThreadSafeModule
m Ptr JITDylib
dylib (l -> Ptr DataLayout
forall l. IRLayer l => l -> Ptr DataLayout
getDataLayout l
irl) (l -> Ptr IRLayer
forall l. IRLayer l => l -> Ptr IRLayer
getIRLayer l
irl)

mangleSymbol :: IRLayer l => l -> ShortByteString -> IO MangledSymbol
mangleSymbol :: forall l. IRLayer l => l -> ShortByteString -> IO MangledSymbol
mangleSymbol l
irl ShortByteString
name = ShortByteString
-> (CString -> IO MangledSymbol) -> IO MangledSymbol
forall a. ShortByteString -> (CString -> IO a) -> IO a
SBS.useAsCString ShortByteString
name ((CString -> IO MangledSymbol) -> IO MangledSymbol)
-> (CString -> IO MangledSymbol) -> IO MangledSymbol
forall a b. (a -> b) -> a -> b
$ \CString
namePtr ->
  Ptr SymbolStringPtr -> MangledSymbol
MangledSymbol (Ptr SymbolStringPtr -> MangledSymbol)
-> IO (Ptr SymbolStringPtr) -> IO MangledSymbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr MangleAndInterner -> CString -> IO (Ptr SymbolStringPtr)
FFI.mangleSymbol (l -> Ptr MangleAndInterner
forall l. IRLayer l => l -> Ptr MangleAndInterner
getMangler l
irl) CString
namePtr

disposeMangledSymbol :: MangledSymbol -> IO ()
disposeMangledSymbol :: MangledSymbol -> IO ()
disposeMangledSymbol (MangledSymbol Ptr SymbolStringPtr
symbol) = Ptr SymbolStringPtr -> IO ()
FFI.disposeMangledSymbol Ptr SymbolStringPtr
symbol

withMangledSymbol :: IRLayer l => l -> ShortByteString -> (MangledSymbol -> IO a) -> IO a
withMangledSymbol :: forall l a.
IRLayer l =>
l -> ShortByteString -> (MangledSymbol -> IO a) -> IO a
withMangledSymbol l
irl ShortByteString
name = IO MangledSymbol
-> (MangledSymbol -> IO ()) -> (MangledSymbol -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (l -> ShortByteString -> IO MangledSymbol
forall l. IRLayer l => l -> ShortByteString -> IO MangledSymbol
mangleSymbol l
irl ShortByteString
name) MangledSymbol -> IO ()
disposeMangledSymbol

-- | An IR layer that compiles the symbols in a module eagerly.
data IRCompileLayer = IRCompileLayer !(Ptr FFI.IRLayer) !(Ptr FFI.DataLayout) !(Ptr FFI.MangleAndInterner)

instance IRLayer IRCompileLayer where
  getIRLayer :: IRCompileLayer -> Ptr IRLayer
getIRLayer    (IRCompileLayer Ptr IRLayer
cl Ptr DataLayout
_ Ptr MangleAndInterner
_) = Ptr IRLayer
cl
  getDataLayout :: IRCompileLayer -> Ptr DataLayout
getDataLayout (IRCompileLayer Ptr IRLayer
_ Ptr DataLayout
dl Ptr MangleAndInterner
_) = Ptr DataLayout
dl
  getMangler :: IRCompileLayer -> Ptr MangleAndInterner
getMangler    (IRCompileLayer Ptr IRLayer
_ Ptr DataLayout
_ Ptr MangleAndInterner
mg) = Ptr MangleAndInterner
mg

-- | Create a new 'IRCompileLayer'.
--
-- The layer will get automatically disposed along with its ExecutionSession.
createIRCompileLayer :: ObjectLayer l => ExecutionSession -> l -> TargetMachine -> IO IRCompileLayer
createIRCompileLayer :: forall l.
ObjectLayer l =>
ExecutionSession -> l -> TargetMachine -> IO IRCompileLayer
createIRCompileLayer (ExecutionSession Ptr ExecutionSession
es IORef [IO ()]
cleanups) l
ol (TargetMachine Ptr TargetMachine
tm) = do
  Ptr DataLayout
dl <- Ptr TargetMachine -> IO (Ptr DataLayout)
FFI.createTargetDataLayout Ptr TargetMachine
tm
  IORef [IO ()] -> ([IO ()] -> [IO ()]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [IO ()]
cleanups (Ptr DataLayout -> IO ()
FFI.disposeDataLayout Ptr DataLayout
dl IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
:)
  Ptr MangleAndInterner
mg <- Ptr ExecutionSession
-> Ptr DataLayout -> IO (Ptr MangleAndInterner)
FFI.createMangleAndInterner Ptr ExecutionSession
es Ptr DataLayout
dl
  IORef [IO ()] -> ([IO ()] -> [IO ()]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [IO ()]
cleanups (Ptr MangleAndInterner -> IO ()
FFI.disposeMangleAndInterner Ptr MangleAndInterner
mg IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
:)
  Ptr IRLayer
cl <- Ptr ExecutionSession
-> Ptr ObjectLayer -> Ptr TargetMachine -> IO (Ptr IRLayer)
FFI.createIRCompileLayer Ptr ExecutionSession
es (l -> Ptr ObjectLayer
forall l. ObjectLayer l => l -> Ptr ObjectLayer
getObjectLayer l
ol) Ptr TargetMachine
tm
  IORef [IO ()] -> ([IO ()] -> [IO ()]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [IO ()]
cleanups (Ptr IRLayer -> IO ()
FFI.disposeIRLayer Ptr IRLayer
cl IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
:)
  IRCompileLayer -> IO IRCompileLayer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IRCompileLayer -> IO IRCompileLayer)
-> IRCompileLayer -> IO IRCompileLayer
forall a b. (a -> b) -> a -> b
$ Ptr IRLayer
-> Ptr DataLayout -> Ptr MangleAndInterner -> IRCompileLayer
IRCompileLayer Ptr IRLayer
cl Ptr DataLayout
dl Ptr MangleAndInterner
mg