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