Commit 89a8be71 authored by thomie's avatar thomie Committed by Ben Gamari
Browse files

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
parent 1ba79fa4
...@@ -20,6 +20,49 @@ ...@@ -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 ( module Pretty (
-- * The document type -- * The document type
...@@ -590,7 +633,7 @@ beside p@(Beside p1 g1 q1) g2 q2 ...@@ -590,7 +633,7 @@ beside p@(Beside p1 g1 q1) g2 q2
| otherwise = beside (reduceDoc p) g2 q2 | otherwise = beside (reduceDoc p) g2 q2
beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q 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 (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 where
rest = case p of rest = case p of
Empty -> nilBeside g q Empty -> nilBeside g q
......
{-# 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.
...@@ -150,7 +150,7 @@ test('T3294', ...@@ -150,7 +150,7 @@ test('T3294',
# 2015-07-11 43196344 (x86/Linux, 64-bit machine) use +RTS -G1 # 2015-07-11 43196344 (x86/Linux, 64-bit machine) use +RTS -G1
# 2016-04-06 28686588 (x86/Linux, 64-bit machine) # 2016-04-06 28686588 (x86/Linux, 64-bit machine)
(wordsize(64), 50367248, 20)]), (wordsize(64), 52992688, 20)]),
# prev: 25753192 (amd64/Linux) # prev: 25753192 (amd64/Linux)
# 29/08/2012: 37724352 (amd64/Linux) # 29/08/2012: 37724352 (amd64/Linux)
# (increase due to new codegen, see #7198) # (increase due to new codegen, see #7198)
...@@ -166,6 +166,8 @@ test('T3294', ...@@ -166,6 +166,8 @@ test('T3294',
# varies between 40959592 and 52914488... increasing to +-20% # varies between 40959592 and 52914488... increasing to +-20%
# 2015-10-28: 50367248 (amd64/Linux) # 2015-10-28: 50367248 (amd64/Linux)
# D757: emit Typeable instances at site of type definition # 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', compiler_stats_num_field('bytes allocated',
[(wordsize(32), 1377050640, 5), [(wordsize(32), 1377050640, 5),
...@@ -175,7 +177,7 @@ test('T3294', ...@@ -175,7 +177,7 @@ test('T3294',
# 2013-11-13: 1478325844 (x86/Windows, 64bit machine) # 2013-11-13: 1478325844 (x86/Windows, 64bit machine)
# 2014-01-12: 1565185140 (x86/Linux) # 2014-01-12: 1565185140 (x86/Linux)
# 2013-04-04: 1377050640 (x86/Windows, 64bit machine) # 2013-04-04: 1377050640 (x86/Windows, 64bit machine)
(wordsize(64), 2709595808, 5)]), (wordsize(64), 2739731144, 5)]),
# old: 1357587088 (amd64/Linux) # old: 1357587088 (amd64/Linux)
# 29/08/2012: 2961778696 (amd64/Linux) # 29/08/2012: 2961778696 (amd64/Linux)
# (^ increase due to new codegen, see #7198) # (^ increase due to new codegen, see #7198)
...@@ -186,6 +188,8 @@ test('T3294', ...@@ -186,6 +188,8 @@ test('T3294',
# 12/03/2014: 2705289664 (amd64/Linux) (more call arity improvements) # 12/03/2014: 2705289664 (amd64/Linux) (more call arity improvements)
# 2014-17-07: 2671595512 (amd64/Linux) (round-about update) # 2014-17-07: 2671595512 (amd64/Linux) (round-about update)
# 2014-09-10: 2709595808 (amd64/Linux) post-AMP cleanup # 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, conf_3294,
# Use `+RTS -G1` for more stable residency measurements. Note [residency]. # Use `+RTS -G1` for more stable residency measurements. Note [residency].
...@@ -822,3 +826,15 @@ test('T10547', ...@@ -822,3 +826,15 @@ test('T10547',
], ],
compile_fail, compile_fail,
['-fprint-expanded-synonyms']) ['-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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment