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