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