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