InteractiveEval.hs 40.4 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2005-2007
--
-- Running statements interactively
--
-- -----------------------------------------------------------------------------

module InteractiveEval (
#ifdef GHCI
11
        RunResult(..), Status(..), Resume(..), History(..),
12
	runStmt, parseImportDecl, SingleStep(..),
13
        resume,
14 15
        abandon, abandonAll,
        getResumeContext,
16
        getHistorySpan,
17
        getModBreaks,
18
        getHistoryModule,
19
        back, forward,
20
	setContext, getContext,	
21
        availsToGlobalRdrEnv,
22 23 24 25 26 27 28 29 30 31 32
	getNamesInScope,
	getRdrNamesInScope,
	moduleIsInterpreted,
	getInfo,
	exprType,
	typeKind,
	parseName,
	showModule,
        isModuleInterpreted,
	compileExpr, dynCompileExpr,
	lookupName,
pepe's avatar
pepe committed
33
        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
mnislaih's avatar
mnislaih committed
34
        skolemiseSubst, skolemiseTy
35 36 37 38 39
#endif
        ) where

#ifdef GHCI

Ian Lynagh's avatar
Ian Lynagh committed
40 41
#include "HsVersions.h"

42
import HscMain          hiding (compileExpr)
43
import HsSyn (ImportDecl)
44 45
import HscTypes
import TcRnDriver
46 47
import TcRnMonad (initTc)
import RnNames		(gresFromAvails, rnImports)
48
import InstEnv
49 50
import Type
import TcType		hiding( typeKind )
51
import Var
52 53 54 55
import Id
import Name             hiding ( varName )
import NameSet
import RdrName
56
import PrelNames (pRELUDE)
57 58 59 60 61 62
import VarSet
import VarEnv
import ByteCodeInstr
import Linker
import DynFlags
import Unique
63
import UniqSupply
64 65
import Module
import Panic
66
import UniqFM
67
import Maybes
68
import ErrUtils
69 70
import Util
import SrcLoc
71
import BreakArray
72 73 74
import RtClosureInspect
import BasicTypes
import Outputable
75
import FastString
76
import MonadUtils
77

78
import System.Directory
79
import Data.Dynamic
80
import Data.List (find, partition)
81 82
import Control.Monad
import Foreign
83
import Foreign.C
84 85
import GHC.Exts
import Data.Array
86
import Exception
87
import Control.Concurrent
88
import Data.List (sortBy)
89
-- import Foreign.StablePtr
pepe's avatar
pepe committed
90
import System.IO
91 92 93 94 95 96 97

-- -----------------------------------------------------------------------------
-- running a statement interactively

data RunResult
  = RunOk [Name] 		-- ^ names bound by this evaluation
  | RunFailed	 		-- ^ statement failed compilation
98
  | RunException SomeException	-- ^ statement raised an exception
99
  | RunBreak ThreadId [Name] (Maybe BreakInfo)
100 101

data Status
102 103
   = Break Bool HValue BreakInfo ThreadId
          -- ^ the computation hit a breakpoint (Bool <=> was an exception)
104
   | Complete (Either SomeException [HValue])
105 106 107 108 109 110 111 112 113 114 115 116
          -- ^ the computation completed with either an exception or a value

data Resume
   = Resume {
       resumeStmt      :: String,       -- the original statement
       resumeThreadId  :: ThreadId,     -- thread running the computation
       resumeBreakMVar :: MVar (),   
       resumeStatMVar  :: MVar Status,
       resumeBindings  :: ([Id], TyVarSet),
       resumeFinalIds  :: [Id],         -- [Id] to bind on completion
       resumeApStack   :: HValue,       -- The object from which we can get
                                        -- value of the free variables.
117 118 119
       resumeBreakInfo :: Maybe BreakInfo,    
                                        -- the breakpoint we stopped at
                                        -- (Nothing <=> exception)
120
       resumeSpan      :: SrcSpan,      -- just a cache, otherwise it's a pain
121 122
                                        -- to fetch the ModDetails & ModBreaks
                                        -- to get this.
123 124
       resumeHistory   :: [History],
       resumeHistoryIx :: Int           -- 0 <==> at the top of the history
125 126
   }

127 128
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext = withSession (return . ic_resume . hsc_IC)
129 130 131 132 133 134

data SingleStep
   = RunToCompletion
   | SingleStep
   | RunAndLogSteps

135
isStep :: SingleStep -> Bool
136 137 138
isStep RunToCompletion = False
isStep _ = True

139 140 141
data History
   = History {
        historyApStack   :: HValue,
142
        historyBreakInfo :: BreakInfo,
143
        historyEnclosingDecl :: Id
mnislaih's avatar
mnislaih committed
144
         -- ^^ A cache of the enclosing top level declaration, for convenience
145
   }
146

