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