InteractiveEval.hs 41.3 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(..),
dterei's avatar
dterei committed
12
        runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
vivian's avatar
vivian committed
13
        parseImportDecl, SingleStep(..),
14
        resume,
15 16
        abandon, abandonAll,
        getResumeContext,
17
        getHistorySpan,
18
        getModBreaks,
19
        getHistoryModule,
20
        back, forward,
dterei's avatar
dterei committed
21
        setContext, getContext,
22
        availsToGlobalRdrEnv,
dterei's avatar
dterei committed
23 24 25 26 27 28 29 30
        getNamesInScope,
        getRdrNamesInScope,
        moduleIsInterpreted,
        getInfo,
        exprType,
        typeKind,
        parseName,
        showModule,
31
        isModuleInterpreted,
dterei's avatar
dterei committed
32
        compileExpr, dynCompileExpr,
33
        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
34 35 36 37 38
#endif
        ) where

#ifdef GHCI

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

41 42
import GhcMonad
import HscMain
43
import HsSyn
44 45
import HscTypes
import InstEnv
46
import TyCon
batterseapower's avatar
batterseapower committed
47
import Type     hiding( typeKind )
dterei's avatar
dterei committed
48
import TcType           hiding( typeKind )
49
import Var
50 51 52
import Id
import Name             hiding ( varName )
import NameSet
53
import Avail
54 55 56 57 58 59 60
import RdrName
import VarSet
import VarEnv
import ByteCodeInstr
import Linker
import DynFlags
import Unique
61
import UniqSupply
62 63
import Module
import Panic
64
import UniqFM
65
import Maybes
66
import ErrUtils
67
import SrcLoc
68
import BreakArray
69 70
import RtClosureInspect
import Outputable
71
import FastString
72
import MonadUtils
73

74
import System.Directory
75
import Data.Dynamic
76
import Data.Either
77
import Data.List (find)
78
import Control.Monad
79
import Foreign.Safe
80
import Foreign.C
81 82
import GHC.Exts
import Data.Array
83
import Exception
84
import Control.Concurrent
Ross Paterson's avatar
Ross Paterson committed
85
import System.IO.Unsafe
86 87 88 89 90

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

data RunResult
dterei's avatar
dterei committed
91
  = RunOk [Name]                -- ^ names bound by this evaluation
92
  | RunException SomeException  -- ^ statement raised an exception
93
  | RunBreak ThreadId [Name] (Maybe BreakInfo)
94 95

data Status
96 97
   = Break Bool HValue BreakInfo ThreadId
          -- ^ the computation hit a breakpoint (Bool <=> was an exception)
98
   | Complete (Either SomeException [HValue])
99 100 101 102 103 104
          -- ^ the computation completed with either an exception or a value

data Resume
   = Resume {
       resumeStmt      :: String,       -- the original statement
       resumeThreadId  :: ThreadId,     -- thread running the computation
dterei's avatar
dterei committed
105
       resumeBreakMVar :: MVar (),
106
       resumeStatMVar  :: MVar Status,
107
       resumeBindings  :: ([TyThing], GlobalRdrEnv),
108 109 110
       resumeFinalIds  :: [Id],         -- [Id] to bind on completion
       resumeApStack   :: HValue,       -- The object from which we can get
                                        -- value of the free variables.
dterei's avatar
dterei committed
111
       resumeBreakInfo :: Maybe BreakInfo,
112 113
                                        -- the breakpoint we stopped at
                                        -- (Nothing <=> exception)
114
       resumeSpan      :: SrcSpan,      -- just a cache, otherwise it's a pain
115 116
                                        -- to fetch the ModDetails & ModBreaks
                                        -- to get this.
117 118
       resumeHistory   :: [History],
       resumeHistoryIx :: Int           -- 0 <==> at the top of the history
119 120
   }

121 122
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext = withSession (return . ic_resume . hsc_IC)
123 124 125 126 127 128

data SingleStep
   = RunToCompletion
   | SingleStep
   | RunAndLogSteps

129
isStep :: SingleStep -> Bool
130 131 132
isStep RunToCompletion = False
isStep _ = True

133 134 135
data History
   = History {
        historyApStack   :: HValue,
136
        historyBreakInfo :: BreakInfo,
137
        historyEnclosingDecls :: [String]  -- declarations enclosing the breakpoint
138
   }
