InteractiveEval.hs 39.6 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 12 13
        RunResult(..), Status(..), Resume(..), History(..),
	runStmt, SingleStep(..),
        resume,
14 15
        abandon, abandonAll,
        getResumeContext,
16
        getHistorySpan,
17
        getModBreaks,
18
        getHistoryModule,
19
        back, forward,
20 21 22 23 24 25 26 27 28 29 30 31 32
	setContext, getContext,	
        nameSetToGlobalRdrEnv,
	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 43 44 45 46 47
import HscMain          hiding (compileExpr)
import HscTypes
import TcRnDriver
import Type             hiding (typeKind)
import TcType           hiding (typeKind)
import InstEnv
48
import Var
49 50 51 52 53 54 55 56 57 58
import Id
import Name             hiding ( varName )
import NameSet
import RdrName
import VarSet
import VarEnv
import ByteCodeInstr
import Linker
import DynFlags
import Unique
59
import UniqSupply
60 61
import Module
import Panic
62
import LazyUniqFM
63
import Maybes
64
import ErrUtils
65 66
import Util
import SrcLoc
67
import BreakArray
68 69 70
import RtClosureInspect
import BasicTypes
import Outputable
71
import FastString
72
import MonadUtils
73

74
import System.Directory
75
import Data.Dynamic
76
import Data.List (find)
77 78
import Control.Monad
import Foreign
79
import Foreign.C
80 81
import GHC.Exts
import Data.Array
82
import Exception
83
import Control.Concurrent
84
import Data.List (sortBy)
85
import Foreign.StablePtr
pepe's avatar
pepe committed
86
import System.IO
87 88 89 90 91 92 93

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

data RunResult
  = RunOk [Name] 		-- ^ names bound by this evaluation
  | RunFailed	 		-- ^ statement failed compilation
94
  | RunException SomeException	-- ^ statement raised an exception
95
  | RunBreak ThreadId [Name] (Maybe BreakInfo)
96 97

data Status
98 99
   = Break Bool HValue BreakInfo ThreadId
          -- ^ the computation hit a breakpoint (Bool <=> was an exception)
100
   | Complete (Either SomeException [HValue])
101 102 103 104 105 106 107 108 109 110 111 112
          -- ^ 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.
113 114 115
       resumeBreakInfo :: Maybe BreakInfo,    
                                        -- the breakpoint we stopped at
                                        -- (Nothing <=> exception)
116
       resumeSpan      :: SrcSpan,      -- just a cache, otherwise it's a pain
117 118
                                        -- to fetch the ModDetails & ModBreaks
                                        -- to get this.
119 120
       resumeHistory   :: [History],
       resumeHistoryIx :: Int           -- 0 <==> at the top of the history
121 122
   }

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

data SingleStep
   = RunToCompletion
   | SingleStep
   | RunAndLogSteps

131
isStep :: SingleStep -> Bool
132 133 134
isStep RunToCompletion = False
isStep _ = True

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

143 144 145 146 147 148 149 150
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
151 152
getHistoryModule = breakInfo_module . historyBreakInfo

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

