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 tid $ do
 282                            putMVar breakMVar ()  -- awaken the stopped thread
 283                            takeMVar statusMVar   -- and wait for the result
 284              traceRunStatus expr ref bindings final_ids
 285                             breakMVar statusMVar status history'
 286      _other ->
 287         handle_normally
 288   where
 289         handle_normally = handleRunStatus expr ref bindings final_ids
 290                                           breakMVar statusMVar status history
 291
 292
 293 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
 294 isBreakEnabled hsc_env inf =
 295    case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
 296        Just hmi -> do
 297          w <- getBreak (modBreaks_flags (getModBreaks hmi))
 298                        (breakInfo_number inf)
 299          case w of Just n -> return (n /= 0); _other -> return False
 300        _ ->
 301          return False
 302
 303
 304 foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt
 305 foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt
 306
 307 setStepFlag   = poke stepFlag 1
 308 resetStepFlag = poke stepFlag 0
 309
 310 -- this points to the IO action that is executed when a breakpoint is hit
 311 foreign import ccall "&rts_breakpoint_io_action"
 312    breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
 313
 314 -- When running a computation, we redirect ^C exceptions to the running
 315 -- thread.  ToDo: we might want a way to continue even if the target
 316 -- thread doesn't die when it receives the exception... "this thread
 317 -- is not responding".
 318 --
 319 -- Careful here: there may be ^C exceptions flying around, so we start
 320 -- the new thread blocked (forkIO inherits block from the parent,
 321 -- #1048), and unblock only while we execute the user's code.  We
 322 -- can't afford to lose the final putMVar, otherwise deadlock
 323 -- ensues. (#1583, #1922, #1946)
 324 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
 325 sandboxIO dflags statusMVar thing =
 326    block $ do  -- fork starts blocked
 327      id <- forkIO $ do res <- Exception.try (unblock $ rethrow dflags thing)
 328                        putMVar statusMVar (Complete res) -- empty: can't block
 329      withInterruptsSentTo id $ takeMVar statusMVar
 330
 331
 332 -- We want to turn ^C into a break when -fbreak-on-exception is on,
 333 -- but it's an async exception and we only break for sync exceptions.
 334 -- Idea: if we catch and re-throw it, then the re-throw will trigger
 335 -- a break.  Great - but we don't want to re-throw all exceptions, because
 336 -- then we'll get a double break for ordinary sync exceptions (you'd have
 337 -- to :continue twice, which looks strange).  So if the exception is
 338 -- not "Interrupted", we unset the exception flag before throwing.
 339 --
 340 rethrow :: DynFlags -> IO a -> IO a
 341 rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
 342                 case e of
 343                    -- If -fbreak-on-error, we break unconditionally,
 344                    --  but with care of not breaking twice
 345                    _ | dopt Opt_BreakOnError dflags &&
 346                        not(dopt Opt_BreakOnException dflags)
 347                         -> poke exceptionFlag 1
 348
 349                    -- If it is an "Interrupted" exception, we allow
 350                    --  a possible break by way of -fbreak-on-exception
 351                    DynException d | Just Interrupted <- fromDynamic d
 352                         -> return ()
 353
 354                    -- In any other case, we don't want to break
 355                    _    -> poke exceptionFlag 0
 356
 357                 Exception.throwIO e
 358
 359
 360 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 361 withInterruptsSentTo thread get_result = do
 362   bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
 363           (\_ -> modifyMVar_ interruptTargetThread (return.tail))
 364           (\_ -> get_result)
 365
 366 -- This function sets up the interpreter for catching breakpoints, and
 367 -- resets everything when the computation has stopped running.  This
 368 -- is a not-very-good way to ensure that only the interactive
 369 -- evaluation should generate breakpoints.
 370 withBreakAction step dflags breakMVar statusMVar io
 371  = bracket setBreakAction resetBreakAction (\_ -> io)
 372  where
 373    setBreakAction = do
 374      stablePtr <- newStablePtr onBreak
 375      poke breakPointIOAction stablePtr
 376      when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
 377      when step $ setStepFlag
 378      return stablePtr
 379         -- Breaking on exceptions is not enabled by default, since it
 380         -- might be a bit surprising.  The exception flag is turned off
 381         -- as soon as it is hit, or in resetBreakAction below.
 382
 383    onBreak is_exception info apStack = do
 384      tid <- myThreadId
 385      putMVar statusMVar (Break is_exception apStack info tid)
 386      takeMVar breakMVar
 387
 388    resetBreakAction stablePtr = do
 389      poke breakPointIOAction noBreakStablePtr
 390      poke exceptionFlag 0
 391      resetStepFlag
 392      freeStablePtr stablePtr
 393
 394 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 395
 396 noBreakAction False info apStack = putStrLn "*** Ignoring breakpoint"
 397 noBreakAction True  info apStack = return () -- exception: just continue
 398
 399 resume :: Session -> SingleStep -> IO RunResult
 400 resume (Session ref) step
 401  = do
 402    hsc_env <- readIORef ref
 403    let ic = hsc_IC hsc_env
 404        resume = ic_resume ic
 405
 406    case resume of
 407      [] -> throwDyn (ProgramError "not stopped at a breakpoint")
 408      (r:rs) -> do
 409         -- unbind the temporary locals by restoring the TypeEnv from
 410         -- before the breakpoint, and drop this Resume from the
 411         -- InteractiveContext.
 412         let (resume_tmp_ids, resume_tyvars) = resumeBindings r
 413             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
 414                        ic_tyvars   = resume_tyvars,
 415                        ic_resume   = rs }
 416         writeIORef ref hsc_env{ hsc_IC = ic' }
 417
 418         -- remove any bindings created since the breakpoint from the
 419         -- linker's environment
 420         let new_names = map idName (filter (`notElem` resume_tmp_ids)
 421                                            (ic_tmp_ids ic))
 422         Linker.deleteFromLinkEnv new_names
 423
 424         when (isStep step) $ setStepFlag
 425         case r of
 426           Resume expr tid breakMVar statusMVar bindings
 427               final_ids apStack info _ hist _ -> do
 428                 withBreakAction (isStep step) (hsc_dflags hsc_env)
 429                                         breakMVar statusMVar $ do
 430                 status <- withInterruptsSentTo tid $ do
 431                              putMVar breakMVar ()
 432                                       -- this awakens the stopped thread...
 433                              takeMVar statusMVar
 434                                       -- and wait for the result
 435                 let hist' =
 436                      case info of
 437                        Nothing -> fromListBL 50 hist
 438                        Just i -> mkHistory hsc_env apStack i `consBL`
 439                                                         fromListBL 50 hist
 440                 case step of
 441                   RunAndLogSteps ->
 442                         traceRunStatus expr ref bindings final_ids
 443                                        breakMVar statusMVar status hist'
 444                   _other ->
 445                         handleRunStatus expr ref bindings final_ids
 446                                         breakMVar statusMVar status hist'
 447
 448 back :: Session -> IO ([Name], Int, SrcSpan)
 449 back  = moveHist (+1)
 450
 451 forward :: Session -> IO ([Name], Int, SrcSpan)
 452 forward  = moveHist (subtract 1)
 453
 454 moveHist fn (Session ref) = do
 455   hsc_env <- readIORef ref
 456   case ic_resume (hsc_IC hsc_env) of
 457      [] -> throwDyn (ProgramError "not stopped at a breakpoint")
 458      (r:rs) -> do
 459         let ix = resumeHistoryIx r
 460             history = resumeHistory r
 461             new_ix = fn ix
 462         --
 463         when (new_ix > length history) $
 464            throwDyn (ProgramError "no more logged breakpoints")
 465         when (new_ix < 0) $
 466            throwDyn (ProgramError "already at the beginning of the history")
 467
 468         let
 469           update_ic apStack mb_info = do
 470             (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
 471                                                 apStack mb_info
 472             let ic = hsc_IC hsc_env1
 473                 r' = r { resumeHistoryIx = new_ix }
 474                 ic' = ic { ic_resume = r':rs }
 475
 476             writeIORef ref hsc_env1{ hsc_IC = ic' }
 477
 478             return (names, new_ix, span)
 479
 480         -- careful: we want apStack to be the AP_STACK itself, not a thunk
 481         -- around it, hence the cases are carefully constructed below to
 482         -- make this the case.  ToDo: this is v. fragile, do something better.
 483         if new_ix == 0
 484            then case r of
 485                    Resume { resumeApStack = apStack,
 486                             resumeBreakInfo = mb_info } ->
 487                           update_ic apStack mb_info
 488            else case history !! (new_ix - 1) of
 489                    History apStack info _ ->
 490                           update_ic apStack (Just info)
 491
 492 -- -----------------------------------------------------------------------------
 493 -- After stopping at a breakpoint, add free variables to the environment
 494 result_fs = FSLIT("_result")
 495
 496 bindLocalsAtBreakpoint
 497         :: HscEnv
 498         -> HValue
 499         -> Maybe BreakInfo
 500         -> IO (HscEnv, [Name], SrcSpan)
 501
 502 -- Nothing case: we stopped when an exception was raised, not at a
 503 -- breakpoint.  We have no location information or local variables to
 504 -- bind, all we can do is bind a local variable to the exception
 505 -- value.
 506 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 507    let exn_fs    = FSLIT("_exception")
 508        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
 509        e_fs      = FSLIT("e")
 510        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
 511        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
 512        exn_id    = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
 513                                 vanillaIdInfo
 514        new_tyvars = unitVarSet e_tyvar
 515
 516        ictxt0 = hsc_IC hsc_env
 517        ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
 518
 519        span = mkGeneralSrcSpan FSLIT("<exception thrown>")
 520    --
 521    Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
 522    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 523
 524 -- Just case: we stopped at a breakpoint, we have information about the location
 525 -- of the breakpoint and the free variables of the expression.
 526 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 527
 528    let
 529        mod_name  = moduleName (breakInfo_module info)
 530        hmi       = expectJust "bindLocalsAtBreakpoint" $
 531                         lookupUFM (hsc_HPT hsc_env) mod_name
 532        breaks    = getModBreaks hmi
 533        index     = breakInfo_number info
 534        vars      = breakInfo_vars info
 535        result_ty = breakInfo_resty info
 536        occs      = modBreaks_vars breaks ! index
 537        span      = modBreaks_locs breaks ! index
 538
 539    -- filter out any unboxed ids; we can't bind these at the prompt
 540    let pointers = filter (\(id,_) -> isPointer id) vars
 541        isPointer id | PtrRep <- idPrimRep id = True
 542                     | otherwise              = False
 543
 544    let (ids, offsets) = unzip pointers
 545
 546    -- It might be that getIdValFromApStack fails, because the AP_STACK
 547    -- has been accidentally evaluated, or something else has gone wrong.
 548    -- So that we don't fall over in a heap when this happens, just don't
 549    -- bind any free variables instead, and we emit a warning.
 550    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
 551    let filtered_ids = [ id | (id, Just hv) <- zip ids mb_hValues ]
 552    when (any isNothing mb_hValues) $
 553       debugTraceMsg (hsc_dflags hsc_env) 1 $
 554           text "Warning: _result has been evaluated, some bindings have been lost"
 555
 556    new_ids <- zipWithM mkNewId occs filtered_ids
 557    let names = map idName new_ids
 558
 559    -- make an Id for _result.  We use the Unique of the FastString "_result";
 560    -- we don't care about uniqueness here, because there will only be one
 561    -- _result in scope at any time.
 562    let result_name = mkInternalName (getUnique result_fs)
 563                           (mkVarOccFS result_fs) span
 564        result_id   = Id.mkGlobalId VanillaGlobal result_name result_ty
 565                                    vanillaIdInfo
 566
 567    -- for each Id we're about to bind in the local envt:
 568    --    - skolemise the type variables in its type, so they can't
 569    --      be randomly unified with other types.  These type variables
 570    --      can only be resolved by type reconstruction in RtClosureInspect
 571    --    - tidy the type variables
 572    --    - globalise the Id (Ids are supposed to be Global, apparently).
 573    --
 574    let all_ids | isPointer result_id = result_id : new_ids
 575                | otherwise           = new_ids
 576        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 577        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 578        new_tyvars = unionVarSets tyvarss
 579    let final_ids = zipWith setIdType all_ids tidy_tys
 580        ictxt0 = hsc_IC hsc_env
 581        ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 582    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 583    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 584    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
 585    return (hsc_env1, result_name:names, span)
 586   where
 587    mkNewId :: OccName -> Id -> IO Id
 588    mkNewId occ id = do
 589      us <- mkSplitUniqSupply 'I'
 590         -- we need a fresh Unique for each Id we bind, because the linker
 591         -- state is single-threaded and otherwise we'd spam old bindings
 592         -- whenever we stop at a breakpoint.  The InteractveContext is properly
 593         -- saved/restored, but not the linker state.  See #1743, test break026.
 594      let
 595          uniq = uniqFromSupply us
 596          loc = nameSrcSpan (idName id)
 597          name = mkInternalName uniq occ loc
 598          ty = idType id
 599          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
 600      return new_id
 601
 602 rttiEnvironment :: HscEnv -> IO HscEnv
 603 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
 604    let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 605        incompletelyTypedIds =
 606            [id | id <- tmp_ids
 607                , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
 608                               , isSkolemTyVar v]
 609                , (occNameFS.nameOccName.idName) id /= result_fs]
 610    tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
 611           -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
 612
 613    let substs = [computeRTTIsubst ty ty'
 614                  | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
 615        ic'    = foldr (flip substInteractiveContext) ic
 616                            (map skolemiseSubst substs)
 617    return hsc_env{hsc_IC=ic'}
 618
 619 skolemiseSubst subst = subst `setTvSubstEnv`
 620                         mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
 621
 622 skolemiseTy :: Type -> (Type, TyVarSet)
 623 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 624   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 625         subst         = mkTvSubst emptyInScopeSet env
 626         tyvars        = varSetElems (tyVarsOfType ty)
 627         new_tyvars    = map skolemiseTyVar tyvars
 628         new_tyvar_tys = map mkTyVarTy new_tyvars
 629
 630 skolemiseTyVar :: TyVar -> TyVar
 631 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 632                                  (SkolemTv RuntimeUnkSkol)
 633
 634 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 635 getIdValFromApStack apStack (I# stackDepth) = do
 636    case getApStackVal# apStack (stackDepth +# 1#) of
 637                                 -- The +1 is magic!  I don't know where it comes
 638                                 -- from, but this makes things line up.  --SDM
 639         (# ok, result #) ->
 640             case ok of
 641               0# -> return Nothing -- AP_STACK not found
 642               _  -> return (Just (unsafeCoerce# result))
 643
 644 pushResume :: HscEnv -> Resume -> HscEnv
 645 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 646   where
 647         ictxt0 = hsc_IC hsc_env
 648         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 649
 650 -- -----------------------------------------------------------------------------
 651 -- Abandoning a resume context
 652
 653 abandon :: Session -> IO Bool
 654 abandon (Session ref) = do
 655    hsc_env <- readIORef ref
 656    let ic = hsc_IC hsc_env
 657        resume = ic_resume ic
 658    case resume of
 659       []    -> return False
 660       r:rs  -> do
 661          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
 662          abandon_ r
 663          return True
 664
 665 abandonAll :: Session -> IO Bool
 666 abandonAll (Session ref) = do
 667    hsc_env <- readIORef ref
 668    let ic = hsc_IC hsc_env
 669        resume = ic_resume ic
 670    case resume of
 671       []  -> return False
 672       rs  -> do
 673          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
 674          mapM_ abandon_ rs
 675          return True
 676
 677 -- when abandoning a computation we have to
 678 --      (a) kill the thread with an async exception, so that the
 679 --          computation itself is stopped, and
 680 --      (b) fill in the MVar.  This step is necessary because any
 681 --          thunks that were under evaluation will now be updated
 682 --          with the partial computation, which still ends in takeMVar,
 683 --          so any attempt to evaluate one of these thunks will block
 684 --          unless we fill in the MVar.
 685 --  See test break010.
 686 abandon_ :: Resume -> IO ()
 687 abandon_ r = do
 688   killThread (resumeThreadId r)
 689   putMVar (resumeBreakMVar r) ()
 690
 691 -- -----------------------------------------------------------------------------
 692 -- Bounded list, optimised for repeated cons
 693
 694 data BoundedList a = BL
 695                         {-# UNPACK #-} !Int  -- length
 696                         {-# UNPACK #-} !Int  -- bound
 697                         [a] -- left
 698                         [a] -- right,  list is (left ++ reverse right)
 699
 700 nilBL :: Int -> BoundedList a
 701 nilBL bound = BL 0 bound [] []
 702
 703 consBL a (BL len bound left right)
 704   | len < bound = BL (len+1) bound (a:left) right
 705   | null right  = BL len     bound [a]      $! tail (reverse left)
 706   | otherwise   = BL len     bound (a:left) $! tail right
 707
 708 toListBL (BL _ _ left right) = left ++ reverse right
 709
 710 fromListBL bound l = BL (length l) bound l []
 711
 712 -- lenBL (BL len _ _ _) = len
 713
 714 -- -----------------------------------------------------------------------------
 715 -- | Set the interactive evaluation context.
 716 --
 717 -- Setting the context doesn't throw away any bindings; the bindings
 718 -- we've built up in the InteractiveContext simply move to the new
 719 -- module.  They always shadow anything in scope in the current context.
 720 setContext :: Session
 721            -> [Module]  -- entire top level scope of these modules
 722            -> [Module]  -- exports only of these modules
 723            -> IO ()
 724 setContext sess@(Session ref) toplev_mods export_mods = do
 725   hsc_env <- readIORef ref
 726   let old_ic  = hsc_IC     hsc_env
 727       hpt     = hsc_HPT    hsc_env
 728   --
 729   export_env  <- mkExportEnv hsc_env export_mods
 730   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
 731   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 732   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 733                                             ic_exports      = export_mods,
 734                                             ic_rn_gbl_env   = all_env }}
 735
 736 -- Make a GlobalRdrEnv based on the exports of the modules only.
 737 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 738 mkExportEnv hsc_env mods = do
 739   stuff <- mapM (getModuleExports hsc_env) mods
 740   let
 741         (_msgs, mb_name_sets) = unzip stuff
 742         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 743                | (Just avails, mod) <- zip mb_name_sets mods ]
 744   --
 745   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 746
 747 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 748 nameSetToGlobalRdrEnv names mod =
 749   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 750                  | name <- nameSetToList names ]
 751
 752 vanillaProv :: ModuleName -> Provenance
 753 -- We're building a GlobalRdrEnv as if the user imported
 754 -- all the specified modules into the global interactive module
 755 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 756   where
 757     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 758                          is_qual = False,
 759                          is_dloc = srcLocSpan interactiveSrcLoc }
 760
 761 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 762 mkTopLevEnv hpt modl
 763   = case lookupUFM hpt (moduleName modl) of
 764       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
 765                                                 showSDoc (ppr modl)))
 766       Just details ->
 767          case mi_globals (hm_iface details) of
 768                 Nothing  ->
 769                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
 770                                                 ++ showSDoc (ppr modl)))
 771                 Just env -> return env
 772
 773 -- | Get the interactive evaluation context, consisting of a pair of the
 774 -- set of modules from which we take the full top-level scope, and the set
 775 -- of modules from which we take just the exports respectively.
 776 getContext :: Session -> IO ([Module],[Module])
 777 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 778                                 return (ic_toplev_scope ic, ic_exports ic))
 779
 780 -- | Returns 'True' if the specified module is interpreted, and hence has
 781 -- its full top-level scope available.
 782 moduleIsInterpreted :: Session -> Module -> IO Bool
 783 moduleIsInterpreted s modl = withSession s $ \h ->
 784  if modulePackageId modl /= thisPackage (hsc_dflags h)
 785         then return False
 786         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 787                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 788                 _not_a_home_module -> return False
 789
 790 -- | Looks up an identifier in the current interactive context (for :info)
 791 -- Filter the instances by the ones whose tycons (or clases resp)
 792 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 793 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 794 --      (see Trac #1581)
 795 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 796 getInfo s name
 797   = withSession s $ \hsc_env ->
 798     do  { mb_stuff <- tcRnGetInfo hsc_env name
 799         ; case mb_stuff of
 800             Nothing -> return Nothing
 801             Just (thing, fixity, ispecs) -> do
 802         { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
 803         ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } }
 804   where
 805     plausible rdr_env ispec     -- Dfun involving only names that are in ic_rn_glb_env
 806         = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
 807         where   -- A name is ok if it's in the rdr_env,
 808                 -- whether qualified or not
 809           ok n | n == name         = True       -- The one we looked for in the first place!
 810                | isBuiltInSyntax n = True
 811                | isExternalName n  = any ((== n) . gre_name)
 812                                          (lookupGRE_Name rdr_env n)
 813                | otherwise         = True
 814
 815 -- | Returns all names in scope in the current interactive context
 816 getNamesInScope :: Session -> IO [Name]
 817 getNamesInScope s = withSession s $ \hsc_env -> do
 818   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 819
 820 getRdrNamesInScope :: Session -> IO [RdrName]
 821 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
 822   let
 823       ic = hsc_IC hsc_env
 824       gbl_rdrenv = ic_rn_gbl_env ic
 825       ids = ic_tmp_ids ic
 826       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 827       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 828   --
 829   return (gbl_names ++ lcl_names)
 830
 831
 832 -- ToDo: move to RdrName
 833 greToRdrNames :: GlobalRdrElt -> [RdrName]
 834 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 835   = case prov of
 836      LocalDef -> [unqual]
 837      Imported specs -> concat (map do_spec (map is_decl specs))
 838   where
 839     occ = nameOccName name
 840     unqual = Unqual occ
 841     do_spec decl_spec
 842         | is_qual decl_spec = [qual]
 843         | otherwise         = [unqual,qual]
 844         where qual = Qual (is_as decl_spec) occ
 845
 846 -- | Parses a string as an identifier, and returns the list of 'Name's that
 847 -- the identifier can refer to in the current interactive context.
 848 parseName :: Session -> String -> IO [Name]
 849 parseName s str = withSession s $ \hsc_env -> do
 850    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 851    case maybe_rdr_name of
 852         Nothing -> return []
 853         Just (L _ rdr_name) -> do
 854             mb_names <- tcRnLookupRdrName hsc_env rdr_name
 855             case mb_names of
 856                 Nothing -> return []
 857                 Just ns -> return ns
 858                 -- ToDo: should return error messages
 859
 860 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 861 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 862 lookupName :: Session -> Name -> IO (Maybe TyThing)
 863 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
 864
 865 -- -----------------------------------------------------------------------------
 866 -- Getting the type of an expression
 867
 868 -- | Get the type of an expression
 869 exprType :: Session -> String -> IO (Maybe Type)
 870 exprType s expr = withSession s $ \hsc_env -> do
 871    maybe_stuff <- hscTcExpr hsc_env expr
 872    case maybe_stuff of
 873         Nothing -> return Nothing
 874         Just ty -> return (Just tidy_ty)
 875              where
 876                 tidy_ty = tidyType emptyTidyEnv ty
 877
 878 -- -----------------------------------------------------------------------------
 879 -- Getting the kind of a type
 880
 881 -- | Get the kind of a  type
 882 typeKind  :: Session -> String -> IO (Maybe Kind)
 883 typeKind s str = withSession s $ \hsc_env -> do
 884    maybe_stuff <- hscKcType hsc_env str
 885    case maybe_stuff of
 886         Nothing -> return Nothing
 887         Just kind -> return (Just kind)
 888
 889 -----------------------------------------------------------------------------
 890 -- cmCompileExpr: compile an expression and deliver an HValue
 891
 892 compileExpr :: Session -> String -> IO (Maybe HValue)
 893 compileExpr s expr = withSession s $ \hsc_env -> do
 894   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 895   case maybe_stuff of
 896         Nothing -> return Nothing
 897         Just (ids, hval) -> do
 898                         -- Run it!
 899                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
 900
 901                 case (ids,hvals) of
 902                   ([n],[hv]) -> return (Just hv)
 903                   _          -> panic "compileExpr"
 904
 905 -- -----------------------------------------------------------------------------
 906 -- Compile an expression into a dynamic
 907
 908 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
 909 dynCompileExpr ses expr = do
 910     (full,exports) <- getContext ses
 911     setContext ses full $
 912         (mkModule
 913             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 914         ):exports
 915     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 916     res <- withSession ses (flip hscStmt stmt)
 917     setContext ses full exports
 918     case res of
 919         Nothing -> return Nothing
 920         Just (ids, hvals) -> do
 921             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
 922             case (ids,vals) of
 923                 (_:[], v:[])    -> return (Just v)
 924                 _               -> panic "dynCompileExpr"
 925
 926 -----------------------------------------------------------------------------
 927 -- show a module and it's source/object filenames
 928
 929 showModule :: Session -> ModSummary -> IO String
 930 showModule s mod_summary = withSession s $                        \hsc_env ->
 931                            isModuleInterpreted s mod_summary >>=  \interpreted ->
 932                            return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 933
 934 isModuleInterpreted :: Session -> ModSummary -> IO Bool
 935 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 936   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 937         Nothing       -> panic "missing linkable"
 938         Just mod_info -> return (not obj_linkable)
 939                       where
 940                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 941
 942 ----------------------------------------------------------------------------
 943 -- RTTI primitives
 944
 945 obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
 946 obtainTerm1 hsc_env force mb_ty x =
 947               cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
 948
 949 obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
 950 obtainTermB hsc_env bound force id =  do
 951               hv <- Linker.getHValue hsc_env (varName id)
 952               cvObtainTerm hsc_env bound force (Just$ idType id) hv
 953
 954 obtainTerm :: HscEnv -> Bool -> Id -> IO Term
 955 obtainTerm hsc_env force id =  do
 956               hv <- Linker.getHValue hsc_env (varName id)
 957               cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
 958
 959 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 960 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 961 reconstructType hsc_env bound id = do
 962               hv <- Linker.getHValue hsc_env (varName id)
 963               cvReconstructType hsc_env bound (Just$ idType id) hv
 964 #endif /* GHCI */