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(..), obtainTermFromId, obtainTermFromVal, 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 Name             hiding ( varName )
  51 import NameSet
  52 import RdrName
  53 import VarSet
  54 import VarEnv
  55 import ByteCodeInstr
  56 import Linker
  57 import DynFlags
  58 import Unique
  59 import UniqSupply
  60 import Module
  61 import Panic
  62 import LazyUniqFM
  63 import Maybes
  64 import ErrUtils
  65 import Util
  66 import SrcLoc
  67 import BreakArray
  68 import RtClosureInspect
  69 import BasicTypes
  70 import Outputable
  71 import FastString
  72 import MonadUtils
  73
  74 import Data.Dynamic
  75 import Data.List (find)
  76 import Control.Monad
  77 import Foreign
  78 import Foreign.C
  79 import GHC.Exts
  80 import Data.Array
  81 import Exception
  82 import Control.Concurrent
  83 import Data.List (sortBy)
  84 import Foreign.StablePtr
  85 import System.IO
  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 rethrow dflags io = Exception.catch io $ \se -> do
 353                    -- If -fbreak-on-error, we break unconditionally,
 354                    --  but with care of not breaking twice
 355                 if dopt Opt_BreakOnError dflags &&
 356                    not (dopt Opt_BreakOnException dflags)
 357                     then poke exceptionFlag 1
 358                     else case fromException se of
 359                          -- If it is an "Interrupted" exception, we allow
 360                          --  a possible break by way of -fbreak-on-exception
 361                          Just Interrupted -> return ()
 362                          -- In any other case, we don't want to break
 363                          _ -> poke exceptionFlag 0
 364
 365                 Exception.throwIO se
 366
 367 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 368 withInterruptsSentTo thread get_result = do
 369   bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
 370           (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
 371           (\_ -> get_result)
 372
 373 -- This function sets up the interpreter for catching breakpoints, and
 374 -- resets everything when the computation has stopped running.  This
 375 -- is a not-very-good way to ensure that only the interactive
 376 -- evaluation should generate breakpoints.
 377 withBreakAction :: (ExceptionMonad m, MonadIO m) =>
 378                    Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
 379 withBreakAction step dflags breakMVar statusMVar act
 380  = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
 381  where
 382    setBreakAction = do
 383      stablePtr <- newStablePtr onBreak
 384      poke breakPointIOAction stablePtr
 385      when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
 386      when step $ setStepFlag
 387      return stablePtr
 388         -- Breaking on exceptions is not enabled by default, since it
 389         -- might be a bit surprising.  The exception flag is turned off
 390         -- as soon as it is hit, or in resetBreakAction below.
 391
 392    onBreak is_exception info apStack = do
 393      tid <- myThreadId
 394      putMVar statusMVar (Break is_exception apStack info tid)
 395      takeMVar breakMVar
 396
 397    resetBreakAction stablePtr = do
 398      poke breakPointIOAction noBreakStablePtr
 399      poke exceptionFlag 0
 400      resetStepFlag
 401      freeStablePtr stablePtr
 402
 403 noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
 404 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 405
 406 noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
 407 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
 408 noBreakAction True  _ _ = return () -- exception: just continue
 409
 410 resume :: GhcMonad m => SingleStep -> m RunResult
 411 resume step
 412  = do
 413    hsc_env <- getSession
 414    let ic = hsc_IC hsc_env
 415        resume = ic_resume ic
 416
 417    case resume of
 418      [] -> ghcError (ProgramError "not stopped at a breakpoint")
 419      (r:rs) -> do
 420         -- unbind the temporary locals by restoring the TypeEnv from
 421         -- before the breakpoint, and drop this Resume from the
 422         -- InteractiveContext.
 423         let (resume_tmp_ids, resume_tyvars) = resumeBindings r
 424             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
 425                        ic_tyvars   = resume_tyvars,
 426                        ic_resume   = rs }
 427         modifySession (\_ -> hsc_env{ hsc_IC = ic' })
 428
 429         -- remove any bindings created since the breakpoint from the
 430         -- linker's environment
 431         let new_names = map idName (filter (`notElem` resume_tmp_ids)
 432                                            (ic_tmp_ids ic))
 433         liftIO $ Linker.deleteFromLinkEnv new_names
 434
 435         when (isStep step) $ liftIO setStepFlag
 436         case r of
 437           Resume expr tid breakMVar statusMVar bindings
 438               final_ids apStack info _ hist _ -> do
 439                 withBreakAction (isStep step) (hsc_dflags hsc_env)
 440                                         breakMVar statusMVar $ do
 441                 status <- liftIO $ withInterruptsSentTo tid $ do
 442                              putMVar breakMVar ()
 443                                       -- this awakens the stopped thread...
 444                              takeMVar statusMVar
 445                                       -- and wait for the result
 446                 let hist' =
 447                      case info of
 448                        Nothing -> fromListBL 50 hist
 449                        Just i -> mkHistory hsc_env apStack i `consBL`
 450                                                         fromListBL 50 hist
 451                 case step of
 452                   RunAndLogSteps ->
 453                         traceRunStatus expr bindings final_ids
 454                                        breakMVar statusMVar status hist'
 455                   _other ->
 456                         handleRunStatus expr bindings final_ids
 457                                         breakMVar statusMVar status hist'
 458
 459 back :: GhcMonad m => m ([Name], Int, SrcSpan)
 460 back  = moveHist (+1)
 461
 462 forward :: GhcMonad m => m ([Name], Int, SrcSpan)
 463 forward  = moveHist (subtract 1)
 464
 465 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
 466 moveHist fn = do
 467   hsc_env <- getSession
 468   case ic_resume (hsc_IC hsc_env) of
 469      [] -> ghcError (ProgramError "not stopped at a breakpoint")
 470      (r:rs) -> do
 471         let ix = resumeHistoryIx r
 472             history = resumeHistory r
 473             new_ix = fn ix
 474         --
 475         when (new_ix > length history) $
 476            ghcError (ProgramError "no more logged breakpoints")
 477         when (new_ix < 0) $
 478            ghcError (ProgramError "already at the beginning of the history")
 479
 480         let
 481           update_ic apStack mb_info = do
 482             (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
 483                                                 apStack mb_info
 484             let ic = hsc_IC hsc_env1
 485                 r' = r { resumeHistoryIx = new_ix }
 486                 ic' = ic { ic_resume = r':rs }
 487
 488             modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
 489
 490             return (names, new_ix, span)
 491
 492         -- careful: we want apStack to be the AP_STACK itself, not a thunk
 493         -- around it, hence the cases are carefully constructed below to
 494         -- make this the case.  ToDo: this is v. fragile, do something better.
 495         if new_ix == 0
 496            then case r of
 497                    Resume { resumeApStack = apStack,
 498                             resumeBreakInfo = mb_info } ->
 499                           update_ic apStack mb_info
 500            else case history !! (new_ix - 1) of
 501                    History apStack info _ ->
 502                           update_ic apStack (Just info)
 503
 504 -- -----------------------------------------------------------------------------
 505 -- After stopping at a breakpoint, add free variables to the environment
 506 result_fs :: FastString
 507 result_fs = fsLit "_result"
 508
 509 bindLocalsAtBreakpoint
 510         :: HscEnv
 511         -> HValue
 512         -> Maybe BreakInfo
 513         -> IO (HscEnv, [Name], SrcSpan)
 514
 515 -- Nothing case: we stopped when an exception was raised, not at a
 516 -- breakpoint.  We have no location information or local variables to
 517 -- bind, all we can do is bind a local variable to the exception
 518 -- value.
 519 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 520    let exn_fs    = fsLit "_exception"
 521        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
 522        e_fs      = fsLit "e"
 523        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
 524        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
 525        exn_id    = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
 526        new_tyvars = unitVarSet e_tyvar
 527
 528        ictxt0 = hsc_IC hsc_env
 529        ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
 530
 531        span = mkGeneralSrcSpan (fsLit "<exception thrown>")
 532    --
 533    Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
 534    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 535
 536 -- Just case: we stopped at a breakpoint, we have information about the location
 537 -- of the breakpoint and the free variables of the expression.
 538 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 539
 540    let
 541        mod_name  = moduleName (breakInfo_module info)
 542        hmi       = expectJust "bindLocalsAtBreakpoint" $
 543                         lookupUFM (hsc_HPT hsc_env) mod_name
 544        breaks    = getModBreaks hmi
 545        index     = breakInfo_number info
 546        vars      = breakInfo_vars info
 547        result_ty = breakInfo_resty info
 548        occs      = modBreaks_vars breaks ! index
 549        span      = modBreaks_locs breaks ! index
 550
 551    -- filter out any unboxed ids; we can't bind these at the prompt
 552    let pointers = filter (\(id,_) -> isPointer id) vars
 553        isPointer id | PtrRep <- idPrimRep id = True
 554                     | otherwise              = False
 555
 556    let (ids, offsets) = unzip pointers
 557
 558    -- It might be that getIdValFromApStack fails, because the AP_STACK
 559    -- has been accidentally evaluated, or something else has gone wrong.
 560    -- So that we don't fall over in a heap when this happens, just don't
 561    -- bind any free variables instead, and we emit a warning.
 562    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
 563    let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
 564    when (any isNothing mb_hValues) $
 565       debugTraceMsg (hsc_dflags hsc_env) 1 $
 566           text "Warning: _result has been evaluated, some bindings have been lost"
 567
 568    new_ids <- zipWithM mkNewId occs filtered_ids
 569    let names = map idName new_ids
 570
 571    -- make an Id for _result.  We use the Unique of the FastString "_result";
 572    -- we don't care about uniqueness here, because there will only be one
 573    -- _result in scope at any time.
 574    let result_name = mkInternalName (getUnique result_fs)
 575                           (mkVarOccFS result_fs) span
 576        result_id   = Id.mkVanillaGlobal result_name result_ty
 577
 578    -- for each Id we're about to bind in the local envt:
 579    --    - skolemise the type variables in its type, so they can't
 580    --      be randomly unified with other types.  These type variables
 581    --      can only be resolved by type reconstruction in RtClosureInspect
 582    --    - tidy the type variables
 583    --    - globalise the Id (Ids are supposed to be Global, apparently).
 584    --
 585    let all_ids | isPointer result_id = result_id : new_ids
 586                | otherwise           = new_ids
 587        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 588        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 589        new_tyvars = unionVarSets tyvarss
 590    let final_ids = zipWith setIdType all_ids tidy_tys
 591        ictxt0 = hsc_IC hsc_env
 592        ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 593    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 594    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 595    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
 596    return (hsc_env1, result_name:names, span)
 597   where
 598    mkNewId :: OccName -> Id -> IO Id
 599    mkNewId occ id = do
 600      us <- mkSplitUniqSupply 'I'
 601         -- we need a fresh Unique for each Id we bind, because the linker
 602         -- state is single-threaded and otherwise we'd spam old bindings
 603         -- whenever we stop at a breakpoint.  The InteractveContext is properly
 604         -- saved/restored, but not the linker state.  See #1743, test break026.
 605      let
 606          uniq = uniqFromSupply us
 607          loc = nameSrcSpan (idName id)
 608          name = mkInternalName uniq occ loc
 609          ty = idType id
 610          new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
 611      return new_id
 612
 613 rttiEnvironment :: HscEnv -> IO HscEnv
 614 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
 615    let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 616        incompletelyTypedIds =
 617            [id | id <- tmp_ids
 618                , not $ noSkolems id
 619                , (occNameFS.nameOccName.idName) id /= result_fs]
 620    hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
 621    return hsc_env'
 622     where
 623      noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
 624      improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
 625       let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 626           Just id = find (\i -> idName i == name) tmp_ids
 627       if noSkolems id
 628          then return hsc_env
 629          else do
 630            mb_new_ty <- reconstructType hsc_env 10 id
 631            let old_ty = idType id
 632            case mb_new_ty of
 633              Nothing -> return hsc_env
 634              Just new_ty -> do
 635               mb_subst <- improveRTTIType hsc_env old_ty new_ty
 636               case mb_subst of
 637                Nothing -> return $
 638                         WARN(True, text (":print failed to calculate the "
 639                                            ++ "improvement for a type")) hsc_env
 640                Just subst -> do
 641                  when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
 642                       printForUser stderr alwaysQualify $
 643                       fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
 644
 645                  let (subst', skols) = skolemiseSubst subst
 646                      ic' = extendInteractiveContext
 647                                (substInteractiveContext ic subst') [] skols
 648                  return hsc_env{hsc_IC=ic'}
 649
 650 skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
 651 skolemiseSubst subst = let
 652     varenv               = getTvSubstEnv subst
 653     all_together         = mapVarEnv skolemiseTy varenv
 654     (varenv', skol_vars) = ( mapVarEnv fst all_together
 655                            , map snd (varEnvElts all_together))
 656     in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
 657
 658
 659 skolemiseTy :: Type -> (Type, TyVarSet)
 660 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 661   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 662         subst         = mkTvSubst emptyInScopeSet env
 663         tyvars        = varSetElems (tyVarsOfType ty)
 664         new_tyvars    = map skolemiseTyVar tyvars
 665         new_tyvar_tys = map mkTyVarTy new_tyvars
 666
 667 skolemiseTyVar :: TyVar -> TyVar
 668 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 669                                  (SkolemTv RuntimeUnkSkol)
 670
 671 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 672 getIdValFromApStack apStack (I# stackDepth) = do
 673    case getApStackVal# apStack (stackDepth +# 1#) of
 674                                 -- The +1 is magic!  I don't know where it comes
 675                                 -- from, but this makes things line up.  --SDM
 676         (# ok, result #) ->
 677             case ok of
 678               0# -> return Nothing -- AP_STACK not found
 679               _  -> return (Just (unsafeCoerce# result))
 680
 681 pushResume :: HscEnv -> Resume -> HscEnv
 682 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 683   where
 684         ictxt0 = hsc_IC hsc_env
 685         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 686
 687 -- -----------------------------------------------------------------------------
 688 -- Abandoning a resume context
 689
 690 abandon :: GhcMonad m => m Bool
 691 abandon = do
 692    hsc_env <- getSession
 693    let ic = hsc_IC hsc_env
 694        resume = ic_resume ic
 695    case resume of
 696       []    -> return False
 697       r:rs  -> do
 698          modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
 699          liftIO $ abandon_ r
 700          return True
 701
 702 abandonAll :: GhcMonad m => m Bool
 703 abandonAll = do
 704    hsc_env <- getSession
 705    let ic = hsc_IC hsc_env
 706        resume = ic_resume ic
 707    case resume of
 708       []  -> return False
 709       rs  -> do
 710          modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
 711          liftIO $ mapM_ abandon_ rs
 712          return True
 713
 714 -- when abandoning a computation we have to
 715 --      (a) kill the thread with an async exception, so that the
 716 --          computation itself is stopped, and
 717 --      (b) fill in the MVar.  This step is necessary because any
 718 --          thunks that were under evaluation will now be updated
 719 --          with the partial computation, which still ends in takeMVar,
 720 --          so any attempt to evaluate one of these thunks will block
 721 --          unless we fill in the MVar.
 722 --  See test break010.
 723 abandon_ :: Resume -> IO ()
 724 abandon_ r = do
 725   killThread (resumeThreadId r)
 726   putMVar (resumeBreakMVar r) ()
 727
 728 -- -----------------------------------------------------------------------------
 729 -- Bounded list, optimised for repeated cons
 730
 731 data BoundedList a = BL
 732                         {-# UNPACK #-} !Int  -- length
 733                         {-# UNPACK #-} !Int  -- bound
 734                         [a] -- left
 735                         [a] -- right,  list is (left ++ reverse right)
 736
 737 nilBL :: Int -> BoundedList a
 738 nilBL bound = BL 0 bound [] []
 739
 740 consBL :: a -> BoundedList a -> BoundedList a
 741 consBL a (BL len bound left right)
 742   | len < bound = BL (len+1) bound (a:left) right
 743   | null right  = BL len     bound [a]      $! tail (reverse left)
 744   | otherwise   = BL len     bound (a:left) $! tail right
 745
 746 toListBL :: BoundedList a -> [a]
 747 toListBL (BL _ _ left right) = left ++ reverse right
 748
 749 fromListBL :: Int -> [a] -> BoundedList a
 750 fromListBL bound l = BL (length l) bound l []
 751
 752 -- lenBL (BL len _ _ _) = len
 753
 754 -- -----------------------------------------------------------------------------
 755 -- | Set the interactive evaluation context.
 756 --
 757 -- Setting the context doesn't throw away any bindings; the bindings
 758 -- we've built up in the InteractiveContext simply move to the new
 759 -- module.  They always shadow anything in scope in the current context.
 760 setContext :: GhcMonad m =>
 761               [Module]  -- ^ entire top level scope of these modules
 762            -> [Module]  -- ^ exports only of these modules
 763            -> m ()
 764 setContext toplev_mods export_mods = do
 765   hsc_env <- getSession
 766   let old_ic  = hsc_IC     hsc_env
 767       hpt     = hsc_HPT    hsc_env
 768   --
 769   export_env  <- liftIO $ mkExportEnv hsc_env export_mods
 770   toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
 771   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 772   modifySession $ \_ ->
 773       hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 774                                  ic_exports      = export_mods,
 775                                  ic_rn_gbl_env   = all_env }}
 776
 777 -- Make a GlobalRdrEnv based on the exports of the modules only.
 778 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 779 mkExportEnv hsc_env mods = do
 780   stuff <- mapM (getModuleExports hsc_env) mods
 781   let
 782         (_msgs, mb_name_sets) = unzip stuff
 783         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 784                | (Just avails, mod) <- zip mb_name_sets mods ]
 785   --
 786   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 787
 788 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 789 nameSetToGlobalRdrEnv names mod =
 790   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 791                  | name <- nameSetToList names ]
 792
 793 vanillaProv :: ModuleName -> Provenance
 794 -- We're building a GlobalRdrEnv as if the user imported
 795 -- all the specified modules into the global interactive module
 796 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 797   where
 798     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 799                          is_qual = False,
 800                          is_dloc = srcLocSpan interactiveSrcLoc }
 801
 802 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 803 mkTopLevEnv hpt modl
 804   = case lookupUFM hpt (moduleName modl) of
 805       Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
 806                                                 showSDoc (ppr modl)))
 807       Just details ->
 808          case mi_globals (hm_iface details) of
 809                 Nothing  ->
 810                    ghcError (ProgramError ("mkTopLevEnv: not interpreted "
 811                                                 ++ showSDoc (ppr modl)))
 812                 Just env -> return env
 813
 814 -- | Get the interactive evaluation context, consisting of a pair of the
 815 -- set of modules from which we take the full top-level scope, and the set
 816 -- of modules from which we take just the exports respectively.
 817 getContext :: GhcMonad m => m ([Module],[Module])
 818 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
 819                return (ic_toplev_scope ic, ic_exports ic)
 820
 821 -- | Returns @True@ if the specified module is interpreted, and hence has
 822 -- its full top-level scope available.
 823 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
 824 moduleIsInterpreted modl = withSession $ \h ->
 825  if modulePackageId modl /= thisPackage (hsc_dflags h)
 826         then return False
 827         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 828                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 829                 _not_a_home_module -> return False
 830
 831 -- | Looks up an identifier in the current interactive context (for :info)
 832 -- Filter the instances by the ones whose tycons (or clases resp)
 833 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 834 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 835 --      (see Trac #1581)
 836 getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
 837 getInfo name
 838   = withSession $ \hsc_env ->
 839     do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
 840        case mb_stuff of
 841          Nothing -> return Nothing
 842          Just (thing, fixity, ispecs) -> do
 843            let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
 844            return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
 845   where
 846     plausible rdr_env ispec     -- Dfun involving only names that are in ic_rn_glb_env
 847         = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
 848         where   -- A name is ok if it's in the rdr_env,
 849                 -- whether qualified or not
 850           ok n | n == name         = True       -- The one we looked for in the first place!
 851                | isBuiltInSyntax n = True
 852                | isExternalName n  = any ((== n) . gre_name)
 853                                          (lookupGRE_Name rdr_env n)
 854                | otherwise         = True
 855
 856 -- | Returns all names in scope in the current interactive context
 857 getNamesInScope :: GhcMonad m => m [Name]
 858 getNamesInScope = withSession $ \hsc_env -> do
 859   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 860
 861 getRdrNamesInScope :: GhcMonad m => m [RdrName]
 862 getRdrNamesInScope = withSession $ \hsc_env -> do
 863   let
 864       ic = hsc_IC hsc_env
 865       gbl_rdrenv = ic_rn_gbl_env ic
 866       ids = ic_tmp_ids ic
 867       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 868       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 869   --
 870   return (gbl_names ++ lcl_names)
 871
 872
 873 -- ToDo: move to RdrName
 874 greToRdrNames :: GlobalRdrElt -> [RdrName]
 875 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 876   = case prov of
 877      LocalDef -> [unqual]
 878      Imported specs -> concat (map do_spec (map is_decl specs))
 879   where
 880     occ = nameOccName name
 881     unqual = Unqual occ
 882     do_spec decl_spec
 883         | is_qual decl_spec = [qual]
 884         | otherwise         = [unqual,qual]
 885         where qual = Qual (is_as decl_spec) occ
 886
 887 -- | Parses a string as an identifier, and returns the list of 'Name's that
 888 -- the identifier can refer to in the current interactive context.
 889 parseName :: GhcMonad m => String -> m [Name]
 890 parseName str = withSession $ \hsc_env -> do
 891    (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
 892    ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
 893
 894 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 895 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 896 lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
 897 lookupName name = withSession $ \hsc_env -> do
 898   mb_tything <- ioMsg $ tcRnLookupName hsc_env name
 899   return mb_tything
 900   -- XXX: calls panic in some circumstances;  is that ok?
 901
 902 -- -----------------------------------------------------------------------------
 903 -- Getting the type of an expression
 904
 905 -- | Get the type of an expression
 906 exprType :: GhcMonad m => String -> m Type
 907 exprType expr = withSession $ \hsc_env -> do
 908    ty <- hscTcExpr hsc_env expr
 909    return $ tidyType emptyTidyEnv ty
 910
 911 -- -----------------------------------------------------------------------------
 912 -- Getting the kind of a type
 913
 914 -- | Get the kind of a  type
 915 typeKind  :: GhcMonad m => String -> m Kind
 916 typeKind str = withSession $ \hsc_env -> do
 917    hscKcType hsc_env str
 918
 919 -----------------------------------------------------------------------------
 920 -- cmCompileExpr: compile an expression and deliver an HValue
 921
 922 compileExpr :: GhcMonad m => String -> m HValue
 923 compileExpr expr = withSession $ \hsc_env -> do
 924   Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 925                  -- Run it!
 926   hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
 927
 928   case (ids,hvals) of
 929     ([_],[hv]) -> return hv
 930     _        -> panic "compileExpr"
 931
 932 -- -----------------------------------------------------------------------------
 933 -- Compile an expression into a dynamic
 934
 935 dynCompileExpr :: GhcMonad m => String -> m Dynamic
 936 dynCompileExpr expr = do
 937     (full,exports) <- getContext
 938     setContext full $
 939         (mkModule
 940             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 941         ):exports
 942     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 943     Just (ids, hvals) <- withSession (flip hscStmt stmt)
 944     setContext full exports
 945     vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
 946     case (ids,vals) of
 947         (_:[], v:[])    -> return v
 948         _               -> panic "dynCompileExpr"
 949
 950 -----------------------------------------------------------------------------
 951 -- show a module and it's source/object filenames
 952
 953 showModule :: GhcMonad m => ModSummary -> m String
 954 showModule mod_summary =
 955     withSession $ \hsc_env -> do
 956         interpreted <- isModuleInterpreted mod_summary
 957         return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 958
 959 isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
 960 isModuleInterpreted mod_summary = withSession $ \hsc_env ->
 961   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 962         Nothing       -> panic "missing linkable"
 963         Just mod_info -> return (not obj_linkable)
 964                       where
 965                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 966
 967 ----------------------------------------------------------------------------
 968 -- RTTI primitives
 969
 970 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
 971 obtainTermFromVal hsc_env bound force ty x =
 972               cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
 973
 974 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
 975 obtainTermFromId hsc_env bound force id =  do
 976               hv <- Linker.getHValue hsc_env (varName id)
 977               cvObtainTerm hsc_env bound force (idType id) hv
 978
 979 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 980 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 981 reconstructType hsc_env bound id = do
 982               hv <- Linker.getHValue hsc_env (varName id)
 983               cvReconstructType hsc_env bound (idType id) hv
 984
 985 #endif /* GHCI */
 986