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