147 148 149 150 151 152 153 154
mkHistory :: HscEnv -> HValue -> BreakInfo -> History
mkHistory hsc_env hval bi = let
    h    = History hval bi decl
    decl = findEnclosingDecl hsc_env (getHistoryModule h)
                                     (getHistorySpan hsc_env h)
    in h

getHistoryModule :: History -> Module
155 156
getHistoryModule = breakInfo_module . historyBreakInfo

157 158 159
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan hsc_env hist =
   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 166 167 168 169 170 171 172
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
  | Just linkable <- hm_linkable hmi, 
    [BCOs _ modBreaks] <- linkableUnlinked linkable
  = modBreaks
  | otherwise
  = emptyModBreaks -- probably object code

Simon Marlow's avatar
Simon Marlow committed
173 174 175 176
{- | Finds the enclosing top level function name -}
-- ToDo: a better way to do this would be to keep hold of the decl_path computed
-- by the coverage pass, which gives the list of lexically-enclosing bindings
-- for each tick.
177
findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
178
findEnclosingDecl hsc_env mod span =
mnislaih's avatar
mnislaih committed
179
   case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
180 181
         Nothing -> panic "findEnclosingDecl"
         Just hmi -> let
182 183 184 185 186 187 188
             globals   = typeEnvIds (md_types (hm_details hmi))
             Just decl = 
                 find (\id -> let n = idName id in 
                               nameSrcSpan n < span && isExternalName n)
                      (reverse$ sortBy (compare `on` (nameSrcSpan.idName))
                                       globals)
           in decl
189

190 191
-- | Run a statement in the current interactive context.  Statement
-- may bind multple values.
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219
runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
runStmt expr step =
  do
    hsc_env <- getSession

    breakMVar  <- liftIO $ newEmptyMVar  -- wait on this when we hit a breakpoint
    statusMVar <- liftIO $ newEmptyMVar  -- wait on this when a computation is running

    -- Turn off -fwarn-unused-bindings when running a statement, to hide
    -- warnings about the implicit bindings we introduce.
    let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
        hsc_env' = hsc_env{ hsc_dflags = dflags' }

    r <- hscStmt hsc_env' expr

    case r of
      Nothing -> return RunFailed -- empty statement / comment

      Just (ids, hval) -> do
          -- XXX: This is the only place we can print warnings before the
          -- result.  Is this really the right thing to do?  It's fine for
          -- GHCi, but what's correct for other GHC API clients?  We could
          -- introduce a callback argument.
        warns <- getWarnings
        liftIO $ printBagOfWarnings dflags' warns
        clearWarnings

        status <-
220
          withVirtualCWD $
221 222 223
            withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
                let thing_to_run = unsafeCoerce# hval :: IO [HValue]
                liftIO $ sandboxIO dflags' statusMVar thing_to_run
mnislaih's avatar
mnislaih committed
224
              
225 226
        let ic = hsc_IC hsc_env
            bindings = (ic_tmp_ids ic, ic_tyvars ic)
227

228 229 230 231 232 233 234
        case step of
          RunAndLogSteps ->
              traceRunStatus expr bindings ids
                             breakMVar statusMVar status emptyHistory
          _other ->
              handleRunStatus expr bindings ids
                               breakMVar statusMVar status emptyHistory
235

