never executed always true always false
1 {-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
2 UnboxedTuples #-}
3 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
4
5 -- |
6 -- Execute GHCi messages.
7 --
8 -- For details on Remote GHCi, see Note [Remote GHCi] in
9 -- compiler/GHC/Runtime/Interpreter.hs.
10 --
11 module GHCi.Run
12 ( run, redirectInterrupts
13 ) where
14
15 import Prelude -- See note [Why do we import Prelude here?]
16 import GHCi.CreateBCO
17 import GHCi.InfoTable
18 import GHCi.FFI
19 import GHCi.Message
20 import GHCi.ObjLink
21 import GHCi.RemoteTypes
22 import GHCi.TH
23 import GHCi.BreakArray
24 import GHCi.StaticPtrTable
25
26 import Control.Concurrent
27 import Control.DeepSeq
28 import Control.Exception
29 import Control.Monad
30 import Data.Binary
31 import Data.Binary.Get
32 import Data.ByteString (ByteString)
33 import qualified Data.ByteString.Unsafe as B
34 import GHC.Exts
35 import qualified GHC.Exts.Heap as Heap
36 import GHC.Stack
37 import Foreign hiding (void)
38 import Foreign.C
39 import GHC.Conc.Sync
40 import GHC.IO hiding ( bracket )
41 import System.Mem.Weak ( deRefWeak )
42 import Unsafe.Coerce
43
44 -- -----------------------------------------------------------------------------
45 -- Implement messages
46
47 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
48 -- Make it "safe", just in case
49
50 run :: Message a -> IO a
51 run m = case m of
52 InitLinker -> initObjLinker RetainCAFs
53 RtsRevertCAFs -> rts_revertCAFs
54 LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str
55 LookupClosure str -> lookupClosure str
56 LoadDLL str -> loadDLL str
57 LoadArchive str -> loadArchive str
58 LoadObj str -> loadObj str
59 UnloadObj str -> unloadObj str
60 AddLibrarySearchPath str -> toRemotePtr <$> addLibrarySearchPath str
61 RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr)
62 ResolveObjs -> resolveObjs
63 FindSystemLibrary str -> findSystemLibrary str
64 CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos)
65 FreeHValueRefs rs -> mapM_ freeRemoteRef rs
66 AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr
67 EvalStmt opts r -> evalStmt opts r
68 ResumeStmt opts r -> resumeStmt opts r
69 AbandonStmt r -> abandonStmt r
70 EvalString r -> evalString r
71 EvalStringToString r s -> evalStringToString r s
72 EvalIO r -> evalIO r
73 MkCostCentres mod ccs -> mkCostCentres mod ccs
74 CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
75 NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
76 SetupBreakpoint ref ix cnt -> do
77 arr <- localRef ref;
78 _ <- setupBreakpoint arr ix cnt
79 return ()
80 BreakpointStatus ref ix -> do
81 arr <- localRef ref; r <- getBreak arr ix
82 case r of
83 Nothing -> return False
84 Just w -> return (w == 0)
85 GetBreakpointVar ref ix -> do
86 aps <- localRef ref
87 mapM mkRemoteRef =<< getIdValFromApStack aps ix
88 MallocData bs -> mkString bs
89 MallocStrings bss -> mapM mkString0 bss
90 PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
91 FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
92 MkConInfoTable tc ptrs nptrs tag ptrtag desc ->
93 toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc
94 StartTH -> startTH
95 GetClosure ref -> do
96 clos <- Heap.getClosureData =<< localRef ref
97 mapM (\(Heap.Box x) -> mkRemoteRef (HValue x)) clos
98 Seq ref -> doSeq ref
99 ResumeSeq ref -> resumeSeq ref
100 _other -> error "GHCi.Run.run"
101
102 evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
103 evalStmt opts expr = do
104 io <- mkIO expr
105 sandboxIO opts $ do
106 rs <- unsafeCoerce io :: IO [HValue]
107 mapM mkRemoteRef rs
108 where
109 mkIO (EvalThis href) = localRef href
110 mkIO (EvalApp l r) = do
111 l' <- mkIO l
112 r' <- mkIO r
113 return ((unsafeCoerce l' :: HValue -> HValue) r')
114
115 evalIO :: HValueRef -> IO (EvalResult ())
116 evalIO r = do
117 io <- localRef r
118 tryEval (unsafeCoerce io :: IO ())
119
120 evalString :: HValueRef -> IO (EvalResult String)
121 evalString r = do
122 io <- localRef r
123 tryEval $ do
124 r <- unsafeCoerce io :: IO String
125 evaluate (force r)
126
127 evalStringToString :: HValueRef -> String -> IO (EvalResult String)
128 evalStringToString r str = do
129 io <- localRef r
130 tryEval $ do
131 r <- (unsafeCoerce io :: String -> IO String) str
132 evaluate (force r)
133
134 -- | Process the Seq message to force a value. #2950
135 -- If during this processing a breakpoint is hit, return
136 -- an EvalBreak value in the EvalStatus to the UI process,
137 -- otherwise return an EvalComplete.
138 -- The UI process has more and therefore also can show more
139 -- information about the breakpoint than the current iserv
140 -- process.
141 doSeq :: RemoteRef a -> IO (EvalStatus ())
142 doSeq ref = do
143 sandboxIO evalOptsSeq $ do
144 _ <- (void $ evaluate =<< localRef ref)
145 return ()
146
147 -- | Process a ResumeSeq message. Continue the :force processing #2950
148 -- after a breakpoint.
149 resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())
150 resumeSeq hvref = do
151 ResumeContext{..} <- localRef hvref
152 withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar $
153 mask_ $ do
154 putMVar resumeBreakMVar () -- this awakens the stopped thread...
155 redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar
156
157 evalOptsSeq :: EvalOpts
158 evalOptsSeq = EvalOpts
159 { useSandboxThread = True
160 , singleStep = False
161 , breakOnException = False
162 , breakOnError = False
163 }
164
165 -- When running a computation, we redirect ^C exceptions to the running
166 -- thread. ToDo: we might want a way to continue even if the target
167 -- thread doesn't die when it receives the exception... "this thread
168 -- is not responding".
169 --
170 -- Careful here: there may be ^C exceptions flying around, so we start the new
171 -- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
172 -- only while we execute the user's code. We can't afford to lose the final
173 -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
174
175 sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)
176 sandboxIO opts io = do
177 -- We are running in uninterruptibleMask
178 breakMVar <- newEmptyMVar
179 statusMVar <- newEmptyMVar
180 withBreakAction opts breakMVar statusMVar $ do
181 let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
182 if useSandboxThread opts
183 then do
184 tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar
185 -- empty: can't block
186 redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar
187 else
188 -- GLUT on OS X needs to run on the main thread. If you
189 -- try to use it from another thread then you just get a
190 -- white rectangle rendered. For this, or anything else
191 -- with such restrictions, you can turn the GHCi sandbox off
192 -- and things will be run in the main thread.
193 --
194 -- BUT, note that the debugging features (breakpoints,
195 -- tracing, etc.) need the expression to be running in a
196 -- separate thread, so debugging is only enabled when
197 -- using the sandbox.
198 runIt
199
200 -- We want to turn ^C into a break when -fbreak-on-exception is on,
201 -- but it's an async exception and we only break for sync exceptions.
202 -- Idea: if we catch and re-throw it, then the re-throw will trigger
203 -- a break. Great - but we don't want to re-throw all exceptions, because
204 -- then we'll get a double break for ordinary sync exceptions (you'd have
205 -- to :continue twice, which looks strange). So if the exception is
206 -- not "Interrupted", we unset the exception flag before throwing.
207 --
208 rethrow :: EvalOpts -> IO a -> IO a
209 rethrow EvalOpts{..} io =
210 catch io $ \se -> do
211 -- If -fbreak-on-error, we break unconditionally,
212 -- but with care of not breaking twice
213 if breakOnError && not breakOnException
214 then poke exceptionFlag 1
215 else case fromException se of
216 -- If it is a "UserInterrupt" exception, we allow
217 -- a possible break by way of -fbreak-on-exception
218 Just UserInterrupt -> return ()
219 -- In any other case, we don't want to break
220 _ -> poke exceptionFlag 0
221 throwIO se
222
223 --
224 -- While we're waiting for the sandbox thread to return a result, if
225 -- the current thread receives an asynchronous exception we re-throw
226 -- it at the sandbox thread and continue to wait.
227 --
228 -- This is for two reasons:
229 --
230 -- * So that ^C interrupts runStmt (e.g. in GHCi), allowing the
231 -- computation to run its exception handlers before returning the
232 -- exception result to the caller of runStmt.
233 --
234 -- * clients of the GHC API can terminate a runStmt in progress
235 -- without knowing the ThreadId of the sandbox thread (#1381)
236 --
237 -- NB. use a weak pointer to the thread, so that the thread can still
238 -- be considered deadlocked by the RTS and sent a BlockedIndefinitely
239 -- exception. A symptom of getting this wrong is that conc033(ghci)
240 -- will hang.
241 --
242 redirectInterrupts :: ThreadId -> IO a -> IO a
243 redirectInterrupts target wait = do
244 wtid <- mkWeakThreadId target
245 wait `catch` \e -> do
246 m <- deRefWeak wtid
247 case m of
248 Nothing -> wait
249 Just target -> do throwTo target (e :: SomeException); wait
250
251 measureAlloc :: IO (EvalResult a) -> IO (EvalStatus a)
252 measureAlloc io = do
253 setAllocationCounter 0 -- #16012
254 a <- io
255 ctr <- getAllocationCounter
256 let allocs = negate $ fromIntegral ctr
257 return (EvalComplete allocs a)
258
259 -- Exceptions can't be marshaled because they're dynamically typed, so
260 -- everything becomes a String.
261 tryEval :: IO a -> IO (EvalResult a)
262 tryEval io = do
263 e <- try io
264 case e of
265 Left ex -> return (EvalException (toSerializableException ex))
266 Right a -> return (EvalSuccess a)
267
268 -- This function sets up the interpreter for catching breakpoints, and
269 -- resets everything when the computation has stopped running. This
270 -- is a not-very-good way to ensure that only the interactive
271 -- evaluation should generate breakpoints.
272 withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
273 withBreakAction opts breakMVar statusMVar act
274 = bracket setBreakAction resetBreakAction (\_ -> act)
275 where
276 setBreakAction = do
277 stablePtr <- newStablePtr onBreak
278 poke breakPointIOAction stablePtr
279 when (breakOnException opts) $ poke exceptionFlag 1
280 when (singleStep opts) $ setStepFlag
281 return stablePtr
282 -- Breaking on exceptions is not enabled by default, since it
283 -- might be a bit surprising. The exception flag is turned off
284 -- as soon as it is hit, or in resetBreakAction below.
285
286 onBreak :: BreakpointCallback
287 onBreak ix# uniq# is_exception apStack = do
288 tid <- myThreadId
289 let resume = ResumeContext
290 { resumeBreakMVar = breakMVar
291 , resumeStatusMVar = statusMVar
292 , resumeThreadId = tid }
293 resume_r <- mkRemoteRef resume
294 apStack_r <- mkRemoteRef apStack
295 ccs <- toRemotePtr <$> getCCSOf apStack
296 putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs
297 takeMVar breakMVar
298
299 resetBreakAction stablePtr = do
300 poke breakPointIOAction noBreakStablePtr
301 poke exceptionFlag 0
302 resetStepFlag
303 freeStablePtr stablePtr
304
305 resumeStmt
306 :: EvalOpts -> RemoteRef (ResumeContext [HValueRef])
307 -> IO (EvalStatus [HValueRef])
308 resumeStmt opts hvref = do
309 ResumeContext{..} <- localRef hvref
310 withBreakAction opts resumeBreakMVar resumeStatusMVar $
311 mask_ $ do
312 putMVar resumeBreakMVar () -- this awakens the stopped thread...
313 redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar
314
315 -- when abandoning a computation we have to
316 -- (a) kill the thread with an async exception, so that the
317 -- computation itself is stopped, and
318 -- (b) fill in the MVar. This step is necessary because any
319 -- thunks that were under evaluation will now be updated
320 -- with the partial computation, which still ends in takeMVar,
321 -- so any attempt to evaluate one of these thunks will block
322 -- unless we fill in the MVar.
323 -- (c) wait for the thread to terminate by taking its status MVar. This
324 -- step is necessary to prevent race conditions with
325 -- -fbreak-on-exception (see #5975).
326 -- See test break010.
327 abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
328 abandonStmt hvref = do
329 ResumeContext{..} <- localRef hvref
330 killThread resumeThreadId
331 putMVar resumeBreakMVar ()
332 _ <- takeMVar resumeStatusMVar
333 return ()
334
335 foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
336 foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
337
338 setStepFlag :: IO ()
339 setStepFlag = poke stepFlag 1
340 resetStepFlag :: IO ()
341 resetStepFlag = poke stepFlag 0
342
343 type BreakpointCallback
344 = Int# -- the breakpoint index
345 -> Int# -- the module uniq
346 -> Bool -- exception?
347 -> HValue -- the AP_STACK, or exception
348 -> IO ()
349
350 foreign import ccall "&rts_breakpoint_io_action"
351 breakPointIOAction :: Ptr (StablePtr BreakpointCallback)
352
353 noBreakStablePtr :: StablePtr BreakpointCallback
354 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
355
356 noBreakAction :: BreakpointCallback
357 noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint"
358 noBreakAction _ _ True _ = return () -- exception: just continue
359
360 -- Malloc and copy the bytes. We don't have any way to monitor the
361 -- lifetime of this memory, so it just leaks.
362 mkString :: ByteString -> IO (RemotePtr ())
363 mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
364 ptr <- mallocBytes len
365 copyBytes ptr cstr len
366 return (castRemotePtr (toRemotePtr ptr))
367
368 mkString0 :: ByteString -> IO (RemotePtr ())
369 mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
370 ptr <- mallocBytes (len+1)
371 copyBytes ptr cstr len
372 pokeElemOff (ptr :: Ptr CChar) len 0
373 return (castRemotePtr (toRemotePtr ptr))
374
375 mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
376 #if defined(PROFILING)
377 mkCostCentres mod ccs = do
378 c_module <- newCString mod
379 mapM (mk_one c_module) ccs
380 where
381 mk_one c_module (decl_path,srcspan) = do
382 c_name <- newCString decl_path
383 c_srcspan <- newCString srcspan
384 toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
385
386 foreign import ccall unsafe "mkCostCentre"
387 c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
388 #else
389 mkCostCentres _ _ = return []
390 #endif
391
392 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
393 getIdValFromApStack apStack (I# stackDepth) = do
394 case getApStackVal# apStack stackDepth of
395 (# ok, result #) ->
396 case ok of
397 0# -> return Nothing -- AP_STACK not found
398 _ -> return (Just (unsafeCoerce# result))