Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/ca380cd19530fad4860e42844e42a473188e0013 >--------------------------------------------------------------- commit ca380cd19530fad4860e42844e42a473188e0013 Author: Simon Peyton Jones <[email protected]> Date: Fri Oct 21 17:53:30 2011 +0100 Recover proper sharing for Integer literals Trac #5549 showed a loss of performance for GHC 7.4. What was happening was that an integer literal was being allocated each time around a loop, rather than being floated to top level and shared. Two fixes * Make the float-out pass float literals that are non-trivial * Make the inliner *not* treat Integer literals as size-zero >--------------------------------------------------------------- compiler/basicTypes/Literal.lhs | 30 +++++++++++++++++------------- compiler/coreSyn/CoreUnfold.lhs | 14 +++++++++++++- compiler/coreSyn/PprCore.lhs | 13 ++++++------- compiler/simplCore/SetLevels.lhs | 14 +++++++++++++- 4 files changed, 49 insertions(+), 22 deletions(-) diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index c3840c8..889cd24 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -23,6 +23,7 @@ module Literal , literalType , hashLiteral , absentLiteralOf + , pprLiteral -- ** Predicates on Literals and their contents , litIsDupable, litIsTrivial @@ -199,7 +200,7 @@ instance Binary Literal where \begin{code} instance Outputable Literal where - ppr lit = pprLit lit + ppr lit = pprLiteral (\d -> d) lit instance Show Literal where showsPrec p lit = showsPrecSDoc p (ppr lit) @@ -437,21 +438,24 @@ litTag (LitInteger {}) = _ILIT(11) exceptions: MachFloat gets an initial keyword prefix. \begin{code} -pprLit :: Literal -> SDoc -pprLit (MachChar ch) = pprHsChar ch -pprLit (MachStr s) = pprHsString s -pprLit (MachInt i) = pprIntVal i -pprLit (MachInt64 i) = ptext (sLit "__int64") <+> integer i -pprLit (MachWord w) = ptext (sLit "__word") <+> integer w -pprLit (MachWord64 w) = ptext (sLit "__word64") <+> integer w -pprLit (MachFloat f) = ptext (sLit "__float") <+> float (fromRat f) -pprLit (MachDouble d) = double (fromRat d) -pprLit (MachNullAddr) = ptext (sLit "__NULL") -pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod +pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc +-- The function is used on non-atomic literals +-- to wrap parens around literals that occur in +-- a context requiring an atomic thing +pprLiteral _ (MachChar ch) = pprHsChar ch +pprLiteral _ (MachStr s) = pprHsString s +pprLiteral _ (MachInt i) = pprIntVal i +pprLiteral _ (MachDouble d) = double (fromRat d) +pprLiteral _ (MachNullAddr) = ptext (sLit "__NULL") +pprLiteral add_par (LitInteger i _) = add_par (ptext (sLit "__integer") <+> integer i) +pprLiteral add_par (MachInt64 i) = add_par (ptext (sLit "__int64") <+> integer i) +pprLiteral add_par (MachWord w) = add_par (ptext (sLit "__word") <+> integer w) +pprLiteral add_par (MachWord64 w) = add_par (ptext (sLit "__word64") <+> integer w) +pprLiteral add_par (MachFloat f) = add_par (ptext (sLit "__float") <+> float (fromRat f)) +pprLiteral add_par (MachLabel l mb fod) = add_par (ptext (sLit "__label") <+> b <+> ppr fod) where b = case mb of Nothing -> pprHsString l Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) -pprLit (LitInteger i _) = ptext (sLit "__integer") <+> integer i pprIntVal :: Integer -> SDoc -- ^ Print negative integers with parens to be sure it's unambiguous diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 165450b..429cce9 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -491,7 +491,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr -- | Finds a nominal size of a string literal. litSize :: Literal -> Int -- Used by CoreUnfold.sizeExpr -litSize (MachStr str) = 10 + 10 * ((lengthFS str + 3) `div` 4) +litSize (LitInteger {}) = 100 -- Note [Size of literal integers] +litSize (MachStr str) = 10 + 10 * ((lengthFS str + 3) `div` 4) -- If size could be 0 then @f "x"@ might be too small -- [Sept03: make literal strings a bit bigger to avoid fruitless -- duplication of little strings] @@ -556,6 +557,17 @@ conSize dc n_val_args -- [SDM, 25/5/11] \end{code} +Note [Literal integer size] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal integers *can* be big (mkInteger [...coefficients...]), but +need not be (S# n). We just use an aribitrary big-ish constant here +so that, in particular, we don't inline top-level defns like + n = S# 5 +There's no point in doing so -- any optimsations will see the S# +through n's unfolding. Nor will a big size inhibit unfoldings functions +that mention a literal Integer, because the float-out pass will float +all those constants to top level. + Note [Constructor size] ~~~~~~~~~~~~~~~~~~~~~~~ Treat a constructors application as size 1, regardless of how many diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 8f83a4c..8128f50 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -14,6 +14,7 @@ module PprCore ( import CoreSyn import CostCentre +import Literal( pprLiteral ) import Var import Id import IdInfo @@ -94,8 +95,8 @@ ppr_binding (val_bdr, expr) \end{code} \begin{code} -pprParendExpr expr = ppr_expr parens expr -pprCoreExpr expr = ppr_expr noParens expr +pprParendExpr expr = ppr_expr parens expr +pprCoreExpr expr = ppr_expr noParens expr noParens :: SDoc -> SDoc noParens pp = pp @@ -106,12 +107,10 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) -ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd - +ppr_expr _ (Var name) = ppr name +ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co) - -ppr_expr _ (Var name) = ppr name -ppr_expr _ (Lit lit) = ppr lit +ppr_expr add_par (Lit lit) = pprLiteral add_par lit ppr_expr add_par (Cast expr co) = add_par $ diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 6603f73..50e547d 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -67,6 +67,7 @@ import IdInfo import Var import VarSet import VarEnv +import Literal ( litIsTrivial ) import Demand ( StrictSig, increaseStrictSigArity ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) @@ -569,7 +570,8 @@ notWorthFloating e abs_vars = go e (count isId abs_vars) where go (_, AnnVar {}) n = n >= 0 - go (_, AnnLit {}) n = n >= 0 + go (_, AnnLit lit) n = ASSERT( n==0 ) + litIsTrivial lit -- Note [Floating literals] go (_, AnnCast e _) n = go e n go (_, AnnApp e arg) n | (_, AnnType {}) <- arg = go e n @@ -587,6 +589,16 @@ notWorthFloating e abs_vars is_triv _ = False \end{code} +Note [Floating literals] +~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to float Integer literals, so that they get shared, +rather than being allocated every time round the loop. +Hence the litIsTrivial. + +We'd *like* to share MachStr literal strings too, mainly so we could +CSE them, but alas can't do so directly because they are unlifted. + + Note [Escaping a value lambda] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to float even cheap expressions out of value lambdas, _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
