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