module GHCi.Run
( run, redirectInterrupts
, toSerializableException, fromSerializableException
) where
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 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 GHC.Stack
import Foreign
import Foreign.C
import GHC.Conc.Sync
import GHC.IO hiding ( bracket )
import System.Exit
import System.Mem.Weak ( deRefWeak )
import Unsafe.Coerce
run :: Message a -> IO a
run m = case m of
InitLinker -> initObjLinker
LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str
LookupClosure str -> lookupClosure str
LoadDLL str -> loadDLL str
LoadArchive str -> loadArchive str
LoadObj str -> loadObj str
UnloadObj str -> unloadObj str
AddLibrarySearchPath str -> toRemotePtr <$> addLibrarySearchPath str
RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr)
ResolveObjs -> resolveObjs
FindSystemLibrary str -> findSystemLibrary str
CreateBCOs bco -> createBCOs bco
FreeHValueRefs rs -> mapM_ freeRemoteRef rs
EvalStmt opts r -> evalStmt opts r
ResumeStmt opts r -> resumeStmt opts r
AbandonStmt r -> abandonStmt r
EvalString r -> evalString r
EvalStringToString r s -> evalStringToString r s
EvalIO r -> evalIO r
MkCostCentre mod name src ->
toRemotePtr <$> mkCostCentre (fromRemotePtr mod) name src
CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
EnableBreakpoint ref ix b -> do
arr <- localRef ref
_ <- if b then setBreakOn arr ix else setBreakOff arr ix
return ()
BreakpointStatus ref ix -> do
arr <- localRef ref; r <- getBreak arr ix
case r of
Nothing -> return False
Just w -> return (w /= 0)
MallocData bs -> mkString bs
PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
MkConInfoTable ptrs nptrs tag desc ->
toRemotePtr <$> mkConInfoTable ptrs nptrs tag desc
StartTH -> startTH
_other -> error "GHCi.Run.run"
evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
evalStmt opts expr = do
io <- mkIO expr
sandboxIO opts $ do
rs <- unsafeCoerce io :: IO [HValue]
mapM mkRemoteRef rs
where
mkIO (EvalThis href) = localRef href
mkIO (EvalApp l r) = do
l' <- mkIO l
r' <- mkIO r
return ((unsafeCoerce l' :: HValue -> HValue) r')
evalIO :: HValueRef -> IO (EvalResult ())
evalIO r = do
io <- localRef r
tryEval (unsafeCoerce io :: IO ())
evalString :: HValueRef -> IO (EvalResult String)
evalString r = do
io <- localRef r
tryEval $ do
r <- unsafeCoerce io :: IO String
evaluate (force r)
evalStringToString :: HValueRef -> String -> IO (EvalResult String)
evalStringToString r str = do
io <- localRef r
tryEval $ do
r <- (unsafeCoerce io :: String -> IO String) str
evaluate (force r)
sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO opts io = do
breakMVar <- newEmptyMVar
statusMVar <- newEmptyMVar
withBreakAction opts breakMVar statusMVar $ do
let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
if useSandboxThread opts
then do
tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar
redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar
else
runIt
rethrow :: EvalOpts -> IO a -> IO a
rethrow EvalOpts{..} io =
catch io $ \se -> do
if breakOnError && not breakOnException
then poke exceptionFlag 1
else case fromException se of
Just UserInterrupt -> return ()
_ -> poke exceptionFlag 0
throwIO se
redirectInterrupts :: ThreadId -> IO a -> IO a
redirectInterrupts target wait = do
wtid <- mkWeakThreadId target
wait `catch` \e -> do
m <- deRefWeak wtid
case m of
Nothing -> wait
Just target -> do throwTo target (e :: SomeException); wait
measureAlloc :: IO (EvalResult a) -> IO (EvalStatus a)
measureAlloc io = do
setAllocationCounter maxBound
a <- io
ctr <- getAllocationCounter
let allocs = fromIntegral (maxBound::Int64) fromIntegral ctr
return (EvalComplete allocs a)
tryEval :: IO a -> IO (EvalResult a)
tryEval io = do
e <- try io
case e of
Left ex -> return (EvalException (toSerializableException ex))
Right a -> return (EvalSuccess a)
toSerializableException :: SomeException -> SerializableException
toSerializableException ex
| Just UserInterrupt <- fromException ex = EUserInterrupt
| Just (ec::ExitCode) <- fromException ex = (EExitCode ec)
| otherwise = EOtherException (show (ex :: SomeException))
fromSerializableException :: SerializableException -> SomeException
fromSerializableException EUserInterrupt = toException UserInterrupt
fromSerializableException (EExitCode c) = toException c
fromSerializableException (EOtherException str) = toException (ErrorCall str)
withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
withBreakAction opts breakMVar statusMVar act
= bracket setBreakAction resetBreakAction (\_ -> act)
where
setBreakAction = do
stablePtr <- newStablePtr onBreak
poke breakPointIOAction stablePtr
when (breakOnException opts) $ poke exceptionFlag 1
when (singleStep opts) $ setStepFlag
return stablePtr
onBreak :: BreakpointCallback
onBreak ix# uniq# is_exception apStack = do
tid <- myThreadId
let resume = ResumeContext
{ resumeBreakMVar = breakMVar
, resumeStatusMVar = statusMVar
, resumeThreadId = tid }
resume_r <- mkRemoteRef resume
apStack_r <- mkRemoteRef apStack
ccs <- toRemotePtr <$> getCCSOf apStack
putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs
takeMVar breakMVar
resetBreakAction stablePtr = do
poke breakPointIOAction noBreakStablePtr
poke exceptionFlag 0
resetStepFlag
freeStablePtr stablePtr
resumeStmt
:: EvalOpts -> RemoteRef (ResumeContext [HValueRef])
-> IO (EvalStatus [HValueRef])
resumeStmt opts hvref = do
ResumeContext{..} <- localRef hvref
withBreakAction opts resumeBreakMVar resumeStatusMVar $
mask_ $ do
putMVar resumeBreakMVar ()
redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar
abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt hvref = do
ResumeContext{..} <- localRef hvref
killThread resumeThreadId
putMVar resumeBreakMVar ()
_ <- takeMVar resumeStatusMVar
return ()
foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
setStepFlag :: IO ()
setStepFlag = poke stepFlag 1
resetStepFlag :: IO ()
resetStepFlag = poke stepFlag 0
type BreakpointCallback = Int# -> Int# -> Bool -> HValue -> IO ()
foreign import ccall "&rts_breakpoint_io_action"
breakPointIOAction :: Ptr (StablePtr BreakpointCallback)
noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction :: BreakpointCallback
noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint"
noBreakAction _ _ True _ = return ()
mkString :: ByteString -> IO (RemotePtr ())
mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
ptr <- mallocBytes len
copyBytes ptr cstr len
return (castRemotePtr (toRemotePtr ptr))
mkCostCentre :: Ptr CChar -> String -> String -> IO (Ptr CostCentre)
#if defined(PROFILING)
mkCostCentre c_module decl_path srcspan = do
c_name <- newCString decl_path
c_srcspan <- newCString srcspan
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
mkCostCentre _ _ _ = return nullPtr
#endif