compiler/main/InteractiveEval.hs

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