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