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