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