Clean up the debugger code
[ghc.git] / compiler / main / InteractiveEval.hs
1 -- -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow, 2005-2007
4 --
5 -- Running statements interactively
6 --
7 -- -----------------------------------------------------------------------------
8
9 module InteractiveEval (
10 #ifdef GHCI
11 RunResult(..), Status(..), Resume(..), History(..),
12 runStmt, parseImportDecl, SingleStep(..),
13 resume,
14 abandon, abandonAll,
15 getResumeContext,
16 getHistorySpan,
17 getModBreaks,
18 getHistoryModule,
19 back, forward,
20 setContext, getContext,
21 availsToGlobalRdrEnv,
22 getNamesInScope,
23 getRdrNamesInScope,
24 moduleIsInterpreted,
25 getInfo,
26 exprType,
27 typeKind,
28 parseName,
29 showModule,
30 isModuleInterpreted,
31 compileExpr, dynCompileExpr,
32 Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
33 #endif
34 ) where
35
36 #ifdef GHCI
37
38 #include "HsVersions.h"
39
40 import HscMain hiding (compileExpr)
41 import HsSyn (ImportDecl)
42 import HscTypes
43 import TcRnDriver
44 import TcRnMonad (initTc)
45 import RnNames (gresFromAvails, rnImports)
46 import InstEnv
47 import Type
48 import TcType hiding( typeKind )
49 import Var
50 import Id
51 import Name hiding ( varName )
52 import NameSet
53 import RdrName
54 import PrelNames (pRELUDE)
55 import VarSet
56 import VarEnv
57 import ByteCodeInstr
58 import Linker
59 import DynFlags
60 import Unique
61 import UniqSupply
62 import Module
63 import Panic
64 import UniqFM
65 import Maybes
66 import ErrUtils
67 import Util
68 import SrcLoc
69 import BreakArray
70 import RtClosureInspect
71 import BasicTypes
72 import Outputable
73 import FastString
74 import MonadUtils
75
76 import System.Directory
77 import Data.Dynamic
78 import Data.List (find, partition)
79 import Control.Monad
80 import Foreign hiding (unsafePerformIO)
81 import Foreign.C
82 import GHC.Exts
83 import Data.Array
84 import Exception
85 import Control.Concurrent
86 import Data.List (sortBy)
87 -- import Foreign.StablePtr
88 import System.IO
89 import System.IO.Unsafe
90
91 -- -----------------------------------------------------------------------------
92 -- running a statement interactively
93
94 data RunResult
95 = RunOk [Name] -- ^ names bound by this evaluation
96 | RunFailed -- ^ statement failed compilation
97 | RunException SomeException -- ^ statement raised an exception
98 | RunBreak ThreadId [Name] (Maybe BreakInfo)
99
100 data Status
101 = Break Bool HValue BreakInfo ThreadId
102 -- ^ the computation hit a breakpoint (Bool <=> was an exception)
103 | Complete (Either SomeException [HValue])
104 -- ^ the computation completed with either an exception or a value
105
106 data Resume
107 = Resume {
108 resumeStmt :: String, -- the original statement
109 resumeThreadId :: ThreadId, -- thread running the computation
110 resumeBreakMVar :: MVar (),
111 resumeStatMVar :: MVar Status,
112 resumeBindings :: [Id],
113 resumeFinalIds :: [Id], -- [Id] to bind on completion
114 resumeApStack :: HValue, -- The object from which we can get
115 -- value of the free variables.
116 resumeBreakInfo :: Maybe BreakInfo,
117 -- the breakpoint we stopped at
118 -- (Nothing <=> exception)
119 resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
120 -- to fetch the ModDetails & ModBreaks
121 -- to get this.
122 resumeHistory :: [History],
123 resumeHistoryIx :: Int -- 0 <==> at the top of the history
124 }
125
126 getResumeContext :: GhcMonad m => m [Resume]
127 getResumeContext = withSession (return . ic_resume . hsc_IC)
128
129 data SingleStep
130 = RunToCompletion
131 | SingleStep
132 | RunAndLogSteps
133
134 isStep :: SingleStep -> Bool
135 isStep RunToCompletion = False
136 isStep _ = True
137
138 data History
139 = History {
140 historyApStack :: HValue,
141 historyBreakInfo :: BreakInfo,
142 historyEnclosingDecl :: Id
143 -- ^^ A cache of the enclosing top level declaration, for convenience
144 }
145
146 mkHistory :: HscEnv -> HValue -> BreakInfo -> History
147 mkHistory hsc_env hval bi = let
148 h = History hval bi decl
149 decl = findEnclosingDecl hsc_env (getHistoryModule h)
150 (getHistorySpan hsc_env h)
151 in h
152
153 getHistoryModule :: History -> Module
154 getHistoryModule = breakInfo_module . historyBreakInfo
155
156 getHistorySpan :: HscEnv -> History -> SrcSpan
157 getHistorySpan hsc_env hist =
158 let inf = historyBreakInfo hist
159 num = breakInfo_number inf
160 in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
161 Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
162 _ -> panic "getHistorySpan"
163
164 getModBreaks :: HomeModInfo -> ModBreaks
165 getModBreaks hmi
166 | Just linkable <- hm_linkable hmi,
167 [BCOs _ modBreaks] <- linkableUnlinked linkable
168 = modBreaks
169 | otherwise
170 = emptyModBreaks -- probably object code
171
172 {- | Finds the enclosing top level function name -}
173 -- ToDo: a better way to do this would be to keep hold of the decl_path computed
174 -- by the coverage pass, which gives the list of lexically-enclosing bindings
175 -- for each tick.
176 findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
177 findEnclosingDecl hsc_env mod span =
178 case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
179 Nothing -> panic "findEnclosingDecl"
180 Just hmi -> let
181 globals = typeEnvIds (md_types (hm_details hmi))
182 Just decl =
183 find (\id -> let n = idName id in
184 nameSrcSpan n < span && isExternalName n)
185 (reverse$ sortBy (compare `on` (nameSrcSpan.idName))
186 globals)
187 in decl
188
189 -- | Run a statement in the current interactive context. Statement
190 -- may bind multple values.
191 runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
192 runStmt expr step =
193 do
194 hsc_env <- getSession
195
196 breakMVar <- liftIO $ newEmptyMVar -- wait on this when we hit a breakpoint
197 statusMVar <- liftIO $ newEmptyMVar -- wait on this when a computation is running
198
199 -- Turn off -fwarn-unused-bindings when running a statement, to hide
200 -- warnings about the implicit bindings we introduce.
201 let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
202 hsc_env' = hsc_env{ hsc_dflags = dflags' }
203
204 r <- hscStmt hsc_env' expr
205
206 case r of
207 Nothing -> return RunFailed -- empty statement / comment
208
209 Just (ids, hval) -> do
210 -- XXX: This is the only place we can print warnings before the
211 -- result. Is this really the right thing to do? It's fine for
212 -- GHCi, but what's correct for other GHC API clients? We could
213 -- introduce a callback argument.
214 warns <- getWarnings
215 liftIO $ printBagOfWarnings dflags' warns
216 clearWarnings
217
218 status <-
219 withVirtualCWD $
220 withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
221 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
222 liftIO $ sandboxIO dflags' statusMVar thing_to_run
223
224 let ic = hsc_IC hsc_env
225 bindings = ic_tmp_ids ic
226
227 case step of
228 RunAndLogSteps ->
229 traceRunStatus expr bindings ids
230 breakMVar statusMVar status emptyHistory
231 _other ->
232 handleRunStatus expr bindings ids
233 breakMVar statusMVar status emptyHistory
234
235 withVirtualCWD :: GhcMonad m => m a -> m a
236 withVirtualCWD m = do
237 hsc_env <- getSession
238 let ic = hsc_IC hsc_env
239
240 let set_cwd = do
241 dir <- liftIO $ getCurrentDirectory
242 case ic_cwd ic of
243 Just dir -> liftIO $ setCurrentDirectory dir
244 Nothing -> return ()
245 return dir
246
247 reset_cwd orig_dir = do
248 virt_dir <- liftIO $ getCurrentDirectory
249 hsc_env <- getSession
250 let old_IC = hsc_IC hsc_env
251 setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
252 liftIO $ setCurrentDirectory orig_dir
253
254 gbracket set_cwd reset_cwd $ \_ -> m
255
256 parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
257 parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr
258
259 emptyHistory :: BoundedList History
260 emptyHistory = nilBL 50 -- keep a log of length 50
261
262 handleRunStatus :: GhcMonad m =>
263 String-> [Id] -> [Id]
264 -> MVar () -> MVar Status -> Status -> BoundedList History
265 -> m RunResult
266 handleRunStatus expr bindings final_ids breakMVar statusMVar status
267 history =
268 case status of
269 -- did we hit a breakpoint or did we complete?
270 (Break is_exception apStack info tid) -> do
271 hsc_env <- getSession
272 let mb_info | is_exception = Nothing
273 | otherwise = Just info
274 (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
275 mb_info
276 let
277 resume = Resume { resumeStmt = expr, resumeThreadId = tid
278 , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
279 , resumeBindings = bindings, resumeFinalIds = final_ids
280 , resumeApStack = apStack, resumeBreakInfo = mb_info
281 , resumeSpan = span, resumeHistory = toListBL history
282 , resumeHistoryIx = 0 }
283 hsc_env2 = pushResume hsc_env1 resume
284 --
285 modifySession (\_ -> hsc_env2)
286 return (RunBreak tid names mb_info)
287 (Complete either_hvals) ->
288 case either_hvals of
289 Left e -> return (RunException e)
290 Right hvals -> do
291 hsc_env <- getSession
292 let final_ic = extendInteractiveContext (hsc_IC hsc_env) final_ids
293 final_names = map idName final_ids
294 liftIO $ Linker.extendLinkEnv (zip final_names hvals)
295 hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
296 modifySession (\_ -> hsc_env')
297 return (RunOk final_names)
298
299 traceRunStatus :: GhcMonad m =>
300 String -> [Id] -> [Id]
301 -> MVar () -> MVar Status -> Status -> BoundedList History
302 -> m RunResult
303 traceRunStatus expr bindings final_ids
304 breakMVar statusMVar status history = do
305 hsc_env <- getSession
306 case status of
307 -- when tracing, if we hit a breakpoint that is not explicitly
308 -- enabled, then we just log the event in the history and continue.
309 (Break is_exception apStack info tid) | not is_exception -> do
310 b <- liftIO $ isBreakEnabled hsc_env info
311 if b
312 then handle_normally
313 else do
314 let history' = mkHistory hsc_env apStack info `consBL` history
315 -- probably better make history strict here, otherwise
316 -- our BoundedList will be pointless.
317 _ <- liftIO $ evaluate history'
318 status <-
319 withBreakAction True (hsc_dflags hsc_env)
320 breakMVar statusMVar $ do
321 liftIO $ withInterruptsSentTo tid $ do
322 putMVar breakMVar () -- awaken the stopped thread
323 takeMVar statusMVar -- and wait for the result
324 traceRunStatus expr bindings final_ids
325 breakMVar statusMVar status history'
326 _other ->
327 handle_normally
328 where
329 handle_normally = handleRunStatus expr bindings final_ids
330 breakMVar statusMVar status history
331
332
333 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
334 isBreakEnabled hsc_env inf =
335 case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
336 Just hmi -> do
337 w <- getBreak (modBreaks_flags (getModBreaks hmi))
338 (breakInfo_number inf)
339 case w of Just n -> return (n /= 0); _other -> return False
340 _ ->
341 return False
342
343
344 foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
345 foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
346
347 setStepFlag :: IO ()
348 setStepFlag = poke stepFlag 1
349 resetStepFlag :: IO ()
350 resetStepFlag = poke stepFlag 0
351
352 -- this points to the IO action that is executed when a breakpoint is hit
353 foreign import ccall "&rts_breakpoint_io_action"
354 breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
355
356 -- When running a computation, we redirect ^C exceptions to the running
357 -- thread. ToDo: we might want a way to continue even if the target
358 -- thread doesn't die when it receives the exception... "this thread
359 -- is not responding".
360 --
361 -- Careful here: there may be ^C exceptions flying around, so we start the new
362 -- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
363 -- only while we execute the user's code. We can't afford to lose the final
364 -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
365 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
366 sandboxIO dflags statusMVar thing =
367 mask $ \restore -> -- fork starts blocked
368 let runIt = liftM Complete $ try (restore $ rethrow dflags thing)
369 in if dopt Opt_GhciSandbox dflags
370 then do tid <- forkIO $ do res <- runIt
371 putMVar statusMVar res -- empty: can't block
372 withInterruptsSentTo tid $ takeMVar statusMVar
373 else -- GLUT on OS X needs to run on the main thread. If you
374 -- try to use it from another thread then you just get a
375 -- white rectangle rendered. For this, or anything else
376 -- with such restrictions, you can turn the GHCi sandbox off
377 -- and things will be run in the main thread.
378 runIt
379
380 -- We want to turn ^C into a break when -fbreak-on-exception is on,
381 -- but it's an async exception and we only break for sync exceptions.
382 -- Idea: if we catch and re-throw it, then the re-throw will trigger
383 -- a break. Great - but we don't want to re-throw all exceptions, because
384 -- then we'll get a double break for ordinary sync exceptions (you'd have
385 -- to :continue twice, which looks strange). So if the exception is
386 -- not "Interrupted", we unset the exception flag before throwing.
387 --
388 rethrow :: DynFlags -> IO a -> IO a
389 rethrow dflags io = Exception.catch io $ \se -> do
390 -- If -fbreak-on-error, we break unconditionally,
391 -- but with care of not breaking twice
392 if dopt Opt_BreakOnError dflags &&
393 not (dopt Opt_BreakOnException dflags)
394 then poke exceptionFlag 1
395 else case fromException se of
396 -- If it is a "UserInterrupt" exception, we allow
397 -- a possible break by way of -fbreak-on-exception
398 Just UserInterrupt -> return ()
399 -- In any other case, we don't want to break
400 _ -> poke exceptionFlag 0
401
402 Exception.throwIO se
403
404 withInterruptsSentTo :: ThreadId -> IO r -> IO r
405 withInterruptsSentTo thread get_result = do
406 bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
407 (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
408 (\_ -> get_result)
409
410 -- This function sets up the interpreter for catching breakpoints, and
411 -- resets everything when the computation has stopped running. This
412 -- is a not-very-good way to ensure that only the interactive
413 -- evaluation should generate breakpoints.
414 withBreakAction :: (ExceptionMonad m, MonadIO m) =>
415 Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
416 withBreakAction step dflags breakMVar statusMVar act
417 = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
418 where
419 setBreakAction = do
420 stablePtr <- newStablePtr onBreak
421 poke breakPointIOAction stablePtr
422 when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
423 when step $ setStepFlag
424 return stablePtr
425 -- Breaking on exceptions is not enabled by default, since it
426 -- might be a bit surprising. The exception flag is turned off
427 -- as soon as it is hit, or in resetBreakAction below.
428
429 onBreak is_exception info apStack = do
430 tid <- myThreadId
431 putMVar statusMVar (Break is_exception apStack info tid)
432 takeMVar breakMVar
433
434 resetBreakAction stablePtr = do
435 poke breakPointIOAction noBreakStablePtr
436 poke exceptionFlag 0
437 resetStepFlag
438 freeStablePtr stablePtr
439
440 noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
441 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
442
443 noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
444 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
445 noBreakAction True _ _ = return () -- exception: just continue
446
447 resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
448 resume canLogSpan step
449 = do
450 hsc_env <- getSession
451 let ic = hsc_IC hsc_env
452 resume = ic_resume ic
453
454 case resume of
455 [] -> ghcError (ProgramError "not stopped at a breakpoint")
456 (r:rs) -> do
457 -- unbind the temporary locals by restoring the TypeEnv from
458 -- before the breakpoint, and drop this Resume from the
459 -- InteractiveContext.
460 let resume_tmp_ids = resumeBindings r
461 ic' = ic { ic_tmp_ids = resume_tmp_ids,
462 ic_resume = rs }
463 modifySession (\_ -> hsc_env{ hsc_IC = ic' })
464
465 -- remove any bindings created since the breakpoint from the
466 -- linker's environment
467 let new_names = map idName (filter (`notElem` resume_tmp_ids)
468 (ic_tmp_ids ic))
469 liftIO $ Linker.deleteFromLinkEnv new_names
470
471 when (isStep step) $ liftIO setStepFlag
472 case r of
473 Resume { resumeStmt = expr, resumeThreadId = tid
474 , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
475 , resumeBindings = bindings, resumeFinalIds = final_ids
476 , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
477 , resumeHistory = hist } -> do
478 withVirtualCWD $ do
479 withBreakAction (isStep step) (hsc_dflags hsc_env)
480 breakMVar statusMVar $ do
481 status <- liftIO $ withInterruptsSentTo tid $ do
482 putMVar breakMVar ()
483 -- this awakens the stopped thread...
484 takeMVar statusMVar
485 -- and wait for the result
486 let prevHistoryLst = fromListBL 50 hist
487 hist' = case info of
488 Nothing -> prevHistoryLst
489 Just i
490 | not $canLogSpan span -> prevHistoryLst
491 | otherwise -> mkHistory hsc_env apStack i `consBL`
492 fromListBL 50 hist
493 case step of
494 RunAndLogSteps ->
495 traceRunStatus expr bindings final_ids
496 breakMVar statusMVar status hist'
497 _other ->
498 handleRunStatus expr bindings final_ids
499 breakMVar statusMVar status hist'
500
501 back :: GhcMonad m => m ([Name], Int, SrcSpan)
502 back = moveHist (+1)
503
504 forward :: GhcMonad m => m ([Name], Int, SrcSpan)
505 forward = moveHist (subtract 1)
506
507 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
508 moveHist fn = do
509 hsc_env <- getSession
510 case ic_resume (hsc_IC hsc_env) of
511 [] -> ghcError (ProgramError "not stopped at a breakpoint")
512 (r:rs) -> do
513 let ix = resumeHistoryIx r
514 history = resumeHistory r
515 new_ix = fn ix
516 --
517 when (new_ix > length history) $
518 ghcError (ProgramError "no more logged breakpoints")
519 when (new_ix < 0) $
520 ghcError (ProgramError "already at the beginning of the history")
521
522 let
523 update_ic apStack mb_info = do
524 (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
525 apStack mb_info
526 let ic = hsc_IC hsc_env1
527 r' = r { resumeHistoryIx = new_ix }
528 ic' = ic { ic_resume = r':rs }
529
530 modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
531
532 return (names, new_ix, span)
533
534 -- careful: we want apStack to be the AP_STACK itself, not a thunk
535 -- around it, hence the cases are carefully constructed below to
536 -- make this the case. ToDo: this is v. fragile, do something better.
537 if new_ix == 0
538 then case r of
539 Resume { resumeApStack = apStack,
540 resumeBreakInfo = mb_info } ->
541 update_ic apStack mb_info
542 else case history !! (new_ix - 1) of
543 History apStack info _ ->
544 update_ic apStack (Just info)
545
546 -- -----------------------------------------------------------------------------
547 -- After stopping at a breakpoint, add free variables to the environment
548 result_fs :: FastString
549 result_fs = fsLit "_result"
550
551 bindLocalsAtBreakpoint
552 :: HscEnv
553 -> HValue
554 -> Maybe BreakInfo
555 -> IO (HscEnv, [Name], SrcSpan)
556
557 -- Nothing case: we stopped when an exception was raised, not at a
558 -- breakpoint. We have no location information or local variables to
559 -- bind, all we can do is bind a local variable to the exception
560 -- value.
561 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
562 let exn_fs = fsLit "_exception"
563 exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
564 e_fs = fsLit "e"
565 e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
566 e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
567 exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
568
569 ictxt0 = hsc_IC hsc_env
570 ictxt1 = extendInteractiveContext ictxt0 [exn_id]
571
572 span = mkGeneralSrcSpan (fsLit "<exception thrown>")
573 --
574 Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
575 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
576
577 -- Just case: we stopped at a breakpoint, we have information about the location
578 -- of the breakpoint and the free variables of the expression.
579 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
580
581 let
582 mod_name = moduleName (breakInfo_module info)
583 hmi = expectJust "bindLocalsAtBreakpoint" $
584 lookupUFM (hsc_HPT hsc_env) mod_name
585 breaks = getModBreaks hmi
586 index = breakInfo_number info
587 vars = breakInfo_vars info
588 result_ty = breakInfo_resty info
589 occs = modBreaks_vars breaks ! index
590 span = modBreaks_locs breaks ! index
591
592 -- filter out any unboxed ids; we can't bind these at the prompt
593 let pointers = filter (\(id,_) -> isPointer id) vars
594 isPointer id | PtrRep <- idPrimRep id = True
595 | otherwise = False
596
597 let (ids, offsets) = unzip pointers
598
599 -- It might be that getIdValFromApStack fails, because the AP_STACK
600 -- has been accidentally evaluated, or something else has gone wrong.
601 -- So that we don't fall over in a heap when this happens, just don't
602 -- bind any free variables instead, and we emit a warning.
603 mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
604 let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
605 when (any isNothing mb_hValues) $
606 debugTraceMsg (hsc_dflags hsc_env) 1 $
607 text "Warning: _result has been evaluated, some bindings have been lost"
608
609 new_ids <- zipWithM mkNewId occs filtered_ids
610 let names = map idName new_ids
611
612 -- make an Id for _result. We use the Unique of the FastString "_result";
613 -- we don't care about uniqueness here, because there will only be one
614 -- _result in scope at any time.
615 let result_name = mkInternalName (getUnique result_fs)
616 (mkVarOccFS result_fs) span
617 result_id = Id.mkVanillaGlobal result_name result_ty
618
619 -- for each Id we're about to bind in the local envt:
620 -- - tidy the type variables
621 -- - globalise the Id (Ids are supposed to be Global, apparently).
622 --
623 let result_ok = isPointer result_id
624 && not (isUnboxedTupleType (idType result_id))
625
626 all_ids | result_ok = result_id : new_ids
627 | otherwise = new_ids
628 id_tys = map idType all_ids
629 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
630 final_ids = zipWith setIdType all_ids tidy_tys
631 ictxt0 = hsc_IC hsc_env
632 ictxt1 = extendInteractiveContext ictxt0 final_ids
633
634 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
635 when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
636 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
637 return (hsc_env1, if result_ok then result_name:names else names, span)
638 where
639 mkNewId :: OccName -> Id -> IO Id
640 mkNewId occ id = do
641 us <- mkSplitUniqSupply 'I'
642 -- we need a fresh Unique for each Id we bind, because the linker
643 -- state is single-threaded and otherwise we'd spam old bindings
644 -- whenever we stop at a breakpoint. The InteractveContext is properly
645 -- saved/restored, but not the linker state. See #1743, test break026.
646 let
647 uniq = uniqFromSupply us
648 loc = nameSrcSpan (idName id)
649 name = mkInternalName uniq occ loc
650 ty = idType id
651 new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
652 return new_id
653
654 rttiEnvironment :: HscEnv -> IO HscEnv
655 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
656 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
657 incompletelyTypedIds =
658 [id | id <- tmp_ids
659 , not $ noSkolems id
660 , (occNameFS.nameOccName.idName) id /= result_fs]
661 hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
662 return hsc_env'
663 where
664 noSkolems = isEmptyVarSet . tyVarsOfType . idType
665 improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
666 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
667 Just id = find (\i -> idName i == name) tmp_ids
668 if noSkolems id
669 then return hsc_env
670 else do
671 mb_new_ty <- reconstructType hsc_env 10 id
672 let old_ty = idType id
673 case mb_new_ty of
674 Nothing -> return hsc_env
675 Just new_ty -> do
676 case improveRTTIType hsc_env old_ty new_ty of
677 Nothing -> return $
678 WARN(True, text (":print failed to calculate the "
679 ++ "improvement for a type")) hsc_env
680 Just subst -> do
681 when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
682 printForUser stderr alwaysQualify $
683 fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
684
685 let ic' = extendInteractiveContext
686 (substInteractiveContext ic subst) []
687 return hsc_env{hsc_IC=ic'}
688
689 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
690 getIdValFromApStack apStack (I# stackDepth) = do
691 case getApStackVal# apStack (stackDepth +# 1#) of
692 -- The +1 is magic! I don't know where it comes
693 -- from, but this makes things line up. --SDM
694 (# ok, result #) ->
695 case ok of
696 0# -> return Nothing -- AP_STACK not found
697 _ -> return (Just (unsafeCoerce# result))
698
699 pushResume :: HscEnv -> Resume -> HscEnv
700 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
701 where
702 ictxt0 = hsc_IC hsc_env
703 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
704
705 -- -----------------------------------------------------------------------------
706 -- Abandoning a resume context
707
708 abandon :: GhcMonad m => m Bool
709 abandon = do
710 hsc_env <- getSession
711 let ic = hsc_IC hsc_env
712 resume = ic_resume ic
713 case resume of
714 [] -> return False
715 r:rs -> do
716 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
717 liftIO $ abandon_ r
718 return True
719
720 abandonAll :: GhcMonad m => m Bool
721 abandonAll = do
722 hsc_env <- getSession
723 let ic = hsc_IC hsc_env
724 resume = ic_resume ic
725 case resume of
726 [] -> return False
727 rs -> do
728 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
729 liftIO $ mapM_ abandon_ rs
730 return True
731
732 -- when abandoning a computation we have to
733 -- (a) kill the thread with an async exception, so that the
734 -- computation itself is stopped, and
735 -- (b) fill in the MVar. This step is necessary because any
736 -- thunks that were under evaluation will now be updated
737 -- with the partial computation, which still ends in takeMVar,
738 -- so any attempt to evaluate one of these thunks will block
739 -- unless we fill in the MVar.
740 -- See test break010.
741 abandon_ :: Resume -> IO ()
742 abandon_ r = do
743 killThread (resumeThreadId r)
744 putMVar (resumeBreakMVar r) ()
745
746 -- -----------------------------------------------------------------------------
747 -- Bounded list, optimised for repeated cons
748
749 data BoundedList a = BL
750 {-# UNPACK #-} !Int -- length
751 {-# UNPACK #-} !Int -- bound
752 [a] -- left
753 [a] -- right, list is (left ++ reverse right)
754
755 nilBL :: Int -> BoundedList a
756 nilBL bound = BL 0 bound [] []
757
758 consBL :: a -> BoundedList a -> BoundedList a
759 consBL a (BL len bound left right)
760 | len < bound = BL (len+1) bound (a:left) right
761 | null right = BL len bound [a] $! tail (reverse left)
762 | otherwise = BL len bound (a:left) $! tail right
763
764 toListBL :: BoundedList a -> [a]
765 toListBL (BL _ _ left right) = left ++ reverse right
766
767 fromListBL :: Int -> [a] -> BoundedList a
768 fromListBL bound l = BL (length l) bound l []
769
770 -- lenBL (BL len _ _ _) = len
771
772 -- -----------------------------------------------------------------------------
773 -- | Set the interactive evaluation context.
774 --
775 -- Setting the context doesn't throw away any bindings; the bindings
776 -- we've built up in the InteractiveContext simply move to the new
777 -- module. They always shadow anything in scope in the current context.
778 setContext :: GhcMonad m =>
779 [Module] -- ^ entire top level scope of these modules
780 -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules
781 -> m ()
782 setContext toplev_mods other_mods = do
783 hsc_env <- getSession
784 let old_ic = hsc_IC hsc_env
785 hpt = hsc_HPT hsc_env
786 (decls,mods) = partition (isJust . snd) other_mods -- time for tracing
787 export_mods = map fst mods
788 imprt_decls = map noLoc (catMaybes (map snd decls))
789 --
790 export_env <- liftIO $ mkExportEnv hsc_env export_mods
791 import_env <-
792 if null imprt_decls then return emptyGlobalRdrEnv else do
793 let imports = rnImports imprt_decls
794 this_mod = if null toplev_mods then pRELUDE else head toplev_mods
795 (_, env, _,_) <-
796 ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports
797 return env
798 toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
799 let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
800 modifySession $ \_ ->
801 hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
802 ic_exports = other_mods,
803 ic_rn_gbl_env = all_env }}
804
805 -- Make a GlobalRdrEnv based on the exports of the modules only.
806 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
807 mkExportEnv hsc_env mods
808 = do { stuff <- mapM (getModuleExports hsc_env) mods
809 ; let (_msgs, mb_name_sets) = unzip stuff
810 envs = [ availsToGlobalRdrEnv (moduleName mod) avails
811 | (Just avails, mod) <- zip mb_name_sets mods ]
812 ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }
813
814 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
815 availsToGlobalRdrEnv mod_name avails
816 = mkGlobalRdrEnv (gresFromAvails imp_prov avails)
817 where
818 -- We're building a GlobalRdrEnv as if the user imported
819 -- all the specified modules into the global interactive module
820 imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
821 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
822 is_qual = False,
823 is_dloc = srcLocSpan interactiveSrcLoc }
824
825 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
826 mkTopLevEnv hpt modl
827 = case lookupUFM hpt (moduleName modl) of
828 Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
829 showSDoc (ppr modl)))
830 Just details ->
831 case mi_globals (hm_iface details) of
832 Nothing ->
833 ghcError (ProgramError ("mkTopLevEnv: not interpreted "
834 ++ showSDoc (ppr modl)))
835 Just env -> return env
836
837 -- | Get the interactive evaluation context, consisting of a pair of the
838 -- set of modules from which we take the full top-level scope, and the set
839 -- of modules from which we take just the exports respectively.
840 getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))])
841 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
842 return (ic_toplev_scope ic, ic_exports ic)
843
844 -- | Returns @True@ if the specified module is interpreted, and hence has
845 -- its full top-level scope available.
846 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
847 moduleIsInterpreted modl = withSession $ \h ->
848 if modulePackageId modl /= thisPackage (hsc_dflags h)
849 then return False
850 else case lookupUFM (hsc_HPT h) (moduleName modl) of
851 Just details -> return (isJust (mi_globals (hm_iface details)))
852 _not_a_home_module -> return False
853
854 -- | Looks up an identifier in the current interactive context (for :info)
855 -- Filter the instances by the ones whose tycons (or clases resp)
856 -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
857 -- The exact choice of which ones to show, and which to hide, is a judgement call.
858 -- (see Trac #1581)
859 getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
860 getInfo name
861 = withSession $ \hsc_env ->
862 do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
863 case mb_stuff of
864 Nothing -> return Nothing
865 Just (thing, fixity, ispecs) -> do
866 let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
867 return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
868 where
869 plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env
870 = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
871 where -- A name is ok if it's in the rdr_env,
872 -- whether qualified or not
873 ok n | n == name = True -- The one we looked for in the first place!
874 | isBuiltInSyntax n = True
875 | isExternalName n = any ((== n) . gre_name)
876 (lookupGRE_Name rdr_env n)
877 | otherwise = True
878
879 -- | Returns all names in scope in the current interactive context
880 getNamesInScope :: GhcMonad m => m [Name]
881 getNamesInScope = withSession $ \hsc_env -> do
882 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
883
884 getRdrNamesInScope :: GhcMonad m => m [RdrName]
885 getRdrNamesInScope = withSession $ \hsc_env -> do
886 let
887 ic = hsc_IC hsc_env
888 gbl_rdrenv = ic_rn_gbl_env ic
889 ids = ic_tmp_ids ic
890 gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
891 lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
892 --
893 return (gbl_names ++ lcl_names)
894
895
896 -- ToDo: move to RdrName
897 greToRdrNames :: GlobalRdrElt -> [RdrName]
898 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
899 = case prov of
900 LocalDef -> [unqual]
901 Imported specs -> concat (map do_spec (map is_decl specs))
902 where
903 occ = nameOccName name
904 unqual = Unqual occ
905 do_spec decl_spec
906 | is_qual decl_spec = [qual]
907 | otherwise = [unqual,qual]
908 where qual = Qual (is_as decl_spec) occ
909
910 -- | Parses a string as an identifier, and returns the list of 'Name's that
911 -- the identifier can refer to in the current interactive context.
912 parseName :: GhcMonad m => String -> m [Name]
913 parseName str = withSession $ \hsc_env -> do
914 (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
915 ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
916
917 -- -----------------------------------------------------------------------------
918 -- Getting the type of an expression
919
920 -- | Get the type of an expression
921 exprType :: GhcMonad m => String -> m Type
922 exprType expr = withSession $ \hsc_env -> do
923 ty <- hscTcExpr hsc_env expr
924 return $ tidyType emptyTidyEnv ty
925
926 -- -----------------------------------------------------------------------------
927 -- Getting the kind of a type
928
929 -- | Get the kind of a type
930 typeKind :: GhcMonad m => String -> m Kind
931 typeKind str = withSession $ \hsc_env -> do
932 hscKcType hsc_env str
933
934 -----------------------------------------------------------------------------
935 -- cmCompileExpr: compile an expression and deliver an HValue
936
937 compileExpr :: GhcMonad m => String -> m HValue
938 compileExpr expr = withSession $ \hsc_env -> do
939 Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
940 -- Run it!
941 hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
942
943 case (ids,hvals) of
944 ([_],[hv]) -> return hv
945 _ -> panic "compileExpr"
946
947 -- -----------------------------------------------------------------------------
948 -- Compile an expression into a dynamic
949
950 dynCompileExpr :: GhcMonad m => String -> m Dynamic
951 dynCompileExpr expr = do
952 (full,exports) <- getContext
953 setContext full $
954 (mkModule
955 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
956 ,Nothing):exports
957 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
958 Just (ids, hvals) <- withSession (flip hscStmt stmt)
959 setContext full exports
960 vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
961 case (ids,vals) of
962 (_:[], v:[]) -> return v
963 _ -> panic "dynCompileExpr"
964
965 -----------------------------------------------------------------------------
966 -- show a module and it's source/object filenames
967
968 showModule :: GhcMonad m => ModSummary -> m String
969 showModule mod_summary =
970 withSession $ \hsc_env -> do
971 interpreted <- isModuleInterpreted mod_summary
972 return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
973
974 isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
975 isModuleInterpreted mod_summary = withSession $ \hsc_env ->
976 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
977 Nothing -> panic "missing linkable"
978 Just mod_info -> return (not obj_linkable)
979 where
980 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
981
982 ----------------------------------------------------------------------------
983 -- RTTI primitives
984
985 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
986 obtainTermFromVal hsc_env bound force ty x =
987 cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
988
989 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
990 obtainTermFromId hsc_env bound force id = do
991 hv <- Linker.getHValue hsc_env (varName id)
992 cvObtainTerm hsc_env bound force (idType id) hv
993
994 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
995 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
996 reconstructType hsc_env bound id = do
997 hv <- Linker.getHValue hsc_env (varName id)
998 cvReconstructType hsc_env bound (idType id) hv
999
1000 #endif /* GHCI */
1001