{-# 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 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 -> String -> IO (Maybe String)
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
  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 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
    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
  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 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 -> (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 -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
    SomeException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO 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 Int#
ix# Addr#
mod_name# 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
         mod_name <- peekCString (Ptr mod_name#)
         pure (Just (EvalBreakpoint (I# ix#) mod_name))
     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
     = Int#    -- the breakpoint index
    -> Addr#   -- pointer to the module name
    -> 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 Int#
_ Addr#
_ Bool
False HValue
_ = String -> IO ()
putStrLn String
"*** Ignoring breakpoint"
noBreakAction Int#
_ Addr#
_ 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#, 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 -- 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 (Any -> HValue
forall a b. a -> b
unsafeCoerce# Any
result))