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 rethrow dflags io = Exception.catch io $ \se -> do
 354                    -- If -fbreak-on-error, we break unconditionally,
 355                    --  but with care of not breaking twice
 356                 if dopt Opt_BreakOnError dflags &&
 357                    not (dopt Opt_BreakOnException dflags)
 358                     then poke exceptionFlag 1
 359                     else case fromException se of
 360                          -- If it is an "Interrupted" exception, we allow
 361                          --  a possible break by way of -fbreak-on-exception
 362                          Just Interrupted -> return ()
 363                          -- In any other case, we don't want to break
 364                          _ -> poke exceptionFlag 0
 365
 366                 Exception.throwIO se
 367
 368 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 369 withInterruptsSentTo thread get_result = do
 370   bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
 371           (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
 372           (\_ -> get_result)
 373
 374 -- This function sets up the interpreter for catching breakpoints, and
 375 -- resets everything when the computation has stopped running.  This
 376 -- is a not-very-good way to ensure that only the interactive
 377 -- evaluation should generate breakpoints.
 378 withBreakAction :: (ExceptionMonad m, MonadIO m) =>
 379                    Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
 380 withBreakAction step dflags breakMVar statusMVar act
 381  = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
 382  where
 383    setBreakAction = do
 384      stablePtr <- newStablePtr onBreak
 385      poke breakPointIOAction stablePtr
 386      when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
 387      when step $ setStepFlag
 388      return stablePtr
 389         -- Breaking on exceptions is not enabled by default, since it
 390         -- might be a bit surprising.  The exception flag is turned off
 391         -- as soon as it is hit, or in resetBreakAction below.
 392
 393    onBreak is_exception info apStack = do
 394      tid <- myThreadId
 395      putMVar statusMVar (Break is_exception apStack info tid)
 396      takeMVar breakMVar
 397
 398    resetBreakAction stablePtr = do
 399      poke breakPointIOAction noBreakStablePtr
 400      poke exceptionFlag 0
 401      resetStepFlag
 402      freeStablePtr stablePtr
 403
 404 noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
 405 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 406
 407 noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
 408 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
 409 noBreakAction True  _ _ = return () -- exception: just continue
 410
 411 resume :: GhcMonad m => SingleStep -> m RunResult
 412 resume step
 413  = do
 414    hsc_env <- getSession
 415    let ic = hsc_IC hsc_env
 416        resume = ic_resume ic
 417
 418    case resume of
 419      [] -> ghcError (ProgramError "not stopped at a breakpoint")
 420      (r:rs) -> do
 421         -- unbind the temporary locals by restoring the TypeEnv from
 422         -- before the breakpoint, and drop this Resume from the
 423         -- InteractiveContext.
 424         let (resume_tmp_ids, resume_tyvars) = resumeBindings r
 425             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
 426                        ic_tyvars   = resume_tyvars,
 427                        ic_resume   = rs }
 428         modifySession (\_ -> hsc_env{ hsc_IC = ic' })
 429
 430         -- remove any bindings created since the breakpoint from the
 431         -- linker's environment
 432         let new_names = map idName (filter (`notElem` resume_tmp_ids)
 433                                            (ic_tmp_ids ic))
 434         liftIO $ Linker.deleteFromLinkEnv new_names
 435
 436         when (isStep step) $ liftIO setStepFlag
 437         case r of
 438           Resume expr tid breakMVar statusMVar bindings
 439               final_ids apStack info _ hist _ -> do
 440                 withBreakAction (isStep step) (hsc_dflags hsc_env)
 441                                         breakMVar statusMVar $ do
 442                 status <- liftIO $ withInterruptsSentTo tid $ do
 443                              putMVar breakMVar ()
 444                                       -- this awakens the stopped thread...
 445                              takeMVar statusMVar
 446                                       -- and wait for the result
 447                 let hist' =
 448                      case info of
 449                        Nothing -> fromListBL 50 hist
 450                        Just i -> mkHistory hsc_env apStack i `consBL`
 451                                                         fromListBL 50 hist
 452                 case step of
 453                   RunAndLogSteps ->
 454                         traceRunStatus expr bindings final_ids
 455                                        breakMVar statusMVar status hist'
 456                   _other ->
 457                         handleRunStatus expr bindings final_ids
 458                                         breakMVar statusMVar status hist'
 459
 460 back :: GhcMonad m => m ([Name], Int, SrcSpan)
 461 back  = moveHist (+1)
 462
 463 forward :: GhcMonad m => m ([Name], Int, SrcSpan)
 464 forward  = moveHist (subtract 1)
 465
 466 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
 467 moveHist fn = do
 468   hsc_env <- getSession
 469   case ic_resume (hsc_IC hsc_env) of
 470      [] -> ghcError (ProgramError "not stopped at a breakpoint")
 471      (r:rs) -> do
 472         let ix = resumeHistoryIx r
 473             history = resumeHistory r
 474             new_ix = fn ix
 475         --
 476         when (new_ix > length history) $
 477            ghcError (ProgramError "no more logged breakpoints")
 478         when (new_ix < 0) $
 479            ghcError (ProgramError "already at the beginning of the history")
 480
 481         let
 482           update_ic apStack mb_info = do
 483             (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
 484                                                 apStack mb_info
 485             let ic = hsc_IC hsc_env1
 486                 r' = r { resumeHistoryIx = new_ix }
 487                 ic' = ic { ic_resume = r':rs }
 488
 489             modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
 490
 491             return (names, new_ix, span)
 492
 493         -- careful: we want apStack to be the AP_STACK itself, not a thunk
 494         -- around it, hence the cases are carefully constructed below to
 495         -- make this the case.  ToDo: this is v. fragile, do something better.
 496         if new_ix == 0
 497            then case r of
 498                    Resume { resumeApStack = apStack,
 499                             resumeBreakInfo = mb_info } ->
 500                           update_ic apStack mb_info
 501            else case history !! (new_ix - 1) of
 502                    History apStack info _ ->
 503                           update_ic apStack (Just info)
 504
 505 -- -----------------------------------------------------------------------------
 506 -- After stopping at a breakpoint, add free variables to the environment
 507 result_fs :: FastString
 508 result_fs = fsLit "_result"
 509
 510 bindLocalsAtBreakpoint
 511         :: HscEnv
 512         -> HValue
 513         -> Maybe BreakInfo
 514         -> IO (HscEnv, [Name], SrcSpan)
 515
 516 -- Nothing case: we stopped when an exception was raised, not at a
 517 -- breakpoint.  We have no location information or local variables to
 518 -- bind, all we can do is bind a local variable to the exception
 519 -- value.
 520 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 521    let exn_fs    = fsLit "_exception"
 522        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
 523        e_fs      = fsLit "e"
 524        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
 525        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
 526        exn_id    = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
 527        new_tyvars = unitVarSet e_tyvar
 528
 529        ictxt0 = hsc_IC hsc_env
 530        ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
 531
 532        span = mkGeneralSrcSpan (fsLit "<exception thrown>")
 533    --
 534    Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
 535    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 536
 537 -- Just case: we stopped at a breakpoint, we have information about the location
 538 -- of the breakpoint and the free variables of the expression.
 539 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 540
 541    let
 542        mod_name  = moduleName (breakInfo_module info)
 543        hmi       = expectJust "bindLocalsAtBreakpoint" $
 544                         lookupUFM (hsc_HPT hsc_env) mod_name
 545        breaks    = getModBreaks hmi
 546        index     = breakInfo_number info
 547        vars      = breakInfo_vars info
 548        result_ty = breakInfo_resty info
 549        occs      = modBreaks_vars breaks ! index
 550        span      = modBreaks_locs breaks ! index
 551
 552    -- filter out any unboxed ids; we can't bind these at the prompt
 553    let pointers = filter (\(id,_) -> isPointer id) vars
 554        isPointer id | PtrRep <- idPrimRep id = True
 555                     | otherwise              = False
 556
 557    let (ids, offsets) = unzip pointers
 558
 559    -- It might be that getIdValFromApStack fails, because the AP_STACK
 560    -- has been accidentally evaluated, or something else has gone wrong.
 561    -- So that we don't fall over in a heap when this happens, just don't
 562    -- bind any free variables instead, and we emit a warning.
 563    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
 564    let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
 565    when (any isNothing mb_hValues) $
 566       debugTraceMsg (hsc_dflags hsc_env) 1 $
 567           text "Warning: _result has been evaluated, some bindings have been lost"
 568
 569    new_ids <- zipWithM mkNewId occs filtered_ids
 570    let names = map idName new_ids
 571
 572    -- make an Id for _result.  We use the Unique of the FastString "_result";
 573    -- we don't care about uniqueness here, because there will only be one
 574    -- _result in scope at any time.
 575    let result_name = mkInternalName (getUnique result_fs)
 576                           (mkVarOccFS result_fs) span
 577        result_id   = Id.mkVanillaGlobal result_name result_ty
 578
 579    -- for each Id we're about to bind in the local envt:
 580    --    - skolemise the type variables in its type, so they can't
 581    --      be randomly unified with other types.  These type variables
 582    --      can only be resolved by type reconstruction in RtClosureInspect
 583    --    - tidy the type variables
 584    --    - globalise the Id (Ids are supposed to be Global, apparently).
 585    --
 586    let all_ids | isPointer result_id = result_id : new_ids
 587                | otherwise           = new_ids
 588        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 589        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 590        new_tyvars = unionVarSets tyvarss
 591    let final_ids = zipWith setIdType all_ids tidy_tys
 592        ictxt0 = hsc_IC hsc_env
 593        ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 594    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 595    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 596    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
 597    return (hsc_env1, result_name:names, span)
 598   where
 599    mkNewId :: OccName -> Id -> IO Id
 600    mkNewId occ id = do
 601      us <- mkSplitUniqSupply 'I'
 602         -- we need a fresh Unique for each Id we bind, because the linker
 603         -- state is single-threaded and otherwise we'd spam old bindings
 604         -- whenever we stop at a breakpoint.  The InteractveContext is properly
 605         -- saved/restored, but not the linker state.  See #1743, test break026.
 606      let
 607          uniq = uniqFromSupply us
 608          loc = nameSrcSpan (idName id)
 609          name = mkInternalName uniq occ loc
 610          ty = idType id
 611          new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
 612      return new_id
 613
 614 rttiEnvironment :: HscEnv -> IO HscEnv
 615 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
 616    let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 617        incompletelyTypedIds =
 618            [id | id <- tmp_ids
 619                , not $ noSkolems id
 620                , (occNameFS.nameOccName.idName) id /= result_fs]
 621    hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
 622    return hsc_env'
 623     where
 624      noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
 625      improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
 626       let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 627           Just id = find (\i -> idName i == name) tmp_ids
 628       if noSkolems id
 629          then return hsc_env
 630          else do
 631            mb_new_ty <- reconstructType hsc_env 10 id
 632            let old_ty = idType id
 633            case mb_new_ty of
 634              Nothing -> return hsc_env
 635              Just new_ty -> do
 636               mb_subst <- improveRTTIType hsc_env old_ty new_ty
 637               case mb_subst of
 638                Nothing -> return $
 639                         WARN(True, text (":print failed to calculate the "
 640                                            ++ "improvement for a type")) hsc_env
 641                Just subst -> do
 642                  when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
 643                       printForUser stderr alwaysQualify $
 644                       fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
 645
 646                  let (subst', skols) = skolemiseSubst subst
 647                      ic' = extendInteractiveContext
 648                                (substInteractiveContext ic subst') [] skols
 649                  return hsc_env{hsc_IC=ic'}
 650
 651 skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
 652 skolemiseSubst subst = let
 653     varenv               = getTvSubstEnv subst
 654     all_together         = mapVarEnv skolemiseTy varenv
 655     (varenv', skol_vars) = ( mapVarEnv fst all_together
 656                            , map snd (varEnvElts all_together))
 657     in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
 658
 659
 660 skolemiseTy :: Type -> (Type, TyVarSet)
 661 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 662   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 663         subst         = mkTvSubst emptyInScopeSet env
 664         tyvars        = varSetElems (tyVarsOfType ty)
 665         new_tyvars    = map skolemiseTyVar tyvars
 666         new_tyvar_tys = map mkTyVarTy new_tyvars
 667
 668 skolemiseTyVar :: TyVar -> TyVar
 669 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 670                                  (SkolemTv RuntimeUnkSkol)
 671
 672 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 673 getIdValFromApStack apStack (I# stackDepth) = do
 674    case getApStackVal# apStack (stackDepth +# 1#) of
 675                                 -- The +1 is magic!  I don't know where it comes
 676                                 -- from, but this makes things line up.  --SDM
 677         (# ok, result #) ->
 678             case ok of
 679               0# -> return Nothing -- AP_STACK not found
 680               _  -> return (Just (unsafeCoerce# result))
 681
 682 pushResume :: HscEnv -> Resume -> HscEnv
 683 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 684   where
 685         ictxt0 = hsc_IC hsc_env
 686         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 687
 688 -- -----------------------------------------------------------------------------
 689 -- Abandoning a resume context
 690
 691 abandon :: GhcMonad m => m Bool
 692 abandon = do
 693    hsc_env <- getSession
 694    let ic = hsc_IC hsc_env
 695        resume = ic_resume ic
 696    case resume of
 697       []    -> return False
 698       r:rs  -> do
 699          modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
 700          liftIO $ abandon_ r
 701          return True
 702
 703 abandonAll :: GhcMonad m => m Bool
 704 abandonAll = do
 705    hsc_env <- getSession
 706    let ic = hsc_IC hsc_env
 707        resume = ic_resume ic
 708    case resume of
 709       []  -> return False
 710       rs  -> do
 711          modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
 712          liftIO $ mapM_ abandon_ rs
 713          return True
 714
 715 -- when abandoning a computation we have to
 716 --      (a) kill the thread with an async exception, so that the
 717 --          computation itself is stopped, and
 718 --      (b) fill in the MVar.  This step is necessary because any
 719 --          thunks that were under evaluation will now be updated
 720 --          with the partial computation, which still ends in takeMVar,
 721 --          so any attempt to evaluate one of these thunks will block
 722 --          unless we fill in the MVar.
 723 --  See test break010.
 724 abandon_ :: Resume -> IO ()
 725 abandon_ r = do
 726   killThread (resumeThreadId r)
 727   putMVar (resumeBreakMVar r) ()
 728
 729 -- -----------------------------------------------------------------------------
 730 -- Bounded list, optimised for repeated cons
 731
 732 data BoundedList a = BL
 733                         {-# UNPACK #-} !Int  -- length
 734                         {-# UNPACK #-} !Int  -- bound
 735                         [a] -- left
 736                         [a] -- right,  list is (left ++ reverse right)
 737
 738 nilBL :: Int -> BoundedList a
 739 nilBL bound = BL 0 bound [] []
 740
 741 consBL :: a -> BoundedList a -> BoundedList a
 742 consBL a (BL len bound left right)
 743   | len < bound = BL (len+1) bound (a:left) right
 744   | null right  = BL len     bound [a]      $! tail (reverse left)
 745   | otherwise   = BL len     bound (a:left) $! tail right
 746
 747 toListBL :: BoundedList a -> [a]
 748 toListBL (BL _ _ left right) = left ++ reverse right
 749
 750 fromListBL :: Int -> [a] -> BoundedList a
 751 fromListBL bound l = BL (length l) bound l []
 752
 753 -- lenBL (BL len _ _ _) = len
 754
 755 -- -----------------------------------------------------------------------------
 756 -- | Set the interactive evaluation context.
 757 --
 758 -- Setting the context doesn't throw away any bindings; the bindings
 759 -- we've built up in the InteractiveContext simply move to the new
 760 -- module.  They always shadow anything in scope in the current context.
 761 setContext :: GhcMonad m =>
 762               [Module]  -- ^ entire top level scope of these modules
 763            -> [Module]  -- ^ exports only of these modules
 764            -> m ()
 765 setContext toplev_mods export_mods = do
 766   hsc_env <- getSession
 767   let old_ic  = hsc_IC     hsc_env
 768       hpt     = hsc_HPT    hsc_env
 769   --
 770   export_env  <- liftIO $ mkExportEnv hsc_env export_mods
 771   toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
 772   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 773   modifySession $ \_ ->
 774       hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 775                                  ic_exports      = export_mods,
 776                                  ic_rn_gbl_env   = all_env }}
 777
 778 -- Make a GlobalRdrEnv based on the exports of the modules only.
 779 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 780 mkExportEnv hsc_env mods = do
 781   stuff <- mapM (getModuleExports hsc_env) mods
 782   let
 783         (_msgs, mb_name_sets) = unzip stuff
 784         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 785                | (Just avails, mod) <- zip mb_name_sets mods ]
 786   --
 787   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 788
 789 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 790 nameSetToGlobalRdrEnv names mod =
 791   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 792                  | name <- nameSetToList names ]
 793
 794 vanillaProv :: ModuleName -> Provenance
 795 -- We're building a GlobalRdrEnv as if the user imported
 796 -- all the specified modules into the global interactive module
 797 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 798   where
 799     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 800                          is_qual = False,
 801                          is_dloc = srcLocSpan interactiveSrcLoc }
 802
 803 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 804 mkTopLevEnv hpt modl
 805   = case lookupUFM hpt (moduleName modl) of
 806       Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
 807                                                 showSDoc (ppr modl)))
 808       Just details ->
 809          case mi_globals (hm_iface details) of
 810                 Nothing  ->
 811                    ghcError (ProgramError ("mkTopLevEnv: not interpreted "
 812                                                 ++ showSDoc (ppr modl)))
 813                 Just env -> return env
 814
 815 -- | Get the interactive evaluation context, consisting of a pair of the
 816 -- set of modules from which we take the full top-level scope, and the set
 817 -- of modules from which we take just the exports respectively.
 818 getContext :: GhcMonad m => m ([Module],[Module])
 819 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
 820                return (ic_toplev_scope ic, ic_exports ic)
 821
 822 -- | Returns @True@ if the specified module is interpreted, and hence has
 823 -- its full top-level scope available.
 824 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
 825 moduleIsInterpreted modl = withSession $ \h ->
 826  if modulePackageId modl /= thisPackage (hsc_dflags h)
 827         then return False
 828         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 829                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 830                 _not_a_home_module -> return False
 831
 832 -- | Looks up an identifier in the current interactive context (for :info)
 833 -- Filter the instances by the ones whose tycons (or clases resp)
 834 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 835 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 836 --      (see Trac #1581)
 837 getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
 838 getInfo name
 839   = withSession $ \hsc_env ->
 840     do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
 841        case mb_stuff of
 842          Nothing -> return Nothing
 843          Just (thing, fixity, ispecs) -> do
 844            let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
 845            return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
 846   where
 847     plausible rdr_env ispec     -- Dfun involving only names that are in ic_rn_glb_env
 848         = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
 849         where   -- A name is ok if it's in the rdr_env,
 850                 -- whether qualified or not
 851           ok n | n == name         = True       -- The one we looked for in the first place!
 852                | isBuiltInSyntax n = True
 853                | isExternalName n  = any ((== n) . gre_name)
 854                                          (lookupGRE_Name rdr_env n)
 855                | otherwise         = True
 856
 857 -- | Returns all names in scope in the current interactive context
 858 getNamesInScope :: GhcMonad m => m [Name]
 859 getNamesInScope = withSession $ \hsc_env -> do
 860   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 861
 862 getRdrNamesInScope :: GhcMonad m => m [RdrName]
 863 getRdrNamesInScope = withSession $ \hsc_env -> do
 864   let
 865       ic = hsc_IC hsc_env
 866       gbl_rdrenv = ic_rn_gbl_env ic
 867       ids = ic_tmp_ids ic
 868       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 869       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 870   --
 871   return (gbl_names ++ lcl_names)
 872
 873
 874 -- ToDo: move to RdrName
 875 greToRdrNames :: GlobalRdrElt -> [RdrName]
 876 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 877   = case prov of
 878      LocalDef -> [unqual]
 879      Imported specs -> concat (map do_spec (map is_decl specs))
 880   where
 881     occ = nameOccName name
 882     unqual = Unqual occ
 883     do_spec decl_spec
 884         | is_qual decl_spec = [qual]
 885         | otherwise         = [unqual,qual]
 886         where qual = Qual (is_as decl_spec) occ
 887
 888 -- | Parses a string as an identifier, and returns the list of 'Name's that
 889 -- the identifier can refer to in the current interactive context.
 890 parseName :: GhcMonad m => String -> m [Name]
 891 parseName str = withSession $ \hsc_env -> do
 892    (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
 893    ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
 894
 895 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 896 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 897 lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
 898 lookupName name = withSession $ \hsc_env -> do
 899   mb_tything <- ioMsg $ tcRnLookupName hsc_env name
 900   return mb_tything
 901   -- XXX: calls panic in some circumstances;  is that ok?
 902
 903 -- -----------------------------------------------------------------------------
 904 -- Getting the type of an expression
 905
 906 -- | Get the type of an expression
 907 exprType :: GhcMonad m => String -> m Type
 908 exprType expr = withSession $ \hsc_env -> do
 909    ty <- hscTcExpr hsc_env expr
 910    return $ tidyType emptyTidyEnv ty
 911
 912 -- -----------------------------------------------------------------------------
 913 -- Getting the kind of a type
 914
 915 -- | Get the kind of a  type
 916 typeKind  :: GhcMonad m => String -> m Kind
 917 typeKind str = withSession $ \hsc_env -> do
 918    hscKcType hsc_env str
 919
 920 -----------------------------------------------------------------------------
 921 -- cmCompileExpr: compile an expression and deliver an HValue
 922
 923 compileExpr :: GhcMonad m => String -> m HValue
 924 compileExpr expr = withSession $ \hsc_env -> do
 925   Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 926                  -- Run it!
 927   hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
 928
 929   case (ids,hvals) of
 930     ([_],[hv]) -> return hv
 931     _        -> panic "compileExpr"
 932
 933 -- -----------------------------------------------------------------------------
 934 -- Compile an expression into a dynamic
 935
 936 dynCompileExpr :: GhcMonad m => String -> m Dynamic
 937 dynCompileExpr expr = do
 938     (full,exports) <- getContext
 939     setContext full $
 940         (mkModule
 941             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 942         ):exports
 943     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 944     Just (ids, hvals) <- withSession (flip hscStmt stmt)
 945     setContext full exports
 946     vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
 947     case (ids,vals) of
 948         (_:[], v:[])    -> return v
 949         _               -> panic "dynCompileExpr"
 950
 951 -----------------------------------------------------------------------------
 952 -- show a module and it's source/object filenames
 953
 954 showModule :: GhcMonad m => ModSummary -> m String
 955 showModule mod_summary =
 956     withSession $ \hsc_env -> do
 957         interpreted <- isModuleInterpreted mod_summary
 958         return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 959
 960 isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
 961 isModuleInterpreted mod_summary = withSession $ \hsc_env ->
 962   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 963         Nothing       -> panic "missing linkable"
 964         Just mod_info -> return (not obj_linkable)
 965                       where
 966                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 967
 968 ----------------------------------------------------------------------------
 969 -- RTTI primitives
 970
 971 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
 972 obtainTermFromVal hsc_env bound force ty x =
 973               cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
 974
 975 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
 976 obtainTermFromId hsc_env bound force id =  do
 977               hv <- Linker.getHValue hsc_env (varName id)
 978               cvObtainTerm hsc_env bound force (idType id) hv
 979
 980 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 981 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 982 reconstructType hsc_env bound id = do
 983               hv <- Linker.getHValue hsc_env (varName id)
 984               cvReconstructType hsc_env bound (idType id) hv
 985
 986 #endif /* GHCI */
 987