[Git][ghc/ghc][wip/tyconapp-opts] 2 commits: Optimize dumping of consecutive whitespace.
Ben Gamari
gitlab at gitlab.haskell.org
Mon Dec 14 20:21:45 UTC 2020
Ben Gamari pushed to branch wip/tyconapp-opts at Glasgow Haskell Compiler / GHC
Commits:
c5187fe9 by Andreas Klebinger at 2020-12-14T15:20:15-05:00
Optimize dumping of consecutive whitespace.
The naive way of putting out n characters of indent would be something
like `hPutStr hdl (replicate n ' ')`. However this is quite inefficient
as we allocate an absurd number of strings consisting of simply spaces
as we don't cache them.
To improve on this we now track if we can simply write ascii spaces via
hPutBuf instead. This is the case when running with -ddump-to-file where
we force the encoding to be UTF8.
This avoids both the cost of going through encoding as well as avoiding
allocation churn from all the white space. Instead we simply use hPutBuf
on a preallocated unlifted string.
When dumping stg like this:
> nofib/spectral/simple/Main.hs -fforce-recomp -ddump-stg-final -ddump-to-file -c +RTS -s
Allocations went from 1,778 MB to 1,702MB. About a 4% reduction of
allocation! I did not measure the difference in runtime but expect it
to be similar.
Bumps the haddock submodule since the interface of GHC's Pretty
slightly changed.
-------------------------
Metric Decrease:
T12227
-------------------------
- - - - -
795ff28d by Ben Gamari at 2020-12-14T15:21:31-05:00
Optimise nullary type constructor usage
During the compilation of programs GHC very frequently deals with
the `Type` type, which is a synonym of `TYPE 'LiftedRep`. This patch
teaches GHC to avoid expanding the `Type` synonym (and other nullary
type synonyms) during type comparisons, saving a good amount of work.
This optimisation is described in `Note [Comparing nullary type
synonyms]`.
To maximize the impact of this optimisation, we introduce a few
special-cases to reduce `TYPE 'LiftedRep` to `Type`. See
`Note [Prefer Type over TYPE 'LiftedPtrRep]`.
Closes #17958.
Metric Decrease:
T18698b
T1969
T12227
T12545
T12707
T14683
T3064
T5631
T5642
T9020
T9630
T9872a
T13035
haddock.Cabal
haddock.base
- - - - -
28 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Builtin/Types/Prim.hs
- + compiler/GHC/Builtin/Types/Prim.hs-boot
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Driver/Ppr.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/GHC/Utils/Ppr.hs
- testsuite/tests/deSugar/should_compile/T2431.stderr
- testsuite/tests/deriving/should_compile/T14578.stderr
- testsuite/tests/plugins/plugins09.stdout
- testsuite/tests/plugins/plugins10.stdout
- testsuite/tests/plugins/plugins11.stdout
- testsuite/tests/plugins/static-plugins.stdout
- testsuite/tests/printer/T18052a.stderr
- testsuite/tests/simplCore/should_compile/T13143.stderr
- testsuite/tests/simplCore/should_compile/T18013.stderr
- testsuite/tests/simplCore/should_compile/T7360.stderr
- testsuite/tests/typecheck/should_compile/T13032.stderr
- utils/haddock
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -170,6 +170,7 @@ import GHC.Types.Var (VarBndr (Bndr))
import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
import GHC.Unit.Module ( Module )
import GHC.Core.Type
+import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))
import GHC.Types.RepType
import GHC.Core.DataCon
import GHC.Core.ConLike
@@ -688,8 +689,9 @@ constraintKindTyCon :: TyCon
-- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon!
constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
+-- See Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep.
liftedTypeKind, typeToTypeKind, constraintKind :: Kind
-liftedTypeKind = tYPE liftedRepTy
+liftedTypeKind = TyCoRep.TyConApp liftedTypeKindTyCon []
typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind
constraintKind = mkTyConApp constraintKindTyCon []
@@ -1410,11 +1412,12 @@ runtimeRepTy :: Type
runtimeRepTy = mkTyConTy runtimeRepTyCon
-- Type synonyms; see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim
+-- and Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep.
-- type Type = tYPE 'LiftedRep
liftedTypeKindTyCon :: TyCon
liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName
- [] liftedTypeKind []
- (tYPE liftedRepTy)
+ [] liftedTypeKind [] rhs
+ where rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy]
runtimeRepTyCon :: TyCon
runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []
=====================================
compiler/GHC/Builtin/Types/Prim.hs
=====================================
@@ -551,10 +551,6 @@ mkPrimTcName built_in_syntax occ key tycon
= mkWiredInName gHC_PRIM (mkTcOccFS occ) key (mkATyCon tycon) built_in_syntax
-----------------------------
--- | Given a RuntimeRep, applies TYPE to it.
--- see Note [TYPE and RuntimeRep]
-tYPE :: Type -> Type
-tYPE rr = TyConApp tYPETyCon [rr]
-- Given a Multiplicity, applies FUN to it.
functionWithMultiplicity :: Type -> Type
=====================================
compiler/GHC/Builtin/Types/Prim.hs-boot
=====================================
@@ -0,0 +1,5 @@
+module GHC.Builtin.Types.Prim where
+
+import GHC.Core.TyCon
+
+tYPETyCon :: TyCon
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -52,6 +52,7 @@ module GHC.Core.TyCo.Rep (
mkVisFunTyMany, mkVisFunTysMany,
mkInvisFunTyMany, mkInvisFunTysMany,
mkTyConApp,
+ tYPE,
-- * Functions over binders
TyCoBinder(..), TyCoVarBinder, TyBinder,
@@ -90,8 +91,9 @@ import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom
-- others
-import GHC.Builtin.Names ( liftedTypeKindTyConKey, manyDataConKey )
-import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, manyDataConTy )
+import GHC.Builtin.Names ( liftedTypeKindTyConKey, liftedRepDataConKey, manyDataConKey, tYPETyConKey )
+import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, liftedTypeKind, manyDataConTy )
+import {-# SOURCE #-} GHC.Builtin.Types.Prim ( tYPETyCon )
import GHC.Types.Basic ( LeftOrRight(..), pickLR )
import GHC.Types.Unique ( hasKey, Uniquable(..) )
import GHC.Utils.Outputable
@@ -1009,7 +1011,7 @@ mkTyConApp tycon tys
-- The FunTyCon (->) is always a visible one
= FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 }
- -- Note [mkTyConApp and Type]
+ -- See Note [Prefer Type over TYPE 'LiftedRep]
| tycon `hasKey` liftedTypeKindTyConKey
= ASSERT2( null tys, ppr tycon $$ ppr tys )
liftedTypeKindTyConApp
@@ -1018,21 +1020,21 @@ mkTyConApp tycon tys
-- avoid reboxing every time `mkTyConApp` is called.
= ASSERT2( null tys, ppr tycon $$ ppr tys )
manyDataConTy
+ -- See Note [Prefer Type over TYPE 'LiftedRep].
+ | tycon `hasKey` tYPETyConKey
+ , [rep] <- tys
+ = tYPE rep
+ -- The catch-all case
| otherwise
= TyConApp tycon tys
--- This is a single, global definition of the type `Type`
--- Defined here so it is only allocated once.
--- See Note [mkTyConApp and Type]
-liftedTypeKindTyConApp :: Type
-liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon []
-
{-
-Note [mkTyConApp and Type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Whilst benchmarking it was observed in #17292 that GHC allocated a lot
-of `TyConApp` constructors. Upon further inspection a large number of these
-TyConApp constructors were all duplicates of `Type` applied to no arguments.
+Note [Prefer Type over TYPE 'LiftedRep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The Core of nearly any program will have numerous occurrences of
+ at TYPE 'LiftedRep@ (and, equivalently, 'Type') floating about. Concretely, while
+investigating #17292 we found that these constituting a majority of TyConApp
+constructors on the heap:
```
(From a sample of 100000 TyConApp closures)
@@ -1046,12 +1048,59 @@ TyConApp constructors were all duplicates of `Type` applied to no arguments.
0x45e68fd - 538 - `TYPE ...`
```
-Therefore in `mkTyConApp` we have a special case for `Type` to ensure that
-only one `TyConApp 'Type []` closure is allocated during the course of
-compilation. In order to avoid a potentially expensive series of checks in
-`mkTyConApp` only this egregious case is special cased at the moment.
+Consequently, we try hard to ensure that operations on such types are
+efficient. Specifically, we strive to
+
+ a. Avoid heap allocation of such types
+ b. Use a small (shallow in the tree-depth sense) representation
+ for such types
+
+Goal (b) is particularly useful as it makes traversals (e.g. free variable
+traversal, substitution, and comparison) more efficient.
+Comparison in particular takes special advantage of nullary type synonym
+applications (e.g. things like @TyConApp typeTyCon []@), Note [Comparing
+nullary type synonyms] in "GHC.Core.Type".
+
+To accomplish these we use a number of tricks:
+
+ 1. Instead of representing the lifted kind as
+ @TyConApp tYPETyCon [liftedRepDataCon]@ we rather prefer to
+ use the 'GHC.Types.Type' type synonym (represented as a nullary TyConApp).
+ This serves goal (b) since there are no applied type arguments to traverse,
+ e.g., during comparison.
+
+ 2. We have a top-level binding to represent `TyConApp GHC.Types.Type []`
+ (namely 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we
+ don't need to allocate such types (goal (a)).
+
+ 3. To avoid allocating 'TyConApp' constructors the
+ 'GHC.Builtin.Types.Prim.tYPE' function catches the lifted case and returns
+ `liftedTypeKind` instead of building an application (goal (a)).
+
+ 4. Similarly, 'Type.mkTyConApp' catches applications of `TYPE` and
+ handles them using 'GHC.Builtin.Types.Prim.tYPE', ensuring
+ that it benefits from the optimisation described above (goal (a)).
+
+Note that it's quite important that we do not define 'liftedTypeKind' in terms
+of 'mkTyConApp' since this tricks (1) and (4) would then result in a loop.
+
+See #17958.
-}
+-- | Given a RuntimeRep, applies TYPE to it.
+-- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.
+tYPE :: Type -> Type
+tYPE (TyConApp tc [])
+ -- See Note [Prefer Type of TYPE 'LiftedRep]
+ | tc `hasKey` liftedRepDataConKey = liftedTypeKind -- TYPE 'LiftedRep
+tYPE rr = TyConApp tYPETyCon [rr]
+
+-- This is a single, global definition of the type `Type`
+-- Defined here so it is only allocated once.
+-- See Note [Prefer Type over TYPE 'LiftedRep] in this module.
+liftedTypeKindTyConApp :: Type
+liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon []
+
{-
%************************************************************************
%* *
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -424,6 +424,7 @@ zipTCvSubst tcvs tys
-- | Generates the in-scope set for the 'TCvSubst' from the types in the
-- incoming environment. No CoVars, please!
mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst
+mkTvSubstPrs [] = emptyTCvSubst
mkTvSubstPrs prs =
ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )
mkTvSubst in_scope tenv
@@ -741,7 +742,8 @@ subst_ty subst ty
go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys
-- NB: mkTyConApp, not TyConApp.
-- mkTyConApp has optimizations.
- -- See Note [mkTyConApp and Type] in GHC.Core.TyCo.Rep
+ -- See Note [Prefer Type over TYPE 'LiftedRep]
+ -- in GHC.Core.TyCo.Rep
go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res })
= let !mult' = go mult
!arg' = go arg
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -2327,12 +2327,14 @@ expandSynTyCon_maybe
-- ^ Expand a type synonym application, if any
expandSynTyCon_maybe tc tys
| SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc
- = case tys `listLengthCmp` arity of
- GT -> Just (tvs `zip` tys, rhs, drop arity tys)
- EQ -> Just (tvs `zip` tys, rhs, [])
- LT -> Nothing
- | otherwise
- = Nothing
+ = case tys of
+ [] -> Just ([], rhs, []) -- Avoid a bit of work in the case of nullary synonyms
+ _ -> case tys `listLengthCmp` arity of
+ GT -> Just (tvs `zip` tys, rhs, drop arity tys)
+ EQ -> Just (tvs `zip` tys, rhs, [])
+ LT -> Nothing
+ | otherwise
+ = Nothing
----------------
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -383,34 +383,28 @@ how roles in kinds might work out.
-}
-- | Gives the typechecker view of a type. This unwraps synonyms but
--- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into
--- TYPE LiftedRep. Returns Nothing if no unwrapping happens.
+-- leaves 'Constraint' alone. c.f. 'coreView', which turns 'Constraint' into
+-- 'Type'. Returns 'Nothing' if no unwrapping happens.
-- See also Note [coreView vs tcView]
-{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
-tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
- = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')
- -- The free vars of 'rhs' should all be bound by 'tenv', so it's
- -- ok to use 'substTy' here.
- -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.
- -- Its important to use mkAppTys, rather than (foldl AppTy),
- -- because the function part might well return a
- -- partially-applied type constructor; indeed, usually will!
+tcView (TyConApp tc tys)
+ | res@(Just _) <- expandSynTyConApp_maybe tc tys
+ = res
tcView _ = Nothing
+-- See Note [Inlining coreView].
+{-# INLINE tcView #-}
-{-# INLINE coreView #-}
coreView :: Type -> Maybe Type
--- ^ This function Strips off the /top layer only/ of a type synonym
+-- ^ This function strips off the /top layer only/ of a type synonym
-- application (if any) its underlying representation type.
--- Returns Nothing if there is nothing to look through.
--- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep at .
+-- Returns 'Nothing' if there is nothing to look through.
+-- This function considers 'Constraint' to be a synonym of @Type at .
--
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
coreView ty@(TyConApp tc tys)
- | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
- = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')
- -- This equation is exactly like tcView
+ | res@(Just _) <- expandSynTyConApp_maybe tc tys
+ = res
-- At the Core level, Constraint = Type
-- See Note [coreView vs tcView]
@@ -419,8 +413,48 @@ coreView ty@(TyConApp tc tys)
Just liftedTypeKind
coreView _ = Nothing
+-- See Note [Inlining coreView].
+{-# INLINE coreView #-}
+
+-----------------------------------------------
+
+-- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@
+-- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a
+-- synonym.
+expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type
+expandSynTyConApp_maybe tc tys
+ | Just (tvs, rhs) <- synTyConDefn_maybe tc
+ , tys `lengthAtLeast` arity
+ = Just (expand_syn arity tvs rhs tys)
+ | otherwise
+ = Nothing
+ where
+ arity = tyConArity tc
+-- Without this INLINE the call to expandSynTyConApp_maybe in coreView
+-- will result in an avoidable allocation.
+{-# INLINE expandSynTyConApp_maybe #-}
+
+-- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path
+-- into call-sites.
+expand_syn :: Int -- ^ the arity of the synonym
+ -> [TyVar] -- ^ the variables bound by the synonym
+ -> Type -- ^ the RHS of the synonym
+ -> [Type] -- ^ the type arguments the synonym is instantiated at.
+ -> Type
+expand_syn arity tvs rhs tys
+ | tys `lengthExceeds` arity = mkAppTys rhs' (drop arity tys)
+ | otherwise = rhs'
+ where
+ rhs' = substTy (mkTvSubstPrs (tvs `zip` tys)) rhs
+ -- The free vars of 'rhs' should all be bound by 'tenv', so it's
+ -- ok to use 'substTy' here (which is what expandSynTyConApp_maybe does).
+ -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.
+ -- Its important to use mkAppTys, rather than (foldl AppTy),
+ -- because the function part might well return a
+ -- partially-applied type constructor; indeed, usually will!
+-- We never want to inline this cold-path.
+{-# INLINE expand_syn #-}
-{-# INLINE coreFullView #-}
coreFullView :: Type -> Type
-- ^ Iterates 'coreView' until there is no more to synonym to expand.
-- See Note [Inlining coreView].
@@ -432,6 +466,7 @@ coreFullView ty@(TyConApp tc _)
| otherwise = ty
coreFullView ty = ty
+{-# INLINE coreFullView #-}
{- Note [Inlining coreView] in GHC.Core.Type
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2207,6 +2242,36 @@ But the left is an AppTy while the right is a TyConApp. The solution is
to use repSplitAppTy_maybe to break up the TyConApp into its pieces and
then continue. Easy to do, but also easy to forget to do.
+
+Note [Comparing nullary type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the task of testing equality between two 'Type's of the form
+
+ TyConApp tc []
+
+where @tc@ is a type synonym. A naive way to perform this comparison these
+would first expand the synonym and then compare the resulting expansions.
+
+However, this is obviously wasteful and the RHS of @tc@ may be large; it is
+much better to rather compare the TyCons directly. Consequently, before
+expanding type synonyms in type comparisons we first look for a nullary
+TyConApp and simply compare the TyCons if we find one. Of course, if we find
+that the TyCons are *not* equal then we still need to perform the expansion as
+their RHSs may still be equal.
+
+We perform this optimisation in a number of places:
+
+ * GHC.Core.Types.eqType
+ * GHC.Core.Types.nonDetCmpType
+ * GHC.Core.Unify.unify_ty
+ * TcCanonical.can_eq_nc'
+ * TcUnify.uType
+
+This optimisation is especially helpful for the ubiquitous GHC.Types.Type,
+since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications
+whenever possible. See [Prefer Type over TYPE 'LiftedRep] in
+GHC.Core.TyCo.Rep for details.
+
-}
eqType :: Type -> Type -> Bool
@@ -2318,6 +2383,10 @@ nonDetCmpTypeX env orig_t1 orig_t2 =
-- Returns both the resulting ordering relation between the two types
-- and whether either contains a cast.
go :: RnEnv2 -> Type -> Type -> TypeOrdering
+ -- See Note [Comparing nullary type synonyms].
+ go _ (TyConApp tc1 []) (TyConApp tc2 [])
+ | tc1 == tc2
+ = TEQ
go env t1 t2
| Just t1' <- coreView t1 = go env t1' t2
| Just t2' <- coreView t2 = go env t1 t2'
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -957,7 +957,12 @@ unify_ty :: UMEnv
-- Respects newtypes, PredTypes
unify_ty env ty1 ty2 kco
- -- Use tcView, not coreView. See Note [coreView vs tcView] in GHC.Core.Type.
+ -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
+ | TyConApp tc1 [] <- ty1
+ , TyConApp tc2 [] <- ty2
+ , tc1 == tc2 = return ()
+
+ -- TODO: More commentary needed here
| Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco
| Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco
| CastTy ty1' co <- ty1 = if um_unif env
=====================================
compiler/GHC/Driver/Ppr.hs
=====================================
@@ -66,7 +66,7 @@ showSDocDebug dflags d = renderWithContext ctx d
printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()
printForUser dflags handle unqual depth doc
- = printSDocLn ctx PageMode handle doc
+ = printSDocLn ctx (PageMode False) handle doc
where ctx = initSDocContext dflags (mkUserStyle unqual depth)
-- | Like 'printSDocLn' but specialized with 'LeftMode' and
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1365,7 +1365,7 @@ defaultFatalMessager = hPutStrLn stderr
jsonLogAction :: LogAction
jsonLogAction dflags reason severity srcSpan msg
=
- defaultLogActionHPutStrDoc dflags stdout
+ defaultLogActionHPutStrDoc dflags True stdout
(withPprStyle (PprCode CStyle) (doc $$ text ""))
where
str = renderWithContext (initSDocContext dflags defaultUserStyle) msg
@@ -1388,9 +1388,9 @@ defaultLogAction dflags reason severity srcSpan msg
SevWarning -> printWarns
SevError -> printWarns
where
- printOut = defaultLogActionHPrintDoc dflags stdout
- printErrs = defaultLogActionHPrintDoc dflags stderr
- putStrSDoc = defaultLogActionHPutStrDoc dflags stdout
+ printOut = defaultLogActionHPrintDoc dflags False stdout
+ printErrs = defaultLogActionHPrintDoc dflags False stderr
+ putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout
-- Pretty print the warning flag, if any (#10752)
message = mkLocMessageAnn flagMsg severity srcSpan msg
@@ -1430,16 +1430,19 @@ defaultLogAction dflags reason severity srcSpan msg
| otherwise = ""
-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
-defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> IO ()
-defaultLogActionHPrintDoc dflags h d
- = defaultLogActionHPutStrDoc dflags h (d $$ text "")
-
-defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> IO ()
-defaultLogActionHPutStrDoc dflags h d
+defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
+defaultLogActionHPrintDoc dflags asciiSpace h d
+ = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "")
+
+-- | The boolean arguments let's the pretty printer know if it can optimize indent
+-- by writing ascii ' ' characters without going through decoding.
+defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
+defaultLogActionHPutStrDoc dflags asciiSpace h d
-- Don't add a newline at the end, so that successive
-- calls to this log-action can output all on the same line
- = printSDoc ctx Pretty.PageMode h d
- where ctx = initSDocContext dflags defaultUserStyle
+ = printSDoc ctx (Pretty.PageMode asciiSpace) h d
+ where
+ ctx = initSDocContext dflags defaultUserStyle
newtype FlushOut = FlushOut (IO ())
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -956,6 +956,11 @@ can_eq_nc'
-> Type -> Type -- RHS, after and before type-synonym expansion, resp
-> TcS (StopOrContinue Ct)
+-- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2
+ | tc1 == tc2
+ = canEqReflexive ev eq_rel ty1
+
-- Expand synonyms first; see Note [Type synonyms and canonicalization]
can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
| Just ty1' <- tcView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -120,7 +120,6 @@ import GHC.Types.Id as Id
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
import GHC.Types.Var.Env
import GHC.Types.Name.Env
import GHC.Utils.Misc
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -1581,6 +1581,11 @@ tc_eq_type keep_syns vis_only orig_ty1 orig_ty2
= go orig_env orig_ty1 orig_ty2
where
go :: RnEnv2 -> Type -> Type -> Bool
+ -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
+ go _ (TyConApp tc1 []) (TyConApp tc2 [])
+ | tc1 == tc2
+ = True
+
go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2
go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2'
=====================================
compiler/GHC/Utils/Error.hs
=====================================
@@ -327,7 +327,8 @@ dumpSDocWithStyle sty dflags dumpOpt hdr doc =
$$ blankLine
$$ doc
return $ mkDumpDoc hdr d
- defaultLogActionHPrintDoc dflags handle (withPprStyle sty doc')
+ -- When we dump to files we use UTF8. Which allows ascii spaces.
+ defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc')
-- write the dump to stdout
writeDump Nothing = do
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -567,7 +567,7 @@ pprCode cs d = withPprStyle (PprCode cs) d
renderWithContext :: SDocContext -> SDoc -> String
renderWithContext ctx sdoc
- = let s = Pretty.style{ Pretty.mode = PageMode,
+ = let s = Pretty.style{ Pretty.mode = PageMode False,
Pretty.lineLength = sdocLineLength ctx }
in Pretty.renderStyle s $ runSDoc sdoc ctx
=====================================
compiler/GHC/Utils/Ppr.hs
=====================================
@@ -917,16 +917,26 @@ data Style
, ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length
}
--- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).
+-- | The default style (@mode=PageMode False, lineLength=100, ribbonsPerLine=1.5@).
style :: Style
-style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
+style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode False }
-- | Rendering mode.
-data Mode = PageMode -- ^ Normal
+data Mode = PageMode { asciiSpace :: Bool } -- ^ Normal
| ZigZagMode -- ^ With zig-zag cuts
| LeftMode -- ^ No indentation, infinitely long lines
| OneLineMode -- ^ All on one line
+-- | Can we output an ascii space character for spaces?
+-- Mostly true, but not for e.g. UTF16
+-- See Note [putSpaces optimizations] for why we bother
+-- to track this.
+hasAsciiSpace :: Mode -> Bool
+hasAsciiSpace mode =
+ case mode of
+ PageMode asciiSpace -> asciiSpace
+ _ -> False
+
-- | Render the @Doc@ to a String using the given @Style at .
renderStyle :: Style -> Doc -> String
renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
@@ -1034,6 +1044,20 @@ printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
-- printDoc adds a newline to the end
printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "")
+{- Note [putSpaces optimizations]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When using dump flags a lot of what we are dumping ends up being whitespace.
+This is especially true for Core/Stg dumps. Enough so that it's worth optimizing.
+
+Especially in the common case of writing to an UTF8 or similarly encoded file
+where space is equal to ascii space we use hPutBuf to write a preallocated
+buffer to the file. This avoids a fair bit of allocation.
+
+For other cases we fall back to the old and slow path for simplicity.
+
+-}
+
printDoc_ :: Mode -> Int -> Handle -> Doc -> IO ()
-- printDoc_ does not add a newline at the end, so that
-- successive calls can output stuff on the same line
@@ -1051,9 +1075,27 @@ printDoc_ mode pprCols hdl doc
-- the I/O library's encoding layer. (#3398)
put (ZStr s) next = hPutFZS hdl s >> next
put (LStr s) next = hPutPtrString hdl s >> next
- put (RStr n c) next = hPutStr hdl (replicate n c) >> next
+ put (RStr n c) next
+ | c == ' '
+ = putSpaces n >> next
+ | otherwise
+ = hPutStr hdl (replicate n c) >> next
+ putSpaces n
+ -- If we use ascii spaces we are allowed to use hPutBuf
+ -- See Note [putSpaces optimizations]
+ | hasAsciiSpace mode
+ , n <= 100
+ = hPutBuf hdl (Ptr spaces') n
+ | hasAsciiSpace mode
+ , n > 100
+ = hPutBuf hdl (Ptr spaces') 100 >> putSpaces (n-100)
+
+ | otherwise = hPutStr hdl (replicate n ' ')
done = return () -- hPutChar hdl '\n'
+ -- 100 spaces, so we avoid the allocation of replicate n ' '
+ spaces' = " "#
+
-- some versions of hPutBuf will barf if the length is zero
hPutPtrString :: Handle -> PtrString -> IO ()
=====================================
testsuite/tests/deSugar/should_compile/T2431.stderr
=====================================
@@ -1,9 +1,9 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 63, types: 43, coercions: 1, joins: 0/0}
+ = {terms: 63, types: 39, coercions: 1, joins: 0/0}
--- RHS size: {terms: 2, types: 4, coercions: 1, joins: 0/0}
+-- RHS size: {terms: 2, types: 3, coercions: 1, joins: 0/0}
T2431.$WRefl [InlPrag=INLINE[final] CONLIKE] :: forall a. a :~: a
[GblId[DataConWrapper],
Caf=NoCafRefs,
@@ -15,7 +15,7 @@ T2431.$WRefl [InlPrag=INLINE[final] CONLIKE] :: forall a. a :~: a
T2431.$WRefl
= \ (@a) -> T2431.Refl @a @a @~(<a>_N :: a GHC.Prim.~# a)
--- RHS size: {terms: 4, types: 8, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 4, types: 7, coercions: 0, joins: 0/0}
absurd :: forall a. (Int :~: Bool) -> a
[GblId, Arity=1, Str=<U>b, Cpr=b, Unf=OtherCon []]
absurd = \ (@a) (x :: Int :~: Bool) -> case x of { }
=====================================
testsuite/tests/deriving/should_compile/T14578.stderr
=====================================
@@ -16,13 +16,12 @@ Derived class instances:
= GHC.Prim.coerce
@(T14578.App (Data.Functor.Compose.Compose f g) a
-> T14578.App (Data.Functor.Compose.Compose f g) a
- -> T14578.App (Data.Functor.Compose.Compose f g) a)
+ -> T14578.App (Data.Functor.Compose.Compose f g) a)
@(T14578.Wat f g a -> T14578.Wat f g a -> T14578.Wat f g a)
((GHC.Base.<>) @(T14578.App (Data.Functor.Compose.Compose f g) a))
GHC.Base.sconcat
= GHC.Prim.coerce
- @(GHC.Base.NonEmpty
- (T14578.App (Data.Functor.Compose.Compose f g) a)
+ @(GHC.Base.NonEmpty (T14578.App (Data.Functor.Compose.Compose f g) a)
-> T14578.App (Data.Functor.Compose.Compose f g) a)
@(GHC.Base.NonEmpty (T14578.Wat f g a) -> T14578.Wat f g a)
(GHC.Base.sconcat
@@ -31,7 +30,7 @@ Derived class instances:
= GHC.Prim.coerce
@(b
-> T14578.App (Data.Functor.Compose.Compose f g) a
- -> T14578.App (Data.Functor.Compose.Compose f g) a)
+ -> T14578.App (Data.Functor.Compose.Compose f g) a)
@(b -> T14578.Wat f g a -> T14578.Wat f g a)
(GHC.Base.stimes
@(T14578.App (Data.Functor.Compose.Compose f g) a))
=====================================
testsuite/tests/plugins/plugins09.stdout
=====================================
@@ -3,6 +3,5 @@ interfacePlugin: Prelude
interfacePlugin: GHC.Float
interfacePlugin: GHC.Base
typeCheckPlugin (rn)
-interfacePlugin: GHC.Types
typeCheckPlugin (tc)
interfacePlugin: GHC.Num.BigNat
=====================================
testsuite/tests/plugins/plugins10.stdout
=====================================
@@ -6,7 +6,6 @@ interfacePlugin: GHC.Float
interfacePlugin: GHC.Base
interfacePlugin: Language.Haskell.TH.Syntax
typeCheckPlugin (rn)
-interfacePlugin: GHC.Types
typeCheckPlugin (tc)
interfacePlugin: GHC.Num.BigNat
parsePlugin(a)
=====================================
testsuite/tests/plugins/plugins11.stdout
=====================================
@@ -3,6 +3,5 @@ interfacePlugin: Prelude
interfacePlugin: GHC.Float
interfacePlugin: GHC.Base
typeCheckPlugin (rn)
-interfacePlugin: GHC.Types
typeCheckPlugin (tc)
interfacePlugin: GHC.Num.BigNat
=====================================
testsuite/tests/plugins/static-plugins.stdout
=====================================
@@ -5,11 +5,11 @@ interfacePlugin: GHC.Float
interfacePlugin: GHC.Base
interfacePlugin: System.IO
typeCheckPlugin (rn)
-interfacePlugin: GHC.Prim
-interfacePlugin: GHC.Show
interfacePlugin: GHC.Types
+interfacePlugin: GHC.Show
interfacePlugin: GHC.TopHandler
typeCheckPlugin (tc)
+interfacePlugin: GHC.Prim
interfacePlugin: GHC.CString
interfacePlugin: GHC.Num.BigNat
==pure.1
=====================================
testsuite/tests/printer/T18052a.stderr
=====================================
@@ -10,9 +10,9 @@ Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0]
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 24, types: 61, coercions: 0, joins: 0/0}
+ = {terms: 24, types: 52, coercions: 0, joins: 0/0}
--- RHS size: {terms: 7, types: 8, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 7, types: 6, coercions: 0, joins: 0/0}
T18052a.$b:||: :: forall {a} {b}. a -> b -> (a, b)
[GblId, Arity=2, Unf=OtherCon []]
T18052a.$b:||: = \ (@a) (@b) (x :: a) (y :: b) -> (x, y)
@@ -22,7 +22,7 @@ T18052a.$b:||: = \ (@a) (@b) (x :: a) (y :: b) -> (x, y)
[GblId]
(+++) = ++
--- RHS size: {terms: 13, types: 20, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 13, types: 18, coercions: 0, joins: 0/0}
T18052a.$m:||:
:: forall {rep :: GHC.Types.RuntimeRep} {r :: TYPE rep} {a} {b}.
(a, b) -> (a -> b -> r) -> ((# #) -> r) -> r
=====================================
testsuite/tests/simplCore/should_compile/T13143.stderr
=====================================
@@ -1,17 +1,17 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 71, types: 44, coercions: 0, joins: 0/0}
+ = {terms: 71, types: 40, coercions: 0, joins: 0/0}
Rec {
--- RHS size: {terms: 4, types: 4, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0}
T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker]
:: forall {a}. (# #) -> a
[GblId, Arity=1, Str=<B>b, Cpr=b, Unf=OtherCon []]
T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.(##)
end Rec }
--- RHS size: {terms: 4, types: 4, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0}
f [InlPrag=[final]] :: forall a. Int -> a
[GblId,
Arity=1,
=====================================
testsuite/tests/simplCore/should_compile/T18013.stderr
=====================================
@@ -129,9 +129,9 @@ Rule fired: Class op fmap (BUILTIN)
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 52, types: 106, coercions: 17, joins: 0/1}
+ = {terms: 52, types: 101, coercions: 17, joins: 0/1}
--- RHS size: {terms: 37, types: 87, coercions: 17, joins: 0/1}
+-- RHS size: {terms: 37, types: 84, coercions: 17, joins: 0/1}
mapMaybeRule
:: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b)
[GblId,
=====================================
testsuite/tests/simplCore/should_compile/T7360.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 106, types: 47, coercions: 0, joins: 0/0}
+ = {terms: 106, types: 45, coercions: 0, joins: 0/0}
-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo
@@ -31,7 +31,7 @@ T7360.fun4 :: ()
WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}]
T7360.fun4 = fun1 T7360.Foo1
--- RHS size: {terms: 11, types: 8, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 11, types: 7, coercions: 0, joins: 0/0}
fun2 :: forall {a}. [a] -> ((), Int)
[GblId,
Arity=1,
=====================================
testsuite/tests/typecheck/should_compile/T13032.stderr
=====================================
@@ -1,9 +1,9 @@
==================== Desugar (after optimization) ====================
Result size of Desugar (after optimization)
- = {terms: 13, types: 24, coercions: 0, joins: 0/0}
+ = {terms: 13, types: 18, coercions: 0, joins: 0/0}
--- RHS size: {terms: 6, types: 11, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 6, types: 8, coercions: 0, joins: 0/0}
f :: forall a b. (a ~ b) => a -> b -> Bool
[LclIdX,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit acf235d607879eb9542127eb0ddb42a250b5b850
+Subproject commit 48c4982646b7fe6343ccdf1581c97a7735fe8940
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7c1056ef11209a5a5133438213a2a294a9772a57...795ff28d72a83b0f4dad9087b82d0cd825c84c4b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7c1056ef11209a5a5133438213a2a294a9772a57...795ff28d72a83b0f4dad9087b82d0cd825c84c4b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201214/8cc3b1c4/attachment-0001.html>
More information about the ghc-commits
mailing list