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