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