[Git][ghc/ghc][wip/andreask/expose-overloaded-unfoldings] Tidy: Expose unfoldings if they take dictionary arguments by default.

Andreas Klebinger (@AndreasK) gitlab at gitlab.haskell.org
Fri Nov 24 15:06:15 UTC 2023



Andreas Klebinger pushed to branch wip/andreask/expose-overloaded-unfoldings at Glasgow Haskell Compiler / GHC


Commits:
b03cf7ea by Andreas Klebinger at 2023-11-24T15:52:37+01:00
Tidy: Expose unfoldings if they take dictionary arguments by default.

Add the flag `-fexpose-overloaded-unfoldings` to be able to control this
behaviour with is on by default with `-O`.

For ghc's boot libraries file size grew by less than 1%.

-------------------------
Metric Decrease:
    MultiLayerModulesTH_OneShot
Metric Increase:
    T12425
    T13386
    hard_hole_fits
-------------------------

- - - - -


10 changed files:

- compiler/GHC/Driver/Config/Tidy.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Tidy.hs
- docs/users_guide/hints.rst
- docs/users_guide/using-optimisation.rst
- testsuite/tests/simplCore/should_compile/T16038/Makefile
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/stranal/should_compile/T23398.stderr


Changes:

=====================================
compiler/GHC/Driver/Config/Tidy.hs
=====================================
@@ -36,6 +36,7 @@ initTidyOpts hsc_env = do
     , opt_unfolding_opts    = unfoldingOpts dflags
     , opt_expose_unfoldings = if | gopt Opt_OmitInterfacePragmas dflags -> ExposeNone
                                  | gopt Opt_ExposeAllUnfoldings dflags  -> ExposeAll
+                                 | gopt Opt_ExposeOverloadedUnfoldings dflags  -> ExposeOverloaded
                                  | otherwise                            -> ExposeSome
     , opt_expose_rules      = not (gopt Opt_OmitInterfacePragmas dflags)
     , opt_trim_ids          = gopt Opt_OmitInterfacePragmas dflags


=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -1285,6 +1285,7 @@ optLevelFlags -- see Note [Documenting optimisation flags]
 
     , ([1,2],   Opt_Specialise)
     , ([1,2],   Opt_CrossModuleSpecialise)
+    , ([1,2],   Opt_ExposeOverloadedUnfoldings)
     , ([1,2],   Opt_InlineGenerics)
     , ([1,2],   Opt_Strictness)
     , ([1,2],   Opt_UnboxSmallStrictFields)


=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -323,6 +323,7 @@ data GeneralFlag
    | Opt_IgnoreInterfacePragmas
    | Opt_OmitInterfacePragmas
    | Opt_ExposeAllUnfoldings
+   | Opt_ExposeOverloadedUnfoldings
    | Opt_KeepAutoRules -- ^Keep auto-generated rules even if they seem to have become useless
    | Opt_WriteInterface -- forces .hi files to be written even with -fno-code
    | Opt_WriteHie -- generate .hie files
@@ -573,6 +574,7 @@ codeGenFlags = EnumSet.fromList
 
      -- Flags that affect generated code
    , Opt_ExposeAllUnfoldings
+   , Opt_ExposeOverloadedUnfoldings
    , Opt_NoTypeableBinds
    , Opt_Haddock
 