236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256
withVirtualCWD :: GhcMonad m => m a -> m a
withVirtualCWD m = do
  hsc_env <- getSession
  let ic = hsc_IC hsc_env

  let set_cwd = do
        dir <- liftIO $ getCurrentDirectory
        case ic_cwd ic of 
           Just dir -> liftIO $ setCurrentDirectory dir
           Nothing  -> return ()
        return dir

      reset_cwd orig_dir = do
        virt_dir <- liftIO $ getCurrentDirectory
        hsc_env <- getSession
        let old_IC = hsc_IC hsc_env
        setSession hsc_env{  hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
        liftIO $ setCurrentDirectory orig_dir

  gbracket set_cwd reset_cwd $ \_ -> m

257 258
parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr
259

260
emptyHistory :: BoundedList History
261 262
emptyHistory = nilBL 50 -- keep a log of length 50

263 264
handleRunStatus :: GhcMonad m =>
                   String-> ([Id], TyVarSet) -> [Id]
265
                -> MVar () -> MVar Status -> Status -> BoundedList History
266 267
                -> m RunResult
handleRunStatus expr bindings final_ids breakMVar statusMVar status
268
                history =
269 270
   case status of  
      -- did we hit a breakpoint or did we complete?
271
      (Break is_exception apStack info tid) -> do
272
        hsc_env <- getSession
273 274
        let mb_info | is_exception = Nothing
                    | otherwise    = Just info
275 276
        (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
                                                               mb_info
277 278
        let
            resume = Resume expr tid breakMVar statusMVar 
279
                              bindings final_ids apStack mb_info span 
280
                              (toListBL history) 0
281 282
            hsc_env2 = pushResume hsc_env1 resume
        --
283
        modifySession (\_ -> hsc_env2)
284
        return (RunBreak tid names mb_info)
285 286 287 288
      (Complete either_hvals) ->
	case either_hvals of
	    Left e -> return (RunException e)
	    Right hvals -> do
289
                hsc_env <- getSession
290 291 292 293
                let final_ic = extendInteractiveContext (hsc_IC hsc_env)
                                        final_ids emptyVarSet
                        -- the bound Ids never have any free TyVars
                    final_names = map idName final_ids
294 295 296
                liftIO $ Linker.extendLinkEnv (zip final_names hvals)
                hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
                modifySession (\_ -> hsc_env')
297 298
                return (RunOk final_names)

299 300
traceRunStatus :: GhcMonad m =>
                  String -> ([Id], TyVarSet) -> [Id]
301
               -> MVar () -> MVar Status -> Status -> BoundedList History
302 303
               -> m RunResult
traceRunStatus expr bindings final_ids
304
               breakMVar statusMVar status history = do
305
  hsc_env <- getSession
306 307 308
  case status of
     -- when tracing, if we hit a breakpoint that is not explicitly
     -- enabled, then we just log the event in the history and continue.
309
     (Break is_exception apStack info tid) | not is_exception -> do
310
        b <- liftIO $ isBreakEnabled hsc_env info
311 312 313
        if b
           then handle_normally
           else do
314
             let history' = mkHistory hsc_env apStack info `consBL` history
315 316
                -- probably better make history strict here, otherwise
                -- our BoundedList will be pointless.
317
             _ <- liftIO $ evaluate history'
318 319 320 321 322 323 324
             status <-
                 withBreakAction True (hsc_dflags hsc_env)
                                      breakMVar statusMVar $ do
                   liftIO $ withInterruptsSentTo tid $ do
                       putMVar breakMVar ()  -- awaken the stopped thread
                       takeMVar statusMVar   -- and wait for the result
             traceRunStatus expr bindings final_ids
325
                            breakMVar statusMVar status history'
326
     _other ->
327 328
        handle_normally
  where
329
        handle_normally = handleRunStatus expr bindings final_ids
330 331 332 333 334 335 336
                                          breakMVar statusMVar status history


isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
isBreakEnabled hsc_env inf =
   case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
       Just hmi -> do
337
         w <- getBreak (modBreaks_flags (getModBreaks hmi))
338 339 340 341 342
                       (breakInfo_number inf)
         case w of Just n -> return (n /= 0); _other -> return False
       _ ->
         return False

343

344 345 346
foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt
foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt

347 348 349
setStepFlag :: IO ()
setStepFlag = poke stepFlag 1
resetStepFlag :: IO ()
350
resetStepFlag = poke stepFlag 0
351 352

-- this points to the IO action that is executed when a breakpoint is hit
353 354
foreign import ccall "&rts_breakpoint_io_action" 
   breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) 
355 356 357 358 359

-- When running a computation, we redirect ^C exceptions to the running
-- thread.  ToDo: we might want a way to continue even if the target
-- thread doesn't die when it receives the exception... "this thread
-- is not responding".
360
-- 
Thomas Schilling's avatar
Thomas Schilling committed
361
-- Careful here: there may be ^C exceptions flying around, so we start the new
362
-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
Thomas Schilling's avatar
Thomas Schilling committed
363 364
-- only while we execute the user's code.  We can't afford to lose the final
-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
mnislaih's avatar
mnislaih committed
365
sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
366
sandboxIO dflags statusMVar thing =
367 368
   mask $ \restore -> do  -- fork starts blocked
     id <- forkIO $ do res <- Exception.try (restore $ rethrow dflags thing)
369 370 371
                       putMVar statusMVar (Complete res) -- empty: can't block
     withInterruptsSentTo id $ takeMVar statusMVar

372

Simon Marlow's avatar
Simon Marlow committed
373 374 375 376 377 378 379 380
-- We want to turn ^C into a break when -fbreak-on-exception is on,
-- but it's an async exception and we only break for sync exceptions.
-- Idea: if we catch and re-throw it, then the re-throw will trigger
-- a break.  Great - but we don't want to re-throw all exceptions, because
-- then we'll get a double break for ordinary sync exceptions (you'd have
-- to :continue twice, which looks strange).  So if the exception is
-- not "Interrupted", we unset the exception flag before throwing.
--
mnislaih's avatar
mnislaih committed
381
rethrow :: DynFlags -> IO a -> IO a
382
rethrow dflags io = Exception.catch io $ \se -> do
383 384 385 386 387
                   -- If -fbreak-on-error, we break unconditionally,
                   --  but with care of not breaking twice 
                if dopt Opt_BreakOnError dflags &&
                   not (dopt Opt_BreakOnException dflags)
                    then poke exceptionFlag 1
388
                    else case fromException se of
389
                         -- If it is a "UserInterrupt" exception, we allow
390
                         --  a possible break by way of -fbreak-on-exception
391
                         Just UserInterrupt -> return ()
392 393 394 395
                         -- In any other case, we don't want to break
                         _ -> poke exceptionFlag 0

                Exception.throwIO se
Simon Marlow's avatar
Simon Marlow committed
396

397 398 399
withInterruptsSentTo :: ThreadId -> IO r -> IO r
withInterruptsSentTo thread get_result = do
  bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
400
          (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
401
          (\_ -> get_result)
402

403 404 405 406
-- This function sets up the interpreter for catching breakpoints, and
-- resets everything when the computation has stopped running.  This
-- is a not-very-good way to ensure that only the interactive
-- evaluation should generate breakpoints.
407 408 409 410
withBreakAction :: (ExceptionMonad m, MonadIO m) =>
                   Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
withBreakAction step dflags breakMVar statusMVar act
 = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
411 412 413 414
 where
   setBreakAction = do
     stablePtr <- newStablePtr onBreak
     poke breakPointIOAction stablePtr
415 416
     when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
     when step $ setStepFlag
417
     return stablePtr
418 419 420
        -- Breaking on exceptions is not enabled by default, since it
        -- might be a bit surprising.  The exception flag is turned off
        -- as soon as it is hit, or in resetBreakAction below.
421

422
   onBreak is_exception info apStack = do
423
     tid <- myThreadId
424
     putMVar statusMVar (Break is_exception apStack info tid)
425 426 427 428
     takeMVar breakMVar

   resetBreakAction stablePtr = do
     poke breakPointIOAction noBreakStablePtr
429 430
     poke exceptionFlag 0
     resetStepFlag
431 432
     freeStablePtr stablePtr

433
noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
434
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
435

436 437 438
noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
noBreakAction True  _ _ = return () -- exception: just continue
439

440 441
resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
resume canLogSpan step
442
 = do
443
   hsc_env <- getSession
444 445 446 447
   let ic = hsc_IC hsc_env
       resume = ic_resume ic

   case resume of
448
     [] -> ghcError (ProgramError "not stopped at a breakpoint")
449 450 451 452 453 454 455 456
     (r:rs) -> do
        -- unbind the temporary locals by restoring the TypeEnv from
        -- before the breakpoint, and drop this Resume from the
        -- InteractiveContext.
        let (resume_tmp_ids, resume_tyvars) = resumeBindings r
            ic' = ic { ic_tmp_ids  = resume_tmp_ids,
                       ic_tyvars   = resume_tyvars,
                       ic_resume   = rs }
457
        modifySession (\_ -> hsc_env{ hsc_IC = ic' })
458 459 460 461 462
        
        -- remove any bindings created since the breakpoint from the 
        -- linker's environment
        let new_names = map idName (filter (`notElem` resume_tmp_ids)
                                           (ic_tmp_ids ic))
463
        liftIO $ Linker.deleteFromLinkEnv new_names
464
        
465
        when (isStep step) $ liftIO setStepFlag
466 467
        case r of 
          Resume expr tid breakMVar statusMVar bindings 
468
              final_ids apStack info span hist _ -> do
469
               withVirtualCWD $ do
470 471
                withBreakAction (isStep step) (hsc_dflags hsc_env) 
                                        breakMVar statusMVar $ do
472
                status <- liftIO $ withInterruptsSentTo tid $ do
473
                             putMVar breakMVar ()
474
                                      -- this awakens the stopped thread...
475
                             takeMVar statusMVar
476
                                      -- and wait for the result 
477 478 479 480 481 482
                let prevHistoryLst = fromListBL 50 hist
                    hist' = case info of
                       Nothing -> prevHistoryLst
                       Just i
                         | not $canLogSpan span -> prevHistoryLst
                         | otherwise -> mkHistory hsc_env apStack i `consBL`
483
                                                        fromListBL 50 hist
484 485
                case step of
                  RunAndLogSteps -> 
486
                        traceRunStatus expr bindings final_ids
487
                                       breakMVar statusMVar status hist'
488
                  _other ->
489
                        handleRunStatus expr bindings final_ids
490
                                        breakMVar statusMVar status hist'
491

492
back :: GhcMonad m => m ([Name], Int, SrcSpan)
493 494
back  = moveHist (+1)

495
forward :: GhcMonad m => m ([Name], Int, SrcSpan)
496 497
forward  = moveHist (subtract 1)

498 499 500
moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
moveHist fn = do
  hsc_env <- getSession
501
  case ic_resume (hsc_IC hsc_env) of
502
     [] -> ghcError (ProgramError "not stopped at a breakpoint")
503 504 505 506 507
     (r:rs) -> do
        let ix = resumeHistoryIx r
            history = resumeHistory r
            new_ix = fn ix
        --
508
        when (new_ix > length history) $
509
           ghcError (ProgramError "no more logged breakpoints")
510
        when (new_ix < 0) $
511
           ghcError (ProgramError "already at the beginning of the history")
512 513

        let
514
          update_ic apStack mb_info = do
515
            (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
516
                                                apStack mb_info
517 518 519 520
            let ic = hsc_IC hsc_env1           
                r' = r { resumeHistoryIx = new_ix }
                ic' = ic { ic_resume = r':rs }
            
521
            modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
522 523 524 525 526 527 528 529 530
            
            return (names, new_ix, span)

        -- careful: we want apStack to be the AP_STACK itself, not a thunk
        -- around it, hence the cases are carefully constructed below to
        -- make this the case.  ToDo: this is v. fragile, do something better.
        if new_ix == 0
           then case r of 
                   Resume { resumeApStack = apStack, 
531 532
                            resumeBreakInfo = mb_info } ->
                          update_ic apStack mb_info
533
           else case history !! (new_ix - 1) of 
534
                   History apStack info _ ->
535
                          update_ic apStack (Just info)
536 537 538

-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment
539
result_fs :: FastString
540
result_fs = fsLit "_result"
541

542 543 544
bindLocalsAtBreakpoint
        :: HscEnv
        -> HValue
545
        -> Maybe BreakInfo
546
        -> IO (HscEnv, [Name], SrcSpan)
547 548 549 550 551 552

-- Nothing case: we stopped when an exception was raised, not at a
-- breakpoint.  We have no location information or local variables to
-- bind, all we can do is bind a local variable to the exception
-- value.
bindLocalsAtBreakpoint hsc_env apStack Nothing = do
553
   let exn_fs    = fsLit "_exception"
554
       exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
555
       e_fs      = fsLit "e"
556
       e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
557
       e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
558
       exn_id    = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
559 560 561 562 563
       new_tyvars = unitVarSet e_tyvar

       ictxt0 = hsc_IC hsc_env
       ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars

564
       span = mkGeneralSrcSpan (fsLit "<exception thrown>")
565 566 567 568 569 570 571
   --
   Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)

-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
572 573

   let 
574 575 576 577
       mod_name  = moduleName (breakInfo_module info)
       hmi       = expectJust "bindLocalsAtBreakpoint" $ 
                        lookupUFM (hsc_HPT hsc_env) mod_name
       breaks    = getModBreaks hmi
578 579 580 581 582 583 584 585 586 587 588 589
       index     = breakInfo_number info
       vars      = breakInfo_vars info
       result_ty = breakInfo_resty info
       occs      = modBreaks_vars breaks ! index
       span      = modBreaks_locs breaks ! index

   -- filter out any unboxed ids; we can't bind these at the prompt
   let pointers = filter (\(id,_) -> isPointer id) vars
       isPointer id | PtrRep <- idPrimRep id = True
                    | otherwise              = False

   let (ids, offsets) = unzip pointers
590 591 592 593 594

   -- It might be that getIdValFromApStack fails, because the AP_STACK
   -- has been accidentally evaluated, or something else has gone wrong.
   -- So that we don't fall over in a heap when this happens, just don't
   -- bind any free variables instead, and we emit a warning.
595
   mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
596
   let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
597 598 599 600 601
   when (any isNothing mb_hValues) $
      debugTraceMsg (hsc_dflags hsc_env) 1 $
	  text "Warning: _result has been evaluated, some bindings have been lost"

   new_ids <- zipWithM mkNewId occs filtered_ids
602
   let names = map idName new_ids
603 604 605 606

   -- make an Id for _result.  We use the Unique of the FastString "_result";
   -- we don't care about uniqueness here, because there will only be one
   -- _result in scope at any time.
mnislaih's avatar
mnislaih committed
607
   let result_name = mkInternalName (getUnique result_fs)
608
                          (mkVarOccFS result_fs) span
609
       result_id   = Id.mkVanillaGlobal result_name result_ty 
610 611 612 613 614 615 616 617

   -- for each Id we're about to bind in the local envt:
   --    - skolemise the type variables in its type, so they can't
   --      be randomly unified with other types.  These type variables
   --      can only be resolved by type reconstruction in RtClosureInspect
   --    - tidy the type variables
   --    - globalise the Id (Ids are supposed to be Global, apparently).
   --
618 619 620 621 622
   let result_ok = isPointer result_id
                    && not (isUnboxedTupleType (idType result_id))

       all_ids | result_ok = result_id : new_ids
               | otherwise = new_ids
623 624 625
       (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
       new_tyvars = unionVarSets tyvarss             
626
       final_ids = zipWith setIdType all_ids tidy_tys
mnislaih's avatar
mnislaih committed
627 628
       ictxt0 = hsc_IC hsc_env
       ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
629

630
   Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
631
   when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
mnislaih's avatar
mnislaih committed
632
   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
633
   return (hsc_env1, if result_ok then result_name:names else names, span)
634 635 636
  where
   mkNewId :: OccName -> Id -> IO Id
   mkNewId occ id = do
637 638 639 640 641 642 643
     us <- mkSplitUniqSupply 'I'
        -- we need a fresh Unique for each Id we bind, because the linker
        -- state is single-threaded and otherwise we'd spam old bindings
        -- whenever we stop at a breakpoint.  The InteractveContext is properly
        -- saved/restored, but not the linker state.  See #1743, test break026.
     let 
         uniq = uniqFromSupply us
644
         loc = nameSrcSpan (idName id)
645
         name = mkInternalName uniq occ loc
646
         ty = idType id
647
         new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
648 649
     return new_id

mnislaih's avatar
mnislaih committed
650 651
rttiEnvironment :: HscEnv -> IO HscEnv 
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
mnislaih's avatar
mnislaih committed
652
   let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
mnislaih's avatar
mnislaih committed
653 654
       incompletelyTypedIds = 
           [id | id <- tmp_ids
pepe's avatar
pepe committed
655
               , not $ noSkolems id
mnislaih's avatar
mnislaih committed
656
               , (occNameFS.nameOccName.idName) id /= result_fs]
pepe's avatar
pepe committed
657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694
   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
   return hsc_env'
    where
     noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
      let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
          Just id = find (\i -> idName i == name) tmp_ids
      if noSkolems id
         then return hsc_env
         else do
           mb_new_ty <- reconstructType hsc_env 10 id
           let old_ty = idType id
           case mb_new_ty of
             Nothing -> return hsc_env
             Just new_ty -> do
              mb_subst <- improveRTTIType hsc_env old_ty new_ty
              case mb_subst of
               Nothing -> return $
                        WARN(True, text (":print failed to calculate the "
                                           ++ "improvement for a type")) hsc_env
               Just subst -> do
                 when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
                      printForUser stderr alwaysQualify $
                      fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]

                 let (subst', skols) = skolemiseSubst subst
                     ic' = extendInteractiveContext
                               (substInteractiveContext ic subst') [] skols
                 return hsc_env{hsc_IC=ic'}

skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
skolemiseSubst subst = let
    varenv               = getTvSubstEnv subst
    all_together         = mapVarEnv skolemiseTy varenv
    (varenv', skol_vars) = ( mapVarEnv fst all_together
                           , map snd (varEnvElts all_together))
    in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
                        
mnislaih's avatar
mnislaih committed
695

696 697 698 699 700 701 702 703 704 705 706 707
skolemiseTy :: Type -> (Type, TyVarSet)
skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
  where env           = mkVarEnv (zip tyvars new_tyvar_tys)
        subst         = mkTvSubst emptyInScopeSet env
        tyvars        = varSetElems (tyVarsOfType ty)
        new_tyvars    = map skolemiseTyVar tyvars
        new_tyvar_tys = map mkTyVarTy new_tyvars

skolemiseTyVar :: TyVar -> TyVar
skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) 
                                 (SkolemTv RuntimeUnkSkol)

708 709 710 711 712 713 714 715 716
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
   case getApStackVal# apStack (stackDepth +# 1#) of
                                -- The +1 is magic!  I don't know where it comes
                                -- from, but this makes things line up.  --SDM
        (# ok, result #) ->
            case ok of
              0# -> return Nothing -- AP_STACK not found
              _  -> return (Just (unsafeCoerce# result))
717 718 719 720 721 722 723 724 725 726

pushResume :: HscEnv -> Resume -> HscEnv
pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
  where
        ictxt0 = hsc_IC hsc_env
        ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }

-- -----------------------------------------------------------------------------
-- Abandoning a resume context

727 728 729
abandon :: GhcMonad m => m Bool
abandon = do
   hsc_env <- getSession
730 731 732 733
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
      []    -> return False
734
      r:rs  -> do 
735 736
         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
         liftIO $ abandon_ r
737 738
         return True

739 740 741
abandonAll :: GhcMonad m => m Bool
abandonAll = do
   hsc_env <- getSession
742 743 744
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
745 746
      []  -> return False
      rs  -> do 
747 748
         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
         liftIO $ mapM_ abandon_ rs
749 750
         return True

751 752 753 754 755 756 757 758 759 760 761 762 763 764
-- when abandoning a computation we have to 
--      (a) kill the thread with an async exception, so that the 
--          computation itself is stopped, and
--      (b) fill in the MVar.  This step is necessary because any
--          thunks that were under evaluation will now be updated
--          with the partial computation, which still ends in takeMVar,
--          so any attempt to evaluate one of these thunks will block
--          unless we fill in the MVar.
--  See test break010.
abandon_ :: Resume -> IO ()
abandon_ r = do
  killThread (resumeThreadId r)
  putMVar (resumeBreakMVar r) () 

765 766 767 768 769 770 771 772 773
-- -----------------------------------------------------------------------------
-- Bounded list, optimised for repeated cons

data BoundedList a = BL
                        {-# UNPACK #-} !Int  -- length
                        {-# UNPACK #-} !Int  -- bound
                        [a] -- left
                        [a] -- right,  list is (left ++ reverse right)

774 775 776
nilBL :: Int -> BoundedList a
nilBL bound = BL 0 bound [] []

777
consBL :: a -> BoundedList a -> BoundedList a
778 779
consBL a (BL len bound left right)
  | len < bound = BL (len+1) bound (a:left) right
780 781
  | null right  = BL len     bound [a]      $! tail (reverse left)
  | otherwise   = BL len     bound (a:left) $! tail right
782

783
toListBL :: BoundedList a -> [a]
784 785
toListBL (BL _ _ left right) = left ++ reverse right

786
fromListBL :: Int -> [a] -> BoundedList a
787 788
fromListBL bound l = BL (length l) bound l []

789
-- lenBL (BL len _ _ _) = len
790 791 792 793 794 795 796

-- -----------------------------------------------------------------------------
-- | Set the interactive evaluation context.
--
-- Setting the context doesn't throw away any bindings; the bindings
-- we've built up in the InteractiveContext simply move to the new
-- module.  They always shadow anything in scope in the current context.
797
setContext :: GhcMonad m =>
798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822
        [Module]	-- ^ entire top level scope of these modules
        -> [(Module, Maybe (ImportDecl RdrName))]	-- ^ exports of these modules
        -> m ()
setContext toplev_mods other_mods = do
    hsc_env <- getSession
    let old_ic  = hsc_IC     hsc_env
        hpt     = hsc_HPT    hsc_env
        (decls,mods)   = partition (isJust . snd) other_mods -- time for tracing
        export_mods = map fst mods
        imprt_decls = map noLoc (catMaybes (map snd decls))
    --
    export_env  <- liftIO $ mkExportEnv hsc_env export_mods
    import_env  <-
        if null imprt_decls then return emptyGlobalRdrEnv else do
            let imports = rnImports imprt_decls
                this_mod = if null toplev_mods then pRELUDE else head toplev_mods
            (_, env, _,_) <-
                ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports
            return env
    toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
    let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
    modifySession $ \_ ->
        hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
      			 ic_exports      = other_mods,
      			 ic_rn_gbl_env   = all_env }}
823 824 825

-- Make a GlobalRdrEnv based on the exports of the modules only.
mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
826 827 828 829 830 831 832 833 834 835
mkExportEnv hsc_env mods
  = do { stuff <- mapM (getModuleExports hsc_env) mods
       ; let (_msgs, mb_name_sets) = unzip stuff
	     envs = [ availsToGlobalRdrEnv (moduleName mod) avails
                    | (Just avails, mod) <- zip mb_name_sets mods ]
       ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }

availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv mod_name avails
  = mkGlobalRdrEnv (gresFromAvails imp_prov avails)
836
  where
837 838 839
      -- We're building a GlobalRdrEnv as if the user imported
      -- all the specified modules into the global interactive module
    imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
840 841 842 843 844 845 846
    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, 
			 is_qual = False, 
			 is_dloc = srcLocSpan interactiveSrcLoc }

mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
mkTopLevEnv hpt modl
  = case lookupUFM hpt (moduleName modl) of
847
      Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ 
848 849 850 851
                                                showSDoc (ppr modl)))
      Just details ->
	 case mi_globals (hm_iface details) of
		Nothing  -> 
852
		   ghcError (ProgramError ("mkTopLevEnv: not interpreted " 
853 854 855 856 857 858
						++ showSDoc (ppr modl)))
		Just env -> return env

-- | Get the interactive evaluation context, consisting of a pair of the
-- set of modules from which we take the full top-level scope, and the set
-- of modules from which we take just the exports respectively.
859
getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))])
860 861
getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
	       return (ic_toplev_scope ic, ic_exports ic)
