Commit ca380cd1 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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
parent 2ad79aaa
...@@ -23,6 +23,7 @@ module Literal ...@@ -23,6 +23,7 @@ module Literal
, literalType , literalType
, hashLiteral , hashLiteral
, absentLiteralOf , absentLiteralOf
, pprLiteral
-- ** Predicates on Literals and their contents -- ** Predicates on Literals and their contents
, litIsDupable, litIsTrivial , litIsDupable, litIsTrivial
...@@ -199,7 +200,7 @@ instance Binary Literal where ...@@ -199,7 +200,7 @@ instance Binary Literal where
\begin{code} \begin{code}
instance Outputable Literal where instance Outputable Literal where
ppr lit = pprLit lit ppr lit = pprLiteral (\d -> d) lit
instance Show Literal where instance Show Literal where
showsPrec p lit = showsPrecSDoc p (ppr lit) showsPrec p lit = showsPrecSDoc p (ppr lit)
...@@ -437,21 +438,24 @@ litTag (LitInteger {}) = _ILIT(11) ...@@ -437,21 +438,24 @@ litTag (LitInteger {}) = _ILIT(11)
exceptions: MachFloat gets an initial keyword prefix. exceptions: MachFloat gets an initial keyword prefix.
\begin{code} \begin{code}
pprLit :: Literal -> SDoc pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
pprLit (MachChar ch) = pprHsChar ch -- The function is used on non-atomic literals
pprLit (MachStr s) = pprHsString s -- to wrap parens around literals that occur in
pprLit (MachInt i) = pprIntVal i -- a context requiring an atomic thing
pprLit (MachInt64 i) = ptext (sLit "__int64") <+> integer i pprLiteral _ (MachChar ch) = pprHsChar ch
pprLit (MachWord w) = ptext (sLit "__word") <+> integer w pprLiteral _ (MachStr s) = pprHsString s
pprLit (MachWord64 w) = ptext (sLit "__word64") <+> integer w pprLiteral _ (MachInt i) = pprIntVal i
pprLit (MachFloat f) = ptext (sLit "__float") <+> float (fromRat f) pprLiteral _ (MachDouble d) = double (fromRat d)
pprLit (MachDouble d) = double (fromRat d) pprLiteral _ (MachNullAddr) = ptext (sLit "__NULL")
pprLit (MachNullAddr) = ptext (sLit "__NULL") pprLiteral add_par (LitInteger i _) = add_par (ptext (sLit "__integer") <+> integer i)
pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod 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 where b = case mb of
Nothing -> pprHsString l Nothing -> pprHsString l
Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
pprLit (LitInteger i _) = ptext (sLit "__integer") <+> integer i
pprIntVal :: Integer -> SDoc pprIntVal :: Integer -> SDoc
-- ^ Print negative integers with parens to be sure it's unambiguous -- ^ Print negative integers with parens to be sure it's unambiguous
......
...@@ -491,7 +491,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr ...@@ -491,7 +491,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr
-- | Finds a nominal size of a string literal. -- | Finds a nominal size of a string literal.
litSize :: Literal -> Int litSize :: Literal -> Int
-- Used by CoreUnfold.sizeExpr -- 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 -- If size could be 0 then @f "x"@ might be too small
-- [Sept03: make literal strings a bit bigger to avoid fruitless -- [Sept03: make literal strings a bit bigger to avoid fruitless
-- duplication of little strings] -- duplication of little strings]
...@@ -556,6 +557,17 @@ conSize dc n_val_args ...@@ -556,6 +557,17 @@ conSize dc n_val_args
-- [SDM, 25/5/11] -- [SDM, 25/5/11]
\end{code} \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] Note [Constructor size]
~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~
Treat a constructors application as size 1, regardless of how many Treat a constructors application as size 1, regardless of how many
......
...@@ -14,6 +14,7 @@ module PprCore ( ...@@ -14,6 +14,7 @@ module PprCore (
import CoreSyn import CoreSyn
import CostCentre import CostCentre
import Literal( pprLiteral )
import Var import Var
import Id import Id
import IdInfo import IdInfo
...@@ -94,8 +95,8 @@ ppr_binding (val_bdr, expr) ...@@ -94,8 +95,8 @@ ppr_binding (val_bdr, expr)
\end{code} \end{code}
\begin{code} \begin{code}
pprParendExpr expr = ppr_expr parens expr pprParendExpr expr = ppr_expr parens expr
pprCoreExpr expr = ppr_expr noParens expr pprCoreExpr expr = ppr_expr noParens expr
noParens :: SDoc -> SDoc noParens :: SDoc -> SDoc
noParens pp = pp noParens pp = pp
...@@ -106,12 +107,10 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc ...@@ -106,12 +107,10 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
-- The function adds parens in context that need -- The function adds parens in context that need
-- an atomic value (e.g. function args) -- 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 add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
ppr_expr add_par (Lit lit) = pprLiteral add_par lit
ppr_expr _ (Var name) = ppr name
ppr_expr _ (Lit lit) = ppr lit
ppr_expr add_par (Cast expr co) ppr_expr add_par (Cast expr co)
= add_par $ = add_par $
......
...@@ -67,6 +67,7 @@ import IdInfo ...@@ -67,6 +67,7 @@ import IdInfo
import Var import Var
import VarSet import VarSet
import VarEnv import VarEnv
import Literal ( litIsTrivial )
import Demand ( StrictSig, increaseStrictSigArity ) import Demand ( StrictSig, increaseStrictSigArity )
import Name ( getOccName, mkSystemVarName ) import Name ( getOccName, mkSystemVarName )
import OccName ( occNameString ) import OccName ( occNameString )
...@@ -569,7 +570,8 @@ notWorthFloating e abs_vars ...@@ -569,7 +570,8 @@ notWorthFloating e abs_vars
= go e (count isId abs_vars) = go e (count isId abs_vars)
where where
go (_, AnnVar {}) n = n >= 0 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 (_, AnnCast e _) n = go e n
go (_, AnnApp e arg) n go (_, AnnApp e arg) n
| (_, AnnType {}) <- arg = go e n | (_, AnnType {}) <- arg = go e n
...@@ -587,6 +589,16 @@ notWorthFloating e abs_vars ...@@ -587,6 +589,16 @@ notWorthFloating e abs_vars
is_triv _ = False is_triv _ = False
\end{code} \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] Note [Escaping a value lambda]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to float even cheap expressions out of value lambdas, We want to float even cheap expressions out of value lambdas,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment