diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2021-04-28 17:46:44 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-04-30 23:22:13 -0400 |
commit | 491266eeaa64f34923335900fa42e1f239326cab (patch) | |
tree | bf43304ac8bdc07de248b4c7ae622e95d42ca918 | |
parent | c7ca3619e2544d7627c082b6e5bbe57a6b8abc05 (diff) | |
download | haskell-491266eeaa64f34923335900fa42e1f239326cab.tar.gz |
Make GHC.Runtime.Interpreter independent of GHC.Driver
-rw-r--r-- | compiler/GHC/Driver/Env.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/Ppr.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Heap/Inspect.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Interpreter.hs | 33 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Loader.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 9 | ||||
-rw-r--r-- | utils/check-exact/ExactPrint.hs | 1 | ||||
-rw-r--r-- | utils/check-exact/Types.hs | 1 |
9 files changed, 36 insertions, 32 deletions
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 219e66106b..79d9e47088 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -11,6 +11,7 @@ module GHC.Driver.Env , mkInteractiveHscEnv , runInteractiveHsc , hscEPS + , hscInterp , hptCompleteSigs , hptInstances , hptAnns @@ -33,6 +34,7 @@ import GHC.Driver.Session import GHC.Driver.Errors ( printOrThrowDiagnostics ) import GHC.Runtime.Context +import GHC.Runtime.Interpreter.Types (Interp) import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) ) import GHC.Unit @@ -59,6 +61,7 @@ import GHC.Builtin.Names ( gHC_PRIM ) import GHC.Data.Maybe +import GHC.Utils.Exception as Ex import GHC.Utils.Outputable import GHC.Utils.Monad import GHC.Utils.Panic @@ -293,3 +296,11 @@ lookupIfaceByModule hpt pit mod mainModIs :: HscEnv -> Module mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env)) + +-- | Retrieve the target code interpreter +-- +-- Fails if no target code interpreter is available +hscInterp :: HscEnv -> Interp +hscInterp hsc_env = case hsc_interp hsc_env of + Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter") + Just i -> i diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index c147733bb3..3f4844b57c 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -101,7 +101,7 @@ import GHC.Driver.Config import GHC.Driver.Hooks import GHC.Runtime.Context -import GHC.Runtime.Interpreter ( addSptEntry, hscInterp ) +import GHC.Runtime.Interpreter ( addSptEntry ) import GHC.Runtime.Loader ( initializePlugins ) import GHCi.RemoteTypes ( ForeignHValue ) import GHC.ByteCode.Types diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs index 186992065f..b6dee0f8e3 100644 --- a/compiler/GHC/Driver/Ppr.hs +++ b/compiler/GHC/Driver/Ppr.hs @@ -41,15 +41,9 @@ import Control.Monad.IO.Class showSDoc :: DynFlags -> SDoc -> String showSDoc dflags sdoc = renderWithContext (initSDocContext dflags defaultUserStyle) sdoc -showSDocUnsafe :: SDoc -> String -showSDocUnsafe sdoc = renderWithContext defaultSDocContext sdoc - showPpr :: Outputable a => DynFlags -> a -> String showPpr dflags thing = showSDoc dflags (ppr thing) -showPprUnsafe :: Outputable a => a -> String -showPprUnsafe a = renderWithContext defaultSDocContext (ppr a) - -- | Allows caller to specify the PrintUnqualified to use showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String showSDocForUser dflags unit_state unqual doc = renderWithContext (initSDocContext dflags sty) doc' diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index dc01a161af..0ec936265e 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -731,6 +731,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do return term where interp = hscInterp hsc_env + unit_env = hsc_unit_env hsc_env go :: Int -> Type -> Type -> ForeignHValue -> TcM Term -- I believe that my_ty should not have any enclosing @@ -753,7 +754,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- Thunks we may want to force t | isThunk t && force -> do traceTR (text "Forcing a " <> text (show (fmap (const ()) t))) - evalRslt <- liftIO $ GHCi.seqHValue interp hsc_env a + evalRslt <- liftIO $ GHCi.seqHValue interp unit_env a case evalRslt of -- #2950 EvalSuccess _ -> go (pred max_depth) my_ty old_ty a EvalException ex -> do diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index 6b6576ed5b..0bd9f1a0c5 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -48,7 +48,7 @@ module GHC.Runtime.Interpreter -- * Lower-level API using messages , interpCmd, Message(..), withIServ, withIServ_ - , hscInterp, stopInterp + , stopInterp , iservCall, readIServ, writeIServ , purgeLookupSymbolCache , freeHValueRefs @@ -60,8 +60,6 @@ module GHC.Runtime.Interpreter import GHC.Prelude import GHC.IO (catchException) -import GHC.Driver.Ppr (showSDoc) -import GHC.Driver.Env import GHC.Runtime.Interpreter.Types import GHCi.Message @@ -83,13 +81,14 @@ import GHC.Types.Basic import GHC.Utils.Panic import GHC.Utils.Exception as Ex -import GHC.Utils.Outputable(brackets, ppr) +import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe) import GHC.Utils.Fingerprint import GHC.Utils.Misc import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Unit.Home.ModInfo +import GHC.Unit.Env #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run @@ -200,14 +199,6 @@ interpCmd interp msg = case interpInstance interp of iservCall iserv msg --- | Retrieve the target code interpreter --- --- Fails if no target code interpreter is available -hscInterp :: HscEnv -> Interp -hscInterp hsc_env = case hsc_interp hsc_env of - Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter") - Just i -> i - -- Note [uninterruptibleMask_ and interpCmd] -- -- If we receive an async exception, such as ^C, while communicating @@ -402,33 +393,33 @@ getClosure interp ref = mapM (mkFinalizedHValue interp) mb -- | Send a Seq message to the iserv process to force a value #2950 -seqHValue :: Interp -> HscEnv -> ForeignHValue -> IO (EvalResult ()) -seqHValue interp hsc_env ref = +seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ()) +seqHValue interp unit_env ref = withForeignRef ref $ \hval -> do status <- interpCmd interp (Seq hval) - handleSeqHValueStatus interp hsc_env status + handleSeqHValueStatus interp unit_env status -- | Process the result of a Seq or ResumeSeq message. #2950 -handleSeqHValueStatus :: Interp -> HscEnv -> EvalStatus () -> IO (EvalResult ()) -handleSeqHValueStatus interp hsc_env eval_status = +handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ()) +handleSeqHValueStatus interp unit_env eval_status = case eval_status of (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do -- A breakpoint was hit; inform the user and tell them -- which breakpoint was hit. resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt let hmi = expectJust "handleRunStatus" $ - lookupHptDirectly (hsc_HPT hsc_env) + lookupHptDirectly (ue_hpt unit_env) (mkUniqueGrimily mod_uniq) modl = mi_module (hm_iface hmi) bp | is_exception = Nothing | otherwise = Just (BreakInfo modl ix) sdocBpLoc = brackets . ppr . getSeqBpSpan putStrLn ("*** Ignoring breakpoint " ++ - (showSDoc (hsc_dflags hsc_env) $ sdocBpLoc bp)) + (showSDocUnsafe $ sdocBpLoc bp)) -- resume the seq (:force) processing in the iserv process withForeignRef resume_ctxt_fhv $ \hval -> do status <- interpCmd interp (ResumeSeq hval) - handleSeqHValueStatus interp hsc_env status + handleSeqHValueStatus interp unit_env status (EvalComplete _ r) -> return r where getSeqBpSpan :: Maybe BreakInfo -> SrcSpan @@ -440,7 +431,7 @@ handleSeqHValueStatus interp hsc_env eval_status = -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "<unknown>") breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $ - lookupHpt (hsc_HPT hsc_env) (moduleName mod) + lookupHpt (ue_hpt unit_env) (moduleName mod) -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 648f80c571..b0a3c2aded 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -28,7 +28,7 @@ import GHC.Driver.Hooks import GHC.Driver.Plugins import GHC.Linker.Loader ( loadModule, loadName ) -import GHC.Runtime.Interpreter ( wormhole, hscInterp ) +import GHC.Runtime.Interpreter ( wormhole ) import GHC.Runtime.Interpreter.Types import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 6f04ba9ad4..d6c79895d5 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -54,6 +54,8 @@ module GHC.Utils.Outputable ( bufLeftRenderSDoc, pprCode, showSDocOneLine, + showSDocUnsafe, + showPprUnsafe, renderWithContext, pprInfixVar, pprPrefixVar, @@ -596,6 +598,13 @@ showSDocOneLine ctx d Pretty.renderStyle s $ runSDoc d ctx +showSDocUnsafe :: SDoc -> String +showSDocUnsafe sdoc = renderWithContext defaultSDocContext sdoc + +showPprUnsafe :: Outputable a => a -> String +showPprUnsafe a = renderWithContext defaultSDocContext (ppr a) + + isEmpty :: SDocContext -> SDoc -> Bool isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True}) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 9f093c7faf..79511e9d34 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -27,7 +27,6 @@ import GHC.Types.Fixity import GHC.Types.ForeignCall import GHC.Types.SourceText import GHC.Utils.Outputable hiding ( (<>) ) -import GHC.Driver.Ppr import GHC.Unit.Module.Warnings import GHC.Utils.Misc import GHC.Utils.Panic diff --git a/utils/check-exact/Types.hs b/utils/check-exact/Types.hs index ac9ae10375..ef08421583 100644 --- a/utils/check-exact/Types.hs +++ b/utils/check-exact/Types.hs @@ -13,7 +13,6 @@ module Types import GHC hiding (EpaComment) import GHC.Utils.Outputable hiding ( (<>) ) -import GHC.Driver.Ppr import Data.Data (Data, toConstr,cast) import qualified Data.Map as Map |