{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
UnboxedTuples #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module GHCi.Run
( run, redirectInterrupts
) where
import Prelude
import GHCi.CreateBCO
import GHCi.InfoTable
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.Binary
import Data.Binary.Get
import Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
import GHC.Exts.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
run :: Message a -> IO a
run :: Message a -> IO a
run m :: Message a
m = case Message a
m of
InitLinker -> ShouldRetainCAFs -> IO ()
initObjLinker ShouldRetainCAFs
RetainCAFs
LookupSymbol str :: String
str -> (Ptr () -> RemotePtr ()) -> Maybe (Ptr ()) -> Maybe (RemotePtr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr (Maybe (Ptr ()) -> Maybe (RemotePtr ()))
-> IO (Maybe (Ptr ())) -> IO (Maybe (RemotePtr ()))
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
LookupClosure str :: String
str -> String -> IO (Maybe HValueRef)
lookupClosure String
str
LoadDLL str :: String
str -> String -> IO (Maybe String)
loadDLL String
str
LoadArchive str :: String
str -> String -> IO ()
loadArchive String
str
LoadObj str :: String
str -> String -> IO ()
loadObj String
str
UnloadObj str :: String
str -> String -> IO ()
unloadObj String
str
AddLibrarySearchPath str :: String
str -> Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr (Ptr () -> RemotePtr ()) -> IO (Ptr ()) -> IO (RemotePtr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Ptr ())
addLibrarySearchPath String
str
RemoveLibrarySearchPath ptr :: RemotePtr ()
ptr -> Ptr () -> IO Bool
removeLibrarySearchPath (RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ()
ptr)
ResolveObjs -> IO a
IO Bool
resolveObjs
FindSystemLibrary str :: String
str -> String -> IO (Maybe String)
findSystemLibrary String
str
CreateBCOs bcos :: [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)
FreeHValueRefs rs :: [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 fpr :: Fingerprint
fpr r :: HValueRef
r -> HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
r IO HValue -> (HValue -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fingerprint -> HValue -> IO ()
sptAddEntry Fingerprint
fpr
EvalStmt opts :: EvalOpts
opts r :: EvalExpr HValueRef
r -> EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
evalStmt EvalOpts
opts EvalExpr HValueRef
r
ResumeStmt opts :: EvalOpts
opts r :: RemoteRef (ResumeContext [HValueRef])
r -> EvalOpts
-> RemoteRef (ResumeContext [HValueRef])
-> IO (EvalStatus [HValueRef])
resumeStmt EvalOpts
opts RemoteRef (ResumeContext [HValueRef])
r
AbandonStmt r :: RemoteRef (ResumeContext [HValueRef])
r -> RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt RemoteRef (ResumeContext [HValueRef])
r
EvalString r :: HValueRef
r -> HValueRef -> IO (EvalResult String)
evalString HValueRef
r
EvalStringToString r :: HValueRef
r s :: String
s -> HValueRef -> String -> IO (EvalResult String)
evalStringToString HValueRef
r String
s
EvalIO r :: HValueRef
r -> HValueRef -> IO (EvalResult ())
evalIO HValueRef
r
MkCostCentres mod :: String
mod ccs :: [(String, String)]
ccs -> String -> [(String, String)] -> IO [RemotePtr CostCentre]
mkCostCentres String
mod [(String, String)]
ccs
CostCentreStackInfo ptr :: RemotePtr CostCentreStack
ptr -> Ptr CostCentreStack -> IO [String]
ccsToStrings (RemotePtr CostCentreStack -> Ptr CostCentreStack
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr CostCentreStack
ptr)
NewBreakArray sz :: Int
sz -> BreakArray -> IO (RemoteRef BreakArray)
forall a. a -> IO (RemoteRef a)
mkRemoteRef (BreakArray -> IO (RemoteRef BreakArray))
-> IO BreakArray -> IO (RemoteRef BreakArray)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO BreakArray
newBreakArray Int
sz
EnableBreakpoint ref :: RemoteRef BreakArray
ref ix :: Int
ix b :: Bool
b -> do
BreakArray
arr <- RemoteRef BreakArray -> IO BreakArray
forall a. RemoteRef a -> IO a
localRef RemoteRef BreakArray
ref
Bool
_ <- if Bool
b then BreakArray -> Int -> IO Bool
setBreakOn BreakArray
arr Int
ix else BreakArray -> Int -> IO Bool
setBreakOff BreakArray
arr Int
ix
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
BreakpointStatus ref :: RemoteRef BreakArray
ref ix :: Int
ix -> do
BreakArray
arr <- RemoteRef BreakArray -> IO BreakArray
forall a. RemoteRef a -> IO a
localRef RemoteRef BreakArray
ref; Maybe Word8
r <- BreakArray -> Int -> IO (Maybe Word8)
getBreak BreakArray
arr Int
ix
case Maybe Word8
r of
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just w :: Word8
w -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)
GetBreakpointVar ref :: HValueRef
ref ix :: 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)
mapM HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef (Maybe HValue -> IO (Maybe HValueRef))
-> IO (Maybe HValue) -> IO (Maybe HValueRef)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack HValue
aps Int
ix
MallocData bs :: ByteString
bs -> ByteString -> IO (RemotePtr ())
mkString ByteString
bs
MallocStrings bss :: [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)
mapM ByteString -> IO (RemotePtr ())
mkString0 [ByteString]
bss
PrepFFI conv :: FFIConv
conv args :: [FFIType]
args res :: FFIType
res -> Ptr C_ffi_cif -> RemotePtr C_ffi_cif
forall a. Ptr a -> RemotePtr a
toRemotePtr (Ptr C_ffi_cif -> RemotePtr C_ffi_cif)
-> IO (Ptr C_ffi_cif) -> IO (RemotePtr C_ffi_cif)
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 p :: 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)
MkConInfoTable ptrs :: Int
ptrs nptrs :: Int
nptrs tag :: Int
tag ptrtag :: Int
ptrtag desc :: [Word8]
desc ->
Ptr StgInfoTable -> RemotePtr StgInfoTable
forall a. Ptr a -> RemotePtr a
toRemotePtr (Ptr StgInfoTable -> RemotePtr StgInfoTable)
-> IO (Ptr StgInfoTable) -> IO (RemotePtr StgInfoTable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Int -> Int -> [Word8] -> IO (Ptr StgInfoTable)
mkConInfoTable Int
ptrs Int
nptrs Int
tag Int
ptrtag [Word8]
desc
StartTH -> IO a
IO (RemoteRef (IORef QState))
startTH
GetClosure ref :: HValueRef
ref -> do
Closure
clos <- HValue -> IO Closure
forall a. HasHeapRep a => a -> IO Closure
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)
mapM (\(Box x :: Any
x) -> HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef (Any -> HValue
HValue Any
x)) Closure
clos
Seq ref :: HValueRef
ref -> IO () -> IO (EvalResult ())
forall a. IO a -> IO (EvalResult a)
tryEval (IO HValue -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO HValue -> IO ()) -> IO HValue -> IO ()
forall a b. (a -> b) -> a -> b
$ HValue -> IO HValue
forall a. a -> IO a
evaluate (HValue -> IO HValue) -> IO HValue -> IO HValue
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)
_other :: Message a
_other -> String -> IO a
forall a. HasCallStack => String -> a
error "GHCi.Run.run"
evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
evalStmt opts :: EvalOpts
opts expr :: EvalExpr HValueRef
expr = do
HValue
io <- EvalExpr HValueRef -> IO HValue
mkIO EvalExpr HValueRef
expr
EvalOpts -> IO [HValueRef] -> IO (EvalStatus [HValueRef])
forall a. EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO EvalOpts
opts (IO [HValueRef] -> IO (EvalStatus [HValueRef]))
-> IO [HValueRef] -> IO (EvalStatus [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)
mapM HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef [HValue]
rs
where
mkIO :: EvalExpr HValueRef -> IO HValue
mkIO (EvalThis href :: HValueRef
href) = HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
href
mkIO (EvalApp l :: EvalExpr HValueRef
l r :: 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 (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 r :: 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 r :: 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 r :: HValueRef
r str :: 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)
sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO opts :: EvalOpts
opts io :: 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 (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 :: EvalOpts -> IO a -> IO a
rethrow EvalOpts{..} io :: 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
$ \se :: 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 1
else case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se of
Just UserInterrupt -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
exceptionFlag 0
SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
se
redirectInterrupts :: ThreadId -> IO a -> IO a
redirectInterrupts :: ThreadId -> IO a -> IO a
redirectInterrupts target :: ThreadId
target wait :: 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` \e :: 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
Nothing -> IO a
wait
Just target :: 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 :: IO (EvalResult a) -> IO (EvalStatus a)
measureAlloc io :: IO (EvalResult a)
io = do
Int64 -> IO ()
setAllocationCounter Int64
forall a. Bounded a => a
maxBound
EvalResult a
a <- IO (EvalResult a)
io
Int64
ctr <- IO Int64
getAllocationCounter
let allocs :: Word64
allocs = Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
forall a. Bounded a => a
maxBound::Int64) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
ctr
EvalStatus a -> IO (EvalStatus 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 :: IO a -> IO (EvalResult a)
tryEval io :: 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 ex :: SomeException
ex -> EvalResult a -> IO (EvalResult 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
a -> EvalResult a -> IO (EvalResult 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 :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
withBreakAction opts :: EvalOpts
opts breakMVar :: MVar ()
breakMVar statusMVar :: MVar (EvalStatus b)
statusMVar act :: 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 (\_ -> 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 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 (m :: * -> *) a. Monad m => a -> m a
return StablePtr BreakpointCallback
stablePtr
onBreak :: BreakpointCallback
onBreak :: BreakpointCallback
onBreak ix# :: Int#
ix# uniq# :: Int#
uniq# is_exception :: Bool
is_exception apStack :: HValue
apStack = do
ThreadId
tid <- IO ThreadId
myThreadId
let resume :: ResumeContext b
resume = ResumeContext :: forall a.
MVar () -> MVar (EvalStatus a) -> ThreadId -> ResumeContext a
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 :: 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 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])
resumeStmt opts :: EvalOpts
opts hvref :: RemoteRef (ResumeContext [HValueRef])
hvref = do
ResumeContext{..} <- RemoteRef (ResumeContext [HValueRef])
-> IO (ResumeContext [HValueRef])
forall a. RemoteRef a -> IO a
localRef RemoteRef (ResumeContext [HValueRef])
hvref
EvalOpts
-> MVar ()
-> MVar (EvalStatus [HValueRef])
-> IO (EvalStatus [HValueRef])
-> IO (EvalStatus [HValueRef])
forall b a.
EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
withBreakAction EvalOpts
opts MVar ()
resumeBreakMVar MVar (EvalStatus [HValueRef])
resumeStatusMVar (IO (EvalStatus [HValueRef]) -> IO (EvalStatus [HValueRef]))
-> IO (EvalStatus [HValueRef]) -> IO (EvalStatus [HValueRef])
forall a b. (a -> b) -> a -> b
$
IO (EvalStatus [HValueRef]) -> IO (EvalStatus [HValueRef])
forall a. IO a -> IO a
mask_ (IO (EvalStatus [HValueRef]) -> IO (EvalStatus [HValueRef]))
-> IO (EvalStatus [HValueRef]) -> IO (EvalStatus [HValueRef])
forall a b. (a -> b) -> a -> b
$ do
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
resumeBreakMVar ()
ThreadId
-> IO (EvalStatus [HValueRef]) -> IO (EvalStatus [HValueRef])
forall a. ThreadId -> IO a -> IO a
redirectInterrupts ThreadId
resumeThreadId (IO (EvalStatus [HValueRef]) -> IO (EvalStatus [HValueRef]))
-> IO (EvalStatus [HValueRef]) -> IO (EvalStatus [HValueRef])
forall a b. (a -> b) -> a -> b
$ MVar (EvalStatus [HValueRef]) -> IO (EvalStatus [HValueRef])
forall a. MVar a -> IO a
takeMVar MVar (EvalStatus [HValueRef])
resumeStatusMVar
abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt hvref :: RemoteRef (ResumeContext [HValueRef])
hvref = do
ResumeContext{..} <- 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]
_ <- MVar (EvalStatus [HValueRef]) -> IO (EvalStatus [HValueRef])
forall a. MVar a -> IO a
takeMVar MVar (EvalStatus [HValueRef])
resumeStatusMVar
() -> IO ()
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 1
resetStepFlag :: IO ()
resetStepFlag :: IO ()
resetStepFlag = Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
stepFlag 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 _ _ False _ = String -> IO ()
putStrLn "*** Ignoring breakpoint"
noBreakAction _ _ True _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkString :: ByteString -> IO (RemotePtr ())
mkString :: ByteString -> IO (RemotePtr ())
mkString bs :: 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
$ \(cstr :: Ptr CChar
cstr,len :: 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 (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 bs :: 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
$ \(cstr :: Ptr CChar
cstr,len :: 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
+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 0
RemotePtr () -> IO (RemotePtr ())
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 _ _ = [RemotePtr CostCentre] -> IO [RemotePtr CostCentre]
forall (m :: * -> *) a. Monad m => a -> m a
return []
#endif
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack :: HValue
apStack (I# stackDepth :: Int#
stackDepth) = do
case HValue -> Int# -> (# Int#, Any #)
forall a b. a -> Int# -> (# Int#, b #)
getApStackVal# HValue
apStack Int#
stackDepth of
(# ok :: Int#
ok, result :: Any
result #) ->
case Int#
ok of
0# -> Maybe HValue -> IO (Maybe HValue)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HValue
forall a. Maybe a
Nothing
_ -> Maybe HValue -> IO (Maybe HValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (HValue -> Maybe HValue
forall a. a -> Maybe a
Just (Any -> HValue
unsafeCoerce# Any
result))