{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
UnboxedTuples, LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module GHCi.Run
( run, redirectInterrupts
) where
import Prelude
#if !defined(javascript_HOST_ARCH)
import GHCi.CreateBCO
import GHCi.InfoTable
import Data.Binary
import Data.Binary.Get
#endif
import GHCi.FFI
import GHCi.Message
import GHCi.ObjLink
import GHCi.RemoteTypes
import GHCi.TH
import GHCi.BreakArray
import GHCi.StaticPtrTable
import Control.Concurrent
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
import qualified GHC.Exts.Heap as Heap
import GHC.Stack
import Foreign hiding (void)
import Foreign.C
import GHC.Conc.Sync
import GHC.IO hiding ( bracket )
import System.Mem.Weak ( deRefWeak )
import Unsafe.Coerce
foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
run :: Message a -> IO a
run :: forall a. Message a -> IO a
run Message a
m = case Message a
m of
#if defined(javascript_HOST_ARCH)
LoadObj p -> withCString p loadJS
InitLinker -> notSupportedJS m
LoadDLL {} -> notSupportedJS m
LoadArchive {} -> notSupportedJS m
UnloadObj {} -> notSupportedJS m
AddLibrarySearchPath {} -> notSupportedJS m
RemoveLibrarySearchPath {} -> notSupportedJS m
MkConInfoTable {} -> notSupportedJS m
ResolveObjs -> notSupportedJS m
FindSystemLibrary {} -> notSupportedJS m
CreateBCOs {} -> notSupportedJS m
LookupClosure str -> lookupJSClosure str
#else
Message a
InitLinker -> ShouldRetainCAFs -> IO ()
initObjLinker ShouldRetainCAFs
RetainCAFs
LoadDLL String
str -> (Ptr LoadedDLL -> RemotePtr LoadedDLL)
-> Either String (Ptr LoadedDLL)
-> Either String (RemotePtr LoadedDLL)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ptr LoadedDLL -> RemotePtr LoadedDLL
forall a. Ptr a -> RemotePtr a
toRemotePtr (Either String (Ptr LoadedDLL) -> a)
-> IO (Either String (Ptr LoadedDLL)) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either String (Ptr LoadedDLL))
loadDLL String
str
LoadArchive String
str -> String -> IO ()
loadArchive String
str
LoadObj String
str -> String -> IO ()
loadObj String
str
UnloadObj String
str -> String -> IO ()
unloadObj String
str
AddLibrarySearchPath String
str -> Ptr () -> a
Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr (Ptr () -> a) -> IO (Ptr ()) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Ptr ())
addLibrarySearchPath String
str
RemoveLibrarySearchPath RemotePtr ()
ptr -> Ptr () -> IO Bool
removeLibrarySearchPath (RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ()
ptr)
MkConInfoTable Bool
tc Int
ptrs Int
nptrs Int
tag Int
ptrtag ByteString
desc ->
Ptr StgInfoTable -> a
Ptr StgInfoTable -> RemotePtr StgInfoTable
forall a. Ptr a -> RemotePtr a
toRemotePtr (Ptr StgInfoTable -> a) -> IO (Ptr StgInfoTable) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Int -> Int -> Int -> Int -> ByteString -> IO (Ptr StgInfoTable)
mkConInfoTable Bool
tc Int
ptrs Int
nptrs Int
tag Int
ptrtag ByteString
desc
Message a
ResolveObjs -> IO a
IO Bool
resolveObjs
FindSystemLibrary String
str -> String -> IO (Maybe String)
findSystemLibrary String
str
CreateBCOs [ByteString]
bcos -> [ResolvedBCO] -> IO [HValueRef]
createBCOs ((ByteString -> [ResolvedBCO]) -> [ByteString] -> [ResolvedBCO]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Get [ResolvedBCO] -> ByteString -> [ResolvedBCO]
forall a. Get a -> ByteString -> a
runGet Get [ResolvedBCO]
forall t. Binary t => Get t
get) [ByteString]
bcos)
LookupClosure String
str -> String -> IO (Maybe HValueRef)
lookupClosure String
str
#endif
Message a
RtsRevertCAFs -> IO a
IO ()
rts_revertCAFs
LookupSymbol String
str -> (Ptr () -> RemotePtr ()) -> Maybe (Ptr ()) -> Maybe (RemotePtr ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr (Maybe (Ptr ()) -> a) -> IO (Maybe (Ptr ())) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe (Ptr ()))
forall a. String -> IO (Maybe (Ptr a))
lookupSymbol String
str
LookupSymbolInDLL RemotePtr LoadedDLL
dll String
str ->
(Ptr () -> RemotePtr ()) -> Maybe (Ptr ()) -> Maybe (RemotePtr ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr (Maybe (Ptr ()) -> a) -> IO (Maybe (Ptr ())) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr LoadedDLL -> String -> IO (Maybe (Ptr ()))
forall a. Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
lookupSymbolInDLL (RemotePtr LoadedDLL -> Ptr LoadedDLL
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr LoadedDLL
dll) String
str
FreeHValueRefs [HValueRef]
rs -> (HValueRef -> IO ()) -> [HValueRef] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HValueRef -> IO ()
forall a. RemoteRef a -> IO ()
freeRemoteRef [HValueRef]
rs
AddSptEntry Fingerprint
fpr HValueRef
r -> HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
r IO HValue -> (HValue -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fingerprint -> HValue -> IO ()
sptAddEntry Fingerprint
fpr
EvalStmt EvalOpts
opts EvalExpr HValueRef
r -> EvalOpts
-> EvalExpr HValueRef -> IO (EvalStatus_ [HValueRef] [HValueRef])
evalStmt EvalOpts
opts EvalExpr HValueRef
r
ResumeStmt EvalOpts
opts RemoteRef (ResumeContext [HValueRef])
r -> EvalOpts
-> RemoteRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
resumeStmt EvalOpts
opts RemoteRef (ResumeContext [HValueRef])
r
AbandonStmt RemoteRef (ResumeContext [HValueRef])
r -> RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt RemoteRef (ResumeContext [HValueRef])
r
EvalString HValueRef
r -> HValueRef -> IO (EvalResult String)
evalString HValueRef
r
EvalStringToString HValueRef
r String
s -> HValueRef -> String -> IO (EvalResult String)
evalStringToString HValueRef
r String
s
EvalIO HValueRef
r -> HValueRef -> IO (EvalResult ())
evalIO HValueRef
r
MkCostCentres String
mod [(String, String)]
ccs -> String -> [(String, String)] -> IO [RemotePtr CostCentre]
mkCostCentres String
mod [(String, String)]
ccs
CostCentreStackInfo RemotePtr CostCentreStack
ptr -> Ptr CostCentreStack -> IO [String]
ccsToStrings (RemotePtr CostCentreStack -> Ptr CostCentreStack
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr CostCentreStack
ptr)
NewBreakArray Int
sz -> BreakArray -> IO a
BreakArray -> IO (RemoteRef BreakArray)
forall a. a -> IO (RemoteRef a)
mkRemoteRef (BreakArray -> IO a) -> IO BreakArray -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO BreakArray
newBreakArray Int
sz
SetupBreakpoint RemoteRef BreakArray
ref Int
ix Int
cnt -> do
BreakArray
arr <- RemoteRef BreakArray -> IO BreakArray
forall a. RemoteRef a -> IO a
localRef RemoteRef BreakArray
ref;
Bool
_ <- BreakArray -> Int -> Int -> IO Bool
setupBreakpoint BreakArray
arr Int
ix Int
cnt
a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
BreakpointStatus RemoteRef BreakArray
ref Int
ix -> do
BreakArray
arr <- RemoteRef BreakArray -> IO BreakArray
forall a. RemoteRef a -> IO a
localRef RemoteRef BreakArray
ref; Maybe Int
r <- BreakArray -> Int -> IO (Maybe Int)
getBreak BreakArray
arr Int
ix
case Maybe Int
r of
Maybe Int
Nothing -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
Bool
False
Just Int
w -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
GetBreakpointVar HValueRef
ref Int
ix -> do
HValue
aps <- HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
ref
(HValue -> IO HValueRef) -> Maybe HValue -> IO (Maybe HValueRef)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef (Maybe HValue -> IO a) -> IO (Maybe HValue) -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack HValue
aps Int
ix
MallocData ByteString
bs -> ByteString -> IO (RemotePtr ())
mkString ByteString
bs
MallocStrings [ByteString]
bss -> (ByteString -> IO (RemotePtr ()))
-> [ByteString] -> IO [RemotePtr ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ByteString -> IO (RemotePtr ())
mkString0 [ByteString]
bss
PrepFFI FFIConv
conv [FFIType]
args FFIType
res -> Ptr C_ffi_cif -> a
Ptr C_ffi_cif -> RemotePtr C_ffi_cif
forall a. Ptr a -> RemotePtr a
toRemotePtr (Ptr C_ffi_cif -> a) -> IO (Ptr C_ffi_cif) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FFIConv -> [FFIType] -> FFIType -> IO (Ptr C_ffi_cif)
prepForeignCall FFIConv
conv [FFIType]
args FFIType
res
FreeFFI RemotePtr C_ffi_cif
p -> Ptr C_ffi_cif -> IO ()
freeForeignCallInfo (RemotePtr C_ffi_cif -> Ptr C_ffi_cif
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr C_ffi_cif
p)
Message a
StartTH -> IO a
IO (RemoteRef (IORef QState))
startTH
GetClosure HValueRef
ref -> do
Closure
clos <- HValue -> IO Closure
forall a. HasHeapRep a => a -> IO Closure
Heap.getClosureData (HValue -> IO Closure) -> IO HValue -> IO Closure
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
ref
(Box -> IO HValueRef) -> Closure -> IO (GenClosure HValueRef)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GenClosure a -> m (GenClosure b)
mapM (\(Heap.Box Any
x) -> HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef (Any -> HValue
HValue Any
x)) Closure
clos
Seq HValueRef
ref -> HValueRef -> IO (EvalStatus_ () ())
forall a. RemoteRef a -> IO (EvalStatus_ () ())
doSeq HValueRef
ref
ResumeSeq RemoteRef (ResumeContext ())
ref -> RemoteRef (ResumeContext ()) -> IO (EvalStatus_ () ())
resumeSeq RemoteRef (ResumeContext ())
ref
Message a
Shutdown -> Message a -> IO a
forall a b. Message a -> b
unexpectedMessage Message a
m
RunTH {} -> Message a -> IO a
forall a b. Message a -> b
unexpectedMessage Message a
m
RunModFinalizers {} -> Message a -> IO a
forall a b. Message a -> b
unexpectedMessage Message a
m
unexpectedMessage :: Message a -> b
unexpectedMessage :: forall a b. Message a -> b
unexpectedMessage Message a
m = String -> b
forall a. HasCallStack => String -> a
error (String
"GHCi.Run.Run: unexpected message: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Message a -> String
forall a. Show a => a -> String
show Message a
m)
#if defined(javascript_HOST_ARCH)
foreign import javascript "((ptr,off) => globalThis.h$loadJS(h$decodeUtf8z(ptr,off)))" loadJS :: CString -> IO ()
foreign import javascript "((ptr,off) => globalThis.h$lookupClosure(h$decodeUtf8z(ptr,off)))" lookupJSClosure# :: CString -> State# RealWorld -> (# State# RealWorld, Int# #)
lookupJSClosure' :: String -> IO Int
lookupJSClosure' str = withCString str $ \cstr -> IO (\s ->
case lookupJSClosure# cstr s of
(# s', r #) -> (# s', I# r #))
lookupJSClosure :: String -> IO (Maybe HValueRef)
lookupJSClosure str = lookupJSClosure' str >>= \case
0 -> pure Nothing
r -> pure (Just (RemoteRef (RemotePtr (fromIntegral r))))
notSupportedJS :: Message a -> b
notSupportedJS m = error ("Message not supported with the JavaScript interpreter: " ++ show m)
#endif
evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
evalStmt :: EvalOpts
-> EvalExpr HValueRef -> IO (EvalStatus_ [HValueRef] [HValueRef])
evalStmt EvalOpts
opts EvalExpr HValueRef
expr = do
HValue
io <- EvalExpr HValueRef -> IO HValue
mkIO EvalExpr HValueRef
expr
EvalOpts
-> IO [HValueRef] -> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO EvalOpts
opts (IO [HValueRef] -> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO [HValueRef] -> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a b. (a -> b) -> a -> b
$ do
[HValue]
rs <- HValue -> IO [HValue]
forall a b. a -> b
unsafeCoerce HValue
io :: IO [HValue]
(HValue -> IO HValueRef) -> [HValue] -> IO [HValueRef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef [HValue]
rs
where
mkIO :: EvalExpr HValueRef -> IO HValue
mkIO (EvalThis HValueRef
href) = HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
href
mkIO (EvalApp EvalExpr HValueRef
l EvalExpr HValueRef
r) = do
HValue
l' <- EvalExpr HValueRef -> IO HValue
mkIO EvalExpr HValueRef
l
HValue
r' <- EvalExpr HValueRef -> IO HValue
mkIO EvalExpr HValueRef
r
HValue -> IO HValue
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((HValue -> HValue -> HValue
forall a b. a -> b
unsafeCoerce HValue
l' :: HValue -> HValue) HValue
r')
evalIO :: HValueRef -> IO (EvalResult ())
evalIO :: HValueRef -> IO (EvalResult ())
evalIO HValueRef
r = do
HValue
io <- HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
r
IO () -> IO (EvalResult ())
forall a. IO a -> IO (EvalResult a)
tryEval (HValue -> IO ()
forall a b. a -> b
unsafeCoerce HValue
io :: IO ())
evalString :: HValueRef -> IO (EvalResult String)
evalString :: HValueRef -> IO (EvalResult String)
evalString HValueRef
r = do
HValue
io <- HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
r
IO String -> IO (EvalResult String)
forall a. IO a -> IO (EvalResult a)
tryEval (IO String -> IO (EvalResult String))
-> IO String -> IO (EvalResult String)
forall a b. (a -> b) -> a -> b
$ do
String
r <- HValue -> IO String
forall a b. a -> b
unsafeCoerce HValue
io :: IO String
String -> IO String
forall a. a -> IO a
evaluate (String -> String
forall a. NFData a => a -> a
force String
r)
evalStringToString :: HValueRef -> String -> IO (EvalResult String)
evalStringToString :: HValueRef -> String -> IO (EvalResult String)
evalStringToString HValueRef
r String
str = do
HValue
io <- HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
r
IO String -> IO (EvalResult String)
forall a. IO a -> IO (EvalResult a)
tryEval (IO String -> IO (EvalResult String))
-> IO String -> IO (EvalResult String)
forall a b. (a -> b) -> a -> b
$ do
String
r <- (HValue -> String -> IO String
forall a b. a -> b
unsafeCoerce HValue
io :: String -> IO String) String
str
String -> IO String
forall a. a -> IO a
evaluate (String -> String
forall a. NFData a => a -> a
force String
r)
doSeq :: RemoteRef a -> IO (EvalStatus ())
doSeq :: forall a. RemoteRef a -> IO (EvalStatus_ () ())
doSeq RemoteRef a
ref = do
EvalOpts -> IO () -> IO (EvalStatus_ () ())
forall a. EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO EvalOpts
evalOptsSeq (IO () -> IO (EvalStatus_ () ()))
-> IO () -> IO (EvalStatus_ () ())
forall a b. (a -> b) -> a -> b
$ do
()
_ <- (IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
evaluate (a -> IO a) -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RemoteRef a -> IO a
forall a. RemoteRef a -> IO a
localRef RemoteRef a
ref)
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())
resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus_ () ())
resumeSeq RemoteRef (ResumeContext ())
hvref = do
ResumeContext{MVar ()
MVar (EvalStatus_ () ())
ThreadId
resumeBreakMVar :: MVar ()
resumeStatusMVar :: MVar (EvalStatus_ () ())
resumeThreadId :: ThreadId
resumeThreadId :: forall a. ResumeContext a -> ThreadId
resumeStatusMVar :: forall a. ResumeContext a -> MVar (EvalStatus a)
resumeBreakMVar :: forall a. ResumeContext a -> MVar ()
..} <- RemoteRef (ResumeContext ()) -> IO (ResumeContext ())
forall a. RemoteRef a -> IO a
localRef RemoteRef (ResumeContext ())
hvref
EvalOpts
-> MVar ()
-> MVar (EvalStatus_ () ())
-> IO (EvalStatus_ () ())
-> IO (EvalStatus_ () ())
forall b a.
EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
withBreakAction EvalOpts
evalOptsSeq MVar ()
resumeBreakMVar MVar (EvalStatus_ () ())
resumeStatusMVar (IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ()))
-> IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a b. (a -> b) -> a -> b
$
IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a. IO a -> IO a
mask_ (IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ()))
-> IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a b. (a -> b) -> a -> b
$ do
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
resumeBreakMVar ()
ThreadId -> IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a. ThreadId -> IO a -> IO a
redirectInterrupts ThreadId
resumeThreadId (IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ()))
-> IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a b. (a -> b) -> a -> b
$ MVar (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a. MVar a -> IO a
takeMVar MVar (EvalStatus_ () ())
resumeStatusMVar
evalOptsSeq :: EvalOpts
evalOptsSeq :: EvalOpts
evalOptsSeq = EvalOpts
{ useSandboxThread :: Bool
useSandboxThread = Bool
True
, singleStep :: Bool
singleStep = Bool
False
, breakOnException :: Bool
breakOnException = Bool
False
, breakOnError :: Bool
breakOnError = Bool
False
}
sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO :: forall a. EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO EvalOpts
opts IO a
io = do
MVar ()
breakMVar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar (EvalStatus a)
statusMVar <- IO (MVar (EvalStatus a))
forall a. IO (MVar a)
newEmptyMVar
EvalOpts
-> MVar ()
-> MVar (EvalStatus a)
-> IO (EvalStatus a)
-> IO (EvalStatus a)
forall b a.
EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
withBreakAction EvalOpts
opts MVar ()
breakMVar MVar (EvalStatus a)
statusMVar (IO (EvalStatus a) -> IO (EvalStatus a))
-> IO (EvalStatus a) -> IO (EvalStatus a)
forall a b. (a -> b) -> a -> b
$ do
let runIt :: IO (EvalStatus a)
runIt = IO (EvalResult a) -> IO (EvalStatus a)
forall a. IO (EvalResult a) -> IO (EvalStatus a)
measureAlloc (IO (EvalResult a) -> IO (EvalStatus a))
-> IO (EvalResult a) -> IO (EvalStatus a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (EvalResult a)
forall a. IO a -> IO (EvalResult a)
tryEval (IO a -> IO (EvalResult a)) -> IO a -> IO (EvalResult a)
forall a b. (a -> b) -> a -> b
$ EvalOpts -> IO a -> IO a
forall a. EvalOpts -> IO a -> IO a
rethrow EvalOpts
opts (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
clearCCS IO a
io
if EvalOpts -> Bool
useSandboxThread EvalOpts
opts
then do
ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do IO (EvalStatus a) -> IO (EvalStatus a)
forall a. IO a -> IO a
unsafeUnmask IO (EvalStatus a)
runIt IO (EvalStatus a) -> (EvalStatus a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (EvalStatus a) -> EvalStatus a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (EvalStatus a)
statusMVar
ThreadId -> IO (EvalStatus a) -> IO (EvalStatus a)
forall a. ThreadId -> IO a -> IO a
redirectInterrupts ThreadId
tid (IO (EvalStatus a) -> IO (EvalStatus a))
-> IO (EvalStatus a) -> IO (EvalStatus a)
forall a b. (a -> b) -> a -> b
$ IO (EvalStatus a) -> IO (EvalStatus a)
forall a. IO a -> IO a
unsafeUnmask (IO (EvalStatus a) -> IO (EvalStatus a))
-> IO (EvalStatus a) -> IO (EvalStatus a)
forall a b. (a -> b) -> a -> b
$ MVar (EvalStatus a) -> IO (EvalStatus a)
forall a. MVar a -> IO a
takeMVar MVar (EvalStatus a)
statusMVar
else
IO (EvalStatus a)
runIt
rethrow :: EvalOpts -> IO a -> IO a
rethrow :: forall a. EvalOpts -> IO a -> IO a
rethrow EvalOpts{Bool
useSandboxThread :: EvalOpts -> Bool
singleStep :: EvalOpts -> Bool
breakOnException :: EvalOpts -> Bool
breakOnError :: EvalOpts -> Bool
useSandboxThread :: Bool
singleStep :: Bool
breakOnException :: Bool
breakOnError :: Bool
..} IO a
io =
IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
io ((SomeException -> IO a) -> IO a)
-> (SomeException -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SomeException
se -> do
if Bool
breakOnError Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
breakOnException
then Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
exceptionFlag CInt
1
else case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se of
Just AsyncException
UserInterrupt -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe AsyncException
_ -> Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
exceptionFlag CInt
0
SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
se
redirectInterrupts :: ThreadId -> IO a -> IO a
redirectInterrupts :: forall a. ThreadId -> IO a -> IO a
redirectInterrupts ThreadId
target IO a
wait = do
Weak ThreadId
wtid <- ThreadId -> IO (Weak ThreadId)
mkWeakThreadId ThreadId
target
IO a
wait IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e -> do
Maybe ThreadId
m <- Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
wtid
case Maybe ThreadId
m of
Maybe ThreadId
Nothing -> IO a
wait
Just ThreadId
target -> do ThreadId -> SomeException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
target (SomeException
e :: SomeException); IO a
wait
measureAlloc :: IO (EvalResult a) -> IO (EvalStatus a)
measureAlloc :: forall a. IO (EvalResult a) -> IO (EvalStatus a)
measureAlloc IO (EvalResult a)
io = do
Int64 -> IO ()
setAllocationCounter Int64
0
EvalResult a
a <- IO (EvalResult a)
io
Int64
ctr <- IO Int64
getAllocationCounter
let allocs :: Word64
allocs = Word64 -> Word64
forall a. Num a => a -> a
negate (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
ctr
EvalStatus a -> IO (EvalStatus a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> EvalResult a -> EvalStatus a
forall a b. Word64 -> EvalResult a -> EvalStatus_ a b
EvalComplete Word64
allocs EvalResult a
a)
tryEval :: IO a -> IO (EvalResult a)
tryEval :: forall a. IO a -> IO (EvalResult a)
tryEval IO a
io = do
Either SomeException a
e <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io
case Either SomeException a
e of
Left SomeException
ex -> EvalResult a -> IO (EvalResult a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SerializableException -> EvalResult a
forall a. SerializableException -> EvalResult a
EvalException (SomeException -> SerializableException
toSerializableException SomeException
ex))
Right a
a -> EvalResult a -> IO (EvalResult a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> EvalResult a
forall a. a -> EvalResult a
EvalSuccess a
a)
withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
withBreakAction :: forall b a.
EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
withBreakAction EvalOpts
opts MVar ()
breakMVar MVar (EvalStatus b)
statusMVar IO a
act
= IO (StablePtr BreakpointCallback)
-> (StablePtr BreakpointCallback -> IO ())
-> (StablePtr BreakpointCallback -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (StablePtr BreakpointCallback)
setBreakAction StablePtr BreakpointCallback -> IO ()
forall {a}. StablePtr a -> IO ()
resetBreakAction (\StablePtr BreakpointCallback
_ -> IO a
act)
where
setBreakAction :: IO (StablePtr BreakpointCallback)
setBreakAction = do
StablePtr BreakpointCallback
stablePtr <- BreakpointCallback -> IO (StablePtr BreakpointCallback)
forall a. a -> IO (StablePtr a)
newStablePtr BreakpointCallback
onBreak
Ptr (StablePtr BreakpointCallback)
-> StablePtr BreakpointCallback -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (StablePtr BreakpointCallback)
breakPointIOAction StablePtr BreakpointCallback
stablePtr
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EvalOpts -> Bool
breakOnException EvalOpts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
exceptionFlag CInt
1
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EvalOpts -> Bool
singleStep EvalOpts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
setStepFlag
StablePtr BreakpointCallback -> IO (StablePtr BreakpointCallback)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StablePtr BreakpointCallback
stablePtr
onBreak :: BreakpointCallback
onBreak :: BreakpointCallback
onBreak Int#
ix# Int#
uniq# Bool
is_exception HValue
apStack = do
ThreadId
tid <- IO ThreadId
myThreadId
let resume :: ResumeContext b
resume = ResumeContext
{ resumeBreakMVar :: MVar ()
resumeBreakMVar = MVar ()
breakMVar
, resumeStatusMVar :: MVar (EvalStatus b)
resumeStatusMVar = MVar (EvalStatus b)
statusMVar
, resumeThreadId :: ThreadId
resumeThreadId = ThreadId
tid }
RemoteRef (ResumeContext b)
resume_r <- ResumeContext b -> IO (RemoteRef (ResumeContext b))
forall a. a -> IO (RemoteRef a)
mkRemoteRef ResumeContext b
resume
HValueRef
apStack_r <- HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef HValue
apStack
RemotePtr CostCentreStack
ccs <- Ptr CostCentreStack -> RemotePtr CostCentreStack
forall a. Ptr a -> RemotePtr a
toRemotePtr (Ptr CostCentreStack -> RemotePtr CostCentreStack)
-> IO (Ptr CostCentreStack) -> IO (RemotePtr CostCentreStack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HValue -> IO (Ptr CostCentreStack)
forall a. a -> IO (Ptr CostCentreStack)
getCCSOf HValue
apStack
MVar (EvalStatus b) -> EvalStatus b -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (EvalStatus b)
statusMVar (EvalStatus b -> IO ()) -> EvalStatus b -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool
-> HValueRef
-> Int
-> Int
-> RemoteRef (ResumeContext b)
-> RemotePtr CostCentreStack
-> EvalStatus b
forall a b.
Bool
-> HValueRef
-> Int
-> Int
-> RemoteRef (ResumeContext b)
-> RemotePtr CostCentreStack
-> EvalStatus_ a b
EvalBreak Bool
is_exception HValueRef
apStack_r (Int# -> Int
I# Int#
ix#) (Int# -> Int
I# Int#
uniq#) RemoteRef (ResumeContext b)
resume_r RemotePtr CostCentreStack
ccs
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
breakMVar
resetBreakAction :: StablePtr a -> IO ()
resetBreakAction StablePtr a
stablePtr = do
Ptr (StablePtr BreakpointCallback)
-> StablePtr BreakpointCallback -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (StablePtr BreakpointCallback)
breakPointIOAction StablePtr BreakpointCallback
noBreakStablePtr
Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
exceptionFlag CInt
0
IO ()
resetStepFlag
StablePtr a -> IO ()
forall {a}. StablePtr a -> IO ()
freeStablePtr StablePtr a
stablePtr
resumeStmt
:: EvalOpts -> RemoteRef (ResumeContext [HValueRef])
-> IO (EvalStatus [HValueRef])
resumeStmt :: EvalOpts
-> RemoteRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
resumeStmt EvalOpts
opts RemoteRef (ResumeContext [HValueRef])
hvref = do
ResumeContext{MVar ()
MVar (EvalStatus_ [HValueRef] [HValueRef])
ThreadId
resumeThreadId :: forall a. ResumeContext a -> ThreadId
resumeStatusMVar :: forall a. ResumeContext a -> MVar (EvalStatus a)
resumeBreakMVar :: forall a. ResumeContext a -> MVar ()
resumeBreakMVar :: MVar ()
resumeStatusMVar :: MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeThreadId :: ThreadId
..} <- RemoteRef (ResumeContext [HValueRef])
-> IO (ResumeContext [HValueRef])
forall a. RemoteRef a -> IO a
localRef RemoteRef (ResumeContext [HValueRef])
hvref
EvalOpts
-> MVar ()
-> MVar (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall b a.
EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
withBreakAction EvalOpts
opts MVar ()
resumeBreakMVar MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeStatusMVar (IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a b. (a -> b) -> a -> b
$
IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. IO a -> IO a
mask_ (IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a b. (a -> b) -> a -> b
$ do
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
resumeBreakMVar ()
ThreadId
-> IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. ThreadId -> IO a -> IO a
redirectInterrupts ThreadId
resumeThreadId (IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a b. (a -> b) -> a -> b
$ MVar (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. MVar a -> IO a
takeMVar MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeStatusMVar
abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt RemoteRef (ResumeContext [HValueRef])
hvref = do
ResumeContext{MVar ()
MVar (EvalStatus_ [HValueRef] [HValueRef])
ThreadId
resumeThreadId :: forall a. ResumeContext a -> ThreadId
resumeStatusMVar :: forall a. ResumeContext a -> MVar (EvalStatus a)
resumeBreakMVar :: forall a. ResumeContext a -> MVar ()
resumeBreakMVar :: MVar ()
resumeStatusMVar :: MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeThreadId :: ThreadId
..} <- RemoteRef (ResumeContext [HValueRef])
-> IO (ResumeContext [HValueRef])
forall a. RemoteRef a -> IO a
localRef RemoteRef (ResumeContext [HValueRef])
hvref
ThreadId -> IO ()
killThread ThreadId
resumeThreadId
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
resumeBreakMVar ()
EvalStatus_ [HValueRef] [HValueRef]
_ <- MVar (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. MVar a -> IO a
takeMVar MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeStatusMVar
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
setStepFlag :: IO ()
setStepFlag :: IO ()
setStepFlag = Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
stepFlag CInt
1
resetStepFlag :: IO ()
resetStepFlag :: IO ()
resetStepFlag = Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
stepFlag CInt
0
type BreakpointCallback
= Int#
-> Int#
-> Bool
-> HValue
-> IO ()
foreign import ccall "&rts_breakpoint_io_action"
breakPointIOAction :: Ptr (StablePtr BreakpointCallback)
noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr = IO (StablePtr BreakpointCallback) -> StablePtr BreakpointCallback
forall a. IO a -> a
unsafePerformIO (IO (StablePtr BreakpointCallback) -> StablePtr BreakpointCallback)
-> IO (StablePtr BreakpointCallback)
-> StablePtr BreakpointCallback
forall a b. (a -> b) -> a -> b
$ BreakpointCallback -> IO (StablePtr BreakpointCallback)
forall a. a -> IO (StablePtr a)
newStablePtr BreakpointCallback
noBreakAction
noBreakAction :: BreakpointCallback
noBreakAction :: BreakpointCallback
noBreakAction Int#
_ Int#
_ Bool
False HValue
_ = String -> IO ()
putStrLn String
"*** Ignoring breakpoint"
noBreakAction Int#
_ Int#
_ Bool
True HValue
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkString :: ByteString -> IO (RemotePtr ())
mkString :: ByteString -> IO (RemotePtr ())
mkString ByteString
bs = ByteString
-> (CStringLen -> IO (RemotePtr ())) -> IO (RemotePtr ())
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO (RemotePtr ())) -> IO (RemotePtr ()))
-> (CStringLen -> IO (RemotePtr ())) -> IO (RemotePtr ())
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstr,Int
len) -> do
Ptr CChar
ptr <- Int -> IO (Ptr CChar)
forall a. Int -> IO (Ptr a)
mallocBytes Int
len
Ptr CChar -> Ptr CChar -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr CChar
ptr Ptr CChar
cstr Int
len
RemotePtr () -> IO (RemotePtr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemotePtr CChar -> RemotePtr ()
forall a b. RemotePtr a -> RemotePtr b
castRemotePtr (Ptr CChar -> RemotePtr CChar
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr CChar
ptr))
mkString0 :: ByteString -> IO (RemotePtr ())
mkString0 :: ByteString -> IO (RemotePtr ())
mkString0 ByteString
bs = ByteString
-> (CStringLen -> IO (RemotePtr ())) -> IO (RemotePtr ())
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO (RemotePtr ())) -> IO (RemotePtr ()))
-> (CStringLen -> IO (RemotePtr ())) -> IO (RemotePtr ())
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstr,Int
len) -> do
Ptr CChar
ptr <- Int -> IO (Ptr CChar)
forall a. Int -> IO (Ptr a)
mallocBytes (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
Ptr CChar -> Ptr CChar -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr CChar
ptr Ptr CChar
cstr Int
len
Ptr CChar -> Int -> CChar -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff (Ptr CChar
ptr :: Ptr CChar) Int
len CChar
0
RemotePtr () -> IO (RemotePtr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemotePtr CChar -> RemotePtr ()
forall a b. RemotePtr a -> RemotePtr b
castRemotePtr (Ptr CChar -> RemotePtr CChar
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr CChar
ptr))
mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
#if defined(PROFILING)
mkCostCentres mod ccs = do
c_module <- newCString mod
mapM (mk_one c_module) ccs
where
mk_one c_module (decl_path,srcspan) = do
c_name <- newCString decl_path
c_srcspan <- newCString srcspan
toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
foreign import ccall unsafe "mkCostCentre"
c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
#else
mkCostCentres :: String -> [(String, String)] -> IO [RemotePtr CostCentre]
mkCostCentres String
_ [(String, String)]
_ = [RemotePtr CostCentre] -> IO [RemotePtr CostCentre]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
#endif
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack HValue
apStack (I# Int#
stackDepth) = do
case HValue -> Int# -> (# Int#, Any #)
forall a b. a -> Int# -> (# Int#, b #)
getApStackVal# HValue
apStack Int#
stackDepth of
(# Int#
ok, Any
result #) ->
case Int#
ok of
Int#
0# -> Maybe HValue -> IO (Maybe HValue)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HValue
forall a. Maybe a
Nothing
Int#
_ -> Maybe HValue -> IO (Maybe HValue)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HValue -> Maybe HValue
forall a. a -> Maybe a
Just (Any -> HValue
forall a b. a -> b
unsafeCoerce# Any
result))