diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2023-01-09 19:42:59 +0100 |
---|---|---|
committer | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2023-01-11 00:48:09 +0100 |
commit | f893d98267d1cadc62ef74cdd542c3dcc08b8aed (patch) | |
tree | 2746ee9395c73cce11c3bea231316b005242ca5a | |
parent | 146a145835f5c2e82da4dd0bcb90702460505a01 (diff) | |
download | haskell-wip/specialize-hdoc.tar.gz |
Add 'docWithStyle' to improve codegenwip/specialize-hdoc
This new combinator
docWithStyle :: IsOutput doc => doc -> (PprStyle -> SDoc) -> doc
let us remove the need for code to be polymorphic in HDoc
when not used in code style.
Metric Decrease:
ManyConstructors
T13035
T1969
-rw-r--r-- | compiler/GHC/Types/CostCentre.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Types/Name.hs | 59 | ||||
-rw-r--r-- | compiler/GHC/Types/Name/Occurrence.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Unit/Types.hs | 23 | ||||
-rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 49 |
5 files changed, 78 insertions, 68 deletions
diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs index e20a4977ec..a41496f83c 100644 --- a/compiler/GHC/Types/CostCentre.hs +++ b/compiler/GHC/Types/CostCentre.hs @@ -265,10 +265,8 @@ instance Outputable CostCentre where ppr = pprCostCentre pprCostCentre :: IsLine doc => CostCentre -> doc -pprCostCentre cc = docWithContext $ \ sty -> - if codeStyle (sdocStyle sty) - then ppCostCentreLbl cc - else ftext (costCentreUserNameFS cc) +pprCostCentre cc = docWithStyle (ppCostCentreLbl cc) + (\_ -> ftext (costCentreUserNameFS cc)) {-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-} {-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index 1b70c4d910..7a069a573d 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -627,21 +627,30 @@ instance OutputableBndr Name where pprName :: forall doc. IsLine doc => Name -> doc pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) - = docWithContext $ \ctx -> - let sty = sdocStyle ctx - debug = sdocPprDebug ctx - listTuplePuns = sdocListTuplePuns ctx - in handlePuns listTuplePuns (namePun_maybe name) $ - case sort of - WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin - External mod -> pprExternal debug sty uniq mod occ False UserSyntax - System -> pprSystem debug sty uniq occ - Internal -> pprInternal debug sty uniq occ + = docWithStyle codeDoc normalDoc where - -- Print GHC.Types.List as [], etc. - handlePuns :: Bool -> Maybe FastString -> doc -> doc - handlePuns True (Just pun) _ = ftext pun - handlePuns _ _ r = r + codeDoc = case sort of + WiredIn mod _ _ -> pprModule mod <> char '_' <> ppr_z_occ_name occ + External mod -> pprModule mod <> char '_' <> ppr_z_occ_name occ + -- In code style, always qualify + -- ToDo: maybe we could print all wired-in things unqualified + -- in code style, to reduce symbol table bloat? + System -> pprUniqueAlways uniq + Internal -> pprUniqueAlways uniq + + normalDoc sty = + getPprDebug $ \debug -> + sdocOption sdocListTuplePuns $ \listTuplePuns -> + handlePuns listTuplePuns (namePun_maybe name) $ + case sort of + WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin + External mod -> pprExternal debug sty uniq mod occ False UserSyntax + System -> pprSystem debug sty uniq occ + Internal -> pprInternal debug sty uniq occ + + handlePuns :: Bool -> Maybe FastString -> SDoc -> SDoc + handlePuns True (Just pun) _ = ftext pun + handlePuns _ _ r = r {-# SPECIALISE pprName :: Name -> SDoc #-} {-# SPECIALISE pprName :: Name -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable @@ -674,12 +683,8 @@ pprTickyName this_mod name pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ -pprExternal :: IsLine doc => Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> doc +pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc pprExternal debug sty uniq mod occ is_wired is_builtin - | codeStyle sty = pprModule mod <> char '_' <> ppr_z_occ_name occ - -- In code style, always qualify - -- ToDo: maybe we could print all wired-in things unqualified - -- in code style, to reduce symbol table bloat? | debug = pp_mod <> ppr_occ_name occ <> braces (hsep [if is_wired then text "(w)" else empty, pprNameSpaceBrief (occNameSpace occ), @@ -695,9 +700,8 @@ pprExternal debug sty uniq mod occ is_wired is_builtin pp_mod = ppUnlessOption sdocSuppressModulePrefixes (pprModule mod <> dot) -pprInternal :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc +pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc pprInternal debug sty uniq occ - | codeStyle sty = pprUniqueAlways uniq | debug = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq @@ -706,9 +710,8 @@ pprInternal debug sty uniq occ | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style -pprSystem :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc -pprSystem debug sty uniq occ - | codeStyle sty = pprUniqueAlways uniq +pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprSystem debug _sty uniq occ | debug = ppr_occ_name occ <> ppr_underscore_unique uniq <> braces (pprNameSpaceBrief (occNameSpace occ)) | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq @@ -717,7 +720,7 @@ pprSystem debug sty uniq occ -- so print the unique -pprModulePrefix :: IsLine doc => PprStyle -> Module -> OccName -> doc +pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc -- Print the "M." part of a name, based on whether it's in scope or not -- See Note [Printing original names] in GHC.Types.Name.Ppr pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ @@ -728,20 +731,20 @@ pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ <> pprModuleName (moduleName mod) <> dot -- scope either NameUnqual -> empty -- In scope unqualified -pprUnique :: IsLine doc => Unique -> doc +pprUnique :: Unique -> SDoc -- Print a unique unless we are suppressing them pprUnique uniq = ppUnlessOption sdocSuppressUniques $ pprUniqueAlways uniq -ppr_underscore_unique :: IsLine doc => Unique -> doc +ppr_underscore_unique :: Unique -> SDoc -- Print an underscore separating the name from its unique -- But suppress it if we aren't printing the uniques anyway ppr_underscore_unique uniq = ppUnlessOption sdocSuppressUniques $ char '_' <> pprUniqueAlways uniq -ppr_occ_name :: IsLine doc => OccName -> doc +ppr_occ_name :: OccName -> SDoc ppr_occ_name occ = ftext (occNameFS occ) -- Don't use pprOccName; instead, just print the string of the OccName; -- we print the namespace in the debug stuff above diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index bfc3b8aa95..f48ab2bac5 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -200,7 +200,7 @@ pprNonVarNameSpace :: NameSpace -> SDoc pprNonVarNameSpace VarName = empty pprNonVarNameSpace ns = pprNameSpace ns -pprNameSpaceBrief :: IsLine doc => NameSpace -> doc +pprNameSpaceBrief :: NameSpace -> SDoc pprNameSpaceBrief DataName = char 'd' pprNameSpaceBrief VarName = char 'v' pprNameSpaceBrief TvName = text "tv" @@ -278,10 +278,9 @@ instance OutputableBndr OccName where pprOccName :: IsLine doc => OccName -> doc pprOccName (OccName sp occ) - = docWithContext $ \ sty -> - if codeStyle (sdocStyle sty) - then ztext (zEncodeFS occ) - else ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp)) + = docWithStyle (ztext (zEncodeFS occ)) (\_ -> ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp))) +{-# SPECIALIZE pprOccName :: OccName -> SDoc #-} +{-# SPECIALIZE pprOccName :: OccName -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable {- ************************************************************************ diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index 4fe2b932f6..7439ab7dde 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -166,7 +166,7 @@ instance Outputable InstantiatedModule where instance Outputable InstantiatedUnit where ppr = pprInstantiatedUnit -pprInstantiatedUnit :: IsLine doc => InstantiatedUnit -> doc +pprInstantiatedUnit :: InstantiatedUnit -> SDoc pprInstantiatedUnit uid = -- getPprStyle $ \sty -> pprUnitId cid <> @@ -180,8 +180,6 @@ pprInstantiatedUnit uid = where cid = instUnitInstanceOf uid insts = instUnitInsts uid -{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> SDoc #-} -{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit) -- @@ -203,14 +201,13 @@ instance IsUnitId u => IsUnitId (GenUnit u) where unitFS HoleUnit = holeFS pprModule :: IsLine doc => Module -> doc -pprModule mod@(Module p n) = docWithContext (doc . sdocStyle) +pprModule mod@(Module p n) = docWithStyle code doc where - doc sty - | codeStyle sty = - (if p == mainUnit + code = (if p == mainUnit then empty -- never qualify the main package in code else ztext (zEncodeFS (unitFS p)) <> char '_') <> pprModuleName n + doc sty | qualModule sty mod = case p of HoleUnit -> angleBrackets (pprModuleName n) @@ -352,12 +349,10 @@ stableUnitCmp p1 p2 = unitFS p1 `lexicalCompareFS` unitFS p2 instance Outputable Unit where ppr pk = pprUnit pk -pprUnit :: IsLine doc => Unit -> doc +pprUnit :: Unit -> SDoc pprUnit (RealUnit (Definite d)) = pprUnitId d pprUnit (VirtUnit uid) = pprInstantiatedUnit uid pprUnit HoleUnit = ftext holeFS -{-# SPECIALIZE pprUnit :: Unit -> SDoc #-} -{-# SPECIALIZE pprUnit :: Unit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable instance Show Unit where show = unitString @@ -535,12 +530,8 @@ instance Uniquable UnitId where instance Outputable UnitId where ppr = pprUnitId -pprUnitId :: IsLine doc => UnitId -> doc -pprUnitId (UnitId fs) = dualLine (sdocOption sdocUnitIdForUser ($ fs)) (ftext fs) - -- see Note [Pretty-printing UnitId] in GHC.Unit - -- also see Note [dualLine and dualDoc] in GHC.Utils.Outputable -{-# SPECIALIZE pprUnitId :: UnitId -> SDoc #-} -{-# SPECIALIZE pprUnitId :: UnitId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +pprUnitId :: UnitId -> SDoc +pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- | A 'DefUnitId' is an 'UnitId' with the invariant that -- it only refers to a definite library; i.e., one we have generated diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index b4a21a314e..55e2bb2a9a 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -126,6 +126,7 @@ import GHC.Data.FastString import qualified GHC.Utils.Ppr as Pretty import qualified GHC.Utils.Ppr.Colour as Col import GHC.Utils.Ppr ( Doc, Mode(..) ) +import GHC.Utils.Panic.Plain (assert) import GHC.Serialized import GHC.LanguageExtensions (Extension) import GHC.Utils.GlobalVars( unsafeHasPprDebug ) @@ -855,9 +856,10 @@ ppWhenOption f doc = sdocOption f $ \case False -> empty {-# INLINE CONLIKE ppUnlessOption #-} -ppUnlessOption :: IsLine doc => (SDocContext -> Bool) -> doc -> doc -ppUnlessOption f doc = docWithContext $ - \ctx -> if f ctx then empty else doc +ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc +ppUnlessOption f doc = sdocOption f $ \case + True -> empty + False -> doc -- | Apply the given colour\/style for the argument. -- @@ -1040,10 +1042,7 @@ instance Outputable ModuleName where pprModuleName :: IsLine doc => ModuleName -> doc pprModuleName (ModuleName nm) = - docWithContext $ \ctx -> - if codeStyle (sdocStyle ctx) - then ztext (zEncodeFS nm) - else ftext nm + docWithStyle (ztext (zEncodeFS nm)) (\_ -> ftext nm) {-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-} {-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc] @@ -1633,6 +1632,7 @@ IsOutput, that allows these combinators to be generic over both variants: class IsOutput doc where empty :: doc docWithContext :: (SDocContext -> doc) -> doc + docWithStyle :: doc -> (PprStyle -> SDoc) -> doc class IsOutput doc => IsLine doc class (IsOutput doc, IsLine (Line doc)) => IsDoc doc @@ -1669,13 +1669,22 @@ arguments depending on the type they are instantiated at. They serve as a difficult to make completely equivalent under both printer implementations. These operations should generally be avoided, as they can result in surprising -changes in behavior when the printer implementation is changed. However, in -certain cases, the alternative is even worse. For example, we use dualLine in -the implementation of pprUnitId, as the hack we use for printing unit ids -(see Note [Pretty-printing UnitId] in GHC.Unit) is difficult to adapt to HLine -and is not necessary for code paths that use it, anyway. - -Use these operations wisely. -} +changes in behavior when the printer implementation is changed. +Right now, they are used only when outputting debugging comments in +codegen, as it is difficult to adapt that code to use HLine and not necessary. + +Use these operations wisely. + +Note [docWithStyle] +~~~~~~~~~~~~~~~~~~~ +Sometimes when printing, we consult the printing style. This can be done +with 'docWithStyle c f'. This is similar to 'docWithContext (f . sdocStyle)', +but: +* For code style, 'docWithStyle c f' will return 'c'. +* For other styles, 'docWithStyle c f', will call 'f style', but expect + an SDoc rather than doc. This removes the need to write code polymorphic + in SDoc and HDoc, since the latter is used only for code style. +-} -- | Represents a single line of output that can be efficiently printed directly -- to a 'System.IO.Handle' (actually a 'BufHandle'). @@ -1700,7 +1709,7 @@ pattern HDoc f <- HDoc' f {-# COMPLETE HDoc #-} bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO () -bPutHDoc h ctx (HDoc f) = f ctx h +bPutHDoc h ctx (HDoc f) = assert (codeStyle (sdocStyle ctx)) (f ctx h) -- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty', -- as well as access to the shared 'SDocContext'. @@ -1709,6 +1718,7 @@ bPutHDoc h ctx (HDoc f) = f ctx h class IsOutput doc where empty :: doc docWithContext :: (SDocContext -> doc) -> doc + docWithStyle :: doc -> (PprStyle -> SDoc) -> doc -- see Note [docWithStyle] -- | A class of types that represent a single logical line of text, with support -- for horizontal composition. @@ -1779,6 +1789,11 @@ instance IsOutput SDoc where {-# INLINE CONLIKE empty #-} docWithContext = sdocWithContext {-# INLINE docWithContext #-} + docWithStyle c f = sdocWithContext (\ctx -> let sty = sdocStyle ctx + in if codeStyle sty then c + else f sty) + -- see Note [docWithStyle] + {-# INLINE CONLIKE docWithStyle #-} instance IsLine SDoc where char c = docToSDoc $ Pretty.char c @@ -1823,12 +1838,16 @@ instance IsOutput HLine where {-# INLINE empty #-} docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h {-# INLINE CONLIKE docWithContext #-} + docWithStyle c _ = c -- see Note [docWithStyle] + {-# INLINE CONLIKE docWithStyle #-} instance IsOutput HDoc where empty = HDoc (\_ _ -> pure ()) {-# INLINE empty #-} docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h {-# INLINE CONLIKE docWithContext #-} + docWithStyle c _ = c -- see Note [docWithStyle] + {-# INLINE CONLIKE docWithStyle #-} instance IsLine HLine where char c = HLine (\_ h -> bPutChar h c) |