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