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