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