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