compiler/main/InteractiveEval.hs

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