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