driver: use PROGBITS type for .debug-ghc-link-info section
[ghc.git] / compiler / main / InteractiveEval.hs
1 {-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,
2 RecordWildCards #-}
3
4 -- -----------------------------------------------------------------------------
5 --
6 -- (c) The University of Glasgow, 2005-2007
7 --
8 -- Running statements interactively
9 --
10 -- -----------------------------------------------------------------------------
11
12 module InteractiveEval (
13 #ifdef GHCI
14 Status(..), Resume(..), History(..),
15 execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec,
16 runDecls, runDeclsWithLocation,
17 parseImportDecl, SingleStep(..),
18 resume,
19 abandon, abandonAll,
20 getResumeContext,
21 getHistorySpan,
22 getModBreaks,
23 getHistoryModule,
24 back, forward,
25 setContext, getContext,
26 availsToGlobalRdrEnv,
27 getNamesInScope,
28 getRdrNamesInScope,
29 moduleIsInterpreted,
30 getInfo,
31 exprType,
32 typeKind,
33 parseName,
34 showModule,
35 isModuleInterpreted,
36 parseExpr, compileParsedExpr,
37 compileExpr, dynCompileExpr,
38 Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
39 -- * Depcreated API (remove in GHC 7.14)
40 RunResult(..), runStmt, runStmtWithLocation,
41 #endif
42 ) where
43
44 #ifdef GHCI
45
46 #include "HsVersions.h"
47
48 import InteractiveEvalTypes
49
50 import GhcMonad
51 import HscMain
52 import HsSyn
53 import HscTypes
54 import BasicTypes ( HValue )
55 import InstEnv
56 import IfaceEnv ( newInteractiveBinder )
57 import FamInstEnv ( FamInst, orphNamesOfFamInst )
58 import TyCon
59 import Type hiding( typeKind )
60 import TcType hiding( typeKind )
61 import Var
62 import Id
63 import Name hiding ( varName )
64 import NameSet
65 import Avail
66 import RdrName
67 import VarSet
68 import VarEnv
69 import ByteCodeInstr
70 import Linker
71 import DynFlags
72 import Unique
73 import UniqSupply
74 import MonadUtils
75 import Module
76 import PrelNames ( toDynName )
77 import Panic
78 import UniqFM
79 import Maybes
80 import ErrUtils
81 import SrcLoc
82 import BreakArray
83 import RtClosureInspect
84 import Outputable
85 import FastString
86 import Bag
87
88 import System.Mem.Weak
89 import System.Directory
90 import Data.Dynamic
91 import Data.Either
92 import Data.List (find)
93 import Control.Monad
94 #if __GLASGOW_HASKELL__ >= 709
95 import Foreign
96 #else
97 import Foreign.Safe
98 #endif
99 import Foreign.C
100 import GHC.Exts
101 import Data.Array
102 import Exception
103 import Control.Concurrent
104 import System.IO.Unsafe
105 import GHC.Conc ( setAllocationCounter, getAllocationCounter )
106
107 -- -----------------------------------------------------------------------------
108 -- running a statement interactively
109
110 getResumeContext :: GhcMonad m => m [Resume]
111 getResumeContext = withSession (return . ic_resume . hsc_IC)
112
113 mkHistory :: HscEnv -> HValue -> BreakInfo -> History
114 mkHistory hsc_env hval bi = let
115 decls = findEnclosingDecls hsc_env bi
116 in History hval bi decls
117
118
119 getHistoryModule :: History -> Module
120 getHistoryModule = breakInfo_module . historyBreakInfo
121
122 getHistorySpan :: HscEnv -> History -> SrcSpan
123 getHistorySpan hsc_env hist =
124 let inf = historyBreakInfo hist
125 num = breakInfo_number inf
126 in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
127 Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
128 _ -> panic "getHistorySpan"
129
130 getModBreaks :: HomeModInfo -> ModBreaks
131 getModBreaks hmi
132 | Just linkable <- hm_linkable hmi,
133 [BCOs _ modBreaks] <- linkableUnlinked linkable
134 = modBreaks
135 | otherwise
136 = emptyModBreaks -- probably object code
137
138 {- | Finds the enclosing top level function name -}
139 -- ToDo: a better way to do this would be to keep hold of the decl_path computed
140 -- by the coverage pass, which gives the list of lexically-enclosing bindings
141 -- for each tick.
142 findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
143 findEnclosingDecls hsc_env inf =
144 let hmi = expectJust "findEnclosingDecls" $
145 lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf)
146 mb = getModBreaks hmi
147 in modBreaks_decls mb ! breakInfo_number inf
148
149 -- | Update fixity environment in the current interactive context.
150 updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
151 updateFixityEnv fix_env = do
152 hsc_env <- getSession
153 let ic = hsc_IC hsc_env
154 setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
155
156 -- -----------------------------------------------------------------------------
157 -- execStmt
158
159 -- | default ExecOptions
160 execOptions :: ExecOptions
161 execOptions = ExecOptions
162 { execSingleStep = RunToCompletion
163 , execSourceFile = "<interactive>"
164 , execLineNumber = 1
165 }
166
167 -- | Run a statement in the current interactive context.
168 execStmt
169 :: GhcMonad m
170 => String -- ^ a statement (bind or expression)
171 -> ExecOptions
172 -> m ExecResult
173 execStmt stmt ExecOptions{..} = do
174 hsc_env <- getSession
175
176 -- wait on this when we hit a breakpoint
177 breakMVar <- liftIO $ newEmptyMVar
178 -- wait on this when a computation is running
179 statusMVar <- liftIO $ newEmptyMVar
180
181 -- Turn off -fwarn-unused-local-binds when running a statement, to hide
182 -- warnings about the implicit bindings we introduce.
183 let ic = hsc_IC hsc_env -- use the interactive dflags
184 idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
185 hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }
186
187 -- compile to value (IO [HValue]), don't run
188 r <- liftIO $ hscStmtWithLocation hsc_env' stmt
189 execSourceFile execLineNumber
190
191 case r of
192 -- empty statement / comment
193 Nothing -> return (ExecComplete (Right []) 0)
194
195 Just (ids, hval, fix_env) -> do
196 updateFixityEnv fix_env
197
198 status <-
199 withVirtualCWD $
200 withBreakAction (isStep execSingleStep) idflags'
201 breakMVar statusMVar $ do
202 liftIO $ sandboxIO idflags' statusMVar hval
203
204 let ic = hsc_IC hsc_env
205 bindings = (ic_tythings ic, ic_rn_gbl_env ic)
206
207 size = ghciHistSize idflags'
208
209 handleRunStatus execSingleStep stmt bindings ids
210 breakMVar statusMVar status (emptyHistory size)
211
212 -- | The type returned by the deprecated 'runStmt' and
213 -- 'runStmtWithLocation' API
214 data RunResult
215 = RunOk [Name] -- ^ names bound by this evaluation
216 | RunException SomeException -- ^ statement raised an exception
217 | RunBreak ThreadId [Name] (Maybe BreakInfo)
218
219 -- | Conver the old result type to the new result type
220 execResultToRunResult :: ExecResult -> RunResult
221 execResultToRunResult r =
222 case r of
223 ExecComplete{ execResult = Left ex } -> RunException ex
224 ExecComplete{ execResult = Right names } -> RunOk names
225 ExecBreak{..} -> RunBreak breakThreadId breakNames breakInfo
226
227 -- Remove in GHC 7.14
228 {-# DEPRECATED runStmt "use execStmt" #-}
229 -- | Run a statement in the current interactive context. Statement
230 -- may bind multple values.
231 runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
232 runStmt stmt step =
233 execResultToRunResult <$> execStmt stmt execOptions { execSingleStep = step }
234
235 -- Remove in GHC 7.14
236 {-# DEPRECATED runStmtWithLocation "use execStmtWithLocation" #-}
237 runStmtWithLocation :: GhcMonad m => String -> Int ->
238 String -> SingleStep -> m RunResult
239 runStmtWithLocation source linenumber expr step = do
240 execResultToRunResult <$>
241 execStmt expr execOptions { execSingleStep = step
242 , execSourceFile = source
243 , execLineNumber = linenumber }
244
245 runDecls :: GhcMonad m => String -> m [Name]
246 runDecls = runDeclsWithLocation "<interactive>" 1
247
248 runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
249 runDeclsWithLocation source linenumber expr =
250 do
251 hsc_env <- getSession
252 (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber
253
254 setSession $ hsc_env { hsc_IC = ic }
255 hsc_env <- getSession
256 hsc_env' <- liftIO $ rttiEnvironment hsc_env
257 modifySession (\_ -> hsc_env')
258 return (map getName tyThings)
259
260
261 withVirtualCWD :: GhcMonad m => m a -> m a
262 withVirtualCWD m = do
263 hsc_env <- getSession
264 let ic = hsc_IC hsc_env
265
266 let set_cwd = do
267 dir <- liftIO $ getCurrentDirectory
268 case ic_cwd ic of
269 Just dir -> liftIO $ setCurrentDirectory dir
270 Nothing -> return ()
271 return dir
272
273 reset_cwd orig_dir = do
274 virt_dir <- liftIO $ getCurrentDirectory
275 hsc_env <- getSession
276 let old_IC = hsc_IC hsc_env
277 setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
278 liftIO $ setCurrentDirectory orig_dir
279
280 gbracket set_cwd reset_cwd $ \_ -> m
281
282 parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
283 parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
284
285 emptyHistory :: Int -> BoundedList History
286 emptyHistory size = nilBL size
287
288 handleRunStatus :: GhcMonad m
289 => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
290 -> MVar () -> MVar Status -> Status -> BoundedList History
291 -> m ExecResult
292
293 handleRunStatus step expr bindings final_ids
294 breakMVar statusMVar status history
295 | RunAndLogSteps <- step = tracing
296 | otherwise = not_tracing
297 where
298 tracing
299 | Break is_exception apStack info tid <- status
300 , not is_exception
301 = do
302 hsc_env <- getSession
303 b <- liftIO $ isBreakEnabled hsc_env info
304 if b
305 then not_tracing
306 -- This breakpoint is explicitly enabled; we want to stop
307 -- instead of just logging it.
308 else do
309 let history' = mkHistory hsc_env apStack info `consBL` history
310 -- probably better make history strict here, otherwise
311 -- our BoundedList will be pointless.
312 _ <- liftIO $ evaluate history'
313 status <- withBreakAction True (hsc_dflags hsc_env)
314 breakMVar statusMVar $ do
315 liftIO $ mask_ $ do
316 putMVar breakMVar () -- awaken the stopped thread
317 redirectInterrupts tid $
318 takeMVar statusMVar -- and wait for the result
319 handleRunStatus RunAndLogSteps expr bindings final_ids
320 breakMVar statusMVar status history'
321 | otherwise
322 = not_tracing
323
324 not_tracing
325 -- Hit a breakpoint
326 | Break is_exception apStack info tid <- status
327 = do
328 hsc_env <- getSession
329 let mb_info | is_exception = Nothing
330 | otherwise = Just info
331 (hsc_env1, names, span) <- liftIO $
332 bindLocalsAtBreakpoint hsc_env apStack mb_info
333 let
334 resume = Resume
335 { resumeStmt = expr, resumeThreadId = tid
336 , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
337 , resumeBindings = bindings, resumeFinalIds = final_ids
338 , resumeApStack = apStack, resumeBreakInfo = mb_info
339 , resumeSpan = span, resumeHistory = toListBL history
340 , resumeHistoryIx = 0 }
341 hsc_env2 = pushResume hsc_env1 resume
342
343 modifySession (\_ -> hsc_env2)
344 return (ExecBreak tid names mb_info)
345
346 -- Completed with an exception
347 | Complete (Left e) alloc <- status
348 = return (ExecComplete (Left e) alloc)
349
350 -- Completed successfully
351 | Complete (Right hvals) allocs <- status
352 = do hsc_env <- getSession
353 let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
354 final_names = map getName final_ids
355 liftIO $ Linker.extendLinkEnv (zip final_names hvals)
356 hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
357 modifySession (\_ -> hsc_env')
358 return (ExecComplete (Right final_names) allocs)
359
360 | otherwise
361 = panic "handleRunStatus" -- The above cases are in fact exhaustive
362
363 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
364 isBreakEnabled hsc_env inf =
365 case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
366 Just hmi -> do
367 w <- getBreak (hsc_dflags hsc_env)
368 (modBreaks_flags (getModBreaks hmi))
369 (breakInfo_number inf)
370 case w of Just n -> return (n /= 0); _other -> return False
371 _ ->
372 return False
373
374
375 foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
376 foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
377
378 setStepFlag :: IO ()
379 setStepFlag = poke stepFlag 1
380 resetStepFlag :: IO ()
381 resetStepFlag = poke stepFlag 0
382
383 -- this points to the IO action that is executed when a breakpoint is hit
384 foreign import ccall "&rts_breakpoint_io_action"
385 breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
386
387 -- When running a computation, we redirect ^C exceptions to the running
388 -- thread. ToDo: we might want a way to continue even if the target
389 -- thread doesn't die when it receives the exception... "this thread
390 -- is not responding".
391 --
392 -- Careful here: there may be ^C exceptions flying around, so we start the new
393 -- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
394 -- only while we execute the user's code. We can't afford to lose the final
395 -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
396 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
397 sandboxIO dflags statusMVar thing =
398 mask $ \restore -> -- fork starts blocked
399 let runIt =
400 liftM (uncurry Complete) $
401 measureAlloc $
402 try $ restore $ rethrow dflags $ thing
403 in if gopt Opt_GhciSandbox dflags
404 then do tid <- forkIO $ do res <- runIt
405 putMVar statusMVar res -- empty: can't block
406 redirectInterrupts tid $
407 takeMVar statusMVar
408
409 else -- GLUT on OS X needs to run on the main thread. If you
410 -- try to use it from another thread then you just get a
411 -- white rectangle rendered. For this, or anything else
412 -- with such restrictions, you can turn the GHCi sandbox off
413 -- and things will be run in the main thread.
414 --
415 -- BUT, note that the debugging features (breakpoints,
416 -- tracing, etc.) need the expression to be running in a
417 -- separate thread, so debugging is only enabled when
418 -- using the sandbox.
419 runIt
420
421 --
422 -- While we're waiting for the sandbox thread to return a result, if
423 -- the current thread receives an asynchronous exception we re-throw
424 -- it at the sandbox thread and continue to wait.
425 --
426 -- This is for two reasons:
427 --
428 -- * So that ^C interrupts runStmt (e.g. in GHCi), allowing the
429 -- computation to run its exception handlers before returning the
430 -- exception result to the caller of runStmt.
431 --
432 -- * clients of the GHC API can terminate a runStmt in progress
433 -- without knowing the ThreadId of the sandbox thread (#1381)
434 --
435 -- NB. use a weak pointer to the thread, so that the thread can still
436 -- be considered deadlocked by the RTS and sent a BlockedIndefinitely
437 -- exception. A symptom of getting this wrong is that conc033(ghci)
438 -- will hang.
439 --
440 redirectInterrupts :: ThreadId -> IO a -> IO a
441 redirectInterrupts target wait
442 = do wtid <- mkWeakThreadId target
443 wait `catch` \e -> do
444 m <- deRefWeak wtid
445 case m of
446 Nothing -> wait
447 Just target -> do throwTo target (e :: SomeException); wait
448
449 measureAlloc :: IO a -> IO (a,Word64)
450 measureAlloc io = do
451 setAllocationCounter maxBound
452 a <- io
453 allocs <- getAllocationCounter
454 return (a, fromIntegral (maxBound::Int64) - fromIntegral allocs)
455
456 -- We want to turn ^C into a break when -fbreak-on-exception is on,
457 -- but it's an async exception and we only break for sync exceptions.
458 -- Idea: if we catch and re-throw it, then the re-throw will trigger
459 -- a break. Great - but we don't want to re-throw all exceptions, because
460 -- then we'll get a double break for ordinary sync exceptions (you'd have
461 -- to :continue twice, which looks strange). So if the exception is
462 -- not "Interrupted", we unset the exception flag before throwing.
463 --
464 rethrow :: DynFlags -> IO a -> IO a
465 rethrow dflags io = Exception.catch io $ \se -> do
466 -- If -fbreak-on-error, we break unconditionally,
467 -- but with care of not breaking twice
468 if gopt Opt_BreakOnError dflags &&
469 not (gopt Opt_BreakOnException dflags)
470 then poke exceptionFlag 1
471 else case fromException se of
472 -- If it is a "UserInterrupt" exception, we allow
473 -- a possible break by way of -fbreak-on-exception
474 Just UserInterrupt -> return ()
475 -- In any other case, we don't want to break
476 _ -> poke exceptionFlag 0
477
478 Exception.throwIO se
479
480 -- This function sets up the interpreter for catching breakpoints, and
481 -- resets everything when the computation has stopped running. This
482 -- is a not-very-good way to ensure that only the interactive
483 -- evaluation should generate breakpoints.
484 withBreakAction :: (ExceptionMonad m) =>
485 Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
486 withBreakAction step dflags breakMVar statusMVar act
487 = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
488 where
489 setBreakAction = do
490 stablePtr <- newStablePtr onBreak
491 poke breakPointIOAction stablePtr
492 when (gopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
493 when step $ setStepFlag
494 return stablePtr
495 -- Breaking on exceptions is not enabled by default, since it
496 -- might be a bit surprising. The exception flag is turned off
497 -- as soon as it is hit, or in resetBreakAction below.
498
499 onBreak is_exception info apStack = do
500 tid <- myThreadId
501 putMVar statusMVar (Break is_exception apStack info tid)
502 takeMVar breakMVar
503
504 resetBreakAction stablePtr = do
505 poke breakPointIOAction noBreakStablePtr
506 poke exceptionFlag 0
507 resetStepFlag
508 freeStablePtr stablePtr
509
510 noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
511 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
512
513 noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
514 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
515 noBreakAction True _ _ = return () -- exception: just continue
516
517 resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
518 resume canLogSpan step = execResultToRunResult <$> resumeExec canLogSpan step
519
520 resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
521 resumeExec canLogSpan step
522 = do
523 hsc_env <- getSession
524 let ic = hsc_IC hsc_env
525 resume = ic_resume ic
526
527 case resume of
528 [] -> liftIO $
529 throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
530 (r:rs) -> do
531 -- unbind the temporary locals by restoring the TypeEnv from
532 -- before the breakpoint, and drop this Resume from the
533 -- InteractiveContext.
534 let (resume_tmp_te,resume_rdr_env) = resumeBindings r
535 ic' = ic { ic_tythings = resume_tmp_te,
536 ic_rn_gbl_env = resume_rdr_env,
537 ic_resume = rs }
538 modifySession (\_ -> hsc_env{ hsc_IC = ic' })
539
540 -- remove any bindings created since the breakpoint from the
541 -- linker's environment
542 let new_names = map getName (filter (`notElem` resume_tmp_te)
543 (ic_tythings ic))
544 liftIO $ Linker.deleteFromLinkEnv new_names
545
546 when (isStep step) $ liftIO setStepFlag
547 case r of
548 Resume { resumeStmt = expr, resumeThreadId = tid
549 , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
550 , resumeBindings = bindings, resumeFinalIds = final_ids
551 , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
552 , resumeHistory = hist } -> do
553 withVirtualCWD $ do
554 withBreakAction (isStep step) (hsc_dflags hsc_env)
555 breakMVar statusMVar $ do
556 status <- liftIO $ mask_ $ do
557 putMVar breakMVar ()
558 -- this awakens the stopped thread...
559 redirectInterrupts tid $
560 takeMVar statusMVar
561 -- and wait for the result
562 let prevHistoryLst = fromListBL 50 hist
563 hist' = case info of
564 Nothing -> prevHistoryLst
565 Just i
566 | not $canLogSpan span -> prevHistoryLst
567 | otherwise -> mkHistory hsc_env apStack i `consBL`
568 fromListBL 50 hist
569 handleRunStatus step expr bindings final_ids
570 breakMVar statusMVar status hist'
571
572 back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
573 back n = moveHist (+n)
574
575 forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
576 forward n = moveHist (subtract n)
577
578 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
579 moveHist fn = do
580 hsc_env <- getSession
581 case ic_resume (hsc_IC hsc_env) of
582 [] -> liftIO $
583 throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
584 (r:rs) -> do
585 let ix = resumeHistoryIx r
586 history = resumeHistory r
587 new_ix = fn ix
588 --
589 when (new_ix > length history) $ liftIO $
590 throwGhcExceptionIO (ProgramError "no more logged breakpoints")
591 when (new_ix < 0) $ liftIO $
592 throwGhcExceptionIO (ProgramError "already at the beginning of the history")
593
594 let
595 update_ic apStack mb_info = do
596 (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
597 apStack mb_info
598 let ic = hsc_IC hsc_env1
599 r' = r { resumeHistoryIx = new_ix }
600 ic' = ic { ic_resume = r':rs }
601
602 modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
603
604 return (names, new_ix, span)
605
606 -- careful: we want apStack to be the AP_STACK itself, not a thunk
607 -- around it, hence the cases are carefully constructed below to
608 -- make this the case. ToDo: this is v. fragile, do something better.
609 if new_ix == 0
610 then case r of
611 Resume { resumeApStack = apStack,
612 resumeBreakInfo = mb_info } ->
613 update_ic apStack mb_info
614 else case history !! (new_ix - 1) of
615 History apStack info _ ->
616 update_ic apStack (Just info)
617
618 -- -----------------------------------------------------------------------------
619 -- After stopping at a breakpoint, add free variables to the environment
620 result_fs :: FastString
621 result_fs = fsLit "_result"
622
623 bindLocalsAtBreakpoint
624 :: HscEnv
625 -> HValue
626 -> Maybe BreakInfo
627 -> IO (HscEnv, [Name], SrcSpan)
628
629 -- Nothing case: we stopped when an exception was raised, not at a
630 -- breakpoint. We have no location information or local variables to
631 -- bind, all we can do is bind a local variable to the exception
632 -- value.
633 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
634 let exn_occ = mkVarOccFS (fsLit "_exception")
635 span = mkGeneralSrcSpan (fsLit "<exception thrown>")
636 exn_name <- newInteractiveBinder hsc_env exn_occ span
637
638 let e_fs = fsLit "e"
639 e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
640 e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
641 exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
642
643 ictxt0 = hsc_IC hsc_env
644 ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
645
646 --
647 Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
648 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
649
650 -- Just case: we stopped at a breakpoint, we have information about the location
651 -- of the breakpoint and the free variables of the expression.
652 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
653
654 let
655 mod_name = moduleName (breakInfo_module info)
656 hmi = expectJust "bindLocalsAtBreakpoint" $
657 lookupUFM (hsc_HPT hsc_env) mod_name
658 breaks = getModBreaks hmi
659 index = breakInfo_number info
660 vars = breakInfo_vars info
661 result_ty = breakInfo_resty info
662 occs = modBreaks_vars breaks ! index
663 span = modBreaks_locs breaks ! index
664
665 -- Filter out any unboxed ids;
666 -- we can't bind these at the prompt
667 pointers = filter (\(id,_) -> isPointer id) vars
668 isPointer id | UnaryRep ty <- repType (idType id)
669 , PtrRep <- typePrimRep ty = True
670 | otherwise = False
671
672 (ids, offsets) = unzip pointers
673
674 free_tvs = mapUnionVarSet (tyVarsOfType . idType) ids
675 `unionVarSet` tyVarsOfType result_ty
676
677 -- It might be that getIdValFromApStack fails, because the AP_STACK
678 -- has been accidentally evaluated, or something else has gone wrong.
679 -- So that we don't fall over in a heap when this happens, just don't
680 -- bind any free variables instead, and we emit a warning.
681 mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
682 when (any isNothing mb_hValues) $
683 debugTraceMsg (hsc_dflags hsc_env) 1 $
684 text "Warning: _result has been evaluated, some bindings have been lost"
685
686
687 us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time
688 let tv_subst = newTyVars us free_tvs
689 filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
690 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
691 map (substTy tv_subst . idType) filtered_ids
692
693 new_ids <- zipWith3M mkNewId occs tidy_tys filtered_ids
694 result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
695
696 let result_id = Id.mkVanillaGlobal result_name (substTy tv_subst result_ty)
697 result_ok = isPointer result_id
698
699 final_ids | result_ok = result_id : new_ids
700 | otherwise = new_ids
701 ictxt0 = hsc_IC hsc_env
702 ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
703 names = map idName new_ids
704
705 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
706 when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
707 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
708 return (hsc_env1, if result_ok then result_name:names else names, span)
709 where
710 -- We need a fresh Unique for each Id we bind, because the linker
711 -- state is single-threaded and otherwise we'd spam old bindings
712 -- whenever we stop at a breakpoint. The InteractveContext is properly
713 -- saved/restored, but not the linker state. See #1743, test break026.
714 mkNewId :: OccName -> Type -> Id -> IO Id
715 mkNewId occ ty old_id
716 = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
717 ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
718
719 newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst
720 -- Similarly, clone the type variables mentioned in the types
721 -- we have here, *and* make them all RuntimeUnk tyars
722 newTyVars us tvs
723 = mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
724 | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
725 , let name = setNameUnique (tyVarName tv) uniq ]
726
727 rttiEnvironment :: HscEnv -> IO HscEnv
728 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
729 let tmp_ids = [id | AnId id <- ic_tythings ic]
730 incompletelyTypedIds =
731 [id | id <- tmp_ids
732 , not $ noSkolems id
733 , (occNameFS.nameOccName.idName) id /= result_fs]
734 hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
735 return hsc_env'
736 where
737 noSkolems = isEmptyVarSet . tyVarsOfType . idType
738 improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
739 let tmp_ids = [id | AnId id <- ic_tythings ic]
740 Just id = find (\i -> idName i == name) tmp_ids
741 if noSkolems id
742 then return hsc_env
743 else do
744 mb_new_ty <- reconstructType hsc_env 10 id
745 let old_ty = idType id
746 case mb_new_ty of
747 Nothing -> return hsc_env
748 Just new_ty -> do
749 case improveRTTIType hsc_env old_ty new_ty of
750 Nothing -> return $
751 WARN(True, text (":print failed to calculate the "
752 ++ "improvement for a type")) hsc_env
753 Just subst -> do
754 let dflags = hsc_dflags hsc_env
755 when (dopt Opt_D_dump_rtti dflags) $
756 printInfoForUser dflags alwaysQualify $
757 fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
758
759 let ic' = substInteractiveContext ic subst
760 return hsc_env{hsc_IC=ic'}
761
762 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
763 getIdValFromApStack apStack (I# stackDepth) = do
764 case getApStackVal# apStack (stackDepth +# 1#) of
765 -- The +1 is magic! I don't know where it comes
766 -- from, but this makes things line up. --SDM
767 (# ok, result #) ->
768 case ok of
769 0# -> return Nothing -- AP_STACK not found
770 _ -> return (Just (unsafeCoerce# result))
771
772 pushResume :: HscEnv -> Resume -> HscEnv
773 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
774 where
775 ictxt0 = hsc_IC hsc_env
776 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
777
778 -- -----------------------------------------------------------------------------
779 -- Abandoning a resume context
780
781 abandon :: GhcMonad m => m Bool
782 abandon = do
783 hsc_env <- getSession
784 let ic = hsc_IC hsc_env
785 resume = ic_resume ic
786 case resume of
787 [] -> return False
788 r:rs -> do
789 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
790 liftIO $ abandon_ r
791 return True
792
793 abandonAll :: GhcMonad m => m Bool
794 abandonAll = do
795 hsc_env <- getSession
796 let ic = hsc_IC hsc_env
797 resume = ic_resume ic
798 case resume of
799 [] -> return False
800 rs -> do
801 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
802 liftIO $ mapM_ abandon_ rs
803 return True
804
805 -- when abandoning a computation we have to
806 -- (a) kill the thread with an async exception, so that the
807 -- computation itself is stopped, and
808 -- (b) fill in the MVar. This step is necessary because any
809 -- thunks that were under evaluation will now be updated
810 -- with the partial computation, which still ends in takeMVar,
811 -- so any attempt to evaluate one of these thunks will block
812 -- unless we fill in the MVar.
813 -- (c) wait for the thread to terminate by taking its status MVar. This
814 -- step is necessary to prevent race conditions with
815 -- -fbreak-on-exception (see #5975).
816 -- See test break010.
817 abandon_ :: Resume -> IO ()
818 abandon_ r = do
819 killThread (resumeThreadId r)
820 putMVar (resumeBreakMVar r) ()
821 _ <- takeMVar (resumeStatMVar r)
822 return ()
823
824 -- -----------------------------------------------------------------------------
825 -- Bounded list, optimised for repeated cons
826
827 data BoundedList a = BL
828 {-# UNPACK #-} !Int -- length
829 {-# UNPACK #-} !Int -- bound
830 [a] -- left
831 [a] -- right, list is (left ++ reverse right)
832
833 nilBL :: Int -> BoundedList a
834 nilBL bound = BL 0 bound [] []
835
836 consBL :: a -> BoundedList a -> BoundedList a
837 consBL a (BL len bound left right)
838 | len < bound = BL (len+1) bound (a:left) right
839 | null right = BL len bound [a] $! tail (reverse left)
840 | otherwise = BL len bound (a:left) $! tail right
841
842 toListBL :: BoundedList a -> [a]
843 toListBL (BL _ _ left right) = left ++ reverse right
844
845 fromListBL :: Int -> [a] -> BoundedList a
846 fromListBL bound l = BL (length l) bound l []
847
848 -- lenBL (BL len _ _ _) = len
849
850 -- -----------------------------------------------------------------------------
851 -- | Set the interactive evaluation context.
852 --
853 -- (setContext imports) sets the ic_imports field (which in turn
854 -- determines what is in scope at the prompt) to 'imports', and
855 -- constructs the ic_rn_glb_env environment to reflect it.
856 --
857 -- We retain in scope all the things defined at the prompt, and kept
858 -- in ic_tythings. (Indeed, they shadow stuff from ic_imports.)
859
860 setContext :: GhcMonad m => [InteractiveImport] -> m ()
861 setContext imports
862 = do { hsc_env <- getSession
863 ; let dflags = hsc_dflags hsc_env
864 ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
865 ; case all_env_err of
866 Left (mod, err) ->
867 liftIO $ throwGhcExceptionIO (formatError dflags mod err)
868 Right all_env -> do {
869 ; let old_ic = hsc_IC hsc_env
870 final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
871 ; modifySession $ \_ ->
872 hsc_env{ hsc_IC = old_ic { ic_imports = imports
873 , ic_rn_gbl_env = final_rdr_env }}}}
874 where
875 formatError dflags mod err = ProgramError . showSDoc dflags $
876 text "Cannot add module" <+> ppr mod <+>
877 text "to context:" <+> text err
878
879 findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
880 -> IO (Either (ModuleName, String) GlobalRdrEnv)
881 -- Compute the GlobalRdrEnv for the interactive context
882 findGlobalRdrEnv hsc_env imports
883 = do { idecls_env <- hscRnImportDecls hsc_env idecls
884 -- This call also loads any orphan modules
885 ; return $ case partitionEithers (map mkEnv imods) of
886 ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
887 (err : _, _) -> Left err }
888 where
889 idecls :: [LImportDecl RdrName]
890 idecls = [noLoc d | IIDecl d <- imports]
891
892 imods :: [ModuleName]
893 imods = [m | IIModule m <- imports]
894
895 mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
896 Left err -> Left (mod, err)
897 Right env -> Right env
898
899 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
900 availsToGlobalRdrEnv mod_name avails
901 = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
902 where
903 -- We're building a GlobalRdrEnv as if the user imported
904 -- all the specified modules into the global interactive module
905 imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
906 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
907 is_qual = False,
908 is_dloc = srcLocSpan interactiveSrcLoc }
909
910 mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
911 mkTopLevEnv hpt modl
912 = case lookupUFM hpt modl of
913 Nothing -> Left "not a home module"
914 Just details ->
915 case mi_globals (hm_iface details) of
916 Nothing -> Left "not interpreted"
917 Just env -> Right env
918
919 -- | Get the interactive evaluation context, consisting of a pair of the
920 -- set of modules from which we take the full top-level scope, and the set
921 -- of modules from which we take just the exports respectively.
922 getContext :: GhcMonad m => m [InteractiveImport]
923 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
924 return (ic_imports ic)
925
926 -- | Returns @True@ if the specified module is interpreted, and hence has
927 -- its full top-level scope available.
928 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
929 moduleIsInterpreted modl = withSession $ \h ->
930 if moduleUnitId modl /= thisPackage (hsc_dflags h)
931 then return False
932 else case lookupUFM (hsc_HPT h) (moduleName modl) of
933 Just details -> return (isJust (mi_globals (hm_iface details)))
934 _not_a_home_module -> return False
935
936 -- | Looks up an identifier in the current interactive context (for :info)
937 -- Filter the instances by the ones whose tycons (or clases resp)
938 -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
939 -- The exact choice of which ones to show, and which to hide, is a judgement call.
940 -- (see Trac #1581)
941 getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))
942 getInfo allInfo name
943 = withSession $ \hsc_env ->
944 do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
945 case mb_stuff of
946 Nothing -> return Nothing
947 Just (thing, fixity, cls_insts, fam_insts) -> do
948 let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
949
950 -- Filter the instances based on whether the constituent names of their
951 -- instance heads are all in scope.
952 let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts
953 fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts
954 return (Just (thing, fixity, cls_insts', fam_insts'))
955 where
956 plausible rdr_env names
957 -- Dfun involving only names that are in ic_rn_glb_env
958 = allInfo
959 || all ok (nameSetElems names)
960 where -- A name is ok if it's in the rdr_env,
961 -- whether qualified or not
962 ok n | n == name = True -- The one we looked for in the first place!
963 | isBuiltInSyntax n = True
964 | isExternalName n = any ((== n) . gre_name)
965 (lookupGRE_Name rdr_env n)
966 | otherwise = True
967
968 -- | Returns all names in scope in the current interactive context
969 getNamesInScope :: GhcMonad m => m [Name]
970 getNamesInScope = withSession $ \hsc_env -> do
971 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
972
973 getRdrNamesInScope :: GhcMonad m => m [RdrName]
974 getRdrNamesInScope = withSession $ \hsc_env -> do
975 let
976 ic = hsc_IC hsc_env
977 gbl_rdrenv = ic_rn_gbl_env ic
978 gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv
979 return gbl_names
980
981
982 -- | Parses a string as an identifier, and returns the list of 'Name's that
983 -- the identifier can refer to in the current interactive context.
984 parseName :: GhcMonad m => String -> m [Name]
985 parseName str = withSession $ \hsc_env -> liftIO $
986 do { lrdr_name <- hscParseIdentifier hsc_env str
987 ; hscTcRnLookupRdrName hsc_env lrdr_name }
988
989 -- -----------------------------------------------------------------------------
990 -- Getting the type of an expression
991
992 -- | Get the type of an expression
993 -- Returns its most general type
994 exprType :: GhcMonad m => String -> m Type
995 exprType expr = withSession $ \hsc_env -> do
996 ty <- liftIO $ hscTcExpr hsc_env expr
997 return $ tidyType emptyTidyEnv ty
998
999 -- -----------------------------------------------------------------------------
1000 -- Getting the kind of a type
1001
1002 -- | Get the kind of a type
1003 typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind)
1004 typeKind normalise str = withSession $ \hsc_env -> do
1005 liftIO $ hscKcType hsc_env normalise str
1006
1007 -----------------------------------------------------------------------------
1008 -- Compile an expression, run it and deliver the result
1009
1010 -- | Parse an expression, the parsed expression can be further processed and
1011 -- passed to compileParsedExpr.
1012 parseExpr :: GhcMonad m => String -> m (LHsExpr RdrName)
1013 parseExpr expr = withSession $ \hsc_env -> do
1014 liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr
1015
1016 -- | Compile an expression, run it and deliver the resulting HValue.
1017 compileExpr :: GhcMonad m => String -> m HValue
1018 compileExpr expr = do
1019 parsed_expr <- parseExpr expr
1020 compileParsedExpr parsed_expr
1021
1022 -- | Compile an parsed expression (before renaming), run it and deliver
1023 -- the resulting HValue.
1024 compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue
1025 compileParsedExpr expr@(L loc _) = withSession $ \hsc_env -> do
1026 -- > let _compileParsedExpr = expr
1027 -- Create let stmt from expr to make hscParsedStmt happy.
1028 -- We will ignore the returned [Id], namely [expr_id], and not really
1029 -- create a new binding.
1030 let expr_fs = fsLit "_compileParsedExpr"
1031 expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
1032 let_stmt = L loc . LetStmt . HsValBinds $
1033 ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
1034
1035 Just (ids, hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
1036 updateFixityEnv fix_env
1037 hvals <- liftIO hvals_io
1038 case (ids, hvals) of
1039 ([_expr_id], [hval]) -> return hval
1040 _ -> panic "compileParsedExpr"
1041
1042 -- | Compile an expression, run it and return the result as a Dynamic.
1043 dynCompileExpr :: GhcMonad m => String -> m Dynamic
1044 dynCompileExpr expr = do
1045 parsed_expr <- parseExpr expr
1046 -- > Data.Dynamic.toDyn expr
1047 let loc = getLoc parsed_expr
1048 to_dyn_expr = mkHsApp (L loc . HsVar $ getRdrName toDynName) parsed_expr
1049 hval <- compileParsedExpr to_dyn_expr
1050 return (unsafeCoerce# hval :: Dynamic)
1051
1052 -----------------------------------------------------------------------------
1053 -- show a module and it's source/object filenames
1054
1055 showModule :: GhcMonad m => ModSummary -> m String
1056 showModule mod_summary =
1057 withSession $ \hsc_env -> do
1058 interpreted <- isModuleInterpreted mod_summary
1059 let dflags = hsc_dflags hsc_env
1060 return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)
1061
1062 isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
1063 isModuleInterpreted mod_summary = withSession $ \hsc_env ->
1064 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
1065 Nothing -> panic "missing linkable"
1066 Just mod_info -> return (not obj_linkable)
1067 where
1068 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
1069
1070 ----------------------------------------------------------------------------
1071 -- RTTI primitives
1072
1073 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
1074 obtainTermFromVal hsc_env bound force ty x =
1075 cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
1076
1077 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
1078 obtainTermFromId hsc_env bound force id = do
1079 hv <- Linker.getHValue hsc_env (varName id)
1080 cvObtainTerm hsc_env bound force (idType id) hv
1081
1082 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
1083 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
1084 reconstructType hsc_env bound id = do
1085 hv <- Linker.getHValue hsc_env (varName id)
1086 cvReconstructType hsc_env bound (idType id) hv
1087
1088 mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
1089 mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
1090 #endif /* GHCI */