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 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 the new
 321 -- thread blocked (forkIO inherits block from the parent, #1048), and unblock
 322 -- only while we execute the user's code.  We can't afford to lose the final
 323 -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
 324 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
 325 sandboxIO dflags statusMVar thing =
 326    block $ do  -- fork starts blocked
 327      id <- forkIO $ do res <- Exception.try (unblock $ rethrow dflags thing)
 328                        putMVar statusMVar (Complete res) -- empty: can't block
 329      withInterruptsSentTo id $ takeMVar statusMVar
 330
 331
 332 -- We want to turn ^C into a break when -fbreak-on-exception is on,
 333 -- but it's an async exception and we only break for sync exceptions.
 334 -- Idea: if we catch and re-throw it, then the re-throw will trigger
 335 -- a break.  Great - but we don't want to re-throw all exceptions, because
 336 -- then we'll get a double break for ordinary sync exceptions (you'd have
 337 -- to :continue twice, which looks strange).  So if the exception is
 338 -- not "Interrupted", we unset the exception flag before throwing.
 339 --
 340 rethrow :: DynFlags -> IO a -> IO a
 341 rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
 342                 case e of
 343                    -- If -fbreak-on-error, we break unconditionally,
 344                    --  but with care of not breaking twice
 345                    _ | dopt Opt_BreakOnError dflags &&
 346                        not(dopt Opt_BreakOnException dflags)
 347                         -> poke exceptionFlag 1
 348
 349                    -- If it is an "Interrupted" exception, we allow
 350                    --  a possible break by way of -fbreak-on-exception
 351                    DynException d | Just Interrupted <- fromDynamic d
 352                         -> return ()
 353
 354                    -- In any other case, we don't want to break
 355                    _    -> poke exceptionFlag 0
 356
 357                 Exception.throwIO e
 358
 359
 360 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 361 withInterruptsSentTo thread get_result = do
 362   bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
 363           (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
 364           (\_ -> get_result)
 365
 366 -- This function sets up the interpreter for catching breakpoints, and
 367 -- resets everything when the computation has stopped running.  This
 368 -- is a not-very-good way to ensure that only the interactive
 369 -- evaluation should generate breakpoints.
 370 withBreakAction :: Bool -> DynFlags -> MVar () -> MVar Status -> IO a -> IO a
 371 withBreakAction step dflags breakMVar statusMVar io
 372  = bracket setBreakAction resetBreakAction (\_ -> io)
 373  where
 374    setBreakAction = do
 375      stablePtr <- newStablePtr onBreak
 376      poke breakPointIOAction stablePtr
 377      when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
 378      when step $ setStepFlag
 379      return stablePtr
 380         -- Breaking on exceptions is not enabled by default, since it
 381         -- might be a bit surprising.  The exception flag is turned off
 382         -- as soon as it is hit, or in resetBreakAction below.
 383
 384    onBreak is_exception info apStack = do
 385      tid <- myThreadId
 386      putMVar statusMVar (Break is_exception apStack info tid)
 387      takeMVar breakMVar
 388
 389    resetBreakAction stablePtr = do
 390      poke breakPointIOAction noBreakStablePtr
 391      poke exceptionFlag 0
 392      resetStepFlag
 393      freeStablePtr stablePtr
 394
 395 noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
 396 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 397
 398 noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
 399 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
 400 noBreakAction True  _ _ = return () -- exception: just continue
 401
 402 resume :: Session -> SingleStep -> IO RunResult
 403 resume (Session ref) step
 404  = do
 405    hsc_env <- readIORef ref
 406    let ic = hsc_IC hsc_env
 407        resume = ic_resume ic
 408
 409    case resume of
 410      [] -> ghcError (ProgramError "not stopped at a breakpoint")
 411      (r:rs) -> do
 412         -- unbind the temporary locals by restoring the TypeEnv from
 413         -- before the breakpoint, and drop this Resume from the
 414         -- InteractiveContext.
 415         let (resume_tmp_ids, resume_tyvars) = resumeBindings r
 416             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
 417                        ic_tyvars   = resume_tyvars,
 418                        ic_resume   = rs }
 419         writeIORef ref hsc_env{ hsc_IC = ic' }
 420
 421         -- remove any bindings created since the breakpoint from the
 422         -- linker's environment
 423         let new_names = map idName (filter (`notElem` resume_tmp_ids)
 424                                            (ic_tmp_ids ic))
 425         Linker.deleteFromLinkEnv new_names
 426
 427         when (isStep step) $ setStepFlag
 428         case r of
 429           Resume expr tid breakMVar statusMVar bindings
 430               final_ids apStack info _ hist _ -> do
 431                 withBreakAction (isStep step) (hsc_dflags hsc_env)
 432                                         breakMVar statusMVar $ do
 433                 status <- withInterruptsSentTo tid $ do
 434                              putMVar breakMVar ()
 435                                       -- this awakens the stopped thread...
 436                              takeMVar statusMVar
 437                                       -- and wait for the result
 438                 let hist' =
 439                      case info of
 440                        Nothing -> fromListBL 50 hist
 441                        Just i -> mkHistory hsc_env apStack i `consBL`
 442                                                         fromListBL 50 hist
 443                 case step of
 444                   RunAndLogSteps ->
 445                         traceRunStatus expr ref bindings final_ids
 446                                        breakMVar statusMVar status hist'
 447                   _other ->
 448                         handleRunStatus expr ref bindings final_ids
 449                                         breakMVar statusMVar status hist'
 450
 451 back :: Session -> IO ([Name], Int, SrcSpan)
 452 back  = moveHist (+1)
 453
 454 forward :: Session -> IO ([Name], Int, SrcSpan)
 455 forward  = moveHist (subtract 1)
 456
 457 moveHist :: (Int -> Int) -> Session -> IO ([Name], Int, SrcSpan)
 458 moveHist fn (Session ref) = do
 459   hsc_env <- readIORef ref
 460   case ic_resume (hsc_IC hsc_env) of
 461      [] -> ghcError (ProgramError "not stopped at a breakpoint")
 462      (r:rs) -> do
 463         let ix = resumeHistoryIx r
 464             history = resumeHistory r
 465             new_ix = fn ix
 466         --
 467         when (new_ix > length history) $
 468            ghcError (ProgramError "no more logged breakpoints")
 469         when (new_ix < 0) $
 470            ghcError (ProgramError "already at the beginning of the history")
 471
 472         let
 473           update_ic apStack mb_info = do
 474             (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
 475                                                 apStack mb_info
 476             let ic = hsc_IC hsc_env1
 477                 r' = r { resumeHistoryIx = new_ix }
 478                 ic' = ic { ic_resume = r':rs }
 479
 480             writeIORef ref hsc_env1{ hsc_IC = ic' }
 481
 482             return (names, new_ix, span)
 483
 484         -- careful: we want apStack to be the AP_STACK itself, not a thunk
 485         -- around it, hence the cases are carefully constructed below to
 486         -- make this the case.  ToDo: this is v. fragile, do something better.
 487         if new_ix == 0
 488            then case r of
 489                    Resume { resumeApStack = apStack,
 490                             resumeBreakInfo = mb_info } ->
 491                           update_ic apStack mb_info
 492            else case history !! (new_ix - 1) of
 493                    History apStack info _ ->
 494                           update_ic apStack (Just info)
 495
 496 -- -----------------------------------------------------------------------------
 497 -- After stopping at a breakpoint, add free variables to the environment
 498 result_fs :: FastString
 499 result_fs = fsLit "_result"
 500
 501 bindLocalsAtBreakpoint
 502         :: HscEnv
 503         -> HValue
 504         -> Maybe BreakInfo
 505         -> IO (HscEnv, [Name], SrcSpan)
 506
 507 -- Nothing case: we stopped when an exception was raised, not at a
 508 -- breakpoint.  We have no location information or local variables to
 509 -- bind, all we can do is bind a local variable to the exception
 510 -- value.
 511 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 512    let exn_fs    = fsLit "_exception"
 513        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
 514        e_fs      = fsLit "e"
 515        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
 516        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
 517        exn_id    = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
 518                                 vanillaIdInfo
 519        new_tyvars = unitVarSet e_tyvar
 520
 521        ictxt0 = hsc_IC hsc_env
 522        ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
 523
 524        span = mkGeneralSrcSpan (fsLit "<exception thrown>")
 525    --
 526    Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
 527    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 528
 529 -- Just case: we stopped at a breakpoint, we have information about the location
 530 -- of the breakpoint and the free variables of the expression.
 531 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 532
 533    let
 534        mod_name  = moduleName (breakInfo_module info)
 535        hmi       = expectJust "bindLocalsAtBreakpoint" $
 536                         lookupUFM (hsc_HPT hsc_env) mod_name
 537        breaks    = getModBreaks hmi
 538        index     = breakInfo_number info
 539        vars      = breakInfo_vars info
 540        result_ty = breakInfo_resty info
 541        occs      = modBreaks_vars breaks ! index
 542        span      = modBreaks_locs breaks ! index
 543
 544    -- filter out any unboxed ids; we can't bind these at the prompt
 545    let pointers = filter (\(id,_) -> isPointer id) vars
 546        isPointer id | PtrRep <- idPrimRep id = True
 547                     | otherwise              = False
 548
 549    let (ids, offsets) = unzip pointers
 550
 551    -- It might be that getIdValFromApStack fails, because the AP_STACK
 552    -- has been accidentally evaluated, or something else has gone wrong.
 553    -- So that we don't fall over in a heap when this happens, just don't
 554    -- bind any free variables instead, and we emit a warning.
 555    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
 556    let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
 557    when (any isNothing mb_hValues) $
 558       debugTraceMsg (hsc_dflags hsc_env) 1 $
 559           text "Warning: _result has been evaluated, some bindings have been lost"
 560
 561    new_ids <- zipWithM mkNewId occs filtered_ids
 562    let names = map idName new_ids
 563
 564    -- make an Id for _result.  We use the Unique of the FastString "_result";
 565    -- we don't care about uniqueness here, because there will only be one
 566    -- _result in scope at any time.
 567    let result_name = mkInternalName (getUnique result_fs)
 568                           (mkVarOccFS result_fs) span
 569        result_id   = Id.mkGlobalId VanillaGlobal result_name result_ty
 570                                    vanillaIdInfo
 571
 572    -- for each Id we're about to bind in the local envt:
 573    --    - skolemise the type variables in its type, so they can't
 574    --      be randomly unified with other types.  These type variables
 575    --      can only be resolved by type reconstruction in RtClosureInspect
 576    --    - tidy the type variables
 577    --    - globalise the Id (Ids are supposed to be Global, apparently).
 578    --
 579    let all_ids | isPointer result_id = result_id : new_ids
 580                | otherwise           = new_ids
 581        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 582        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 583        new_tyvars = unionVarSets tyvarss
 584    let final_ids = zipWith setIdType all_ids tidy_tys
 585        ictxt0 = hsc_IC hsc_env
 586        ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 587    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 588    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 589    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
 590    return (hsc_env1, result_name:names, span)
 591   where
 592    mkNewId :: OccName -> Id -> IO Id
 593    mkNewId occ id = do
 594      us <- mkSplitUniqSupply 'I'
 595         -- we need a fresh Unique for each Id we bind, because the linker
 596         -- state is single-threaded and otherwise we'd spam old bindings
 597         -- whenever we stop at a breakpoint.  The InteractveContext is properly
 598         -- saved/restored, but not the linker state.  See #1743, test break026.
 599      let
 600          uniq = uniqFromSupply us
 601          loc = nameSrcSpan (idName id)
 602          name = mkInternalName uniq occ loc
 603          ty = idType id
 604          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
 605      return new_id
 606
 607 rttiEnvironment :: HscEnv -> IO HscEnv
 608 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
 609    let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 610        incompletelyTypedIds =
 611            [id | id <- tmp_ids
 612                , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
 613                               , isSkolemTyVar v]
 614                , (occNameFS.nameOccName.idName) id /= result_fs]
 615    tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
 616           -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
 617
 618    improvs <- sequence [improveRTTIType hsc_env ty ty'
 619                  | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
 620    let ic' = foldr (\mb_subst ic' ->
 621                         maybe (WARN(True, text ("RTTI failed to calculate the "
 622                                            ++  "improvement for a type")) ic')
 623                               (substInteractiveContext ic' . skolemiseSubst)
 624                               mb_subst)
 625                    ic
 626                    improvs
 627    return hsc_env{hsc_IC=ic'}
 628
 629 skolemiseSubst :: TvSubst -> TvSubst
 630 skolemiseSubst subst = subst `setTvSubstEnv`
 631                         mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
 632
 633 skolemiseTy :: Type -> (Type, TyVarSet)
 634 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 635   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 636         subst         = mkTvSubst emptyInScopeSet env
 637         tyvars        = varSetElems (tyVarsOfType ty)
 638         new_tyvars    = map skolemiseTyVar tyvars
 639         new_tyvar_tys = map mkTyVarTy new_tyvars
 640
 641 skolemiseTyVar :: TyVar -> TyVar
 642 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 643                                  (SkolemTv RuntimeUnkSkol)
 644
 645 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 646 getIdValFromApStack apStack (I# stackDepth) = do
 647    case getApStackVal# apStack (stackDepth +# 1#) of
 648                                 -- The +1 is magic!  I don't know where it comes
 649                                 -- from, but this makes things line up.  --SDM
 650         (# ok, result #) ->
 651             case ok of
 652               0# -> return Nothing -- AP_STACK not found
 653               _  -> return (Just (unsafeCoerce# result))
 654
 655 pushResume :: HscEnv -> Resume -> HscEnv
 656 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 657   where
 658         ictxt0 = hsc_IC hsc_env
 659         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 660
 661 -- -----------------------------------------------------------------------------
 662 -- Abandoning a resume context
 663
 664 abandon :: Session -> IO Bool
 665 abandon (Session ref) = do
 666    hsc_env <- readIORef ref
 667    let ic = hsc_IC hsc_env
 668        resume = ic_resume ic
 669    case resume of
 670       []    -> return False
 671       r:rs  -> do
 672          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
 673          abandon_ r
 674          return True
 675
 676 abandonAll :: Session -> IO Bool
 677 abandonAll (Session ref) = do
 678    hsc_env <- readIORef ref
 679    let ic = hsc_IC hsc_env
 680        resume = ic_resume ic
 681    case resume of
 682       []  -> return False
 683       rs  -> do
 684          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
 685          mapM_ abandon_ rs
 686          return True
 687
 688 -- when abandoning a computation we have to
 689 --      (a) kill the thread with an async exception, so that the
 690 --          computation itself is stopped, and
 691 --      (b) fill in the MVar.  This step is necessary because any
 692 --          thunks that were under evaluation will now be updated
 693 --          with the partial computation, which still ends in takeMVar,
 694 --          so any attempt to evaluate one of these thunks will block
 695 --          unless we fill in the MVar.
 696 --  See test break010.
 697 abandon_ :: Resume -> IO ()
 698 abandon_ r = do
 699   killThread (resumeThreadId r)
 700   putMVar (resumeBreakMVar r) ()
 701
 702 -- -----------------------------------------------------------------------------
 703 -- Bounded list, optimised for repeated cons
 704
 705 data BoundedList a = BL
 706                         {-# UNPACK #-} !Int  -- length
 707                         {-# UNPACK #-} !Int  -- bound
 708                         [a] -- left
 709                         [a] -- right,  list is (left ++ reverse right)
 710
 711 nilBL :: Int -> BoundedList a
 712 nilBL bound = BL 0 bound [] []
 713
 714 consBL :: a -> BoundedList a -> BoundedList a
 715 consBL a (BL len bound left right)
 716   | len < bound = BL (len+1) bound (a:left) right
 717   | null right  = BL len     bound [a]      $! tail (reverse left)
 718   | otherwise   = BL len     bound (a:left) $! tail right
 719
 720 toListBL :: BoundedList a -> [a]
 721 toListBL (BL _ _ left right) = left ++ reverse right
 722
 723 fromListBL :: Int -> [a] -> BoundedList a
 724 fromListBL bound l = BL (length l) bound l []
 725
 726 -- lenBL (BL len _ _ _) = len
 727
 728 -- -----------------------------------------------------------------------------
 729 -- | Set the interactive evaluation context.
 730 --
 731 -- Setting the context doesn't throw away any bindings; the bindings
 732 -- we've built up in the InteractiveContext simply move to the new
 733 -- module.  They always shadow anything in scope in the current context.
 734 setContext :: Session
 735            -> [Module]  -- entire top level scope of these modules
 736            -> [Module]  -- exports only of these modules
 737            -> IO ()
 738 setContext (Session ref) toplev_mods export_mods = do
 739   hsc_env <- readIORef ref
 740   let old_ic  = hsc_IC     hsc_env
 741       hpt     = hsc_HPT    hsc_env
 742   --
 743   export_env  <- mkExportEnv hsc_env export_mods
 744   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
 745   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 746   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 747                                             ic_exports      = export_mods,
 748                                             ic_rn_gbl_env   = all_env }}
 749
 750 -- Make a GlobalRdrEnv based on the exports of the modules only.
 751 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 752 mkExportEnv hsc_env mods = do
 753   stuff <- mapM (getModuleExports hsc_env) mods
 754   let
 755         (_msgs, mb_name_sets) = unzip stuff
 756         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 757                | (Just avails, mod) <- zip mb_name_sets mods ]
 758   --
 759   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 760
 761 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 762 nameSetToGlobalRdrEnv names mod =
 763   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 764                  | name <- nameSetToList names ]
 765
 766 vanillaProv :: ModuleName -> Provenance
 767 -- We're building a GlobalRdrEnv as if the user imported
 768 -- all the specified modules into the global interactive module
 769 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 770   where
 771     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 772                          is_qual = False,
 773                          is_dloc = srcLocSpan interactiveSrcLoc }
 774
 775 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 776 mkTopLevEnv hpt modl
 777   = case lookupUFM hpt (moduleName modl) of
 778       Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
 779                                                 showSDoc (ppr modl)))
 780       Just details ->
 781          case mi_globals (hm_iface details) of
 782                 Nothing  ->
 783                    ghcError (ProgramError ("mkTopLevEnv: not interpreted "
 784                                                 ++ showSDoc (ppr modl)))
 785                 Just env -> return env
 786
 787 -- | Get the interactive evaluation context, consisting of a pair of the
 788 -- set of modules from which we take the full top-level scope, and the set
 789 -- of modules from which we take just the exports respectively.
 790 getContext :: Session -> IO ([Module],[Module])
 791 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 792                                 return (ic_toplev_scope ic, ic_exports ic))
 793
 794 -- | Returns 'True' if the specified module is interpreted, and hence has
 795 -- its full top-level scope available.
 796 moduleIsInterpreted :: Session -> Module -> IO Bool
 797 moduleIsInterpreted s modl = withSession s $ \h ->
 798  if modulePackageId modl /= thisPackage (hsc_dflags h)
 799         then return False
 800         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 801                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 802                 _not_a_home_module -> return False
 803
 804 -- | Looks up an identifier in the current interactive context (for :info)
 805 -- Filter the instances by the ones whose tycons (or clases resp)
 806 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 807 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 808 --      (see Trac #1581)
 809 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 810 getInfo s name
 811   = withSession s $ \hsc_env ->
 812     do mb_stuff <- tcRnGetInfo hsc_env name
 813        case mb_stuff of
 814          Nothing -> return Nothing
 815          Just (thing, fixity, ispecs) -> do
 816            let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
 817            return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
 818   where
 819     plausible rdr_env ispec     -- Dfun involving only names that are in ic_rn_glb_env
 820         = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
 821         where   -- A name is ok if it's in the rdr_env,
 822                 -- whether qualified or not
 823           ok n | n == name         = True       -- The one we looked for in the first place!
 824                | isBuiltInSyntax n = True
 825                | isExternalName n  = any ((== n) . gre_name)
 826                                          (lookupGRE_Name rdr_env n)
 827                | otherwise         = True
 828
 829 -- | Returns all names in scope in the current interactive context
 830 getNamesInScope :: Session -> IO [Name]
 831 getNamesInScope s = withSession s $ \hsc_env -> do
 832   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 833
 834 getRdrNamesInScope :: Session -> IO [RdrName]
 835 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
 836   let
 837       ic = hsc_IC hsc_env
 838       gbl_rdrenv = ic_rn_gbl_env ic
 839       ids = ic_tmp_ids ic
 840       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 841       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 842   --
 843   return (gbl_names ++ lcl_names)
 844
 845
 846 -- ToDo: move to RdrName
 847 greToRdrNames :: GlobalRdrElt -> [RdrName]
 848 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 849   = case prov of
 850      LocalDef -> [unqual]
 851      Imported specs -> concat (map do_spec (map is_decl specs))
 852   where
 853     occ = nameOccName name
 854     unqual = Unqual occ
 855     do_spec decl_spec
 856         | is_qual decl_spec = [qual]
 857         | otherwise         = [unqual,qual]
 858         where qual = Qual (is_as decl_spec) occ
 859
 860 -- | Parses a string as an identifier, and returns the list of 'Name's that
 861 -- the identifier can refer to in the current interactive context.
 862 parseName :: Session -> String -> IO [Name]
 863 parseName s str = withSession s $ \hsc_env -> do
 864    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 865    case maybe_rdr_name of
 866         Nothing -> return []
 867         Just (L _ rdr_name) -> do
 868             mb_names <- tcRnLookupRdrName hsc_env rdr_name
 869             case mb_names of
 870                 Nothing -> return []
 871                 Just ns -> return ns
 872                 -- ToDo: should return error messages
 873
 874 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 875 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 876 lookupName :: Session -> Name -> IO (Maybe TyThing)
 877 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
 878
 879 -- -----------------------------------------------------------------------------
 880 -- Getting the type of an expression
 881
 882 -- | Get the type of an expression
 883 exprType :: Session -> String -> IO (Maybe Type)
 884 exprType s expr = withSession s $ \hsc_env -> do
 885    maybe_stuff <- hscTcExpr hsc_env expr
 886    case maybe_stuff of
 887         Nothing -> return Nothing
 888         Just ty -> return (Just tidy_ty)
 889              where
 890                 tidy_ty = tidyType emptyTidyEnv ty
 891
 892 -- -----------------------------------------------------------------------------
 893 -- Getting the kind of a type
 894
 895 -- | Get the kind of a  type
 896 typeKind  :: Session -> String -> IO (Maybe Kind)
 897 typeKind s str = withSession s $ \hsc_env -> do
 898    maybe_stuff <- hscKcType hsc_env str
 899    case maybe_stuff of
 900         Nothing -> return Nothing
 901         Just kind -> return (Just kind)
 902
 903 -----------------------------------------------------------------------------
 904 -- cmCompileExpr: compile an expression and deliver an HValue
 905
 906 compileExpr :: Session -> String -> IO (Maybe HValue)
 907 compileExpr s expr = withSession s $ \hsc_env -> do
 908   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 909   case maybe_stuff of
 910         Nothing -> return Nothing
 911         Just (ids, hval) -> do
 912                         -- Run it!
 913                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
 914
 915                 case (ids,hvals) of
 916                   ([_],[hv]) -> return (Just hv)
 917                   _          -> panic "compileExpr"
 918
 919 -- -----------------------------------------------------------------------------
 920 -- Compile an expression into a dynamic
 921
 922 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
 923 dynCompileExpr ses expr = do
 924     (full,exports) <- getContext ses
 925     setContext ses full $
 926         (mkModule
 927             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 928         ):exports
 929     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 930     res <- withSession ses (flip hscStmt stmt)
 931     setContext ses full exports
 932     case res of
 933         Nothing -> return Nothing
 934         Just (ids, hvals) -> do
 935             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
 936             case (ids,vals) of
 937                 (_:[], v:[])    -> return (Just v)
 938                 _               -> panic "dynCompileExpr"
 939
 940 -----------------------------------------------------------------------------
 941 -- show a module and it's source/object filenames
 942
 943 showModule :: Session -> ModSummary -> IO String
 944 showModule s mod_summary = withSession s $                        \hsc_env ->
 945                            isModuleInterpreted s mod_summary >>=  \interpreted ->
 946                            return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 947
 948 isModuleInterpreted :: Session -> ModSummary -> IO Bool
 949 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 950   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 951         Nothing       -> panic "missing linkable"
 952         Just mod_info -> return (not obj_linkable)
 953                       where
 954                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 955
 956 ----------------------------------------------------------------------------
 957 -- RTTI primitives
 958
 959 obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
 960 obtainTerm1 hsc_env force mb_ty x =
 961               cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
 962
 963 obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
 964 obtainTermB hsc_env bound force id =  do
 965               hv <- Linker.getHValue hsc_env (varName id)
 966               cvObtainTerm hsc_env bound force (Just$ idType id) hv
 967
 968 obtainTerm :: HscEnv -> Bool -> Id -> IO Term
 969 obtainTerm hsc_env force id =  do
 970               hv <- Linker.getHValue hsc_env (varName id)
 971               cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
 972
 973 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 974 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 975 reconstructType hsc_env bound id = do
 976               hv <- Linker.getHValue hsc_env (varName id)
 977               cvReconstructType hsc_env bound (Just$ idType id) hv
 978 #endif /* GHCI */