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