compiler/main/InteractiveEval.hs

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