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