161 162 163 164 165 166 167 168
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
169 170 171 172
{- | 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.
173
findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
174
findEnclosingDecl hsc_env mod span =
mnislaih's avatar
mnislaih committed
175
   case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
176 177
         Nothing -> panic "findEnclosingDecl"
         Just hmi -> let
178 179 180 181 182 183 184
             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
185

186 187
-- | Run a statement in the current interactive context.  Statement
-- may bind multple values.
188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215
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 <-
216
          withVirtualCWD $
217 218 219
            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
220
              
221 222
        let ic = hsc_IC hsc_env
            bindings = (ic_tmp_ids ic, ic_tyvars ic)
223

224 225 226 227 228 229 230
        case step of
          RunAndLogSteps ->
              traceRunStatus expr bindings ids
                             breakMVar statusMVar status emptyHistory
          _other ->
              handleRunStatus expr bindings ids
                               breakMVar statusMVar status emptyHistory
231

232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
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


254
emptyHistory :: BoundedList History
255 256
emptyHistory = nilBL 50 -- keep a log of length 50

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

293 294
traceRunStatus :: GhcMonad m =>
                  String -> ([Id], TyVarSet) -> [Id]
295
               -> MVar () -> MVar Status -> Status -> BoundedList History
296 297
               -> m RunResult
traceRunStatus expr bindings final_ids
298
               breakMVar statusMVar status history = do
299
  hsc_env <- getSession
300 301 302
  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.
303
     (Break is_exception apStack info tid) | not is_exception -> do
304
        b <- liftIO $ isBreakEnabled hsc_env info
305 306 307
        if b
           then handle_normally
           else do
308
             let history' = mkHistory hsc_env apStack info `consBL` history
309 310
                -- probably better make history strict here, otherwise
                -- our BoundedList will be pointless.
311 312 313 314 315 316 317 318
             liftIO $ evaluate history'
             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
319
                            breakMVar statusMVar status history'
320
     _other ->
321 322
        handle_normally
  where
323
        handle_normally = handleRunStatus expr bindings final_ids
324 325 326 327 328 329 330
                                          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
331
         w <- getBreak (modBreaks_flags (getModBreaks hmi))
332 333 334 335 336
                       (breakInfo_number inf)
         case w of Just n -> return (n /= 0); _other -> return False
       _ ->
         return False

337

338 339 340
foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt
foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt

341 342 343
setStepFlag :: IO ()
setStepFlag = poke stepFlag 1
resetStepFlag :: IO ()
344
resetStepFlag = poke stepFlag 0
345 346

-- this points to the IO action that is executed when a breakpoint is hit
347 348
foreign import ccall "&rts_breakpoint_io_action" 
   breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) 
349 350 351 352 353

