X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=bb5fab6b9fe0bc51bef7f5ddfe79173458d59cac;hp=8579901afc4610596d683c9cc644c8dc58c60238;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=c9a8811e407ea25e271d850468839935d0cf5e4f diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 8579901..bb5fab6 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -6,25 +6,20 @@ -- -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings --- for details - module InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), - runStmt, SingleStep(..), + runStmt, runStmtWithLocation, + parseImportDecl, SingleStep(..), resume, abandon, abandonAll, getResumeContext, getHistorySpan, + getModBreaks, getHistoryModule, back, forward, setContext, getContext, - nameSetToGlobalRdrEnv, + availsToGlobalRdrEnv, getNamesInScope, getRdrNamesInScope, moduleIsInterpreted, @@ -35,9 +30,7 @@ module InteractiveEval ( showModule, isModuleInterpreted, compileExpr, dynCompileExpr, - lookupName, - Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType, - skolemiseSubst, skolemiseTy + Term(..), obtainTermFromId, obtainTermFromVal, reconstructType #endif ) where @@ -45,49 +38,52 @@ module InteractiveEval ( #include "HsVersions.h" -import HscMain hiding (compileExpr) +import GhcMonad +import HscMain +import HsSyn import HscTypes -import TcRnDriver -import Type hiding (typeKind) -import TcType hiding (typeKind) +import RnNames (gresFromAvails) import InstEnv -import Var hiding (setIdType) +import Type +import TcType hiding( typeKind ) +import Var import Id -import IdInfo import Name hiding ( varName ) import NameSet import RdrName +import PrelNames (pRELUDE) import VarSet import VarEnv import ByteCodeInstr import Linker import DynFlags import Unique +import UniqSupply import Module import Panic import UniqFM import Maybes import ErrUtils -import Util import SrcLoc import BreakArray import RtClosureInspect -import Packages -import BasicTypes import Outputable +import FastString +import MonadUtils +import System.Directory import Data.Dynamic import Data.List (find) import Control.Monad -import Foreign +import Foreign hiding (unsafePerformIO) import Foreign.C import GHC.Exts import Data.Array -import Control.Exception as Exception +import Exception import Control.Concurrent -import Data.List (sortBy) -import Data.IORef -import Foreign.StablePtr +-- import Foreign.StablePtr +import System.IO +import System.IO.Unsafe -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -95,13 +91,13 @@ import Foreign.StablePtr data RunResult = RunOk [Name] -- ^ names bound by this evaluation | RunFailed -- ^ statement failed compilation - | RunException Exception -- ^ statement raised an exception + | RunException SomeException -- ^ statement raised an exception | RunBreak ThreadId [Name] (Maybe BreakInfo) data Status = Break Bool HValue BreakInfo ThreadId -- ^ the computation hit a breakpoint (Bool <=> was an exception) - | Complete (Either Exception [HValue]) + | Complete (Either SomeException [HValue]) -- ^ the computation completed with either an exception or a value data Resume @@ -110,7 +106,7 @@ data Resume resumeThreadId :: ThreadId, -- thread running the computation resumeBreakMVar :: MVar (), resumeStatMVar :: MVar Status, - resumeBindings :: ([Id], TyVarSet), + resumeBindings :: [Id], resumeFinalIds :: [Id], -- [Id] to bind on completion resumeApStack :: HValue, -- The object from which we can get -- value of the free variables. @@ -124,14 +120,15 @@ data Resume resumeHistoryIx :: Int -- 0 <==> at the top of the history } -getResumeContext :: Session -> IO [Resume] -getResumeContext s = withSession s (return . ic_resume . hsc_IC) +getResumeContext :: GhcMonad m => m [Resume] +getResumeContext = withSession (return . ic_resume . hsc_IC) data SingleStep = RunToCompletion | SingleStep | RunAndLogSteps +isStep :: SingleStep -> Bool isStep RunToCompletion = False isStep _ = True @@ -139,16 +136,14 @@ data History = History { historyApStack :: HValue, historyBreakInfo :: BreakInfo, - historyEnclosingDecl :: Id - -- ^^ A cache of the enclosing top level declaration, for convenience + historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint } mkHistory :: HscEnv -> HValue -> BreakInfo -> History mkHistory hsc_env hval bi = let - h = History hval bi decl - decl = findEnclosingDecl hsc_env (getHistoryModule h) - (getHistorySpan hsc_env h) - in h + decls = findEnclosingDecls hsc_env bi + in History hval bi decls + getHistoryModule :: History -> Module getHistoryModule = breakInfo_module . historyBreakInfo @@ -158,126 +153,168 @@ getHistorySpan hsc_env hist = let inf = historyBreakInfo hist num = breakInfo_number inf in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of - Just hmi -> modBreaks_locs (md_modBreaks (hm_details hmi)) ! num + Just hmi -> modBreaks_locs (getModBreaks hmi) ! num _ -> panic "getHistorySpan" +getModBreaks :: HomeModInfo -> ModBreaks +getModBreaks hmi + | Just linkable <- hm_linkable hmi, + [BCOs _ modBreaks] <- linkableUnlinked linkable + = modBreaks + | otherwise + = emptyModBreaks -- probably object code + {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick. -findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id -findEnclosingDecl hsc_env mod span = - case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of - Nothing -> panic "findEnclosingDecl" - Just hmi -> let - globals = typeEnvIds (md_types (hm_details hmi)) - Just decl = - find (\id -> let n = idName id in - nameSrcSpan n < span && isExternalName n) - (reverse$ sortBy (compare `on` (nameSrcSpan.idName)) - globals) - in decl +findEnclosingDecls :: HscEnv -> BreakInfo -> [String] +findEnclosingDecls hsc_env inf = + let hmi = expectJust "findEnclosingDecls" $ + lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf) + mb = getModBreaks hmi + in modBreaks_decls mb ! breakInfo_number inf + -- | Run a statement in the current interactive context. Statement -- may bind multple values. -runStmt :: Session -> String -> SingleStep -> IO RunResult -runStmt (Session ref) expr step - = do - hsc_env <- readIORef ref - - breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint - statusMVar <- newEmptyMVar -- wait on this when a computation is running - - -- Turn off -fwarn-unused-bindings when running a statement, to hide - -- warnings about the implicit bindings we introduce. - let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } - - maybe_stuff <- hscStmt hsc_env' expr - - case maybe_stuff of - Nothing -> return RunFailed - Just (ids, hval) -> do - - withBreakAction (isStep step) dflags' breakMVar statusMVar $ do - - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - status <- sandboxIO statusMVar thing_to_run +runStmt :: GhcMonad m => String -> SingleStep -> m RunResult +runStmt = runStmtWithLocation "" 1 + +-- | Run a statement in the current interactive context. Passing debug information +-- Statement may bind multple values. +runStmtWithLocation :: GhcMonad m => String -> Int -> + String -> SingleStep -> m RunResult +runStmtWithLocation source linenumber expr step = + do + hsc_env <- getSession + + breakMVar <- liftIO $ newEmptyMVar -- wait on this when we hit a breakpoint + statusMVar <- liftIO $ newEmptyMVar -- wait on this when a computation is running + + -- Turn off -fwarn-unused-bindings when running a statement, to hide + -- warnings about the implicit bindings we introduce. + let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_dflags = dflags' } + + r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber + + case r of + Nothing -> return RunFailed -- empty statement / comment + + Just (ids, hval) -> do + status <- + withVirtualCWD $ + withBreakAction (isStep step) dflags' breakMVar statusMVar $ do + let thing_to_run = unsafeCoerce# hval :: IO [HValue] + liftIO $ sandboxIO dflags' statusMVar thing_to_run - let ic = hsc_IC hsc_env - bindings = (ic_tmp_ids ic, ic_tyvars ic) - - case step of - RunAndLogSteps -> - traceRunStatus expr ref bindings ids - breakMVar statusMVar status emptyHistory - _other -> - handleRunStatus expr ref bindings ids - breakMVar statusMVar status emptyHistory - - + let ic = hsc_IC hsc_env + bindings = ic_tmp_ids ic + + case step of + RunAndLogSteps -> + traceRunStatus expr bindings ids + breakMVar statusMVar status emptyHistory + _other -> + handleRunStatus expr bindings ids + breakMVar statusMVar status emptyHistory + +withVirtualCWD :: GhcMonad m => m a -> m a +withVirtualCWD m = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + + let set_cwd = do + dir <- liftIO $ getCurrentDirectory + case ic_cwd ic of + Just dir -> liftIO $ setCurrentDirectory dir + Nothing -> return () + return dir + + reset_cwd orig_dir = do + virt_dir <- liftIO $ getCurrentDirectory + hsc_env <- getSession + let old_IC = hsc_IC hsc_env + setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } + liftIO $ setCurrentDirectory orig_dir + + gbracket set_cwd reset_cwd $ \_ -> m + +parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) +parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr + +emptyHistory :: BoundedList History emptyHistory = nilBL 50 -- keep a log of length 50 -handleRunStatus expr ref bindings final_ids breakMVar statusMVar status +handleRunStatus :: GhcMonad m => + String-> [Id] -> [Id] + -> MVar () -> MVar Status -> Status -> BoundedList History + -> m RunResult +handleRunStatus expr bindings final_ids breakMVar statusMVar status history = case status of -- did we hit a breakpoint or did we complete? (Break is_exception apStack info tid) -> do - hsc_env <- readIORef ref + hsc_env <- getSession let mb_info | is_exception = Nothing | otherwise = Just info - (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env - apStack mb_info + (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack + mb_info let - resume = Resume expr tid breakMVar statusMVar - bindings final_ids apStack mb_info span - (toListBL history) 0 + resume = Resume { resumeStmt = expr, resumeThreadId = tid + , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar + , resumeBindings = bindings, resumeFinalIds = final_ids + , resumeApStack = apStack, resumeBreakInfo = mb_info + , resumeSpan = span, resumeHistory = toListBL history + , resumeHistoryIx = 0 } hsc_env2 = pushResume hsc_env1 resume -- - writeIORef ref hsc_env2 + modifySession (\_ -> hsc_env2) return (RunBreak tid names mb_info) (Complete either_hvals) -> case either_hvals of Left e -> return (RunException e) Right hvals -> do - hsc_env <- readIORef ref - let final_ic = extendInteractiveContext (hsc_IC hsc_env) - final_ids emptyVarSet - -- the bound Ids never have any free TyVars + hsc_env <- getSession + let final_ic = extendInteractiveContext (hsc_IC hsc_env) final_ids final_names = map idName final_ids - Linker.extendLinkEnv (zip final_names hvals) - hsc_env' <- rttiEnvironment hsc_env{hsc_IC=final_ic} - writeIORef ref hsc_env' + liftIO $ Linker.extendLinkEnv (zip final_names hvals) + hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} + modifySession (\_ -> hsc_env') return (RunOk final_names) - -traceRunStatus expr ref bindings final_ids +traceRunStatus :: GhcMonad m => + String -> [Id] -> [Id] + -> MVar () -> MVar Status -> Status -> BoundedList History + -> m RunResult +traceRunStatus expr bindings final_ids breakMVar statusMVar status history = do - hsc_env <- readIORef ref + hsc_env <- getSession case status of -- when tracing, if we hit a breakpoint that is not explicitly -- enabled, then we just log the event in the history and continue. (Break is_exception apStack info tid) | not is_exception -> do - b <- isBreakEnabled hsc_env info + b <- liftIO $ isBreakEnabled hsc_env info if b then handle_normally else do let history' = mkHistory hsc_env apStack info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. - evaluate history' - status <- withBreakAction True (hsc_dflags hsc_env) - breakMVar statusMVar $ do - withInterruptsSentTo - (do putMVar breakMVar () -- awaken the stopped thread - return tid) - (takeMVar statusMVar) -- and wait for the result - traceRunStatus expr ref bindings final_ids + _ <- liftIO $ evaluate history' + status <- + withBreakAction True (hsc_dflags hsc_env) + breakMVar statusMVar $ do + liftIO $ withInterruptsSentTo tid $ do + putMVar breakMVar () -- awaken the stopped thread + takeMVar statusMVar -- and wait for the result + traceRunStatus expr bindings final_ids breakMVar statusMVar status history' _other -> handle_normally where - handle_normally = handleRunStatus expr ref bindings final_ids + handle_normally = handleRunStatus expr bindings final_ids breakMVar statusMVar status history @@ -285,7 +322,7 @@ isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool isBreakEnabled hsc_env inf = case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of Just hmi -> do - w <- getBreak (modBreaks_flags (md_modBreaks (hm_details hmi))) + w <- getBreak (modBreaks_flags (getModBreaks hmi)) (breakInfo_number inf) case w of Just n -> return (n /= 0); _other -> return False _ -> @@ -295,7 +332,9 @@ isBreakEnabled hsc_env inf = foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt -setStepFlag = poke stepFlag 1 +setStepFlag :: IO () +setStepFlag = poke stepFlag 1 +resetStepFlag :: IO () resetStepFlag = poke stepFlag 0 -- this points to the IO action that is executed when a breakpoint is hit @@ -306,12 +345,25 @@ foreign import ccall "&rts_breakpoint_io_action" -- thread. ToDo: we might want a way to continue even if the target -- thread doesn't die when it receives the exception... "this thread -- is not responding". -sandboxIO :: MVar Status -> IO [HValue] -> IO Status -sandboxIO statusMVar thing = - withInterruptsSentTo - (forkIO (do res <- Exception.try (rethrow thing) - putMVar statusMVar (Complete res))) - (takeMVar statusMVar) +-- +-- Careful here: there may be ^C exceptions flying around, so we start the new +-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock +-- only while we execute the user's code. We can't afford to lose the final +-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946) +sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status +sandboxIO dflags statusMVar thing = + mask $ \restore -> -- fork starts blocked + let runIt = liftM Complete $ try (restore $ rethrow dflags thing) + in if dopt Opt_GhciSandbox dflags + then do tid <- forkIO $ do res <- runIt + putMVar statusMVar res -- empty: can't block + withInterruptsSentTo tid $ takeMVar statusMVar + else -- GLUT on OS X needs to run on the main thread. If you + -- try to use it from another thread then you just get a + -- white rectangle rendered. For this, or anything else + -- with such restrictions, you can turn the GHCi sandbox off + -- and things will be run in the main thread. + runIt -- We want to turn ^C into a break when -fbreak-on-exception is on, -- but it's an async exception and we only break for sync exceptions. @@ -321,27 +373,36 @@ sandboxIO statusMVar thing = -- to :continue twice, which looks strange). So if the exception is -- not "Interrupted", we unset the exception flag before throwing. -- -rethrow :: IO a -> IO a -rethrow io = Exception.catch io $ \e -> -- NB. not catchDyn - case e of - DynException d | Just Interrupted <- fromDynamic d - -> Exception.throwIO e - _ -> do poke exceptionFlag 0; Exception.throwIO e - - -withInterruptsSentTo :: IO ThreadId -> IO r -> IO r -withInterruptsSentTo io get_result = do - ts <- takeMVar interruptTargetThread - child <- io - putMVar interruptTargetThread (child:ts) - get_result `finally` modifyMVar_ interruptTargetThread (return.tail) +rethrow :: DynFlags -> IO a -> IO a +rethrow dflags io = Exception.catch io $ \se -> do + -- If -fbreak-on-error, we break unconditionally, + -- but with care of not breaking twice + if dopt Opt_BreakOnError dflags && + not (dopt Opt_BreakOnException dflags) + then poke exceptionFlag 1 + else case fromException se of + -- If it is a "UserInterrupt" exception, we allow + -- a possible break by way of -fbreak-on-exception + Just UserInterrupt -> return () + -- In any other case, we don't want to break + _ -> poke exceptionFlag 0 + + Exception.throwIO se + +withInterruptsSentTo :: ThreadId -> IO r -> IO r +withInterruptsSentTo thread get_result = do + bracket (modifyMVar_ interruptTargetThread (return . (thread:))) + (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl)) + (\_ -> get_result) -- This function sets up the interpreter for catching breakpoints, and -- resets everything when the computation has stopped running. This -- is a not-very-good way to ensure that only the interactive -- evaluation should generate breakpoints. -withBreakAction step dflags breakMVar statusMVar io - = bracket setBreakAction resetBreakAction (\_ -> io) +withBreakAction :: (ExceptionMonad m, MonadIO m) => + Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a +withBreakAction step dflags breakMVar statusMVar act + = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act) where setBreakAction = do stablePtr <- newStablePtr onBreak @@ -364,91 +425,97 @@ withBreakAction step dflags breakMVar statusMVar io resetStepFlag freeStablePtr stablePtr +noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ()) noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction -noBreakAction False info apStack = putStrLn "*** Ignoring breakpoint" -noBreakAction True info apStack = return () -- exception: just continue +noBreakAction :: Bool -> BreakInfo -> HValue -> IO () +noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint" +noBreakAction True _ _ = return () -- exception: just continue -resume :: Session -> SingleStep -> IO RunResult -resume (Session ref) step +resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult +resume canLogSpan step = do - hsc_env <- readIORef ref + hsc_env <- getSession let ic = hsc_IC hsc_env resume = ic_resume ic case resume of - [] -> throwDyn (ProgramError "not stopped at a breakpoint") + [] -> ghcError (ProgramError "not stopped at a breakpoint") (r:rs) -> do -- unbind the temporary locals by restoring the TypeEnv from -- before the breakpoint, and drop this Resume from the -- InteractiveContext. - let (resume_tmp_ids, resume_tyvars) = resumeBindings r + let resume_tmp_ids = resumeBindings r ic' = ic { ic_tmp_ids = resume_tmp_ids, - ic_tyvars = resume_tyvars, ic_resume = rs } - writeIORef ref hsc_env{ hsc_IC = ic' } + modifySession (\_ -> hsc_env{ hsc_IC = ic' }) -- remove any bindings created since the breakpoint from the -- linker's environment let new_names = map idName (filter (`notElem` resume_tmp_ids) (ic_tmp_ids ic)) - Linker.deleteFromLinkEnv new_names + liftIO $ Linker.deleteFromLinkEnv new_names - when (isStep step) $ setStepFlag + when (isStep step) $ liftIO setStepFlag case r of - Resume expr tid breakMVar statusMVar bindings - final_ids apStack info _ hist _ -> do + Resume { resumeStmt = expr, resumeThreadId = tid + , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar + , resumeBindings = bindings, resumeFinalIds = final_ids + , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span + , resumeHistory = hist } -> do + withVirtualCWD $ do withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do - status <- withInterruptsSentTo - (do putMVar breakMVar () + status <- liftIO $ withInterruptsSentTo tid $ do + putMVar breakMVar () -- this awakens the stopped thread... - return tid) - (takeMVar statusMVar) + takeMVar statusMVar -- and wait for the result - let hist' = - case info of - Nothing -> fromListBL 50 hist - Just i -> mkHistory hsc_env apStack i `consBL` + let prevHistoryLst = fromListBL 50 hist + hist' = case info of + Nothing -> prevHistoryLst + Just i + | not $canLogSpan span -> prevHistoryLst + | otherwise -> mkHistory hsc_env apStack i `consBL` fromListBL 50 hist case step of RunAndLogSteps -> - traceRunStatus expr ref bindings final_ids + traceRunStatus expr bindings final_ids breakMVar statusMVar status hist' _other -> - handleRunStatus expr ref bindings final_ids + handleRunStatus expr bindings final_ids breakMVar statusMVar status hist' - -back :: Session -> IO ([Name], Int, SrcSpan) +back :: GhcMonad m => m ([Name], Int, SrcSpan) back = moveHist (+1) -forward :: Session -> IO ([Name], Int, SrcSpan) +forward :: GhcMonad m => m ([Name], Int, SrcSpan) forward = moveHist (subtract 1) -moveHist fn (Session ref) = do - hsc_env <- readIORef ref +moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) +moveHist fn = do + hsc_env <- getSession case ic_resume (hsc_IC hsc_env) of - [] -> throwDyn (ProgramError "not stopped at a breakpoint") + [] -> ghcError (ProgramError "not stopped at a breakpoint") (r:rs) -> do let ix = resumeHistoryIx r history = resumeHistory r new_ix = fn ix -- when (new_ix > length history) $ - throwDyn (ProgramError "no more logged breakpoints") + ghcError (ProgramError "no more logged breakpoints") when (new_ix < 0) $ - throwDyn (ProgramError "already at the beginning of the history") + ghcError (ProgramError "already at the beginning of the history") let update_ic apStack mb_info = do - (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env + (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } ic' = ic { ic_resume = r':rs } - writeIORef ref hsc_env1{ hsc_IC = ic' } + modifySession (\_ -> hsc_env1{ hsc_IC = ic' }) return (names, new_ix, span) @@ -466,8 +533,9 @@ moveHist fn (Session ref) = do -- ----------------------------------------------------------------------------- -- After stopping at a breakpoint, add free variables to the environment -result_fs = FSLIT("_result") - +result_fs :: FastString +result_fs = fsLit "_result" + bindLocalsAtBreakpoint :: HscEnv -> HValue @@ -479,19 +547,17 @@ bindLocalsAtBreakpoint -- bind, all we can do is bind a local variable to the exception -- value. bindLocalsAtBreakpoint hsc_env apStack Nothing = do - let exn_fs = FSLIT("_exception") + let exn_fs = fsLit "_exception" exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span - e_fs = FSLIT("e") - e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span - e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol) - exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar) - vanillaIdInfo - new_tyvars = unitVarSet e_tyvar + e_fs = fsLit "e" + e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span + e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind + exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars + ictxt1 = extendInteractiveContext ictxt0 [exn_id] - span = mkGeneralSrcSpan FSLIT("") + span = mkGeneralSrcSpan (fsLit "") -- Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)] return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span) @@ -501,103 +567,124 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do bindLocalsAtBreakpoint hsc_env apStack (Just info) = do let - mod_name = moduleName (breakInfo_module info) - mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name) - breaks = md_modBreaks (expectJust "handlRunStatus" mod_details) + mod_name = moduleName (breakInfo_module info) + hmi = expectJust "bindLocalsAtBreakpoint" $ + lookupUFM (hsc_HPT hsc_env) mod_name + breaks = getModBreaks hmi index = breakInfo_number info vars = breakInfo_vars info result_ty = breakInfo_resty info occs = modBreaks_vars breaks ! index span = modBreaks_locs breaks ! index - -- filter out any unboxed ids; we can't bind these at the prompt - let pointers = filter (\(id,_) -> isPointer id) vars + -- Filter out any unboxed ids; + -- we can't bind these at the prompt + pointers = filter (\(id,_) -> isPointer id) vars isPointer id | PtrRep <- idPrimRep id = True | otherwise = False - let (ids, offsets) = unzip pointers + (ids, offsets) = unzip pointers + + free_tvs = foldr (unionVarSet . tyVarsOfType . idType) + (tyVarsOfType result_ty) ids -- It might be that getIdValFromApStack fails, because the AP_STACK -- has been accidentally evaluated, or something else has gone wrong. -- So that we don't fall over in a heap when this happens, just don't -- bind any free variables instead, and we emit a warning. - mb_hValues <- mapM (getIdValFromApStack apStack) offsets - let filtered_ids = [ id | (id, Just hv) <- zip ids mb_hValues ] + mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets) + let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ] when (any isNothing mb_hValues) $ debugTraceMsg (hsc_dflags hsc_env) 1 $ text "Warning: _result has been evaluated, some bindings have been lost" - new_ids <- zipWithM mkNewId occs filtered_ids - let names = map idName new_ids + us <- mkSplitUniqSupply 'I' + let (us1, us2) = splitUniqSupply us + tv_subst = newTyVars us1 free_tvs + new_ids = zipWith3 (mkNewId tv_subst) occs filtered_ids (uniqsFromSupply us2) + names = map idName new_ids -- make an Id for _result. We use the Unique of the FastString "_result"; -- we don't care about uniqueness here, because there will only be one -- _result in scope at any time. let result_name = mkInternalName (getUnique result_fs) (mkVarOccFS result_fs) span - result_id = Id.mkGlobalId VanillaGlobal result_name result_ty - vanillaIdInfo + result_id = Id.mkVanillaGlobal result_name (substTy tv_subst result_ty) -- for each Id we're about to bind in the local envt: - -- - skolemise the type variables in its type, so they can't - -- be randomly unified with other types. These type variables - -- can only be resolved by type reconstruction in RtClosureInspect -- - tidy the type variables -- - globalise the Id (Ids are supposed to be Global, apparently). -- - let all_ids | isPointer result_id = result_id : new_ids - | otherwise = new_ids - (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids + let result_ok = isPointer result_id + && not (isUnboxedTupleType (idType result_id)) + + all_ids | result_ok = result_id : new_ids + | otherwise = new_ids + id_tys = map idType all_ids (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys - new_tyvars = unionVarSets tyvarss - let final_ids = zipWith setIdType all_ids tidy_tys + final_ids = zipWith setIdType all_ids tidy_tys ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars + ictxt1 = extendInteractiveContext ictxt0 final_ids + Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] - Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, result_name:names, span) + return (hsc_env1, if result_ok then result_name:names else names, span) where - mkNewId :: OccName -> Id -> IO Id - mkNewId occ id = do - let uniq = idUnique id - loc = nameSrcSpan (idName id) - name = mkInternalName uniq occ loc - ty = idType id - new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) - return new_id + -- We need a fresh Unique for each Id we bind, because the linker + -- state is single-threaded and otherwise we'd spam old bindings + -- whenever we stop at a breakpoint. The InteractveContext is properly + -- saved/restored, but not the linker state. See #1743, test break026. + mkNewId :: TvSubst -> OccName -> Id -> Unique -> Id + mkNewId tv_subst occ id uniq + = Id.mkVanillaGlobalWithInfo name ty (idInfo id) + where + loc = nameSrcSpan (idName id) + name = mkInternalName uniq occ loc + ty = substTy tv_subst (idType id) + + newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst + -- Similarly, clone the type variables mentioned in the types + -- we have here, *and* make them all RuntimeUnk tyars + newTyVars us tvs + = mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) + | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us + , let name = setNameUnique (tyVarName tv) uniq ] rttiEnvironment :: HscEnv -> IO HscEnv rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do let InteractiveContext{ic_tmp_ids=tmp_ids} = ic incompletelyTypedIds = [id | id <- tmp_ids - , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id) - , isSkolemTyVar v] + , not $ noSkolems id , (occNameFS.nameOccName.idName) id /= result_fs] - tys <- reconstructType hsc_env False `mapM` incompletelyTypedIds - -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds) - - let substs = [computeRTTIsubst ty ty' - | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys] - ic' = foldr (flip substInteractiveContext) ic - (map skolemiseSubst $ catMaybes substs) - return hsc_env{hsc_IC=ic'} - -skolemiseSubst subst = subst `setTvSubstEnv` - mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst) - -skolemiseTy :: Type -> (Type, TyVarSet) -skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars) - where env = mkVarEnv (zip tyvars new_tyvar_tys) - subst = mkTvSubst emptyInScopeSet env - tyvars = varSetElems (tyVarsOfType ty) - new_tyvars = map skolemiseTyVar tyvars - new_tyvar_tys = map mkTyVarTy new_tyvars - -skolemiseTyVar :: TyVar -> TyVar -skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) - (SkolemTv RuntimeUnkSkol) + hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) + return hsc_env' + where + noSkolems = isEmptyVarSet . tyVarsOfType . idType + improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do + let InteractiveContext{ic_tmp_ids=tmp_ids} = ic + Just id = find (\i -> idName i == name) tmp_ids + if noSkolems id + then return hsc_env + else do + mb_new_ty <- reconstructType hsc_env 10 id + let old_ty = idType id + case mb_new_ty of + Nothing -> return hsc_env + Just new_ty -> do + case improveRTTIType hsc_env old_ty new_ty of + Nothing -> return $ + WARN(True, text (":print failed to calculate the " + ++ "improvement for a type")) hsc_env + Just subst -> do + when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $ + printForUser stderr alwaysQualify $ + fsep [text "RTTI Improvement for", ppr id, equals, ppr subst] + + let ic' = extendInteractiveContext + (substInteractiveContext ic subst) [] + return hsc_env{hsc_IC=ic'} getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue) getIdValFromApStack apStack (I# stackDepth) = do @@ -618,28 +705,28 @@ pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } -- ----------------------------------------------------------------------------- -- Abandoning a resume context -abandon :: Session -> IO Bool -abandon (Session ref) = do - hsc_env <- readIORef ref +abandon :: GhcMonad m => m Bool +abandon = do + hsc_env <- getSession let ic = hsc_IC hsc_env resume = ic_resume ic case resume of [] -> return False r:rs -> do - writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } } - abandon_ r + modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } } + liftIO $ abandon_ r return True -abandonAll :: Session -> IO Bool -abandonAll (Session ref) = do - hsc_env <- readIORef ref +abandonAll :: GhcMonad m => m Bool +abandonAll = do + hsc_env <- getSession let ic = hsc_IC hsc_env resume = ic_resume ic case resume of [] -> return False rs -> do - writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } } - mapM_ abandon_ rs + modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } } + liftIO $ mapM_ abandon_ rs return True -- when abandoning a computation we have to @@ -668,13 +755,16 @@ data BoundedList a = BL nilBL :: Int -> BoundedList a nilBL bound = BL 0 bound [] [] +consBL :: a -> BoundedList a -> BoundedList a consBL a (BL len bound left right) | len < bound = BL (len+1) bound (a:left) right | null right = BL len bound [a] $! tail (reverse left) | otherwise = BL len bound (a:left) $! tail right +toListBL :: BoundedList a -> [a] toListBL (BL _ _ left right) = left ++ reverse right +fromListBL :: Int -> [a] -> BoundedList a fromListBL bound l = BL (length l) bound l [] -- lenBL (BL len _ _ _) = len @@ -685,43 +775,37 @@ fromListBL bound l = BL (length l) bound l [] -- Setting the context doesn't throw away any bindings; the bindings -- we've built up in the InteractiveContext simply move to the new -- module. They always shadow anything in scope in the current context. -setContext :: Session - -> [Module] -- entire top level scope of these modules - -> [Module] -- exports only of these modules - -> IO () -setContext sess@(Session ref) toplev_mods export_mods = do - hsc_env <- readIORef ref - let old_ic = hsc_IC hsc_env - hpt = hsc_HPT hsc_env - -- - export_env <- mkExportEnv hsc_env export_mods - toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods - let all_env = foldr plusGlobalRdrEnv export_env toplev_envs - writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, - ic_exports = export_mods, - ic_rn_gbl_env = all_env }} - --- Make a GlobalRdrEnv based on the exports of the modules only. -mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv -mkExportEnv hsc_env mods = do - stuff <- mapM (getModuleExports hsc_env) mods - let - (_msgs, mb_name_sets) = unzip stuff - gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod) - | (Just avails, mod) <- zip mb_name_sets mods ] - -- - return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres - -nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv -nameSetToGlobalRdrEnv names mod = - mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod } - | name <- nameSetToList names ] - -vanillaProv :: ModuleName -> Provenance --- We're building a GlobalRdrEnv as if the user imported --- all the specified modules into the global interactive module -vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] +setContext :: GhcMonad m => + [Module] -- ^ entire top level scope of these modules + -> [ImportDecl RdrName] -- ^ these import declarations + -> m () +setContext toplev_mods import_decls = do + hsc_env <- getSession + let old_ic = hsc_IC hsc_env + hpt = hsc_HPT hsc_env + imprt_decls = map noLoc import_decls + -- + import_env <- + if null imprt_decls then return emptyGlobalRdrEnv else do + let this_mod | null toplev_mods = pRELUDE + | otherwise = head toplev_mods + liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls + + toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods + + let all_env = foldr plusGlobalRdrEnv import_env toplev_envs + modifySession $ \_ -> + hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, + ic_imports = import_decls, + ic_rn_gbl_env = all_env }} + +availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv +availsToGlobalRdrEnv mod_name avails + = mkGlobalRdrEnv (gresFromAvails imp_prov avails) where + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } @@ -729,26 +813,26 @@ vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv mkTopLevEnv hpt modl = case lookupUFM hpt (moduleName modl) of - Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ + Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ showSDoc (ppr modl))) Just details -> case mi_globals (hm_iface details) of Nothing -> - throwDyn (ProgramError ("mkTopLevEnv: not interpreted " + ghcError (ProgramError ("mkTopLevEnv: not interpreted " ++ showSDoc (ppr modl))) Just env -> return env -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set -- of modules from which we take just the exports respectively. -getContext :: Session -> IO ([Module],[Module]) -getContext s = withSession s (\HscEnv{ hsc_IC=ic } -> - return (ic_toplev_scope ic, ic_exports ic)) +getContext :: GhcMonad m => m ([Module],[ImportDecl RdrName]) +getContext = withSession $ \HscEnv{ hsc_IC=ic } -> + return (ic_toplev_scope ic, ic_imports ic) --- | Returns 'True' if the specified module is interpreted, and hence has +-- | Returns @True@ if the specified module is interpreted, and hence has -- its full top-level scope available. -moduleIsInterpreted :: Session -> Module -> IO Bool -moduleIsInterpreted s modl = withSession s $ \h -> +moduleIsInterpreted :: GhcMonad m => Module -> m Bool +moduleIsInterpreted modl = withSession $ \h -> if modulePackageId modl /= thisPackage (hsc_dflags h) then return False else case lookupUFM (hsc_HPT h) (moduleName modl) of @@ -760,18 +844,18 @@ moduleIsInterpreted s modl = withSession s $ \h -> -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! -- The exact choice of which ones to show, and which to hide, is a judgement call. -- (see Trac #1581) -getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) -getInfo s name - = withSession s $ \hsc_env -> - do { mb_stuff <- tcRnGetInfo hsc_env name - ; case mb_stuff of - Nothing -> return Nothing - Just (thing, fixity, ispecs) -> do - { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) - ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } } +getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) +getInfo name + = withSession $ \hsc_env -> + do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name + case mb_stuff of + Nothing -> return Nothing + Just (thing, fixity, ispecs) -> do + let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) + return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) where plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env - = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec + = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec where -- A name is ok if it's in the rdr_env, -- whether qualified or not ok n | n == name = True -- The one we looked for in the first place! @@ -781,12 +865,12 @@ getInfo s name | otherwise = True -- | Returns all names in scope in the current interactive context -getNamesInScope :: Session -> IO [Name] -getNamesInScope s = withSession s $ \hsc_env -> do +getNamesInScope :: GhcMonad m => m [Name] +getNamesInScope = withSession $ \hsc_env -> do return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) -getRdrNamesInScope :: Session -> IO [RdrName] -getRdrNamesInScope s = withSession s $ \hsc_env -> do +getRdrNamesInScope :: GhcMonad m => m [RdrName] +getRdrNamesInScope = withSession $ \hsc_env -> do let ic = hsc_IC hsc_env gbl_rdrenv = ic_rn_gbl_env ic @@ -813,94 +897,65 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov } -- | Parses a string as an identifier, and returns the list of 'Name's that -- the identifier can refer to in the current interactive context. -parseName :: Session -> String -> IO [Name] -parseName s str = withSession s $ \hsc_env -> do - maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str - case maybe_rdr_name of - Nothing -> return [] - Just (L _ rdr_name) -> do - mb_names <- tcRnLookupRdrName hsc_env rdr_name - case mb_names of - Nothing -> return [] - Just ns -> return ns - -- ToDo: should return error messages - --- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any --- entity known to GHC, including 'Name's defined using 'runStmt'. -lookupName :: Session -> Name -> IO (Maybe TyThing) -lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name +parseName :: GhcMonad m => String -> m [Name] +parseName str = withSession $ \hsc_env -> do + (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str + liftIO $ hscTcRnLookupRdrName hsc_env rdr_name -- ----------------------------------------------------------------------------- -- Getting the type of an expression -- | Get the type of an expression -exprType :: Session -> String -> IO (Maybe Type) -exprType s expr = withSession s $ \hsc_env -> do - maybe_stuff <- hscTcExpr hsc_env expr - case maybe_stuff of - Nothing -> return Nothing - Just ty -> return (Just tidy_ty) - where - tidy_ty = tidyType emptyTidyEnv ty +exprType :: GhcMonad m => String -> m Type +exprType expr = withSession $ \hsc_env -> do + ty <- liftIO $ hscTcExpr hsc_env expr + return $ tidyType emptyTidyEnv ty -- ----------------------------------------------------------------------------- -- Getting the kind of a type -- | Get the kind of a type -typeKind :: Session -> String -> IO (Maybe Kind) -typeKind s str = withSession s $ \hsc_env -> do - maybe_stuff <- hscKcType hsc_env str - case maybe_stuff of - Nothing -> return Nothing - Just kind -> return (Just kind) +typeKind :: GhcMonad m => String -> m Kind +typeKind str = withSession $ \hsc_env -> do + liftIO $ hscKcType hsc_env str ----------------------------------------------------------------------------- -- cmCompileExpr: compile an expression and deliver an HValue -compileExpr :: Session -> String -> IO (Maybe HValue) -compileExpr s expr = withSession s $ \hsc_env -> do - maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr) - case maybe_stuff of - Nothing -> return Nothing - Just (ids, hval) -> do - -- Run it! - hvals <- (unsafeCoerce# hval) :: IO [HValue] +compileExpr :: GhcMonad m => String -> m HValue +compileExpr expr = withSession $ \hsc_env -> do + Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) + -- Run it! + hvals <- liftIO (unsafeCoerce# hval :: IO [HValue]) - case (ids,hvals) of - ([n],[hv]) -> return (Just hv) - _ -> panic "compileExpr" + case (ids,hvals) of + ([_],[hv]) -> return hv + _ -> panic "compileExpr" -- ----------------------------------------------------------------------------- -- Compile an expression into a dynamic -dynCompileExpr :: Session -> String -> IO (Maybe Dynamic) -dynCompileExpr ses expr = do - (full,exports) <- getContext ses - setContext ses full $ - (mkModule - (stringToPackageId "base") (mkModuleName "Data.Dynamic") - ):exports +dynCompileExpr :: GhcMonad m => String -> m Dynamic +dynCompileExpr expr = do let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" - res <- withSession ses (flip hscStmt stmt) - setContext ses full exports - case res of - Nothing -> return Nothing - Just (ids, hvals) -> do - vals <- (unsafeCoerce# hvals :: IO [Dynamic]) - case (ids,vals) of - (_:[], v:[]) -> return (Just v) - _ -> panic "dynCompileExpr" + Just (ids, hvals) <- withSession $ \hsc_env -> + liftIO $ hscStmt hsc_env stmt + vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) + case (ids,vals) of + (_:[], v:[]) -> return v + _ -> panic "dynCompileExpr" ----------------------------------------------------------------------------- -- show a module and it's source/object filenames -showModule :: Session -> ModSummary -> IO String -showModule s mod_summary = withSession s $ \hsc_env -> - isModuleInterpreted s mod_summary >>= \interpreted -> - return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) +showModule :: GhcMonad m => ModSummary -> m String +showModule mod_summary = + withSession $ \hsc_env -> do + interpreted <- isModuleInterpreted mod_summary + return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) -isModuleInterpreted :: Session -> ModSummary -> IO Bool -isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> +isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool +isModuleInterpreted mod_summary = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of Nothing -> panic "missing linkable" Just mod_info -> return (not obj_linkable) @@ -910,23 +965,22 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> ---------------------------------------------------------------------------- -- RTTI primitives -obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term -obtainTerm1 hsc_env force mb_ty x = - cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x) - -obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term -obtainTermB hsc_env bound force id = do - hv <- Linker.getHValue hsc_env (varName id) - cvObtainTerm hsc_env bound force (Just$ idType id) hv +obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term +obtainTermFromVal hsc_env bound force ty x = + cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) -obtainTerm :: HscEnv -> Bool -> Id -> IO Term -obtainTerm hsc_env force id = do - hv <- Linker.getHValue hsc_env (varName id) - cvObtainTerm hsc_env maxBound force (Just$ idType id) hv +obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term +obtainTermFromId hsc_env bound force id = do + hv <- Linker.getHValue hsc_env (varName id) + cvObtainTerm hsc_env bound force (idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic -reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type) -reconstructType hsc_env force id = do +reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) +reconstructType hsc_env bound id = do hv <- Linker.getHValue hsc_env (varName id) - cvReconstructType hsc_env force (Just$ idType id) hv + cvReconstructType hsc_env bound (idType id) hv + +mkRuntimeUnkTyVar :: Name -> Kind -> TyVar +mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk #endif /* GHCI */ +