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