compiler/main/InteractiveEval.hs

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