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 _ _ _ -> 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                 case step of
 371                   RunAndLogSteps ->
 372                         traceRunStatus expr ref bindings final_ids
 373                                        breakMVar statusMVar status emptyHistory
 374                   _other ->
 375                         handleRunStatus expr ref bindings final_ids
 376                                         breakMVar statusMVar status emptyHistory
 377
 378
 379 back :: Session -> IO ([Name], Int, SrcSpan)
 380 back  = moveHist (+1)
 381
 382 forward :: Session -> IO ([Name], Int, SrcSpan)
 383 forward  = moveHist (subtract 1)
 384
 385 moveHist fn (Session ref) = do
 386   hsc_env <- readIORef ref
 387   case ic_resume (hsc_IC hsc_env) of
 388      [] -> throwDyn (ProgramError "not stopped at a breakpoint")
 389      (r:rs) -> do
 390         let ix = resumeHistoryIx r
 391             history = resumeHistory r
 392             new_ix = fn ix
 393         --
 394         when (new_ix > length history) $
 395            throwDyn (ProgramError "no more logged breakpoints")
 396         when (new_ix < 0) $
 397            throwDyn (ProgramError "already at the beginning of the history")
 398
 399         let
 400           update_ic apStack mb_info = do
 401             (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
 402                                                 apStack mb_info
 403             let ic = hsc_IC hsc_env1
 404                 r' = r { resumeHistoryIx = new_ix }
 405                 ic' = ic { ic_resume = r':rs }
 406
 407             writeIORef ref hsc_env1{ hsc_IC = ic' }
 408
 409             return (names, new_ix, span)
 410
 411         -- careful: we want apStack to be the AP_STACK itself, not a thunk
 412         -- around it, hence the cases are carefully constructed below to
 413         -- make this the case.  ToDo: this is v. fragile, do something better.
 414         if new_ix == 0
 415            then case r of
 416                    Resume { resumeApStack = apStack,
 417                             resumeBreakInfo = mb_info } ->
 418                           update_ic apStack mb_info
 419            else case history !! (new_ix - 1) of
 420                    History apStack info ->
 421                           update_ic apStack (Just info)
 422
 423 -- -----------------------------------------------------------------------------
 424 -- After stopping at a breakpoint, add free variables to the environment
 425 result_fs = FSLIT("_result")
 426
 427 bindLocalsAtBreakpoint
 428         :: HscEnv
 429         -> HValue
 430         -> Maybe BreakInfo
 431         -> IO (HscEnv, [Name], SrcSpan)
 432
 433 -- Nothing case: we stopped when an exception was raised, not at a
 434 -- breakpoint.  We have no location information or local variables to
 435 -- bind, all we can do is bind a local variable to the exception
 436 -- value.
 437 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 438    let exn_fs    = FSLIT("_exception")
 439        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
 440        e_fs      = FSLIT("e")
 441        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
 442        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
 443        exn_id    = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
 444                                 vanillaIdInfo
 445        new_tyvars = unitVarSet e_tyvar
 446
 447        ictxt0 = hsc_IC hsc_env
 448        ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
 449
 450        span = mkGeneralSrcSpan FSLIT("<exception thrown>")
 451    --
 452    Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
 453    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 454
 455 -- Just case: we stopped at a breakpoint, we have information about the location
 456 -- of the breakpoint and the free variables of the expression.
 457 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 458
 459    let
 460        mod_name    = moduleName (breakInfo_module info)
 461        mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
 462        breaks      = md_modBreaks (expectJust "handlRunStatus" mod_details)
 463        index     = breakInfo_number info
 464        vars      = breakInfo_vars info
 465        result_ty = breakInfo_resty info
 466        occs      = modBreaks_vars breaks ! index
 467        span      = modBreaks_locs breaks ! index
 468
 469    -- filter out any unboxed ids; we can't bind these at the prompt
 470    let pointers = filter (\(id,_) -> isPointer id) vars
 471        isPointer id | PtrRep <- idPrimRep id = True
 472                     | otherwise              = False
 473
 474    let (ids, offsets) = unzip pointers
 475
 476    -- It might be that getIdValFromApStack fails, because the AP_STACK
 477    -- has been accidentally evaluated, or something else has gone wrong.
 478    -- So that we don't fall over in a heap when this happens, just don't
 479    -- bind any free variables instead, and we emit a warning.
 480    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
 481    let (filtered_hvs, filtered_ids) =
 482                        unzip [ (hv, id) | (id, Just hv) <- zip ids mb_hValues ]
 483    when (any isNothing mb_hValues) $
 484       debugTraceMsg (hsc_dflags hsc_env) 1 $
 485           text "Warning: _result has been evaluated, some bindings have been lost"
 486
 487    new_ids <- zipWithM mkNewId occs filtered_ids
 488    let names = map idName new_ids
 489
 490    -- make an Id for _result.  We use the Unique of the FastString "_result";
 491    -- we don't care about uniqueness here, because there will only be one
 492    -- _result in scope at any time.
 493    let result_name = mkInternalName (getUnique result_fs)
 494                           (mkVarOccFS result_fs) span
 495        result_id   = Id.mkGlobalId VanillaGlobal result_name result_ty
 496                                    vanillaIdInfo
 497
 498    -- for each Id we're about to bind in the local envt:
 499    --    - skolemise the type variables in its type, so they can't
 500    --      be randomly unified with other types.  These type variables
 501    --      can only be resolved by type reconstruction in RtClosureInspect
 502    --    - tidy the type variables
 503    --    - globalise the Id (Ids are supposed to be Global, apparently).
 504    --
 505    let all_ids | isPointer result_id = result_id : new_ids
 506                | otherwise           = new_ids
 507        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 508        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 509        new_tyvars = unionVarSets tyvarss
 510    let final_ids = zipWith setIdType all_ids tidy_tys
 511        ictxt0 = hsc_IC hsc_env
 512        ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 513    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 514    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 515    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
 516    return (hsc_env1, result_name:names, span)
 517   where
 518    mkNewId :: OccName -> Id -> IO Id
 519    mkNewId occ id = do
 520      let uniq = idUnique id
 521          loc = nameSrcSpan (idName id)
 522          name = mkInternalName uniq occ loc
 523          ty = idType id
 524          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
 525      return new_id
 526
 527 rttiEnvironment :: HscEnv -> IO HscEnv
 528 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
 529    let InteractiveContext{ic_tmp_ids=tmp_ids, ic_tyvars = tyvars} = ic
 530        incompletelyTypedIds =
 531            [id | id <- tmp_ids
 532                , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
 533                               , isSkolemTyVar v]
 534                , (occNameFS.nameOccName.idName) id /= result_fs]
 535    tys <- reconstructType hsc_env False `mapM` incompletelyTypedIds
 536           -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
 537
 538    let substs = [computeRTTIsubst ty ty'
 539                  | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
 540        ic'    = foldr (flip substInteractiveContext) ic
 541                            (map skolemiseSubst $ catMaybes substs)
 542    return hsc_env{hsc_IC=ic'}
 543
 544 skolemiseSubst subst = subst `setTvSubstEnv`
 545                         mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
 546
 547 skolemiseTy :: Type -> (Type, TyVarSet)
 548 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 549   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 550         subst         = mkTvSubst emptyInScopeSet env
 551         tyvars        = varSetElems (tyVarsOfType ty)
 552         new_tyvars    = map skolemiseTyVar tyvars
 553         new_tyvar_tys = map mkTyVarTy new_tyvars
 554
 555 skolemiseTyVar :: TyVar -> TyVar
 556 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 557                                  (SkolemTv RuntimeUnkSkol)
 558
 559 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 560 getIdValFromApStack apStack (I# stackDepth) = do
 561    case getApStackVal# apStack (stackDepth +# 1#) of
 562                                 -- The +1 is magic!  I don't know where it comes
 563                                 -- from, but this makes things line up.  --SDM
 564         (# ok, result #) ->
 565             case ok of
 566               0# -> return Nothing -- AP_STACK not found
 567               _  -> return (Just (unsafeCoerce# result))
 568
 569 pushResume :: HscEnv -> Resume -> HscEnv
 570 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 571   where
 572         ictxt0 = hsc_IC hsc_env
 573         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 574
 575 -- -----------------------------------------------------------------------------
 576 -- Abandoning a resume context
 577
 578 abandon :: Session -> IO Bool
 579 abandon (Session ref) = do
 580    hsc_env <- readIORef ref
 581    let ic = hsc_IC hsc_env
 582        resume = ic_resume ic
 583    case resume of
 584       []    -> return False
 585       r:rs  -> do
 586          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
 587          abandon_ r
 588          return True
 589
 590 abandonAll :: Session -> IO Bool
 591 abandonAll (Session ref) = do
 592    hsc_env <- readIORef ref
 593    let ic = hsc_IC hsc_env
 594        resume = ic_resume ic
 595    case resume of
 596       []  -> return False
 597       rs  -> do
 598          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
 599          mapM_ abandon_ rs
 600          return True
 601
 602 -- when abandoning a computation we have to
 603 --      (a) kill the thread with an async exception, so that the
 604 --          computation itself is stopped, and
 605 --      (b) fill in the MVar.  This step is necessary because any
 606 --          thunks that were under evaluation will now be updated
 607 --          with the partial computation, which still ends in takeMVar,
 608 --          so any attempt to evaluate one of these thunks will block
 609 --          unless we fill in the MVar.
 610 --  See test break010.
 611 abandon_ :: Resume -> IO ()
 612 abandon_ r = do
 613   killThread (resumeThreadId r)
 614   putMVar (resumeBreakMVar r) ()
 615
 616 -- -----------------------------------------------------------------------------
 617 -- Bounded list, optimised for repeated cons
 618
 619 data BoundedList a = BL
 620                         {-# UNPACK #-} !Int  -- length
 621                         {-# UNPACK #-} !Int  -- bound
 622                         [a] -- left
 623                         [a] -- right,  list is (left ++ reverse right)
 624
 625 nilBL :: Int -> BoundedList a
 626 nilBL bound = BL 0 bound [] []
 627
 628 consBL a (BL len bound left right)
 629   | len < bound = BL (len+1) bound (a:left) right
 630   | null right  = BL len     bound [a]      $! tail (reverse left)
 631   | otherwise   = BL len     bound (a:left) $! tail right
 632
 633 toListBL (BL _ _ left right) = left ++ reverse right
 634
 635 -- lenBL (BL len _ _ _) = len
 636
 637 -- -----------------------------------------------------------------------------
 638 -- | Set the interactive evaluation context.
 639 --
 640 -- Setting the context doesn't throw away any bindings; the bindings
 641 -- we've built up in the InteractiveContext simply move to the new
 642 -- module.  They always shadow anything in scope in the current context.
 643 setContext :: Session
 644            -> [Module]  -- entire top level scope of these modules
 645            -> [Module]  -- exports only of these modules
 646            -> IO ()
 647 setContext sess@(Session ref) toplev_mods export_mods = do
 648   hsc_env <- readIORef ref
 649   let old_ic  = hsc_IC     hsc_env
 650       hpt     = hsc_HPT    hsc_env
 651   --
 652   export_env  <- mkExportEnv hsc_env export_mods
 653   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
 654   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 655   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 656                                             ic_exports      = export_mods,
 657                                             ic_rn_gbl_env   = all_env }}
 658
 659 -- Make a GlobalRdrEnv based on the exports of the modules only.
 660 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 661 mkExportEnv hsc_env mods = do
 662   stuff <- mapM (getModuleExports hsc_env) mods
 663   let
 664         (_msgs, mb_name_sets) = unzip stuff
 665         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 666                | (Just avails, mod) <- zip mb_name_sets mods ]
 667   --
 668   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 669
 670 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 671 nameSetToGlobalRdrEnv names mod =
 672   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 673                  | name <- nameSetToList names ]
 674
 675 vanillaProv :: ModuleName -> Provenance
 676 -- We're building a GlobalRdrEnv as if the user imported
 677 -- all the specified modules into the global interactive module
 678 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 679   where
 680     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 681                          is_qual = False,
 682                          is_dloc = srcLocSpan interactiveSrcLoc }
 683
 684 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 685 mkTopLevEnv hpt modl
 686   = case lookupUFM hpt (moduleName modl) of
 687       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
 688                                                 showSDoc (ppr modl)))
 689       Just details ->
 690          case mi_globals (hm_iface details) of
 691                 Nothing  ->
 692                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
 693                                                 ++ showSDoc (ppr modl)))
 694                 Just env -> return env
 695
 696 -- | Get the interactive evaluation context, consisting of a pair of the
 697 -- set of modules from which we take the full top-level scope, and the set
 698 -- of modules from which we take just the exports respectively.
 699 getContext :: Session -> IO ([Module],[Module])
 700 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 701                                 return (ic_toplev_scope ic, ic_exports ic))
 702
 703 -- | Returns 'True' if the specified module is interpreted, and hence has
 704 -- its full top-level scope available.
 705 moduleIsInterpreted :: Session -> Module -> IO Bool
 706 moduleIsInterpreted s modl = withSession s $ \h ->
 707  if modulePackageId modl /= thisPackage (hsc_dflags h)
 708         then return False
 709         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 710                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 711                 _not_a_home_module -> return False
 712
 713 -- | Looks up an identifier in the current interactive context (for :info)
 714 -- Filter the instances by the ones whose tycons (or clases resp)
 715 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 716 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 717 --      (see Trac #1581)
 718 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 719 getInfo s name
 720   = withSession s $ \hsc_env ->
 721     do  { mb_stuff <- tcRnGetInfo hsc_env name
 722         ; case mb_stuff of
 723             Nothing -> return Nothing
 724             Just (thing, fixity, ispecs) -> do
 725         { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
 726         ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } }
 727   where
 728     plausible rdr_env ispec     -- Dfun involving only names that are in ic_rn_glb_env
 729         = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
 730         where   -- A name is ok if it's in the rdr_env,
 731                 -- whether qualified or not
 732           ok n | n == name         = True       -- The one we looked for in the first place!
 733                | isBuiltInSyntax n = True
 734                | isExternalName n  = any ((== n) . gre_name)
 735                                          (lookupGRE_Name rdr_env n)
 736                | otherwise         = True
 737
 738 -- | Returns all names in scope in the current interactive context
 739 getNamesInScope :: Session -> IO [Name]
 740 getNamesInScope s = withSession s $ \hsc_env -> do
 741   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 742
 743 getRdrNamesInScope :: Session -> IO [RdrName]
 744 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
 745   let
 746       ic = hsc_IC hsc_env
 747       gbl_rdrenv = ic_rn_gbl_env ic
 748       ids = ic_tmp_ids ic
 749       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 750       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 751   --
 752   return (gbl_names ++ lcl_names)
 753
 754
 755 -- ToDo: move to RdrName
 756 greToRdrNames :: GlobalRdrElt -> [RdrName]
 757 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 758   = case prov of
 759      LocalDef -> [unqual]
 760      Imported specs -> concat (map do_spec (map is_decl specs))
 761   where
 762     occ = nameOccName name
 763     unqual = Unqual occ
 764     do_spec decl_spec
 765         | is_qual decl_spec = [qual]
 766         | otherwise         = [unqual,qual]
 767         where qual = Qual (is_as decl_spec) occ
 768
 769 -- | Parses a string as an identifier, and returns the list of 'Name's that
 770 -- the identifier can refer to in the current interactive context.
 771 parseName :: Session -> String -> IO [Name]
 772 parseName s str = withSession s $ \hsc_env -> do
 773    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 774    case maybe_rdr_name of
 775         Nothing -> return []
 776         Just (L _ rdr_name) -> do
 777             mb_names <- tcRnLookupRdrName hsc_env rdr_name
 778             case mb_names of
 779                 Nothing -> return []
 780                 Just ns -> return ns
 781                 -- ToDo: should return error messages
 782
 783 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 784 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 785 lookupName :: Session -> Name -> IO (Maybe TyThing)
 786 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
 787
 788 -- -----------------------------------------------------------------------------
 789 -- Getting the type of an expression
 790
 791 -- | Get the type of an expression
 792 exprType :: Session -> String -> IO (Maybe Type)
 793 exprType s expr = withSession s $ \hsc_env -> do
 794    maybe_stuff <- hscTcExpr hsc_env expr
 795    case maybe_stuff of
 796         Nothing -> return Nothing
 797         Just ty -> return (Just tidy_ty)
 798              where
 799                 tidy_ty = tidyType emptyTidyEnv ty
 800
 801 -- -----------------------------------------------------------------------------
 802 -- Getting the kind of a type
 803
 804 -- | Get the kind of a  type
 805 typeKind  :: Session -> String -> IO (Maybe Kind)
 806 typeKind s str = withSession s $ \hsc_env -> do
 807    maybe_stuff <- hscKcType hsc_env str
 808    case maybe_stuff of
 809         Nothing -> return Nothing
 810         Just kind -> return (Just kind)
 811
 812 -----------------------------------------------------------------------------
 813 -- cmCompileExpr: compile an expression and deliver an HValue
 814
 815 compileExpr :: Session -> String -> IO (Maybe HValue)
 816 compileExpr s expr = withSession s $ \hsc_env -> do
 817   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 818   case maybe_stuff of
 819         Nothing -> return Nothing
 820         Just (ids, hval) -> do
 821                         -- Run it!
 822                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
 823
 824                 case (ids,hvals) of
 825                   ([n],[hv]) -> return (Just hv)
 826                   _          -> panic "compileExpr"
 827
 828 -- -----------------------------------------------------------------------------
 829 -- Compile an expression into a dynamic
 830
 831 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
 832 dynCompileExpr ses expr = do
 833     (full,exports) <- getContext ses
 834     setContext ses full $
 835         (mkModule
 836             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 837         ):exports
 838     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 839     res <- withSession ses (flip hscStmt stmt)
 840     setContext ses full exports
 841     case res of
 842         Nothing -> return Nothing
 843         Just (ids, hvals) -> do
 844             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
 845             case (ids,vals) of
 846                 (_:[], v:[])    -> return (Just v)
 847                 _               -> panic "dynCompileExpr"
 848
 849 -----------------------------------------------------------------------------
 850 -- show a module and it's source/object filenames
 851
 852 showModule :: Session -> ModSummary -> IO String
 853 showModule s mod_summary = withSession s $                        \hsc_env ->
 854                            isModuleInterpreted s mod_summary >>=  \interpreted ->
 855                            return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 856
 857 isModuleInterpreted :: Session -> ModSummary -> IO Bool
 858 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 859   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 860         Nothing       -> panic "missing linkable"
 861         Just mod_info -> return (not obj_linkable)
 862                       where
 863                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 864
 865 ----------------------------------------------------------------------------
 866 -- RTTI primitives
 867
 868 obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
 869 obtainTerm1 hsc_env force mb_ty x =
 870               cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
 871
 872 obtainTerm :: HscEnv -> Bool -> Id -> IO Term
 873 obtainTerm hsc_env force id =  do
 874               hv <- Linker.getHValue hsc_env (varName id)
 875               cvObtainTerm hsc_env force (Just$ idType id) hv
 876
 877 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 878 reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type)
 879 reconstructType hsc_env force id = do
 880               hv <- Linker.getHValue hsc_env (varName id)
 881               cvReconstructType hsc_env force (Just$ idType id) hv
 882 #endif /* GHCI */