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