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.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
 527                                 vanillaIdInfo
 528        new_tyvars = unitVarSet e_tyvar
 529
 530        ictxt0 = hsc_IC hsc_env
 531        ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
 532
 533        span = mkGeneralSrcSpan (fsLit "<exception thrown>")
 534    --
 535    Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
 536    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 537
 538 -- Just case: we stopped at a breakpoint, we have information about the location
 539 -- of the breakpoint and the free variables of the expression.
 540 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 541
 542    let
 543        mod_name  = moduleName (breakInfo_module info)
 544        hmi       = expectJust "bindLocalsAtBreakpoint" $
 545                         lookupUFM (hsc_HPT hsc_env) mod_name
 546        breaks    = getModBreaks hmi
 547        index     = breakInfo_number info
 548        vars      = breakInfo_vars info
 549        result_ty = breakInfo_resty info
 550        occs      = modBreaks_vars breaks ! index
 551        span      = modBreaks_locs breaks ! index
 552
 553    -- filter out any unboxed ids; we can't bind these at the prompt
 554    let pointers = filter (\(id,_) -> isPointer id) vars
 555        isPointer id | PtrRep <- idPrimRep id = True
 556                     | otherwise              = False
 557
 558    let (ids, offsets) = unzip pointers
 559
 560    -- It might be that getIdValFromApStack fails, because the AP_STACK
 561    -- has been accidentally evaluated, or something else has gone wrong.
 562    -- So that we don't fall over in a heap when this happens, just don't
 563    -- bind any free variables instead, and we emit a warning.
 564    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
 565    let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
 566    when (any isNothing mb_hValues) $
 567       debugTraceMsg (hsc_dflags hsc_env) 1 $
 568           text "Warning: _result has been evaluated, some bindings have been lost"
 569
 570    new_ids <- zipWithM mkNewId occs filtered_ids
 571    let names = map idName new_ids
 572
 573    -- make an Id for _result.  We use the Unique of the FastString "_result";
 574    -- we don't care about uniqueness here, because there will only be one
 575    -- _result in scope at any time.
 576    let result_name = mkInternalName (getUnique result_fs)
 577                           (mkVarOccFS result_fs) span
 578        result_id   = Id.mkGlobalId VanillaGlobal result_name result_ty
 579                                    vanillaIdInfo
 580
 581    -- for each Id we're about to bind in the local envt:
 582    --    - skolemise the type variables in its type, so they can't
 583    --      be randomly unified with other types.  These type variables
 584    --      can only be resolved by type reconstruction in RtClosureInspect
 585    --    - tidy the type variables
 586    --    - globalise the Id (Ids are supposed to be Global, apparently).
 587    --
 588    let all_ids | isPointer result_id = result_id : new_ids
 589                | otherwise           = new_ids
 590        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 591        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 592        new_tyvars = unionVarSets tyvarss
 593    let final_ids = zipWith setIdType all_ids tidy_tys
 594        ictxt0 = hsc_IC hsc_env
 595        ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 596    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 597    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 598    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
 599    return (hsc_env1, result_name:names, span)
 600   where
 601    mkNewId :: OccName -> Id -> IO Id
 602    mkNewId occ id = do
 603      us <- mkSplitUniqSupply 'I'
 604         -- we need a fresh Unique for each Id we bind, because the linker
 605         -- state is single-threaded and otherwise we'd spam old bindings
 606         -- whenever we stop at a breakpoint.  The InteractveContext is properly
 607         -- saved/restored, but not the linker state.  See #1743, test break026.
 608      let
 609          uniq = uniqFromSupply us
 610          loc = nameSrcSpan (idName id)
 611          name = mkInternalName uniq occ loc
 612          ty = idType id
 613          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
 614      return new_id
 615
 616 rttiEnvironment :: HscEnv -> IO HscEnv
 617 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
 618    let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 619        incompletelyTypedIds =
 620            [id | id <- tmp_ids
 621                , not $ noSkolems id
 622                , (occNameFS.nameOccName.idName) id /= result_fs]
 623    hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
 624    return hsc_env'
 625     where
 626      noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
 627      improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
 628       let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 629           Just id = find (\i -> idName i == name) tmp_ids
 630       if noSkolems id
 631          then return hsc_env
 632          else do
 633            mb_new_ty <- reconstructType hsc_env 10 id
 634            let old_ty = idType id
 635            case mb_new_ty of
 636              Nothing -> return hsc_env
 637              Just new_ty -> do
 638               mb_subst <- improveRTTIType hsc_env old_ty new_ty
 639               case mb_subst of
 640                Nothing -> return $
 641                         WARN(True, text (":print failed to calculate the "
 642                                            ++ "improvement for a type")) hsc_env
 643                Just subst -> do
 644                  when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
 645                       printForUser stderr alwaysQualify $
 646                       fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
 647
 648                  let (subst', skols) = skolemiseSubst subst
 649                      ic' = extendInteractiveContext
 650                                (substInteractiveContext ic subst') [] skols
 651                  return hsc_env{hsc_IC=ic'}
 652
 653 skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
 654 skolemiseSubst subst = let
 655     varenv               = getTvSubstEnv subst
 656     all_together         = mapVarEnv skolemiseTy varenv
 657     (varenv', skol_vars) = ( mapVarEnv fst all_together
 658                            , map snd (varEnvElts all_together))
 659     in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
 660
 661
 662 skolemiseTy :: Type -> (Type, TyVarSet)
 663 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 664   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 665         subst         = mkTvSubst emptyInScopeSet env
 666         tyvars        = varSetElems (tyVarsOfType ty)
 667         new_tyvars    = map skolemiseTyVar tyvars
 668         new_tyvar_tys = map mkTyVarTy new_tyvars
 669
 670 skolemiseTyVar :: TyVar -> TyVar
 671 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 672                                  (SkolemTv RuntimeUnkSkol)
 673
 674 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 675 getIdValFromApStack apStack (I# stackDepth) = do
 676    case getApStackVal# apStack (stackDepth +# 1#) of
 677                                 -- The +1 is magic!  I don't know where it comes
 678                                 -- from, but this makes things line up.  --SDM
 679         (# ok, result #) ->
 680             case ok of
 681               0# -> return Nothing -- AP_STACK not found
 682               _  -> return (Just (unsafeCoerce# result))
 683
 684 pushResume :: HscEnv -> Resume -> HscEnv
 685 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 686   where
 687         ictxt0 = hsc_IC hsc_env
 688         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 689
 690 -- -----------------------------------------------------------------------------
 691 -- Abandoning a resume context
 692
 693 abandon :: GhcMonad m => m Bool
 694 abandon = do
 695    hsc_env <- getSession
 696    let ic = hsc_IC hsc_env
 697        resume = ic_resume ic
 698    case resume of
 699       []    -> return False
 700       r:rs  -> do
 701          modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
 702          liftIO $ abandon_ r
 703          return True
 704
 705 abandonAll :: GhcMonad m => m Bool
 706 abandonAll = do
 707    hsc_env <- getSession
 708    let ic = hsc_IC hsc_env
 709        resume = ic_resume ic
 710    case resume of
 711       []  -> return False
 712       rs  -> do
 713          modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
 714          liftIO $ mapM_ abandon_ rs
 715          return True
 716
 717 -- when abandoning a computation we have to
 718 --      (a) kill the thread with an async exception, so that the
 719 --          computation itself is stopped, and
 720 --      (b) fill in the MVar.  This step is necessary because any
 721 --          thunks that were under evaluation will now be updated
 722 --          with the partial computation, which still ends in takeMVar,
 723 --          so any attempt to evaluate one of these thunks will block
 724 --          unless we fill in the MVar.
 725 --  See test break010.
 726 abandon_ :: Resume -> IO ()
 727 abandon_ r = do
 728   killThread (resumeThreadId r)
 729   putMVar (resumeBreakMVar r) ()
 730
 731 -- -----------------------------------------------------------------------------
 732 -- Bounded list, optimised for repeated cons
 733
 734 data BoundedList a = BL
 735                         {-# UNPACK #-} !Int  -- length
 736                         {-# UNPACK #-} !Int  -- bound
 737                         [a] -- left
 738                         [a] -- right,  list is (left ++ reverse right)
 739
 740 nilBL :: Int -> BoundedList a
 741 nilBL bound = BL 0 bound [] []
 742
 743 consBL :: a -> BoundedList a -> BoundedList a
 744 consBL a (BL len bound left right)
 745   | len < bound = BL (len+1) bound (a:left) right
 746   | null right  = BL len     bound [a]      $! tail (reverse left)
 747   | otherwise   = BL len     bound (a:left) $! tail right
 748
 749 toListBL :: BoundedList a -> [a]
 750 toListBL (BL _ _ left right) = left ++ reverse right
 751
 752 fromListBL :: Int -> [a] -> BoundedList a
 753 fromListBL bound l = BL (length l) bound l []
 754
 755 -- lenBL (BL len _ _ _) = len
 756
 757 -- -----------------------------------------------------------------------------
 758 -- | Set the interactive evaluation context.
 759 --
 760 -- Setting the context doesn't throw away any bindings; the bindings
 761 -- we've built up in the InteractiveContext simply move to the new
 762 -- module.  They always shadow anything in scope in the current context.
 763 setContext :: GhcMonad m =>
 764               [Module]  -- ^ entire top level scope of these modules
 765            -> [Module]  -- ^ exports only of these modules
 766            -> m ()
 767 setContext toplev_mods export_mods = do
 768   hsc_env <- getSession
 769   let old_ic  = hsc_IC     hsc_env
 770       hpt     = hsc_HPT    hsc_env
 771   --
 772   export_env  <- liftIO $ mkExportEnv hsc_env export_mods
 773   toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
 774   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 775   modifySession $ \_ ->
 776       hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 777                                  ic_exports      = export_mods,
 778                                  ic_rn_gbl_env   = all_env }}
 779
 780 -- Make a GlobalRdrEnv based on the exports of the modules only.
 781 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 782 mkExportEnv hsc_env mods = do
 783   stuff <- mapM (getModuleExports hsc_env) mods
 784   let
 785         (_msgs, mb_name_sets) = unzip stuff
 786         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 787                | (Just avails, mod) <- zip mb_name_sets mods ]
 788   --
 789   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 790
 791 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 792 nameSetToGlobalRdrEnv names mod =
 793   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 794                  | name <- nameSetToList names ]
 795
 796 vanillaProv :: ModuleName -> Provenance
 797 -- We're building a GlobalRdrEnv as if the user imported
 798 -- all the specified modules into the global interactive module
 799 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 800   where
 801     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 802                          is_qual = False,
 803                          is_dloc = srcLocSpan interactiveSrcLoc }
 804
 805 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 806 mkTopLevEnv hpt modl
 807   = case lookupUFM hpt (moduleName modl) of
 808       Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
 809                                                 showSDoc (ppr modl)))
 810       Just details ->
 811          case mi_globals (hm_iface details) of
 812                 Nothing  ->
 813                    ghcError (ProgramError ("mkTopLevEnv: not interpreted "
 814                                                 ++ showSDoc (ppr modl)))
 815                 Just env -> return env
 816
 817 -- | Get the interactive evaluation context, consisting of a pair of the
 818 -- set of modules from which we take the full top-level scope, and the set
 819 -- of modules from which we take just the exports respectively.
 820 getContext :: GhcMonad m => m ([Module],[Module])
 821 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
 822                return (ic_toplev_scope ic, ic_exports ic)
 823
 824 -- | Returns @True@ if the specified module is interpreted, and hence has
 825 -- its full top-level scope available.
 826 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
 827 moduleIsInterpreted modl = withSession $ \h ->
 828  if modulePackageId modl /= thisPackage (hsc_dflags h)
 829         then return False
 830         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 831                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 832                 _not_a_home_module -> return False
 833
 834 -- | Looks up an identifier in the current interactive context (for :info)
 835 -- Filter the instances by the ones whose tycons (or clases resp)
 836 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 837 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 838 --      (see Trac #1581)
 839 getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
 840 getInfo name
 841   = withSession $ \hsc_env ->
 842     do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
 843        case mb_stuff of
 844          Nothing -> return Nothing
 845          Just (thing, fixity, ispecs) -> do
 846            let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
 847            return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
 848   where
 849     plausible rdr_env ispec     -- Dfun involving only names that are in ic_rn_glb_env
 850         = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
 851         where   -- A name is ok if it's in the rdr_env,
 852                 -- whether qualified or not
 853           ok n | n == name         = True       -- The one we looked for in the first place!
 854                | isBuiltInSyntax n = True
 855                | isExternalName n  = any ((== n) . gre_name)
 856                                          (lookupGRE_Name rdr_env n)
 857                | otherwise         = True
 858
 859 -- | Returns all names in scope in the current interactive context
 860 getNamesInScope :: GhcMonad m => m [Name]
 861 getNamesInScope = withSession $ \hsc_env -> do
 862   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 863
 864 getRdrNamesInScope :: GhcMonad m => m [RdrName]
 865 getRdrNamesInScope = withSession $ \hsc_env -> do
 866   let
 867       ic = hsc_IC hsc_env
 868       gbl_rdrenv = ic_rn_gbl_env ic
 869       ids = ic_tmp_ids ic
 870       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 871       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 872   --
 873   return (gbl_names ++ lcl_names)
 874
 875
 876 -- ToDo: move to RdrName
 877 greToRdrNames :: GlobalRdrElt -> [RdrName]
 878 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 879   = case prov of
 880      LocalDef -> [unqual]
 881      Imported specs -> concat (map do_spec (map is_decl specs))
 882   where
 883     occ = nameOccName name
 884     unqual = Unqual occ
 885     do_spec decl_spec
 886         | is_qual decl_spec = [qual]
 887         | otherwise         = [unqual,qual]
 888         where qual = Qual (is_as decl_spec) occ
 889
 890 -- | Parses a string as an identifier, and returns the list of 'Name's that
 891 -- the identifier can refer to in the current interactive context.
 892 parseName :: GhcMonad m => String -> m [Name]
 893 parseName str = withSession $ \hsc_env -> do
 894    (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
 895    ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
 896
 897 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 898 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 899 lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
 900 lookupName name = withSession $ \hsc_env -> do
 901   mb_tything <- ioMsg $ tcRnLookupName hsc_env name
 902   return mb_tything
 903   -- XXX: calls panic in some circumstances;  is that ok?
 904
 905 -- -----------------------------------------------------------------------------
 906 -- Getting the type of an expression
 907
 908 -- | Get the type of an expression
 909 exprType :: GhcMonad m => String -> m Type
 910 exprType expr = withSession $ \hsc_env -> do
 911    ty <- hscTcExpr hsc_env expr
 912    return $ tidyType emptyTidyEnv ty
 913
 914 -- -----------------------------------------------------------------------------
 915 -- Getting the kind of a type
 916
 917 -- | Get the kind of a  type
 918 typeKind  :: GhcMonad m => String -> m Kind
 919 typeKind str = withSession $ \hsc_env -> do
 920    hscKcType hsc_env str
 921
 922 -----------------------------------------------------------------------------
 923 -- cmCompileExpr: compile an expression and deliver an HValue
 924
 925 compileExpr :: GhcMonad m => String -> m HValue
 926 compileExpr expr = withSession $ \hsc_env -> do
 927   Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 928                  -- Run it!
 929   hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
 930
 931   case (ids,hvals) of
 932     ([_],[hv]) -> return hv
 933     _        -> panic "compileExpr"
 934
 935 -- -----------------------------------------------------------------------------
 936 -- Compile an expression into a dynamic
 937
 938 dynCompileExpr :: GhcMonad m => String -> m Dynamic
 939 dynCompileExpr expr = do
 940     (full,exports) <- getContext
 941     setContext full $
 942         (mkModule
 943             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 944         ):exports
 945     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 946     Just (ids, hvals) <- withSession (flip hscStmt stmt)
 947     setContext full exports
 948     vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
 949     case (ids,vals) of
 950         (_:[], v:[])    -> return v
 951         _               -> panic "dynCompileExpr"
 952
 953 -----------------------------------------------------------------------------
 954 -- show a module and it's source/object filenames
 955
 956 showModule :: GhcMonad m => ModSummary -> m String
 957 showModule mod_summary =
 958     withSession $ \hsc_env -> do
 959         interpreted <- isModuleInterpreted mod_summary
 960         return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 961
 962 isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
 963 isModuleInterpreted mod_summary = withSession $ \hsc_env ->
 964   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 965         Nothing       -> panic "missing linkable"
 966         Just mod_info -> return (not obj_linkable)
 967                       where
 968                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 969
 970 ----------------------------------------------------------------------------
 971 -- RTTI primitives
 972
 973 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
 974 obtainTermFromVal hsc_env bound force ty x =
 975               cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
 976
 977 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
 978 obtainTermFromId hsc_env bound force id =  do
 979               hv <- Linker.getHValue hsc_env (varName id)
 980               cvObtainTerm hsc_env bound force (idType id) hv
 981
 982 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 983 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 984 reconstructType hsc_env bound id = do
 985               hv <- Linker.getHValue hsc_env (varName id)
 986               cvReconstructType hsc_env bound (idType id) hv
 987
 988 #endif /* GHCI */
 989