[commit: ghc] master: Make layLeft and reduceDoc stricter (#7258) (2a4c24e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/2a4c24e40462832a4a97cd7a65119542e842de81/ghc

>---------------------------------------------------------------

commit 2a4c24e40462832a4a97cd7a65119542e842de81
Author: Tobias Dammers <tdammers at gmail.com>
Date:   Wed Oct 25 14:17:58 2017 -0400

    Make layLeft and reduceDoc stricter (#7258)
    
    Making the pretty-printer based assembly output stricter in
    strategically chosen locations produces a minor performance improvement
    when compiling large derived Read instance (on the order of 5-10%).
    
    Reviewers: austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie
    
    Differential Revision: https://phabricator.haskell.org/D4111


>---------------------------------------------------------------

2a4c24e40462832a4a97cd7a65119542e842de81
 compiler/utils/Pretty.hs | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index 78c8e6a..f4987d3 100644
--- a/compiler/utils/Pretty.hs
+++ b/compiler/utils/Pretty.hs
@@ -433,8 +433,8 @@ maybeParens True = parens
 
 -- | Perform some simplification of a built up @GDoc at .
 reduceDoc :: Doc -> RDoc
-reduceDoc (Beside p g q) = beside p g (reduceDoc q)
-reduceDoc (Above  p g q) = above  p g (reduceDoc q)
+reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q)
+reduceDoc (Above  p g q) = p `seq` g `seq` (above  p g $! reduceDoc q)
 reduceDoc p              = p
 
 -- | List version of '<>'.
@@ -1032,11 +1032,11 @@ bufLeftRender b doc = layLeft b (reduceDoc doc)
 layLeft :: BufHandle -> Doc -> IO ()
 layLeft b _ | b `seq` False  = undefined -- make it strict in b
 layLeft _ NoDoc              = error "layLeft: NoDoc"
-layLeft b (Union p q)        = layLeft b (first p q)
-layLeft b (Nest _ p)         = layLeft b p
+layLeft b (Union p q)        = layLeft b $! first p q
+layLeft b (Nest _ p)         = layLeft b $! p
 layLeft b Empty              = bPutChar b '\n'
-layLeft b (NilAbove p)       = bPutChar b '\n' >> layLeft b p
-layLeft b (TextBeside s _ p) = put b s >> layLeft b p
+layLeft b (NilAbove p)       = p `seq` (bPutChar b '\n' >> layLeft b p)
+layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p)
  where
     put b _ | b `seq` False = undefined
     put b (Chr c)    = bPutChar b c