139

140 141
mkHistory :: HscEnv -> HValue -> BreakInfo -> History
mkHistory hsc_env hval bi = let
Ian Lynagh's avatar
Ian Lynagh committed
142
    decls = findEnclosingDecls hsc_env bi
143 144
    in History hval bi decls

145 146

getHistoryModule :: History -> Module
147 148
getHistoryModule = breakInfo_module . historyBreakInfo

149 150 151
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan hsc_env hist =
   let inf = historyBreakInfo hist
152
       num = breakInfo_number inf
153
   in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
154
       Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
155
       _ -> panic "getHistorySpan"
156

157 158
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
159
  | Just linkable <- hm_linkable hmi,
160 161 162 163 164
    [BCOs _ modBreaks] <- linkableUnlinked linkable
  = modBreaks
  | otherwise
  = emptyModBreaks -- probably object code

Simon Marlow's avatar
Simon Marlow committed
165 166 167 168
{- | 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.
Ian Lynagh's avatar
Ian Lynagh committed
169 170 171
findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
findEnclosingDecls hsc_env inf =
   let hmi = expectJust "findEnclosingDecls" $
172 173 174 175
             lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf)
       mb = getModBreaks hmi
   in modBreaks_decls mb ! breakInfo_number inf

176 177 178 179 180 181
-- | Update fixity environment in the current interactive context.
updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
updateFixityEnv fix_env = do
  hsc_env <- getSession
  let ic = hsc_IC hsc_env
  setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
182

183 184
-- | Run a statement in the current interactive context.  Statement
-- may bind multple values.
185
runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
vivian's avatar
vivian committed
186 187 188 189
runStmt = runStmtWithLocation "<interactive>" 1

-- | Run a statement in the current interactive context.  Passing debug information
--   Statement may bind multple values.
dterei's avatar
dterei committed
190 191
runStmtWithLocation :: GhcMonad m => String -> Int ->
                       String -> SingleStep -> m RunResult
vivian's avatar
vivian committed
192
runStmtWithLocation source linenumber expr step =
193 194 195 196 197 198 199 200
  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.
201 202 203
    let ic       = hsc_IC hsc_env -- use the interactive dflags
        idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedBinds
        hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }
204

dterei's avatar
dterei committed
205
    -- compile to value (IO [HValue]), don't run
vivian's avatar
vivian committed
206
    r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber
207 208

    case r of
dterei's avatar
dterei committed
209 210
      -- empty statement / comment
      Nothing -> return (RunOk [])
211

212 213 214
      Just (tyThings, hval, fix_env) -> do
        updateFixityEnv fix_env

215
        status <-
216
          withVirtualCWD $
217 218
            withBreakAction (isStep step) idflags' breakMVar statusMVar $ do
                liftIO $ sandboxIO idflags' statusMVar hval
dterei's avatar
dterei committed
219

220
        let ic = hsc_IC hsc_env
221
            bindings = (ic_tythings ic, ic_rn_gbl_env ic)
222

223 224
            size = ghciHistSize idflags'

225 226
        case step of
          RunAndLogSteps ->
227
              traceRunStatus expr bindings tyThings
228
                             breakMVar statusMVar status (emptyHistory size)
229
          _other ->
230
              handleRunStatus expr bindings tyThings
231
                               breakMVar statusMVar status (emptyHistory size)
232

233 234 235 236 237 238 239
runDecls :: GhcMonad m => String -> m [Name]
runDecls = runDeclsWithLocation "<interactive>" 1

runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
runDeclsWithLocation source linenumber expr =
  do
    hsc_env <- getSession