-- 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".
354
-- 
Thomas Schilling's avatar
Thomas Schilling committed
355 356 357 358
-- Careful here: there may be ^C exceptions flying around, so we start the new
-- thread blocked (forkIO inherits block from the parent, #1048), and unblock
-- 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
359
sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
360 361 362 363 364 365
sandboxIO dflags statusMVar thing =
   block $ do  -- fork starts blocked
     id <- forkIO $ do res <- Exception.try (unblock $ rethrow dflags thing)
                       putMVar statusMVar (Complete res) -- empty: can't block
     withInterruptsSentTo id $ takeMVar statusMVar

366

Simon Marlow's avatar
Simon Marlow committed
367 368 369 370 371 372 373 374
-- 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
375
rethrow :: DynFlags -> IO a -> IO a
376
rethrow dflags io = Exception.catch io $ \se -> do
377 378 379 380 381
                   -- 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
382
                    else case fromException se of
383 384 385 386 387 388 389
                         -- If it is an "Interrupted" exception, we allow
                         --  a possible break by way of -fbreak-on-exception
                         Just Interrupted -> return ()
                         -- In any other case, we don't want to break
                         _ -> poke exceptionFlag 0

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

391 392 393
withInterruptsSentTo :: ThreadId -> IO r -> IO r
withInterruptsSentTo thread get_result = do
  bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
394
          (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
395
          (\_ -> get_result)
396

397 398 399 400
-- 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.
401 402 403 404
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)
405 406 407 408
 where
   setBreakAction = do
     stablePtr <- newStablePtr onBreak
     poke breakPointIOAction stablePtr
409 410
     when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
     when step $ setStepFlag
411
     return stablePtr
412 413 414
        -- 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.
415

416
   onBreak is_exception info apStack = do
417
     tid <- myThreadId
418
     putMVar statusMVar (Break is_exception apStack info tid)
419 420 421 422
     takeMVar breakMVar

   resetBreakAction stablePtr = do
     poke breakPointIOAction noBreakStablePtr
423 424
     poke exceptionFlag 0
     resetStepFlag
425 426
     freeStablePtr stablePtr

427
noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
428
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
429

430 431 432
noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
noBreakAction True  _ _ = return () -- exception: just continue
433

434 435
resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
resume canLogSpan step
436
 = do
437
   hsc_env <- getSession
438 439 440 441
   let ic = hsc_IC hsc_env
       resume = ic_resume ic

   case resume of
442
     [] -> ghcError (ProgramError "not stopped at a breakpoint")
443 444 445 446 447 448 449 450
     (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 }
451
        modifySession (\_ -> hsc_env{ hsc_IC = ic' })
452 453 454 455 456
        
        -- 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))
457
        liftIO $ Linker.deleteFromLinkEnv new_names
458
        
459
        when (isStep step) $ liftIO setStepFlag
460 461
        case r of 
          Resume expr tid breakMVar statusMVar bindings 
462
              final_ids apStack info span hist _ -> do
463
               withVirtualCWD $ do
464 465
                withBreakAction (isStep step) (hsc_dflags hsc_env) 
                                        breakMVar statusMVar $ do
466
                status <- liftIO $ withInterruptsSentTo tid $ do
467
                             putMVar breakMVar ()
468
                                      -- this awakens the stopped thread...
469
                             takeMVar statusMVar
470
                                      -- and wait for the result 
471 472 473 474 475 476
                let prevHistoryLst = fromListBL 50 hist
                    hist' = case info of
                       Nothing -> prevHistoryLst
                       Just i
                         | not $canLogSpan span -> prevHistoryLst
                         | otherwise -> mkHistory hsc_env apStack i `consBL`
477
                                                        fromListBL 50 hist
478 479
                case step of
                  RunAndLogSteps -> 
480
                        traceRunStatus expr bindings final_ids
481
                                       breakMVar statusMVar status hist'
482
                  _other ->
483
                        handleRunStatus expr bindings final_ids
484
                                        breakMVar statusMVar status hist'
485

486
back :: GhcMonad m => m ([Name], Int, SrcSpan)
487 488
back  = moveHist (+1)

489
forward :: GhcMonad m => m ([Name], Int, SrcSpan)
490 491
forward  = moveHist (subtract 1)

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

        let
508
          update_ic apStack mb_info = do
509
            (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
510
                                                apStack mb_info
511 512 513 514
            let ic = hsc_IC hsc_env1           
                r' = r { resumeHistoryIx = new_ix }
                ic' = ic { ic_resume = r':rs }
            
515
            modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
516 517 518 519 520 521 522 523 524
            
            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, 
525 526
                            resumeBreakInfo = mb_info } ->
                          update_ic apStack mb_info
527
           else case history !! (new_ix - 1) of 
528
                   History apStack info _ ->
529
                          update_ic apStack (Just info)
530 531 532

-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment
533
result_fs :: FastString
534
result_fs = fsLit "_result"
535

536 537 538
bindLocalsAtBreakpoint
        :: HscEnv
        -> HValue
539
        -> Maybe BreakInfo
540
        -> IO (HscEnv, [Name], SrcSpan)
541 542 543 544 545 546

-- 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
547
   let exn_fs    = fsLit "_exception"
548
       exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
549
       e_fs      = fsLit "e"
550
       e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
551
       e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
552
       exn_id    = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
553 554 555 556 557
       new_tyvars = unitVarSet e_tyvar

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

558
       span = mkGeneralSrcSpan (fsLit "<exception thrown>")
559 560 561 562 563 564 565
   --
   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
566 567

   let 
568 569 570 571
       mod_name  = moduleName (breakInfo_module info)
       hmi       = expectJust "bindLocalsAtBreakpoint" $ 
                        lookupUFM (hsc_HPT hsc_env) mod_name
       breaks    = getModBreaks hmi
572 573 574 575 576 577 578 579 580 581 582 583
       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
584 585 586 587 588 589

   -- 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.
   mb_hValues <- mapM (getIdValFromApStack apStack) offsets
590
   let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
591 592 593 594 595
   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
596
   let names = map idName new_ids
597 598 599 600

   -- 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
601
   let result_name = mkInternalName (getUnique result_fs)
