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   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
 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; we can't bind these at the prompt
 576    let pointers = filter (\(id,_) -> isPointer id) vars
 577        isPointer id | PtrRep <- idPrimRep id = True
 578                     | otherwise              = False
 579
 580    let (ids, offsets) = unzip pointers
 581
 582    -- It might be that getIdValFromApStack fails, because the AP_STACK
 583    -- has been accidentally evaluated, or something else has gone wrong.
 584    -- So that we don't fall over in a heap when this happens, just don't
 585    -- bind any free variables instead, and we emit a warning.
 586    mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
 587    let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
 588    when (any isNothing mb_hValues) $
 589       debugTraceMsg (hsc_dflags hsc_env) 1 $
 590           text "Warning: _result has been evaluated, some bindings have been lost"
 591
 592    new_ids <- zipWithM mkNewId occs filtered_ids
 593    let names = map idName new_ids
 594
 595    -- make an Id for _result.  We use the Unique of the FastString "_result";
 596    -- we don't care about uniqueness here, because there will only be one
 597    -- _result in scope at any time.
 598    let result_name = mkInternalName (getUnique result_fs)
 599                           (mkVarOccFS result_fs) span
 600        result_id   = Id.mkVanillaGlobal result_name result_ty
 601
 602    -- for each Id we're about to bind in the local envt:
 603    --    - tidy the type variables
 604    --    - globalise the Id (Ids are supposed to be Global, apparently).
 605    --
 606    let result_ok = isPointer result_id
 607                     && not (isUnboxedTupleType (idType result_id))
 608
 609        all_ids | result_ok = result_id : new_ids
 610                | otherwise = new_ids
 611        id_tys = map idType all_ids
 612        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 613        final_ids = zipWith setIdType all_ids tidy_tys
 614        ictxt0 = hsc_IC hsc_env
 615        ictxt1 = extendInteractiveContext ictxt0 final_ids
 616
 617    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 618    when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 619    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
 620    return (hsc_env1, if result_ok then result_name:names else names, span)
 621   where
 622    mkNewId :: OccName -> Id -> IO Id
 623    mkNewId occ id = do
 624      us <- mkSplitUniqSupply 'I'
 625         -- we need a fresh Unique for each Id we bind, because the linker
 626         -- state is single-threaded and otherwise we'd spam old bindings
 627         -- whenever we stop at a breakpoint.  The InteractveContext is properly
 628         -- saved/restored, but not the linker state.  See #1743, test break026.
 629      let
 630          uniq = uniqFromSupply us
 631          loc = nameSrcSpan (idName id)
 632          name = mkInternalName uniq occ loc
 633          ty = idType id
 634          new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
 635      return new_id
 636
 637 rttiEnvironment :: HscEnv -> IO HscEnv
 638 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
 639    let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 640        incompletelyTypedIds =
 641            [id | id <- tmp_ids
 642                , not $ noSkolems id
 643                , (occNameFS.nameOccName.idName) id /= result_fs]
 644    hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
 645    return hsc_env'
 646     where
 647      noSkolems = isEmptyVarSet . tyVarsOfType . idType
 648      improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
 649       let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 650           Just id = find (\i -> idName i == name) tmp_ids
 651       if noSkolems id
 652          then return hsc_env
 653          else do
 654            mb_new_ty <- reconstructType hsc_env 10 id
 655            let old_ty = idType id
 656            case mb_new_ty of
 657              Nothing -> return hsc_env
 658              Just new_ty -> do
 659               case improveRTTIType hsc_env old_ty new_ty of
 660                Nothing -> return $
 661                         WARN(True, text (":print failed to calculate the "
 662                                            ++ "improvement for a type")) hsc_env
 663                Just subst -> do
 664                  when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
 665                       printForUser stderr alwaysQualify $
 666                       fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
 667
 668                  let ic' = extendInteractiveContext
 669                                (substInteractiveContext ic subst) []
 670                  return hsc_env{hsc_IC=ic'}
 671
 672 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 673 getIdValFromApStack apStack (I# stackDepth) = do
 674    case getApStackVal# apStack (stackDepth +# 1#) of
 675                                 -- The +1 is magic!  I don't know where it comes
 676                                 -- from, but this makes things line up.  --SDM
 677         (# ok, result #) ->
 678             case ok of
 679               0# -> return Nothing -- AP_STACK not found
 680               _  -> return (Just (unsafeCoerce# result))
 681
 682 pushResume :: HscEnv -> Resume -> HscEnv
 683 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 684   where
 685         ictxt0 = hsc_IC hsc_env
 686         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 687
 688 -- -----------------------------------------------------------------------------
 689 -- Abandoning a resume context
 690
 691 abandon :: GhcMonad m => m Bool
 692 abandon = do
 693    hsc_env <- getSession
 694    let ic = hsc_IC hsc_env
 695        resume = ic_resume ic
 696    case resume of
 697       []    -> return False
 698       r:rs  -> do
 699          modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
 700          liftIO $ abandon_ r
 701          return True
 702
 703 abandonAll :: GhcMonad m => m Bool
 704 abandonAll = 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       rs  -> do
 711          modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
 712          liftIO $ mapM_ abandon_ rs
 713          return True
 714
 715 -- when abandoning a computation we have to
 716 --      (a) kill the thread with an async exception, so that the
 717 --          computation itself is stopped, and
 718 --      (b) fill in the MVar.  This step is necessary because any
 719 --          thunks that were under evaluation will now be updated
 720 --          with the partial computation, which still ends in takeMVar,
 721 --          so any attempt to evaluate one of these thunks will block
 722 --          unless we fill in the MVar.
 723 --  See test break010.
 724 abandon_ :: Resume -> IO ()
 725 abandon_ r = do
 726   killThread (resumeThreadId r)
 727   putMVar (resumeBreakMVar r) ()
 728
 729 -- -----------------------------------------------------------------------------
 730 -- Bounded list, optimised for repeated cons
 731
 732 data BoundedList a = BL
 733                         {-# UNPACK #-} !Int  -- length
 734                         {-# UNPACK #-} !Int  -- bound
 735                         [a] -- left
 736                         [a] -- right,  list is (left ++ reverse right)
 737
 738 nilBL :: Int -> BoundedList a
 739 nilBL bound = BL 0 bound [] []
 740
 741 consBL :: a -> BoundedList a -> BoundedList a
 742 consBL a (BL len bound left right)
 743   | len < bound = BL (len+1) bound (a:left) right
 744   | null right  = BL len     bound [a]      $! tail (reverse left)
 745   | otherwise   = BL len     bound (a:left) $! tail right
 746
 747 toListBL :: BoundedList a -> [a]
 748 toListBL (BL _ _ left right) = left ++ reverse right
 749
 750 fromListBL :: Int -> [a] -> BoundedList a
 751 fromListBL bound l = BL (length l) bound l []
 752
 753 -- lenBL (BL len _ _ _) = len
 754
 755 -- -----------------------------------------------------------------------------
 756 -- | Set the interactive evaluation context.
 757 --
 758 -- Setting the context doesn't throw away any bindings; the bindings
 759 -- we've built up in the InteractiveContext simply move to the new
 760 -- module.  They always shadow anything in scope in the current context.
 761 setContext :: GhcMonad m =>
 762         [Module]        -- ^ entire top level scope of these modules
 763         -> [(Module, Maybe (ImportDecl RdrName))]       -- ^ exports of these modules
 764         -> m ()
 765 setContext toplev_mods other_mods = do
 766     hsc_env <- getSession
 767     let old_ic  = hsc_IC     hsc_env
 768         hpt     = hsc_HPT    hsc_env
 769         (decls,mods)   = partition (isJust . snd) other_mods -- time for tracing
 770         export_mods = map fst mods
 771         imprt_decls = map noLoc (catMaybes (map snd decls))
 772     --
 773     export_env  <- liftIO $ mkExportEnv hsc_env export_mods
 774     import_env  <-
 775         if null imprt_decls then return emptyGlobalRdrEnv else do
 776             let this_mod | null toplev_mods = pRELUDE
 777                          | otherwise        = head toplev_mods
 778             liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls
 779     toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
 780     let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
 781     modifySession $ \_ ->
 782         hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 783                          ic_exports      = other_mods,
 784                          ic_rn_gbl_env   = all_env }}
 785
 786 -- Make a GlobalRdrEnv based on the exports of the modules only.
 787 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 788 mkExportEnv hsc_env mods
 789   = do { stuff <- mapM (getModuleExports hsc_env) mods
 790        ; let (_msgs, mb_name_sets) = unzip stuff
 791              envs = [ availsToGlobalRdrEnv (moduleName mod) avails
 792                     | (Just avails, mod) <- zip mb_name_sets mods ]
 793        ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }
 794
 795 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
 796 availsToGlobalRdrEnv mod_name avails
 797   = mkGlobalRdrEnv (gresFromAvails imp_prov avails)
 798   where
 799       -- We're building a GlobalRdrEnv as if the user imported
 800       -- all the specified modules into the global interactive module
 801     imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 802     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 803                          is_qual = False,
 804                          is_dloc = srcLocSpan interactiveSrcLoc }
 805
 806 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 807 mkTopLevEnv hpt modl
 808   = case lookupUFM hpt (moduleName modl) of
 809       Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
 810                                                 showSDoc (ppr modl)))
 811       Just details ->
 812          case mi_globals (hm_iface details) of
 813                 Nothing  ->
 814                    ghcError (ProgramError ("mkTopLevEnv: not interpreted "
 815                                                 ++ showSDoc (ppr modl)))
 816                 Just env -> return env
 817
 818 -- | Get the interactive evaluation context, consisting of a pair of the
 819 -- set of modules from which we take the full top-level scope, and the set
 820 -- of modules from which we take just the exports respectively.
 821 getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))])
 822 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
 823                return (ic_toplev_scope ic, ic_exports ic)
 824
 825 -- | Returns @True@ if the specified module is interpreted, and hence has
 826 -- its full top-level scope available.
 827 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
 828 moduleIsInterpreted modl = withSession $ \h ->
 829  if modulePackageId modl /= thisPackage (hsc_dflags h)
 830         then return False
 831         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 832                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 833                 _not_a_home_module -> return False
 834
 835 -- | Looks up an identifier in the current interactive context (for :info)
 836 -- Filter the instances by the ones whose tycons (or clases resp)
 837 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 838 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 839 --      (see Trac #1581)
 840 getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
 841 getInfo name
 842   = withSession $ \hsc_env ->
 843     do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
 844        case mb_stuff of
 845          Nothing -> return Nothing
 846          Just (thing, fixity, ispecs) -> do
 847            let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
 848            return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
 849   where
 850     plausible rdr_env ispec     -- Dfun involving only names that are in ic_rn_glb_env
 851         = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
 852         where   -- A name is ok if it's in the rdr_env,
 853                 -- whether qualified or not
 854           ok n | n == name         = True       -- The one we looked for in the first place!
 855                | isBuiltInSyntax n = True
 856                | isExternalName n  = any ((== n) . gre_name)
 857                                          (lookupGRE_Name rdr_env n)
 858                | otherwise         = True
 859
 860 -- | Returns all names in scope in the current interactive context
 861 getNamesInScope :: GhcMonad m => m [Name]
 862 getNamesInScope = withSession $ \hsc_env -> do
 863   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 864
 865 getRdrNamesInScope :: GhcMonad m => m [RdrName]
 866 getRdrNamesInScope = withSession $ \hsc_env -> do
 867   let
 868       ic = hsc_IC hsc_env
 869       gbl_rdrenv = ic_rn_gbl_env ic
 870       ids = ic_tmp_ids ic
 871       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 872       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 873   --
 874   return (gbl_names ++ lcl_names)
 875
 876
 877 -- ToDo: move to RdrName
 878 greToRdrNames :: GlobalRdrElt -> [RdrName]
 879 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 880   = case prov of
 881      LocalDef -> [unqual]
 882      Imported specs -> concat (map do_spec (map is_decl specs))
 883   where
 884     occ = nameOccName name
 885     unqual = Unqual occ
 886     do_spec decl_spec
 887         | is_qual decl_spec = [qual]
 888         | otherwise         = [unqual,qual]
 889         where qual = Qual (is_as decl_spec) occ
 890
 891 -- | Parses a string as an identifier, and returns the list of 'Name's that
 892 -- the identifier can refer to in the current interactive context.
 893 parseName :: GhcMonad m => String -> m [Name]
 894 parseName str = withSession $ \hsc_env -> do
 895    (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str
 896    liftIO $ hscTcRnLookupRdrName hsc_env rdr_name
 897
 898 -- -----------------------------------------------------------------------------
 899 -- Getting the type of an expression
 900
 901 -- | Get the type of an expression
 902 exprType :: GhcMonad m => String -> m Type
 903 exprType expr = withSession $ \hsc_env -> do
 904    ty <- liftIO $ hscTcExpr hsc_env expr
 905    return $ tidyType emptyTidyEnv ty
 906
 907 -- -----------------------------------------------------------------------------
 908 -- Getting the kind of a type
 909
 910 -- | Get the kind of a  type
 911 typeKind  :: GhcMonad m => String -> m Kind
 912 typeKind str = withSession $ \hsc_env -> do
 913    liftIO $ hscKcType hsc_env str
 914
 915 -----------------------------------------------------------------------------
 916 -- cmCompileExpr: compile an expression and deliver an HValue
 917
 918 compileExpr :: GhcMonad m => String -> m HValue
 919 compileExpr expr = withSession $ \hsc_env -> do
 920   Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 921                  -- Run it!
 922   hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
 923
 924   case (ids,hvals) of
 925     ([_],[hv]) -> return hv
 926     _        -> panic "compileExpr"
 927
 928 -- -----------------------------------------------------------------------------
 929 -- Compile an expression into a dynamic
 930
 931 dynCompileExpr :: GhcMonad m => String -> m Dynamic
 932 dynCompileExpr expr = do
 933     (full,exports) <- getContext
 934     setContext full $
 935         (mkModule
 936             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 937         ,Nothing):exports
 938     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 939     Just (ids, hvals) <- withSession $ \hsc_env ->
 940                            liftIO $ hscStmt hsc_env stmt
 941     setContext full exports
 942     vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
 943     case (ids,vals) of
 944         (_:[], v:[])    -> return v
 945         _               -> panic "dynCompileExpr"
 946
 947 -----------------------------------------------------------------------------
 948 -- show a module and it's source/object filenames
 949
 950 showModule :: GhcMonad m => ModSummary -> m String
 951 showModule mod_summary =
 952     withSession $ \hsc_env -> do
 953         interpreted <- isModuleInterpreted mod_summary
 954         return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 955
 956 isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
 957 isModuleInterpreted mod_summary = withSession $ \hsc_env ->
 958   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 959         Nothing       -> panic "missing linkable"
 960         Just mod_info -> return (not obj_linkable)
 961                       where
 962                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 963
 964 ----------------------------------------------------------------------------
 965 -- RTTI primitives
 966
 967 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
 968 obtainTermFromVal hsc_env bound force ty x =
 969               cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
 970
 971 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
 972 obtainTermFromId hsc_env bound force id =  do
 973               hv <- Linker.getHValue hsc_env (varName id)
 974               cvObtainTerm hsc_env bound force (idType id) hv
 975
 976 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 977 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 978 reconstructType hsc_env bound id = do
 979               hv <- Linker.getHValue hsc_env (varName id)
 980               cvReconstructType hsc_env bound (idType id) hv
 981
 982 #endif /* GHCI */
 983