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         Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
  33 #endif
  34         ) where
  35
  36 #ifdef GHCI
  37
  38 #include "HsVersions.h"
  39
  40 import HscMain          hiding (compileExpr)
  41 import HsSyn (ImportDecl)
  42 import HscTypes
  43 import TcRnDriver
  44 import TcRnMonad (initTc)
  45 import RnNames          (gresFromAvails, rnImports)
  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 Util
  68 import SrcLoc
  69 import BreakArray
  70 import RtClosureInspect
  71 import BasicTypes
  72 import Outputable
  73 import FastString
  74 import MonadUtils
  75
  76 import System.Directory
  77 import Data.Dynamic
  78 import Data.List (find, partition)
  79 import Control.Monad
  80 import Foreign hiding (unsafePerformIO)
  81 import Foreign.C
  82 import GHC.Exts
  83 import Data.Array
  84 import Exception
  85 import Control.Concurrent
  86 import Data.List (sortBy)
  87 -- import Foreign.StablePtr
  88 import System.IO
  89 import System.IO.Unsafe
  90
  91 -- -----------------------------------------------------------------------------
  92 -- running a statement interactively
  93
  94 data RunResult
  95   = RunOk [Name]                -- ^ names bound by this evaluation
  96   | RunFailed                   -- ^ statement failed compilation
  97   | RunException SomeException  -- ^ statement raised an exception
  98   | RunBreak ThreadId [Name] (Maybe BreakInfo)
  99
 100 data Status
 101    = Break Bool HValue BreakInfo ThreadId
 102           -- ^ the computation hit a breakpoint (Bool <=> was an exception)
 103    | Complete (Either SomeException [HValue])
 104           -- ^ the computation completed with either an exception or a value
 105
 106 data Resume
 107    = Resume {
 108        resumeStmt      :: String,       -- the original statement
 109        resumeThreadId  :: ThreadId,     -- thread running the computation
 110        resumeBreakMVar :: MVar (),
 111        resumeStatMVar  :: MVar Status,
 112        resumeBindings  :: [Id],
 113        resumeFinalIds  :: [Id],         -- [Id] to bind on completion
 114        resumeApStack   :: HValue,       -- The object from which we can get
 115                                         -- value of the free variables.
 116        resumeBreakInfo :: Maybe BreakInfo,
 117                                         -- the breakpoint we stopped at
 118                                         -- (Nothing <=> exception)
 119        resumeSpan      :: SrcSpan,      -- just a cache, otherwise it's a pain
 120                                         -- to fetch the ModDetails & ModBreaks
 121                                         -- to get this.
 122        resumeHistory   :: [History],
 123        resumeHistoryIx :: Int           -- 0 <==> at the top of the history
 124    }
 125
 126 getResumeContext :: GhcMonad m => m [Resume]
 127 getResumeContext = withSession (return . ic_resume . hsc_IC)
 128
 129 data SingleStep
 130    = RunToCompletion
 131    | SingleStep
 132    | RunAndLogSteps
 133
 134 isStep :: SingleStep -> Bool
 135 isStep RunToCompletion = False
 136 isStep _ = True
 137
 138 data History
 139    = History {
 140         historyApStack   :: HValue,
 141         historyBreakInfo :: BreakInfo,
 142         historyEnclosingDecl :: Id
 143          -- ^^ A cache of the enclosing top level declaration, for convenience
 144    }
 145
 146 mkHistory :: HscEnv -> HValue -> BreakInfo -> History
 147 mkHistory hsc_env hval bi = let
 148     h    = History hval bi decl
 149     decl = findEnclosingDecl hsc_env (getHistoryModule h)
 150                                      (getHistorySpan hsc_env h)
 151     in h
 152
 153 getHistoryModule :: History -> Module
 154 getHistoryModule = breakInfo_module . historyBreakInfo
 155
 156 getHistorySpan :: HscEnv -> History -> SrcSpan
 157 getHistorySpan hsc_env hist =
 158    let inf = historyBreakInfo hist
 159        num = breakInfo_number inf
 160    in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
 161        Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
 162        _ -> panic "getHistorySpan"
 163
 164 getModBreaks :: HomeModInfo -> ModBreaks
 165 getModBreaks hmi
 166   | Just linkable <- hm_linkable hmi,
 167     [BCOs _ modBreaks] <- linkableUnlinked linkable
 168   = modBreaks
 169   | otherwise
 170   = emptyModBreaks -- probably object code
 171
 172 {- | Finds the enclosing top level function name -}
 173 -- ToDo: a better way to do this would be to keep hold of the decl_path computed
 174 -- by the coverage pass, which gives the list of lexically-enclosing bindings
 175 -- for each tick.
 176 findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
 177 findEnclosingDecl hsc_env mod span =
 178    case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
 179          Nothing -> panic "findEnclosingDecl"
 180          Just hmi -> let
 181              globals   = typeEnvIds (md_types (hm_details hmi))
 182              Just decl =
 183                  find (\id -> let n = idName id in
 184                                nameSrcSpan n < span && isExternalName n)
 185                       (reverse$ sortBy (compare `on` (nameSrcSpan.idName))
 186                                        globals)
 187            in decl
 188
 189 -- | Run a statement in the current interactive context.  Statement
 190 -- may bind multple values.
 191 runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
 192 runStmt expr step =
 193   do
 194     hsc_env <- getSession
 195
 196     breakMVar  <- liftIO $ newEmptyMVar  -- wait on this when we hit a breakpoint
 197     statusMVar <- liftIO $ newEmptyMVar  -- wait on this when a computation is running
 198
 199     -- Turn off -fwarn-unused-bindings when running a statement, to hide
 200     -- warnings about the implicit bindings we introduce.
 201     let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
 202         hsc_env' = hsc_env{ hsc_dflags = dflags' }
 203
 204     r <- hscStmt hsc_env' expr
 205
 206     case r of
 207       Nothing -> return RunFailed -- empty statement / comment
 208
 209       Just (ids, hval) -> do
 210           -- XXX: This is the only place we can print warnings before the
 211           -- result.  Is this really the right thing to do?  It's fine for
 212           -- GHCi, but what's correct for other GHC API clients?  We could
 213           -- introduce a callback argument.
 214         warns <- getWarnings
 215         liftIO $ printBagOfWarnings dflags' warns
 216         clearWarnings
 217
 218         status <-
 219           withVirtualCWD $
 220             withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
 221                 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
 222                 liftIO $ sandboxIO dflags' statusMVar thing_to_run
 223
 224         let ic = hsc_IC hsc_env
 225             bindings = ic_tmp_ids ic
 226
 227         case step of
 228           RunAndLogSteps ->
 229               traceRunStatus expr bindings ids
 230                              breakMVar statusMVar status emptyHistory
 231           _other ->
 232               handleRunStatus expr bindings ids
 233                                breakMVar statusMVar status emptyHistory
 234
 235 withVirtualCWD :: GhcMonad m => m a -> m a
 236 withVirtualCWD m = do
 237   hsc_env <- getSession
 238   let ic = hsc_IC hsc_env
 239
 240   let set_cwd = do
 241         dir <- liftIO $ getCurrentDirectory
 242         case ic_cwd ic of
 243            Just dir -> liftIO $ setCurrentDirectory dir
 244            Nothing  -> return ()
 245         return dir
 246
 247       reset_cwd orig_dir = do
 248         virt_dir <- liftIO $ getCurrentDirectory
 249         hsc_env <- getSession
 250         let old_IC = hsc_IC hsc_env
 251         setSession hsc_env{  hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
 252         liftIO $ setCurrentDirectory orig_dir
 253
 254   gbracket set_cwd reset_cwd $ \_ -> m
 255
 256 parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
 257 parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr
 258
 259 emptyHistory :: BoundedList History
 260 emptyHistory = nilBL 50 -- keep a log of length 50
 261
 262 handleRunStatus :: GhcMonad m =>
 263                    String-> [Id] -> [Id]
 264                 -> MVar () -> MVar Status -> Status -> BoundedList History
 265                 -> m RunResult
 266 handleRunStatus expr bindings final_ids breakMVar statusMVar status
 267                 history =
 268    case status of
 269       -- did we hit a breakpoint or did we complete?
 270       (Break is_exception apStack info tid) -> do
 271         hsc_env <- getSession
 272         let mb_info | is_exception = Nothing
 273                     | otherwise    = Just info
 274         (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
 275                                                                mb_info
 276         let
 277             resume = Resume { resumeStmt = expr, resumeThreadId = tid
 278                             , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
 279                             , resumeBindings = bindings, resumeFinalIds = final_ids
 280                             , resumeApStack = apStack, resumeBreakInfo = mb_info
 281                             , resumeSpan = span, resumeHistory = toListBL history
 282                             , resumeHistoryIx = 0 }
 283             hsc_env2 = pushResume hsc_env1 resume
 284         --
 285         modifySession (\_ -> hsc_env2)
 286         return (RunBreak tid names mb_info)
 287       (Complete either_hvals) ->
 288         case either_hvals of
 289             Left e -> return (RunException e)
 290             Right hvals -> do
 291                 hsc_env <- getSession
 292                 let final_ic = extendInteractiveContext (hsc_IC hsc_env) final_ids
 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] -> [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 -> -- fork starts blocked
 368      let runIt = liftM Complete $ try (restore $ rethrow dflags thing)
 369      in if dopt Opt_GhciSandbox dflags
 370         then do tid <- forkIO $ do res <- runIt
 371                                    putMVar statusMVar res -- empty: can't block
 372                 withInterruptsSentTo tid $ takeMVar statusMVar
 373         else -- GLUT on OS X needs to run on the main thread. If you
 374              -- try to use it from another thread then you just get a
 375              -- white rectangle rendered. For this, or anything else
 376              -- with such restrictions, you can turn the GHCi sandbox off
 377              -- and things will be run in the main thread.
 378              runIt
 379
 380 -- We want to turn ^C into a break when -fbreak-on-exception is on,
 381 -- but it's an async exception and we only break for sync exceptions.
 382 -- Idea: if we catch and re-throw it, then the re-throw will trigger
 383 -- a break.  Great - but we don't want to re-throw all exceptions, because
 384 -- then we'll get a double break for ordinary sync exceptions (you'd have
 385 -- to :continue twice, which looks strange).  So if the exception is
 386 -- not "Interrupted", we unset the exception flag before throwing.
 387 --
 388 rethrow :: DynFlags -> IO a -> IO a
 389 rethrow dflags io = Exception.catch io $ \se -> do
 390                    -- If -fbreak-on-error, we break unconditionally,
 391                    --  but with care of not breaking twice
 392                 if dopt Opt_BreakOnError dflags &&
 393                    not (dopt Opt_BreakOnException dflags)
 394                     then poke exceptionFlag 1
 395                     else case fromException se of
 396                          -- If it is a "UserInterrupt" exception, we allow
 397                          --  a possible break by way of -fbreak-on-exception
 398                          Just UserInterrupt -> return ()
 399                          -- In any other case, we don't want to break
 400                          _ -> poke exceptionFlag 0
 401
 402                 Exception.throwIO se
 403
 404 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 405 withInterruptsSentTo thread get_result = do
 406   bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
 407           (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
 408           (\_ -> get_result)
 409
 410 -- This function sets up the interpreter for catching breakpoints, and
 411 -- resets everything when the computation has stopped running.  This
 412 -- is a not-very-good way to ensure that only the interactive
 413 -- evaluation should generate breakpoints.
 414 withBreakAction :: (ExceptionMonad m, MonadIO m) =>
 415                    Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
 416 withBreakAction step dflags breakMVar statusMVar act
 417  = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
 418  where
 419    setBreakAction = do
 420      stablePtr <- newStablePtr onBreak
 421      poke breakPointIOAction stablePtr
 422      when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
 423      when step $ setStepFlag
 424      return stablePtr
 425         -- Breaking on exceptions is not enabled by default, since it
 426         -- might be a bit surprising.  The exception flag is turned off
 427         -- as soon as it is hit, or in resetBreakAction below.
 428
 429    onBreak is_exception info apStack = do
 430      tid <- myThreadId
 431      putMVar statusMVar (Break is_exception apStack info tid)
 432      takeMVar breakMVar
 433
 434    resetBreakAction stablePtr = do
 435      poke breakPointIOAction noBreakStablePtr
 436      poke exceptionFlag 0
 437      resetStepFlag
 438      freeStablePtr stablePtr
 439
 440 noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
 441 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 442
 443 noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
 444 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
 445 noBreakAction True  _ _ = return () -- exception: just continue
 446
 447 resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
 448 resume canLogSpan step
 449  = do
 450    hsc_env <- getSession
 451    let ic = hsc_IC hsc_env
 452        resume = ic_resume ic
 453
 454    case resume of
 455      [] -> ghcError (ProgramError "not stopped at a breakpoint")
 456      (r:rs) -> do
 457         -- unbind the temporary locals by restoring the TypeEnv from
 458         -- before the breakpoint, and drop this Resume from the
 459         -- InteractiveContext.
 460         let resume_tmp_ids = resumeBindings r
 461             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
 462                        ic_resume   = rs }
 463         modifySession (\_ -> hsc_env{ hsc_IC = ic' })
 464
 465         -- remove any bindings created since the breakpoint from the
 466         -- linker's environment
 467         let new_names = map idName (filter (`notElem` resume_tmp_ids)
 468                                            (ic_tmp_ids ic))
 469         liftIO $ Linker.deleteFromLinkEnv new_names
 470
 471         when (isStep step) $ liftIO setStepFlag
 472         case r of
 473           Resume { resumeStmt = expr, resumeThreadId = tid
 474                  , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
 475                  , resumeBindings = bindings, resumeFinalIds = final_ids
 476                  , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
 477                  , resumeHistory = hist } -> do
 478                withVirtualCWD $ do
 479                 withBreakAction (isStep step) (hsc_dflags hsc_env)
 480                                         breakMVar statusMVar $ do
 481                 status <- liftIO $ withInterruptsSentTo tid $ do
 482                              putMVar breakMVar ()
 483                                       -- this awakens the stopped thread...
 484                              takeMVar statusMVar
 485                                       -- and wait for the result
 486                 let prevHistoryLst = fromListBL 50 hist
 487                     hist' = case info of
 488                        Nothing -> prevHistoryLst
 489                        Just i
 490                          | not $canLogSpan span -> prevHistoryLst
 491                          | otherwise -> mkHistory hsc_env apStack i `consBL`
 492                                                         fromListBL 50 hist
 493                 case step of
 494                   RunAndLogSteps ->
 495                         traceRunStatus expr bindings final_ids
 496                                        breakMVar statusMVar status hist'
 497                   _other ->
 498                         handleRunStatus expr bindings final_ids
 499                                         breakMVar statusMVar status hist'
 500
 501 back :: GhcMonad m => m ([Name], Int, SrcSpan)
 502 back  = moveHist (+1)
 503
 504 forward :: GhcMonad m => m ([Name], Int, SrcSpan)
 505 forward  = moveHist (subtract 1)
 506
 507 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
 508 moveHist fn = do
 509   hsc_env <- getSession
 510   case ic_resume (hsc_IC hsc_env) of
 511      [] -> ghcError (ProgramError "not stopped at a breakpoint")
 512      (r:rs) -> do
 513         let ix = resumeHistoryIx r
 514             history = resumeHistory r
 515             new_ix = fn ix
 516         --
 517         when (new_ix > length history) $
 518            ghcError (ProgramError "no more logged breakpoints")
 519         when (new_ix < 0) $
 520            ghcError (ProgramError "already at the beginning of the history")
 521
 522         let
 523           update_ic apStack mb_info = do
 524             (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
 525                                                 apStack mb_info
 526             let ic = hsc_IC hsc_env1
 527                 r' = r { resumeHistoryIx = new_ix }
 528                 ic' = ic { ic_resume = r':rs }
 529
 530             modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
 531
 532             return (names, new_ix, span)
 533
 534         -- careful: we want apStack to be the AP_STACK itself, not a thunk
 535         -- around it, hence the cases are carefully constructed below to
 536         -- make this the case.  ToDo: this is v. fragile, do something better.
 537         if new_ix == 0
 538            then case r of
 539                    Resume { resumeApStack = apStack,
 540                             resumeBreakInfo = mb_info } ->
 541                           update_ic apStack mb_info
 542            else case history !! (new_ix - 1) of
 543                    History apStack info _ ->
 544                           update_ic apStack (Just info)
 545
 546 -- -----------------------------------------------------------------------------
 547 -- After stopping at a breakpoint, add free variables to the environment
 548 result_fs :: FastString
 549 result_fs = fsLit "_result"
 550
 551 bindLocalsAtBreakpoint
 552         :: HscEnv
 553         -> HValue
 554         -> Maybe BreakInfo
 555         -> IO (HscEnv, [Name], SrcSpan)
 556
 557 -- Nothing case: we stopped when an exception was raised, not at a
 558 -- breakpoint.  We have no location information or local variables to
 559 -- bind, all we can do is bind a local variable to the exception
 560 -- value.
 561 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 562    let exn_fs    = fsLit "_exception"
 563        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
 564        e_fs      = fsLit "e"
 565        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
 566        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
 567        exn_id    = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
 568
 569        ictxt0 = hsc_IC hsc_env
 570        ictxt1 = extendInteractiveContext ictxt0 [exn_id]
 571
 572        span = mkGeneralSrcSpan (fsLit "<exception thrown>")
 573    --
 574    Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
 575    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 576
 577 -- Just case: we stopped at a breakpoint, we have information about the location
 578 -- of the breakpoint and the free variables of the expression.
 579 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 580
 581    let
 582        mod_name  = moduleName (breakInfo_module info)
 583        hmi       = expectJust "bindLocalsAtBreakpoint" $
 584                         lookupUFM (hsc_HPT hsc_env) mod_name
 585        breaks    = getModBreaks hmi
 586        index     = breakInfo_number info
 587        vars      = breakInfo_vars info
 588        result_ty = breakInfo_resty info
 589        occs      = modBreaks_vars breaks ! index
 590        span      = modBreaks_locs breaks ! index
 591
 592    -- filter out any unboxed ids; we can't bind these at the prompt
 593    let pointers = filter (\(id,_) -> isPointer id) vars
 594        isPointer id | PtrRep <- idPrimRep id = True
 595                     | otherwise              = False
 596
 597    let (ids, offsets) = unzip pointers
 598
 599    -- It might be that getIdValFromApStack fails, because the AP_STACK
 600    -- has been accidentally evaluated, or something else has gone wrong.
 601    -- So that we don't fall over in a heap when this happens, just don't
 602    -- bind any free variables instead, and we emit a warning.
 603    mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
 604    let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
 605    when (any isNothing mb_hValues) $
 606       debugTraceMsg (hsc_dflags hsc_env) 1 $
 607           text "Warning: _result has been evaluated, some bindings have been lost"
 608
 609    new_ids <- zipWithM mkNewId occs filtered_ids
 610    let names = map idName new_ids
 611
 612    -- make an Id for _result.  We use the Unique of the FastString "_result";
 613    -- we don't care about uniqueness here, because there will only be one
 614    -- _result in scope at any time.
 615    let result_name = mkInternalName (getUnique result_fs)
 616                           (mkVarOccFS result_fs) span
 617        result_id   = Id.mkVanillaGlobal result_name result_ty
 618
 619    -- for each Id we're about to bind in the local envt:
 620    --    - tidy the type variables
 621    --    - globalise the Id (Ids are supposed to be Global, apparently).
 622    --
 623    let result_ok = isPointer result_id
 624                     && not (isUnboxedTupleType (idType result_id))
 625
 626        all_ids | result_ok = result_id : new_ids
 627                | otherwise = new_ids
 628        id_tys = map idType all_ids
 629        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 630        final_ids = zipWith setIdType all_ids tidy_tys
 631        ictxt0 = hsc_IC hsc_env
 632        ictxt1 = extendInteractiveContext ictxt0 final_ids
 633
 634    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 635    when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 636    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
 637    return (hsc_env1, if result_ok then result_name:names else names, span)
 638   where
 639    mkNewId :: OccName -> Id -> IO Id
 640    mkNewId occ id = do
 641      us <- mkSplitUniqSupply 'I'
 642         -- we need a fresh Unique for each Id we bind, because the linker
 643         -- state is single-threaded and otherwise we'd spam old bindings
 644         -- whenever we stop at a breakpoint.  The InteractveContext is properly
 645         -- saved/restored, but not the linker state.  See #1743, test break026.
 646      let
 647          uniq = uniqFromSupply us
 648          loc = nameSrcSpan (idName id)
 649          name = mkInternalName uniq occ loc
 650          ty = idType id
 651          new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
 652      return new_id
 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         -> [(Module, Maybe (ImportDecl RdrName))]       -- ^ exports of these modules
 781         -> m ()
 782 setContext toplev_mods other_mods = do
 783     hsc_env <- getSession
 784     let old_ic  = hsc_IC     hsc_env
 785         hpt     = hsc_HPT    hsc_env
 786         (decls,mods)   = partition (isJust . snd) other_mods -- time for tracing
 787         export_mods = map fst mods
 788         imprt_decls = map noLoc (catMaybes (map snd decls))
 789     --
 790     export_env  <- liftIO $ mkExportEnv hsc_env export_mods
 791     import_env  <-
 792         if null imprt_decls then return emptyGlobalRdrEnv else do
 793             let imports = rnImports imprt_decls
 794                 this_mod = if null toplev_mods then pRELUDE else head toplev_mods
 795             (_, env, _,_) <-
 796                 ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports
 797             return env
 798     toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
 799     let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
 800     modifySession $ \_ ->
 801         hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 802                          ic_exports      = other_mods,
 803                          ic_rn_gbl_env   = all_env }}
 804
 805 -- Make a GlobalRdrEnv based on the exports of the modules only.
 806 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 807 mkExportEnv hsc_env mods
 808   = do { stuff <- mapM (getModuleExports hsc_env) mods
 809        ; let (_msgs, mb_name_sets) = unzip stuff
 810              envs = [ availsToGlobalRdrEnv (moduleName mod) avails
 811                     | (Just avails, mod) <- zip mb_name_sets mods ]
 812        ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }
 813
 814 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
 815 availsToGlobalRdrEnv mod_name avails
 816   = mkGlobalRdrEnv (gresFromAvails imp_prov avails)
 817   where
 818       -- We're building a GlobalRdrEnv as if the user imported
 819       -- all the specified modules into the global interactive module
 820     imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 821     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 822                          is_qual = False,
 823                          is_dloc = srcLocSpan interactiveSrcLoc }
 824
 825 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 826 mkTopLevEnv hpt modl
 827   = case lookupUFM hpt (moduleName modl) of
 828       Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
 829                                                 showSDoc (ppr modl)))
 830       Just details ->
 831          case mi_globals (hm_iface details) of
 832                 Nothing  ->
 833                    ghcError (ProgramError ("mkTopLevEnv: not interpreted "
 834                                                 ++ showSDoc (ppr modl)))
 835                 Just env -> return env
 836
 837 -- | Get the interactive evaluation context, consisting of a pair of the
 838 -- set of modules from which we take the full top-level scope, and the set
 839 -- of modules from which we take just the exports respectively.
 840 getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))])
 841 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
 842                return (ic_toplev_scope ic, ic_exports ic)
 843
 844 -- | Returns @True@ if the specified module is interpreted, and hence has
 845 -- its full top-level scope available.
 846 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
 847 moduleIsInterpreted modl = withSession $ \h ->
 848  if modulePackageId modl /= thisPackage (hsc_dflags h)
 849         then return False
 850         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 851                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 852                 _not_a_home_module -> return False
 853
 854 -- | Looks up an identifier in the current interactive context (for :info)
 855 -- Filter the instances by the ones whose tycons (or clases resp)
 856 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 857 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 858 --      (see Trac #1581)
 859 getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
 860 getInfo name
 861   = withSession $ \hsc_env ->
 862     do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
 863        case mb_stuff of
 864          Nothing -> return Nothing
 865          Just (thing, fixity, ispecs) -> do
 866            let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
 867            return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
 868   where
 869     plausible rdr_env ispec     -- Dfun involving only names that are in ic_rn_glb_env
 870         = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
 871         where   -- A name is ok if it's in the rdr_env,
 872                 -- whether qualified or not
 873           ok n | n == name         = True       -- The one we looked for in the first place!
 874                | isBuiltInSyntax n = True
 875                | isExternalName n  = any ((== n) . gre_name)
 876                                          (lookupGRE_Name rdr_env n)
 877                | otherwise         = True
 878
 879 -- | Returns all names in scope in the current interactive context
 880 getNamesInScope :: GhcMonad m => m [Name]
 881 getNamesInScope = withSession $ \hsc_env -> do
 882   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 883
 884 getRdrNamesInScope :: GhcMonad m => m [RdrName]
 885 getRdrNamesInScope = withSession $ \hsc_env -> do
 886   let
 887       ic = hsc_IC hsc_env
 888       gbl_rdrenv = ic_rn_gbl_env ic
 889       ids = ic_tmp_ids ic
 890       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 891       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 892   --
 893   return (gbl_names ++ lcl_names)
 894
 895
 896 -- ToDo: move to RdrName
 897 greToRdrNames :: GlobalRdrElt -> [RdrName]
 898 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 899   = case prov of
 900      LocalDef -> [unqual]
 901      Imported specs -> concat (map do_spec (map is_decl specs))
 902   where
 903     occ = nameOccName name
 904     unqual = Unqual occ
 905     do_spec decl_spec
 906         | is_qual decl_spec = [qual]
 907         | otherwise         = [unqual,qual]
 908         where qual = Qual (is_as decl_spec) occ
 909
 910 -- | Parses a string as an identifier, and returns the list of 'Name's that
 911 -- the identifier can refer to in the current interactive context.
 912 parseName :: GhcMonad m => String -> m [Name]
 913 parseName str = withSession $ \hsc_env -> do
 914    (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
 915    ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
 916
 917 -- -----------------------------------------------------------------------------
 918 -- Getting the type of an expression
 919
 920 -- | Get the type of an expression
 921 exprType :: GhcMonad m => String -> m Type
 922 exprType expr = withSession $ \hsc_env -> do
 923    ty <- hscTcExpr hsc_env expr
 924    return $ tidyType emptyTidyEnv ty
 925
 926 -- -----------------------------------------------------------------------------
 927 -- Getting the kind of a type
 928
 929 -- | Get the kind of a  type
 930 typeKind  :: GhcMonad m => String -> m Kind
 931 typeKind str = withSession $ \hsc_env -> do
 932    hscKcType hsc_env str
 933
 934 -----------------------------------------------------------------------------
 935 -- cmCompileExpr: compile an expression and deliver an HValue
 936
 937 compileExpr :: GhcMonad m => String -> m HValue
 938 compileExpr expr = withSession $ \hsc_env -> do
 939   Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 940                  -- Run it!
 941   hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
 942
 943   case (ids,hvals) of
 944     ([_],[hv]) -> return hv
 945     _        -> panic "compileExpr"
 946
 947 -- -----------------------------------------------------------------------------
 948 -- Compile an expression into a dynamic
 949
 950 dynCompileExpr :: GhcMonad m => String -> m Dynamic
 951 dynCompileExpr expr = do
 952     (full,exports) <- getContext
 953     setContext full $
 954         (mkModule
 955             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 956         ,Nothing):exports
 957     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 958     Just (ids, hvals) <- withSession (flip hscStmt stmt)
 959     setContext full exports
 960     vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
 961     case (ids,vals) of
 962         (_:[], v:[])    -> return v
 963         _               -> panic "dynCompileExpr"
 964
 965 -----------------------------------------------------------------------------
 966 -- show a module and it's source/object filenames
 967
 968 showModule :: GhcMonad m => ModSummary -> m String
 969 showModule mod_summary =
 970     withSession $ \hsc_env -> do
 971         interpreted <- isModuleInterpreted mod_summary
 972         return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 973
 974 isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
 975 isModuleInterpreted mod_summary = withSession $ \hsc_env ->
 976   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 977         Nothing       -> panic "missing linkable"
 978         Just mod_info -> return (not obj_linkable)
 979                       where
 980                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 981
 982 ----------------------------------------------------------------------------
 983 -- RTTI primitives
 984
 985 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
 986 obtainTermFromVal hsc_env bound force ty x =
 987               cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
 988
 989 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
 990 obtainTermFromId hsc_env bound force id =  do
 991               hv <- Linker.getHValue hsc_env (varName id)
 992               cvObtainTerm hsc_env bound force (idType id) hv
 993
 994 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 995 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 996 reconstructType hsc_env bound id = do
 997               hv <- Linker.getHValue hsc_env (varName id)
 998               cvReconstructType hsc_env bound (idType id) hv
 999
1000 #endif /* GHCI */
1001