From a2ba15db67abb18446ae3033f435f2d85e8e5676 Mon Sep 17 00:00:00 2001
From: andy <unknown>
Date: Thu, 11 Nov 1999 21:13:12 +0000
Subject: [PATCH] [project @ 1999-11-11 21:13:12 by andy] This change provided
 by Alastair Reid is a bunch of wibbles which fix some
 severe performance problems in the copy of the Pretty
 library distributed with Hugs-Sept99.

The problems show up when making heavy use of hsep (eg printing large
numbers of comma separated lists which tend to run over the end of
line).  The problems manifest themselves as the infamous "control
stack overflow" and seem to be due to the generation of large
Int thunks that look something like this:

  80 - 4 - 1 - 1 - 3 - 1 - ... -1

(There may be a few +'s in there too but -'s predominate.)
---
 ghc/lib/exts/Pretty.lhs |    7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/ghc/lib/exts/Pretty.lhs b/ghc/lib/exts/Pretty.lhs
index 2c79d5a..fe93348 100644
--- a/ghc/lib/exts/Pretty.lhs
+++ b/ghc/lib/exts/Pretty.lhs
@@ -646,6 +646,7 @@ sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
 --                              `union` x $$ nest k (vcat ys)
 
 sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
+sep1 g _                   k ys | k == 0 && False = undefined
 sep1 g NoDoc               k ys = NoDoc
 sep1 g (p `Union` q)       k ys = sep1 g p k ys
                                   `union_`
@@ -696,6 +697,7 @@ fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
 
 
 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
+fill1 g _                   k ys | k == 0 && False = undefined
 fill1 g NoDoc               k ys = NoDoc
 fill1 g (p `Union` q)       k ys = fill1 g p k ys
                                    `union_`
@@ -707,6 +709,7 @@ fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)
 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
 
+fillNB g _           k ys | k == 0 && False = undefined
 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
 fillNB g Empty k []        = Empty
 fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
@@ -748,6 +751,7 @@ best mode w r p
   where
     get :: Int          -- (Remaining) width of line
         -> Doc -> Doc
+    get w _ | w==0 && False   = undefined
     get w Empty               = Empty
     get w NoDoc               = NoDoc
     get w (NilAbove p)        = nilAbove_ (get w p)
@@ -760,6 +764,7 @@ best mode w r p
          -> Doc         -- This is an argument to TextBeside => eat Nests
          -> Doc         -- No unions in here!
 
+    get1 w _ _ | w==0 && False = undefined
     get1 w sl Empty               = Empty
     get1 w sl NoDoc               = NoDoc
     get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)
@@ -780,7 +785,7 @@ fits n p    | n < 0 = False
 fits n NoDoc               = False
 fits n Empty               = True
 fits n (NilAbove _)        = True
-fits n (TextBeside _ sl p) = fits (n - sl) p
+fits n (TextBeside _ sl p) = (fits $! (n - sl)) p
 
 minn x y | x < y    = x
          | otherwise = y
-- 
1.7.10.4