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               withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
 213
 214               let thing_to_run = unsafeCoerce# hval :: IO [HValue]
 215               status <- 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
 445 back :: Session -> IO ([Name], Int, SrcSpan)
 446 back  = moveHist (+1)
 447
 448 forward :: Session -> IO ([Name], Int, SrcSpan)
 449 forward  = moveHist (subtract 1)
 450
 451 moveHist fn (Session ref) = do
 452   hsc_env <- readIORef ref
 453   case ic_resume (hsc_IC hsc_env) of
 454      [] -> throwDyn (ProgramError "not stopped at a breakpoint")
 455      (r:rs) -> do
 456         let ix = resumeHistoryIx r
 457             history = resumeHistory r
 458             new_ix = fn ix
 459         --
 460         when (new_ix > length history) $
 461            throwDyn (ProgramError "no more logged breakpoints")
 462         when (new_ix < 0) $
 463            throwDyn (ProgramError "already at the beginning of the history")
 464
 465         let
 466           update_ic apStack mb_info = do
 467             (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
 468                                                 apStack mb_info
 469             let ic = hsc_IC hsc_env1
 470                 r' = r { resumeHistoryIx = new_ix }
 471                 ic' = ic { ic_resume = r':rs }
 472
 473             writeIORef ref hsc_env1{ hsc_IC = ic' }
 474
 475             return (names, new_ix, span)
 476
 477         -- careful: we want apStack to be the AP_STACK itself, not a thunk
 478         -- around it, hence the cases are carefully constructed below to
 479         -- make this the case.  ToDo: this is v. fragile, do something better.
 480         if new_ix == 0
 481            then case r of
 482                    Resume { resumeApStack = apStack,
 483                             resumeBreakInfo = mb_info } ->
 484                           update_ic apStack mb_info
 485            else case history !! (new_ix - 1) of
 486                    History apStack info _ ->
 487                           update_ic apStack (Just info)
 488
 489 -- -----------------------------------------------------------------------------
 490 -- After stopping at a breakpoint, add free variables to the environment
 491 result_fs = FSLIT("_result")
 492
 493 bindLocalsAtBreakpoint
 494         :: HscEnv
 495         -> HValue
 496         -> Maybe BreakInfo
 497         -> IO (HscEnv, [Name], SrcSpan)
 498
 499 -- Nothing case: we stopped when an exception was raised, not at a
 500 -- breakpoint.  We have no location information or local variables to
 501 -- bind, all we can do is bind a local variable to the exception
 502 -- value.
 503 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 504    let exn_fs    = FSLIT("_exception")
 505        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
 506        e_fs      = FSLIT("e")
 507        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
 508        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
 509        exn_id    = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
 510                                 vanillaIdInfo
 511        new_tyvars = unitVarSet e_tyvar
 512
 513        ictxt0 = hsc_IC hsc_env
 514        ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
 515
 516        span = mkGeneralSrcSpan FSLIT("<exception thrown>")
 517    --
 518    Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
 519    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 520
 521 -- Just case: we stopped at a breakpoint, we have information about the location
 522 -- of the breakpoint and the free variables of the expression.
 523 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 524
 525    let
 526        mod_name  = moduleName (breakInfo_module info)
 527        hmi       = expectJust "bindLocalsAtBreakpoint" $
 528                         lookupUFM (hsc_HPT hsc_env) mod_name
 529        breaks    = getModBreaks hmi
 530        index     = breakInfo_number info
 531        vars      = breakInfo_vars info
 532        result_ty = breakInfo_resty info
 533        occs      = modBreaks_vars breaks ! index
 534        span      = modBreaks_locs breaks ! index
 535
 536    -- filter out any unboxed ids; we can't bind these at the prompt
 537    let pointers = filter (\(id,_) -> isPointer id) vars
 538        isPointer id | PtrRep <- idPrimRep id = True
 539                     | otherwise              = False
 540
 541    let (ids, offsets) = unzip pointers
 542
 543    -- It might be that getIdValFromApStack fails, because the AP_STACK
 544    -- has been accidentally evaluated, or something else has gone wrong.
 545    -- So that we don't fall over in a heap when this happens, just don't
 546    -- bind any free variables instead, and we emit a warning.
 547    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
 548    let filtered_ids = [ id | (id, Just hv) <- zip ids mb_hValues ]
 549    when (any isNothing mb_hValues) $
 550       debugTraceMsg (hsc_dflags hsc_env) 1 $
 551           text "Warning: _result has been evaluated, some bindings have been lost"
 552
 553    new_ids <- zipWithM mkNewId occs filtered_ids
 554    let names = map idName new_ids
 555
 556    -- make an Id for _result.  We use the Unique of the FastString "_result";
 557    -- we don't care about uniqueness here, because there will only be one
 558    -- _result in scope at any time.
 559    let result_name = mkInternalName (getUnique result_fs)
 560                           (mkVarOccFS result_fs) span
 561        result_id   = Id.mkGlobalId VanillaGlobal result_name result_ty
 562                                    vanillaIdInfo
 563
 564    -- for each Id we're about to bind in the local envt:
 565    --    - skolemise the type variables in its type, so they can't
 566    --      be randomly unified with other types.  These type variables
 567    --      can only be resolved by type reconstruction in RtClosureInspect
 568    --    - tidy the type variables
 569    --    - globalise the Id (Ids are supposed to be Global, apparently).
 570    --
 571    let all_ids | isPointer result_id = result_id : new_ids
 572                | otherwise           = new_ids
 573        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 574        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 575        new_tyvars = unionVarSets tyvarss
 576    let final_ids = zipWith setIdType all_ids tidy_tys
 577        ictxt0 = hsc_IC hsc_env
 578        ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 579    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 580    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 581    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
 582    return (hsc_env1, result_name:names, span)
 583   where
 584    mkNewId :: OccName -> Id -> IO Id
 585    mkNewId occ id = do
 586      us <- mkSplitUniqSupply 'I'
 587         -- we need a fresh Unique for each Id we bind, because the linker
 588         -- state is single-threaded and otherwise we'd spam old bindings
 589         -- whenever we stop at a breakpoint.  The InteractveContext is properly
 590         -- saved/restored, but not the linker state.  See #1743, test break026.
 591      let
 592          uniq = uniqFromSupply us
 593          loc = nameSrcSpan (idName id)
 594          name = mkInternalName uniq occ loc
 595          ty = idType id
 596          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
 597      return new_id
 598
 599 rttiEnvironment :: HscEnv -> IO HscEnv
 600 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
 601    let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
 602        incompletelyTypedIds =
 603            [id | id <- tmp_ids
 604                , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
 605                               , isSkolemTyVar v]
 606                , (occNameFS.nameOccName.idName) id /= result_fs]
 607    tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
 608           -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
 609
 610    let substs = [computeRTTIsubst ty ty'
 611                  | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
 612        ic'    = foldr (flip substInteractiveContext) ic
 613                            (map skolemiseSubst $ catMaybes substs)
 614    return hsc_env{hsc_IC=ic'}
 615
 616 skolemiseSubst subst = subst `setTvSubstEnv`
 617                         mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
 618
 619 skolemiseTy :: Type -> (Type, TyVarSet)
 620 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 621   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 622         subst         = mkTvSubst emptyInScopeSet env
 623         tyvars        = varSetElems (tyVarsOfType ty)
 624         new_tyvars    = map skolemiseTyVar tyvars
 625         new_tyvar_tys = map mkTyVarTy new_tyvars
 626
 627 skolemiseTyVar :: TyVar -> TyVar
 628 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 629                                  (SkolemTv RuntimeUnkSkol)
 630
 631 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 632 getIdValFromApStack apStack (I# stackDepth) = do
 633    case getApStackVal# apStack (stackDepth +# 1#) of
 634                                 -- The +1 is magic!  I don't know where it comes
 635                                 -- from, but this makes things line up.  --SDM
 636         (# ok, result #) ->
 637             case ok of
 638               0# -> return Nothing -- AP_STACK not found
 639               _  -> return (Just (unsafeCoerce# result))
 640
 641 pushResume :: HscEnv -> Resume -> HscEnv
 642 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 643   where
 644         ictxt0 = hsc_IC hsc_env
 645         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 646
 647 -- -----------------------------------------------------------------------------
 648 -- Abandoning a resume context
 649
 650 abandon :: Session -> IO Bool
 651 abandon (Session ref) = do
 652    hsc_env <- readIORef ref
 653    let ic = hsc_IC hsc_env
 654        resume = ic_resume ic
 655    case resume of
 656       []    -> return False
 657       r:rs  -> do
 658          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
 659          abandon_ r
 660          return True
 661
 662 abandonAll :: Session -> IO Bool
 663 abandonAll (Session ref) = do
 664    hsc_env <- readIORef ref
 665    let ic = hsc_IC hsc_env
 666        resume = ic_resume ic
 667    case resume of
 668       []  -> return False
 669       rs  -> do
 670          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
 671          mapM_ abandon_ rs
 672          return True
 673
 674 -- when abandoning a computation we have to
 675 --      (a) kill the thread with an async exception, so that the
 676 --          computation itself is stopped, and
 677 --      (b) fill in the MVar.  This step is necessary because any
 678 --          thunks that were under evaluation will now be updated
 679 --          with the partial computation, which still ends in takeMVar,
 680 --          so any attempt to evaluate one of these thunks will block
 681 --          unless we fill in the MVar.
 682 --  See test break010.
 683 abandon_ :: Resume -> IO ()
 684 abandon_ r = do
 685   killThread (resumeThreadId r)
 686   putMVar (resumeBreakMVar r) ()
 687
 688 -- -----------------------------------------------------------------------------
 689 -- Bounded list, optimised for repeated cons
 690
 691 data BoundedList a = BL
 692                         {-# UNPACK #-} !Int  -- length
 693                         {-# UNPACK #-} !Int  -- bound
 694                         [a] -- left
 695                         [a] -- right,  list is (left ++ reverse right)
 696
 697 nilBL :: Int -> BoundedList a
 698 nilBL bound = BL 0 bound [] []
 699
 700 consBL a (BL len bound left right)
 701   | len < bound = BL (len+1) bound (a:left) right
 702   | null right  = BL len     bound [a]      $! tail (reverse left)
 703   | otherwise   = BL len     bound (a:left) $! tail right
 704
 705 toListBL (BL _ _ left right) = left ++ reverse right
 706
 707 fromListBL bound l = BL (length l) bound l []
 708
 709 -- lenBL (BL len _ _ _) = len
 710
 711 -- -----------------------------------------------------------------------------
 712 -- | Set the interactive evaluation context.
 713 --
 714 -- Setting the context doesn't throw away any bindings; the bindings
 715 -- we've built up in the InteractiveContext simply move to the new
 716 -- module.  They always shadow anything in scope in the current context.
 717 setContext :: Session
 718            -> [Module]  -- entire top level scope of these modules
 719            -> [Module]  -- exports only of these modules
 720            -> IO ()
 721 setContext sess@(Session ref) toplev_mods export_mods = do
 722   hsc_env <- readIORef ref
 723   let old_ic  = hsc_IC     hsc_env
 724       hpt     = hsc_HPT    hsc_env
 725   --
 726   export_env  <- mkExportEnv hsc_env export_mods
 727   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
 728   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 729   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 730                                             ic_exports      = export_mods,
 731                                             ic_rn_gbl_env   = all_env }}
 732
 733 -- Make a GlobalRdrEnv based on the exports of the modules only.
 734 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 735 mkExportEnv hsc_env mods = do
 736   stuff <- mapM (getModuleExports hsc_env) mods
 737   let
 738         (_msgs, mb_name_sets) = unzip stuff
 739         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 740                | (Just avails, mod) <- zip mb_name_sets mods ]
 741   --
 742   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 743
 744 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 745 nameSetToGlobalRdrEnv names mod =
 746   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 747                  | name <- nameSetToList names ]
 748
 749 vanillaProv :: ModuleName -> Provenance
 750 -- We're building a GlobalRdrEnv as if the user imported
 751 -- all the specified modules into the global interactive module
 752 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 753   where
 754     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 755                          is_qual = False,
 756                          is_dloc = srcLocSpan interactiveSrcLoc }
 757
 758 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 759 mkTopLevEnv hpt modl
 760   = case lookupUFM hpt (moduleName modl) of
 761       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
 762                                                 showSDoc (ppr modl)))
 763       Just details ->
 764          case mi_globals (hm_iface details) of
 765                 Nothing  ->
 766                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
 767                                                 ++ showSDoc (ppr modl)))
 768                 Just env -> return env
 769
 770 -- | Get the interactive evaluation context, consisting of a pair of the
 771 -- set of modules from which we take the full top-level scope, and the set
 772 -- of modules from which we take just the exports respectively.
 773 getContext :: Session -> IO ([Module],[Module])
 774 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 775                                 return (ic_toplev_scope ic, ic_exports ic))
 776
 777 -- | Returns 'True' if the specified module is interpreted, and hence has
 778 -- its full top-level scope available.
 779 moduleIsInterpreted :: Session -> Module -> IO Bool
 780 moduleIsInterpreted s modl = withSession s $ \h ->
 781  if modulePackageId modl /= thisPackage (hsc_dflags h)
 782         then return False
 783         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 784                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 785                 _not_a_home_module -> return False
 786
 787 -- | Looks up an identifier in the current interactive context (for :info)
 788 -- Filter the instances by the ones whose tycons (or clases resp)
 789 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 790 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 791 --      (see Trac #1581)
 792 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 793 getInfo s name
 794   = withSession s $ \hsc_env ->
 795     do  { mb_stuff <- tcRnGetInfo hsc_env name
 796         ; case mb_stuff of
 797             Nothing -> return Nothing
 798             Just (thing, fixity, ispecs) -> do
 799         { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
 800         ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } }
 801   where
 802     plausible rdr_env ispec     -- Dfun involving only names that are in ic_rn_glb_env
 803         = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
 804         where   -- A name is ok if it's in the rdr_env,
 805                 -- whether qualified or not
 806           ok n | n == name         = True       -- The one we looked for in the first place!
 807                | isBuiltInSyntax n = True
 808                | isExternalName n  = any ((== n) . gre_name)
 809                                          (lookupGRE_Name rdr_env n)
 810                | otherwise         = True
 811
 812 -- | Returns all names in scope in the current interactive context
 813 getNamesInScope :: Session -> IO [Name]
 814 getNamesInScope s = withSession s $ \hsc_env -> do
 815   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 816
 817 getRdrNamesInScope :: Session -> IO [RdrName]
 818 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
 819   let
 820       ic = hsc_IC hsc_env
 821       gbl_rdrenv = ic_rn_gbl_env ic
 822       ids = ic_tmp_ids ic
 823       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 824       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 825   --
 826   return (gbl_names ++ lcl_names)
 827
 828
 829 -- ToDo: move to RdrName
 830 greToRdrNames :: GlobalRdrElt -> [RdrName]
 831 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 832   = case prov of
 833      LocalDef -> [unqual]
 834      Imported specs -> concat (map do_spec (map is_decl specs))
 835   where
 836     occ = nameOccName name
 837     unqual = Unqual occ
 838     do_spec decl_spec
 839         | is_qual decl_spec = [qual]
 840         | otherwise         = [unqual,qual]
 841         where qual = Qual (is_as decl_spec) occ
 842
 843 -- | Parses a string as an identifier, and returns the list of 'Name's that
 844 -- the identifier can refer to in the current interactive context.
 845 parseName :: Session -> String -> IO [Name]
 846 parseName s str = withSession s $ \hsc_env -> do
 847    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 848    case maybe_rdr_name of
 849         Nothing -> return []
 850         Just (L _ rdr_name) -> do
 851             mb_names <- tcRnLookupRdrName hsc_env rdr_name
 852             case mb_names of
 853                 Nothing -> return []
 854                 Just ns -> return ns
 855                 -- ToDo: should return error messages
 856
 857 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 858 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 859 lookupName :: Session -> Name -> IO (Maybe TyThing)
 860 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
 861
 862 -- -----------------------------------------------------------------------------
 863 -- Getting the type of an expression
 864
 865 -- | Get the type of an expression
 866 exprType :: Session -> String -> IO (Maybe Type)
 867 exprType s expr = withSession s $ \hsc_env -> do
 868    maybe_stuff <- hscTcExpr hsc_env expr
 869    case maybe_stuff of
 870         Nothing -> return Nothing
 871         Just ty -> return (Just tidy_ty)
 872              where
 873                 tidy_ty = tidyType emptyTidyEnv ty
 874
 875 -- -----------------------------------------------------------------------------
 876 -- Getting the kind of a type
 877
 878 -- | Get the kind of a  type
 879 typeKind  :: Session -> String -> IO (Maybe Kind)
 880 typeKind s str = withSession s $ \hsc_env -> do
 881    maybe_stuff <- hscKcType hsc_env str
 882    case maybe_stuff of
 883         Nothing -> return Nothing
 884         Just kind -> return (Just kind)
 885
 886 -----------------------------------------------------------------------------
 887 -- cmCompileExpr: compile an expression and deliver an HValue
 888
 889 compileExpr :: Session -> String -> IO (Maybe HValue)
 890 compileExpr s expr = withSession s $ \hsc_env -> do
 891   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 892   case maybe_stuff of
 893         Nothing -> return Nothing
 894         Just (ids, hval) -> do
 895                         -- Run it!
 896                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
 897
 898                 case (ids,hvals) of
 899                   ([n],[hv]) -> return (Just hv)
 900                   _          -> panic "compileExpr"
 901
 902 -- -----------------------------------------------------------------------------
 903 -- Compile an expression into a dynamic
 904
 905 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
 906 dynCompileExpr ses expr = do
 907     (full,exports) <- getContext ses
 908     setContext ses full $
 909         (mkModule
 910             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 911         ):exports
 912     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 913     res <- withSession ses (flip hscStmt stmt)
 914     setContext ses full exports
 915     case res of
 916         Nothing -> return Nothing
 917         Just (ids, hvals) -> do
 918             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
 919             case (ids,vals) of
 920                 (_:[], v:[])    -> return (Just v)
 921                 _               -> panic "dynCompileExpr"
 922
 923 -----------------------------------------------------------------------------
 924 -- show a module and it's source/object filenames
 925
 926 showModule :: Session -> ModSummary -> IO String
 927 showModule s mod_summary = withSession s $                        \hsc_env ->
 928                            isModuleInterpreted s mod_summary >>=  \interpreted ->
 929                            return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 930
 931 isModuleInterpreted :: Session -> ModSummary -> IO Bool
 932 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 933   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 934         Nothing       -> panic "missing linkable"
 935         Just mod_info -> return (not obj_linkable)
 936                       where
 937                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 938
 939 ----------------------------------------------------------------------------
 940 -- RTTI primitives
 941
 942 obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
 943 obtainTerm1 hsc_env force mb_ty x =
 944               cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
 945
 946 obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
 947 obtainTermB hsc_env bound force id =  do
 948               hv <- Linker.getHValue hsc_env (varName id)
 949               cvObtainTerm hsc_env bound force (Just$ idType id) hv
 950
 951 obtainTerm :: HscEnv -> Bool -> Id -> IO Term
 952 obtainTerm hsc_env force id =  do
 953               hv <- Linker.getHValue hsc_env (varName id)
 954               cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
 955
 956 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 957 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 958 reconstructType hsc_env bound id = do
 959               hv <- Linker.getHValue hsc_env (varName id)
 960               cvReconstructType hsc_env bound (Just$ idType id) hv
 961 #endif /* GHCI */