862

863
-- | Returns @True@ if the specified module is interpreted, and hence has
864
-- its full top-level scope available.
865 866
moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted modl = withSession $ \h ->
867 868 869 870 871 872 873
 if modulePackageId modl /= thisPackage (hsc_dflags h)
        then return False
        else case lookupUFM (hsc_HPT h) (moduleName modl) of
                Just details       -> return (isJust (mi_globals (hm_iface details)))
                _not_a_home_module -> return False

-- | Looks up an identifier in the current interactive context (for :info)
874 875 876 877
-- Filter the instances by the ones whose tycons (or clases resp) 
-- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
-- The exact choice of which ones to show, and which to hide, is a judgement call.
-- 	(see Trac #1581)
878 879 880 881
getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
getInfo name
  = withSession $ \hsc_env ->
    do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
Thomas Schilling's avatar
Thomas Schilling committed
882 883 884 885 886
       case mb_stuff of
         Nothing -> return Nothing
         Just (thing, fixity, ispecs) -> do
           let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
           return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
887 888 889 890 891 892 893 894 895 896
  where
    plausible rdr_env ispec	-- Dfun involving only names that are in ic_rn_glb_env
	= all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
	where	-- A name is ok if it's in the rdr_env, 
		-- whether qualified or not
	  ok n | n == name	   = True	-- The one we looked for in the first place!
	       | isBuiltInSyntax n = True
	       | isExternalName n  = any ((== n) . gre_name)
					 (lookupGRE_Name rdr_env n)
	       | otherwise	   = True
897 898

-- | Returns all names in scope in the current interactive context
899 900
getNamesInScope :: GhcMonad m => m [Name]
getNamesInScope = withSession $ \hsc_env -> do
901 902
  return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))

