Fix #2044 (:printing impredicatively typed things)
[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 Control.Exception as 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
321 -- the new thread blocked (forkIO inherits block from the parent,
322 -- #1048), and unblock only while we execute the user's code. We
323 -- can't afford to lose the final putMVar, otherwise deadlock
324 -- ensues. (#1583, #1922, #1946)
325 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
326 sandboxIO dflags statusMVar thing =
327 block $ do -- fork starts blocked
328 id <- forkIO $ do res <- Exception.try (unblock $ rethrow dflags thing)
329 putMVar statusMVar (Complete res) -- empty: can't block
330 withInterruptsSentTo id $ takeMVar statusMVar
331
332
333 -- We want to turn ^C into a break when -fbreak-on-exception is on,
334 -- but it's an async exception and we only break for sync exceptions.
335 -- Idea: if we catch and re-throw it, then the re-throw will trigger
336 -- a break. Great - but we don't want to re-throw all exceptions, because
337 -- then we'll get a double break for ordinary sync exceptions (you'd have
338 -- to :continue twice, which looks strange). So if the exception is
339 -- not "Interrupted", we unset the exception flag before throwing.
340 --
341 rethrow :: DynFlags -> IO a -> IO a
342 rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
343 case e of
344 -- If -fbreak-on-error, we break unconditionally,
345 -- but with care of not breaking twice
346 _ | dopt Opt_BreakOnError dflags &&
347 not(dopt Opt_BreakOnException dflags)
348 -> poke exceptionFlag 1
349
350 -- If it is an "Interrupted" exception, we allow
351 -- a possible break by way of -fbreak-on-exception
352 DynException d | Just Interrupted <- fromDynamic d
353 -> return ()
354
355 -- In any other case, we don't want to break
356 _ -> poke exceptionFlag 0
357
358 Exception.throwIO e
359
360
361 withInterruptsSentTo :: ThreadId -> IO r -> IO r
362 withInterruptsSentTo thread get_result = do
363 bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
364 (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
365 (\_ -> get_result)
366
367 -- This function sets up the interpreter for catching breakpoints, and
368 -- resets everything when the computation has stopped running. This
369 -- is a not-very-good way to ensure that only the interactive
370 -- evaluation should generate breakpoints.
371 withBreakAction :: Bool -> DynFlags -> MVar () -> MVar Status -> IO a -> IO a
372 withBreakAction step dflags breakMVar statusMVar io
373 = bracket setBreakAction resetBreakAction (\_ -> io)
374 where
375 setBreakAction = do
376 stablePtr <- newStablePtr onBreak
377 poke breakPointIOAction stablePtr
378 when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
379 when step $ setStepFlag
380 return stablePtr
381 -- Breaking on exceptions is not enabled by default, since it
382 -- might be a bit surprising. The exception flag is turned off
383 -- as soon as it is hit, or in resetBreakAction below.
384
385 onBreak is_exception info apStack = do
386 tid <- myThreadId
387 putMVar statusMVar (Break is_exception apStack info tid)
388 takeMVar breakMVar
389
390 resetBreakAction stablePtr = do
391 poke breakPointIOAction noBreakStablePtr
392 poke exceptionFlag 0
393 resetStepFlag
394 freeStablePtr stablePtr
395
396 noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
397 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
398
399 noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
400 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
401 noBreakAction True _ _ = return () -- exception: just continue
402
403 resume :: Session -> SingleStep -> IO RunResult
404 resume (Session ref) step
405 = do
406 hsc_env <- readIORef ref
407 let ic = hsc_IC hsc_env
408 resume = ic_resume ic
409
410 case resume of
411 [] -> throwDyn (ProgramError "not stopped at a breakpoint")
412 (r:rs) -> do
413 -- unbind the temporary locals by restoring the TypeEnv from
414 -- before the breakpoint, and drop this Resume from the
415 -- InteractiveContext.
416 let (resume_tmp_ids, resume_tyvars) = resumeBindings r
417 ic' = ic { ic_tmp_ids = resume_tmp_ids,
418 ic_tyvars = resume_tyvars,
419 ic_resume = rs }
420 writeIORef ref hsc_env{ hsc_IC = ic' }
421
422 -- remove any bindings created since the breakpoint from the
423 -- linker's environment
424 let new_names = map idName (filter (`notElem` resume_tmp_ids)
425 (ic_tmp_ids ic))
426 Linker.deleteFromLinkEnv new_names
427
428 when (isStep step) $ setStepFlag
429 case r of
430 Resume expr tid breakMVar statusMVar bindings
431 final_ids apStack info _ hist _ -> do
432 withBreakAction (isStep step) (hsc_dflags hsc_env)
433 breakMVar statusMVar $ do
434 status <- withInterruptsSentTo tid $ do
435 putMVar breakMVar ()
436 -- this awakens the stopped thread...
437 takeMVar statusMVar
438 -- and wait for the result
439 let hist' =
440 case info of
441 Nothing -> fromListBL 50 hist
442 Just i -> mkHistory hsc_env apStack i `consBL`
443 fromListBL 50 hist
444 case step of
445 RunAndLogSteps ->
446 traceRunStatus expr ref bindings final_ids
447 breakMVar statusMVar status hist'
448 _other ->
449 handleRunStatus expr ref bindings final_ids
450 breakMVar statusMVar status hist'
451
452 back :: Session -> IO ([Name], Int, SrcSpan)
453 back = moveHist (+1)
454
455 forward :: Session -> IO ([Name], Int, SrcSpan)
456 forward = moveHist (subtract 1)
457
458 moveHist :: (Int -> Int) -> Session -> IO ([Name], Int, SrcSpan)
459 moveHist fn (Session ref) = do
460 hsc_env <- readIORef ref
461 case ic_resume (hsc_IC hsc_env) of
462 [] -> throwDyn (ProgramError "not stopped at a breakpoint")
463 (r:rs) -> do
464 let ix = resumeHistoryIx r
465 history = resumeHistory r
466 new_ix = fn ix
467 --
468 when (new_ix > length history) $
469 throwDyn (ProgramError "no more logged breakpoints")
470 when (new_ix < 0) $
471 throwDyn (ProgramError "already at the beginning of the history")
472
473 let
474 update_ic apStack mb_info = do
475 (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
476 apStack mb_info
477 let ic = hsc_IC hsc_env1
478 r' = r { resumeHistoryIx = new_ix }
479 ic' = ic { ic_resume = r':rs }
480
481 writeIORef ref hsc_env1{ hsc_IC = ic' }
482
483 return (names, new_ix, span)
484
485 -- careful: we want apStack to be the AP_STACK itself, not a thunk
486 -- around it, hence the cases are carefully constructed below to
487 -- make this the case. ToDo: this is v. fragile, do something better.
488 if new_ix == 0
489 then case r of
490 Resume { resumeApStack = apStack,
491 resumeBreakInfo = mb_info } ->
492 update_ic apStack mb_info
493 else case history !! (new_ix - 1) of
494 History apStack info _ ->
495 update_ic apStack (Just info)
496
497 -- -----------------------------------------------------------------------------
498 -- After stopping at a breakpoint, add free variables to the environment
499 result_fs :: FastString
500 result_fs = FSLIT("_result")
501
502 bindLocalsAtBreakpoint
503 :: HscEnv
504 -> HValue
505 -> Maybe BreakInfo
506 -> IO (HscEnv, [Name], SrcSpan)
507
508 -- Nothing case: we stopped when an exception was raised, not at a
509 -- breakpoint. We have no location information or local variables to
510 -- bind, all we can do is bind a local variable to the exception
511 -- value.
512 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
513 let exn_fs = FSLIT("_exception")
514 exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
515 e_fs = FSLIT("e")
516 e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
517 e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
518 exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
519 vanillaIdInfo
520 new_tyvars = unitVarSet e_tyvar
521
522 ictxt0 = hsc_IC hsc_env
523 ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
524
525 span = mkGeneralSrcSpan FSLIT("<exception thrown>")
526 --
527 Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
528 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
529
530 -- Just case: we stopped at a breakpoint, we have information about the location
531 -- of the breakpoint and the free variables of the expression.
532 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
533
534 let
535 mod_name = moduleName (breakInfo_module info)
536 hmi = expectJust "bindLocalsAtBreakpoint" $
537 lookupUFM (hsc_HPT hsc_env) mod_name
538 breaks = getModBreaks hmi
539 index = breakInfo_number info
540 vars = breakInfo_vars info
541 result_ty = breakInfo_resty info
542 occs = modBreaks_vars breaks ! index
543 span = modBreaks_locs breaks ! index
544
545 -- filter out any unboxed ids; we can't bind these at the prompt
546 let pointers = filter (\(id,_) -> isPointer id) vars
547 isPointer id | PtrRep <- idPrimRep id = True
548 | otherwise = False
549
550 let (ids, offsets) = unzip pointers
551
552 -- It might be that getIdValFromApStack fails, because the AP_STACK
553 -- has been accidentally evaluated, or something else has gone wrong.
554 -- So that we don't fall over in a heap when this happens, just don't
555 -- bind any free variables instead, and we emit a warning.
556 mb_hValues <- mapM (getIdValFromApStack apStack) offsets
557 let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
558 when (any isNothing mb_hValues) $
559 debugTraceMsg (hsc_dflags hsc_env) 1 $
560 text "Warning: _result has been evaluated, some bindings have been lost"
561
562 new_ids <- zipWithM mkNewId occs filtered_ids
563 let names = map idName new_ids
564
565 -- make an Id for _result. We use the Unique of the FastString "_result";
566 -- we don't care about uniqueness here, because there will only be one
567 -- _result in scope at any time.
568 let result_name = mkInternalName (getUnique result_fs)
569 (mkVarOccFS result_fs) span
570 result_id = Id.mkGlobalId VanillaGlobal result_name result_ty
571 vanillaIdInfo
572
573 -- for each Id we're about to bind in the local envt:
574 -- - skolemise the type variables in its type, so they can't
575 -- be randomly unified with other types. These type variables
576 -- can only be resolved by type reconstruction in RtClosureInspect
577 -- - tidy the type variables
578 -- - globalise the Id (Ids are supposed to be Global, apparently).
579 --
580 let all_ids | isPointer result_id = result_id : new_ids
581 | otherwise = new_ids
582 (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
583 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
584 new_tyvars = unionVarSets tyvarss
585 let final_ids = zipWith setIdType all_ids tidy_tys
586 ictxt0 = hsc_IC hsc_env
587 ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
588 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
589 Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
590 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
591 return (hsc_env1, result_name:names, span)
592 where
593 mkNewId :: OccName -> Id -> IO Id
594 mkNewId occ id = do
595 us <- mkSplitUniqSupply 'I'
596 -- we need a fresh Unique for each Id we bind, because the linker
597 -- state is single-threaded and otherwise we'd spam old bindings
598 -- whenever we stop at a breakpoint. The InteractveContext is properly
599 -- saved/restored, but not the linker state. See #1743, test break026.
600 let
601 uniq = uniqFromSupply us
602 loc = nameSrcSpan (idName id)
603 name = mkInternalName uniq occ loc
604 ty = idType id
605 new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
606 return new_id
607
608 rttiEnvironment :: HscEnv -> IO HscEnv
609 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
610 let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
611 incompletelyTypedIds =
612 [id | id <- tmp_ids
613 , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
614 , isSkolemTyVar v]
615 , (occNameFS.nameOccName.idName) id /= result_fs]
616 tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
617 -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
618
619 improvs <- sequence [improveRTTIType hsc_env ty ty'
620 | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
621 let ic' = foldr (\mb_subst ic' ->
622 maybe (WARN(True, text ("RTTI failed to calculate the "
623 ++ "improvement for a type")) ic')
624 (substInteractiveContext ic' . skolemiseSubst)
625 mb_subst)
626 ic
627 improvs
628 return hsc_env{hsc_IC=ic'}
629
630 skolemiseSubst :: TvSubst -> TvSubst
631 skolemiseSubst subst = subst `setTvSubstEnv`
632 mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
633
634 skolemiseTy :: Type -> (Type, TyVarSet)
635 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
636 where env = mkVarEnv (zip tyvars new_tyvar_tys)
637 subst = mkTvSubst emptyInScopeSet env
638 tyvars = varSetElems (tyVarsOfType ty)
639 new_tyvars = map skolemiseTyVar tyvars
640 new_tyvar_tys = map mkTyVarTy new_tyvars
641
642 skolemiseTyVar :: TyVar -> TyVar
643 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
644 (SkolemTv RuntimeUnkSkol)
645
646 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
647 getIdValFromApStack apStack (I# stackDepth) = do
648 case getApStackVal# apStack (stackDepth +# 1#) of
649 -- The +1 is magic! I don't know where it comes
650 -- from, but this makes things line up. --SDM
651 (# ok, result #) ->
652 case ok of
653 0# -> return Nothing -- AP_STACK not found
654 _ -> return (Just (unsafeCoerce# result))
655
656 pushResume :: HscEnv -> Resume -> HscEnv
657 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
658 where
659 ictxt0 = hsc_IC hsc_env
660 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
661
662 -- -----------------------------------------------------------------------------
663 -- Abandoning a resume context
664
665 abandon :: Session -> IO Bool
666 abandon (Session ref) = do
667 hsc_env <- readIORef ref
668 let ic = hsc_IC hsc_env
669 resume = ic_resume ic
670 case resume of
671 [] -> return False
672 r:rs -> do
673 writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
674 abandon_ r
675 return True
676
677 abandonAll :: Session -> IO Bool
678 abandonAll (Session ref) = do
679 hsc_env <- readIORef ref
680 let ic = hsc_IC hsc_env
681 resume = ic_resume ic
682 case resume of
683 [] -> return False
684 rs -> do
685 writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
686 mapM_ abandon_ rs
687 return True
688
689 -- when abandoning a computation we have to
690 -- (a) kill the thread with an async exception, so that the
691 -- computation itself is stopped, and
692 -- (b) fill in the MVar. This step is necessary because any
693 -- thunks that were under evaluation will now be updated
694 -- with the partial computation, which still ends in takeMVar,
695 -- so any attempt to evaluate one of these thunks will block
696 -- unless we fill in the MVar.
697 -- See test break010.
698 abandon_ :: Resume -> IO ()
699 abandon_ r = do
700 killThread (resumeThreadId r)
701 putMVar (resumeBreakMVar r) ()
702
703 -- -----------------------------------------------------------------------------
704 -- Bounded list, optimised for repeated cons
705
706 data BoundedList a = BL
707 {-# UNPACK #-} !Int -- length
708 {-# UNPACK #-} !Int -- bound
709 [a] -- left
710 [a] -- right, list is (left ++ reverse right)
711
712 nilBL :: Int -> BoundedList a
713 nilBL bound = BL 0 bound [] []
714
715 consBL :: a -> BoundedList a -> BoundedList a
716 consBL a (BL len bound left right)
717 | len < bound = BL (len+1) bound (a:left) right
718 | null right = BL len bound [a] $! tail (reverse left)
719 | otherwise = BL len bound (a:left) $! tail right
720
721 toListBL :: BoundedList a -> [a]
722 toListBL (BL _ _ left right) = left ++ reverse right
723
724 fromListBL :: Int -> [a] -> BoundedList a
725 fromListBL bound l = BL (length l) bound l []
726
727 -- lenBL (BL len _ _ _) = len
728
729 -- -----------------------------------------------------------------------------
730 -- | Set the interactive evaluation context.
731 --
732 -- Setting the context doesn't throw away any bindings; the bindings
733 -- we've built up in the InteractiveContext simply move to the new
734 -- module. They always shadow anything in scope in the current context.
735 setContext :: Session
736 -> [Module] -- entire top level scope of these modules
737 -> [Module] -- exports only of these modules
738 -> IO ()
739 setContext (Session ref) toplev_mods export_mods = do
740 hsc_env <- readIORef ref
741 let old_ic = hsc_IC hsc_env
742 hpt = hsc_HPT hsc_env
743 --
744 export_env <- mkExportEnv hsc_env export_mods
745 toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
746 let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
747 writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
748 ic_exports = export_mods,
749 ic_rn_gbl_env = all_env }}
750
751 -- Make a GlobalRdrEnv based on the exports of the modules only.
752 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
753 mkExportEnv hsc_env mods = do
754 stuff <- mapM (getModuleExports hsc_env) mods
755 let
756 (_msgs, mb_name_sets) = unzip stuff
757 gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
758 | (Just avails, mod) <- zip mb_name_sets mods ]
759 --
760 return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
761
762 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
763 nameSetToGlobalRdrEnv names mod =
764 mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
765 | name <- nameSetToList names ]
766
767 vanillaProv :: ModuleName -> Provenance
768 -- We're building a GlobalRdrEnv as if the user imported
769 -- all the specified modules into the global interactive module
770 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
771 where
772 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
773 is_qual = False,
774 is_dloc = srcLocSpan interactiveSrcLoc }
775
776 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
777 mkTopLevEnv hpt modl
778 = case lookupUFM hpt (moduleName modl) of
779 Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
780 showSDoc (ppr modl)))
781 Just details ->
782 case mi_globals (hm_iface details) of
783 Nothing ->
784 throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
785 ++ showSDoc (ppr modl)))
786 Just env -> return env
787
788 -- | Get the interactive evaluation context, consisting of a pair of the
789 -- set of modules from which we take the full top-level scope, and the set
790 -- of modules from which we take just the exports respectively.
791 getContext :: Session -> IO ([Module],[Module])
792 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
793 return (ic_toplev_scope ic, ic_exports ic))
794
795 -- | Returns 'True' if the specified module is interpreted, and hence has
796 -- its full top-level scope available.
797 moduleIsInterpreted :: Session -> Module -> IO Bool
798 moduleIsInterpreted s modl = withSession s $ \h ->
799 if modulePackageId modl /= thisPackage (hsc_dflags h)
800 then return False
801 else case lookupUFM (hsc_HPT h) (moduleName modl) of
802 Just details -> return (isJust (mi_globals (hm_iface details)))
803 _not_a_home_module -> return False
804
805 -- | Looks up an identifier in the current interactive context (for :info)
806 -- Filter the instances by the ones whose tycons (or clases resp)
807 -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
808 -- The exact choice of which ones to show, and which to hide, is a judgement call.
809 -- (see Trac #1581)
810 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
811 getInfo s name
812 = withSession s $ \hsc_env ->
813 do { mb_stuff <- tcRnGetInfo hsc_env name
814 ; case mb_stuff of
815 Nothing -> return Nothing
816 Just (thing, fixity, ispecs) -> do
817 { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
818 ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } }
819 where
820 plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env
821 = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
822 where -- A name is ok if it's in the rdr_env,
823 -- whether qualified or not
824 ok n | n == name = True -- The one we looked for in the first place!
825 | isBuiltInSyntax n = True
826 | isExternalName n = any ((== n) . gre_name)
827 (lookupGRE_Name rdr_env n)
828 | otherwise = True
829
830 -- | Returns all names in scope in the current interactive context
831 getNamesInScope :: Session -> IO [Name]
832 getNamesInScope s = withSession s $ \hsc_env -> do
833 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
834
835 getRdrNamesInScope :: Session -> IO [RdrName]
836 getRdrNamesInScope s = withSession s $ \hsc_env -> do
837 let
838 ic = hsc_IC hsc_env
839 gbl_rdrenv = ic_rn_gbl_env ic
840 ids = ic_tmp_ids ic
841 gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
842 lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
843 --
844 return (gbl_names ++ lcl_names)
845
846
847 -- ToDo: move to RdrName
848 greToRdrNames :: GlobalRdrElt -> [RdrName]
849 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
850 = case prov of
851 LocalDef -> [unqual]
852 Imported specs -> concat (map do_spec (map is_decl specs))
853 where
854 occ = nameOccName name
855 unqual = Unqual occ
856 do_spec decl_spec
857 | is_qual decl_spec = [qual]
858 | otherwise = [unqual,qual]
859 where qual = Qual (is_as decl_spec) occ
860
861 -- | Parses a string as an identifier, and returns the list of 'Name's that
862 -- the identifier can refer to in the current interactive context.
863 parseName :: Session -> String -> IO [Name]
864 parseName s str = withSession s $ \hsc_env -> do
865 maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
866 case maybe_rdr_name of
867 Nothing -> return []
868 Just (L _ rdr_name) -> do
869 mb_names <- tcRnLookupRdrName hsc_env rdr_name
870 case mb_names of
871 Nothing -> return []
872 Just ns -> return ns
873 -- ToDo: should return error messages
874
875 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
876 -- entity known to GHC, including 'Name's defined using 'runStmt'.
877 lookupName :: Session -> Name -> IO (Maybe TyThing)
878 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
879
880 -- -----------------------------------------------------------------------------
881 -- Getting the type of an expression
882
883 -- | Get the type of an expression
884 exprType :: Session -> String -> IO (Maybe Type)
885 exprType s expr = withSession s $ \hsc_env -> do
886 maybe_stuff <- hscTcExpr hsc_env expr
887 case maybe_stuff of
888 Nothing -> return Nothing
889 Just ty -> return (Just tidy_ty)
890 where
891 tidy_ty = tidyType emptyTidyEnv ty
892
893 -- -----------------------------------------------------------------------------
894 -- Getting the kind of a type
895
896 -- | Get the kind of a type
897 typeKind :: Session -> String -> IO (Maybe Kind)
898 typeKind s str = withSession s $ \hsc_env -> do
899 maybe_stuff <- hscKcType hsc_env str
900 case maybe_stuff of
901 Nothing -> return Nothing
902 Just kind -> return (Just kind)
903
904 -----------------------------------------------------------------------------
905 -- cmCompileExpr: compile an expression and deliver an HValue
906
907 compileExpr :: Session -> String -> IO (Maybe HValue)
908 compileExpr s expr = withSession s $ \hsc_env -> do
909 maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
910 case maybe_stuff of
911 Nothing -> return Nothing
912 Just (ids, hval) -> do
913 -- Run it!
914 hvals <- (unsafeCoerce# hval) :: IO [HValue]
915
916 case (ids,hvals) of
917 ([_],[hv]) -> return (Just hv)
918 _ -> panic "compileExpr"
919
920 -- -----------------------------------------------------------------------------
921 -- Compile an expression into a dynamic
922
923 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
924 dynCompileExpr ses expr = do
925 (full,exports) <- getContext ses
926 setContext ses full $
927 (mkModule
928 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
929 ):exports
930 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
931 res <- withSession ses (flip hscStmt stmt)
932 setContext ses full exports
933 case res of
934 Nothing -> return Nothing
935 Just (ids, hvals) -> do
936 vals <- (unsafeCoerce# hvals :: IO [Dynamic])
937 case (ids,vals) of
938 (_:[], v:[]) -> return (Just v)
939 _ -> panic "dynCompileExpr"
940
941 -----------------------------------------------------------------------------
942 -- show a module and it's source/object filenames
943
944 showModule :: Session -> ModSummary -> IO String
945 showModule s mod_summary = withSession s $ \hsc_env ->
946 isModuleInterpreted s mod_summary >>= \interpreted ->
947 return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
948
949 isModuleInterpreted :: Session -> ModSummary -> IO Bool
950 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
951 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
952 Nothing -> panic "missing linkable"
953 Just mod_info -> return (not obj_linkable)
954 where
955 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
956
957 ----------------------------------------------------------------------------
958 -- RTTI primitives
959
960 obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
961 obtainTerm1 hsc_env force mb_ty x =
962 cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
963
964 obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
965 obtainTermB hsc_env bound force id = do
966 hv <- Linker.getHValue hsc_env (varName id)
967 cvObtainTerm hsc_env bound force (Just$ idType id) hv
968
969 obtainTerm :: HscEnv -> Bool -> Id -> IO Term
970 obtainTerm hsc_env force id = do
971 hv <- Linker.getHValue hsc_env (varName id)
972 cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
973
974 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
975 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
976 reconstructType hsc_env bound id = do
977 hv <- Linker.getHValue hsc_env (varName id)
978 cvReconstructType hsc_env bound (Just$ idType id) hv
979 #endif /* GHCI */