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