Fix Trac #4127: build GlobalRdrEnv in GHCi correctly
[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 availsToGlobalRdrEnv,
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 RnNames ( gresFromAvails )
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 VarSet
55 import VarEnv
56 import ByteCodeInstr
57 import Linker
58 import DynFlags
59 import Unique
60 import UniqSupply
61 import Module
62 import Panic
63 import UniqFM
64 import Maybes
65 import ErrUtils
66 import Util
67 import SrcLoc
68 import BreakArray
69 import RtClosureInspect
70 import BasicTypes
71 import Outputable
72 import FastString
73 import MonadUtils
74
75 import System.Directory
76 import Data.Dynamic
77 import Data.List (find)
78 import Control.Monad
79 import Foreign
80 import Foreign.C
81 import GHC.Exts
82 import Data.Array
83 import Exception
84 import Control.Concurrent
85 import Data.List (sortBy)
86 -- import Foreign.StablePtr
87 import System.IO
88
89 -- -----------------------------------------------------------------------------
90 -- running a statement interactively
91
92 data RunResult
93 = RunOk [Name] -- ^ names bound by this evaluation
94 | RunFailed -- ^ statement failed compilation
95 | RunException SomeException -- ^ statement raised an exception
96 | RunBreak ThreadId [Name] (Maybe BreakInfo)
97
98 data Status
99 = Break Bool HValue BreakInfo ThreadId
100 -- ^ the computation hit a breakpoint (Bool <=> was an exception)
101 | Complete (Either SomeException [HValue])
102 -- ^ the computation completed with either an exception or a value
103
104 data Resume
105 = Resume {
106 resumeStmt :: String, -- the original statement
107 resumeThreadId :: ThreadId, -- thread running the computation
108 resumeBreakMVar :: MVar (),
109 resumeStatMVar :: MVar Status,
110 resumeBindings :: ([Id], TyVarSet),
111 resumeFinalIds :: [Id], -- [Id] to bind on completion
112 resumeApStack :: HValue, -- The object from which we can get
113 -- value of the free variables.
114 resumeBreakInfo :: Maybe BreakInfo,
115 -- the breakpoint we stopped at
116 -- (Nothing <=> exception)
117 resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
118 -- to fetch the ModDetails & ModBreaks
119 -- to get this.
120 resumeHistory :: [History],
121 resumeHistoryIx :: Int -- 0 <==> at the top of the history
122 }
123
124 getResumeContext :: GhcMonad m => m [Resume]
125 getResumeContext = withSession (return . ic_resume . hsc_IC)
126
127 data SingleStep
128 = RunToCompletion
129 | SingleStep
130 | RunAndLogSteps
131
132 isStep :: SingleStep -> Bool
133 isStep RunToCompletion = False
134 isStep _ = True
135
136 data History
137 = History {
138 historyApStack :: HValue,
139 historyBreakInfo :: BreakInfo,
140 historyEnclosingDecl :: Id
141 -- ^^ A cache of the enclosing top level declaration, for convenience
142 }
143
144 mkHistory :: HscEnv -> HValue -> BreakInfo -> History
145 mkHistory hsc_env hval bi = let
146 h = History hval bi decl
147 decl = findEnclosingDecl hsc_env (getHistoryModule h)
148 (getHistorySpan hsc_env h)
149 in h
150
151 getHistoryModule :: History -> Module
152 getHistoryModule = breakInfo_module . historyBreakInfo
153
154 getHistorySpan :: HscEnv -> History -> SrcSpan
155 getHistorySpan hsc_env hist =
156 let inf = historyBreakInfo hist
157 num = breakInfo_number inf
158 in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
159 Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
160 _ -> panic "getHistorySpan"
161
162 getModBreaks :: HomeModInfo -> ModBreaks
163 getModBreaks hmi
164 | Just linkable <- hm_linkable hmi,
165 [BCOs _ modBreaks] <- linkableUnlinked linkable
166 = modBreaks
167 | otherwise
168 = emptyModBreaks -- probably object code
169
170 {- | Finds the enclosing top level function name -}
171 -- ToDo: a better way to do this would be to keep hold of the decl_path computed
172 -- by the coverage pass, which gives the list of lexically-enclosing bindings
173 -- for each tick.
174 findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
175 findEnclosingDecl hsc_env mod span =
176 case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
177 Nothing -> panic "findEnclosingDecl"
178 Just hmi -> let
179 globals = typeEnvIds (md_types (hm_details hmi))
180 Just decl =
181 find (\id -> let n = idName id in
182 nameSrcSpan n < span && isExternalName n)
183 (reverse$ sortBy (compare `on` (nameSrcSpan.idName))
184 globals)
185 in decl
186
187 -- | Run a statement in the current interactive context. Statement
188 -- may bind multple values.
189 runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
190 runStmt expr step =
191 do
192 hsc_env <- getSession
193
194 breakMVar <- liftIO $ newEmptyMVar -- wait on this when we hit a breakpoint
195 statusMVar <- liftIO $ newEmptyMVar -- wait on this when a computation is running
196
197 -- Turn off -fwarn-unused-bindings when running a statement, to hide
198 -- warnings about the implicit bindings we introduce.
199 let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
200 hsc_env' = hsc_env{ hsc_dflags = dflags' }
201
202 r <- hscStmt hsc_env' expr
203
204 case r of
205 Nothing -> return RunFailed -- empty statement / comment
206
207 Just (ids, hval) -> do
208 -- XXX: This is the only place we can print warnings before the
209 -- result. Is this really the right thing to do? It's fine for
210 -- GHCi, but what's correct for other GHC API clients? We could
211 -- introduce a callback argument.
212 warns <- getWarnings
213 liftIO $ printBagOfWarnings dflags' warns
214 clearWarnings
215
216 status <-
217 withVirtualCWD $
218 withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
219 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
220 liftIO $ sandboxIO dflags' statusMVar thing_to_run
221
222 let ic = hsc_IC hsc_env
223 bindings = (ic_tmp_ids ic, ic_tyvars ic)
224
225 case step of
226 RunAndLogSteps ->
227 traceRunStatus expr bindings ids
228 breakMVar statusMVar status emptyHistory
229 _other ->
230 handleRunStatus expr bindings ids
231 breakMVar statusMVar status emptyHistory
232
233 withVirtualCWD :: GhcMonad m => m a -> m a
234 withVirtualCWD m = do
235 hsc_env <- getSession
236 let ic = hsc_IC hsc_env
237
238 let set_cwd = do
239 dir <- liftIO $ getCurrentDirectory
240 case ic_cwd ic of
241 Just dir -> liftIO $ setCurrentDirectory dir
242 Nothing -> return ()
243 return dir
244
245 reset_cwd orig_dir = do
246 virt_dir <- liftIO $ getCurrentDirectory
247 hsc_env <- getSession
248 let old_IC = hsc_IC hsc_env
249 setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
250 liftIO $ setCurrentDirectory orig_dir
251
252 gbracket set_cwd reset_cwd $ \_ -> m
253
254
255 emptyHistory :: BoundedList History
256 emptyHistory = nilBL 50 -- keep a log of length 50
257
258 handleRunStatus :: GhcMonad m =>
259 String-> ([Id], TyVarSet) -> [Id]
260 -> MVar () -> MVar Status -> Status -> BoundedList History
261 -> m RunResult
262 handleRunStatus expr bindings final_ids breakMVar statusMVar status
263 history =
264 case status of
265 -- did we hit a breakpoint or did we complete?
266 (Break is_exception apStack info tid) -> do
267 hsc_env <- getSession
268 let mb_info | is_exception = Nothing
269 | otherwise = Just info
270 (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
271 mb_info
272 let
273 resume = Resume expr tid breakMVar statusMVar
274 bindings final_ids apStack mb_info span
275 (toListBL history) 0
276 hsc_env2 = pushResume hsc_env1 resume
277 --
278 modifySession (\_ -> hsc_env2)
279 return (RunBreak tid names mb_info)
280 (Complete either_hvals) ->
281 case either_hvals of
282 Left e -> return (RunException e)
283 Right hvals -> do
284 hsc_env <- getSession
285 let final_ic = extendInteractiveContext (hsc_IC hsc_env)
286 final_ids emptyVarSet
287 -- the bound Ids never have any free TyVars
288 final_names = map idName final_ids
289 liftIO $ Linker.extendLinkEnv (zip final_names hvals)
290 hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
291 modifySession (\_ -> hsc_env')
292 return (RunOk final_names)
293
294 traceRunStatus :: GhcMonad m =>
295 String -> ([Id], TyVarSet) -> [Id]
296 -> MVar () -> MVar Status -> Status -> BoundedList History
297 -> m RunResult
298 traceRunStatus expr bindings final_ids
299 breakMVar statusMVar status history = do
300 hsc_env <- getSession
301 case status of
302 -- when tracing, if we hit a breakpoint that is not explicitly
303 -- enabled, then we just log the event in the history and continue.
304 (Break is_exception apStack info tid) | not is_exception -> do
305 b <- liftIO $ isBreakEnabled hsc_env info
306 if b
307 then handle_normally
308 else do
309 let history' = mkHistory hsc_env apStack info `consBL` history
310 -- probably better make history strict here, otherwise
311 -- our BoundedList will be pointless.
312 _ <- liftIO $ evaluate history'
313 status <-
314 withBreakAction True (hsc_dflags hsc_env)
315 breakMVar statusMVar $ do
316 liftIO $ withInterruptsSentTo tid $ do
317 putMVar breakMVar () -- awaken the stopped thread
318 takeMVar statusMVar -- and wait for the result
319 traceRunStatus expr bindings final_ids
320 breakMVar statusMVar status history'
321 _other ->
322 handle_normally
323 where
324 handle_normally = handleRunStatus expr bindings final_ids
325 breakMVar statusMVar status history
326
327
328 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
329 isBreakEnabled hsc_env inf =
330 case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
331 Just hmi -> do
332 w <- getBreak (modBreaks_flags (getModBreaks hmi))
333 (breakInfo_number inf)
334 case w of Just n -> return (n /= 0); _other -> return False
335 _ ->
336 return False
337
338
339 foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
340 foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
341
342 setStepFlag :: IO ()
343 setStepFlag = poke stepFlag 1
344 resetStepFlag :: IO ()
345 resetStepFlag = poke stepFlag 0
346
347 -- this points to the IO action that is executed when a breakpoint is hit
348 foreign import ccall "&rts_breakpoint_io_action"
349 breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
350
351 -- When running a computation, we redirect ^C exceptions to the running
352 -- thread. ToDo: we might want a way to continue even if the target
353 -- thread doesn't die when it receives the exception... "this thread
354 -- is not responding".
355 --
356 -- Careful here: there may be ^C exceptions flying around, so we start the new
357 -- thread blocked (forkIO inherits block from the parent, #1048), and unblock
358 -- only while we execute the user's code. We can't afford to lose the final
359 -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
360 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
361 sandboxIO dflags statusMVar thing =
362 block $ do -- fork starts blocked
363 id <- forkIO $ do res <- Exception.try (unblock $ rethrow dflags thing)
364 putMVar statusMVar (Complete res) -- empty: can't block
365 withInterruptsSentTo id $ takeMVar statusMVar
366
367
368 -- We want to turn ^C into a break when -fbreak-on-exception is on,
369 -- but it's an async exception and we only break for sync exceptions.
370 -- Idea: if we catch and re-throw it, then the re-throw will trigger
371 -- a break. Great - but we don't want to re-throw all exceptions, because
372 -- then we'll get a double break for ordinary sync exceptions (you'd have
373 -- to :continue twice, which looks strange). So if the exception is
374 -- not "Interrupted", we unset the exception flag before throwing.
375 --
376 rethrow :: DynFlags -> IO a -> IO a
377 rethrow dflags io = Exception.catch io $ \se -> do
378 -- If -fbreak-on-error, we break unconditionally,
379 -- but with care of not breaking twice
380 if dopt Opt_BreakOnError dflags &&
381 not (dopt Opt_BreakOnException dflags)
382 then poke exceptionFlag 1
383 else case fromException se of
384 -- If it is a "UserInterrupt" exception, we allow
385 -- a possible break by way of -fbreak-on-exception
386 Just UserInterrupt -> return ()
387 -- In any other case, we don't want to break
388 _ -> poke exceptionFlag 0
389
390 Exception.throwIO se
391
392 withInterruptsSentTo :: ThreadId -> IO r -> IO r
393 withInterruptsSentTo thread get_result = do
394 bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
395 (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
396 (\_ -> get_result)
397
398 -- This function sets up the interpreter for catching breakpoints, and
399 -- resets everything when the computation has stopped running. This
400 -- is a not-very-good way to ensure that only the interactive
401 -- evaluation should generate breakpoints.
402 withBreakAction :: (ExceptionMonad m, MonadIO m) =>
403 Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
404 withBreakAction step dflags breakMVar statusMVar act
405 = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
406 where
407 setBreakAction = do
408 stablePtr <- newStablePtr onBreak
409 poke breakPointIOAction stablePtr
410 when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
411 when step $ setStepFlag
412 return stablePtr
413 -- Breaking on exceptions is not enabled by default, since it
414 -- might be a bit surprising. The exception flag is turned off
415 -- as soon as it is hit, or in resetBreakAction below.
416
417 onBreak is_exception info apStack = do
418 tid <- myThreadId
419 putMVar statusMVar (Break is_exception apStack info tid)
420 takeMVar breakMVar
421
422 resetBreakAction stablePtr = do
423 poke breakPointIOAction noBreakStablePtr
424 poke exceptionFlag 0
425 resetStepFlag
426 freeStablePtr stablePtr
427
428 noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
429 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
430
431 noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
432 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
433 noBreakAction True _ _ = return () -- exception: just continue
434
435 resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
436 resume canLogSpan step
437 = do
438 hsc_env <- getSession
439 let ic = hsc_IC hsc_env
440 resume = ic_resume ic
441
442 case resume of
443 [] -> ghcError (ProgramError "not stopped at a breakpoint")
444 (r:rs) -> do
445 -- unbind the temporary locals by restoring the TypeEnv from
446 -- before the breakpoint, and drop this Resume from the
447 -- InteractiveContext.
448 let (resume_tmp_ids, resume_tyvars) = resumeBindings r
449 ic' = ic { ic_tmp_ids = resume_tmp_ids,
450 ic_tyvars = resume_tyvars,
451 ic_resume = rs }
452 modifySession (\_ -> hsc_env{ hsc_IC = ic' })
453
454 -- remove any bindings created since the breakpoint from the
455 -- linker's environment
456 let new_names = map idName (filter (`notElem` resume_tmp_ids)
457 (ic_tmp_ids ic))
458 liftIO $ Linker.deleteFromLinkEnv new_names
459
460 when (isStep step) $ liftIO setStepFlag
461 case r of
462 Resume expr tid breakMVar statusMVar bindings
463 final_ids apStack info span hist _ -> do
464 withVirtualCWD $ do
465 withBreakAction (isStep step) (hsc_dflags hsc_env)
466 breakMVar statusMVar $ do
467 status <- liftIO $ withInterruptsSentTo tid $ do
468 putMVar breakMVar ()
469 -- this awakens the stopped thread...
470 takeMVar statusMVar
471 -- and wait for the result
472 let prevHistoryLst = fromListBL 50 hist
473 hist' = case info of
474 Nothing -> prevHistoryLst
475 Just i
476 | not $canLogSpan span -> prevHistoryLst
477 | otherwise -> mkHistory hsc_env apStack i `consBL`
478 fromListBL 50 hist
479 case step of
480 RunAndLogSteps ->
481 traceRunStatus expr bindings final_ids
482 breakMVar statusMVar status hist'
483 _other ->
484 handleRunStatus expr bindings final_ids
485 breakMVar statusMVar status hist'
486
487 back :: GhcMonad m => m ([Name], Int, SrcSpan)
488 back = moveHist (+1)
489
490 forward :: GhcMonad m => m ([Name], Int, SrcSpan)
491 forward = moveHist (subtract 1)
492
493 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
494 moveHist fn = do
495 hsc_env <- getSession
496 case ic_resume (hsc_IC hsc_env) of
497 [] -> ghcError (ProgramError "not stopped at a breakpoint")
498 (r:rs) -> do
499 let ix = resumeHistoryIx r
500 history = resumeHistory r
501 new_ix = fn ix
502 --
503 when (new_ix > length history) $
504 ghcError (ProgramError "no more logged breakpoints")
505 when (new_ix < 0) $
506 ghcError (ProgramError "already at the beginning of the history")
507
508 let
509 update_ic apStack mb_info = do
510 (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
511 apStack mb_info
512 let ic = hsc_IC hsc_env1
513 r' = r { resumeHistoryIx = new_ix }
514 ic' = ic { ic_resume = r':rs }
515
516 modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
517
518 return (names, new_ix, span)
519
520 -- careful: we want apStack to be the AP_STACK itself, not a thunk
521 -- around it, hence the cases are carefully constructed below to
522 -- make this the case. ToDo: this is v. fragile, do something better.
523 if new_ix == 0
524 then case r of
525 Resume { resumeApStack = apStack,
526 resumeBreakInfo = mb_info } ->
527 update_ic apStack mb_info
528 else case history !! (new_ix - 1) of
529 History apStack info _ ->
530 update_ic apStack (Just info)
531
532 -- -----------------------------------------------------------------------------
533 -- After stopping at a breakpoint, add free variables to the environment
534 result_fs :: FastString
535 result_fs = fsLit "_result"
536
537 bindLocalsAtBreakpoint
538 :: HscEnv
539 -> HValue
540 -> Maybe BreakInfo
541 -> IO (HscEnv, [Name], SrcSpan)
542
543 -- Nothing case: we stopped when an exception was raised, not at a
544 -- breakpoint. We have no location information or local variables to
545 -- bind, all we can do is bind a local variable to the exception
546 -- value.
547 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
548 let exn_fs = fsLit "_exception"
549 exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
550 e_fs = fsLit "e"
551 e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
552 e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
553 exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
554 new_tyvars = unitVarSet e_tyvar
555
556 ictxt0 = hsc_IC hsc_env
557 ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
558
559 span = mkGeneralSrcSpan (fsLit "<exception thrown>")
560 --
561 Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
562 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
563
564 -- Just case: we stopped at a breakpoint, we have information about the location
565 -- of the breakpoint and the free variables of the expression.
566 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
567
568 let
569 mod_name = moduleName (breakInfo_module info)
570 hmi = expectJust "bindLocalsAtBreakpoint" $
571 lookupUFM (hsc_HPT hsc_env) mod_name
572 breaks = getModBreaks hmi
573 index = breakInfo_number info
574 vars = breakInfo_vars info
575 result_ty = breakInfo_resty info
576 occs = modBreaks_vars breaks ! index
577 span = modBreaks_locs breaks ! index
578
579 -- filter out any unboxed ids; we can't bind these at the prompt
580 let pointers = filter (\(id,_) -> isPointer id) vars
581 isPointer id | PtrRep <- idPrimRep id = True
582 | otherwise = False
583
584 let (ids, offsets) = unzip pointers
585
586 -- It might be that getIdValFromApStack fails, because the AP_STACK
587 -- has been accidentally evaluated, or something else has gone wrong.
588 -- So that we don't fall over in a heap when this happens, just don't
589 -- bind any free variables instead, and we emit a warning.
590 mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
591 let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
592 when (any isNothing mb_hValues) $
593 debugTraceMsg (hsc_dflags hsc_env) 1 $
594 text "Warning: _result has been evaluated, some bindings have been lost"
595
596 new_ids <- zipWithM mkNewId occs filtered_ids
597 let names = map idName new_ids
598
599 -- make an Id for _result. We use the Unique of the FastString "_result";
600 -- we don't care about uniqueness here, because there will only be one
601 -- _result in scope at any time.
602 let result_name = mkInternalName (getUnique result_fs)
603 (mkVarOccFS result_fs) span
604 result_id = Id.mkVanillaGlobal result_name result_ty
605
606 -- for each Id we're about to bind in the local envt:
607 -- - skolemise the type variables in its type, so they can't
608 -- be randomly unified with other types. These type variables
609 -- can only be resolved by type reconstruction in RtClosureInspect
610 -- - tidy the type variables
611 -- - globalise the Id (Ids are supposed to be Global, apparently).
612 --
613 let result_ok = isPointer result_id
614 && not (isUnboxedTupleType (idType result_id))
615
616 all_ids | result_ok = result_id : new_ids
617 | otherwise = new_ids
618 (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
619 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
620 new_tyvars = unionVarSets tyvarss
621 final_ids = zipWith setIdType all_ids tidy_tys
622 ictxt0 = hsc_IC hsc_env
623 ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
624
625 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
626 when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
627 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
628 return (hsc_env1, if result_ok then result_name:names else names, span)
629 where
630 mkNewId :: OccName -> Id -> IO Id
631 mkNewId occ id = do
632 us <- mkSplitUniqSupply 'I'
633 -- we need a fresh Unique for each Id we bind, because the linker
634 -- state is single-threaded and otherwise we'd spam old bindings
635 -- whenever we stop at a breakpoint. The InteractveContext is properly
636 -- saved/restored, but not the linker state. See #1743, test break026.
637 let
638 uniq = uniqFromSupply us
639 loc = nameSrcSpan (idName id)
640 name = mkInternalName uniq occ loc
641 ty = idType id
642 new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
643 return new_id
644
645 rttiEnvironment :: HscEnv -> IO HscEnv
646 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
647 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
648 incompletelyTypedIds =
649 [id | id <- tmp_ids
650 , not $ noSkolems id
651 , (occNameFS.nameOccName.idName) id /= result_fs]
652 hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
653 return hsc_env'
654 where
655 noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
656 improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
657 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
658 Just id = find (\i -> idName i == name) tmp_ids
659 if noSkolems id
660 then return hsc_env
661 else do
662 mb_new_ty <- reconstructType hsc_env 10 id
663 let old_ty = idType id
664 case mb_new_ty of
665 Nothing -> return hsc_env
666 Just new_ty -> do
667 mb_subst <- improveRTTIType hsc_env old_ty new_ty
668 case mb_subst of
669 Nothing -> return $
670 WARN(True, text (":print failed to calculate the "
671 ++ "improvement for a type")) hsc_env
672 Just subst -> do
673 when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
674 printForUser stderr alwaysQualify $
675 fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
676
677 let (subst', skols) = skolemiseSubst subst
678 ic' = extendInteractiveContext
679 (substInteractiveContext ic subst') [] skols
680 return hsc_env{hsc_IC=ic'}
681
682 skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
683 skolemiseSubst subst = let
684 varenv = getTvSubstEnv subst
685 all_together = mapVarEnv skolemiseTy varenv
686 (varenv', skol_vars) = ( mapVarEnv fst all_together
687 , map snd (varEnvElts all_together))
688 in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
689
690
691 skolemiseTy :: Type -> (Type, TyVarSet)
692 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
693 where env = mkVarEnv (zip tyvars new_tyvar_tys)
694 subst = mkTvSubst emptyInScopeSet env
695 tyvars = varSetElems (tyVarsOfType ty)
696 new_tyvars = map skolemiseTyVar tyvars
697 new_tyvar_tys = map mkTyVarTy new_tyvars
698
699 skolemiseTyVar :: TyVar -> TyVar
700 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
701 (SkolemTv RuntimeUnkSkol)
702
703 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
704 getIdValFromApStack apStack (I# stackDepth) = do
705 case getApStackVal# apStack (stackDepth +# 1#) of
706 -- The +1 is magic! I don't know where it comes
707 -- from, but this makes things line up. --SDM
708 (# ok, result #) ->
709 case ok of
710 0# -> return Nothing -- AP_STACK not found
711 _ -> return (Just (unsafeCoerce# result))
712
713 pushResume :: HscEnv -> Resume -> HscEnv
714 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
715 where
716 ictxt0 = hsc_IC hsc_env
717 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
718
719 -- -----------------------------------------------------------------------------
720 -- Abandoning a resume context
721
722 abandon :: GhcMonad m => m Bool
723 abandon = do
724 hsc_env <- getSession
725 let ic = hsc_IC hsc_env
726 resume = ic_resume ic
727 case resume of
728 [] -> return False
729 r:rs -> do
730 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
731 liftIO $ abandon_ r
732 return True
733
734 abandonAll :: GhcMonad m => m Bool
735 abandonAll = do
736 hsc_env <- getSession
737 let ic = hsc_IC hsc_env
738 resume = ic_resume ic
739 case resume of
740 [] -> return False
741 rs -> do
742 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
743 liftIO $ mapM_ abandon_ rs
744 return True
745
746 -- when abandoning a computation we have to
747 -- (a) kill the thread with an async exception, so that the
748 -- computation itself is stopped, and
749 -- (b) fill in the MVar. This step is necessary because any
750 -- thunks that were under evaluation will now be updated
751 -- with the partial computation, which still ends in takeMVar,
752 -- so any attempt to evaluate one of these thunks will block
753 -- unless we fill in the MVar.
754 -- See test break010.
755 abandon_ :: Resume -> IO ()
756 abandon_ r = do
757 killThread (resumeThreadId r)
758 putMVar (resumeBreakMVar r) ()
759
760 -- -----------------------------------------------------------------------------
761 -- Bounded list, optimised for repeated cons
762
763 data BoundedList a = BL
764 {-# UNPACK #-} !Int -- length
765 {-# UNPACK #-} !Int -- bound
766 [a] -- left
767 [a] -- right, list is (left ++ reverse right)
768
769 nilBL :: Int -> BoundedList a
770 nilBL bound = BL 0 bound [] []
771
772 consBL :: a -> BoundedList a -> BoundedList a
773 consBL a (BL len bound left right)
774 | len < bound = BL (len+1) bound (a:left) right
775 | null right = BL len bound [a] $! tail (reverse left)
776 | otherwise = BL len bound (a:left) $! tail right
777
778 toListBL :: BoundedList a -> [a]
779 toListBL (BL _ _ left right) = left ++ reverse right
780
781 fromListBL :: Int -> [a] -> BoundedList a
782 fromListBL bound l = BL (length l) bound l []
783
784 -- lenBL (BL len _ _ _) = len
785
786 -- -----------------------------------------------------------------------------
787 -- | Set the interactive evaluation context.
788 --
789 -- Setting the context doesn't throw away any bindings; the bindings
790 -- we've built up in the InteractiveContext simply move to the new
791 -- module. They always shadow anything in scope in the current context.
792 setContext :: GhcMonad m =>
793 [Module] -- ^ entire top level scope of these modules
794 -> [Module] -- ^ exports only of these modules
795 -> m ()
796 setContext toplev_mods export_mods = do
797 hsc_env <- getSession
798 let old_ic = hsc_IC hsc_env
799 hpt = hsc_HPT hsc_env
800 --
801 export_env <- liftIO $ mkExportEnv hsc_env export_mods
802 toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
803 let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
804 modifySession $ \_ ->
805 hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
806 ic_exports = export_mods,
807 ic_rn_gbl_env = all_env }}
808
809 -- Make a GlobalRdrEnv based on the exports of the modules only.
810 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
811 mkExportEnv hsc_env mods
812 = do { stuff <- mapM (getModuleExports hsc_env) mods
813 ; let (_msgs, mb_name_sets) = unzip stuff
814 envs = [ availsToGlobalRdrEnv (moduleName mod) avails
815 | (Just avails, mod) <- zip mb_name_sets mods ]
816 ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }
817
818 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
819 availsToGlobalRdrEnv mod_name avails
820 = mkGlobalRdrEnv (gresFromAvails imp_prov avails)
821 where
822 -- We're building a GlobalRdrEnv as if the user imported
823 -- all the specified modules into the global interactive module
824 imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
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