compiler/main/InteractiveEval.hs

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