602
                          (mkVarOccFS result_fs) span
603
       result_id   = Id.mkVanillaGlobal result_name result_ty 
604 605 606 607 608 609 610 611

   -- 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).
   --
612 613 614 615 616
   let result_ok = isPointer result_id
                    && not (isUnboxedTupleType (idType result_id))

       all_ids | result_ok = result_id : new_ids
               | otherwise = new_ids
617 618 619
       (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
       new_tyvars = unionVarSets tyvarss             
620
       final_ids = zipWith setIdType all_ids tidy_tys
mnislaih's avatar
mnislaih committed
621 622
       ictxt0 = hsc_IC hsc_env
       ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
623

624
   Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
625
   when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
mnislaih's avatar
mnislaih committed
626
   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
627
   return (hsc_env1, if result_ok then result_name:names else names, span)
628 629 630
  where
   mkNewId :: OccName -> Id -> IO Id
   mkNewId occ id = do
631 632 633 634 635 636 637
     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
638
         loc = nameSrcSpan (idName id)
639
         name = mkInternalName uniq occ loc
640
         ty = idType id
641
         new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
642 643
     return new_id

mnislaih's avatar
mnislaih committed
644 645
rttiEnvironment :: HscEnv -> IO HscEnv 
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
mnislaih's avatar
mnislaih committed
646
   let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
mnislaih's avatar
mnislaih committed
647 648
       incompletelyTypedIds = 
           [id | id <- tmp_ids
pepe's avatar
pepe committed
649
               , not $ noSkolems id
mnislaih's avatar
mnislaih committed
650
               , (occNameFS.nameOccName.idName) id /= result_fs]
pepe's avatar
pepe committed
651 652 653 654 655 656 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
   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
689

690 691 692 693 694 695 696 697 698 699 700 701
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)

702 703 704 705 706 707 708 709 710
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))
711 712 713 714 715 716 717 718 719 720

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

721 722 723
abandon :: GhcMonad m => m Bool
abandon = do
   hsc_env <- getSession
724 725 726 727
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
      []    -> return False
728
      r:rs  -> do 
729 730
         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
         liftIO $ abandon_ r
731 732
         return True

733 734 735
abandonAll :: GhcMonad m => m Bool
abandonAll = do
   hsc_env <- getSession
736 737 738
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
739 740
      []  -> return False
      rs  -> do 
741 742
         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
         liftIO $ mapM_ abandon_ rs
743 744
         return True

745 746 747 748 749 750 751 752 753 754 755 756 757 758
-- 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) () 

759 760 761 762 763 764 765 766 767
-- -----------------------------------------------------------------------------
-- 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)

768 769 770
nilBL :: Int -> BoundedList a
nilBL bound = BL 0 bound [] []

771
consBL :: a -> BoundedList a -> BoundedList a
772 773
consBL a (BL len bound left right)
  | len < bound = BL (len+1) bound (a:left) right
774 775
  | null right  = BL len     bound [a]      $! tail (reverse left)
  | otherwise   = BL len     bound (a:left) $! tail right
776

777
toListBL :: BoundedList a -> [a]
778 779
toListBL (BL _ _ left right) = left ++ reverse right

780
fromListBL :: Int -> [a] -> BoundedList a
781 782
fromListBL bound l = BL (length l) bound l []

783
-- lenBL (BL len _ _ _) = len
784 785 786 787 788 789 790

-- -----------------------------------------------------------------------------
-- | 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.
791 792 793 794 795 796
setContext :: GhcMonad m =>
              [Module]	-- ^ entire top level scope of these modules
	   -> [Module]	-- ^ exports only of these modules
	   -> m ()
setContext toplev_mods export_mods = do
  hsc_env <- getSession
797 798 799
  let old_ic  = hsc_IC     hsc_env
      hpt     = hsc_HPT    hsc_env
  --
800 801
  export_env  <- liftIO $ mkExportEnv hsc_env export_mods
  toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
802
  let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
