summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-08-21 11:02:33 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-08-24 00:33:13 -0400
commitb1eb38a0a7168d7612c791c4289cc02d900d402f (patch)
tree7e226b76ec63a2e24ddcd68d5bfea583adc8dda0
parent364258e0ad25bc95e69745554f5ca831ce80baf8 (diff)
downloadhaskell-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.hs14
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