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

3 files changed, 199 insertions, 3 deletions

diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index ab7db59a6a..98490322c5 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 0000000000..a97ff69f45
--- /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 f0308bf2a9..2e4d43d263 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -150,7 +150,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)
@@ -166,6 +166,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),
@@ -175,7 +177,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)
@@ -186,6 +188,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].
@@ -822,3 +826,15 @@ test('T10547',
      ],
      compile_fail,
      ['-fprint-expanded-synonyms'])
+
+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'])