803 804 805 806
  modifySession $ \_ ->
      hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
				 ic_exports      = export_mods,
				 ic_rn_gbl_env   = all_env }}
807 808 809 810 811 812 813 814 815 816 817 818 819 820

-- Make a GlobalRdrEnv based on the exports of the modules only.
mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
mkExportEnv hsc_env mods = do
  stuff <- mapM (getModuleExports hsc_env) mods
  let 
	(_msgs, mb_name_sets) = unzip stuff
	gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
  	       | (Just avails, mod) <- zip mb_name_sets mods ]
  --
  return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres

nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
nameSetToGlobalRdrEnv names mod =
Simon Marlow's avatar
Simon Marlow committed
821
  mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
822 823 824 825 826 827 828 829 830 831 832 833 834 835
		 | name <- nameSetToList names ]

vanillaProv :: ModuleName -> Provenance
-- We're building a GlobalRdrEnv as if the user imported
-- all the specified modules into the global interactive module
vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
  where
    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
836
      Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ 
837 838 839 840
                                                showSDoc (ppr modl)))
      Just details ->
	 case mi_globals (hm_iface details) of
		Nothing  -> 
841
		   ghcError (ProgramError ("mkTopLevEnv: not interpreted " 
842 843 844 845 846 847
						++ 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.
848 849 850
getContext :: GhcMonad m => m ([Module],[Module])
getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
	       return (ic_toplev_scope ic, ic_exports ic)
851

852
-- | Returns @True@ if the specified module is interpreted, and hence has
853
-- its full top-level scope available.
854 855
moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted modl = withSession $ \h ->
856 857 858 859 860 861 862
 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)
863 864 865 866
-- 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)
867 868 869 870
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
871 872 873 874 875
       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))
876 877 878 879 880 881 882 883 884 885
  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
886 887

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

892 893
getRdrNamesInScope :: GhcMonad m => m [RdrName]
getRdrNamesInScope = withSession $ \hsc_env -> do
894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919
  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.
920 921 922 923
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
924 925 926

-- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
-- entity known to GHC, including 'Name's defined using 'runStmt'.
927 928 929 930 931
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?
932 933 934 935 936

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

-- | Get the type of an expression
937 938 939 940
exprType :: GhcMonad m => String -> m Type
exprType expr = withSession $ \hsc_env -> do
   ty <- hscTcExpr hsc_env expr
   return $ tidyType emptyTidyEnv ty
941 942 943 944 945

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

-- | Get the kind of a  type
946 947 948
typeKind  :: GhcMonad m => String -> m Kind
typeKind str = withSession $ \hsc_env -> do
   hscKcType hsc_env str
949 950 951 952

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

953 954 955 956 957
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])
958

959 960 961
  case (ids,hvals) of
    ([_],[hv]) -> return hv
    _ 	     -> panic "compileExpr"
962 963 964 965

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

966 967 968 969
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr expr = do
    (full,exports) <- getContext
    setContext full $
970 971 972 973
        (mkModule
            (stringToPackageId "base") (mkModuleName "Data.Dynamic")
        ):exports
    let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
974 975 976 977 978 979
    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"
980 981 982 983

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

984 985 986 987 988
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)
989

990 991
isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
isModuleInterpreted mod_summary = withSession $ \hsc_env ->
992 993 994 995 996 997
  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
998 999 1000
----------------------------------------------------------------------------
-- RTTI primitives

pepe's avatar
pepe committed
1001 1002 1003
obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
obtainTermFromVal hsc_env bound force ty x =
              cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
1004

pepe's avatar
pepe committed
1005 1006 1007 1008
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
1009

mnislaih's avatar
mnislaih committed
1010
-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
mnislaih's avatar
mnislaih committed
1011 1012
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType hsc_env bound id = do
mnislaih's avatar
mnislaih committed
1013
              hv <- Linker.getHValue hsc_env (varName id) 
pepe's avatar
pepe committed
1014 1015
              cvReconstructType hsc_env bound (idType id) hv

1016
#endif /* GHCI */
pepe's avatar
pepe committed
1017