InteractiveEval.hs 42.1 KB
Newer Older
1 2
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,
    RecordWildCards #-}
3

4 5 6 7 8 9 10 11 12 13
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2005-2007
--
-- Running statements interactively
--
-- -----------------------------------------------------------------------------

module InteractiveEval (
#ifdef GHCI
14 15 16
        Status(..), Resume(..), History(..),
        execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec,
        runDecls, runDeclsWithLocation,
vivian's avatar
vivian committed
17
        parseImportDecl, SingleStep(..),
18
        resume,
19 20
        abandon, abandonAll,
        getResumeContext,
21
        getHistorySpan,
22
        getModBreaks,
23
        getHistoryModule,
24
        back, forward,
dterei's avatar
dterei committed
25
        setContext, getContext,
26
        availsToGlobalRdrEnv,
dterei's avatar
dterei committed
27 28 29 30 31 32 33 34
        getNamesInScope,
        getRdrNamesInScope,
        moduleIsInterpreted,
        getInfo,
        exprType,
        typeKind,
        parseName,
        showModule,
35
        isModuleInterpreted,
36
        parseExpr, compileParsedExpr,
dterei's avatar
dterei committed
37
        compileExpr, dynCompileExpr,
38 39 40
        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
        -- * Depcreated API (remove in GHC 7.14)
        RunResult(..), runStmt, runStmtWithLocation,
41 42 43 44 45
#endif
        ) where

#ifdef GHCI

Ian Lynagh's avatar
Ian Lynagh committed
46 47
#include "HsVersions.h"

48 49
import InteractiveEvalTypes

50 51
import GhcMonad
import HscMain
52
import HsSyn
53
import HscTypes
54
import BasicTypes ( HValue )
55
import InstEnv
56
import IfaceEnv   ( newInteractiveBinder )
57
import FamInstEnv ( FamInst, orphNamesOfFamInst )
58
import TyCon
batterseapower's avatar
batterseapower committed
59
import Type     hiding( typeKind )
dterei's avatar
dterei committed
60
import TcType           hiding( typeKind )
61
import Var
62 63 64
import Id
import Name             hiding ( varName )
import NameSet
65
import Avail
66 67 68 69 70 71 72
import RdrName
import VarSet
import VarEnv
import ByteCodeInstr
import Linker
import DynFlags
import Unique
73
import UniqSupply
74
import MonadUtils
75
import Module
76
import PrelNames  ( toDynName )
77
import Panic
78
import UniqFM
79
import Maybes
80
import ErrUtils
81
import SrcLoc
82
import BreakArray
83 84
import RtClosureInspect
import Outputable
85
import FastString
86
import Bag
87

88
import System.Mem.Weak
89
import System.Directory
90
import Data.Dynamic
91
import Data.Either
92
import Data.List (find)
93
import Control.Monad
94 95 96
#if __GLASGOW_HASKELL__ >= 709
import Foreign
#else
97
import Foreign.Safe
98
#endif
99
import Foreign.C
100 101
import GHC.Exts
import Data.Array
102
import Exception
103
import Control.Concurrent
Ross Paterson's avatar
Ross Paterson committed
104
import System.IO.Unsafe
105
import GHC.Conc         ( setAllocationCounter, getAllocationCounter )
106 107 108 109

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

110 111
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext = withSession (return . ic_resume . hsc_IC)
112

113 114
mkHistory :: HscEnv -> HValue -> BreakInfo -> History
mkHistory hsc_env hval bi = let
Ian Lynagh's avatar
Ian Lynagh committed
115
    decls = findEnclosingDecls hsc_env bi
116 117
    in History hval bi decls

118 119

getHistoryModule :: History -> Module
120 121
getHistoryModule = breakInfo_module . historyBreakInfo

122 123 124
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan hsc_env hist =
   let inf = historyBreakInfo hist
125
       num = breakInfo_number inf
126
   in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
127
       Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
128
       _ -> panic "getHistorySpan"
129

130 131
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
132
  | Just linkable <- hm_linkable hmi,
133 134 135 136 137
    [BCOs _ modBreaks] <- linkableUnlinked linkable
  = modBreaks
  | otherwise
  = emptyModBreaks -- probably object code

