X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=bb5fab6b9fe0bc51bef7f5ddfe79173458d59cac;hp=de636053dbf8a4be6901eb4bb3c94daec2750139;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=b80c3f61a1a063c15392b706f241d949926582bd diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index de63605..bb5fab6 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -9,14 +9,17 @@ 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, @@ -27,8 +30,7 @@ module InteractiveEval ( showModule, isModuleInterpreted, compileExpr, dynCompileExpr, - lookupName, - obtainTerm, obtainTerm1 + Term(..), obtainTermFromId, obtainTermFromVal, reconstructType #endif ) where @@ -36,46 +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.IORef -import Foreign.StablePtr +-- import Foreign.StablePtr +import System.IO +import System.IO.Unsafe -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -83,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 - | RunBreak ThreadId [Name] BreakInfo + | RunException SomeException -- ^ statement raised an exception + | RunBreak ThreadId [Name] (Maybe BreakInfo) data Status - = Break HValue BreakInfo ThreadId - -- ^ the computation hit a breakpoint - | Complete (Either Exception [HValue]) + = Break Bool HValue BreakInfo ThreadId + -- ^ the computation hit a breakpoint (Bool <=> was an exception) + | Complete (Either SomeException [HValue]) -- ^ the computation completed with either an exception or a value data Resume @@ -98,11 +106,13 @@ 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. - resumeBreakInfo :: BreakInfo, -- the breakpoint we stopped at. + resumeBreakInfo :: Maybe BreakInfo, + -- the breakpoint we stopped at + -- (Nothing <=> exception) resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain -- to fetch the ModDetails & ModBreaks -- to get this. @@ -110,155 +120,201 @@ 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 data History = History { historyApStack :: HValue, - historyBreakInfo :: BreakInfo + historyBreakInfo :: BreakInfo, + historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint } -getHistorySpan :: Session -> History -> IO SrcSpan -getHistorySpan s hist = withSession s $ \hsc_env -> do - let inf = historyBreakInfo hist - num = breakInfo_number inf - case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of - Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num) - _ -> panic "getHistorySpan" - -{- - [Main.hs:42:(1,0)-(3,52)] *Main> :history 2 - Foo.hs:1:3-5 - Bar.hs:5:23-48 - [Main.hs:42:(1,0)-(3,52)] *Main> :back - Logged breakpoint at Foo.hs:1:3-5 - x :: Int - y :: a - _result :: [Char] - [-1: Foo.hs:1:3-5] *Main> :back - Logged breakpoint at Bar.hs:5:23-48 - z :: a - _result :: Float - [-2: Bar.hs:5:23-48] *Main> :forward - Logged breakpoint at Foo.hs:1:3-5 - x :: Int - y :: a - _result :: [Char] - [-1: Foo.hs:1:3-5] *Main> :cont - .. continues --} - --- | 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 +mkHistory :: HscEnv -> HValue -> BreakInfo -> History +mkHistory hsc_env hval bi = let + decls = findEnclosingDecls hsc_env bi + in History hval bi decls - case maybe_stuff of - Nothing -> return RunFailed - Just (ids, hval) -> do - when (isStep step) $ setStepFlag +getHistoryModule :: History -> Module +getHistoryModule = breakInfo_module . historyBreakInfo - -- set the onBreakAction to be performed when we hit a - -- breakpoint this is visible in the Byte Code - -- Interpreter, thus it is a global variable, - -- implemented with stable pointers - withBreakAction breakMVar statusMVar $ do - - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - status <- sandboxIO statusMVar thing_to_run - - let ic = hsc_IC hsc_env - bindings = (ic_tmp_ids ic, ic_tyvars ic) +getHistorySpan :: HscEnv -> History -> SrcSpan +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 (getModBreaks hmi) ! num + _ -> panic "getHistorySpan" - case step of - RunAndLogSteps -> - traceRunStatus expr ref bindings ids - breakMVar statusMVar status emptyHistory - _other -> - handleRunStatus expr ref bindings ids - breakMVar statusMVar status emptyHistory +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. +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 :: 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 + + 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 apStack info tid) -> do - hsc_env <- readIORef ref - (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env apStack info + (Break is_exception apStack info tid) -> do + hsc_env <- getSession + let mb_info | is_exception = Nothing + | otherwise = Just info + (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack + mb_info let - resume = Resume expr tid breakMVar statusMVar - bindings final_ids apStack 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 - return (RunBreak tid names info) + 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 - writeIORef ref hsc_env{hsc_IC=final_ic} - Linker.extendLinkEnv (zip final_names hvals) + 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 apStack info tid) -> do - b <- isBreakEnabled hsc_env info + (Break is_exception apStack info tid) | not is_exception -> do + b <- liftIO $ isBreakEnabled hsc_env info if b then handle_normally else do - let history' = consBL (History apStack info) history + let history' = mkHistory hsc_env apStack info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. - evaluate history' - setStepFlag - status <- withBreakAction 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 @@ -266,131 +322,200 @@ 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 _ -> return False -foreign import ccall "rts_setStepFlag" setStepFlag :: IO () +foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt +foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt + +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 -foreign import ccall "&breakPointIOAction" - breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ())) +foreign import ccall "&rts_breakpoint_io_action" + breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) -- When running a computation, we redirect ^C exceptions to the running -- 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 thing - putMVar statusMVar (Complete res))) - (takeMVar statusMVar) - -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) - -withBreakAction breakMVar statusMVar io - = bracket setBreakAction resetBreakAction (\_ -> io) +-- +-- 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. +-- Idea: if we catch and re-throw it, then the re-throw will trigger +-- a break. Great - but we don't want to re-throw all exceptions, because +-- then we'll get a double break for ordinary sync exceptions (you'd have +-- to :continue twice, which looks strange). So if the exception is +-- not "Interrupted", we unset the exception flag before throwing. +-- +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 :: (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 poke breakPointIOAction stablePtr + when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1 + when step $ setStepFlag return stablePtr + -- Breaking on exceptions is not enabled by default, since it + -- might be a bit surprising. The exception flag is turned off + -- as soon as it is hit, or in resetBreakAction below. - onBreak info apStack = do + onBreak is_exception info apStack = do tid <- myThreadId - putMVar statusMVar (Break apStack info tid) + putMVar statusMVar (Break is_exception apStack info tid) takeMVar breakMVar resetBreakAction stablePtr = do poke breakPointIOAction noBreakStablePtr + poke exceptionFlag 0 + resetStepFlag freeStablePtr stablePtr +noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ()) noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction -noBreakAction info apStack = putStrLn "*** Ignoring breakpoint" -resume :: Session -> SingleStep -> IO RunResult -resume (Session ref) step +noBreakAction :: Bool -> BreakInfo -> HValue -> IO () +noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint" +noBreakAction True _ _ = return () -- exception: just continue + +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 _ _ _ -> do - withBreakAction breakMVar statusMVar $ do - status <- withInterruptsSentTo - (do putMVar breakMVar () + 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 <- liftIO $ withInterruptsSentTo tid $ do + putMVar breakMVar () -- this awakens the stopped thread... - return tid) - (takeMVar statusMVar) - -- and wait for the result + takeMVar statusMVar + -- and wait for the result + 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 - breakMVar statusMVar status emptyHistory + traceRunStatus expr bindings final_ids + breakMVar statusMVar status hist' _other -> - handleRunStatus expr ref bindings final_ids - breakMVar statusMVar status emptyHistory - + 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") + when (new_ix > length history) $ + 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 info = do - (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env - apStack info + update_ic apStack mb_info = do + (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) @@ -400,102 +525,166 @@ moveHist fn (Session ref) = do if new_ix == 0 then case r of Resume { resumeApStack = apStack, - resumeBreakInfo = info } -> - update_ic apStack info + resumeBreakInfo = mb_info } -> + update_ic apStack mb_info else case history !! (new_ix - 1) of - History apStack info -> - update_ic apStack info + History apStack info _ -> + update_ic apStack (Just info) -- ----------------------------------------------------------------------------- -- After stopping at a breakpoint, add free variables to the environment +result_fs :: FastString +result_fs = fsLit "_result" bindLocalsAtBreakpoint :: HscEnv -> HValue - -> BreakInfo + -> Maybe BreakInfo -> IO (HscEnv, [Name], SrcSpan) -bindLocalsAtBreakpoint hsc_env apStack info = do + +-- Nothing case: we stopped when an exception was raised, not at a +-- breakpoint. We have no location information or local variables to +-- 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" + exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span + 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] + + span = mkGeneralSrcSpan (fsLit "") + -- + Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)] + return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span) + +-- Just case: we stopped at a breakpoint, we have information about the location +-- of the breakpoint and the free variables of the expression. +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 _) <- 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_fs = FSLIT("_result") - result_name = mkInternalName (getUnique result_fs) + 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 final_ids = zipWith setIdType all_ids tidy_tys - - let ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars + ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContext ictxt0 final_ids Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] - Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] - return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span) + when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } + 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 - -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) + -- 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 $ noSkolems id + , (occNameFS.nameOccName.idName) id /= result_fs] + 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 @@ -516,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 @@ -566,13 +755,18 @@ 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 -- ----------------------------------------------------------------------------- @@ -581,43 +775,37 @@ toListBL (BL _ _ left right) = left ++ reverse right -- 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_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 } @@ -625,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 @@ -652,16 +840,37 @@ moduleIsInterpreted s modl = withSession s $ \h -> _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) -getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) -getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name +-- Filter the instances by the ones whose tycons (or clases resp) +-- 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 :: 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 $ 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! + | isBuiltInSyntax n = True + | isExternalName n = any ((== n) . gre_name) + (lookupGRE_Name rdr_env n) + | 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 @@ -688,106 +897,90 @@ 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) where obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) -obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term -obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x) +---------------------------------------------------------------------------- +-- RTTI primitives + +obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term +obtainTermFromVal hsc_env bound force ty x = + cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) -obtainTerm :: Session -> Bool -> Id -> IO Term -obtainTerm sess force id = withSession sess $ \hsc_env -> do +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 -> Int -> Id -> IO (Maybe Type) +reconstructType hsc_env bound id = do hv <- Linker.getHValue hsc_env (varName id) - cvObtainTerm 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 */ +