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