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