Simon Marlow's avatar
Simon Marlow committed
138 139 140 141
{- | 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
142 143 144
findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
findEnclosingDecls hsc_env inf =
   let hmi = expectJust "findEnclosingDecls" $
145 146 147 148
             lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf)
       mb = getModBreaks hmi
   in modBreaks_decls mb ! breakInfo_number inf

149 150 151 152 153 154
-- | 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 } }
155

156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
-- -----------------------------------------------------------------------------
-- execStmt

-- | default ExecOptions
execOptions :: ExecOptions
execOptions = ExecOptions
  { execSingleStep = RunToCompletion
  , execSourceFile = "<interactive>"
  , execLineNumber = 1
  }

-- | Run a statement in the current interactive context.
execStmt
  :: GhcMonad m
  => String             -- ^ a statement (bind or expression)
  -> ExecOptions
  -> m ExecResult
execStmt stmt ExecOptions{..} = do
174 175
    hsc_env <- getSession

176 177 178 179
    -- wait on this when we hit a breakpoint
    breakMVar  <- liftIO $ newEmptyMVar
    -- wait on this when a computation is running
    statusMVar <- liftIO $ newEmptyMVar
180

181
    -- Turn off -fwarn-unused-local-binds when running a statement, to hide
182
    -- warnings about the implicit bindings we introduce.
183
    let ic       = hsc_IC hsc_env -- use the interactive dflags
184
        idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
185
        hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }
186

dterei's avatar
dterei committed
187
    -- compile to value (IO [HValue]), don't run
188 189
    r <- liftIO $ hscStmtWithLocation hsc_env' stmt
                    execSourceFile execLineNumber
190 191

    case r of
dterei's avatar
dterei committed
192
      -- empty statement / comment
193
      Nothing -> return (ExecComplete (Right []) 0)
194

195
      Just (ids, hval, fix_env) -> do
196 197
        updateFixityEnv fix_env

198
        status <-
199
          withVirtualCWD $
200 201 202
            withBreakAction (isStep execSingleStep) idflags'
               breakMVar statusMVar $ do
                 liftIO $ sandboxIO idflags' statusMVar hval
dterei's avatar
dterei committed
203

204
        let ic = hsc_IC hsc_env
205
            bindings = (ic_tythings ic, ic_rn_gbl_env ic)
206

207 208
            size = ghciHistSize idflags'

209
        handleRunStatus execSingleStep stmt bindings ids
210
                        breakMVar statusMVar status (emptyHistory size)
211

212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
-- | The type returned by the deprecated 'runStmt' and
-- 'runStmtWithLocation' API
data RunResult
  = RunOk [Name]                -- ^ names bound by this evaluation
  | RunException SomeException  -- ^ statement raised an exception
  | RunBreak ThreadId [Name] (Maybe BreakInfo)

-- | Conver the old result type to the new result type
execResultToRunResult :: ExecResult -> RunResult
execResultToRunResult r =
  case r of
    ExecComplete{ execResult = Left ex } -> RunException ex
    ExecComplete{ execResult = Right names } -> RunOk names
    ExecBreak{..} -> RunBreak breakThreadId breakNames breakInfo

