Support for -fwarn-unused-do-bind and -fwarn-wrong-do-bind, as per #3263
[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 result_ok = isPointer result_id
613 && not (isUnboxedTupleType (idType result_id))
614
615 all_ids | result_ok = result_id : new_ids
616 | otherwise = new_ids
617 (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
618 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
619 new_tyvars = unionVarSets tyvarss
620 final_ids = zipWith setIdType all_ids tidy_tys
621 ictxt0 = hsc_IC hsc_env
622 ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
623
624 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
625 when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
626 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
627 return (hsc_env1, if result_ok then result_name:names else names, span)
628 where
629 mkNewId :: OccName -> Id -> IO Id
630 mkNewId occ id = do
631 us <- mkSplitUniqSupply 'I'
632 -- we need a fresh Unique for each Id we bind, because the linker
633 -- state is single-threaded and otherwise we'd spam old bindings
634 -- whenever we stop at a breakpoint. The InteractveContext is properly
635 -- saved/restored, but not the linker state. See #1743, test break026.
636 let
637 uniq = uniqFromSupply us
638 loc = nameSrcSpan (idName id)
639 name = mkInternalName uniq occ loc
640 ty = idType id
641 new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
642 return new_id
643
644 rttiEnvironment :: HscEnv -> IO HscEnv
645 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
646 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
647 incompletelyTypedIds =
648 [id | id <- tmp_ids
649 , not $ noSkolems id
650 , (occNameFS.nameOccName.idName) id /= result_fs]
651 hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
652 return hsc_env'
653 where
654 noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
655 improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
656 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
657 Just id = find (\i -> idName i == name) tmp_ids
658 if noSkolems id
659 then return hsc_env
660 else do
661 mb_new_ty <- reconstructType hsc_env 10 id
662 let old_ty = idType id
663 case mb_new_ty of
664 Nothing -> return hsc_env
665 Just new_ty -> do
666 mb_subst <- improveRTTIType hsc_env old_ty new_ty
667 case mb_subst of
668 Nothing -> return $
669 WARN(True, text (":print failed to calculate the "
670 ++ "improvement for a type")) hsc_env
671 Just subst -> do
672 when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
673 printForUser stderr alwaysQualify $
674 fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
675
676 let (subst', skols) = skolemiseSubst subst
677 ic' = extendInteractiveContext
678 (substInteractiveContext ic subst') [] skols
679 return hsc_env{hsc_IC=ic'}
680
681 skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
682 skolemiseSubst subst = let
683 varenv = getTvSubstEnv subst
684 all_together = mapVarEnv skolemiseTy varenv
685 (varenv', skol_vars) = ( mapVarEnv fst all_together
686 , map snd (varEnvElts all_together))
687 in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
688
689
690 skolemiseTy :: Type -> (Type, TyVarSet)
691 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
692 where env = mkVarEnv (zip tyvars new_tyvar_tys)
693 subst = mkTvSubst emptyInScopeSet env
694 tyvars = varSetElems (tyVarsOfType ty)
695 new_tyvars = map skolemiseTyVar tyvars
696 new_tyvar_tys = map mkTyVarTy new_tyvars
697
698 skolemiseTyVar :: TyVar -> TyVar
699 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
700 (SkolemTv RuntimeUnkSkol)
701
702 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
703 getIdValFromApStack apStack (I# stackDepth) = do
704 case getApStackVal# apStack (stackDepth +# 1#) of
705 -- The +1 is magic! I don't know where it comes
706 -- from, but this makes things line up. --SDM
707 (# ok, result #) ->
708 case ok of
709 0# -> return Nothing -- AP_STACK not found
710 _ -> return (Just (unsafeCoerce# result))
711
712 pushResume :: HscEnv -> Resume -> HscEnv
713 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
714 where
715 ictxt0 = hsc_IC hsc_env
716 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
717
718 -- -----------------------------------------------------------------------------
719 -- Abandoning a resume context
720
721 abandon :: GhcMonad m => m Bool
722 abandon = do
723 hsc_env <- getSession
724 let ic = hsc_IC hsc_env
725 resume = ic_resume ic
726 case resume of
727 [] -> return False
728 r:rs -> do
729 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
730 liftIO $ abandon_ r
731 return True
732
733 abandonAll :: GhcMonad m => m Bool
734 abandonAll = do
735 hsc_env <- getSession
736 let ic = hsc_IC hsc_env
737 resume = ic_resume ic
738 case resume of
739 [] -> return False
740 rs -> do
741 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
742 liftIO $ mapM_ abandon_ rs
743 return True
744
745 -- when abandoning a computation we have to
746 -- (a) kill the thread with an async exception, so that the
747 -- computation itself is stopped, and
748 -- (b) fill in the MVar. This step is necessary because any
749 -- thunks that were under evaluation will now be updated
750 -- with the partial computation, which still ends in takeMVar,
751 -- so any attempt to evaluate one of these thunks will block
752 -- unless we fill in the MVar.
753 -- See test break010.
754 abandon_ :: Resume -> IO ()
755 abandon_ r = do
756 killThread (resumeThreadId r)
757 putMVar (resumeBreakMVar r) ()
758
759 -- -----------------------------------------------------------------------------
760 -- Bounded list, optimised for repeated cons
761
762 data BoundedList a = BL
763 {-# UNPACK #-} !Int -- length
764 {-# UNPACK #-} !Int -- bound
765 [a] -- left
766 [a] -- right, list is (left ++ reverse right)
767
768 nilBL :: Int -> BoundedList a
769 nilBL bound = BL 0 bound [] []
770
771 consBL :: a -> BoundedList a -> BoundedList a
772 consBL a (BL len bound left right)
773 | len < bound = BL (len+1) bound (a:left) right
774 | null right = BL len bound [a] $! tail (reverse left)
775 | otherwise = BL len bound (a:left) $! tail right
776
777 toListBL :: BoundedList a -> [a]
778 toListBL (BL _ _ left right) = left ++ reverse right
779
780 fromListBL :: Int -> [a] -> BoundedList a
781 fromListBL bound l = BL (length l) bound l []
782
783 -- lenBL (BL len _ _ _) = len
784
785 -- -----------------------------------------------------------------------------
786 -- | Set the interactive evaluation context.
787 --
788 -- Setting the context doesn't throw away any bindings; the bindings
789 -- we've built up in the InteractiveContext simply move to the new
790 -- module. They always shadow anything in scope in the current context.
791 setContext :: GhcMonad m =>
792 [Module] -- ^ entire top level scope of these modules
793 -> [Module] -- ^ exports only of these modules
794 -> m ()
795 setContext toplev_mods export_mods = do
796 hsc_env <- getSession
797 let old_ic = hsc_IC hsc_env
798 hpt = hsc_HPT hsc_env
799 --
800 export_env <- liftIO $ mkExportEnv hsc_env export_mods
801 toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
802 let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
803 modifySession $ \_ ->
804 hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
805 ic_exports = export_mods,
806 ic_rn_gbl_env = all_env }}
807
808 -- Make a GlobalRdrEnv based on the exports of the modules only.
809 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
810 mkExportEnv hsc_env mods = do
811 stuff <- mapM (getModuleExports hsc_env) mods
812 let
813 (_msgs, mb_name_sets) = unzip stuff
814 gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
815 | (Just avails, mod) <- zip mb_name_sets mods ]
816 --
817 return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
818
819 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
820 nameSetToGlobalRdrEnv names mod =
821 mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
822 | name <- nameSetToList names ]
823
824 vanillaProv :: ModuleName -> Provenance
825 -- We're building a GlobalRdrEnv as if the user imported
826 -- all the specified modules into the global interactive module
827 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
828 where
829 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
830 is_qual = False,
831 is_dloc = srcLocSpan interactiveSrcLoc }
832
833 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
834 mkTopLevEnv hpt modl
835 = case lookupUFM hpt (moduleName modl) of
836 Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
837 showSDoc (ppr modl)))
838 Just details ->
839 case mi_globals (hm_iface details) of
840 Nothing ->
841 ghcError (ProgramError ("mkTopLevEnv: not interpreted "
842 ++ showSDoc (ppr modl)))
843 Just env -> return env
844
845 -- | Get the interactive evaluation context, consisting of a pair of the
846 -- set of modules from which we take the full top-level scope, and the set
847 -- of modules from which we take just the exports respectively.
848 getContext :: GhcMonad m => m ([Module],[Module])
849 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
850 return (ic_toplev_scope ic, ic_exports ic)
851
852 -- | Returns @True@ if the specified module is interpreted, and hence has
853 -- its full top-level scope available.
854 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
855 moduleIsInterpreted modl = withSession $ \h ->
856 if modulePackageId modl /= thisPackage (hsc_dflags h)
857 then return False
858 else case lookupUFM (hsc_HPT h) (moduleName modl) of
859 Just details -> return (isJust (mi_globals (hm_iface details)))
860 _not_a_home_module -> return False
861
862 -- | Looks up an identifier in the current interactive context (for :info)
863 -- Filter the instances by the ones whose tycons (or clases resp)
864 -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
865 -- The exact choice of which ones to show, and which to hide, is a judgement call.
866 -- (see Trac #1581)
867 getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
868 getInfo name
869 = withSession $ \hsc_env ->
870 do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
871 case mb_stuff of
872 Nothing -> return Nothing
873 Just (thing, fixity, ispecs) -> do
874 let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
875 return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
876 where
877 plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env
878 = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
879 where -- A name is ok if it's in the rdr_env,
880 -- whether qualified or not
881 ok n | n == name = True -- The one we looked for in the first place!
882 | isBuiltInSyntax n = True
883 | isExternalName n = any ((== n) . gre_name)
884 (lookupGRE_Name rdr_env n)
885 | otherwise = True
886
887 -- | Returns all names in scope in the current interactive context
888 getNamesInScope :: GhcMonad m => m [Name]
889 getNamesInScope = withSession $ \hsc_env -> do
890 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
891
892 getRdrNamesInScope :: GhcMonad m => m [RdrName]
893 getRdrNamesInScope = withSession $ \hsc_env -> do
894 let
895 ic = hsc_IC hsc_env
896 gbl_rdrenv = ic_rn_gbl_env ic
897 ids = ic_tmp_ids ic
898 gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
899 lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
900 --
901 return (gbl_names ++ lcl_names)
902
903
904 -- ToDo: move to RdrName
905 greToRdrNames :: GlobalRdrElt -> [RdrName]
906 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
907 = case prov of
908 LocalDef -> [unqual]
909 Imported specs -> concat (map do_spec (map is_decl specs))
910 where
911 occ = nameOccName name
912 unqual = Unqual occ
913 do_spec decl_spec
914 | is_qual decl_spec = [qual]
915 | otherwise = [unqual,qual]
916 where qual = Qual (is_as decl_spec) occ
917
918 -- | Parses a string as an identifier, and returns the list of 'Name's that
919 -- the identifier can refer to in the current interactive context.
920 parseName :: GhcMonad m => String -> m [Name]
921 parseName str = withSession $ \hsc_env -> do
922 (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
923 ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
924
925 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
926 -- entity known to GHC, including 'Name's defined using 'runStmt'.
927 lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
928 lookupName name = withSession $ \hsc_env -> do
929 mb_tything <- ioMsg $ tcRnLookupName hsc_env name
930 return mb_tything
931 -- XXX: calls panic in some circumstances; is that ok?
932
933 -- -----------------------------------------------------------------------------
934 -- Getting the type of an expression
935
936 -- | Get the type of an expression
937 exprType :: GhcMonad m => String -> m Type
938 exprType expr = withSession $ \hsc_env -> do
939 ty <- hscTcExpr hsc_env expr
940 return $ tidyType emptyTidyEnv ty
941
942 -- -----------------------------------------------------------------------------
943 -- Getting the kind of a type
944
945 -- | Get the kind of a type
946 typeKind :: GhcMonad m => String -> m Kind
947 typeKind str = withSession $ \hsc_env -> do
948 hscKcType hsc_env str
949
950 -----------------------------------------------------------------------------
951 -- cmCompileExpr: compile an expression and deliver an HValue
952
953 compileExpr :: GhcMonad m => String -> m HValue
954 compileExpr expr = withSession $ \hsc_env -> do
955 Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
956 -- Run it!
957 hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
958
959 case (ids,hvals) of
960 ([_],[hv]) -> return hv
961 _ -> panic "compileExpr"
962
963 -- -----------------------------------------------------------------------------
964 -- Compile an expression into a dynamic
965
966 dynCompileExpr :: GhcMonad m => String -> m Dynamic
967 dynCompileExpr expr = do
968 (full,exports) <- getContext
969 setContext full $
970 (mkModule
971 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
972 ):exports
973 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
974 Just (ids, hvals) <- withSession (flip hscStmt stmt)
975 setContext full exports
976 vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
977 case (ids,vals) of
978 (_:[], v:[]) -> return v
979 _ -> panic "dynCompileExpr"
980
981 -----------------------------------------------------------------------------
982 -- show a module and it's source/object filenames
983
984 showModule :: GhcMonad m => ModSummary -> m String
985 showModule mod_summary =
986 withSession $ \hsc_env -> do
987 interpreted <- isModuleInterpreted mod_summary
988 return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
989
990 isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
991 isModuleInterpreted mod_summary = withSession $ \hsc_env ->
992 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
993 Nothing -> panic "missing linkable"
994 Just mod_info -> return (not obj_linkable)
995 where
996 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
997
998 ----------------------------------------------------------------------------
999 -- RTTI primitives
1000
1001 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
1002 obtainTermFromVal hsc_env bound force ty x =
1003 cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
1004
1005 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
1006 obtainTermFromId hsc_env bound force id = do
1007 hv <- Linker.getHValue hsc_env (varName id)
1008 cvObtainTerm hsc_env bound force (idType id) hv
1009
1010 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
1011 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
1012 reconstructType hsc_env bound id = do
1013 hv <- Linker.getHValue hsc_env (varName id)
1014 cvReconstructType hsc_env bound (idType id) hv
1015
1016 #endif /* GHCI */
1017