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