[commit: ghc] wip/tdammers-7258: Make layLeft and reduceDoc stricter (#7258) (375d4bd)

[git at git.haskell.org]

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

On branch  : wip/tdammers-7258
Link       : http://ghc.haskell.org/trac/ghc/changeset/375d4bd0fc2afd72617bc827bf63b5eeb24f2f7c/ghc

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

commit 375d4bd0fc2afd72617bc827bf63b5eeb24f2f7c
Author: Tobias Dammers <tdammers at gmail.com>
Date:   Mon Oct 16 11:33:01 2017 +0200

    Make layLeft and reduceDoc stricter (#7258)


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

375d4bd0fc2afd72617bc827bf63b5eeb24f2f7c
 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