compiler/main/InteractiveEval.hs

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