=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2370,6 +2370,7 @@ fFlagsDeps = [
   flagSpec "error-spans"                      Opt_ErrorSpans,
   flagSpec "excess-precision"                 Opt_ExcessPrecision,
   flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,
+  flagSpec "expose-overloaded-unfoldings"     Opt_ExposeOverloadedUnfoldings,
   flagSpec "keep-auto-rules"                  Opt_KeepAutoRules,
   flagSpec "expose-internal-symbols"          Opt_ExposeInternalSymbols,
   flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,


=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -57,7 +57,7 @@ import GHC.Core.Tidy
 import GHC.Core.Seq         ( seqBinds )
 import GHC.Core.Opt.Arity   ( exprArity, typeArity, exprBotStrictness_maybe )
 import GHC.Core.InstEnv
-import GHC.Core.Type     ( Type, tidyTopType )
+import GHC.Core.Type
 import GHC.Core.DataCon
 import GHC.Core.TyCon
 import GHC.Core.Class
@@ -87,6 +87,8 @@ import GHC.Types.Name.Cache
 import GHC.Types.Avail
 import GHC.Types.Tickish
 import GHC.Types.TypeEnv
+import GHC.Tc.Utils.TcType (tcSplitNestedSigmaTys)
+
 
 import GHC.Unit.Module
 import GHC.Unit.Module.ModGuts
@@ -100,6 +102,7 @@ import Data.Function
 import Data.List        ( sortBy, mapAccumL )
 import qualified Data.Set as S
 import GHC.Types.CostCentre
+import GHC.Core.Predicate
 
 {-
 Constructing the TypeEnv, Instances, Rules from which the
@@ -367,7 +370,9 @@ three places this is actioned:
 
 data UnfoldingExposure
   = ExposeNone -- ^ Don't expose unfoldings
-  | ExposeSome -- ^ Only expose required unfoldings
+  | ExposeSome -- ^ Expose mandatory unfoldings and those meeting inlining thresholds.
+  | ExposeOverloaded -- ^ Expose unfoldings useful for inlinings and those which
+                     -- which might be specialised.
   | ExposeAll  -- ^ Expose all unfoldings
   deriving (Show,Eq,Ord)
 
@@ -805,6 +810,8 @@ addExternal opts id
                                  -- source is an inline rule
 
        || not dont_inline
+
+       || opt_expose_unfoldings opts == ExposeOverloaded && isOverloaded id
        where
          dont_inline
             | never_active = True   -- Will never inline
@@ -821,6 +828,51 @@ addExternal opts id
     show_unfolding (DFunUnfolding {}) = True
     show_unfolding _                  = False
 
+isOverloaded :: Id -> Bool
+isOverloaded fn =
+  let fun_type = idType fn
+      -- TODO: The specialiser currently doesn't handle newtypes of the
+      -- form `newtype T x = T (C x => x)` well. So we don't bother
+      -- looking through newtypes for constraints.
+      -- (Newtypes are opaque to tcSplitNestedSigmaTys)
+      (_ty_vars, constraints, _ty) = tcSplitNestedSigmaTys fun_type
+
+  in any (not . (\x -> isEqPred x || isEqPrimPred x)) constraints
+
+{- Note [Exposing overloaded functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also #13090 and #22942.
+
+The basic idea is that exposing only overloaded function is reasonably cheap
+but allows the specializer to fire more often as unfoldings for overloaded
+functions will generally be available. So we make the unfoldings of overloaded
+functions available by default.
+
+We use `tcSplitNestedSigmaTys` to see the constraints deep withing in types like:
+  f :: Int -> forall a. Eq a => blah
+
+We can't simply use isClassPred to check if any of the constraints responds to
+a class dictionary because of programs like the one below:
+
+    type family C a where
+      C Int = Eq Int
+      C Bool = Ord Bool
+
+
+    bar :: C a => a -> a -> Bool
+    bar = undefined
+    {-# SPECIALIZE bar :: Int -> Int -> Bool #-}
+
+GHC will specialize `bar` properly. However `C a =>` isn't recognized as class
+predicate since it's a type family in the definition. To ensure it's exposed
+anyway we allow for some false positives and merely try to rule out constraints
+which we know to be useless to the specializer. Rather than looking for all useful
+ones.
+
+This means we might expose a few unhelpful unfoldings. But it seems like the better
+choice.
+-}
+
 {-
 ************************************************************************
 *                                                                      *


=====================================
docs/users_guide/hints.rst
=====================================
@@ -390,8 +390,9 @@ GHC requires the functions unfolding. The following flags can
 be used to control unfolding creation. Making their creation more
 or less likely:
 
-* :ghc-flag:`-fexpose-all-unfoldings`
 * :ghc-flag:`-funfolding-creation-threshold=⟨n⟩`
+* :ghc-flag:`-fexpose-overloaded-unfoldings`
+* :ghc-flag:`-fexpose-all-unfoldings`
 
 Inlining decisions
 ~~~~~~~~~~~~~~~~~~


=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -519,10 +519,38 @@ as such you shouldn't need to set any of them explicitly. A flag
 
     :default: off
 
-    An experimental flag to expose all unfoldings, even for very large
+    An flag to expose all unfoldings, even for very large
     or recursive functions. This allows for all functions to be inlined
     while usually GHC would avoid inlining larger functions.
 
+.. ghc-flag:: -fexpose-overloaded-unfoldings
+    :shortdesc: Expose unfoldings which might be specialised, even for very large or recursive functions.
+    :type: dynamic
+    :reverse: -fno-expose-overloaded-unfoldings
+    :category:
+
+    :default: off but enabled by :ghc-flag:`-O`.
+
+    An experimental flag to expose overloaded unfoldings, even for very large
+    or recursive functions. This allows for these functions to be specialised
+    or inlined while usually GHC would avoid inlining or specialising larger functions.
+
+    This is intended to be used for cases where specialization is considered
+    crucial but :ghc-flag:`-fexpose-all-unfoldings` imposes too much compile
+    time cost.
+
+    Currently this won't expose unfoldings where a type class is hidden under a
+    newtype. That is for cases like: ::
+
+        newtype NT a = NT (Integral a => a)
+
+        foo :: NT a -> T1 -> TR
+
+    GHC won't recognise `foo` as specialisable and won't expose the unfolding
+    even with the flag enabled.
+
+
+
 .. ghc-flag:: -ffloat-in
     :shortdesc: Turn on the float-in transformation. Implied by :ghc-flag:`-O`.
     :type: dynamic
@@ -1125,7 +1153,8 @@ as such you shouldn't need to set any of them explicitly. A flag
     regardless of size if its unfolding is available. This flag is not
     included in any optimisation level as it can massively increase code
     size. It can be used in conjunction with :ghc-flag:`-fexpose-all-unfoldings`
-    if you want to ensure all calls are specialised.
+    or :ghc-flag:`-fexpose-overloaded-unfoldings` if you want to ensure all calls
+    are specialised.
 
 
 .. ghc-flag:: -fcross-module-specialise


=====================================
testsuite/tests/simplCore/should_compile/T16038/Makefile
=====================================
@@ -6,5 +6,5 @@ T16038:
 	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c A.hs-boot
 	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c B.hs
 	# All `fEqHsExpr` bindings should be in one recursive group:
-	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c A.hs -ddump-simpl -dsuppress-all | \
+	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c A.hs -ddump-simpl -dsuppress-all -fno-expose-overloaded-unfoldings | \
 		grep -e "^\$$fEqHsExpr" -e "Rec"


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -332,7 +332,7 @@ test('T18231', [ only_ways(['optasm']), grep_errmsg(r'^[\w\.]+ ::.*->.*') ], com
 # Cast WW
 test('T17673', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
 test('T18078', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
-test('T18328', [ only_ways(['optasm']), grep_errmsg(r'Arity=') ], compile, ['-ddump-simpl -dsuppress-uniques'])
+test('T18328', [ only_ways(['optasm']), grep_errmsg(r'(Arity=2)',1) ], compile, ['-ddump-simpl -dsuppress-uniques'])
 test('T18347', normal, compile, ['-dcore-lint -O'])
 test('T18355', [ grep_errmsg(r'OneShot') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
 test('T18399', normal, compile, ['-dcore-lint -O'])
@@ -364,7 +364,7 @@ test('T19599a', normal, compile, ['-O -ddump-rules'])
 # Look for a specialisation rule for wimwam
 test('T19672', normal, compile, ['-O2 -ddump-rules'])
 
-test('T20103',  [ grep_errmsg(r'Arity') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
+test('T20103',  [ grep_errmsg(r'(Arity=[0-9]*)',[1]) ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
 test('T19780', normal, compile, ['-O2'])
 test('T19794', normal, compile, ['-O'])
 test('T19890',  [ grep_errmsg(r'= T19890.foo1') ], compile, ['-O -ddump-simpl'])


=====================================
testsuite/tests/stranal/should_compile/T23398.stderr
=====================================
@@ -47,7 +47,9 @@ T23398.$wbar [InlPrag=[2], Occ=LoopBreaker]
 [GblId[StrictWorker([~, !])],
  Arity=4,
  Str=<L><SP(A,SC(S,L),A)><1L><L>,
- Unf=OtherCon []]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [0 30 60 0] 91 70}]
 T23398.$wbar
   = \ (@a)
       (@b)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b03cf7eab68250757ac6052d4b1ca1a8504961f4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b03cf7eab68250757ac6052d4b1ca1a8504961f4
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/20231124/ccc0bf98/attachment-0001.html>


More information about the ghc-commits mailing list