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