903 904
getRdrNamesInScope :: GhcMonad m => m [RdrName]
getRdrNamesInScope = withSession $ \hsc_env -> do
905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930
  let 
      ic = hsc_IC hsc_env
      gbl_rdrenv = ic_rn_gbl_env ic
      ids = ic_tmp_ids ic
      gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
      lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
  --
  return (gbl_names ++ lcl_names)


-- ToDo: move to RdrName
greToRdrNames :: GlobalRdrElt -> [RdrName]
greToRdrNames GRE{ gre_name = name, gre_prov = prov }
  = case prov of
     LocalDef -> [unqual]
     Imported specs -> concat (map do_spec (map is_decl specs))
  where
    occ = nameOccName name
    unqual = Unqual occ
    do_spec decl_spec
	| is_qual decl_spec = [qual]
	| otherwise         = [unqual,qual]
	where qual = Qual (is_as decl_spec) occ

-- | Parses a string as an identifier, and returns the list of 'Name's that
-- the identifier can refer to in the current interactive context.
931 932 933 934
parseName :: GhcMonad m => String -> m [Name]
parseName str = withSession $ \hsc_env -> do
   (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
   ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
935 936 937

-- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
-- entity known to GHC, including 'Name's defined using 'runStmt'.
938 939 940 941 942
lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupName name = withSession $ \hsc_env -> do
  mb_tything <- ioMsg $ tcRnLookupName hsc_env name
  return mb_tything
  -- XXX: calls panic in some circumstances;  is that ok?
943 944 945 946 947

-- -----------------------------------------------------------------------------
-- Getting the type of an expression

-- | Get the type of an expression
948 949 950 951
exprType :: GhcMonad m => String -> m Type
exprType expr = withSession $ \hsc_env -> do
   ty <- hscTcExpr hsc_env expr
   return $ tidyType emptyTidyEnv ty
952 953 954 955 956

-- -----------------------------------------------------------------------------
-- Getting the kind of a type

-- | Get the kind of a  type
957 958 959
typeKind  :: GhcMonad m => String -> m Kind
typeKind str = withSession $ \hsc_env -> do
   hscKcType hsc_env str
960 961 962 963

-----------------------------------------------------------------------------
-- cmCompileExpr: compile an expression and deliver an HValue

964 965 966 967 968
compileExpr :: GhcMonad m => String -> m HValue
compileExpr expr = withSession $ \hsc_env -> do
  Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 		 -- Run it!
  hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
969

970 971 972
  case (ids,hvals) of
    ([_],[hv]) -> return hv
    _ 	     -> panic "compileExpr"
973 974 975 976

-- -----------------------------------------------------------------------------
-- Compile an expression into a dynamic

977 978 979 980
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr expr = do
    (full,exports) <- getContext
    setContext full $
981 982
        (mkModule
            (stringToPackageId "base") (mkModuleName "Data.Dynamic")
983
        ,Nothing):exports
984
    let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
985 986 987 988 989 990
    Just (ids, hvals) <- withSession (flip hscStmt stmt)
    setContext full exports
    vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
    case (ids,vals) of
        (_:[], v:[])    -> return v
        _               -> panic "dynCompileExpr"
991 992 993 994

-----------------------------------------------------------------------------
-- show a module and it's source/object filenames

995 996 997 998 999
showModule :: GhcMonad m => ModSummary -> m String
showModule mod_summary =
    withSession $ \hsc_env -> do
        interpreted <- isModuleInterpreted mod_summary
        return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
1000

1001 1002
isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
isModuleInterpreted mod_summary = withSession $ \hsc_env ->
1003 1004 1005 1006 1007 1008
  case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
	Nothing	      -> panic "missing linkable"
	Just mod_info -> return (not obj_linkable)
		      where
			 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))

mnislaih's avatar
mnislaih committed
1009 1010 1011
----------------------------------------------------------------------------
-- RTTI primitives

pepe's avatar
pepe committed
1012 1013 1014
obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
obtainTermFromVal hsc_env bound force ty x =
              cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
1015

pepe's avatar
pepe committed
1016 1017 1018 1019
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id =  do
              hv <- Linker.getHValue hsc_env (varName id)
              cvObtainTerm hsc_env bound force (idType id) hv
1020

mnislaih's avatar
mnislaih committed
1021
-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic