compiler/main/InteractiveEval.hs

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