{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
    UnboxedTuples #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module GHCi.Run
  ( run, redirectInterrupts
  ) where
import Prelude 
import GHCi.CreateBCO
import GHCi.InfoTable
import GHCi.FFI
import GHCi.Message
import GHCi.ObjLink
import GHCi.RemoteTypes
import GHCi.TH
import GHCi.BreakArray
import GHCi.StaticPtrTable
import Control.Concurrent
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.Binary
import Data.Binary.Get
import Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
import 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
foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
        
run :: Message a -> IO a
run :: forall a. Message a -> IO a
run Message a
m = case Message a
m of
  Message a
InitLinker -> ShouldRetainCAFs -> IO ()
initObjLinker ShouldRetainCAFs
RetainCAFs
  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
  LookupClosure String
str -> String -> IO (Maybe HValueRef)
lookupClosure String
str
  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)
  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)
  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)
  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
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
_other -> String -> IO a
forall a. HasCallStack => String -> a
error String
"GHCi.Run.run"
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)
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 ()
resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())
resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus_ () ())
resumeSeq RemoteRef (ResumeContext ())
hvref = do
    ResumeContext{ThreadId
MVar ()
MVar (EvalStatus_ () ())
resumeBreakMVar :: MVar ()
resumeStatusMVar :: MVar (EvalStatus_ () ())
resumeThreadId :: ThreadId
resumeBreakMVar :: forall a. ResumeContext a -> MVar ()
resumeStatusMVar :: forall a. ResumeContext a -> MVar (EvalStatus a)
resumeThreadId :: forall a. ResumeContext a -> ThreadId
..} <- 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 () 
        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
              }
sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO :: forall a. EvalOpts -> IO a -> IO (EvalStatus a)
sandboxIO EvalOpts
opts IO a
io = do
  
  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
                                
         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
          
          
          
          
          
          
          
          
          
          
         IO (EvalStatus a)
runIt
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 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
               
               
               Just AsyncException
UserInterrupt -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               
               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
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                                 
  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)
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)
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
        
        
        
   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{ThreadId
MVar ()
MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeBreakMVar :: forall a. ResumeContext a -> MVar ()
resumeStatusMVar :: forall a. ResumeContext a -> MVar (EvalStatus a)
resumeThreadId :: forall a. ResumeContext a -> ThreadId
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 () 
      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
abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt RemoteRef (ResumeContext [HValueRef])
hvref = do
  ResumeContext{ThreadId
MVar ()
MVar (EvalStatus_ [HValueRef] [HValueRef])
resumeBreakMVar :: forall a. ResumeContext a -> MVar ()
resumeStatusMVar :: forall a. ResumeContext a -> MVar (EvalStatus a)
resumeThreadId :: forall a. ResumeContext a -> ThreadId
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#    
    -> Int#    
    -> Bool    
    -> HValue  
    -> 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 () 
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 
              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))