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