Run.hs 12.9 KB
Newer Older
1 2
{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
    UnboxedTuples #-}
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

-- |
-- Execute GHCi messages
--
module GHCi.Run
  ( run, redirectInterrupts
  , toSerializableException, fromSerializableException
  ) where

import GHCi.CreateBCO
import GHCi.InfoTable
import GHCi.FFI
import GHCi.Message
import GHCi.ObjLink
import GHCi.RemoteTypes
import GHCi.TH
20
import GHCi.BreakArray
21 22 23 24 25 26 27 28

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
29
import GHC.Stack
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
import Foreign
import Foreign.C
import GHC.Conc.Sync
import GHC.IO hiding ( bracket )
import System.Exit
import System.Mem.Weak  ( deRefWeak )
import Unsafe.Coerce

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

run :: Message a -> IO a
run m = case m of
  InitLinker -> initObjLinker
  LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str
  LookupClosure str -> lookupClosure str
  LoadDLL str -> loadDLL str
  LoadArchive str -> loadArchive str
  LoadObj str -> loadObj str
  UnloadObj str -> unloadObj str
  AddLibrarySearchPath str -> toRemotePtr <$> addLibrarySearchPath str
  RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr)
  ResolveObjs -> resolveObjs
  FindSystemLibrary str -> findSystemLibrary str
  CreateBCOs bco -> createBCOs bco
55
  FreeHValueRefs rs -> mapM_ freeRemoteRef rs
56 57 58 59 60 61
  EvalStmt opts r -> evalStmt opts r
  ResumeStmt opts r -> resumeStmt opts r
  AbandonStmt r -> abandonStmt r
  EvalString r -> evalString r
  EvalStringToString r s -> evalStringToString r s
  EvalIO r -> evalIO r
62
  MkCostCentres mod ccs -> mkCostCentres mod ccs
63
  CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
64 65 66 67 68 69 70 71 72 73
  NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
  EnableBreakpoint ref ix b -> do
    arr <- localRef ref
    _ <- if b then setBreakOn arr ix else setBreakOff arr ix
    return ()
  BreakpointStatus ref ix -> do
    arr <- localRef ref; r <- getBreak arr ix
    case r of
      Nothing -> return False
      Just w -> return (w /= 0)
74 75 76
  GetBreakpointVar ref ix -> do
    aps <- localRef ref
    mapM mkRemoteRef =<< getIdValFromApStack aps ix
77 78 79 80 81 82 83 84 85 86 87 88 89
  MallocData bs -> mkString bs
  PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
  FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
  MkConInfoTable ptrs nptrs tag desc ->
    toRemotePtr <$> mkConInfoTable ptrs nptrs tag desc
  StartTH -> startTH
  _other -> error "GHCi.Run.run"

evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
evalStmt opts expr = do
  io <- mkIO expr
  sandboxIO opts $ do
    rs <- unsafeCoerce io :: IO [HValue]
90
    mapM mkRemoteRef rs
91
 where
92
  mkIO (EvalThis href) = localRef href
