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