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