diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-03-16 15:17:49 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-04-21 06:39:32 -0400 |
commit | 35e43d48a9a3ab22da90c4c2ea2c805fe762b9c5 (patch) | |
tree | 3cd08ed7ce20790f9fd522936b2d5e737f41c7f4 | |
parent | 70be0fbcefa07ff164437476bf2809ea7c3ff495 (diff) | |
download | haskell-35e43d48a9a3ab22da90c4c2ea2c805fe762b9c5.tar.gz |
Avoid DynFlags in Ppr code (#17957)
* replace `DynFlags` parameters with `SDocContext` parameters for a few
Ppr related functions: `bufLeftRenderSDoc`, `printSDoc`,
`printSDocLn`, `showSDocOneLine`.
* remove the use of `pprCols :: DynFlags -> Int` in Outputable. We
already have the information via `sdocLineLength :: SDocContext ->
Int`
-rw-r--r-- | compiler/GHC/CmmToAsm.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/CmmToLlvm/Base.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs-boot | 1 | ||||
-rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 3 | ||||
-rw-r--r-- | compiler/main/ErrUtils.hs | 25 | ||||
-rw-r--r-- | compiler/utils/Outputable.hs | 40 |
7 files changed, 49 insertions, 42 deletions
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 4ccdad826d..558d422ba1 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -387,7 +387,8 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats) -- write out the imports - printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle) + let ctx = initSDocContext dflags (mkCodeStyle AsmStyle) + printSDocLn ctx Pretty.LeftMode h $ makeImportsDoc dflags (concat (ngs_imports ngs)) return us' where @@ -516,8 +517,8 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO () emitNativeCode dflags h sdoc = do - {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h - (mkCodeStyle AsmStyle) sdoc + let ctx = initSDocContext dflags (mkCodeStyle AsmStyle) + {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc -- dump native code dumpIfSet_dyn dflags diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index 981535e993..b36b4814f1 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -447,8 +447,8 @@ renderLlvm sdoc = do -- Write to output dflags <- getDynFlags out <- getEnv envOutput - liftIO $ Outp.bufLeftRenderSDoc dflags out - (Outp.mkCodeStyle Outp.CStyle) sdoc + let ctx = initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle) + liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc -- Dump, if requested dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 5ed6e093d7..8f64966131 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -230,7 +230,7 @@ module GHC.Driver.Session ( IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, -- * SDoc - initSDocContext, + initSDocContext, initDefaultSDocContext, -- * Make use of the Cmm CFG CfgWeights(..) @@ -1588,7 +1588,8 @@ defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () defaultLogActionHPutStrDoc dflags h d sty -- Don't add a newline at the end, so that successive -- calls to this log-action can output all on the same line - = printSDoc Pretty.PageMode dflags h sty d + = printSDoc ctx Pretty.PageMode h d + where ctx = initSDocContext dflags sty newtype FlushOut = FlushOut (IO ()) @@ -5184,7 +5185,7 @@ emptyFilesToClean :: FilesToClean emptyFilesToClean = FilesToClean Set.empty Set.empty - +-- | Initialize the pretty-printing options initSDocContext :: DynFlags -> PprStyle -> SDocContext initSDocContext dflags style = SDC { sdocStyle = style @@ -5220,3 +5221,7 @@ initSDocContext dflags style = SDC , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags , sdocDynFlags = dflags } + +-- | Initialize the pretty-printing options using the default user style +initDefaultSDocContext :: DynFlags -> SDocContext +initDefaultSDocContext dflags = initSDocContext dflags (defaultUserStyle dflags) diff --git a/compiler/GHC/Driver/Session.hs-boot b/compiler/GHC/Driver/Session.hs-boot index 23458ee1eb..2bc44dc3c6 100644 --- a/compiler/GHC/Driver/Session.hs-boot +++ b/compiler/GHC/Driver/Session.hs-boot @@ -8,7 +8,6 @@ data DynFlags targetPlatform :: DynFlags -> Platform pprUserLength :: DynFlags -> Int -pprCols :: DynFlags -> Int unsafeGlobalDynFlags :: DynFlags hasPprDebug :: DynFlags -> Bool hasNoDebugOutput :: DynFlags -> Bool diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 4f00de2427..5156bb0aa1 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -1342,8 +1342,9 @@ gen_data dflags data_type_name constr_names loc rep_tc L loc (TypeSig noExtField [L loc data_type_name] sig_ty)) sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) + ctx = initDefaultSDocContext dflags rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc))) + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr rep_tc))) `nlHsApp` nlList (map nlHsVar constr_names) genDataDataCon :: DataCon -> RdrName -> DerivStuff diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 0096891e54..2a4168302b 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -729,12 +729,13 @@ withTiming' dflags what force_result prtimings action then do whenPrintTimings $ logInfo dflags (defaultUserStyle dflags) $ text "***" <+> what <> colon - eventBegins dflags what + let ctx = initDefaultSDocContext dflags + eventBegins ctx what alloc0 <- liftIO getAllocationCounter start <- liftIO getCPUTime !r <- action () <- pure $ force_result r - eventEnds dflags what + eventEnds ctx what end <- liftIO getCPUTime alloc1 <- liftIO getAllocationCounter -- recall that allocation counter counts down @@ -753,7 +754,7 @@ withTiming' dflags what force_result prtimings action whenPrintTimings $ dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText - $ text $ showSDocOneLine dflags + $ text $ showSDocOneLine ctx $ hsep [ what <> colon , text "alloc=" <> ppr alloc , text "time=" <> doublePrec 3 time @@ -762,15 +763,15 @@ withTiming' dflags what force_result prtimings action else action where whenPrintTimings = liftIO . when (prtimings == PrintTimings) - eventBegins dflags w = do - whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w) - liftIO $ traceEventIO (eventBeginsDoc dflags w) - eventEnds dflags w = do - whenPrintTimings $ traceMarkerIO (eventEndsDoc dflags w) - liftIO $ traceEventIO (eventEndsDoc dflags w) - - eventBeginsDoc dflags w = showSDocOneLine dflags $ text "GHC:started:" <+> w - eventEndsDoc dflags w = showSDocOneLine dflags $ text "GHC:finished:" <+> w + eventBegins ctx w = do + whenPrintTimings $ traceMarkerIO (eventBeginsDoc ctx w) + liftIO $ traceEventIO (eventBeginsDoc ctx w) + eventEnds ctx w = do + whenPrintTimings $ traceMarkerIO (eventEndsDoc ctx w) + liftIO $ traceEventIO (eventEndsDoc ctx w) + + eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w + eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val $ diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index c23f6ed180..d36faa4724 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -96,7 +96,7 @@ import GhcPrelude import {-# SOURCE #-} GHC.Driver.Session ( DynFlags, hasPprDebug, hasNoDebugOutput - , pprUserLength, pprCols + , pprUserLength , unsafeGlobalDynFlags, initSDocContext ) import {-# SOURCE #-} GHC.Types.Module( UnitId, Module, ModuleName, moduleName ) @@ -484,43 +484,43 @@ whenPprDebug d = ifPprDebug d empty -- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the -- terminal doesn't get screwed up by the ANSI color codes if an exception -- is thrown during pretty-printing. -printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () -printSDoc mode dflags handle sty doc = +printSDoc :: SDocContext -> Mode -> Handle -> SDoc -> IO () +printSDoc ctx mode handle doc = Pretty.printDoc_ mode cols handle (runSDoc doc ctx) `finally` Pretty.printDoc_ mode cols handle (runSDoc (coloured Col.colReset empty) ctx) where - cols = pprCols dflags - ctx = initSDocContext dflags sty + cols = sdocLineLength ctx -- | Like 'printSDoc' but appends an extra newline. -printSDocLn :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () -printSDocLn mode dflags handle sty doc = - printSDoc mode dflags handle sty (doc $$ text "") +printSDocLn :: SDocContext -> Mode -> Handle -> SDoc -> IO () +printSDocLn ctx mode handle doc = + printSDoc ctx mode handle (doc $$ text "") printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () printForUser dflags handle unqual doc - = printSDocLn PageMode dflags handle - (mkUserStyle dflags unqual AllTheWay) doc + = printSDocLn ctx PageMode handle doc + where ctx = initSDocContext dflags (mkUserStyle dflags unqual AllTheWay) printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc -> IO () printForUserPartWay dflags handle d unqual doc - = printSDocLn PageMode dflags handle - (mkUserStyle dflags unqual (PartWay d)) doc + = printSDocLn ctx PageMode handle doc + where ctx = initSDocContext dflags (mkUserStyle dflags unqual (PartWay d)) -- | Like 'printSDocLn' but specialized with 'LeftMode' and -- @'PprCode' 'CStyle'@. This is typically used to output C-- code. printForC :: DynFlags -> Handle -> SDoc -> IO () printForC dflags handle doc = - printSDocLn LeftMode dflags handle (PprCode CStyle) doc + printSDocLn ctx LeftMode handle doc + where ctx = initSDocContext dflags (PprCode CStyle) -- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that -- outputs to a 'BufHandle'. -bufLeftRenderSDoc :: DynFlags -> BufHandle -> PprStyle -> SDoc -> IO () -bufLeftRenderSDoc dflags bufHandle sty doc = - Pretty.bufLeftRender bufHandle (runSDoc doc (initSDocContext dflags sty)) +bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO () +bufLeftRenderSDoc ctx bufHandle doc = + Pretty.bufLeftRender bufHandle (runSDoc doc ctx) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d @@ -566,12 +566,12 @@ renderWithStyle ctx sdoc -- This shows an SDoc, but on one line only. It's cheaper than a full -- showSDoc, designed for when we're getting results like "Foo.bar" -- and "foo{uniq strictness}" so we don't want fancy layout anyway. -showSDocOneLine :: DynFlags -> SDoc -> String -showSDocOneLine dflags d +showSDocOneLine :: SDocContext -> SDoc -> String +showSDocOneLine ctx d = let s = Pretty.style{ Pretty.mode = OneLineMode, - Pretty.lineLength = pprCols dflags } in + Pretty.lineLength = sdocLineLength ctx } in Pretty.renderStyle s $ - runSDoc d (initSDocContext dflags (defaultUserStyle dflags)) + runSDoc d ctx showSDocDumpOneLine :: DynFlags -> SDoc -> String showSDocDumpOneLine dflags d |