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