module GHCi.Run
( run, redirectInterrupts
) 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 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.Stack
import Foreign
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 m = case m of
InitLinker -> initObjLinker RetainCAFs
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 bcos -> createBCOs (concatMap (runGet get) bcos)
FreeHValueRefs rs -> mapM_ freeRemoteRef rs
AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr
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
MkCostCentres mod ccs -> mkCostCentres mod ccs
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)
GetBreakpointVar ref ix -> do
aps <- localRef ref
mapM mkRemoteRef =<< getIdValFromApStack aps ix
MallocData bs -> mkString bs
MallocStrings bss -> mapM mkString0 bss
PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
MkConInfoTable ptrs nptrs tag ptrtag desc ->
toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag 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)
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))
mkString0 :: ByteString -> IO (RemotePtr ())
mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
ptr <- mallocBytes (len+1)
copyBytes ptr cstr len
pokeElemOff (ptr :: Ptr CChar) len 0
return (castRemotePtr (toRemotePtr 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 _ _ = return []
#endif
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
case getApStackVal# apStack stackDepth of
(# ok, result #) ->
case ok of
0# -> return Nothing
_ -> return (Just (unsafeCoerce# result))