diff options
| author | Tobias Dammers <tdammers@gmail.com> | 2017-10-25 14:17:58 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-10-25 15:45:35 -0400 |
| commit | 2a4c24e40462832a4a97cd7a65119542e842de81 (patch) | |
| tree | 01ae730f6e3dec4b05c641d97dc78e912cab2a7a /compiler/utils/Pretty.hs | |
| parent | bd53b488d6bf59329f33a5fb6ba2ef0170285298 (diff) | |
| download | haskell-2a4c24e40462832a4a97cd7a65119542e842de81.tar.gz | |
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
Diffstat (limited to 'compiler/utils/Pretty.hs')
| -rw-r--r-- | compiler/utils/Pretty.hs | 12 |
1 files changed, 6 insertions, 6 deletions
diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs index 78c8e6a885..f4987d3751 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@. 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 |