-- Remove in GHC 7.14
{-# DEPRECATED runStmt "use execStmt" #-}
-- | Run a statement in the current interactive context.  Statement
-- may bind multple values.
runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
runStmt stmt step =
  execResultToRunResult <$> execStmt stmt execOptions { execSingleStep = step }

-- Remove in GHC 7.14
{-# DEPRECATED runStmtWithLocation "use execStmtWithLocation" #-}
runStmtWithLocation :: GhcMonad m => String -> Int ->
                       String -> SingleStep -> m RunResult
runStmtWithLocation source linenumber expr step = do
  execResultToRunResult <$>
     execStmt expr execOptions { execSingleStep = step
                               , execSourceFile = source
                               , execLineNumber = linenumber }

245 246 247 248 249 250 251
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
252
    (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber
dterei's avatar
dterei committed
253

254 255 256 257 258 259 260
    setSession $ hsc_env { hsc_IC = ic }
    hsc_env <- getSession
    hsc_env' <- liftIO $ rttiEnvironment hsc_env
    modifySession (\_ -> hsc_env')
    return (map getName tyThings)


261 262 263 264 265 266 267
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
268
        case ic_cwd ic of
269 270 271 272 273 274 275 276 277 278 279 280 281
           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

282
parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
283
parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
284

285 286
emptyHistory :: Int -> BoundedList History
emptyHistory size = nilBL size
287

288 289
handleRunStatus :: GhcMonad m
                => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
290
                -> MVar () -> MVar Status -> Status -> BoundedList History
291
                -> m ExecResult
292 293 294

handleRunStatus step expr bindings final_ids
               breakMVar statusMVar status history
295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
  | RunAndLogSteps <- step = tracing
  | otherwise              = not_tracing
 where
  tracing
    | Break is_exception apStack info tid <- status
    , not is_exception
    = do
       hsc_env <- getSession
       b <- liftIO $ isBreakEnabled hsc_env info
       if b
         then not_tracing
           -- This breakpoint is explicitly enabled; we want to stop
           -- instead of just logging it.
         else do
           let history' = mkHistory hsc_env apStack info `consBL` history
                 -- probably better make history strict here, otherwise
                 -- our BoundedList will be pointless.
           _ <- liftIO $ evaluate history'
           status <- withBreakAction True (hsc_dflags hsc_env)
                                     breakMVar statusMVar $ do
                     liftIO $ mask_ $ do
                        putMVar breakMVar ()  -- awaken the stopped thread
                        redirectInterrupts tid $
                          takeMVar statusMVar   -- and wait for the result
           handleRunStatus RunAndLogSteps expr bindings final_ids
                           breakMVar statusMVar status history'
    | otherwise
    = not_tracing

  not_tracing
    -- Hit a breakpoint
    | Break is_exception apStack info tid <- status
    = do
         hsc_env <- getSession
         let mb_info | is_exception = Nothing
330
                     | otherwise    = Just info
331 332 333 334 335 336 337 338 339 340 341
         (hsc_env1, names, span) <- liftIO $
           bindLocalsAtBreakpoint hsc_env apStack mb_info
         let
           resume = Resume
             { resumeStmt = expr, resumeThreadId = tid
             , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
             , resumeBindings = bindings, resumeFinalIds = final_ids
             , resumeApStack = apStack, resumeBreakInfo = mb_info
             , resumeSpan = span, resumeHistory = toListBL history
             , resumeHistoryIx = 0 }
           hsc_env2 = pushResume hsc_env1 resume
Simon Peyton Jones's avatar
Simon Peyton Jones committed
342

343
         modifySession (\_ -> hsc_env2)
344
         return (ExecBreak tid names mb_info)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
345

346
    -- Completed with an exception
347 348
    | Complete (Left e) alloc <- status
    = return (ExecComplete (Left e) alloc)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
349

350
    -- Completed successfully
351
    | Complete (Right hvals) allocs <- status
352
    = do hsc_env <- getSession
353
         let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
354
             final_names = map getName final_ids
355 356 357
         liftIO $ Linker.extendLinkEnv (zip final_names hvals)
         hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
         modifySession (\_ -> hsc_env')
358
         return (ExecComplete (Right final_names) allocs)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
359

360 361
    | otherwise
    = panic "handleRunStatus"  -- The above cases are in fact exhaustive
362 363 364 365 366

isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
isBreakEnabled hsc_env inf =
   case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
       Just hmi -> do
367 368
         w <- getBreak (hsc_dflags hsc_env)
                       (modBreaks_flags (getModBreaks hmi))
369 370 371 372 373
                       (breakInfo_number inf)
         case w of Just n -> return (n /= 0); _other -> return False
       _ ->
         return False

374

375 376 377
foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt
foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt

378 379 380
setStepFlag :: IO ()
setStepFlag = poke stepFlag 1
resetStepFlag :: IO ()
381
resetStepFlag = poke stepFlag 0
382 383

-- this points to the IO action that is executed when a breakpoint is hit
dterei's avatar
dterei committed
384 385
foreign import ccall "&rts_breakpoint_io_action"
   breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
386 387 388 389 390

-- 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".
391
--
Thomas Schilling's avatar
Thomas Schilling committed
392
-- Careful here: there may be ^C exceptions flying around, so we start the new
393
-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
Thomas Schilling's avatar
Thomas Schilling committed
394 395
-- 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
396
sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
397
sandboxIO dflags statusMVar thing =
398
   mask $ \restore -> -- fork starts blocked
399 400 401 402
     let runIt =
           liftM (uncurry Complete) $
           measureAlloc $
           try $ restore $ rethrow dflags $ thing
ian@well-typed.com's avatar
ian@well-typed.com committed
403
     in if gopt Opt_GhciSandbox dflags
404 405
        then do tid <- forkIO $ do res <- runIt
                                   putMVar statusMVar res -- empty: can't block
406 407 408
                redirectInterrupts tid $
                  takeMVar statusMVar

409 410 411 412 413
        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.
414 415 416 417 418
             --
             -- BUT, note that the debugging features (breakpoints,
             -- tracing, etc.) need the expression to be running in a
             -- separate thread, so debugging is only enabled when
             -- using the sandbox.
419
             runIt
420

421 422 423 424 425 426 427 428 429 430 431 432 433 434
--
-- While we're waiting for the sandbox thread to return a result, if
-- the current thread receives an asynchronous exception we re-throw
-- it at the sandbox thread and continue to wait.
--
-- This is for two reasons:
--
--  * So that ^C interrupts runStmt (e.g. in GHCi), allowing the
--    computation to run its exception handlers before returning the
--    exception result to the caller of runStmt.
--
--  * clients of the GHC API can terminate a runStmt in progress
--    without knowing the ThreadId of the sandbox thread (#1381)
--
435 436 437 438 439
-- NB. use a weak pointer to the thread, so that the thread can still
-- be considered deadlocked by the RTS and sent a BlockedIndefinitely
-- exception.  A symptom of getting this wrong is that conc033(ghci)
-- will hang.
--
440 441
redirectInterrupts :: ThreadId -> IO a -> IO a
redirectInterrupts target wait
442 443 444 445 446 447
  = do wtid <- mkWeakThreadId target
       wait `catch` \e -> do
          m <- deRefWeak wtid
          case m of
            Nothing -> wait
            Just target -> do throwTo target (e :: SomeException); wait
448

449 450 451 452 453 454 455
measureAlloc :: IO a -> IO (a,Word64)
measureAlloc io = do
  setAllocationCounter maxBound
  a <- io
  allocs <- getAllocationCounter
  return (a, fromIntegral (maxBound::Int64) - fromIntegral allocs)

Simon Marlow's avatar
Simon Marlow committed
456 457 458 459 460 461 462 463
-- 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
464
rethrow :: DynFlags -> IO a -> IO a
465
rethrow dflags io = Exception.catch io $ \se -> do
466
                   -- If -fbreak-on-error, we break unconditionally,
dterei's avatar
dterei committed
467
                   --  but with care of not breaking twice
ian@well-typed.com's avatar
ian@well-typed.com committed
468 469
                if gopt Opt_BreakOnError dflags &&
                   not (gopt Opt_BreakOnException dflags)
470
                    then poke exceptionFlag 1
471
                    else case fromException se of
472
                         -- If it is a "UserInterrupt" exception, we allow
473
                         --  a possible break by way of -fbreak-on-exception
474
                         Just UserInterrupt -> return ()
475 476 477 478
                         -- In any other case, we don't want to break
                         _ -> poke exceptionFlag 0

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

480 481 482 483
-- 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.
484
withBreakAction :: (ExceptionMonad m) =>
485 486 487
                   Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
withBreakAction step dflags breakMVar statusMVar act
 = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
488 489 490 491
 where
   setBreakAction = do
     stablePtr <- newStablePtr onBreak
     poke breakPointIOAction stablePtr
ian@well-typed.com's avatar
ian@well-typed.com committed
492
     when (gopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
493
     when step $ setStepFlag
494
     return stablePtr
495 496 497
        -- 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.
498

499
   onBreak is_exception info apStack = do
500
     tid <- myThreadId
501
     putMVar statusMVar (Break is_exception apStack info tid)
502 503 504 505
     takeMVar breakMVar

   resetBreakAction stablePtr = do
     poke breakPointIOAction noBreakStablePtr
506 507
     poke exceptionFlag 0
     resetStepFlag
508 509
     freeStablePtr stablePtr

510
noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
511
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
512

513 514 515
noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
noBreakAction True  _ _ = return () -- exception: just continue
516

517
resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
518 519 520 521
resume canLogSpan step = execResultToRunResult <$> resumeExec canLogSpan step

resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
resumeExec canLogSpan step
522
 = do
523
   hsc_env <- getSession
524 525 526 527
   let ic = hsc_IC hsc_env
       resume = ic_resume ic

   case resume of
528 529
     [] -> liftIO $
           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
530 531 532 533
     (r:rs) -> do
        -- unbind the temporary locals by restoring the TypeEnv from
        -- before the breakpoint, and drop this Resume from the
        -- InteractiveContext.
534 535 536
        let (resume_tmp_te,resume_rdr_env) = resumeBindings r
            ic' = ic { ic_tythings = resume_tmp_te,
                       ic_rn_gbl_env = resume_rdr_env,
537
                       ic_resume   = rs }
538
        modifySession (\_ -> hsc_env{ hsc_IC = ic' })
dterei's avatar
dterei committed
539 540

        -- remove any bindings created since the breakpoint from the
541
        -- linker's environment
542 543
        let new_names = map getName (filter (`notElem` resume_tmp_te)
                                           (ic_tythings ic))
544
        liftIO $ Linker.deleteFromLinkEnv new_names
dterei's avatar
dterei committed
545

546
        when (isStep step) $ liftIO setStepFlag
dterei's avatar
dterei committed
547
        case r of
548 549 550 551 552
          Resume { resumeStmt = expr, resumeThreadId = tid
                 , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
                 , resumeBindings = bindings, resumeFinalIds = final_ids
                 , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
                 , resumeHistory = hist } -> do
553
               withVirtualCWD $ do
dterei's avatar
dterei committed
554
                withBreakAction (isStep step) (hsc_dflags hsc_env)
555
                                        breakMVar statusMVar $ do
556
                status <- liftIO $ mask_ $ do
557
                             putMVar breakMVar ()
558
                                      -- this awakens the stopped thread...
559 560
                             redirectInterrupts tid $
                               takeMVar statusMVar
dterei's avatar
dterei committed
561
                                      -- and wait for the result
562 563 564 565 566 567
                let prevHistoryLst = fromListBL 50 hist
                    hist' = case info of
                       Nothing -> prevHistoryLst
                       Just i
                         | not $canLogSpan span -> prevHistoryLst
                         | otherwise -> mkHistory hsc_env apStack i `consBL`
568
                                                        fromListBL 50 hist
569 570
                handleRunStatus step expr bindings final_ids
                                breakMVar statusMVar status hist'
571

572 573
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
back n = moveHist (+n)
574

575 576
forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
forward n = moveHist (subtract n)
577

578 579 580
moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
moveHist fn = do
  hsc_env <- getSession
581
  case ic_resume (hsc_IC hsc_env) of
582 583
     [] -> liftIO $
           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
584 585 586 587 588
     (r:rs) -> do
        let ix = resumeHistoryIx r
            history = resumeHistory r
            new_ix = fn ix
        --
589 590 591 592
        when (new_ix > length history) $ liftIO $
           throwGhcExceptionIO (ProgramError "no more logged breakpoints")
        when (new_ix < 0) $ liftIO $
           throwGhcExceptionIO (ProgramError "already at the beginning of the history")
593 594

        let
595
          update_ic apStack mb_info = do
596
            (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
597
                                                apStack mb_info
dterei's avatar
dterei committed
598
            let ic = hsc_IC hsc_env1
599 600
                r' = r { resumeHistoryIx = new_ix }
                ic' = ic { ic_resume = r':rs }
dterei's avatar
dterei committed
601

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

604 605 606 607 608 609
            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
610 611
           then case r of
                   Resume { resumeApStack = apStack,
612 613
                            resumeBreakInfo = mb_info } ->
                          update_ic apStack mb_info
dterei's avatar
dterei committed
614
           else case history !! (new_ix - 1) of
615
                   History apStack info _ ->
616
                          update_ic apStack (Just info)
617 618 619

-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment
620
result_fs :: FastString
621
result_fs = fsLit "_result"
622

623 624 625
bindLocalsAtBreakpoint
        :: HscEnv
        -> HValue
626
        -> Maybe BreakInfo
627
        -> IO (HscEnv, [Name], SrcSpan)
628 629 630 631 632 633

-- 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
634 635 636 637 638 639 640 641
   let exn_occ = mkVarOccFS (fsLit "_exception")
       span    = mkGeneralSrcSpan (fsLit "<exception thrown>")
   exn_name <- newInteractiveBinder hsc_env exn_occ span

   let e_fs    = fsLit "e"
       e_name  = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
       e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
       exn_id  = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
642 643

       ictxt0 = hsc_IC hsc_env
644
       ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
645 646 647 648 649 650 651 652

   --
   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
653

dterei's avatar
dterei committed
654
   let
655
       mod_name  = moduleName (breakInfo_module info)
dterei's avatar
dterei committed
656
       hmi       = expectJust "bindLocalsAtBreakpoint" $
657 658
                        lookupUFM (hsc_HPT hsc_env) mod_name
       breaks    = getModBreaks hmi
659 660 661 662 663 664
       index     = breakInfo_number info
       vars      = breakInfo_vars info
       result_ty = breakInfo_resty info
       occs      = modBreaks_vars breaks ! index
       span      = modBreaks_locs breaks ! index

665 666 667
           -- Filter out any unboxed ids;
           -- we can't bind these at the prompt
       pointers = filter (\(id,_) -> isPointer id) vars
668 669 670
       isPointer id | UnaryRep ty <- repType (idType id)
                    , PtrRep <- typePrimRep ty = True
                    | otherwise                = False
671

672 673
       (ids, offsets) = unzip pointers

674 675
       free_tvs = mapUnionVarSet (tyVarsOfType . idType) ids
                  `unionVarSet` tyVarsOfType result_ty
676 677 678 679 680

   -- 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.
681
   mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
682 683
   when (any isNothing mb_hValues) $
      debugTraceMsg (hsc_dflags hsc_env) 1 $
dterei's avatar
dterei committed
684
          text "Warning: _result has been evaluated, some bindings have been lost"
685

686

687 688 689 690 691 692 693 694 695 696 697 698 699 700
   us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time
   let tv_subst     = newTyVars us free_tvs
       filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
                      map (substTy tv_subst . idType) filtered_ids

   new_ids     <- zipWith3M mkNewId occs tidy_tys filtered_ids
   result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span

   let result_id = Id.mkVanillaGlobal result_name (substTy tv_subst result_ty)
       result_ok = isPointer result_id

       final_ids | result_ok = result_id : new_ids
                 | otherwise = new_ids
mnislaih's avatar
mnislaih committed
701
       ictxt0 = hsc_IC hsc_env
702
       ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
703
       names  = map idName new_ids
704

705
   Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
706
   when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
mnislaih's avatar
mnislaih committed
707
   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
708
   return (hsc_env1, if result_ok then result_name:names else names, span)
709
  where
710
        -- We need a fresh Unique for each Id we bind, because the linker
711 712 713
        -- 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.
714 715 716 717
   mkNewId :: OccName -> Type -> Id -> IO Id
   mkNewId occ ty old_id
     = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
          ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
718 719 720 721 722 723 724 725

   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 ]
726

dterei's avatar
dterei committed
727
rttiEnvironment :: HscEnv -> IO HscEnv
mnislaih's avatar
mnislaih committed
728
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
729
   let tmp_ids = [id | AnId id <- ic_tythings ic]
dterei's avatar
dterei committed
730
       incompletelyTypedIds =
mnislaih's avatar
mnislaih committed
731
           [id | id <- tmp_ids
pepe's avatar
pepe committed
732
               , not $ noSkolems id
mnislaih's avatar
mnislaih committed
733
               , (occNameFS.nameOccName.idName) id /= result_fs]
pepe's avatar
pepe committed
734 735 736
   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
   return hsc_env'
    where
737
     noSkolems = isEmptyVarSet . tyVarsOfType . idType
pepe's avatar
pepe committed
738
     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
739
      let tmp_ids = [id | AnId id <- ic_tythings ic]
pepe's avatar
pepe committed
740 741 742 743 744 745 746 747 748
          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
749
              case improveRTTIType hsc_env old_ty new_ty of
pepe's avatar
pepe committed
750 751 752 753
               Nothing -> return $
                        WARN(True, text (":print failed to calculate the "
                                           ++ "improvement for a type")) hsc_env
               Just subst -> do
754
                 let dflags = hsc_dflags hsc_env
755
                 when (dopt Opt_D_dump_rtti dflags) $
756
                      printInfoForUser dflags alwaysQualify $
pepe's avatar
pepe committed
757 758
                      fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]

759
                 let ic' = substInteractiveContext ic subst
pepe's avatar
pepe committed
760 761
                 return hsc_env{hsc_IC=ic'}

762 763 764 765 766 767 768 769 770
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))
771 772 773 774 775 776 777 778 779 780

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

781 782 783
abandon :: GhcMonad m => m Bool
abandon = do
   hsc_env <- getSession
784 785 786 787
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
      []    -> return False
dterei's avatar
dterei committed
788
      r:rs  -> do
789 790
         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
         liftIO $ abandon_ r
791 792
         return True

793 794 795
abandonAll :: GhcMonad m => m Bool
abandonAll = do
   hsc_env <- getSession
796 797 798
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
799
      []  -> return False
dterei's avatar
dterei committed
800
      rs  -> do
801 802
         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
         liftIO $ mapM_ abandon_ rs
803 804
         return True

dterei's avatar
dterei committed
805 806
-- when abandoning a computation we have to
--      (a) kill the thread with an async exception, so that the
807 808 809 810 811 812
--          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.
813 814 815
--      (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).
816 817 818 819
--  See test break010.
abandon_ :: Resume -> IO ()
abandon_ r = do
  killThread (resumeThreadId r)
dterei's avatar
dterei committed
820
  putMVar (resumeBreakMVar r) ()
821 822
  _ <- takeMVar (resumeStatMVar r)
  return ()
823

824 825 826 827 828 829 830 831 832
-- -----------------------------------------------------------------------------
-- 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)

833 834 835
nilBL :: Int -> BoundedList a
nilBL bound = BL 0 bound [] []

836
consBL :: a -> BoundedList a -> BoundedList a
837 838
consBL a (BL len bound left right)
  | len < bound = BL (len+1) bound (a:left) right
839 840
  | null right  = BL len     bound [a]      $! tail (reverse left)
  | otherwise   = BL len     bound (a:left) $! tail right
841

842
toListBL :: BoundedList a -> [a]
843 844
toListBL (BL _ _ left right) = left ++ reverse right

845
fromListBL :: Int -> [a] -> BoundedList a
846 847
fromListBL bound l = BL (length l) bound l []

848
-- lenBL (BL len _ _ _) = len
849 850 851 852

-- -----------------------------------------------------------------------------
-- | Set the interactive evaluation context.
--
Simon Peyton Jones's avatar
Simon Peyton Jones committed
853 854
-- (setContext imports) sets the ic_imports field (which in turn
-- determines what is in scope at the prompt) to 'imports', and
Gabor Greif's avatar
Gabor Greif committed
855
-- constructs the ic_rn_glb_env environment to reflect it.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
856 857 858 859
--
-- We retain in scope all the things defined at the prompt, and kept
-- in ic_tythings.  (Indeed, they shadow stuff from ic_imports.)

860 861 862
setContext :: GhcMonad m => [InteractiveImport] -> m ()
setContext imports
  = do { hsc_env <- getSession
Ian Lynagh's avatar
Ian Lynagh committed
863
       ; let dflags = hsc_dflags hsc_env
864 865
       ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
       ; case all_env_err of
866 867
           Left (mod, err) ->
               liftIO $ throwGhcExceptionIO (formatError dflags mod err)
868
           Right all_env -> do {
869
       ; let old_ic        = hsc_IC hsc_env
870
             final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
871
       ; modifySession $ \_ ->