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