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