The attached (reverse :-() diff is a bunch of ugly hacks 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.)
I found the problems using the --enable-stack-dumps configure flag,
made a few guesses about what was going wrong and then went berserk
with hacks that would force evaluation of the Ints in any nearby code.
(In other words, you might be able to get away with less hacks and you
can certainly do it in a cleaner way. You might also want to add more
strictness hacks - the attached patch was enough to let me get back to
work but I suspect there's more gains to be had.)
The problems probably don't show up in Simon PJ's copy of the Pretty
library when compiled using GHC because that version uses Int#'s where
the Hugs copy uses Ints. In other words, it already has (something
equivalent to) the strictness hacks I added.
--
Alastair Reid
diff -c2 Pretty.lhs /home/css/staff/reid/hugs-Sept99/share/hugs/lib/exts/Pretty.lhs
*** Pretty.lhs Tue Nov 9 12:50:44 1999
--- /home/css/staff/reid/hugs-Sept99/share/hugs/lib/exts/Pretty.lhs Tue Nov 9
13:08:31 1999
***************
*** 547,551 ****
-- Specfication: aboveNest p g k q = p $g$ (nest k q)
- --aboveNest _ g k q | k == 0 && False = undefined
aboveNest NoDoc g k q = NoDoc
aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
--- 550,553 ----
***************
*** 570,574 ****
-- = text s <> (text "" $g$ nest k q)
- --nilAboveNest g k _ | k == 0 && False = undefined
nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
--- 572,575 ----
***************
*** 646,650 ****
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
--- 647,650 ----
***************
*** 697,701 ****
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
--- 697,700 ----
***************
*** 709,713 ****
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
--- 708,711 ----
***************
*** 751,755 ****
get :: Int -- (Remaining) width of line
-> Doc -> Doc
- get w _ | w==0 && False = undefined
get w Empty = Empty
get w NoDoc = NoDoc
--- 749,752 ----
***************
*** 764,768 ****
-> Doc -- No unions in here!
- get1 w _ _ | w==0 && False = undefined
get1 w sl Empty = Empty
get1 w sl NoDoc = NoDoc
--- 761,764 ----
***************
*** 785,789 ****
fits n Empty = True
fits n (NilAbove _) = True
! fits n (TextBeside _ sl p) = (fits $! (n - sl)) p
minn x y | x < y = x
--- 781,785 ----
fits n Empty = True
fits n (NilAbove _) = True
! fits n (TextBeside _ sl p) = fits (n - sl) p
minn x y | x < y = x
***************
