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