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
38 #include "HsVersions.h"
42 import HsSyn (ImportDecl)
45 import RnNames (gresFromAvails)
48 import TcType hiding( typeKind )
51 import Name hiding ( varName )
54 import PrelNames (pRELUDE)
69 import RtClosureInspect
75 import System.Directory
77 import Data.List (find, partition)
79 import Foreign hiding (unsafePerformIO)
84 import Control.Concurrent
85 -- import Foreign.StablePtr
87 import System.IO.Unsafe
89 -- -----------------------------------------------------------------------------
90 -- running a statement interactively
93 = RunOk [Name] -- ^ names bound by this evaluation
94 | RunFailed -- ^ statement failed compilation
95 | RunException SomeException -- ^ statement raised an exception
96 | RunBreak ThreadId [Name] (Maybe BreakInfo)
99 = Break Bool HValue BreakInfo ThreadId
100 -- ^ the computation hit a breakpoint (Bool <=> was an exception)
101 | Complete (Either SomeException [HValue])
102 -- ^ the computation completed with either an exception or a value
106 resumeStmt :: String, -- the original statement
107 resumeThreadId :: ThreadId, -- thread running the computation
108 resumeBreakMVar :: MVar (),
109 resumeStatMVar :: MVar Status,
110 resumeBindings :: [Id],
111 resumeFinalIds :: [Id], -- [Id] to bind on completion
112 resumeApStack :: HValue, -- The object from which we can get
113 -- value of the free variables.
114 resumeBreakInfo :: Maybe BreakInfo,
115 -- the breakpoint we stopped at
116 -- (Nothing <=> exception)
117 resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
118 -- to fetch the ModDetails & ModBreaks
120 resumeHistory :: [History],
121 resumeHistoryIx :: Int -- 0 <==> at the top of the history
124 getResumeContext :: GhcMonad m => m [Resume]
125 getResumeContext = withSession (return . ic_resume . hsc_IC)
132 isStep :: SingleStep -> Bool
133 isStep RunToCompletion = False
138 historyApStack :: HValue,
139 historyBreakInfo :: BreakInfo,
140 historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint
143 mkHistory :: HscEnv -> HValue -> BreakInfo -> History
144 mkHistory hsc_env hval bi = let
145 decls = findEnclosingDecls hsc_env bi
146 in History hval bi decls
149 getHistoryModule :: History -> Module
150 getHistoryModule = breakInfo_module . historyBreakInfo
152 getHistorySpan :: HscEnv -> History -> SrcSpan
153 getHistorySpan hsc_env hist =
154 let inf = historyBreakInfo hist
155 num = breakInfo_number inf
156 in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
157 Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
158 _ -> panic "getHistorySpan"
160 getModBreaks :: HomeModInfo -> ModBreaks
162 | Just linkable <- hm_linkable hmi,
163 [BCOs _ modBreaks] <- linkableUnlinked linkable
166 = emptyModBreaks -- probably object code
168 {- | Finds the enclosing top level function name -}
169 -- ToDo: a better way to do this would be to keep hold of the decl_path computed
170 -- by the coverage pass, which gives the list of lexically-enclosing bindings
172 findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
173 findEnclosingDecls hsc_env inf =
174 let hmi = expectJust "findEnclosingDecls" $
175 lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf)
176 mb = getModBreaks hmi
177 in modBreaks_decls mb ! breakInfo_number inf
180 -- | Run a statement in the current interactive context. Statement
181 -- may bind multple values.
182 runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
185 hsc_env <- getSession
187 breakMVar <- liftIO $ newEmptyMVar -- wait on this when we hit a breakpoint
188 statusMVar <- liftIO $ newEmptyMVar -- wait on this when a computation is running
190 -- Turn off -fwarn-unused-bindings when running a statement, to hide
191 -- warnings about the implicit bindings we introduce.
192 let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
193 hsc_env' = hsc_env{ hsc_dflags = dflags' }
195 r <- liftIO $ hscStmt hsc_env' expr
198 Nothing -> return RunFailed -- empty statement / comment
200 Just (ids, hval) -> do
203 withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
204 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
205 liftIO $ sandboxIO dflags' statusMVar thing_to_run
207 let ic = hsc_IC hsc_env
208 bindings = ic_tmp_ids ic
212 traceRunStatus expr bindings ids
213 breakMVar statusMVar status emptyHistory
215 handleRunStatus expr bindings ids
216 breakMVar statusMVar status emptyHistory
218 withVirtualCWD :: GhcMonad m => m a -> m a
219 withVirtualCWD m = do
220 hsc_env <- getSession
221 let ic = hsc_IC hsc_env
224 dir <- liftIO $ getCurrentDirectory
226 Just dir -> liftIO $ setCurrentDirectory dir
230 reset_cwd orig_dir = do
231 virt_dir <- liftIO $ getCurrentDirectory
232 hsc_env <- getSession
233 let old_IC = hsc_IC hsc_env
234 setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
235 liftIO $ setCurrentDirectory orig_dir
237 gbracket set_cwd reset_cwd $ \_ -> m
239 parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
240 parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
242 emptyHistory :: BoundedList History
243 emptyHistory = nilBL 50 -- keep a log of length 50
245 handleRunStatus :: GhcMonad m =>
246 String-> [Id] -> [Id]
247 -> MVar () -> MVar Status -> Status -> BoundedList History
249 handleRunStatus expr bindings final_ids breakMVar statusMVar status
252 -- did we hit a breakpoint or did we complete?
253 (Break is_exception apStack info tid) -> do
254 hsc_env <- getSession
255 let mb_info | is_exception = Nothing
256 | otherwise = Just info
257 (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
260 resume = Resume { resumeStmt = expr, resumeThreadId = tid
261 , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
262 , resumeBindings = bindings, resumeFinalIds = final_ids
263 , resumeApStack = apStack, resumeBreakInfo = mb_info
264 , resumeSpan = span, resumeHistory = toListBL history
265 , resumeHistoryIx = 0 }
266 hsc_env2 = pushResume hsc_env1 resume
268 modifySession (\_ -> hsc_env2)
269 return (RunBreak tid names mb_info)
270 (Complete either_hvals) ->
272 Left e -> return (RunException e)
274 hsc_env <- getSession
275 let final_ic = extendInteractiveContext (hsc_IC hsc_env) final_ids
276 final_names = map idName final_ids
277 liftIO $ Linker.extendLinkEnv (zip final_names hvals)
278 hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
279 modifySession (\_ -> hsc_env')
280 return (RunOk final_names)
282 traceRunStatus :: GhcMonad m =>
283 String -> [Id] -> [Id]
284 -> MVar () -> MVar Status -> Status -> BoundedList History
286 traceRunStatus expr bindings final_ids
287 breakMVar statusMVar status history = do
288 hsc_env <- getSession
290 -- when tracing, if we hit a breakpoint that is not explicitly
291 -- enabled, then we just log the event in the history and continue.
292 (Break is_exception apStack info tid) | not is_exception -> do
293 b <- liftIO $ isBreakEnabled hsc_env info
297 let history' = mkHistory hsc_env apStack info `consBL` history
298 -- probably better make history strict here, otherwise
299 -- our BoundedList will be pointless.
300 _ <- liftIO $ evaluate history'
302 withBreakAction True (hsc_dflags hsc_env)
303 breakMVar statusMVar $ do
304 liftIO $ withInterruptsSentTo tid $ do
305 putMVar breakMVar () -- awaken the stopped thread
306 takeMVar statusMVar -- and wait for the result
307 traceRunStatus expr bindings final_ids
308 breakMVar statusMVar status history'
312 handle_normally = handleRunStatus expr bindings final_ids
313 breakMVar statusMVar status history
316 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
317 isBreakEnabled hsc_env inf =
318 case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
320 w <- getBreak (modBreaks_flags (getModBreaks hmi))
321 (breakInfo_number inf)
322 case w of Just n -> return (n /= 0); _other -> return False
327 foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
328 foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
331 setStepFlag = poke stepFlag 1
332 resetStepFlag :: IO ()
333 resetStepFlag = poke stepFlag 0
335 -- this points to the IO action that is executed when a breakpoint is hit
336 foreign import ccall "&rts_breakpoint_io_action"
337 breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
339 -- When running a computation, we redirect ^C exceptions to the running
340 -- thread. ToDo: we might want a way to continue even if the target
341 -- thread doesn't die when it receives the exception... "this thread
342 -- is not responding".
344 -- Careful here: there may be ^C exceptions flying around, so we start the new
345 -- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
346 -- only while we execute the user's code. We can't afford to lose the final
347 -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
348 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
349 sandboxIO dflags statusMVar thing =
350 mask $ \restore -> -- fork starts blocked
351 let runIt = liftM Complete $ try (restore $ rethrow dflags thing)
352 in if dopt Opt_GhciSandbox dflags
353 then do tid <- forkIO $ do res <- runIt
354 putMVar statusMVar res -- empty: can't block
355 withInterruptsSentTo tid $ takeMVar statusMVar
356 else -- GLUT on OS X needs to run on the main thread. If you
357 -- try to use it from another thread then you just get a
358 -- white rectangle rendered. For this, or anything else
359 -- with such restrictions, you can turn the GHCi sandbox off
360 -- and things will be run in the main thread.
363 -- We want to turn ^C into a break when -fbreak-on-exception is on,
364 -- but it's an async exception and we only break for sync exceptions.
365 -- Idea: if we catch and re-throw it, then the re-throw will trigger
366 -- a break. Great - but we don't want to re-throw all exceptions, because
367 -- then we'll get a double break for ordinary sync exceptions (you'd have
368 -- to :continue twice, which looks strange). So if the exception is
369 -- not "Interrupted", we unset the exception flag before throwing.
371 rethrow :: DynFlags -> IO a -> IO a
372 rethrow dflags io = Exception.catch io $ \se -> do
373 -- If -fbreak-on-error, we break unconditionally,
374 -- but with care of not breaking twice
375 if dopt Opt_BreakOnError dflags &&
376 not (dopt Opt_BreakOnException dflags)
377 then poke exceptionFlag 1
378 else case fromException se of
379 -- If it is a "UserInterrupt" exception, we allow
380 -- a possible break by way of -fbreak-on-exception
381 Just UserInterrupt -> return ()
382 -- In any other case, we don't want to break
383 _ -> poke exceptionFlag 0
387 withInterruptsSentTo :: ThreadId -> IO r -> IO r
388 withInterruptsSentTo thread get_result = do
389 bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
390 (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
393 -- This function sets up the interpreter for catching breakpoints, and
394 -- resets everything when the computation has stopped running. This
395 -- is a not-very-good way to ensure that only the interactive
396 -- evaluation should generate breakpoints.
397 withBreakAction :: (ExceptionMonad m, MonadIO m) =>
398 Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
399 withBreakAction step dflags breakMVar statusMVar act
400 = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
403 stablePtr <- newStablePtr onBreak
404 poke breakPointIOAction stablePtr
405 when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
406 when step $ setStepFlag
408 -- Breaking on exceptions is not enabled by default, since it
409 -- might be a bit surprising. The exception flag is turned off
410 -- as soon as it is hit, or in resetBreakAction below.
412 onBreak is_exception info apStack = do
414 putMVar statusMVar (Break is_exception apStack info tid)
417 resetBreakAction stablePtr = do
418 poke breakPointIOAction noBreakStablePtr
421 freeStablePtr stablePtr
423 noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
424 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
426 noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
427 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
428 noBreakAction True _ _ = return () -- exception: just continue
430 resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
431 resume canLogSpan step
433 hsc_env <- getSession
434 let ic = hsc_IC hsc_env
435 resume = ic_resume ic
438 [] -> ghcError (ProgramError "not stopped at a breakpoint")
440 -- unbind the temporary locals by restoring the TypeEnv from
441 -- before the breakpoint, and drop this Resume from the
442 -- InteractiveContext.
443 let resume_tmp_ids = resumeBindings r
444 ic' = ic { ic_tmp_ids = resume_tmp_ids,
446 modifySession (\_ -> hsc_env{ hsc_IC = ic' })
448 -- remove any bindings created since the breakpoint from the
449 -- linker's environment
450 let new_names = map idName (filter (`notElem` resume_tmp_ids)
452 liftIO $ Linker.deleteFromLinkEnv new_names
454 when (isStep step) $ liftIO setStepFlag
456 Resume { resumeStmt = expr, resumeThreadId = tid
457 , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
458 , resumeBindings = bindings, resumeFinalIds = final_ids
459 , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
460 , resumeHistory = hist } -> do
462 withBreakAction (isStep step) (hsc_dflags hsc_env)
463 breakMVar statusMVar $ do
464 status <- liftIO $ withInterruptsSentTo tid $ do
466 -- this awakens the stopped thread...
468 -- and wait for the result
469 let prevHistoryLst = fromListBL 50 hist
471 Nothing -> prevHistoryLst
473 | not $canLogSpan span -> prevHistoryLst
474 | otherwise -> mkHistory hsc_env apStack i `consBL`
478 traceRunStatus expr bindings final_ids
479 breakMVar statusMVar status hist'
481 handleRunStatus expr bindings final_ids
482 breakMVar statusMVar status hist'
484 back :: GhcMonad m => m ([Name], Int, SrcSpan)
487 forward :: GhcMonad m => m ([Name], Int, SrcSpan)
488 forward = moveHist (subtract 1)
490 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
492 hsc_env <- getSession
493 case ic_resume (hsc_IC hsc_env) of
494 [] -> ghcError (ProgramError "not stopped at a breakpoint")
496 let ix = resumeHistoryIx r
497 history = resumeHistory r
500 when (new_ix > length history) $
501 ghcError (ProgramError "no more logged breakpoints")
503 ghcError (ProgramError "already at the beginning of the history")
506 update_ic apStack mb_info = do
507 (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
509 let ic = hsc_IC hsc_env1
510 r' = r { resumeHistoryIx = new_ix }
511 ic' = ic { ic_resume = r':rs }
513 modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
515 return (names, new_ix, span)
517 -- careful: we want apStack to be the AP_STACK itself, not a thunk
518 -- around it, hence the cases are carefully constructed below to
519 -- make this the case. ToDo: this is v. fragile, do something better.
522 Resume { resumeApStack = apStack,
523 resumeBreakInfo = mb_info } ->
524 update_ic apStack mb_info
525 else case history !! (new_ix - 1) of
526 History apStack info _ ->
527 update_ic apStack (Just info)
529 -- -----------------------------------------------------------------------------
530 -- After stopping at a breakpoint, add free variables to the environment
531 result_fs :: FastString
532 result_fs = fsLit "_result"
534 bindLocalsAtBreakpoint
538 -> IO (HscEnv, [Name], SrcSpan)
540 -- Nothing case: we stopped when an exception was raised, not at a
541 -- breakpoint. We have no location information or local variables to
542 -- bind, all we can do is bind a local variable to the exception
544 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
545 let exn_fs = fsLit "_exception"
546 exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
548 e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
549 e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
550 exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
552 ictxt0 = hsc_IC hsc_env
553 ictxt1 = extendInteractiveContext ictxt0 [exn_id]
555 span = mkGeneralSrcSpan (fsLit "<exception thrown>")
557 Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
558 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
560 -- Just case: we stopped at a breakpoint, we have information about the location
561 -- of the breakpoint and the free variables of the expression.
562 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
565 mod_name = moduleName (breakInfo_module info)
566 hmi = expectJust "bindLocalsAtBreakpoint" $
567 lookupUFM (hsc_HPT hsc_env) mod_name
568 breaks = getModBreaks hmi
569 index = breakInfo_number info
570 vars = breakInfo_vars info
571 result_ty = breakInfo_resty info
572 occs = modBreaks_vars breaks ! index
573 span = modBreaks_locs breaks ! index
575 -- filter out any unboxed ids; we can't bind these at the prompt
576 let pointers = filter (\(id,_) -> isPointer id) vars
577 isPointer id | PtrRep <- idPrimRep id = True
580 let (ids, offsets) = unzip pointers
582 -- It might be that getIdValFromApStack fails, because the AP_STACK
583 -- has been accidentally evaluated, or something else has gone wrong.
584 -- So that we don't fall over in a heap when this happens, just don't
585 -- bind any free variables instead, and we emit a warning.
586 mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
587 let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
588 when (any isNothing mb_hValues) $
589 debugTraceMsg (hsc_dflags hsc_env) 1 $
590 text "Warning: _result has been evaluated, some bindings have been lost"
592 new_ids <- zipWithM mkNewId occs filtered_ids
593 let names = map idName new_ids
595 -- make an Id for _result. We use the Unique of the FastString "_result";
596 -- we don't care about uniqueness here, because there will only be one
597 -- _result in scope at any time.
598 let result_name = mkInternalName (getUnique result_fs)
599 (mkVarOccFS result_fs) span
600 result_id = Id.mkVanillaGlobal result_name result_ty
602 -- for each Id we're about to bind in the local envt:
603 -- - tidy the type variables
604 -- - globalise the Id (Ids are supposed to be Global, apparently).
606 let result_ok = isPointer result_id
607 && not (isUnboxedTupleType (idType result_id))
609 all_ids | result_ok = result_id : new_ids
610 | otherwise = new_ids
611 id_tys = map idType all_ids
612 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
613 final_ids = zipWith setIdType all_ids tidy_tys
614 ictxt0 = hsc_IC hsc_env
615 ictxt1 = extendInteractiveContext ictxt0 final_ids
617 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
618 when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
619 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
620 return (hsc_env1, if result_ok then result_name:names else names, span)
622 mkNewId :: OccName -> Id -> IO Id
624 us <- mkSplitUniqSupply 'I'
625 -- we need a fresh Unique for each Id we bind, because the linker
626 -- state is single-threaded and otherwise we'd spam old bindings
627 -- whenever we stop at a breakpoint. The InteractveContext is properly
628 -- saved/restored, but not the linker state. See #1743, test break026.
630 uniq = uniqFromSupply us
631 loc = nameSrcSpan (idName id)
632 name = mkInternalName uniq occ loc
634 new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
637 rttiEnvironment :: HscEnv -> IO HscEnv
638 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
639 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
640 incompletelyTypedIds =
643 , (occNameFS.nameOccName.idName) id /= result_fs]
644 hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
647 noSkolems = isEmptyVarSet . tyVarsOfType . idType
648 improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
649 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
650 Just id = find (\i -> idName i == name) tmp_ids
654 mb_new_ty <- reconstructType hsc_env 10 id
655 let old_ty = idType id
657 Nothing -> return hsc_env
659 case improveRTTIType hsc_env old_ty new_ty of
661 WARN(True, text (":print failed to calculate the "
662 ++ "improvement for a type")) hsc_env
664 when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
665 printForUser stderr alwaysQualify $
666 fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
668 let ic' = extendInteractiveContext
669 (substInteractiveContext ic subst) []
670 return hsc_env{hsc_IC=ic'}
672 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
673 getIdValFromApStack apStack (I# stackDepth) = do
674 case getApStackVal# apStack (stackDepth +# 1#) of
675 -- The +1 is magic! I don't know where it comes
676 -- from, but this makes things line up. --SDM
679 0# -> return Nothing -- AP_STACK not found
680 _ -> return (Just (unsafeCoerce# result))
682 pushResume :: HscEnv -> Resume -> HscEnv
683 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
685 ictxt0 = hsc_IC hsc_env
686 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
688 -- -----------------------------------------------------------------------------
689 -- Abandoning a resume context
691 abandon :: GhcMonad m => m Bool
693 hsc_env <- getSession
694 let ic = hsc_IC hsc_env
695 resume = ic_resume ic
699 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
703 abandonAll :: GhcMonad m => m Bool
705 hsc_env <- getSession
706 let ic = hsc_IC hsc_env
707 resume = ic_resume ic
711 modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
712 liftIO $ mapM_ abandon_ rs
715 -- when abandoning a computation we have to
716 -- (a) kill the thread with an async exception, so that the
717 -- computation itself is stopped, and
718 -- (b) fill in the MVar. This step is necessary because any
719 -- thunks that were under evaluation will now be updated
720 -- with the partial computation, which still ends in takeMVar,
721 -- so any attempt to evaluate one of these thunks will block
722 -- unless we fill in the MVar.
723 -- See test break010.
724 abandon_ :: Resume -> IO ()
726 killThread (resumeThreadId r)
727 putMVar (resumeBreakMVar r) ()
729 -- -----------------------------------------------------------------------------
730 -- Bounded list, optimised for repeated cons
732 data BoundedList a = BL
733 {-# UNPACK #-} !Int -- length
734 {-# UNPACK #-} !Int -- bound
736 [a] -- right, list is (left ++ reverse right)
738 nilBL :: Int -> BoundedList a
739 nilBL bound = BL 0 bound [] []
741 consBL :: a -> BoundedList a -> BoundedList a
742 consBL a (BL len bound left right)
743 | len < bound = BL (len+1) bound (a:left) right
744 | null right = BL len bound [a] $! tail (reverse left)
745 | otherwise = BL len bound (a:left) $! tail right
747 toListBL :: BoundedList a -> [a]
748 toListBL (BL _ _ left right) = left ++ reverse right
750 fromListBL :: Int -> [a] -> BoundedList a
751 fromListBL bound l = BL (length l) bound l []
753 -- lenBL (BL len _ _ _) = len
755 -- -----------------------------------------------------------------------------
756 -- | Set the interactive evaluation context.
758 -- Setting the context doesn't throw away any bindings; the bindings
759 -- we've built up in the InteractiveContext simply move to the new
760 -- module. They always shadow anything in scope in the current context.
761 setContext :: GhcMonad m =>
762 [Module] -- ^ entire top level scope of these modules
763 -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules
765 setContext toplev_mods other_mods = do
766 hsc_env <- getSession
767 let old_ic = hsc_IC hsc_env
768 hpt = hsc_HPT hsc_env
769 (decls,mods) = partition (isJust . snd) other_mods -- time for tracing
770 export_mods = map fst mods
771 imprt_decls = map noLoc (catMaybes (map snd decls))
773 export_env <- liftIO $ mkExportEnv hsc_env export_mods
775 if null imprt_decls then return emptyGlobalRdrEnv else do
776 let this_mod | null toplev_mods = pRELUDE
777 | otherwise = head toplev_mods
778 liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls
779 toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
780 let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
781 modifySession $ \_ ->
782 hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
783 ic_exports = other_mods,
784 ic_rn_gbl_env = all_env }}
786 -- Make a GlobalRdrEnv based on the exports of the modules only.
787 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
788 mkExportEnv hsc_env mods
789 = do { stuff <- mapM (getModuleExports hsc_env) mods
790 ; let (_msgs, mb_name_sets) = unzip stuff
791 envs = [ availsToGlobalRdrEnv (moduleName mod) avails
792 | (Just avails, mod) <- zip mb_name_sets mods ]
793 ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }
795 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
796 availsToGlobalRdrEnv mod_name avails
797 = mkGlobalRdrEnv (gresFromAvails imp_prov avails)
799 -- We're building a GlobalRdrEnv as if the user imported
800 -- all the specified modules into the global interactive module
801 imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
802 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
804 is_dloc = srcLocSpan interactiveSrcLoc }
806 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
808 = case lookupUFM hpt (moduleName modl) of
809 Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
810 showSDoc (ppr modl)))
812 case mi_globals (hm_iface details) of
814 ghcError (ProgramError ("mkTopLevEnv: not interpreted "
815 ++ showSDoc (ppr modl)))
816 Just env -> return env
818 -- | Get the interactive evaluation context, consisting of a pair of the
819 -- set of modules from which we take the full top-level scope, and the set
820 -- of modules from which we take just the exports respectively.
821 getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))])
822 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
823 return (ic_toplev_scope ic, ic_exports ic)
825 -- | Returns @True@ if the specified module is interpreted, and hence has
826 -- its full top-level scope available.
827 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
828 moduleIsInterpreted modl = withSession $ \h ->
829 if modulePackageId modl /= thisPackage (hsc_dflags h)
831 else case lookupUFM (hsc_HPT h) (moduleName modl) of
832 Just details -> return (isJust (mi_globals (hm_iface details)))
833 _not_a_home_module -> return False
835 -- | Looks up an identifier in the current interactive context (for :info)
836 -- Filter the instances by the ones whose tycons (or clases resp)
837 -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
838 -- The exact choice of which ones to show, and which to hide, is a judgement call.
840 getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
842 = withSession $ \hsc_env ->
843 do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
845 Nothing -> return Nothing
846 Just (thing, fixity, ispecs) -> do
847 let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
848 return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
850 plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env
851 = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
852 where -- A name is ok if it's in the rdr_env,
853 -- whether qualified or not
854 ok n | n == name = True -- The one we looked for in the first place!
855 | isBuiltInSyntax n = True
856 | isExternalName n = any ((== n) . gre_name)
857 (lookupGRE_Name rdr_env n)
860 -- | Returns all names in scope in the current interactive context
861 getNamesInScope :: GhcMonad m => m [Name]
862 getNamesInScope = withSession $ \hsc_env -> do
863 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
865 getRdrNamesInScope :: GhcMonad m => m [RdrName]
866 getRdrNamesInScope = withSession $ \hsc_env -> do
869 gbl_rdrenv = ic_rn_gbl_env ic
871 gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
872 lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
874 return (gbl_names ++ lcl_names)
877 -- ToDo: move to RdrName
878 greToRdrNames :: GlobalRdrElt -> [RdrName]
879 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
882 Imported specs -> concat (map do_spec (map is_decl specs))
884 occ = nameOccName name
887 | is_qual decl_spec = [qual]
888 | otherwise = [unqual,qual]
889 where qual = Qual (is_as decl_spec) occ
891 -- | Parses a string as an identifier, and returns the list of 'Name's that
892 -- the identifier can refer to in the current interactive context.
893 parseName :: GhcMonad m => String -> m [Name]
894 parseName str = withSession $ \hsc_env -> do
895 (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str
896 liftIO $ hscTcRnLookupRdrName hsc_env rdr_name
898 -- -----------------------------------------------------------------------------
899 -- Getting the type of an expression
901 -- | Get the type of an expression
902 exprType :: GhcMonad m => String -> m Type
903 exprType expr = withSession $ \hsc_env -> do
904 ty <- liftIO $ hscTcExpr hsc_env expr
905 return $ tidyType emptyTidyEnv ty
907 -- -----------------------------------------------------------------------------
908 -- Getting the kind of a type
910 -- | Get the kind of a type
911 typeKind :: GhcMonad m => String -> m Kind
912 typeKind str = withSession $ \hsc_env -> do
913 liftIO $ hscKcType hsc_env str
915 -----------------------------------------------------------------------------
916 -- cmCompileExpr: compile an expression and deliver an HValue
918 compileExpr :: GhcMonad m => String -> m HValue
919 compileExpr expr = withSession $ \hsc_env -> do
920 Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
922 hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
925 ([_],[hv]) -> return hv
926 _ -> panic "compileExpr"
928 -- -----------------------------------------------------------------------------
929 -- Compile an expression into a dynamic
931 dynCompileExpr :: GhcMonad m => String -> m Dynamic
932 dynCompileExpr expr = do
933 (full,exports) <- getContext
936 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
938 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
939 Just (ids, hvals) <- withSession $ \hsc_env ->
940 liftIO $ hscStmt hsc_env stmt
941 setContext full exports
942 vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
944 (_:[], v:[]) -> return v
945 _ -> panic "dynCompileExpr"
947 -----------------------------------------------------------------------------
948 -- show a module and it's source/object filenames
950 showModule :: GhcMonad m => ModSummary -> m String
951 showModule mod_summary =
952 withSession $ \hsc_env -> do
953 interpreted <- isModuleInterpreted mod_summary
954 return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
956 isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
957 isModuleInterpreted mod_summary = withSession $ \hsc_env ->
958 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
959 Nothing -> panic "missing linkable"
960 Just mod_info -> return (not obj_linkable)
962 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
964 ----------------------------------------------------------------------------
967 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
968 obtainTermFromVal hsc_env bound force ty x =
969 cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
971 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
972 obtainTermFromId hsc_env bound force id = do
973 hv <- Linker.getHValue hsc_env (varName id)
974 cvObtainTerm hsc_env bound force (idType id) hv
976 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
977 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
978 reconstructType hsc_env bound id = do
979 hv <- Linker.getHValue hsc_env (varName id)
980 cvReconstructType hsc_env bound (idType id) hv