1 -- -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow, 2005-2007
5 -- Running statements interactively
7 -- -----------------------------------------------------------------------------
9 module InteractiveEval (
11 RunResult(..), Status(..), Resume(..), History(..),
12 runStmt, parseImportDecl, SingleStep(..),
20 setContext, getContext,
31 compileExpr, dynCompileExpr,
32 Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
33 skolemiseSubst, skolemiseTy
39 #include "HsVersions.h"
41 import HscMain hiding (compileExpr)
42 import HsSyn (ImportDecl)
45 import TcRnMonad (initTc)
46 import RnNames (gresFromAvails, rnImports)
49 import TcType hiding( typeKind )
52 import Name hiding ( varName )
55 import PrelNames (pRELUDE)
71 import RtClosureInspect
77 import System.Directory
79 import Data.List (find, partition)
86 import Control.Concurrent
87 import Data.List (sortBy)
88 -- import Foreign.StablePtr
91 -- -----------------------------------------------------------------------------
92 -- running a statement interactively
95 = RunOk [Name] -- ^ names bound by this evaluation
96 | RunFailed -- ^ statement failed compilation
97 | RunException SomeException -- ^ statement raised an exception
98 | RunBreak ThreadId [Name] (Maybe BreakInfo)
101 = Break Bool HValue BreakInfo ThreadId
102 -- ^ the computation hit a breakpoint (Bool <=> was an exception)
103 | Complete (Either SomeException [HValue])
104 -- ^ the computation completed with either an exception or a value
108 resumeStmt :: String, -- the original statement
109 resumeThreadId :: ThreadId, -- thread running the computation
110 resumeBreakMVar :: MVar (),
111 resumeStatMVar :: MVar Status,
112 resumeBindings :: ([Id], TyVarSet),
113 resumeFinalIds :: [Id], -- [Id] to bind on completion
114 resumeApStack :: HValue, -- The object from which we can get
115 -- value of the free variables.
116 resumeBreakInfo :: Maybe BreakInfo,
117 -- the breakpoint we stopped at
118 -- (Nothing <=> exception)
119 resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
120 -- to fetch the ModDetails & ModBreaks
122 resumeHistory :: [History],
123 resumeHistoryIx :: Int -- 0 <==> at the top of the history
126 getResumeContext :: GhcMonad m => m [Resume]
127 getResumeContext = withSession (return . ic_resume . hsc_IC)
134 isStep :: SingleStep -> Bool
135 isStep RunToCompletion = False
140 historyApStack :: HValue,
141 historyBreakInfo :: BreakInfo,
142 historyEnclosingDecl :: Id
143 -- ^^ A cache of the enclosing top level declaration, for convenience
146 mkHistory :: HscEnv -> HValue -> BreakInfo -> History
147 mkHistory hsc_env hval bi = let
148 h = History hval bi decl
149 decl = findEnclosingDecl hsc_env (getHistoryModule h)
150 (getHistorySpan hsc_env h)
153 getHistoryModule :: History -> Module
154 getHistoryModule = breakInfo_module . historyBreakInfo
156 getHistorySpan :: HscEnv -> History -> SrcSpan
157 getHistorySpan hsc_env hist =
158 let inf = historyBreakInfo hist
159 num = breakInfo_number inf
160 in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
161 Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
162 _ -> panic "getHistorySpan"
164 getModBreaks :: HomeModInfo -> ModBreaks
166 | Just linkable <- hm_linkable hmi,
167 [BCOs _ modBreaks] <- linkableUnlinked linkable
170 = emptyModBreaks -- probably object code
172 {- | Finds the enclosing top level function name -}
173 -- ToDo: a better way to do this would be to keep hold of the decl_path computed
174 -- by the coverage pass, which gives the list of lexically-enclosing bindings
176 findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
177 findEnclosingDecl hsc_env mod span =
178 case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
179 Nothing -> panic "findEnclosingDecl"
181 globals = typeEnvIds (md_types (hm_details hmi))
183 find (\id -> let n = idName id in
184 nameSrcSpan n < span && isExternalName n)
185 (reverse$ sortBy (compare `on` (nameSrcSpan.idName))
189 -- | Run a statement in the current interactive context. Statement
190 -- may bind multple values.
191 runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
194 hsc_env <- getSession
196 breakMVar <- liftIO $ newEmptyMVar -- wait on this when we hit a breakpoint
197 statusMVar <- liftIO $ newEmptyMVar -- wait on this when a computation is running
199 -- Turn off -fwarn-unused-bindings when running a statement, to hide
200 -- warnings about the implicit bindings we introduce.
201 let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
202 hsc_env' = hsc_env{ hsc_dflags = dflags' }
204 r <- hscStmt hsc_env' expr
207 Nothing -> return RunFailed -- empty statement / comment
209 Just (ids, hval) -> do
210 -- XXX: This is the only place we can print warnings before the
211 -- result. Is this really the right thing to do? It's fine for
212 -- GHCi, but what's correct for other GHC API clients? We could
213 -- introduce a callback argument.
215 liftIO $ printBagOfWarnings dflags' warns
220 withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
221 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
222 liftIO $ sandboxIO dflags' statusMVar thing_to_run
224 let ic = hsc_IC hsc_env
225 bindings = (ic_tmp_ids ic, ic_tyvars ic)
229 traceRunStatus expr bindings ids
230 breakMVar statusMVar status emptyHistory
232 handleRunStatus expr bindings ids
233 breakMVar statusMVar status emptyHistory
235 withVirtualCWD :: GhcMonad m => m a -> m a
236 withVirtualCWD m = do
237 hsc_env <- getSession
238 let ic = hsc_IC hsc_env
241 dir <- liftIO $ getCurrentDirectory
243 Just dir -> liftIO $ setCurrentDirectory dir
247 reset_cwd orig_dir = do
248 virt_dir <- liftIO $ getCurrentDirectory
249 hsc_env <- getSession
250 let old_IC = hsc_IC hsc_env
251 setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
252 liftIO $ setCurrentDirectory orig_dir
254 gbracket set_cwd reset_cwd $ \_ -> m
256 parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
257 parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr
259 emptyHistory :: BoundedList History
260 emptyHistory = nilBL 50 -- keep a log of length 50
262 handleRunStatus :: GhcMonad m =>
263 String-> ([Id], TyVarSet) -> [Id]
264 -> MVar () -> MVar Status -> Status -> BoundedList History
266 handleRunStatus expr bindings final_ids breakMVar statusMVar status
269 -- did we hit a breakpoint or did we complete?
270 (Break is_exception apStack info tid) -> do
271 hsc_env <- getSession
272 let mb_info | is_exception = Nothing
273 | otherwise = Just info
274 (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
277 resume = Resume expr tid breakMVar statusMVar
278 bindings final_ids apStack mb_info span
280 hsc_env2 = pushResume hsc_env1 resume
282 modifySession (\_ -> hsc_env2)
283 return (RunBreak tid names mb_info)
284 (Complete either_hvals) ->
286 Left e -> return (RunException e)
288 hsc_env <- getSession
289 let final_ic = extendInteractiveContext (hsc_IC hsc_env)
290 final_ids emptyVarSet
291 -- the bound Ids never have any free TyVars
292 final_names = map idName final_ids
293 liftIO $ Linker.extendLinkEnv (zip final_names hvals)
294 hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
295 modifySession (\_ -> hsc_env')
296 return (RunOk final_names)
298 traceRunStatus :: GhcMonad m =>
299 String -> ([Id], TyVarSet) -> [Id]
300 -> MVar () -> MVar Status -> Status -> BoundedList History
302 traceRunStatus expr bindings final_ids
303 breakMVar statusMVar status history = do
304 hsc_env <- getSession
306 -- when tracing, if we hit a breakpoint that is not explicitly
307 -- enabled, then we just log the event in the history and continue.
308 (Break is_exception apStack info tid) | not is_exception -> do
309 b <- liftIO $ isBreakEnabled hsc_env info
313 let history' = mkHistory hsc_env apStack info `consBL` history
314 -- probably better make history strict here, otherwise
315 -- our BoundedList will be pointless.
316 _ <- liftIO $ evaluate history'
318 withBreakAction True (hsc_dflags hsc_env)
319 breakMVar statusMVar $ do
320 liftIO $ withInterruptsSentTo tid $ do
321 putMVar breakMVar () -- awaken the stopped thread
322 takeMVar statusMVar -- and wait for the result
323 traceRunStatus expr bindings final_ids
324 breakMVar statusMVar status history'
328 handle_normally = handleRunStatus expr bindings final_ids
329 breakMVar statusMVar status history
332 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
333 isBreakEnabled hsc_env inf =
334 case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
336 w <- getBreak (modBreaks_flags (getModBreaks hmi))
337 (breakInfo_number inf)
338 case w of Just n -> return (n /= 0); _other -> return False
343 foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
344 foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
347 setStepFlag = poke stepFlag 1
348 resetStepFlag :: IO ()
349 resetStepFlag = poke stepFlag 0
351 -- this points to the IO action that is executed when a breakpoint is hit
352 foreign import ccall "&rts_breakpoint_io_action"
353 breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
355 -- When running a computation, we redirect ^C exceptions to the running
356 -- thread. ToDo: we might want a way to continue even if the target
357 -- thread doesn't die when it receives the exception... "this thread
358 -- is not responding".
360 -- Careful here: there may be ^C exceptions flying around, so we start the new
361 -- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
362 -- only while we execute the user's code. We can't afford to lose the final
363 -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
364 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
365 sandboxIO dflags statusMVar thing =
366 mask $ \restore -> do -- fork starts blocked
367 id <- forkIO $ do res <- Exception.try (restore $ rethrow dflags thing)
368 putMVar statusMVar (Complete res) -- empty: can't block
369 withInterruptsSentTo id $ takeMVar statusMVar
372 -- We want to turn ^C into a break when -fbreak-on-exception is on,
373 -- but it's an async exception and we only break for sync exceptions.
374 -- Idea: if we catch and re-throw it, then the re-throw will trigger
375 -- a break. Great - but we don't want to re-throw all exceptions, because
376 -- then we'll get a double break for ordinary sync exceptions (you'd have
377 -- to :continue twice, which looks strange). So if the exception is
378 -- not "Interrupted", we unset the exception flag before throwing.
380 rethrow :: DynFlags -> IO a -> IO a
381 rethrow dflags io = Exception.catch io $ \se -> do
382 -- If -fbreak-on-error, we break unconditionally,
383 -- but with care of not breaking twice
384 if dopt Opt_BreakOnError dflags &&
385 not (dopt Opt_BreakOnException dflags)
386 then poke exceptionFlag 1
387 else case fromException se of
388 -- If it is a "UserInterrupt" exception, we allow
389 -- a possible break by way of -fbreak-on-exception
390 Just UserInterrupt -> return ()
391 -- In any other case, we don't want to break
392 _ -> poke exceptionFlag 0
396 withInterruptsSentTo :: ThreadId -> IO r -> IO r
397 withInterruptsSentTo thread get_result = do
398 bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
399 (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
402 -- This function sets up the interpreter for catching breakpoints, and
403 -- resets everything when the computation has stopped running. This
404 -- is a not-very-good way to ensure that only the interactive
405 -- evaluation should generate breakpoints.
406 withBreakAction :: (ExceptionMonad m, MonadIO m) =>
407 Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
408 withBreakAction step dflags breakMVar statusMVar act
409 = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
412 stablePtr <- newStablePtr onBreak
413 poke breakPointIOAction stablePtr
414 when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
415 when step $ setStepFlag
417 -- Breaking on exceptions is not enabled by default, since it
418 -- might be a bit surprising. The exception flag is turned off
419 -- as soon as it is hit, or in resetBreakAction below.
421 onBreak is_exception info apStack = do
423 putMVar statusMVar (Break is_exception apStack info tid)
426 resetBreakAction stablePtr = do
427 poke breakPointIOAction noBreakStablePtr
430 freeStablePtr stablePtr
432 noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
433 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
435 noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
436 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
437 noBreakAction True _ _ = return () -- exception: just continue
439 resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
440 resume canLogSpan step
442 hsc_env <- getSession
443 let ic = hsc_IC hsc_env
444 resume = ic_resume ic
447 [] -> ghcError (ProgramError "not stopped at a breakpoint")
449 -- unbind the temporary locals by restoring the TypeEnv from
450 -- before the breakpoint, and drop this Resume from the
451 -- InteractiveContext.
452 let (resume_tmp_ids, resume_tyvars) = resumeBindings r
453 ic' = ic { ic_tmp_ids = resume_tmp_ids,
454 ic_tyvars = resume_tyvars,
456 modifySession (\_ -> hsc_env{ hsc_IC = ic' })
458 -- remove any bindings created since the breakpoint from the
459 -- linker's environment
460 let new_names = map idName (filter (`notElem` resume_tmp_ids)
462 liftIO $ Linker.deleteFromLinkEnv new_names
464 when (isStep step) $ liftIO setStepFlag
466 Resume expr tid breakMVar statusMVar bindings
467 final_ids apStack info span hist _ -> do
469 withBreakAction (isStep step) (hsc_dflags hsc_env)
470 breakMVar statusMVar $ do
471 status <- liftIO $ withInterruptsSentTo tid $ do
473 -- this awakens the stopped thread...
475 -- and wait for the result
476 let prevHistoryLst = fromListBL 50 hist
478 Nothing -> prevHistoryLst
480 | not $canLogSpan span -> prevHistoryLst
481 | otherwise -> mkHistory hsc_env apStack i `consBL`
485 traceRunStatus expr bindings final_ids
486 breakMVar statusMVar status hist'
488 handleRunStatus expr bindings final_ids
489 breakMVar statusMVar status hist'
491 back :: GhcMonad m => m ([Name], Int, SrcSpan)
494 forward :: GhcMonad m => m ([Name], Int, SrcSpan)
495 forward = moveHist (subtract 1)
497 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
499 hsc_env <- getSession
500 case ic_resume (hsc_IC hsc_env) of
501 [] -> ghcError (ProgramError "not stopped at a breakpoint")
503 let ix = resumeHistoryIx r
504 history = resumeHistory r
507 when (new_ix > length history) $
508 ghcError (ProgramError "no more logged breakpoints")
510 ghcError (ProgramError "already at the beginning of the history")
513 update_ic apStack mb_info = do
514 (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
516 let ic = hsc_IC hsc_env1
517 r' = r { resumeHistoryIx = new_ix }
518 ic' = ic { ic_resume = r':rs }
520 modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
522 return (names, new_ix, span)
524 -- careful: we want apStack to be the AP_STACK itself, not a thunk
525 -- around it, hence the cases are carefully constructed below to
526 -- make this the case. ToDo: this is v. fragile, do something better.
529 Resume { resumeApStack = apStack,
530 resumeBreakInfo = mb_info } ->
531 update_ic apStack mb_info
532 else case history !! (new_ix - 1) of
533 History apStack info _ ->
534 update_ic apStack (Just info)
536 -- -----------------------------------------------------------------------------
537 -- After stopping at a breakpoint, add free variables to the environment
538 result_fs :: FastString
539 result_fs = fsLit "_result"
541 bindLocalsAtBreakpoint
545 -> IO (HscEnv, [Name], SrcSpan)
547 -- Nothing case: we stopped when an exception was raised, not at a
548 -- breakpoint. We have no location information or local variables to
549 -- bind, all we can do is bind a local variable to the exception
551 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
552 let exn_fs = fsLit "_exception"
553 exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
555 e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
556 e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
557 exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
558 new_tyvars = unitVarSet e_tyvar
560 ictxt0 = hsc_IC hsc_env
561 ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
563 span = mkGeneralSrcSpan (fsLit "<exception thrown>")
565 Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
566 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
568 -- Just case: we stopped at a breakpoint, we have information about the location
569 -- of the breakpoint and the free variables of the expression.
570 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
573 mod_name = moduleName (breakInfo_module info)
574 hmi = expectJust "bindLocalsAtBreakpoint" $
575 lookupUFM (hsc_HPT hsc_env) mod_name
576 breaks = getModBreaks hmi
577 index = breakInfo_number info
578 vars = breakInfo_vars info
579 result_ty = breakInfo_resty info
580 occs = modBreaks_vars breaks ! index
581 span = modBreaks_locs breaks ! index
583 -- filter out any unboxed ids; we can't bind these at the prompt
584 let pointers = filter (\(id,_) -> isPointer id) vars
585 isPointer id | PtrRep <- idPrimRep id = True
588 let (ids, offsets) = unzip pointers
590 -- It might be that getIdValFromApStack fails, because the AP_STACK
591 -- has been accidentally evaluated, or something else has gone wrong.
592 -- So that we don't fall over in a heap when this happens, just don't
593 -- bind any free variables instead, and we emit a warning.
594 mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
595 let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
596 when (any isNothing mb_hValues) $
597 debugTraceMsg (hsc_dflags hsc_env) 1 $
598 text "Warning: _result has been evaluated, some bindings have been lost"
600 new_ids <- zipWithM mkNewId occs filtered_ids
601 let names = map idName new_ids
603 -- make an Id for _result. We use the Unique of the FastString "_result";
604 -- we don't care about uniqueness here, because there will only be one
605 -- _result in scope at any time.
606 let result_name = mkInternalName (getUnique result_fs)
607 (mkVarOccFS result_fs) span
608 result_id = Id.mkVanillaGlobal result_name result_ty
610 -- for each Id we're about to bind in the local envt:
611 -- - skolemise the type variables in its type, so they can't
612 -- be randomly unified with other types. These type variables
613 -- can only be resolved by type reconstruction in RtClosureInspect
614 -- - tidy the type variables
615 -- - globalise the Id (Ids are supposed to be Global, apparently).
617 let result_ok = isPointer result_id
618 && not (isUnboxedTupleType (idType result_id))
620 all_ids | result_ok = result_id : new_ids
621 | otherwise = new_ids
622 (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
623 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
624 new_tyvars = unionVarSets tyvarss
625 final_ids = zipWith setIdType all_ids tidy_tys
626 ictxt0 = hsc_IC hsc_env
627 ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
629 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
630 when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
631 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
632 return (hsc_env1, if result_ok then result_name:names else names, span)
634 mkNewId :: OccName -> Id -> IO Id
636 us <- mkSplitUniqSupply 'I'
637 -- we need a fresh Unique for each Id we bind, because the linker
638 -- state is single-threaded and otherwise we'd spam old bindings
639 -- whenever we stop at a breakpoint. The InteractveContext is properly
640 -- saved/restored, but not the linker state. See #1743, test break026.
642 uniq = uniqFromSupply us
643 loc = nameSrcSpan (idName id)
644 name = mkInternalName uniq occ loc
646 new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
649 rttiEnvironment :: HscEnv -> IO HscEnv
650 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
651 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
652 incompletelyTypedIds =
655 , (occNameFS.nameOccName.idName) id /= result_fs]
656 hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
659 noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
660 improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
661 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
662 Just id = find (\i -> idName i == name) tmp_ids
666 mb_new_ty <- reconstructType hsc_env 10 id
667 let old_ty = idType id
669 Nothing -> return hsc_env
671 mb_subst <- improveRTTIType hsc_env old_ty new_ty
674 WARN(True, text (":print failed to calculate the "
675 ++ "improvement for a type")) hsc_env
677 when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
678 printForUser stderr alwaysQualify $
679 fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
681 let (subst', skols) = skolemiseSubst subst
682 ic' = extendInteractiveContext
683 (substInteractiveContext ic subst') [] skols
684 return hsc_env{hsc_IC=ic'}
686 skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
687 skolemiseSubst subst = let
688 varenv = getTvSubstEnv subst
689 all_together = mapVarEnv skolemiseTy varenv
690 (varenv', skol_vars) = ( mapVarEnv fst all_together
691 , map snd (varEnvElts all_together))
692 in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
695 skolemiseTy :: Type -> (Type, TyVarSet)
696 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
697 where env = mkVarEnv (zip tyvars new_tyvar_tys)
698 subst = mkTvSubst emptyInScopeSet env
699 tyvars = varSetElems (tyVarsOfType ty)
700 new_tyvars = map skolemiseTyVar tyvars
701 new_tyvar_tys = map mkTyVarTy new_tyvars
703 skolemiseTyVar :: TyVar -> TyVar
704 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
705 (SkolemTv RuntimeUnkSkol)
707 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
708 getIdValFromApStack apStack (I# stackDepth) = do
709 case getApStackVal# apStack (stackDepth +# 1#) of
710 -- The +1 is magic! I don't know where it comes
711 -- from, but this makes things line up. --SDM
714 0# -> return Nothing -- AP_STACK not found
715 _ -> return (Just (unsafeCoerce# result))
717 pushResume :: HscEnv -> Resume -> HscEnv
718 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
720 ictxt0 = hsc_IC hsc_env
721 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
723 -- -----------------------------------------------------------------------------
724 -- Abandoning a resume context
726 abandon :: GhcMonad m => m Bool
728 hsc_env <- getSession
729 let ic = hsc_IC hsc_env
730 resume = ic_resume ic
734 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
738 abandonAll :: GhcMonad m => m Bool
740 hsc_env <- getSession
741 let ic = hsc_IC hsc_env
742 resume = ic_resume ic
746 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
747 liftIO $ mapM_ abandon_ rs
750 -- when abandoning a computation we have to
751 -- (a) kill the thread with an async exception, so that the
752 -- computation itself is stopped, and
753 -- (b) fill in the MVar. This step is necessary because any
754 -- thunks that were under evaluation will now be updated
755 -- with the partial computation, which still ends in takeMVar,
756 -- so any attempt to evaluate one of these thunks will block
757 -- unless we fill in the MVar.
758 -- See test break010.
759 abandon_ :: Resume -> IO ()
761 killThread (resumeThreadId r)
762 putMVar (resumeBreakMVar r) ()
764 -- -----------------------------------------------------------------------------
765 -- Bounded list, optimised for repeated cons
767 data BoundedList a = BL
768 {-# UNPACK #-} !Int -- length
769 {-# UNPACK #-} !Int -- bound
771 [a] -- right, list is (left ++ reverse right)
773 nilBL :: Int -> BoundedList a
774 nilBL bound = BL 0 bound [] []
776 consBL :: a -> BoundedList a -> BoundedList a
777 consBL a (BL len bound left right)
778 | len < bound = BL (len+1) bound (a:left) right
779 | null right = BL len bound [a] $! tail (reverse left)
780 | otherwise = BL len bound (a:left) $! tail right
782 toListBL :: BoundedList a -> [a]
783 toListBL (BL _ _ left right) = left ++ reverse right
785 fromListBL :: Int -> [a] -> BoundedList a
786 fromListBL bound l = BL (length l) bound l []
788 -- lenBL (BL len _ _ _) = len
790 -- -----------------------------------------------------------------------------
791 -- | Set the interactive evaluation context.
793 -- Setting the context doesn't throw away any bindings; the bindings
794 -- we've built up in the InteractiveContext simply move to the new
795 -- module. They always shadow anything in scope in the current context.
796 setContext :: GhcMonad m =>
797 [Module] -- ^ entire top level scope of these modules
798 -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules
800 setContext toplev_mods other_mods = do
801 hsc_env <- getSession
802 let old_ic = hsc_IC hsc_env
803 hpt = hsc_HPT hsc_env
804 (decls,mods) = partition (isJust . snd) other_mods -- time for tracing
805 export_mods = map fst mods
806 imprt_decls = map noLoc (catMaybes (map snd decls))
808 export_env <- liftIO $ mkExportEnv hsc_env export_mods
810 if null imprt_decls then return emptyGlobalRdrEnv else do
811 let imports = rnImports imprt_decls
812 this_mod = if null toplev_mods then pRELUDE else head toplev_mods
814 ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports
816 toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
817 let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
818 modifySession $ \_ ->
819 hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
820 ic_exports = other_mods,
821 ic_rn_gbl_env = all_env }}
823 -- Make a GlobalRdrEnv based on the exports of the modules only.
824 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
825 mkExportEnv hsc_env mods
826 = do { stuff <- mapM (getModuleExports hsc_env) mods
827 ; let (_msgs, mb_name_sets) = unzip stuff
828 envs = [ availsToGlobalRdrEnv (moduleName mod) avails
829 | (Just avails, mod) <- zip mb_name_sets mods ]
830 ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }
832 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
833 availsToGlobalRdrEnv mod_name avails
834 = mkGlobalRdrEnv (gresFromAvails imp_prov avails)
836 -- We're building a GlobalRdrEnv as if the user imported
837 -- all the specified modules into the global interactive module
838 imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
839 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
841 is_dloc = srcLocSpan interactiveSrcLoc }
843 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
845 = case lookupUFM hpt (moduleName modl) of
846 Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
847 showSDoc (ppr modl)))
849 case mi_globals (hm_iface details) of
851 ghcError (ProgramError ("mkTopLevEnv: not interpreted "
852 ++ showSDoc (ppr modl)))
853 Just env -> return env
855 -- | Get the interactive evaluation context, consisting of a pair of the
856 -- set of modules from which we take the full top-level scope, and the set
857 -- of modules from which we take just the exports respectively.
858 getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))])
859 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
860 return (ic_toplev_scope ic, ic_exports ic)
862 -- | Returns @True@ if the specified module is interpreted, and hence has
863 -- its full top-level scope available.
864 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
865 moduleIsInterpreted modl = withSession $ \h ->
866 if modulePackageId modl /= thisPackage (hsc_dflags h)
868 else case lookupUFM (hsc_HPT h) (moduleName modl) of
869 Just details -> return (isJust (mi_globals (hm_iface details)))
870 _not_a_home_module -> return False
872 -- | Looks up an identifier in the current interactive context (for :info)
873 -- Filter the instances by the ones whose tycons (or clases resp)
874 -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
875 -- The exact choice of which ones to show, and which to hide, is a judgement call.
877 getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
879 = withSession $ \hsc_env ->
880 do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
882 Nothing -> return Nothing
883 Just (thing, fixity, ispecs) -> do
884 let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
885 return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
887 plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env
888 = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
889 where -- A name is ok if it's in the rdr_env,
890 -- whether qualified or not
891 ok n | n == name = True -- The one we looked for in the first place!
892 | isBuiltInSyntax n = True
893 | isExternalName n = any ((== n) . gre_name)
894 (lookupGRE_Name rdr_env n)
897 -- | Returns all names in scope in the current interactive context
898 getNamesInScope :: GhcMonad m => m [Name]
899 getNamesInScope = withSession $ \hsc_env -> do
900 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
902 getRdrNamesInScope :: GhcMonad m => m [RdrName]
903 getRdrNamesInScope = withSession $ \hsc_env -> do
906 gbl_rdrenv = ic_rn_gbl_env ic
908 gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
909 lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
911 return (gbl_names ++ lcl_names)
914 -- ToDo: move to RdrName
915 greToRdrNames :: GlobalRdrElt -> [RdrName]
916 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
919 Imported specs -> concat (map do_spec (map is_decl specs))
921 occ = nameOccName name
924 | is_qual decl_spec = [qual]
925 | otherwise = [unqual,qual]
926 where qual = Qual (is_as decl_spec) occ
928 -- | Parses a string as an identifier, and returns the list of 'Name's that
929 -- the identifier can refer to in the current interactive context.
930 parseName :: GhcMonad m => String -> m [Name]
931 parseName str = withSession $ \hsc_env -> do
932 (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
933 ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
935 -- -----------------------------------------------------------------------------
936 -- Getting the type of an expression
938 -- | Get the type of an expression
939 exprType :: GhcMonad m => String -> m Type
940 exprType expr = withSession $ \hsc_env -> do
941 ty <- hscTcExpr hsc_env expr
942 return $ tidyType emptyTidyEnv ty
944 -- -----------------------------------------------------------------------------
945 -- Getting the kind of a type
947 -- | Get the kind of a type
948 typeKind :: GhcMonad m => String -> m Kind
949 typeKind str = withSession $ \hsc_env -> do
950 hscKcType hsc_env str
952 -----------------------------------------------------------------------------
953 -- cmCompileExpr: compile an expression and deliver an HValue
955 compileExpr :: GhcMonad m => String -> m HValue
956 compileExpr expr = withSession $ \hsc_env -> do
957 Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
959 hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
962 ([_],[hv]) -> return hv
963 _ -> panic "compileExpr"
965 -- -----------------------------------------------------------------------------
966 -- Compile an expression into a dynamic
968 dynCompileExpr :: GhcMonad m => String -> m Dynamic
969 dynCompileExpr expr = do
970 (full,exports) <- getContext
973 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
975 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
976 Just (ids, hvals) <- withSession (flip hscStmt stmt)
977 setContext full exports
978 vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
980 (_:[], v:[]) -> return v
981 _ -> panic "dynCompileExpr"
983 -----------------------------------------------------------------------------
984 -- show a module and it's source/object filenames
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)
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)
998 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
1000 ----------------------------------------------------------------------------
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)
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
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