Recover proper sharing for Integer literals
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 21 Oct 2011 16:53:30 +0000 (17:53 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 21 Oct 2011 16:53:30 +0000 (17:53 +0100)
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
compiler/coreSyn/CoreUnfold.lhs
compiler/coreSyn/PprCore.lhs
compiler/simplCore/SetLevels.lhs

index c3840c8..889cd24 100644 (file)
@@ -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
index 165450b..429cce9 100644 (file)
@@ -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
index 8f83a4c..8128f50 100644 (file)
@@ -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 $
index 6603f73..50e547d 100644 (file)
@@ -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,