240
    (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber
dterei's avatar
dterei committed
241

242 243 244 245 246 247 248
    setSession $ hsc_env { hsc_IC = ic }
    hsc_env <- getSession
    hsc_env' <- liftIO $ rttiEnvironment hsc_env
    modifySession (\_ -> hsc_env')
    return (map getName tyThings)


249 250 251 252 253 254 255
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
dterei's avatar
dterei committed
256
        case ic_cwd ic of
257 258 259 260 261 262 263 264 265 266 267 268 269
           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

270
parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
271
parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
272

273 274
emptyHistory :: Int -> BoundedList History
emptyHistory size = nilBL size
275

276
handleRunStatus :: GhcMonad m =>
277
                   String-> ([TyThing],GlobalRdrEnv) -> [Id]
278
                -> MVar () -> MVar Status -> Status -> BoundedList History
279 280
                -> m RunResult
handleRunStatus expr bindings final_ids breakMVar statusMVar status
281
                history =
dterei's avatar
dterei committed
282
   case status of
283
      -- did we hit a breakpoint or did we complete?
284
      (Break is_exception apStack info tid) -> do
285
        hsc_env <- getSession
286 287
        let mb_info | is_exception = Nothing
                    | otherwise    = Just info
288 289
        (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
                                                               mb_info
290
        let
291
            resume = Resume { resumeStmt = expr, resumeThreadId = tid
dterei's avatar
dterei committed
292
                            , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
293
                            , resumeBindings = bindings, resumeFinalIds = final_ids
dterei's avatar
dterei committed
294
                            , resumeApStack = apStack, resumeBreakInfo = mb_info
295 296
                            , resumeSpan = span, resumeHistory = toListBL history
                            , resumeHistoryIx = 0 }
297 298
            hsc_env2 = pushResume hsc_env1 resume
        --
299
        modifySession (\_ -> hsc_env2)
300
        return (RunBreak tid names mb_info)
301
      (Complete either_hvals) ->
dterei's avatar
dterei committed
302 303 304
        case either_hvals of
            Left e -> return (RunException e)
            Right hvals -> do
305
                hsc_env <- getSession
306 307 308
                let final_ic = extendInteractiveContext (hsc_IC hsc_env)
                                                        (map AnId final_ids)
                    final_names = map getName final_ids
309 310 311
                liftIO $ Linker.extendLinkEnv (zip final_names hvals)
                hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
                modifySession (\_ -> hsc_env')
312 313
                return (RunOk final_names)

314
traceRunStatus :: GhcMonad m =>
315
                  String -> ([TyThing], GlobalRdrEnv) -> [Id]
316
               -> MVar () -> MVar Status -> Status -> BoundedList History
317 318
               -> m RunResult
traceRunStatus expr bindings final_ids
319
               breakMVar statusMVar status history = do
320
  hsc_env <- getSession
321 322 323
  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.
324
     (Break is_exception apStack info tid) | not is_exception -> do
325
        b <- liftIO $ isBreakEnabled hsc_env info
326 327 328
        if b
           then handle_normally
           else do
329
             let history' = mkHistory hsc_env apStack info `consBL` history
330 331
                -- probably better make history strict here, otherwise
                -- our BoundedList will be pointless.
332
             _ <- liftIO $ evaluate history'
333 334 335 336 337 338 339
             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
340
                            breakMVar statusMVar status history'
341
     _other ->
342 343
        handle_normally
  where
344
        handle_normally = handleRunStatus expr bindings final_ids
345 346 347 348 349 350 351
                                          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
352 353
         w <- getBreak (hsc_dflags hsc_env)
                       (modBreaks_flags (getModBreaks hmi))
354 355 356 357 358
                       (breakInfo_number inf)
         case w of Just n -> return (n /= 0); _other -> return False
       _ ->
         return False

359

360 361 362
foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt
foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt

363 364 365
setStepFlag :: IO ()
setStepFlag = poke stepFlag 1
resetStepFlag :: IO ()
366
resetStepFlag = poke stepFlag 0
367 368

-- this points to the IO action that is executed when a breakpoint is hit
dterei's avatar
dterei committed
369 370
foreign import ccall "&rts_breakpoint_io_action"
   breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
371 372 373 374 375

-- 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".
376
--
Thomas Schilling's avatar
Thomas Schilling committed
377
-- Careful here: there may be ^C exceptions flying around, so we start the new
378
-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
Thomas Schilling's avatar
Thomas Schilling committed
379 380
-- 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
381
sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
382
sandboxIO dflags statusMVar thing =
383 384
   mask $ \restore -> -- fork starts blocked
     let runIt = liftM Complete $ try (restore $ rethrow dflags thing)
ian@well-typed.com's avatar
ian@well-typed.com committed
385
     in if gopt Opt_GhciSandbox dflags
386 387 388 389 390 391 392 393 394
        then do tid <- forkIO $ do res <- runIt
                                   putMVar statusMVar res -- empty: can't block
                withInterruptsSentTo tid $ takeMVar statusMVar
        else -- GLUT on OS X needs to run on the main thread. If you
             -- try to use it from another thread then you just get a
             -- white rectangle rendered. For this, or anything else
             -- with such restrictions, you can turn the GHCi sandbox off
             -- and things will be run in the main thread.
             runIt
395

Simon Marlow's avatar
Simon Marlow committed
396 397 398 399 400 401 402 403
-- 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
404
rethrow :: DynFlags -> IO a -> IO a
405
rethrow dflags io = Exception.catch io $ \se -> do
406
                   -- If -fbreak-on-error, we break unconditionally,
dterei's avatar
dterei committed
407
                   --  but with care of not breaking twice
ian@well-typed.com's avatar
ian@well-typed.com committed
408 409
                if gopt Opt_BreakOnError dflags &&
                   not (gopt Opt_BreakOnException dflags)
410
                    then poke exceptionFlag 1
411
                    else case fromException se of
412
                         -- If it is a "UserInterrupt" exception, we allow
413
                         --  a possible break by way of -fbreak-on-exception
414
                         Just UserInterrupt -> return ()
415 416 417 418
                         -- In any other case, we don't want to break
                         _ -> poke exceptionFlag 0

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

420 421
withInterruptsSentTo :: ThreadId -> IO r -> IO r
withInterruptsSentTo thread get_result = do
422 423
  bracket (pushInterruptTargetThread thread)
          (\_ -> popInterruptTargetThread)
424
          (\_ -> get_result)
425

426 427 428 429
-- 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.
430 431 432 433
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)
434 435 436 437
 where
   setBreakAction = do
     stablePtr <- newStablePtr onBreak
     poke breakPointIOAction stablePtr
ian@well-typed.com's avatar
ian@well-typed.com committed
438
     when (gopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
439
     when step $ setStepFlag
440
     return stablePtr
441 442 443
        -- 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.
444

445
   onBreak is_exception info apStack = do
446
     tid <- myThreadId
447
     putMVar statusMVar (Break is_exception apStack info tid)
448 449 450 451
     takeMVar breakMVar

   resetBreakAction stablePtr = do
     poke breakPointIOAction noBreakStablePtr
452 453
     poke exceptionFlag 0
     resetStepFlag
454 455
     freeStablePtr stablePtr

456
noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
457
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
458

459 460 461
noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
noBreakAction True  _ _ = return () -- exception: just continue
462

463 464
resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
resume canLogSpan step
465
 = do
466
   hsc_env <- getSession
467 468 469 470
   let ic = hsc_IC hsc_env
       resume = ic_resume ic

   case resume of
471
     [] -> ghcError (ProgramError "not stopped at a breakpoint")
472 473 474 475
     (r:rs) -> do
        -- unbind the temporary locals by restoring the TypeEnv from
        -- before the breakpoint, and drop this Resume from the
        -- InteractiveContext.
476 477 478
        let (resume_tmp_te,resume_rdr_env) = resumeBindings r
            ic' = ic { ic_tythings = resume_tmp_te,
                       ic_rn_gbl_env = resume_rdr_env,
479
                       ic_resume   = rs }
480
        modifySession (\_ -> hsc_env{ hsc_IC = ic' })
dterei's avatar
dterei committed
481 482

        -- remove any bindings created since the breakpoint from the
483
        -- linker's environment
484 485
        let new_names = map getName (filter (`notElem` resume_tmp_te)
                                           (ic_tythings ic))
486
        liftIO $ Linker.deleteFromLinkEnv new_names
dterei's avatar
dterei committed
487

488
        when (isStep step) $ liftIO setStepFlag
dterei's avatar
dterei committed
489
        case r of
490 491 492 493 494
          Resume { resumeStmt = expr, resumeThreadId = tid
                 , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
                 , resumeBindings = bindings, resumeFinalIds = final_ids
                 , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
                 , resumeHistory = hist } -> do
495
               withVirtualCWD $ do
dterei's avatar
dterei committed
496
                withBreakAction (isStep step) (hsc_dflags hsc_env)
497
                                        breakMVar statusMVar $ do
498
                status <- liftIO $ withInterruptsSentTo tid $ do
499
                             putMVar breakMVar ()
500
                                      -- this awakens the stopped thread...
501
                             takeMVar statusMVar
dterei's avatar
dterei committed
502
                                      -- and wait for the result
503 504 505 506 507 508
                let prevHistoryLst = fromListBL 50 hist
                    hist' = case info of
                       Nothing -> prevHistoryLst
                       Just i
                         | not $canLogSpan span -> prevHistoryLst
                         | otherwise -> mkHistory hsc_env apStack i `consBL`
509
                                                        fromListBL 50 hist
510
                case step of
dterei's avatar
dterei committed
511
                  RunAndLogSteps ->
512
                        traceRunStatus expr bindings final_ids
513
                                       breakMVar statusMVar status hist'
514
                  _other ->
515
                        handleRunStatus expr bindings final_ids
516
                                        breakMVar statusMVar status hist'
517

518
back :: GhcMonad m => m ([Name], Int, SrcSpan)
519 520
back  = moveHist (+1)

521
forward :: GhcMonad m => m ([Name], Int, SrcSpan)
522 523
forward  = moveHist (subtract 1)

524 525 526
moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
moveHist fn = do
  hsc_env <- getSession
527
  case ic_resume (hsc_IC hsc_env) of
528
     [] -> ghcError (ProgramError "not stopped at a breakpoint")
529 530 531 532 533
     (r:rs) -> do
        let ix = resumeHistoryIx r
            history = resumeHistory r
            new_ix = fn ix
        --
534
        when (new_ix > length history) $
535
           ghcError (ProgramError "no more logged breakpoints")
536
        when (new_ix < 0) $
537
           ghcError (ProgramError "already at the beginning of the history")
538 539

        let
540
          update_ic apStack mb_info = do
541
            (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
542
                                                apStack mb_info
dterei's avatar
dterei committed
543
            let ic = hsc_IC hsc_env1
544 545
                r' = r { resumeHistoryIx = new_ix }
                ic' = ic { ic_resume = r':rs }
dterei's avatar
dterei committed
546

547
            modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
dterei's avatar
dterei committed
548

549 550 551 552 553 554
            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
dterei's avatar
dterei committed
555 556
           then case r of
                   Resume { resumeApStack = apStack,
557 558
                            resumeBreakInfo = mb_info } ->
                          update_ic apStack mb_info
dterei's avatar
dterei committed
559
           else case history !! (new_ix - 1) of
560
                   History apStack info _ ->
561
                          update_ic apStack (Just info)
562 563 564

-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment
565
result_fs :: FastString
566
result_fs = fsLit "_result"
567

568 569 570
bindLocalsAtBreakpoint
        :: HscEnv
        -> HValue
571
        -> Maybe BreakInfo
572
        -> IO (HscEnv, [Name], SrcSpan)
573 574 575 576 577 578

-- 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
579
   let exn_fs    = fsLit "_exception"
580
       exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
581
       e_fs      = fsLit "e"
582
       e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
583
       e_tyvar   = mkRuntimeUnkTyVar e_name liftedTypeKind
584
       exn_id    = AnId $ Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
585 586

       ictxt0 = hsc_IC hsc_env
587
       ictxt1 = extendInteractiveContext ictxt0 [exn_id]
588

589
       span = mkGeneralSrcSpan (fsLit "<exception thrown>")
590 591 592 593 594 595 596
   --
   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
597

dterei's avatar
dterei committed
598
   let
599
       mod_name  = moduleName (breakInfo_module info)
dterei's avatar
dterei committed
600
       hmi       = expectJust "bindLocalsAtBreakpoint" $
601 602
                        lookupUFM (hsc_HPT hsc_env) mod_name
       breaks    = getModBreaks hmi
603 604 605 606 607 608
       index     = breakInfo_number info
       vars      = breakInfo_vars info
       result_ty = breakInfo_resty info
       occs      = modBreaks_vars breaks ! index
       span      = modBreaks_locs breaks ! index

609 610 611
           -- Filter out any unboxed ids;
           -- we can't bind these at the prompt
       pointers = filter (\(id,_) -> isPointer id) vars
612 613 614
       isPointer id | UnaryRep ty <- repType (idType id)
                    , PtrRep <- typePrimRep ty = True
                    | otherwise                = False
615

616 617 618 619
       (ids, offsets) = unzip pointers

       free_tvs = foldr (unionVarSet . tyVarsOfType . idType)
                        (tyVarsOfType result_ty) ids
620 621 622 623 624

   -- 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.
625
   mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
626
   let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
627 628
   when (any isNothing mb_hValues) $
      debugTraceMsg (hsc_dflags hsc_env) 1 $
dterei's avatar
dterei committed
629
          text "Warning: _result has been evaluated, some bindings have been lost"
630

631 632 633 634 635
   us <- mkSplitUniqSupply 'I'
   let (us1, us2) = splitUniqSupply us
       tv_subst   = newTyVars us1 free_tvs
       new_ids    = zipWith3 (mkNewId tv_subst) occs filtered_ids (uniqsFromSupply us2)
       names      = map idName new_ids
636 637 638 639

   -- 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
640
   let result_name = mkInternalName (getUnique result_fs)
641
                          (mkVarOccFS result_fs) span
642
       result_id   = Id.mkVanillaGlobal result_name (substTy tv_subst result_ty)
643 644 645 646 647

   -- for each Id we're about to bind in the local envt:
   --    - tidy the type variables
   --    - globalise the Id (Ids are supposed to be Global, apparently).
   --
648 649 650 651
   let result_ok = isPointer result_id

       all_ids | result_ok = result_id : new_ids
               | otherwise = new_ids
652
       id_tys = map idType all_ids
653
       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
654
       final_ids = zipWith setIdType all_ids tidy_tys
mnislaih's avatar
mnislaih committed
655
       ictxt0 = hsc_IC hsc_env
656
       ictxt1 = extendInteractiveContext ictxt0 (map AnId final_ids)
657

658
   Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
659
   when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
mnislaih's avatar
mnislaih committed
660
   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
661
   return (hsc_env1, if result_ok then result_name:names else names, span)
662
  where
663
        -- We need a fresh Unique for each Id we bind, because the linker
664 665 666
        -- 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.
667 668 669 670 671 672 673 674 675 676 677 678 679 680 681
   mkNewId :: TvSubst -> OccName -> Id -> Unique -> Id
   mkNewId tv_subst occ id uniq
     = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
     where
         loc    = nameSrcSpan (idName id)
         name   = mkInternalName uniq occ loc
         ty     = substTy tv_subst (idType id)

   newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst
     -- Similarly, clone the type variables mentioned in the types
     -- we have here, *and* make them all RuntimeUnk tyars
   newTyVars us tvs
     = mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
                    | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
                    , let name = setNameUnique (tyVarName tv) uniq ]
682

dterei's avatar
dterei committed
683
rttiEnvironment :: HscEnv -> IO HscEnv
mnislaih's avatar
mnislaih committed
684
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
685
   let tmp_ids = [id | AnId id <- ic_tythings ic]
dterei's avatar
dterei committed
686
       incompletelyTypedIds =
mnislaih's avatar
mnislaih committed
687
           [id | id <- tmp_ids
pepe's avatar
pepe committed
688
               , not $ noSkolems id
mnislaih's avatar
mnislaih committed
689
               , (occNameFS.nameOccName.idName) id /= result_fs]
pepe's avatar
pepe committed
690 691 692
   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
   return hsc_env'
    where
693
     noSkolems = isEmptyVarSet . tyVarsOfType . idType
pepe's avatar
pepe committed
694
     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
695
      let tmp_ids = [id | AnId id <- ic_tythings ic]
pepe's avatar
pepe committed
696 697 698 699 700 701 702 703 704
          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
705
              case improveRTTIType hsc_env old_ty new_ty of
pepe's avatar
pepe committed
706 707 708 709
               Nothing -> return $
                        WARN(True, text (":print failed to calculate the "
                                           ++ "improvement for a type")) hsc_env
               Just subst -> do
710
                 let dflags = hsc_dflags hsc_env
711
                 when (dopt Opt_D_dump_rtti dflags) $
712
                      printInfoForUser dflags alwaysQualify $
pepe's avatar
pepe committed
713 714
                      fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]

715 716
                 let ic' = extendInteractiveContext
                               (substInteractiveContext ic subst) []
pepe's avatar
pepe committed
717 718
                 return hsc_env{hsc_IC=ic'}

719 720 721 722 723 724 725 726 727
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))
728 729 730 731 732 733 734 735 736 737

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

738 739 740
abandon :: GhcMonad m => m Bool
abandon = do
   hsc_env <- getSession
741 742 743 744
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
      []    -> return False
dterei's avatar
dterei committed
745
      r:rs  -> do
746 747
         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
         liftIO $ abandon_ r
748 749
         return True

750 751 752
abandonAll :: GhcMonad m => m Bool
abandonAll = do
   hsc_env <- getSession
753 754 755
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
756
      []  -> return False
dterei's avatar
dterei committed
757
      rs  -> do
758 759
         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
         liftIO $ mapM_ abandon_ rs
760 761
         return True

dterei's avatar
dterei committed
762 763
-- when abandoning a computation we have to
--      (a) kill the thread with an async exception, so that the
764 765 766 767 768 769
--          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.
770 771 772
--      (c) wait for the thread to terminate by taking its status MVar.  This
--          step is necessary to prevent race conditions with
--          -fbreak-on-exception (see #5975).
773 774 775 776
--  See test break010.
abandon_ :: Resume -> IO ()
abandon_ r = do
  killThread (resumeThreadId r)
dterei's avatar
dterei committed
777
  putMVar (resumeBreakMVar r) ()
778 779
  _ <- takeMVar (resumeStatMVar r)
  return ()
780

781 782 783 784 785 786 787 788 789
-- -----------------------------------------------------------------------------
-- 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)

790 791 792
nilBL :: Int -> BoundedList a
nilBL bound = BL 0 bound [] []

793
consBL :: a -> BoundedList a -> BoundedList a
794 795
consBL a (BL len bound left right)
  | len < bound = BL (len+1) bound (a:left) right
796 797
  | null right  = BL len     bound [a]      $! tail (reverse left)
  | otherwise   = BL len     bound (a:left) $! tail right
798

799
toListBL :: BoundedList a -> [a]
800 801
toListBL (BL _ _ left right) = left ++ reverse right

802
fromListBL :: Int -> [a] -> BoundedList a
803 804
fromListBL bound l = BL (length l) bound l []

805
-- lenBL (BL len _ _ _) = len
806 807 808 809 810 811 812

-- -----------------------------------------------------------------------------
-- | 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.
813 814 815
setContext :: GhcMonad m => [InteractiveImport] -> m ()
setContext imports
  = do { hsc_env <- getSession
Ian Lynagh's avatar
Ian Lynagh committed
816
       ; let dflags = hsc_dflags hsc_env
817 818
       ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
       ; case all_env_err of
Ian Lynagh's avatar
Ian Lynagh committed
819
           Left (mod, err) -> ghcError (formatError dflags mod err)
820
           Right all_env -> do {
821 822
       ; let old_ic        = hsc_IC hsc_env
             final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env
823
       ; modifySession $ \_ ->
824
         hsc_env{ hsc_IC = old_ic { ic_imports    = imports
825 826
                                  , ic_rn_gbl_env = final_rdr_env }}}}
  where
Ian Lynagh's avatar
Ian Lynagh committed
827
    formatError dflags mod err = ProgramError . showSDoc dflags $
828 829
      text "Cannot add module" <+> ppr mod <+>
      text "to context:" <+> text err
830

831 832
findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
                 -> IO (Either (ModuleName, String) GlobalRdrEnv)
833 834
-- Compute the GlobalRdrEnv for the interactive context
findGlobalRdrEnv hsc_env imports
835
  = do { idecls_env <- hscRnImportDecls hsc_env idecls
dterei's avatar
dterei committed
836
                    -- This call also loads any orphan modules
837 838 839
       ; return $ case partitionEithers (map mkEnv imods) of
           ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
           (err : _, _)       -> Left err }
840 841 842 843
  where
    idecls :: [LImportDecl RdrName]
    idecls = [noLoc d | IIDecl d <- imports]

844
    imods :: [ModuleName]
845 846
    imods = [m | IIModule m <- imports]