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