diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-08-21 11:02:33 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-08-24 00:33:13 -0400 |
| commit | b1eb38a0a7168d7612c791c4289cc02d900d402f (patch) | |
| tree | 7e226b76ec63a2e24ddcd68d5bfea583adc8dda0 | |
| parent | 364258e0ad25bc95e69745554f5ca831ce80baf8 (diff) | |
| download | haskell-b1eb38a0a7168d7612c791c4289cc02d900d402f.tar.gz | |
Perf: make SDoc monad one-shot (#18202)
With validate-x86_64-linux-deb9-hadrian:
T1969 -3.4% (threshold: +/-1%)
T3294 -3.3% (threshold: +/-1%)
T12707 -1.4% (threshold: +/-1%)
Additionally with validate-x86_64-linux-deb9-unreg-hadrian:
T4801 -2.4% (threshold: +/-2%)
T13035 -1.4% (threshold: +/-1%)
T13379 -2.4% (threshold: +/-2%)
ManyAlternatives -2.5% (threshold: +/-2%)
ManyConstructors -3.0% (threshold: +/-2%)
Metric Decrease:
T12707
T1969
T3294
ManyAlternatives
ManyConstructors
T13035
T13379
T4801
| -rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 14 |
1 files changed, 13 insertions, 1 deletions
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 23bceff20a..736d609def 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} {- (c) The University of Glasgow 2006-2012 @@ -121,6 +122,7 @@ import qualified Data.List.NonEmpty as NEL import GHC.Fingerprint import GHC.Show ( showMultiLineString ) import GHC.Utils.Exception +import GHC.Exts (oneShot) {- ************************************************************************ @@ -304,7 +306,17 @@ code (either C or assembly), or generating interface files. -- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc', -- or 'renderWithContext'. Avoid calling 'runSDoc' directly as it breaks the -- abstraction layer. -newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } +newtype SDoc = SDoc' (SDocContext -> Doc) + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE SDoc #-} +pattern SDoc :: (SDocContext -> Doc) -> SDoc +pattern SDoc m <- SDoc' m + where + SDoc m = SDoc' (oneShot m) + +runSDoc :: SDoc -> (SDocContext -> Doc) +runSDoc (SDoc m) = m data SDocContext = SDC { sdocStyle :: !PprStyle |