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