{-# 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
import Data.Binary
import Data.Binary.Get
#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 [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)
  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
  SetupBreakpoint RemoteRef BreakArray
ref Int
ix Int
cnt -> do
    BreakArray
arr <- RemoteRef BreakArray -> IO BreakArray
forall a. RemoteRef a -> IO a
localRef RemoteRef BreakArray
ref;
    Bool
_ <- BreakArray -> Int -> Int -> IO Bool
setupBreakpoint BreakArray
arr Int
ix Int
cnt
    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  BreakpointStatus RemoteRef BreakArray
ref Int
ix -> do
    BreakArray
arr <- RemoteRef BreakArray -> IO BreakArray
forall a. RemoteRef a -> IO a
localRef RemoteRef BreakArray
ref; Maybe Int
r <- BreakArray -> Int -> IO (Maybe Int)
getBreak BreakArray
arr Int
ix
    case Maybe Int
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
    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)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef (Maybe HValue -> IO a) -> IO (Maybe HValue) -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack HValue
aps Int
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
    Closure
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
    (Box -> IO HValueRef) -> Closure -> IO (GenClosure HValueRef)
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) -> GenClosure a -> m (GenClosure b)
mapM (\(Heap.Box Any
x) -> HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef (Any -> HValue
HValue Any
x)) Closure
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
  HValue
io <- EvalExpr HValueRef -> IO HValue
mkIO EvalExpr HValueRef
expr
  EvalOpts
-> IO [HValueRef] -> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO EvalOpts
opts (IO [HValueRef] -> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO [HValueRef] -> IO (EvalStatus_ [HValueRef] [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef [HValue]
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
    HValue
l' <- EvalExpr HValueRef -> IO HValue
mkIO EvalExpr HValueRef
l
    HValue
r' <- EvalExpr HValueRef -> IO HValue
mkIO EvalExpr HValueRef
r
    HValue -> IO HValue
forall a. a -> IO a
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 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 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 HValueRef
r 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)

-- | 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)
      () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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{MVar ()
MVar (EvalStatus_ () ())
ThreadId
resumeBreakMVar :: MVar ()
resumeStatusMVar :: MVar (EvalStatus_ () ())
resumeThreadId :: ThreadId
resumeThreadId :: forall a. ResumeContext a -> ThreadId
resumeStatusMVar :: forall a. ResumeContext a -> MVar (EvalStatus a)
resumeBreakMVar :: forall a. ResumeContext a -> MVar ()
..} <- RemoteRef (ResumeContext ()) -> IO (ResumeContext ())
forall a. RemoteRef a -> IO a
localRef RemoteRef (ResumeContext ())
hvref
    EvalOpts
-> MVar ()
-> MVar (EvalStatus_ () ())
-> IO (EvalStatus_ () ())
-> IO (EvalStatus_ () ())
forall b a.
EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
withBreakAction EvalOpts
evalOptsSeq MVar ()
resumeBreakMVar MVar (EvalStatus_ () ())
resumeStatusMVar (IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ()))
-> IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a b. (a -> b) -> a -> b
$
      IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a. IO a -> IO a
mask_ (IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ()))
-> IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a b. (a -> b) -> a -> b
$ do
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
resumeBreakMVar () -- this awakens the stopped thread...
        ThreadId -> IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a. ThreadId -> IO a -> IO a
redirectInterrupts ThreadId
resumeThreadId (IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ()))
-> IO (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a b. (a -> b) -> a -> b
$ MVar (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a. MVar a -> IO a
takeMVar MVar (EvalStatus_ () ())
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
  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 a b. IO a -> (a -> IO b) -> IO b
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
                                -- empty: can't block
         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
          -- 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.
         IO (EvalStatus a)
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. 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
  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` \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
       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
  EvalResult a
a <- IO (EvalResult a)
io
  Int64
ctr <- IO Int64
getAllocationCounter
  let allocs :: Word64
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
  EvalStatus a -> IO (EvalStatus a)
forall a. a -> IO 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)

-- 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
  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 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
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 CInt
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StablePtr BreakpointCallback
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# Int#
uniq# Bool
is_exception HValue
apStack = do
     ThreadId
tid <- IO ThreadId
myThreadId
     let resume :: ResumeContext b
resume = 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 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{MVar ()
MVar (EvalStatus_ [HValueRef] [HValueRef])
ThreadId
resumeThreadId :: forall a. ResumeContext a -> ThreadId
resumeStatusMVar :: forall a. ResumeContext a -> MVar (EvalStatus a)
resumeBreakMVar :: forall a. ResumeContext a -> MVar ()
resumeBreakMVar :: MVar ()
resumeStatusMVar :: MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeThreadId :: ThreadId
..} <- RemoteRef (ResumeContext [HValueRef])
-> IO (ResumeContext [HValueRef])
forall a. RemoteRef a -> IO a
localRef RemoteRef (ResumeContext [HValueRef])
hvref
  EvalOpts
-> MVar ()
-> MVar (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall b a.
EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
withBreakAction EvalOpts
opts MVar ()
resumeBreakMVar MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeStatusMVar (IO (EvalStatus_ [HValueRef] [HValueRef])
 -> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a b. (a -> b) -> a -> b
$
    IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. IO a -> IO a
mask_ (IO (EvalStatus_ [HValueRef] [HValueRef])
 -> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a b. (a -> b) -> a -> b
$ do
      MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
resumeBreakMVar () -- this awakens the stopped thread...
      ThreadId
-> IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. ThreadId -> IO a -> IO a
redirectInterrupts ThreadId
resumeThreadId (IO (EvalStatus_ [HValueRef] [HValueRef])
 -> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a b. (a -> b) -> a -> b
$ MVar (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. MVar a -> IO a
takeMVar MVar (EvalStatus_ [HValueRef] [HValueRef])
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{MVar ()
MVar (EvalStatus_ [HValueRef] [HValueRef])
ThreadId
resumeThreadId :: forall a. ResumeContext a -> ThreadId
resumeStatusMVar :: forall a. ResumeContext a -> MVar (EvalStatus a)
resumeBreakMVar :: forall a. ResumeContext a -> MVar ()
resumeBreakMVar :: MVar ()
resumeStatusMVar :: MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeThreadId :: ThreadId
..} <- 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] [HValueRef]
_ <- MVar (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. MVar a -> IO a
takeMVar MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeStatusMVar
  () -> IO ()
forall a. a -> IO a
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 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
    -> Int#    -- the module uniq
    -> 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#
_ Int#
_ Bool
False HValue
_ = String -> IO ()
putStrLn String
"*** Ignoring breakpoint"
noBreakAction Int#
_ 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
$ \(Ptr CChar
cstr,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 a. a -> IO a
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 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
$ \(Ptr CChar
cstr,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
+Int
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 CChar
0
  RemotePtr () -> IO (RemotePtr ())
forall a. a -> IO a
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 String
_ [(String, String)]
_ = [RemotePtr CostCentre] -> IO [RemotePtr CostCentre]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
#endif

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))