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