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 thing
 272                     putMVar statusMVar (Complete res)))
 273         (takeMVar statusMVar)
 274
 275 withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
 276 withInterruptsSentTo io get_result = do
 277   ts <- takeMVar interruptTargetThread
 278   child <- io
 279   putMVar interruptTargetThread (child:ts)
 280   get_result `finally` modifyMVar_ interruptTargetThread (return.tail)
 281
 282 -- This function sets up the interpreter for catching breakpoints, and
 283 -- resets everything when the computation has stopped running.  This
 284 -- is a not-very-good way to ensure that only the interactive
 285 -- evaluation should generate breakpoints.
 286 withBreakAction step dflags breakMVar statusMVar io
 287  = bracket setBreakAction resetBreakAction (\_ -> io)
 288  where
 289    setBreakAction = do
 290      stablePtr <- newStablePtr onBreak
 291      poke breakPointIOAction stablePtr
 292      when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
 293      when step $ setStepFlag
 294      return stablePtr
 295         -- Breaking on exceptions is not enabled by default, since it
 296         -- might be a bit surprising.  The exception flag is turned off
 297         -- as soon as it is hit, or in resetBreakAction below.
 298
 299    onBreak is_exception info apStack = do
 300      tid <- myThreadId
 301      putMVar statusMVar (Break is_exception apStack info tid)
 302      takeMVar breakMVar
 303
 304    resetBreakAction stablePtr = do
 305      poke breakPointIOAction noBreakStablePtr
 306      poke exceptionFlag 0
 307      resetStepFlag
 308      freeStablePtr stablePtr
 309
 310 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 311
 312 noBreakAction False info apStack = putStrLn "*** Ignoring breakpoint"
 313 noBreakAction True  info apStack = return () -- exception: just continue
 314
 315 resume :: Session -> SingleStep -> IO RunResult
 316 resume (Session ref) step
 317  = do
 318    hsc_env <- readIORef ref
 319    let ic = hsc_IC hsc_env
 320        resume = ic_resume ic
 321
 322    case resume of
 323      [] -> throwDyn (ProgramError "not stopped at a breakpoint")
 324      (r:rs) -> do
 325         -- unbind the temporary locals by restoring the TypeEnv from
 326         -- before the breakpoint, and drop this Resume from the
 327         -- InteractiveContext.
 328         let (resume_tmp_ids, resume_tyvars) = resumeBindings r
 329             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
 330                        ic_tyvars   = resume_tyvars,
 331                        ic_resume   = rs }
 332         writeIORef ref hsc_env{ hsc_IC = ic' }
 333
 334         -- remove any bindings created since the breakpoint from the
 335         -- linker's environment
 336         let new_names = map idName (filter (`notElem` resume_tmp_ids)
 337                                            (ic_tmp_ids ic))
 338         Linker.deleteFromLinkEnv new_names
 339
 340         when (isStep step) $ setStepFlag
 341         case r of
 342           Resume expr tid breakMVar statusMVar bindings
 343               final_ids apStack info _ _ _ -> do
 344                 withBreakAction (isStep step) (hsc_dflags hsc_env)
 345                                         breakMVar statusMVar $ do
 346                 status <- withInterruptsSentTo
 347                              (do putMVar breakMVar ()
 348                                       -- this awakens the stopped thread...
 349                                  return tid)
 350                              (takeMVar statusMVar)
 351                                       -- and wait for the result
 352                 case step of
 353                   RunAndLogSteps ->
 354                         traceRunStatus expr ref bindings final_ids
 355                                        breakMVar statusMVar status emptyHistory
 356                   _other ->
 357                         handleRunStatus expr ref bindings final_ids
 358                                         breakMVar statusMVar status emptyHistory
 359
 360
 361 back :: Session -> IO ([Name], Int, SrcSpan)
 362 back  = moveHist (+1)
 363
 364 forward :: Session -> IO ([Name], Int, SrcSpan)
 365 forward  = moveHist (subtract 1)
 366
 367 moveHist fn (Session ref) = do
 368   hsc_env <- readIORef ref
 369   case ic_resume (hsc_IC hsc_env) of
 370      [] -> throwDyn (ProgramError "not stopped at a breakpoint")
 371      (r:rs) -> do
 372         let ix = resumeHistoryIx r
 373             history = resumeHistory r
 374             new_ix = fn ix
 375         --
 376         when (new_ix > length history) $
 377            throwDyn (ProgramError "no more logged breakpoints")
 378         when (new_ix < 0) $
 379            throwDyn (ProgramError "already at the beginning of the history")
 380
 381         let
 382           update_ic apStack mb_info = do
 383             (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
 384                                                 apStack mb_info
 385             let ic = hsc_IC hsc_env1
 386                 r' = r { resumeHistoryIx = new_ix }
 387                 ic' = ic { ic_resume = r':rs }
 388
 389             writeIORef ref hsc_env1{ hsc_IC = ic' }
 390
 391             return (names, new_ix, span)
 392
 393         -- careful: we want apStack to be the AP_STACK itself, not a thunk
 394         -- around it, hence the cases are carefully constructed below to
 395         -- make this the case.  ToDo: this is v. fragile, do something better.
 396         if new_ix == 0
 397            then case r of
 398                    Resume { resumeApStack = apStack,
 399                             resumeBreakInfo = mb_info } ->
 400                           update_ic apStack mb_info
 401            else case history !! (new_ix - 1) of
 402                    History apStack info ->
 403                           update_ic apStack (Just info)
 404
 405 -- -----------------------------------------------------------------------------
 406 -- After stopping at a breakpoint, add free variables to the environment
 407
 408 bindLocalsAtBreakpoint
 409         :: HscEnv
 410         -> HValue
 411         -> Maybe BreakInfo
 412         -> IO (HscEnv, [Name], SrcSpan)
 413
 414 -- Nothing case: we stopped when an exception was raised, not at a
 415 -- breakpoint.  We have no location information or local variables to
 416 -- bind, all we can do is bind a local variable to the exception
 417 -- value.
 418 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 419    let exn_fs    = FSLIT("_exception")
 420        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
 421        e_fs      = FSLIT("e")
 422        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
 423        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
 424        exn_id    = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
 425                                 vanillaIdInfo
 426        new_tyvars = unitVarSet e_tyvar
 427
 428        ictxt0 = hsc_IC hsc_env
 429        ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
 430
 431        span = mkGeneralSrcSpan FSLIT("<exception thrown>")
 432    --
 433    Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
 434    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 435
 436 -- Just case: we stopped at a breakpoint, we have information about the location
 437 -- of the breakpoint and the free variables of the expression.
 438 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 439
 440    let
 441        mod_name    = moduleName (breakInfo_module info)
 442        mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
 443        breaks      = md_modBreaks (expectJust "handlRunStatus" mod_details)
 444        index     = breakInfo_number info
 445        vars      = breakInfo_vars info
 446        result_ty = breakInfo_resty info
 447        occs      = modBreaks_vars breaks ! index
 448        span      = modBreaks_locs breaks ! index
 449
 450    -- filter out any unboxed ids; we can't bind these at the prompt
 451    let pointers = filter (\(id,_) -> isPointer id) vars
 452        isPointer id | PtrRep <- idPrimRep id = True
 453                     | otherwise              = False
 454
 455    let (ids, offsets) = unzip pointers
 456
 457    -- It might be that getIdValFromApStack fails, because the AP_STACK
 458    -- has been accidentally evaluated, or something else has gone wrong.
 459    -- So that we don't fall over in a heap when this happens, just don't
 460    -- bind any free variables instead, and we emit a warning.
 461    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
 462    let filtered_ids = [ id | (id, Just _) <- zip ids mb_hValues ]
 463    when (any isNothing mb_hValues) $
 464       debugTraceMsg (hsc_dflags hsc_env) 1 $
 465           text "Warning: _result has been evaluated, some bindings have been lost"
 466
 467    new_ids <- zipWithM mkNewId occs filtered_ids
 468    let names = map idName new_ids
 469
 470    -- make an Id for _result.  We use the Unique of the FastString "_result";
 471    -- we don't care about uniqueness here, because there will only be one
 472    -- _result in scope at any time.
 473    let result_fs = FSLIT("_result")
 474        result_name = mkInternalName (getUnique result_fs)
 475                           (mkVarOccFS result_fs) span
 476        result_id   = Id.mkGlobalId VanillaGlobal result_name result_ty
 477                                    vanillaIdInfo
 478
 479    -- for each Id we're about to bind in the local envt:
 480    --    - skolemise the type variables in its type, so they can't
 481    --      be randomly unified with other types.  These type variables
 482    --      can only be resolved by type reconstruction in RtClosureInspect
 483    --    - tidy the type variables
 484    --    - globalise the Id (Ids are supposed to be Global, apparently).
 485    --
 486    let all_ids | isPointer result_id = result_id : new_ids
 487                | otherwise           = new_ids
 488        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 489        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 490        new_tyvars = unionVarSets tyvarss
 491        final_ids = zipWith setIdType all_ids tidy_tys
 492
 493    let   ictxt0 = hsc_IC hsc_env
 494          ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 495
 496    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 497    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 498    return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span)
 499   where
 500    mkNewId :: OccName -> Id -> IO Id
 501    mkNewId occ id = do
 502      let uniq = idUnique id
 503          loc = nameSrcSpan (idName id)
 504          name = mkInternalName uniq occ loc
 505          ty = idType id
 506          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
 507      return new_id
 508
 509 skolemiseTy :: Type -> (Type, TyVarSet)
 510 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 511   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 512         subst         = mkTvSubst emptyInScopeSet env
 513         tyvars        = varSetElems (tyVarsOfType ty)
 514         new_tyvars    = map skolemiseTyVar tyvars
 515         new_tyvar_tys = map mkTyVarTy new_tyvars
 516
 517 skolemiseTyVar :: TyVar -> TyVar
 518 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 519                                  (SkolemTv RuntimeUnkSkol)
 520
 521 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 522 getIdValFromApStack apStack (I# stackDepth) = do
 523    case getApStackVal# apStack (stackDepth +# 1#) of
 524                                 -- The +1 is magic!  I don't know where it comes
 525                                 -- from, but this makes things line up.  --SDM
 526         (# ok, result #) ->
 527             case ok of
 528               0# -> return Nothing -- AP_STACK not found
 529               _  -> return (Just (unsafeCoerce# result))
 530
 531 pushResume :: HscEnv -> Resume -> HscEnv
 532 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 533   where
 534         ictxt0 = hsc_IC hsc_env
 535         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 536
 537 -- -----------------------------------------------------------------------------
 538 -- Abandoning a resume context
 539
 540 abandon :: Session -> IO Bool
 541 abandon (Session ref) = do
 542    hsc_env <- readIORef ref
 543    let ic = hsc_IC hsc_env
 544        resume = ic_resume ic
 545    case resume of
 546       []    -> return False
 547       r:rs  -> do
 548          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
 549          abandon_ r
 550          return True
 551
 552 abandonAll :: Session -> IO Bool
 553 abandonAll (Session ref) = do
 554    hsc_env <- readIORef ref
 555    let ic = hsc_IC hsc_env
 556        resume = ic_resume ic
 557    case resume of
 558       []  -> return False
 559       rs  -> do
 560          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
 561          mapM_ abandon_ rs
 562          return True
 563
 564 -- when abandoning a computation we have to
 565 --      (a) kill the thread with an async exception, so that the
 566 --          computation itself is stopped, and
 567 --      (b) fill in the MVar.  This step is necessary because any
 568 --          thunks that were under evaluation will now be updated
 569 --          with the partial computation, which still ends in takeMVar,
 570 --          so any attempt to evaluate one of these thunks will block
 571 --          unless we fill in the MVar.
 572 --  See test break010.
 573 abandon_ :: Resume -> IO ()
 574 abandon_ r = do
 575   killThread (resumeThreadId r)
 576   putMVar (resumeBreakMVar r) ()
 577
 578 -- -----------------------------------------------------------------------------
 579 -- Bounded list, optimised for repeated cons
 580
 581 data BoundedList a = BL
 582                         {-# UNPACK #-} !Int  -- length
 583                         {-# UNPACK #-} !Int  -- bound
 584                         [a] -- left
 585                         [a] -- right,  list is (left ++ reverse right)
 586
 587 nilBL :: Int -> BoundedList a
 588 nilBL bound = BL 0 bound [] []
 589
 590 consBL a (BL len bound left right)
 591   | len < bound = BL (len+1) bound (a:left) right
 592   | null right  = BL len     bound [a]      $! tail (reverse left)
 593   | otherwise   = BL len     bound (a:left) $! tail right
 594
 595 toListBL (BL _ _ left right) = left ++ reverse right
 596
 597 -- lenBL (BL len _ _ _) = len
 598
 599 -- -----------------------------------------------------------------------------
 600 -- | Set the interactive evaluation context.
 601 --
 602 -- Setting the context doesn't throw away any bindings; the bindings
 603 -- we've built up in the InteractiveContext simply move to the new
 604 -- module.  They always shadow anything in scope in the current context.
 605 setContext :: Session
 606            -> [Module]  -- entire top level scope of these modules
 607            -> [Module]  -- exports only of these modules
 608            -> IO ()
 609 setContext sess@(Session ref) toplev_mods export_mods = do
 610   hsc_env <- readIORef ref
 611   let old_ic  = hsc_IC     hsc_env
 612       hpt     = hsc_HPT    hsc_env
 613   --
 614   export_env  <- mkExportEnv hsc_env export_mods
 615   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
 616   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 617   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 618                                             ic_exports      = export_mods,
 619                                             ic_rn_gbl_env   = all_env }}
 620
 621 -- Make a GlobalRdrEnv based on the exports of the modules only.
 622 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 623 mkExportEnv hsc_env mods = do
 624   stuff <- mapM (getModuleExports hsc_env) mods
 625   let
 626         (_msgs, mb_name_sets) = unzip stuff
 627         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 628                | (Just avails, mod) <- zip mb_name_sets mods ]
 629   --
 630   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 631
 632 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 633 nameSetToGlobalRdrEnv names mod =
 634   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 635                  | name <- nameSetToList names ]
 636
 637 vanillaProv :: ModuleName -> Provenance
 638 -- We're building a GlobalRdrEnv as if the user imported
 639 -- all the specified modules into the global interactive module
 640 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 641   where
 642     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 643                          is_qual = False,
 644                          is_dloc = srcLocSpan interactiveSrcLoc }
 645
 646 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 647 mkTopLevEnv hpt modl
 648   = case lookupUFM hpt (moduleName modl) of
 649       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
 650                                                 showSDoc (ppr modl)))
 651       Just details ->
 652          case mi_globals (hm_iface details) of
 653                 Nothing  ->
 654                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
 655                                                 ++ showSDoc (ppr modl)))
 656                 Just env -> return env
 657
 658 -- | Get the interactive evaluation context, consisting of a pair of the
 659 -- set of modules from which we take the full top-level scope, and the set
 660 -- of modules from which we take just the exports respectively.
 661 getContext :: Session -> IO ([Module],[Module])
 662 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 663                                 return (ic_toplev_scope ic, ic_exports ic))
 664
 665 -- | Returns 'True' if the specified module is interpreted, and hence has
 666 -- its full top-level scope available.
 667 moduleIsInterpreted :: Session -> Module -> IO Bool
 668 moduleIsInterpreted s modl = withSession s $ \h ->
 669  if modulePackageId modl /= thisPackage (hsc_dflags h)
 670         then return False
 671         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 672                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 673                 _not_a_home_module -> return False
 674
 675 -- | Looks up an identifier in the current interactive context (for :info)
 676 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 677 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
 678
 679 -- | Returns all names in scope in the current interactive context
 680 getNamesInScope :: Session -> IO [Name]
 681 getNamesInScope s = withSession s $ \hsc_env -> do
 682   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 683
 684 getRdrNamesInScope :: Session -> IO [RdrName]
 685 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
 686   let
 687       ic = hsc_IC hsc_env
 688       gbl_rdrenv = ic_rn_gbl_env ic
 689       ids = ic_tmp_ids ic
 690       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 691       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 692   --
 693   return (gbl_names ++ lcl_names)
 694
 695
 696 -- ToDo: move to RdrName
 697 greToRdrNames :: GlobalRdrElt -> [RdrName]
 698 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 699   = case prov of
 700      LocalDef -> [unqual]
 701      Imported specs -> concat (map do_spec (map is_decl specs))
 702   where
 703     occ = nameOccName name
 704     unqual = Unqual occ
 705     do_spec decl_spec
 706         | is_qual decl_spec = [qual]
 707         | otherwise         = [unqual,qual]
 708         where qual = Qual (is_as decl_spec) occ
 709
 710 -- | Parses a string as an identifier, and returns the list of 'Name's that
 711 -- the identifier can refer to in the current interactive context.
 712 parseName :: Session -> String -> IO [Name]
 713 parseName s str = withSession s $ \hsc_env -> do
 714    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 715    case maybe_rdr_name of
 716         Nothing -> return []
 717         Just (L _ rdr_name) -> do
 718             mb_names <- tcRnLookupRdrName hsc_env rdr_name
 719             case mb_names of
 720                 Nothing -> return []
 721                 Just ns -> return ns
 722                 -- ToDo: should return error messages
 723
 724 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 725 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 726 lookupName :: Session -> Name -> IO (Maybe TyThing)
 727 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
 728
 729 -- -----------------------------------------------------------------------------
 730 -- Getting the type of an expression
 731
 732 -- | Get the type of an expression
 733 exprType :: Session -> String -> IO (Maybe Type)
 734 exprType s expr = withSession s $ \hsc_env -> do
 735    maybe_stuff <- hscTcExpr hsc_env expr
 736    case maybe_stuff of
 737         Nothing -> return Nothing
 738         Just ty -> return (Just tidy_ty)
 739              where
 740                 tidy_ty = tidyType emptyTidyEnv ty
 741
 742 -- -----------------------------------------------------------------------------
 743 -- Getting the kind of a type
 744
 745 -- | Get the kind of a  type
 746 typeKind  :: Session -> String -> IO (Maybe Kind)
 747 typeKind s str = withSession s $ \hsc_env -> do
 748    maybe_stuff <- hscKcType hsc_env str
 749    case maybe_stuff of
 750         Nothing -> return Nothing
 751         Just kind -> return (Just kind)
 752
 753 -----------------------------------------------------------------------------
 754 -- cmCompileExpr: compile an expression and deliver an HValue
 755
 756 compileExpr :: Session -> String -> IO (Maybe HValue)
 757 compileExpr s expr = withSession s $ \hsc_env -> do
 758   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 759   case maybe_stuff of
 760         Nothing -> return Nothing
 761         Just (ids, hval) -> do
 762                         -- Run it!
 763                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
 764
 765                 case (ids,hvals) of
 766                   ([n],[hv]) -> return (Just hv)
 767                   _          -> panic "compileExpr"
 768
 769 -- -----------------------------------------------------------------------------
 770 -- Compile an expression into a dynamic
 771
 772 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
 773 dynCompileExpr ses expr = do
 774     (full,exports) <- getContext ses
 775     setContext ses full $
 776         (mkModule
 777             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 778         ):exports
 779     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 780     res <- withSession ses (flip hscStmt stmt)
 781     setContext ses full exports
 782     case res of
 783         Nothing -> return Nothing
 784         Just (ids, hvals) -> do
 785             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
 786             case (ids,vals) of
 787                 (_:[], v:[])    -> return (Just v)
 788                 _               -> panic "dynCompileExpr"
 789
 790 -----------------------------------------------------------------------------
 791 -- show a module and it's source/object filenames
 792
 793 showModule :: Session -> ModSummary -> IO String
 794 showModule s mod_summary = withSession s $                        \hsc_env ->
 795                            isModuleInterpreted s mod_summary >>=  \interpreted ->
 796                            return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 797
 798 isModuleInterpreted :: Session -> ModSummary -> IO Bool
 799 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 800   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 801         Nothing       -> panic "missing linkable"
 802         Just mod_info -> return (not obj_linkable)
 803                       where
 804                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 805
 806 obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
 807 obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
 808
 809 obtainTerm :: Session -> Bool -> Id -> IO Term
 810 obtainTerm sess force id = withSession sess $ \hsc_env -> do
 811               hv <- Linker.getHValue hsc_env (varName id)
 812               cvObtainTerm hsc_env force (Just$ idType id) hv
 813
 814 #endif /* GHCI */