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