Add dump flag for timing output
[ghc.git] / compiler / main / InteractiveEval.hs
1 {-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,
2 RecordWildCards, BangPatterns #-}
3
4 -- -----------------------------------------------------------------------------
5 --
6 -- (c) The University of Glasgow, 2005-2007
7 --
8 -- Running statements interactively
9 --
10 -- -----------------------------------------------------------------------------
11
12 module InteractiveEval (
13 Resume(..), History(..),
14 execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec,
15 runDecls, runDeclsWithLocation,
16 isStmt, hasImport, isImport, isDecl,
17 parseImportDecl, SingleStep(..),
18 abandon, abandonAll,
19 getResumeContext,
20 getHistorySpan,
21 getModBreaks,
22 getHistoryModule,
23 back, forward,
24 setContext, getContext,
25 availsToGlobalRdrEnv,
26 getNamesInScope,
27 getRdrNamesInScope,
28 moduleIsInterpreted,
29 getInfo,
30 exprType,
31 typeKind,
32 parseName,
33 showModule,
34 moduleIsBootOrNotObjectLinkable,
35 parseExpr, compileParsedExpr,
36 compileExpr, dynCompileExpr,
37 compileExprRemote, compileParsedExprRemote,
38 Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
39 ) where
40
41 #include "HsVersions.h"
42
43 import GhcPrelude
44
45 import InteractiveEvalTypes
46
47 import GHCi
48 import GHCi.Message
49 import GHCi.RemoteTypes
50 import GhcMonad
51 import HscMain
52 import HsSyn
53 import HscTypes
54 import InstEnv
55 import IfaceEnv ( newInteractiveBinder )
56 import FamInstEnv ( FamInst )
57 import CoreFVs ( orphNamesOfFamInst )
58 import TyCon
59 import Type hiding( typeKind )
60 import RepType
61 import TcType hiding( typeKind )
62 import Var
63 import Id
64 import Name hiding ( varName )
65 import NameSet
66 import Avail
67 import RdrName
68 import VarEnv
69 import ByteCodeTypes
70 import Linker
71 import DynFlags
72 import Unique
73 import UniqSupply
74 import MonadUtils
75 import Module
76 import PrelNames ( toDynName, pretendNameIsInScope )
77 import Panic
78 import Maybes
79 import ErrUtils
80 import SrcLoc
81 import RtClosureInspect
82 import Outputable
83 import FastString
84 import Bag
85 import Util
86 import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
87 import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport)
88
89 import System.Directory
90 import Data.Dynamic
91 import Data.Either
92 import qualified Data.IntMap as IntMap
93 import Data.List (find,intercalate)
94 import StringBuffer (stringToStringBuffer)
95 import Control.Monad
96 import GHC.Exts
97 import Data.Array
98 import Exception
99
100 -- -----------------------------------------------------------------------------
101 -- running a statement interactively
102
103 getResumeContext :: GhcMonad m => m [Resume]
104 getResumeContext = withSession (return . ic_resume . hsc_IC)
105
106 mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
107 mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)
108
109 getHistoryModule :: History -> Module
110 getHistoryModule = breakInfo_module . historyBreakInfo
111
112 getHistorySpan :: HscEnv -> History -> SrcSpan
113 getHistorySpan hsc_env History{..} =
114 let BreakInfo{..} = historyBreakInfo in
115 case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of
116 Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
117 _ -> panic "getHistorySpan"
118
119 getModBreaks :: HomeModInfo -> ModBreaks
120 getModBreaks hmi
121 | Just linkable <- hm_linkable hmi,
122 [BCOs cbc _] <- linkableUnlinked linkable
123 = fromMaybe emptyModBreaks (bc_breaks cbc)
124 | otherwise
125 = emptyModBreaks -- probably object code
126
127 {- | Finds the enclosing top level function name -}
128 -- ToDo: a better way to do this would be to keep hold of the decl_path computed
129 -- by the coverage pass, which gives the list of lexically-enclosing bindings
130 -- for each tick.
131 findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
132 findEnclosingDecls hsc_env (BreakInfo modl ix) =
133 let hmi = expectJust "findEnclosingDecls" $
134 lookupHpt (hsc_HPT hsc_env) (moduleName modl)
135 mb = getModBreaks hmi
136 in modBreaks_decls mb ! ix
137
138 -- | Update fixity environment in the current interactive context.
139 updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
140 updateFixityEnv fix_env = do
141 hsc_env <- getSession
142 let ic = hsc_IC hsc_env
143 setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
144
145 -- -----------------------------------------------------------------------------
146 -- execStmt
147
148 -- | default ExecOptions
149 execOptions :: ExecOptions
150 execOptions = ExecOptions
151 { execSingleStep = RunToCompletion
152 , execSourceFile = "<interactive>"
153 , execLineNumber = 1
154 , execWrap = EvalThis -- just run the statement, don't wrap it in anything
155 }
156
157 -- | Run a statement in the current interactive context.
158 execStmt
159 :: GhcMonad m
160 => String -- ^ a statement (bind or expression)
161 -> ExecOptions
162 -> m ExecResult
163 execStmt stmt ExecOptions{..} = do
164 hsc_env <- getSession
165
166 -- Turn off -fwarn-unused-local-binds when running a statement, to hide
167 -- warnings about the implicit bindings we introduce.
168 let ic = hsc_IC hsc_env -- use the interactive dflags
169 idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
170 hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }
171
172 -- compile to value (IO [HValue]), don't run
173 r <- liftIO $ hscStmtWithLocation hsc_env' stmt
174 execSourceFile execLineNumber
175
176 case r of
177 -- empty statement / comment
178 Nothing -> return (ExecComplete (Right []) 0)
179
180 Just (ids, hval, fix_env) -> do
181 updateFixityEnv fix_env
182
183 status <-
184 withVirtualCWD $
185 liftIO $
186 evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)
187
188 let ic = hsc_IC hsc_env
189 bindings = (ic_tythings ic, ic_rn_gbl_env ic)
190
191 size = ghciHistSize idflags'
192
193 handleRunStatus execSingleStep stmt bindings ids
194 status (emptyHistory size)
195
196
197 runDecls :: GhcMonad m => String -> m [Name]
198 runDecls = runDeclsWithLocation "<interactive>" 1
199
200 -- | Run some declarations and return any user-visible names that were brought
201 -- into scope.
202 runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
203 runDeclsWithLocation source linenumber expr =
204 do
205 hsc_env <- getSession
206 (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber
207
208 setSession $ hsc_env { hsc_IC = ic }
209 hsc_env <- getSession
210 hsc_env' <- liftIO $ rttiEnvironment hsc_env
211 setSession hsc_env'
212 return $ filter (not . isDerivedOccName . nameOccName)
213 -- For this filter, see Note [What to show to users]
214 $ map getName tyThings
215
216 {- Note [What to show to users]
217 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
218 We don't want to display internally-generated bindings to users.
219 Things like the coercion axiom for newtypes. These bindings all get
220 OccNames that users can't write, to avoid the possiblity of name
221 clashes (in linker symbols). That gives a convenient way to suppress
222 them. The relevant predicate is OccName.isDerivedOccName.
223 See Trac #11051 for more background and examples.
224 -}
225
226 withVirtualCWD :: GhcMonad m => m a -> m a
227 withVirtualCWD m = do
228 hsc_env <- getSession
229
230 -- a virtual CWD is only necessary when we're running interpreted code in
231 -- the same process as the compiler.
232 if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do
233
234 let ic = hsc_IC hsc_env
235 let set_cwd = do
236 dir <- liftIO $ getCurrentDirectory
237 case ic_cwd ic of
238 Just dir -> liftIO $ setCurrentDirectory dir
239 Nothing -> return ()
240 return dir
241
242 reset_cwd orig_dir = do
243 virt_dir <- liftIO $ getCurrentDirectory
244 hsc_env <- getSession
245 let old_IC = hsc_IC hsc_env
246 setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
247 liftIO $ setCurrentDirectory orig_dir
248
249 gbracket set_cwd reset_cwd $ \_ -> m
250
251 parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
252 parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
253
254 emptyHistory :: Int -> BoundedList History
255 emptyHistory size = nilBL size
256
257 handleRunStatus :: GhcMonad m
258 => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
259 -> EvalStatus_ [ForeignHValue] [HValueRef]
260 -> BoundedList History
261 -> m ExecResult
262
263 handleRunStatus step expr bindings final_ids status history
264 | RunAndLogSteps <- step = tracing
265 | otherwise = not_tracing
266 where
267 tracing
268 | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status
269 , not is_exception
270 = do
271 hsc_env <- getSession
272 let hmi = expectJust "handleRunStatus" $
273 lookupHptDirectly (hsc_HPT hsc_env)
274 (mkUniqueGrimily mod_uniq)
275 modl = mi_module (hm_iface hmi)
276 breaks = getModBreaks hmi
277
278 b <- liftIO $
279 breakpointStatus hsc_env (modBreaks_flags breaks) ix
280 if b
281 then not_tracing
282 -- This breakpoint is explicitly enabled; we want to stop
283 -- instead of just logging it.
284 else do
285 apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
286 let bi = BreakInfo modl ix
287 !history' = mkHistory hsc_env apStack_fhv bi `consBL` history
288 -- history is strict, otherwise our BoundedList is pointless.
289 fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
290 status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
291 handleRunStatus RunAndLogSteps expr bindings final_ids
292 status history'
293 | otherwise
294 = not_tracing
295
296 not_tracing
297 -- Hit a breakpoint
298 | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status
299 = do
300 hsc_env <- getSession
301 resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
302 apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
303 let hmi = expectJust "handleRunStatus" $
304 lookupHptDirectly (hsc_HPT hsc_env)
305 (mkUniqueGrimily mod_uniq)
306 modl = mi_module (hm_iface hmi)
307 bp | is_exception = Nothing
308 | otherwise = Just (BreakInfo modl ix)
309 (hsc_env1, names, span, decl) <- liftIO $
310 bindLocalsAtBreakpoint hsc_env apStack_fhv bp
311 let
312 resume = Resume
313 { resumeStmt = expr, resumeContext = resume_ctxt_fhv
314 , resumeBindings = bindings, resumeFinalIds = final_ids
315 , resumeApStack = apStack_fhv
316 , resumeBreakInfo = bp
317 , resumeSpan = span, resumeHistory = toListBL history
318 , resumeDecl = decl
319 , resumeCCS = ccs
320 , resumeHistoryIx = 0 }
321 hsc_env2 = pushResume hsc_env1 resume
322
323 setSession hsc_env2
324 return (ExecBreak names bp)
325
326 -- Completed successfully
327 | EvalComplete allocs (EvalSuccess hvals) <- status
328 = do hsc_env <- getSession
329 let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
330 final_names = map getName final_ids
331 liftIO $ Linker.extendLinkEnv (zip final_names hvals)
332 hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
333 setSession hsc_env'
334 return (ExecComplete (Right final_names) allocs)
335
336 -- Completed with an exception
337 | EvalComplete alloc (EvalException e) <- status
338 = return (ExecComplete (Left (fromSerializableException e)) alloc)
339
340 | otherwise
341 = panic "not_tracing" -- actually exhaustive, but GHC can't tell
342
343
344 resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
345 resumeExec canLogSpan step
346 = do
347 hsc_env <- getSession
348 let ic = hsc_IC hsc_env
349 resume = ic_resume ic
350
351 case resume of
352 [] -> liftIO $
353 throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
354 (r:rs) -> do
355 -- unbind the temporary locals by restoring the TypeEnv from
356 -- before the breakpoint, and drop this Resume from the
357 -- InteractiveContext.
358 let (resume_tmp_te,resume_rdr_env) = resumeBindings r
359 ic' = ic { ic_tythings = resume_tmp_te,
360 ic_rn_gbl_env = resume_rdr_env,
361 ic_resume = rs }
362 setSession hsc_env{ hsc_IC = ic' }
363
364 -- remove any bindings created since the breakpoint from the
365 -- linker's environment
366 let old_names = map getName resume_tmp_te
367 new_names = [ n | thing <- ic_tythings ic
368 , let n = getName thing
369 , not (n `elem` old_names) ]
370 liftIO $ Linker.deleteFromLinkEnv new_names
371
372 case r of
373 Resume { resumeStmt = expr, resumeContext = fhv
374 , resumeBindings = bindings, resumeFinalIds = final_ids
375 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt
376 , resumeSpan = span
377 , resumeHistory = hist } -> do
378 withVirtualCWD $ do
379 status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
380 let prevHistoryLst = fromListBL 50 hist
381 hist' = case mb_brkpt of
382 Nothing -> prevHistoryLst
383 Just bi
384 | not $canLogSpan span -> prevHistoryLst
385 | otherwise -> mkHistory hsc_env apStack bi `consBL`
386 fromListBL 50 hist
387 handleRunStatus step expr bindings final_ids status hist'
388
389 back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
390 back n = moveHist (+n)
391
392 forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
393 forward n = moveHist (subtract n)
394
395 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
396 moveHist fn = do
397 hsc_env <- getSession
398 case ic_resume (hsc_IC hsc_env) of
399 [] -> liftIO $
400 throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
401 (r:rs) -> do
402 let ix = resumeHistoryIx r
403 history = resumeHistory r
404 new_ix = fn ix
405 --
406 when (history `lengthLessThan` new_ix) $ liftIO $
407 throwGhcExceptionIO (ProgramError "no more logged breakpoints")
408 when (new_ix < 0) $ liftIO $
409 throwGhcExceptionIO (ProgramError "already at the beginning of the history")
410
411 let
412 update_ic apStack mb_info = do
413 (hsc_env1, names, span, decl) <-
414 liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
415 let ic = hsc_IC hsc_env1
416 r' = r { resumeHistoryIx = new_ix }
417 ic' = ic { ic_resume = r':rs }
418
419 setSession hsc_env1{ hsc_IC = ic' }
420
421 return (names, new_ix, span, decl)
422
423 -- careful: we want apStack to be the AP_STACK itself, not a thunk
424 -- around it, hence the cases are carefully constructed below to
425 -- make this the case. ToDo: this is v. fragile, do something better.
426 if new_ix == 0
427 then case r of
428 Resume { resumeApStack = apStack,
429 resumeBreakInfo = mb_brkpt } ->
430 update_ic apStack mb_brkpt
431 else case history !! (new_ix - 1) of
432 History{..} ->
433 update_ic historyApStack (Just historyBreakInfo)
434
435
436 -- -----------------------------------------------------------------------------
437 -- After stopping at a breakpoint, add free variables to the environment
438
439 result_fs :: FastString
440 result_fs = fsLit "_result"
441
442 bindLocalsAtBreakpoint
443 :: HscEnv
444 -> ForeignHValue
445 -> Maybe BreakInfo
446 -> IO (HscEnv, [Name], SrcSpan, String)
447
448 -- Nothing case: we stopped when an exception was raised, not at a
449 -- breakpoint. We have no location information or local variables to
450 -- bind, all we can do is bind a local variable to the exception
451 -- value.
452 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
453 let exn_occ = mkVarOccFS (fsLit "_exception")
454 span = mkGeneralSrcSpan (fsLit "<unknown>")
455 exn_name <- newInteractiveBinder hsc_env exn_occ span
456
457 let e_fs = fsLit "e"
458 e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
459 e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
460 exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
461
462 ictxt0 = hsc_IC hsc_env
463 ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
464 --
465 Linker.extendLinkEnv [(exn_name, apStack)]
466 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
467
468 -- Just case: we stopped at a breakpoint, we have information about the location
469 -- of the breakpoint and the free variables of the expression.
470 bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
471 let
472 hmi = expectJust "bindLocalsAtBreakpoint" $
473 lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)
474 breaks = getModBreaks hmi
475 info = expectJust "bindLocalsAtBreakpoint2" $
476 IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
477 vars = cgb_vars info
478 result_ty = cgb_resty info
479 occs = modBreaks_vars breaks ! breakInfo_number
480 span = modBreaks_locs breaks ! breakInfo_number
481 decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
482
483 -- Filter out any unboxed ids;
484 -- we can't bind these at the prompt
485 pointers = filter (\(id,_) -> isPointer id) vars
486 isPointer id | [rep] <- typePrimRep (idType id)
487 , isGcPtrRep rep = True
488 | otherwise = False
489
490 (ids, offsets) = unzip pointers
491
492 free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)
493
494 -- It might be that getIdValFromApStack fails, because the AP_STACK
495 -- has been accidentally evaluated, or something else has gone wrong.
496 -- So that we don't fall over in a heap when this happens, just don't
497 -- bind any free variables instead, and we emit a warning.
498 mb_hValues <-
499 mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets
500 when (any isNothing mb_hValues) $
501 debugTraceMsg (hsc_dflags hsc_env) 1 $
502 text "Warning: _result has been evaluated, some bindings have been lost"
503
504 us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time
505 let tv_subst = newTyVars us free_tvs
506 filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
507 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
508 map (substTy tv_subst . idType) filtered_ids
509
510 new_ids <- zipWith3M mkNewId occs tidy_tys filtered_ids
511 result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
512
513 let result_id = Id.mkVanillaGlobal result_name
514 (substTy tv_subst result_ty)
515 result_ok = isPointer result_id
516
517 final_ids | result_ok = result_id : new_ids
518 | otherwise = new_ids
519 ictxt0 = hsc_IC hsc_env
520 ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
521 names = map idName new_ids
522
523 let fhvs = catMaybes mb_hValues
524 Linker.extendLinkEnv (zip names fhvs)
525 when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
526 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
527 return (hsc_env1, if result_ok then result_name:names else names, span, decl)
528 where
529 -- We need a fresh Unique for each Id we bind, because the linker
530 -- state is single-threaded and otherwise we'd spam old bindings
531 -- whenever we stop at a breakpoint. The InteractveContext is properly
532 -- saved/restored, but not the linker state. See #1743, test break026.
533 mkNewId :: OccName -> Type -> Id -> IO Id
534 mkNewId occ ty old_id
535 = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
536 ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
537
538 newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
539 -- Similarly, clone the type variables mentioned in the types
540 -- we have here, *and* make them all RuntimeUnk tyvars
541 newTyVars us tvs
542 = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
543 | (tv, uniq) <- tvs `zip` uniqsFromSupply us
544 , let name = setNameUnique (tyVarName tv) uniq ]
545
546 rttiEnvironment :: HscEnv -> IO HscEnv
547 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
548 let tmp_ids = [id | AnId id <- ic_tythings ic]
549 incompletelyTypedIds =
550 [id | id <- tmp_ids
551 , not $ noSkolems id
552 , (occNameFS.nameOccName.idName) id /= result_fs]
553 hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
554 return hsc_env'
555 where
556 noSkolems = noFreeVarsOfType . idType
557 improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
558 let tmp_ids = [id | AnId id <- ic_tythings ic]
559 Just id = find (\i -> idName i == name) tmp_ids
560 if noSkolems id
561 then return hsc_env
562 else do
563 mb_new_ty <- reconstructType hsc_env 10 id
564 let old_ty = idType id
565 case mb_new_ty of
566 Nothing -> return hsc_env
567 Just new_ty -> do
568 case improveRTTIType hsc_env old_ty new_ty of
569 Nothing -> return $
570 WARN(True, text (":print failed to calculate the "
571 ++ "improvement for a type")) hsc_env
572 Just subst -> do
573 let dflags = hsc_dflags hsc_env
574 when (dopt Opt_D_dump_rtti dflags) $
575 printInfoForUser dflags alwaysQualify $
576 fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
577
578 let ic' = substInteractiveContext ic subst
579 return hsc_env{hsc_IC=ic'}
580
581 pushResume :: HscEnv -> Resume -> HscEnv
582 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
583 where
584 ictxt0 = hsc_IC hsc_env
585 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
586
587 -- -----------------------------------------------------------------------------
588 -- Abandoning a resume context
589
590 abandon :: GhcMonad m => m Bool
591 abandon = do
592 hsc_env <- getSession
593 let ic = hsc_IC hsc_env
594 resume = ic_resume ic
595 case resume of
596 [] -> return False
597 r:rs -> do
598 setSession hsc_env{ hsc_IC = ic { ic_resume = rs } }
599 liftIO $ abandonStmt hsc_env (resumeContext r)
600 return True
601
602 abandonAll :: GhcMonad m => m Bool
603 abandonAll = do
604 hsc_env <- getSession
605 let ic = hsc_IC hsc_env
606 resume = ic_resume ic
607 case resume of
608 [] -> return False
609 rs -> do
610 setSession hsc_env{ hsc_IC = ic { ic_resume = [] } }
611 liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs
612 return True
613
614 -- -----------------------------------------------------------------------------
615 -- Bounded list, optimised for repeated cons
616
617 data BoundedList a = BL
618 {-# UNPACK #-} !Int -- length
619 {-# UNPACK #-} !Int -- bound
620 [a] -- left
621 [a] -- right, list is (left ++ reverse right)
622
623 nilBL :: Int -> BoundedList a
624 nilBL bound = BL 0 bound [] []
625
626 consBL :: a -> BoundedList a -> BoundedList a
627 consBL a (BL len bound left right)
628 | len < bound = BL (len+1) bound (a:left) right
629 | null right = BL len bound [a] $! tail (reverse left)
630 | otherwise = BL len bound (a:left) $! tail right
631
632 toListBL :: BoundedList a -> [a]
633 toListBL (BL _ _ left right) = left ++ reverse right
634
635 fromListBL :: Int -> [a] -> BoundedList a
636 fromListBL bound l = BL (length l) bound l []
637
638 -- lenBL (BL len _ _ _) = len
639
640 -- -----------------------------------------------------------------------------
641 -- | Set the interactive evaluation context.
642 --
643 -- (setContext imports) sets the ic_imports field (which in turn
644 -- determines what is in scope at the prompt) to 'imports', and
645 -- constructs the ic_rn_glb_env environment to reflect it.
646 --
647 -- We retain in scope all the things defined at the prompt, and kept
648 -- in ic_tythings. (Indeed, they shadow stuff from ic_imports.)
649
650 setContext :: GhcMonad m => [InteractiveImport] -> m ()
651 setContext imports
652 = do { hsc_env <- getSession
653 ; let dflags = hsc_dflags hsc_env
654 ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
655 ; case all_env_err of
656 Left (mod, err) ->
657 liftIO $ throwGhcExceptionIO (formatError dflags mod err)
658 Right all_env -> do {
659 ; let old_ic = hsc_IC hsc_env
660 !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
661 ; setSession
662 hsc_env{ hsc_IC = old_ic { ic_imports = imports
663 , ic_rn_gbl_env = final_rdr_env }}}}
664 where
665 formatError dflags mod err = ProgramError . showSDoc dflags $
666 text "Cannot add module" <+> ppr mod <+>
667 text "to context:" <+> text err
668
669 findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
670 -> IO (Either (ModuleName, String) GlobalRdrEnv)
671 -- Compute the GlobalRdrEnv for the interactive context
672 findGlobalRdrEnv hsc_env imports
673 = do { idecls_env <- hscRnImportDecls hsc_env idecls
674 -- This call also loads any orphan modules
675 ; return $ case partitionEithers (map mkEnv imods) of
676 ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
677 (err : _, _) -> Left err }
678 where
679 idecls :: [LImportDecl GhcPs]
680 idecls = [noLoc d | IIDecl d <- imports]
681
682 imods :: [ModuleName]
683 imods = [m | IIModule m <- imports]
684
685 mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
686 Left err -> Left (mod, err)
687 Right env -> Right env
688
689 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
690 availsToGlobalRdrEnv mod_name avails
691 = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
692 where
693 -- We're building a GlobalRdrEnv as if the user imported
694 -- all the specified modules into the global interactive module
695 imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
696 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
697 is_qual = False,
698 is_dloc = srcLocSpan interactiveSrcLoc }
699
700 mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
701 mkTopLevEnv hpt modl
702 = case lookupHpt hpt modl of
703 Nothing -> Left "not a home module"
704 Just details ->
705 case mi_globals (hm_iface details) of
706 Nothing -> Left "not interpreted"
707 Just env -> Right env
708
709 -- | Get the interactive evaluation context, consisting of a pair of the
710 -- set of modules from which we take the full top-level scope, and the set
711 -- of modules from which we take just the exports respectively.
712 getContext :: GhcMonad m => m [InteractiveImport]
713 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
714 return (ic_imports ic)
715
716 -- | Returns @True@ if the specified module is interpreted, and hence has
717 -- its full top-level scope available.
718 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
719 moduleIsInterpreted modl = withSession $ \h ->
720 if moduleUnitId modl /= thisPackage (hsc_dflags h)
721 then return False
722 else case lookupHpt (hsc_HPT h) (moduleName modl) of
723 Just details -> return (isJust (mi_globals (hm_iface details)))
724 _not_a_home_module -> return False
725
726 -- | Looks up an identifier in the current interactive context (for :info)
727 -- Filter the instances by the ones whose tycons (or clases resp)
728 -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
729 -- The exact choice of which ones to show, and which to hide, is a judgement call.
730 -- (see Trac #1581)
731 getInfo :: GhcMonad m => Bool -> Name
732 -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc))
733 getInfo allInfo name
734 = withSession $ \hsc_env ->
735 do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
736 case mb_stuff of
737 Nothing -> return Nothing
738 Just (thing, fixity, cls_insts, fam_insts, docs) -> do
739 let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
740
741 -- Filter the instances based on whether the constituent names of their
742 -- instance heads are all in scope.
743 let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts
744 fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts
745 return (Just (thing, fixity, cls_insts', fam_insts', docs))
746 where
747 plausible rdr_env names
748 -- Dfun involving only names that are in ic_rn_glb_env
749 = allInfo
750 || nameSetAll ok names
751 where -- A name is ok if it's in the rdr_env,
752 -- whether qualified or not
753 ok n | n == name = True
754 -- The one we looked for in the first place!
755 | pretendNameIsInScope n = True
756 | isBuiltInSyntax n = True
757 | isExternalName n = isJust (lookupGRE_Name rdr_env n)
758 | otherwise = True
759
760 -- | Returns all names in scope in the current interactive context
761 getNamesInScope :: GhcMonad m => m [Name]
762 getNamesInScope = withSession $ \hsc_env -> do
763 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
764
765 -- | Returns all 'RdrName's in scope in the current interactive
766 -- context, excluding any that are internally-generated.
767 getRdrNamesInScope :: GhcMonad m => m [RdrName]
768 getRdrNamesInScope = withSession $ \hsc_env -> do
769 let
770 ic = hsc_IC hsc_env
771 gbl_rdrenv = ic_rn_gbl_env ic
772 gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv
773 -- Exclude internally generated names; see e.g. Trac #11328
774 return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)
775
776
777 -- | Parses a string as an identifier, and returns the list of 'Name's that
778 -- the identifier can refer to in the current interactive context.
779 parseName :: GhcMonad m => String -> m [Name]
780 parseName str = withSession $ \hsc_env -> liftIO $
781 do { lrdr_name <- hscParseIdentifier hsc_env str
782 ; hscTcRnLookupRdrName hsc_env lrdr_name }
783
784 -- | Returns @True@ if passed string is a statement.
785 isStmt :: DynFlags -> String -> Bool
786 isStmt dflags stmt =
787 case parseThing Parser.parseStmt dflags stmt of
788 Lexer.POk _ _ -> True
789 Lexer.PFailed _ _ _ -> False
790
791 -- | Returns @True@ if passed string has an import declaration.
792 hasImport :: DynFlags -> String -> Bool
793 hasImport dflags stmt =
794 case parseThing Parser.parseModule dflags stmt of
795 Lexer.POk _ thing -> hasImports thing
796 Lexer.PFailed _ _ _ -> False
797 where
798 hasImports = not . null . hsmodImports . unLoc
799
800 -- | Returns @True@ if passed string is an import declaration.
801 isImport :: DynFlags -> String -> Bool
802 isImport dflags stmt =
803 case parseThing Parser.parseImport dflags stmt of
804 Lexer.POk _ _ -> True
805 Lexer.PFailed _ _ _ -> False
806
807 -- | Returns @True@ if passed string is a declaration but __/not a splice/__.
808 isDecl :: DynFlags -> String -> Bool
809 isDecl dflags stmt = do
810 case parseThing Parser.parseDeclaration dflags stmt of
811 Lexer.POk _ thing ->
812 case unLoc thing of
813 SpliceD _ -> False
814 _ -> True
815 Lexer.PFailed _ _ _ -> False
816
817 parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
818 parseThing parser dflags stmt = do
819 let buf = stringToStringBuffer stmt
820 loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
821
822 Lexer.unP parser (Lexer.mkPState dflags buf loc)
823
824 -- -----------------------------------------------------------------------------
825 -- Getting the type of an expression
826
827 -- | Get the type of an expression
828 -- Returns the type as described by 'TcRnExprMode'
829 exprType :: GhcMonad m => TcRnExprMode -> String -> m Type
830 exprType mode expr = withSession $ \hsc_env -> do
831 ty <- liftIO $ hscTcExpr hsc_env mode expr
832 return $ tidyType emptyTidyEnv ty
833
834 -- -----------------------------------------------------------------------------
835 -- Getting the kind of a type
836
837 -- | Get the kind of a type
838 typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind)
839 typeKind normalise str = withSession $ \hsc_env -> do
840 liftIO $ hscKcType hsc_env normalise str
841
842 -----------------------------------------------------------------------------
843 -- Compile an expression, run it, and deliver the result
844
845 -- | Parse an expression, the parsed expression can be further processed and
846 -- passed to compileParsedExpr.
847 parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs)
848 parseExpr expr = withSession $ \hsc_env -> do
849 liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr
850
851 -- | Compile an expression, run it, and deliver the resulting HValue.
852 compileExpr :: GhcMonad m => String -> m HValue
853 compileExpr expr = do
854 parsed_expr <- parseExpr expr
855 compileParsedExpr parsed_expr
856
857 -- | Compile an expression, run it, and deliver the resulting HValue.
858 compileExprRemote :: GhcMonad m => String -> m ForeignHValue
859 compileExprRemote expr = do
860 parsed_expr <- parseExpr expr
861 compileParsedExprRemote parsed_expr
862
863 -- | Compile a parsed expression (before renaming), run it, and deliver
864 -- the resulting HValue.
865 compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue
866 compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
867 -- > let _compileParsedExpr = expr
868 -- Create let stmt from expr to make hscParsedStmt happy.
869 -- We will ignore the returned [Id], namely [expr_id], and not really
870 -- create a new binding.
871 let expr_fs = fsLit "_compileParsedExpr"
872 expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
873 let_stmt = L loc . LetStmt . L loc . HsValBinds $
874 ValBinds noExt
875 (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
876
877 Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
878 updateFixityEnv fix_env
879 status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
880 case status of
881 EvalComplete _ (EvalSuccess [hval]) -> return hval
882 EvalComplete _ (EvalException e) ->
883 liftIO $ throwIO (fromSerializableException e)
884 _ -> panic "compileParsedExpr"
885
886 compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue
887 compileParsedExpr expr = do
888 fhv <- compileParsedExprRemote expr
889 dflags <- getDynFlags
890 liftIO $ wormhole dflags fhv
891
892 -- | Compile an expression, run it and return the result as a Dynamic.
893 dynCompileExpr :: GhcMonad m => String -> m Dynamic
894 dynCompileExpr expr = do
895 parsed_expr <- parseExpr expr
896 -- > Data.Dynamic.toDyn expr
897 let loc = getLoc parsed_expr
898 to_dyn_expr = mkHsApp (L loc . HsVar noExt . L loc $ getRdrName toDynName)
899 parsed_expr
900 hval <- compileParsedExpr to_dyn_expr
901 return (unsafeCoerce# hval :: Dynamic)
902
903 -----------------------------------------------------------------------------
904 -- show a module and it's source/object filenames
905
906 showModule :: GhcMonad m => ModSummary -> m String
907 showModule mod_summary =
908 withSession $ \hsc_env -> do
909 interpreted <- moduleIsBootOrNotObjectLinkable mod_summary
910 let dflags = hsc_dflags hsc_env
911 return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)
912
913 moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
914 moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
915 case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
916 Nothing -> panic "missing linkable"
917 Just mod_info -> return $ case hm_linkable mod_info of
918 Nothing -> True
919 Just linkable -> not (isObjectLinkable linkable)
920
921 ----------------------------------------------------------------------------
922 -- RTTI primitives
923
924 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
925 obtainTermFromVal hsc_env bound force ty x =
926 cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
927
928 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
929 obtainTermFromId hsc_env bound force id = do
930 let dflags = hsc_dflags hsc_env
931 hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
932 cvObtainTerm hsc_env bound force (idType id) hv
933
934 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
935 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
936 reconstructType hsc_env bound id = do
937 let dflags = hsc_dflags hsc_env
938 hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
939 cvReconstructType hsc_env bound (idType id) hv
940
941 mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
942 mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk