{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
    UnboxedTuples, LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

-- |
-- Execute GHCi messages.
--
-- For details on Remote GHCi, see Note [Remote GHCi] in
-- compiler/GHC/Runtime/Interpreter.hs.
--
module GHCi.Run
  ( run, redirectInterrupts
  ) where

import Prelude -- See note [Why do we import Prelude here?]

#if !defined(javascript_HOST_ARCH)
import GHCi.CreateBCO
import GHCi.InfoTable
#endif

import qualified GHC.InfoProv as InfoProv
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

-- -----------------------------------------------------------------------------
-- Implement messages

foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
        -- Make it "safe", just in case

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 [ResolvedBCO]
bcos -> [ResolvedBCO] -> IO [HValueRef]
createBCOs [ResolvedBCO]
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
  NewBreakModule String
name -> String -> IO (RemotePtr BreakModule)
newModuleName String
name
  SetupBreakpoint RemoteRef BreakArray
ref Int
ix Int
cnt -> do
    arr <- RemoteRef BreakArray -> IO BreakArray
forall a. RemoteRef a -> IO a
localRef RemoteRef BreakArray
ref;
    _ <- setupBreakpoint arr ix cnt
    return ()
  BreakpointStatus RemoteRef BreakArray
ref Int
ix -> do
    arr <- RemoteRef BreakArray -> IO BreakArray
forall a. RemoteRef a -> IO a
localRef RemoteRef BreakArray
ref; r <- getBreak arr ix
    case 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
    aps <- HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
ref
    mapM mkRemoteRef =<< getIdValFromApStack aps 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 [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
<$> [FFIType] -> FFIType -> IO (Ptr C_ffi_cif)
prepForeignCall [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
    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
    mapM (\(Heap.Box Any
x) -> HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef (Any -> HValue
HValue Any
x)) clos
  WhereFrom HValueRef
ref ->
    HValue -> IO a
HValue -> IO (Maybe InfoProv)
forall a. a -> IO (Maybe InfoProv)
InfoProv.whereFrom (HValue -> IO a) -> IO HValue -> IO a
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
  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
  io <- EvalExpr HValueRef -> IO HValue
mkIO EvalExpr HValueRef
expr
  sandboxIO opts $ do
    rs <- unsafeCoerce io :: IO [HValue]
    mapM mkRemoteRef 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
    l' <- EvalExpr HValueRef -> IO HValue
mkIO EvalExpr HValueRef
l
    r' <- mkIO r
    return ((unsafeCoerce l' :: HValue -> HValue) r')

evalIO :: HValueRef -> IO (EvalResult ())
evalIO :: HValueRef -> IO (EvalResult ())
evalIO HValueRef
r = do
  io <- HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
r
  tryEval (unsafeCoerce io :: IO ())

evalString :: HValueRef -> IO (EvalResult String)
evalString :: HValueRef -> IO (EvalResult String)
evalString HValueRef
r = do
  io <- HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
r
  tryEval $ do
    r <- unsafeCoerce io :: IO String
    evaluate (force r)

evalStringToString :: HValueRef -> String -> IO (EvalResult String)
evalStringToString :: HValueRef -> String -> IO (EvalResult String)
evalStringToString HValueRef
r String
str = do
  io <- HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
r
  tryEval $ do
    r <- (unsafeCoerce io :: String -> IO String) str
    evaluate (force r)

-- | Process the Seq message to force a value.                       #2950
-- If during this processing a breakpoint is hit, return
-- an EvalBreak value in the EvalStatus to the UI process,
-- otherwise return an EvalComplete.
-- The UI process has more and therefore also can show more
-- information about the breakpoint than the current iserv
-- process.
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)
      return ()

-- | Process a ResumeSeq message. Continue the :force processing     #2950
-- after a breakpoint.
resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())
resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus_ () ())
resumeSeq RemoteRef (ResumeContext ())
hvref = do
    ResumeContext{..} <- RemoteRef (ResumeContext ()) -> IO (ResumeContext ())
forall a. RemoteRef a -> IO a
localRef RemoteRef (ResumeContext ())
hvref
    withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar $
      mask_ $ do
        putMVar resumeBreakMVar () -- this awakens the stopped thread...
        redirectInterrupts resumeThreadId $ takeMVar 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
              }

-- When running a computation, we redirect ^C exceptions to the running
-- thread.  ToDo: we might want a way to continue even if the target
-- thread doesn't die when it receives the exception... "this thread
-- is not responding".
--
-- Careful here: there may be ^C exceptions flying around, so we start the new
-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
-- only while we execute the user's code.  We can't afford to lose the final
-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)

sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO :: forall a. EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO EvalOpts
opts IO a
io = do
  -- We are running in uninterruptibleMask
  breakMVar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  statusMVar <- newEmptyMVar
  withBreakAction opts breakMVar statusMVar $ do
    let 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 useSandboxThread opts
       then do
         tid <- forkIO $ do
           tid <- myThreadId
           labelThread tid "GHCi sandbox"
           unsafeUnmask runIt >>= putMVar statusMVar
                                -- empty: can't block
         redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar
       else
          -- GLUT on OS X needs to run on the main thread. If you
          -- try to use it from another thread then you just get a
          -- white rectangle rendered. For this, or anything else
          -- with such restrictions, you can turn the GHCi sandbox off
          -- and things will be run in the main thread.
          --
          -- BUT, note that the debugging features (breakpoints,
          -- tracing, etc.) need the expression to be running in a
          -- separate thread, so debugging is only enabled when
          -- using the sandbox.
         runIt

-- We want to turn ^C into a break when -fbreak-on-exception is on,
-- but it's an async exception and we only break for sync exceptions.
-- Idea: if we catch and re-throw it, then the re-throw will trigger
-- a break.  Great - but we don't want to re-throw all exceptions, because
-- then we'll get a double break for ordinary sync exceptions (you'd have
-- to :continue twice, which looks strange).  So if the exception is
-- not "Interrupted", we unset the exception flag before throwing.
--
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 -> (ExceptionWithContext SomeException -> IO a) -> IO a
forall e a.
Exception e =>
IO a -> (ExceptionWithContext e -> IO a) -> IO a
catchNoPropagate IO a
io ((ExceptionWithContext SomeException -> IO a) -> IO a)
-> (ExceptionWithContext SomeException -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(ExceptionWithContext ExceptionContext
cx SomeException
se) -> do
    -- If -fbreak-on-error, we break unconditionally,
    --  but with care of not breaking twice
    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
               -- If it is a "UserInterrupt" exception, we allow
               --  a possible break by way of -fbreak-on-exception
               Just AsyncException
UserInterrupt -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               -- In any other case, we don't want to break
               Maybe AsyncException
_ -> Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
exceptionFlag CInt
0
    ExceptionWithContext SomeException -> IO a
forall e a. Exception e => ExceptionWithContext e -> IO a
rethrowIO (ExceptionContext
-> SomeException -> ExceptionWithContext SomeException
forall a. ExceptionContext -> a -> ExceptionWithContext a
ExceptionWithContext ExceptionContext
cx SomeException
se)

--
-- While we're waiting for the sandbox thread to return a result, if
-- the current thread receives an asynchronous exception we re-throw
-- it at the sandbox thread and continue to wait.
--
-- This is for two reasons:
--
--  * So that ^C interrupts runStmt (e.g. in GHCi), allowing the
--    computation to run its exception handlers before returning the
--    exception result to the caller of runStmt.
--
--  * clients of the GHC API can terminate a runStmt in progress
--    without knowing the ThreadId of the sandbox thread (#1381)
--
-- NB. use a weak pointer to the thread, so that the thread can still
-- be considered deadlocked by the RTS and sent a BlockedIndefinitely
-- exception.  A symptom of getting this wrong is that conc033(ghci)
-- will hang.
--
redirectInterrupts :: ThreadId -> IO a -> IO a
redirectInterrupts :: forall a. ThreadId -> IO a -> IO a
redirectInterrupts ThreadId
target IO a
wait = do
  wtid <- ThreadId -> IO (Weak ThreadId)
mkWeakThreadId ThreadId
target
  wait `catch` \SomeException
e -> do
     m <- Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
wtid
     case 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                                 -- #16012
  a <- IO (EvalResult a)
io
  ctr <- getAllocationCounter
  let 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
  return (EvalComplete allocs a)

-- Exceptions can't be marshaled because they're dynamically typed, so
-- everything becomes a String.
tryEval :: IO a -> IO (EvalResult a)
tryEval :: forall a. IO a -> IO (EvalResult a)
tryEval IO a
io = do
  e <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io
  case 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)

-- This function sets up the interpreter for catching breakpoints, and
-- resets everything when the computation has stopped running.  This
-- is a not-very-good way to ensure that only the interactive
-- evaluation should generate breakpoints.
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 -> IO (StablePtr BreakpointCallback)
forall a. a -> IO (StablePtr a)
newStablePtr BreakpointCallback
onBreak
     poke breakPointIOAction stablePtr
     when (breakOnException opts) $ poke exceptionFlag 1
     when (singleStep opts) $ setStepFlag
     return stablePtr
        -- Breaking on exceptions is not enabled by default, since it
        -- might be a bit surprising.  The exception flag is turned off
        -- as soon as it is hit, or in resetBreakAction below.

   onBreak :: BreakpointCallback
   onBreak :: BreakpointCallback
onBreak Addr#
tick_mod# Int#
tickx# Addr#
info_mod# Int#
infox# Bool
is_exception HValue
apStack = do
     tid <- IO ThreadId
myThreadId
     let resume = ResumeContext
           { resumeBreakMVar :: MVar ()
resumeBreakMVar = MVar ()
breakMVar
           , resumeStatusMVar :: MVar (EvalStatus b)
resumeStatusMVar = MVar (EvalStatus b)
statusMVar
           , resumeThreadId :: ThreadId
resumeThreadId = ThreadId
tid }
     resume_r <- mkRemoteRef resume
     apStack_r <- mkRemoteRef apStack
     ccs <- toRemotePtr <$> getCCSOf apStack
     breakpoint <-
       if is_exception
       then pure Nothing
       else do
         tick_mod <- peekCString (Ptr tick_mod#)
         info_mod <- peekCString (Ptr info_mod#)
         pure (Just (EvalBreakpoint tick_mod (I# tickx#) info_mod (I# infox#)))
     putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
     takeMVar 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{..} <- RemoteRef (ResumeContext [HValueRef])
-> IO (ResumeContext [HValueRef])
forall a. RemoteRef a -> IO a
localRef RemoteRef (ResumeContext [HValueRef])
hvref
  withBreakAction opts resumeBreakMVar resumeStatusMVar $
    mask_ $ do
      putMVar resumeBreakMVar () -- this awakens the stopped thread...
      redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar

-- when abandoning a computation we have to
--      (a) kill the thread with an async exception, so that the
--          computation itself is stopped, and
--      (b) fill in the MVar.  This step is necessary because any
--          thunks that were under evaluation will now be updated
--          with the partial computation, which still ends in takeMVar,
--          so any attempt to evaluate one of these thunks will block
--          unless we fill in the MVar.
--      (c) wait for the thread to terminate by taking its status MVar.  This
--          step is necessary to prevent race conditions with
--          -fbreak-on-exception (see #5975).
--  See test break010.
abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt RemoteRef (ResumeContext [HValueRef])
hvref = do
  ResumeContext{..} <- RemoteRef (ResumeContext [HValueRef])
-> IO (ResumeContext [HValueRef])
forall a. RemoteRef a -> IO a
localRef RemoteRef (ResumeContext [HValueRef])
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 :: 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
     = Addr#   -- pointer to the breakpoint tick module name
    -> Int#    -- breakpoint tick index
    -> Addr#   -- pointer to the breakpoint info module name
    -> Int#    -- breakpoint info index
    -> Bool    -- exception?
    -> HValue  -- the AP_STACK, or exception
    -> 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 Addr#
_ Int#
_ Addr#
_ Int#
_ Bool
False HValue
_ = String -> IO ()
putStrLn String
"*** Ignoring breakpoint"
noBreakAction Addr#
_ Int#
_ Addr#
_ Int#
_ Bool
True  HValue
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- exception: just continue

-- Malloc and copy the bytes.  We don't have any way to monitor the
-- lifetime of this memory, so it just leaks.
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
$ \(CString
cstr,Int
len) -> do
  ptr <- Int -> IO CString
forall a. Int -> IO (Ptr a)
mallocBytes Int
len
  copyBytes ptr cstr len
  return (castRemotePtr (toRemotePtr 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
$ \(CString
cstr,Int
len) -> do
  ptr <- Int -> IO CString
forall a. Int -> IO (Ptr a)
mallocBytes (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
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 :: 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

newModuleName :: String -> IO (RemotePtr BreakModule)
newModuleName :: String -> IO (RemotePtr BreakModule)
newModuleName String
name =
  RemotePtr CChar -> RemotePtr BreakModule
forall a b. RemotePtr a -> RemotePtr b
castRemotePtr (RemotePtr CChar -> RemotePtr BreakModule)
-> (CString -> RemotePtr CChar) -> CString -> RemotePtr BreakModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> RemotePtr CChar
forall a. Ptr a -> RemotePtr a
toRemotePtr (CString -> RemotePtr BreakModule)
-> IO CString -> IO (RemotePtr BreakModule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO CString
newCString String
name

getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack HValue
apStack (I# Int#
stackDepth) = do
   case HValue -> Int# -> (# Int#, ZonkAny 0 #)
forall a b. a -> Int# -> (# Int#, b #)
getApStackVal# HValue
apStack Int#
stackDepth of
        (# Int#
ok, ZonkAny 0
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 -- AP_STACK not found
              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 (ZonkAny 0 -> HValue
forall a b. a -> b
unsafeCoerce# ZonkAny 0
result))