From 2756af87aebee769ffca959adc4b9dc607a49fdb Mon Sep 17 00:00:00 2001 From: Thomas Miedema Date: Sun, 17 Jul 2016 00:13:45 +0200 Subject: [PATCH] Pretty: remove a harmful $! (#12227) This is backport of [1] for GHC's copy of Pretty. See Note [Differences between libraries/pretty and compiler/utils/Pretty.hs]. [1] http://git.haskell.org/packages/pretty.git/commit/bbe9270c5f849a5bb74c9166a5f4202cfb0dba22 https://github.com/haskell/pretty/issues/32 https://github.com/haskell/pretty/pull/35 Reviewers: bgamari, austin Reviewed By: austin Differential Revision: https://phabricator.haskell.org/D2397 GHC Trac Issues: #12227 (cherry picked from commit 89a8be71a3715c948cebcb19ac81f84da0e6270e) --- compiler/utils/Pretty.hs | 45 +++++++- testsuite/tests/perf/compiler/T12227.hs | 137 ++++++++++++++++++++++++ testsuite/tests/perf/compiler/all.T | 21 +++- 3 files changed, 200 insertions(+), 3 deletions(-) create mode 100644 testsuite/tests/perf/compiler/T12227.hs diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs index ab7db59a6af8..98490322c5a7 100644 --- a/compiler/utils/Pretty.hs +++ b/compiler/utils/Pretty.hs @@ -20,6 +20,49 @@ -- ----------------------------------------------------------------------------- +{- +Note [Differences between libraries/pretty and compiler/utils/Pretty.hs] + +For historical reasons, there are two different copies of `Pretty` in the GHC +source tree: + * `libraries/pretty` is a submodule containing + https://github.com/haskell/pretty. This is the `pretty` library as released + on hackage. It is used by several other libraries in the GHC source tree + (e.g. template-haskell and Cabal). + * `compiler/utils/Pretty.hs` (this module). It is used by GHC only. + +There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and +https://ghc.haskell.org/trac/ghc/ticket/10735 to try to get rid of GHC's copy +of Pretty. + +Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following +major differences: + * GHC's copy uses `Faststring` for performance reasons. + * GHC's copy has received a backported bugfix for #12227, which was + released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside", + https://github.com/haskell/pretty/pull/35). + +Other differences are minor. Both copies define some extra functions and +instances not defined in the other copy. To see all differences, do this in a +ghc git tree: + + $ cd libraries/pretty + $ git checkout v1.1.2.0 + $ cd - + $ vimdiff compiler/utils/Pretty.hs \ + libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs + +For parity with `pretty-1.1.2.1`, the following two `pretty` commits would +have to be backported: + * "Resolve foldr-strictness stack overflow bug" + (307b8173f41cd776eae8f547267df6d72bff2d68) + * "Special-case reduce for horiz/vert" + (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c) +This has not been done sofar, because these commits seem to cause more +allocation in the compiler (see thomie's comments in +https://github.com/haskell/pretty/pull/9). +-} + module Pretty ( -- * The document type @@ -590,7 +633,7 @@ beside p@(Beside p1 g1 q1) g2 q2 | otherwise = beside (reduceDoc p) g2 q2 beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q beside (NilAbove p) g q = nilAbove_ $! beside p g q -beside (TextBeside s sl p) g q = textBeside_ s sl $! rest +beside (TextBeside s sl p) g q = textBeside_ s sl rest where rest = case p of Empty -> nilBeside g q diff --git a/testsuite/tests/perf/compiler/T12227.hs b/testsuite/tests/perf/compiler/T12227.hs new file mode 100644 index 000000000000..a97ff69f4573 --- /dev/null +++ b/testsuite/tests/perf/compiler/T12227.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} + +module Crash where + +import Data.Proxy (Proxy(..)) +import Data.Type.Equality (type (==)) +import GHC.Exts +import GHC.Generics + +data Dict :: Constraint -> * where + Dict :: a => Dict a + +infixr 0 --> + +type family (args :: [*]) --> (ret :: *) :: * + where + '[] --> ret = ret + (arg ': args) --> ret = arg -> (args --> ret) + +type family AllArguments (func :: *) :: [*] + where + AllArguments (arg -> func) = arg ': AllArguments func + AllArguments ret = '[] + +type family FinalReturn (func :: *) :: * + where + FinalReturn (arg -> func) = FinalReturn func + FinalReturn ret = ret + +type IsFullFunction f + = (AllArguments f --> FinalReturn f) ~ f + +type family SConstructor (struct :: *) :: * + where + SConstructor struct = GPrependFields (Rep struct ()) '[] --> struct + +type family GPrependFields (gstruct :: *) (tail :: [*]) :: [*] + where + GPrependFields (M1 i t f p) tail = GPrependFields (f p) tail + GPrependFields (K1 i c p) tail = c ': tail + GPrependFields ((:*:) f g p) tail = + GPrependFields (f p) (GPrependFields (g p) tail) + +class (fields1 --> (fields2 --> r)) ~ (fields --> r) + => AppendFields fields1 fields2 fields r + | fields1 fields2 -> fields + +instance AppendFields '[] fields fields r + +instance AppendFields fields1 fields2 fields r + => AppendFields (f ': fields1) fields2 (f ': fields) r + +class Generic struct + => GoodConstructor (struct :: *) + where + goodConstructor :: Proxy struct + -> Dict ( IsFullFunction (SConstructor struct) + , FinalReturn (SConstructor struct) ~ struct + ) + +instance ( Generic struct + , GoodConstructorEq (SConstructor struct == struct) + (SConstructor struct) + struct + ) => GoodConstructor struct + where + goodConstructor _ = + goodConstructorEq (Proxy :: Proxy (SConstructor struct == struct)) + (Proxy :: Proxy (SConstructor struct)) + (Proxy :: Proxy struct) + {-# INLINE goodConstructor #-} + +class GoodConstructorEq (isEqual :: Bool) (ctor :: *) (struct :: *) + where + goodConstructorEq :: Proxy isEqual + -> Proxy ctor + -> Proxy struct + -> Dict ( IsFullFunction ctor + , FinalReturn ctor ~ struct + ) + +instance ( FinalReturn struct ~ struct + , AllArguments struct ~ '[] + ) => GoodConstructorEq True struct struct + where + goodConstructorEq _ _ _ = Dict + {-# INLINE goodConstructorEq #-} + +instance GoodConstructorEq (ctor == struct) ctor struct + => GoodConstructorEq False (arg -> ctor) struct + where + goodConstructorEq _ _ _ = + case goodConstructorEq (Proxy :: Proxy (ctor == struct)) + (Proxy :: Proxy ctor) + (Proxy :: Proxy struct) + of + Dict -> Dict + {-# INLINE goodConstructorEq #-} + +data Foo = Foo + { _01 :: Int + , _02 :: Int + , _03 :: Int + , _04 :: Int + , _05 :: Int + , _06 :: Int + , _07 :: Int + , _08 :: Int + , _09 :: Int + , _10 :: Int + , _11 :: Int + , _12 :: Int + , _13 :: Int + , _14 :: Int + , _15 :: Int + , _16 :: Int + } + deriving (Generic) + +crash :: () -> Int +crash p1 = x + y + where + p2 = p1 -- This indirection is required to trigger the problem. + x = fst $ case goodConstructor (Proxy :: Proxy Foo) of + Dict -> (0, p2) + y = fst $ case goodConstructor (Proxy :: Proxy Foo) of + Dict -> (0, p2) +{-# INLINE crash #-} -- Even 'INLINABLE' is not enough to trigger the problem. diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index ce94d9326bad..6dc89587f1a6 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -149,7 +149,7 @@ test('T3294', # 2015-07-11 43196344 (x86/Linux, 64-bit machine) use +RTS -G1 # 2016-04-06 28686588 (x86/Linux, 64-bit machine) - (wordsize(64), 50367248, 20)]), + (wordsize(64), 52992688, 20)]), # prev: 25753192 (amd64/Linux) # 29/08/2012: 37724352 (amd64/Linux) # (increase due to new codegen, see #7198) @@ -165,6 +165,8 @@ test('T3294', # varies between 40959592 and 52914488... increasing to +-20% # 2015-10-28: 50367248 (amd64/Linux) # D757: emit Typeable instances at site of type definition + # 2016-07-11: 54609256 (Windows) before fix for #12227 + # 2016-07-11: 52992688 (Windows) after fix for #12227 compiler_stats_num_field('bytes allocated', [(wordsize(32), 1377050640, 5), @@ -174,7 +176,7 @@ test('T3294', # 2013-11-13: 1478325844 (x86/Windows, 64bit machine) # 2014-01-12: 1565185140 (x86/Linux) # 2013-04-04: 1377050640 (x86/Windows, 64bit machine) - (wordsize(64), 2709595808, 5)]), + (wordsize(64), 2739731144, 5)]), # old: 1357587088 (amd64/Linux) # 29/08/2012: 2961778696 (amd64/Linux) # (^ increase due to new codegen, see #7198) @@ -185,6 +187,8 @@ test('T3294', # 12/03/2014: 2705289664 (amd64/Linux) (more call arity improvements) # 2014-17-07: 2671595512 (amd64/Linux) (round-about update) # 2014-09-10: 2709595808 (amd64/Linux) post-AMP cleanup + # 2016-07-11: 2664479936 (Windows) before fix for #12227 + # 2016-07-11: 2739731144 (Windows) after fix for #12227 (ignoring) conf_3294, # Use `+RTS -G1` for more stable residency measurements. Note [residency]. @@ -798,3 +802,16 @@ test('T10370', ], compile, ['']) + +test('T12227', + [ only_ways(['normal']), + compiler_stats_num_field('bytes allocated', + [(wordsize(64), 1822822016, 5), + # 2016-07-11 5650186880 (Windows) before fix for #12227 + # 2016-07-11 1822822016 (Windows) after fix for #12227 + ]), + ], + compile, + # Use `-M1G` to prevent memory thrashing with ghc-8.0.1. + ['-O2 -ddump-hi -ddump-to-file +RTS -M1G']) +