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    let substs = [unifyRTTI ty ty'
 620                  | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
 621        ic'    = foldr (flip substInteractiveContext) ic
 622                            (map skolemiseSubst substs)
 623    return hsc_env{hsc_IC=ic'}
 624
 625 skolemiseSubst :: TvSubst -> TvSubst
 626 skolemiseSubst subst = subst `setTvSubstEnv`
 627                         mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
 628
 629 skolemiseTy :: Type -> (Type, TyVarSet)
 630 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 631   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 632         subst         = mkTvSubst emptyInScopeSet env
 633         tyvars        = varSetElems (tyVarsOfType ty)
 634         new_tyvars    = map skolemiseTyVar tyvars
 635         new_tyvar_tys = map mkTyVarTy new_tyvars
 636
 637 skolemiseTyVar :: TyVar -> TyVar
 638 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 639                                  (SkolemTv RuntimeUnkSkol)
 640
 641 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 642 getIdValFromApStack apStack (I# stackDepth) = do
 643    case getApStackVal# apStack (stackDepth +# 1#) of
 644                                 -- The +1 is magic!  I don't know where it comes
 645                                 -- from, but this makes things line up.  --SDM
 646         (# ok, result #) ->
 647             case ok of
 648               0# -> return Nothing -- AP_STACK not found
 649               _  -> return (Just (unsafeCoerce# result))
 650
 651 pushResume :: HscEnv -> Resume -> HscEnv
 652 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 653   where
 654         ictxt0 = hsc_IC hsc_env
 655         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 656
 657 -- -----------------------------------------------------------------------------
 658 -- Abandoning a resume context
 659
 660 abandon :: Session -> IO Bool
 661 abandon (Session ref) = do
 662    hsc_env <- readIORef ref
 663    let ic = hsc_IC hsc_env
 664        resume = ic_resume ic
 665    case resume of
 666       []    -> return False
 667       r:rs  -> do
 668          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
 669          abandon_ r
 670          return True
 671
 672 abandonAll :: Session -> IO Bool
 673 abandonAll (Session ref) = do
 674    hsc_env <- readIORef ref
 675    let ic = hsc_IC hsc_env
 676        resume = ic_resume ic
 677    case resume of
 678       []  -> return False
 679       rs  -> do
 680          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
 681          mapM_ abandon_ rs
 682          return True
 683
 684 -- when abandoning a computation we have to
 685 --      (a) kill the thread with an async exception, so that the
 686 --          computation itself is stopped, and
 687 --      (b) fill in the MVar.  This step is necessary because any
 688 --          thunks that were under evaluation will now be updated
 689 --          with the partial computation, which still ends in takeMVar,
 690 --          so any attempt to evaluate one of these thunks will block
 691 --          unless we fill in the MVar.
 692 --  See test break010.
 693 abandon_ :: Resume -> IO ()
 694 abandon_ r = do
 695   killThread (resumeThreadId r)
 696   putMVar (resumeBreakMVar r) ()
 697
 698 -- -----------------------------------------------------------------------------
 699 -- Bounded list, optimised for repeated cons
 700
 701 data BoundedList a = BL
 702                         {-# UNPACK #-} !Int  -- length
 703                         {-# UNPACK #-} !Int  -- bound
 704                         [a] -- left
 705                         [a] -- right,  list is (left ++ reverse right)
 706
 707 nilBL :: Int -> BoundedList a
 708 nilBL bound = BL 0 bound [] []
 709
 710 consBL :: a -> BoundedList a -> BoundedList a
 711 consBL a (BL len bound left right)
 712   | len < bound = BL (len+1) bound (a:left) right
 713   | null right  = BL len     bound [a]      $! tail (reverse left)
 714   | otherwise   = BL len     bound (a:left) $! tail right
 715
 716 toListBL :: BoundedList a -> [a]
 717 toListBL (BL _ _ left right) = left ++ reverse right
 718
 719 fromListBL :: Int -> [a] -> BoundedList a
 720 fromListBL bound l = BL (length l) bound l []
 721
 722 -- lenBL (BL len _ _ _) = len
 723
 724 -- -----------------------------------------------------------------------------
 725 -- | Set the interactive evaluation context.
 726 --
 727 -- Setting the context doesn't throw away any bindings; the bindings
 728 -- we've built up in the InteractiveContext simply move to the new
 729 -- module.  They always shadow anything in scope in the current context.
 730 setContext :: Session
 731            -> [Module]  -- entire top level scope of these modules
 732            -> [Module]  -- exports only of these modules
 733            -> IO ()
 734 setContext (Session ref) toplev_mods export_mods = do
 735   hsc_env <- readIORef ref
 736   let old_ic  = hsc_IC     hsc_env
 737       hpt     = hsc_HPT    hsc_env
 738   --
 739   export_env  <- mkExportEnv hsc_env export_mods
 740   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
 741   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 742   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 743                                             ic_exports      = export_mods,
 744                                             ic_rn_gbl_env   = all_env }}
 745
 746 -- Make a GlobalRdrEnv based on the exports of the modules only.
 747 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 748 mkExportEnv hsc_env mods = do
 749   stuff <- mapM (getModuleExports hsc_env) mods
 750   let
 751         (_msgs, mb_name_sets) = unzip stuff
 752         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 753                | (Just avails, mod) <- zip mb_name_sets mods ]
 754   --
 755   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 756
 757 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 758 nameSetToGlobalRdrEnv names mod =
 759   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 760                  | name <- nameSetToList names ]
 761
 762 vanillaProv :: ModuleName -> Provenance
 763 -- We're building a GlobalRdrEnv as if the user imported
 764 -- all the specified modules into the global interactive module
 765 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 766   where
 767     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 768                          is_qual = False,
 769                          is_dloc = srcLocSpan interactiveSrcLoc }
 770
 771 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 772 mkTopLevEnv hpt modl
 773   = case lookupUFM hpt (moduleName modl) of
 774       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
 775                                                 showSDoc (ppr modl)))
 776       Just details ->
 777          case mi_globals (hm_iface details) of
 778                 Nothing  ->
 779                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
 780                                                 ++ showSDoc (ppr modl)))
 781                 Just env -> return env
 782
 783 -- | Get the interactive evaluation context, consisting of a pair of the
 784 -- set of modules from which we take the full top-level scope, and the set
 785 -- of modules from which we take just the exports respectively.
 786 getContext :: Session -> IO ([Module],[Module])
 787 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 788                                 return (ic_toplev_scope ic, ic_exports ic))
 789
 790 -- | Returns 'True' if the specified module is interpreted, and hence has
 791 -- its full top-level scope available.
 792 moduleIsInterpreted :: Session -> Module -> IO Bool
 793 moduleIsInterpreted s modl = withSession s $ \h ->
 794  if modulePackageId modl /= thisPackage (hsc_dflags h)
 795         then return False
 796         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 797                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 798                 _not_a_home_module -> return False
 799
 800 -- | Looks up an identifier in the current interactive context (for :info)
 801 -- Filter the instances by the ones whose tycons (or clases resp)
 802 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 803 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 804 --      (see Trac #1581)
 805 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 806 getInfo s name
 807   = withSession s $ \hsc_env ->
 808     do  { mb_stuff <- tcRnGetInfo hsc_env name
 809         ; case mb_stuff of
 810             Nothing -> return Nothing
 811             Just (thing, fixity, ispecs) -> do
 812         { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
 813         ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } }
 814   where
 815     plausible rdr_env ispec     -- Dfun involving only names that are in ic_rn_glb_env
 816         = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
 817         where   -- A name is ok if it's in the rdr_env,
 818                 -- whether qualified or not
 819           ok n | n == name         = True       -- The one we looked for in the first place!
 820                | isBuiltInSyntax n = True
 821                | isExternalName n  = any ((== n) . gre_name)
 822                                          (lookupGRE_Name rdr_env n)
 823                | otherwise         = True
 824
 825 -- | Returns all names in scope in the current interactive context
 826 getNamesInScope :: Session -> IO [Name]
 827 getNamesInScope s = withSession s $ \hsc_env -> do
 828   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 829
 830 getRdrNamesInScope :: Session -> IO [RdrName]
 831 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
 832   let
 833       ic = hsc_IC hsc_env
 834       gbl_rdrenv = ic_rn_gbl_env ic
 835       ids = ic_tmp_ids ic
 836       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 837       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 838   --
 839   return (gbl_names ++ lcl_names)
 840
 841
 842 -- ToDo: move to RdrName
 843 greToRdrNames :: GlobalRdrElt -> [RdrName]
 844 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 845   = case prov of
 846      LocalDef -> [unqual]
 847      Imported specs -> concat (map do_spec (map is_decl specs))
 848   where
 849     occ = nameOccName name
 850     unqual = Unqual occ
 851     do_spec decl_spec
 852         | is_qual decl_spec = [qual]
 853         | otherwise         = [unqual,qual]
 854         where qual = Qual (is_as decl_spec) occ
 855
 856 -- | Parses a string as an identifier, and returns the list of 'Name's that
 857 -- the identifier can refer to in the current interactive context.
 858 parseName :: Session -> String -> IO [Name]
 859 parseName s str = withSession s $ \hsc_env -> do
 860    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 861    case maybe_rdr_name of
 862         Nothing -> return []
 863         Just (L _ rdr_name) -> do
 864             mb_names <- tcRnLookupRdrName hsc_env rdr_name
 865             case mb_names of
 866                 Nothing -> return []
 867                 Just ns -> return ns
 868                 -- ToDo: should return error messages
 869
 870 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 871 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 872 lookupName :: Session -> Name -> IO (Maybe TyThing)
 873 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
 874
 875 -- -----------------------------------------------------------------------------
 876 -- Getting the type of an expression
 877
 878 -- | Get the type of an expression
 879 exprType :: Session -> String -> IO (Maybe Type)
 880 exprType s expr = withSession s $ \hsc_env -> do
 881    maybe_stuff <- hscTcExpr hsc_env expr
 882    case maybe_stuff of
 883         Nothing -> return Nothing
 884         Just ty -> return (Just tidy_ty)
 885              where
 886                 tidy_ty = tidyType emptyTidyEnv ty
 887
 888 -- -----------------------------------------------------------------------------
 889 -- Getting the kind of a type
 890
 891 -- | Get the kind of a  type
 892 typeKind  :: Session -> String -> IO (Maybe Kind)
 893 typeKind s str = withSession s $ \hsc_env -> do
 894    maybe_stuff <- hscKcType hsc_env str
 895    case maybe_stuff of
 896         Nothing -> return Nothing
 897         Just kind -> return (Just kind)
 898
 899 -----------------------------------------------------------------------------
 900 -- cmCompileExpr: compile an expression and deliver an HValue
 901
 902 compileExpr :: Session -> String -> IO (Maybe HValue)
 903 compileExpr s expr = withSession s $ \hsc_env -> do
 904   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 905   case maybe_stuff of
 906         Nothing -> return Nothing
 907         Just (ids, hval) -> do
 908                         -- Run it!
 909                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
 910
 911                 case (ids,hvals) of
 912                   ([_],[hv]) -> return (Just hv)
 913                   _          -> panic "compileExpr"
 914
 915 -- -----------------------------------------------------------------------------
 916 -- Compile an expression into a dynamic
 917
 918 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
 919 dynCompileExpr ses expr = do
 920     (full,exports) <- getContext ses
 921     setContext ses full $
 922         (mkModule
 923             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 924         ):exports
 925     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 926     res <- withSession ses (flip hscStmt stmt)
 927     setContext ses full exports
 928     case res of
 929         Nothing -> return Nothing
 930         Just (ids, hvals) -> do
 931             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
 932             case (ids,vals) of
 933                 (_:[], v:[])    -> return (Just v)
 934                 _               -> panic "dynCompileExpr"
 935
 936 -----------------------------------------------------------------------------
 937 -- show a module and it's source/object filenames
 938
 939 showModule :: Session -> ModSummary -> IO String
 940 showModule s mod_summary = withSession s $                        \hsc_env ->
 941                            isModuleInterpreted s mod_summary >>=  \interpreted ->
 942                            return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 943
 944 isModuleInterpreted :: Session -> ModSummary -> IO Bool
 945 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 946   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 947         Nothing       -> panic "missing linkable"
 948         Just mod_info -> return (not obj_linkable)
 949                       where
 950                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 951
 952 ----------------------------------------------------------------------------
 953 -- RTTI primitives
 954
 955 obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
 956 obtainTerm1 hsc_env force mb_ty x =
 957               cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
 958
 959 obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
 960 obtainTermB hsc_env bound force id =  do
 961               hv <- Linker.getHValue hsc_env (varName id)
 962               cvObtainTerm hsc_env bound force (Just$ idType id) hv
 963
 964 obtainTerm :: HscEnv -> Bool -> Id -> IO Term
 965 obtainTerm hsc_env force id =  do
 966               hv <- Linker.getHValue hsc_env (varName id)
 967               cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
 968
 969 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 970 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 971 reconstructType hsc_env bound id = do
 972               hv <- Linker.getHValue hsc_env (varName id)
 973               cvReconstructType hsc_env bound (Just$ idType id) hv
 974 #endif /* GHCI */