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