compiler/main/InteractiveEval.hs

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