93 94 95 96 97 98 99
  mkIO (EvalApp l r) = do
    l' <- mkIO l
    r' <- mkIO r
    return ((unsafeCoerce l' :: HValue -> HValue) r')

evalIO :: HValueRef -> IO (EvalResult ())
evalIO r = do
100
  io <- localRef r
101 102 103 104
  tryEval (unsafeCoerce io :: IO ())

evalString :: HValueRef -> IO (EvalResult String)
evalString r = do
105
  io <- localRef r
106 107 108 109 110 111
  tryEval $ do
    r <- unsafeCoerce io :: IO String
    evaluate (force r)

evalStringToString :: HValueRef -> String -> IO (EvalResult String)
evalStringToString r str = do
112
  io <- localRef r
113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
  tryEval $ do
    r <- (unsafeCoerce io :: String -> IO String) str
    evaluate (force r)

-- 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 opts io = do
  -- We are running in uninterruptibleMask
  breakMVar <- newEmptyMVar
  statusMVar <- newEmptyMVar
  withBreakAction opts breakMVar statusMVar $ do
133
    let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248
    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 EvalOpts{..} io =
  catch io $ \se -> do
    -- If -fbreak-on-error, we break unconditionally,
    --  but with care of not breaking twice
    if breakOnError && not breakOnException
       then poke exceptionFlag 1
       else case fromException se of
               -- If it is a "UserInterrupt" exception, we allow
               --  a possible break by way of -fbreak-on-exception
               Just UserInterrupt -> return ()
               -- In any other case, we don't want to break
               _ -> poke exceptionFlag 0
    throwIO 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 target wait = do
  wtid <- mkWeakThreadId target
  wait `catch` \e -> do
     m <- deRefWeak wtid
     case m of
       Nothing -> wait
       Just target -> do throwTo target (e :: SomeException); wait

measureAlloc :: IO (EvalResult a) -> IO (EvalStatus a)
measureAlloc io = do
  setAllocationCounter maxBound
  a <- io
  ctr <- getAllocationCounter
  let allocs = fromIntegral (maxBound::Int64) - fromIntegral ctr
  return (EvalComplete allocs a)

-- Exceptions can't be marshaled because they're dynamically typed, so
-- everything becomes a String.
tryEval :: IO a -> IO (EvalResult a)
tryEval io = do
  e <- try io
  case e of
    Left ex -> return (EvalException (toSerializableException ex))
    Right a -> return (EvalSuccess a)

toSerializableException :: SomeException -> SerializableException
toSerializableException ex
  | Just UserInterrupt <- fromException ex  = EUserInterrupt
  | Just (ec::ExitCode) <- fromException ex = (EExitCode ec)
  | otherwise = EOtherException (show (ex :: SomeException))

fromSerializableException :: SerializableException -> SomeException
fromSerializableException EUserInterrupt = toException UserInterrupt
fromSerializableException (EExitCode c) = toException c
fromSerializableException (EOtherException str) = toException (ErrorCall str)

-- 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 opts breakMVar statusMVar act
 = bracket setBreakAction resetBreakAction (\_ -> act)
 where
   setBreakAction = do
     stablePtr <- newStablePtr onBreak
     poke breakPointIOAction stablePtr
     when (breakOnException opts) $ poke exceptionFlag 1
     when (singleStep opts) $ setStepFlag
     return stablePtr
        -- 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.

249 250
   onBreak :: BreakpointCallback
   onBreak ix# uniq# is_exception apStack = do
251 252 253 254 255
     tid <- myThreadId
     let resume = ResumeContext
           { resumeBreakMVar = breakMVar
           , resumeStatusMVar = statusMVar
           , resumeThreadId = tid }
256 257
     resume_r <- mkRemoteRef resume
     apStack_r <- mkRemoteRef apStack
258
     ccs <- toRemotePtr <$> getCCSOf apStack
259
     putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs
260 261 262 263 264 265 266 267
     takeMVar breakMVar

   resetBreakAction stablePtr = do
     poke breakPointIOAction noBreakStablePtr
     poke exceptionFlag 0
     resetStepFlag
     freeStablePtr stablePtr

268 269 270
resumeStmt
  :: EvalOpts -> RemoteRef (ResumeContext [HValueRef])
  -> IO (EvalStatus [HValueRef])
271
resumeStmt opts hvref = do
272
  ResumeContext{..} <- localRef hvref
273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289
  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.
290
abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
291
abandonStmt hvref = do
292
  ResumeContext{..} <- localRef hvref
293 294 295 296 297 298 299 300 301 302 303 304 305
  killThread resumeThreadId
  putMVar resumeBreakMVar ()
  _ <- takeMVar resumeStatusMVar
  return ()

foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt
foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt

setStepFlag :: IO ()
setStepFlag = poke stepFlag 1
resetStepFlag :: IO ()
resetStepFlag = poke stepFlag 0

306 307
type BreakpointCallback = Int# -> Int# -> Bool -> HValue -> IO ()

308
foreign import ccall "&rts_breakpoint_io_action"
309
   breakPointIOAction :: Ptr (StablePtr BreakpointCallback)
310

311
noBreakStablePtr :: StablePtr BreakpointCallback
312 313
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction

314 315 316
noBreakAction :: BreakpointCallback
noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint"
noBreakAction _ _ True  _ = return () -- exception: just continue
317 318 319

-- Malloc and copy the bytes.  We don't have any way to monitor the
-- lifetime of this memory, so it just leaks.
320
mkString :: ByteString -> IO (RemotePtr ())
321 322 323
mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
  ptr <- mallocBytes len
  copyBytes ptr cstr len
324
  return (castRemotePtr (toRemotePtr ptr))
325

326
mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
327
#if defined(PROFILING)
328 329 330 331 332 333 334 335
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
336 337

foreign import ccall unsafe "mkCostCentre"
338
  c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
339
#else
340
mkCostCentres _ _ = return []
341
#endif
342 343 344 345 346 347 348 349 350 351

getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
   case getApStackVal# apStack (stackDepth +# 1#) of
                                -- The +1 is magic!  I don't know where it comes
                                -- from, but this makes things line up.  --SDM
        (# ok, result #) ->
            case ok of
              0# -> return Nothing -- AP_STACK not found
              _  -> return (Just (unsafeCoerce# result))