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