[Git][ghc/ghc][wip/polymorphic-spec] Add -fpolymorphic-specialisation flag (off by default at all optimisation levels)
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Mon Jun 26 11:29:33 UTC 2023
Matthew Pickering pushed to branch wip/polymorphic-spec at Glasgow Haskell Compiler / GHC
Commits:
9449a8df by Matthew Pickering at 2023-06-26T12:25:29+01:00
Add -fpolymorphic-specialisation flag (off by default at all optimisation levels)
Polymorphic specialisation has led to a number of hard to diagnose
incorrect runtime result bugs (see #23469, #23109, #21229, #23445) so
this commit introduces a flag `-fpolymorhphic-specialisation` which
allows users to turn on this experimental optimisation if they are
willing to buy into things going very wrong.
Ticket #23469
- - - - -
7 changed files:
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- docs/users_guide/9.8.1-notes.rst
- docs/users_guide/using-optimisation.rst
- testsuite/tests/simplCore/should_compile/T8331.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -2490,6 +2490,12 @@ specArgFreeIds (SpecDict dx) = exprFreeIds dx
specArgFreeIds UnspecType = emptyVarSet
specArgFreeIds UnspecArg = emptyVarSet
+specArgFreeVars :: SpecArg -> VarSet
+specArgFreeVars (SpecType ty) = tyCoVarsOfType ty
+specArgFreeVars (SpecDict dx) = exprFreeVars dx
+specArgFreeVars UnspecType = emptyVarSet
+specArgFreeVars UnspecArg = emptyVarSet
+
isSpecDict :: SpecArg -> Bool
isSpecDict (SpecDict {}) = True
isSpecDict _ = False
@@ -2798,6 +2804,12 @@ non-dictionary bindings too.
Note [Specialising polymorphic dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Note June 2023: This has proved to be quite a tricky optimisation to get right
+see (#23469, #23109, #21229, #23445) so it is now guarded by a flag
+`-fpolymorphic-specialisation`.
+
+
Consider
class M a where { foo :: a -> Int }
@@ -2988,14 +3000,23 @@ getTheta = fmap piTyBinderType . filter isInvisiblePiTyBinder . filter isAnonPiT
------------------------------------------------------------
-singleCall :: Id -> [SpecArg] -> UsageDetails
-singleCall id args
+singleCall :: SpecEnv -> Id -> [SpecArg] -> UsageDetails
+singleCall spec_env id args
= MkUD {ud_binds = emptyFDBs,
ud_calls = unitDVarEnv id $ CIS id $
unitBag (CI { ci_key = args
, ci_fvs = call_fvs }) }
where
- call_fvs = foldr (unionVarSet . specArgFreeIds) emptyVarSet args
+ call_fvs =
+ foldr (unionVarSet . free_var_fn) emptyVarSet args
+
+ free_var_fn =
+ if gopt Opt_PolymorphicSpecialisation (se_dflags spec_env)
+ then specArgFreeIds
+ else specArgFreeVars
+
+
+
-- specArgFreeIds: we specifically look for free Ids, not TyVars
-- see (MP1) in Note [Specialising polymorphic dictionaries]
--
@@ -3014,7 +3035,7 @@ mkCallUDs' env f args
| wantCallsFor env f -- We want it, and...
, not (null ci_key) -- this call site has a useful specialisation
= -- pprTrace "mkCallUDs: keeping" _trace_doc
- singleCall f ci_key
+ singleCall env f ci_key
| otherwise -- See also Note [Specialisations already covered]
= -- pprTrace "mkCallUDs: discarding" _trace_doc
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -257,6 +257,7 @@ data GeneralFlag
| Opt_Specialise
| Opt_SpecialiseAggressively
| Opt_CrossModuleSpecialise
+ | Opt_PolymorphicSpecialisation
| Opt_InlineGenerics
| Opt_InlineGenericsAggressively
| Opt_StaticArgumentTransformation
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2429,6 +2429,7 @@ fFlagsDeps = [
flagSpec "specialize-aggressively" Opt_SpecialiseAggressively,
flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise,
flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise,
+ flagSpec "polymorphic-specialisation" Opt_PolymorphicSpecialisation,
flagSpec "inline-generics" Opt_InlineGenerics,
flagSpec "inline-generics-aggressively" Opt_InlineGenericsAggressively,
flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation,
=====================================
docs/users_guide/9.8.1-notes.rst
=====================================
@@ -174,11 +174,16 @@ Compiler
D(D2)
)
D = D1 | D2
-
+
This allows for changing the structure of a library without immediately breaking user code,
but instead being able to warn the user that a change in the library interface
will occur in the future.
+- Guard polymorphic specialisation behind the flag :ghc-flag:`-fpolymorphic-specialisation`.
+ This optimisation has led to a number of incorrect runtime result bugs, so we are disabling it
+ by default for now whilst we consider more carefully an appropiate fix.
+ (See :ghc-ticket:`23469`, :ghc-ticket:`23109`, :ghc-ticket:`21229`, :ghc-ticket:`23445`)
+
GHCi
~~~~
@@ -241,8 +246,8 @@ Runtime system
We use this functionality in GHCi to modify how some messages are displayed.
- The extensions fields of constructors of ``IE`` now take ``Maybe (WarningTxt p)``
- in ``GhcPs`` and ``GhcRn`` variants of the Syntax Tree.
- This represents the warning assigned to a certain export item,
+ in ``GhcPs`` and ``GhcRn`` variants of the Syntax Tree.
+ This represents the warning assigned to a certain export item,
which is used for :ref:`deprecated-exports`.
``ghc-heap`` library
=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -1113,6 +1113,21 @@ as such you shouldn't need to set any of them explicitly. A flag
which they are called in this module. Note that specialisation must be
enabled (by ``-fspecialise``) for this to have any effect.
+.. ghc-flag:: -fpolymorphic-specialisation
+ :shortdesc: Allow specialisation to abstract over free type variables
+ :type: dynamic
+ :reverse: -fno-polymorphic-specialisation
+ :category:
+
+ :default: off
+
+ Warning, this feature is highly experimental and may lead to incorrect runtime
+ results. Use at your own risk (:ghc-ticket:`23469`, :ghc-ticket:`23109`, :ghc-ticket:`21229`, :ghc-ticket:`23445`).
+
+ Enable specialisation of function calls to known dictionaries with free type variables.
+ The created specialisation will abstract over the type variables free in the dictionary.
+
+
.. ghc-flag:: -flate-specialise
:shortdesc: Run a late specialisation pass
:type: dynamic
=====================================
testsuite/tests/simplCore/should_compile/T8331.stderr
=====================================
@@ -1,149 +1,5 @@
==================== Tidy Core rules ====================
-"SPEC $c*> @(ST s) @_"
- forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
- $fApplicativeReaderT_$c*> @(ST s) @r $dApplicative
- = ($fApplicativeReaderT2 @s @r)
- `cast` (forall (a :: <*>_N) (b :: <*>_N).
- <ReaderT r (ST s) a>_R
- %<'Many>_N ->_R <ReaderT r (ST s) b>_R
- %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
- ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <b>_N)
- :: Coercible
- (forall {a} {b}.
- ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s b)
- (forall {a} {b}.
- ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) b))
-"SPEC $c<$ @(ST s) @_"
- forall (@s) (@r) ($dFunctor :: Functor (ST s)).
- $fFunctorReaderT_$c<$ @(ST s) @r $dFunctor
- = ($fApplicativeReaderT6 @s @r)
- `cast` (forall (a :: <*>_N) (b :: <*>_N).
- <a>_R
- %<'Many>_N ->_R <ReaderT r (ST s) b>_R
- %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <a>_R)
- ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <a>_N)
- :: Coercible
- (forall {a} {b}. a -> ReaderT r (ST s) b -> r -> STRep s a)
- (forall {a} {b}. a -> ReaderT r (ST s) b -> ReaderT r (ST s) a))
-"SPEC $c<* @(ST s) @_"
- forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
- $fApplicativeReaderT_$c<* @(ST s) @r $dApplicative
- = ($fApplicativeReaderT1 @s @r)
- `cast` (forall (a :: <*>_N) (b :: <*>_N).
- <ReaderT r (ST s) a>_R
- %<'Many>_N ->_R <ReaderT r (ST s) b>_R
- %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <a>_R)
- ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <a>_N)
- :: Coercible
- (forall {a} {b}.
- ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s a)
- (forall {a} {b}.
- ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) a))
-"SPEC $c<*> @(ST s) @_"
- forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
- $fApplicativeReaderT9 @(ST s) @r $dApplicative
- = ($fApplicativeReaderT4 @s @r)
- `cast` (forall (a :: <*>_N) (b :: <*>_N).
- <ReaderT r (ST s) (a -> b)>_R
- %<'Many>_N ->_R <ReaderT r (ST s) a>_R
- %<'Many>_N ->_R <r>_R
- %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
- :: Coercible
- (forall {a} {b}.
- ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> STRep s b)
- (forall {a} {b}.
- ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> ST s b))
-"SPEC $c>> @(ST s) @_"
- forall (@s) (@r) ($dMonad :: Monad (ST s)).
- $fMonadReaderT1 @(ST s) @r $dMonad
- = $fMonadAbstractIOSTReaderT_$s$c>> @s @r
-"SPEC $c>>= @(ST s) @_"
- forall (@s) (@r) ($dMonad :: Monad (ST s)).
- $fMonadReaderT2 @(ST s) @r $dMonad
- = ($fMonadAbstractIOSTReaderT2 @s @r)
- `cast` (forall (a :: <*>_N) (b :: <*>_N).
- <ReaderT r (ST s) a>_R
- %<'Many>_N ->_R <a -> ReaderT r (ST s) b>_R
- %<'Many>_N ->_R <r>_R
- %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
- :: Coercible
- (forall {a} {b}.
- ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> STRep s b)
- (forall {a} {b}.
- ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> ST s b))
-"SPEC $cfmap @(ST s) @_"
- forall (@s) (@r) ($dFunctor :: Functor (ST s)).
- $fFunctorReaderT_$cfmap @(ST s) @r $dFunctor
- = ($fApplicativeReaderT7 @s @r)
- `cast` (forall (a :: <*>_N) (b :: <*>_N).
- <a -> b>_R
- %<'Many>_N ->_R <ReaderT r (ST s) a>_R
- %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
- ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <b>_N)
- :: Coercible
- (forall {a} {b}. (a -> b) -> ReaderT r (ST s) a -> r -> STRep s b)
- (forall {a} {b}.
- (a -> b) -> ReaderT r (ST s) a -> ReaderT r (ST s) b))
-"SPEC $cliftA2 @(ST s) @_"
- forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
- $fApplicativeReaderT_$cliftA2 @(ST s) @r $dApplicative
- = ($fApplicativeReaderT3 @s @r)
- `cast` (forall (a :: <*>_N) (b :: <*>_N) (c :: <*>_N).
- <a -> b -> c>_R
- %<'Many>_N ->_R <ReaderT r (ST s) a>_R
- %<'Many>_N ->_R <ReaderT r (ST s) b>_R
- %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <c>_R)
- ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <c>_N)
- :: Coercible
- (forall {a} {b} {c}.
- (a -> b -> c)
- -> ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s c)
- (forall {a} {b} {c}.
- (a -> b -> c)
- -> ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) c))
-"SPEC $cp1Applicative @(ST s) @_"
- forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
- $fApplicativeReaderT_$cp1Applicative @(ST s) @r $dApplicative
- = $fApplicativeReaderT_$s$fFunctorReaderT @s @r
-"SPEC $cp1Monad @(ST s) @_"
- forall (@s) (@r) ($dMonad :: Monad (ST s)).
- $fMonadReaderT_$cp1Monad @(ST s) @r $dMonad
- = $fApplicativeReaderT_$s$fApplicativeReaderT @s @r
-"SPEC $cpure @(ST s) @_"
- forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
- $fApplicativeReaderT_$cpure @(ST s) @r $dApplicative
- = ($fApplicativeReaderT5 @s @r)
- `cast` (forall (a :: <*>_N).
- <a>_R
- %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <a>_R)
- ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <a>_N)
- :: Coercible
- (forall {a}. a -> r -> STRep s a)
- (forall {a}. a -> ReaderT r (ST s) a))
-"SPEC $creturn @(ST s) @_"
- forall (@s) (@r) ($dMonad :: Monad (ST s)).
- $fMonadReaderT_$creturn @(ST s) @r $dMonad
- = ($fApplicativeReaderT5 @s @r)
- `cast` (forall (a :: <*>_N).
- <a>_R
- %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <a>_R)
- ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <a>_N)
- :: Coercible
- (forall {a}. a -> r -> STRep s a)
- (forall {a}. a -> ReaderT r (ST s) a))
-"SPEC $fApplicativeReaderT @(ST s) @_"
- forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
- $fApplicativeReaderT @(ST s) @r $dApplicative
- = $fApplicativeReaderT_$s$fApplicativeReaderT @s @r
-"SPEC $fFunctorReaderT @(ST s) @_"
- forall (@s) (@r) ($dFunctor :: Functor (ST s)).
- $fFunctorReaderT @(ST s) @r $dFunctor
- = $fApplicativeReaderT_$s$fFunctorReaderT @s @r
-"SPEC $fMonadReaderT @(ST s) @_"
- forall (@s) (@r) ($dMonad :: Monad (ST s)).
- $fMonadReaderT @(ST s) @r $dMonad
- = $fMonadAbstractIOSTReaderT_$s$fMonadReaderT @s @r
"USPEC useAbstractMonad @(ReaderT Int (ST s))"
forall (@s)
($dMonadAbstractIOST :: MonadAbstractIOST (ReaderT Int (ST s))).
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -435,7 +435,7 @@ test('T21851', [grep_errmsg(r'case.*w\$sf') ], multimod_compile, ['T21851', '-O
# One module, T22097.hs, has OPTIONS_GHC -ddump-simpl
test('T22097', [grep_errmsg(r'case.*wgoEven') ], multimod_compile, ['T22097', '-O -dno-typeable-binds -dsuppress-uniques'])
-test('T13873', [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
+test('T13873', [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules -fpolymorphic-specialisation'])
test('T22357', normal, compile, ['-O'])
test('T22471', normal, compile, ['-O'])
test('T22347', normal, compile, ['-O -fno-full-laziness'])
@@ -443,8 +443,8 @@ test('T22347a', normal, compile, ['-O2 -fno-full-laziness'])
# T17366: expecting to see a rule
# Rule fired: SPEC/T17366 f @(Tagged tag) @_ (T17366)
-test('T17366', normal, multimod_compile, ['T17366', '-O -v0 -ddump-rule-firings'])
-test('T17366_AR', [grep_errmsg(r'SPEC')], multimod_compile, ['T17366_AR', '-O -v0 -ddump-rule-firings'])
+test('T17366', normal, multimod_compile, ['T17366', '-O -v0 -ddump-rule-firings -fpolymorphic-specialisation'])
+test('T17366_AR', [grep_errmsg(r'SPEC')], multimod_compile, ['T17366_AR', '-O -v0 -ddump-rule-firings -fpolymorphic-specialisation'])
test('T22375', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds -dsuppress-unfoldings'])
# One module, T21851_2.hs, has OPTIONS_GHC -ddump-simpl
@@ -467,7 +467,7 @@ test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
test('T22662', normal, compile, [''])
test('T22725', normal, compile, ['-O'])
test('T22502', normal, compile, ['-O'])
-test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all'])
+test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -fpolymorphic-specialisation'])
test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively'])
test('T22802', normal, compile, ['-O'])
test('T15205', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9449a8df88d5335806bb5c3ba2cddfba58008eb1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9449a8df88d5335806bb5c3ba2cddfba58008eb1
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230626/34815c0d/attachment-0001.html>
More information about the ghc-commits
mailing list