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