[Git][ghc/ghc][wip/andreask/expose-overloaded-unfoldings] Tidy: Add flag to expose unfoldings if they take dictionary arguments.

Andreas Klebinger (@AndreasK) gitlab at gitlab.haskell.org
Fri May 10 14:57:33 UTC 2024



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


Commits:
806d0cda by Andreas Klebinger at 2024-05-10T16:41:28+02:00
Tidy: Add flag to expose unfoldings if they take dictionary arguments.

Add the flag `-fexpose-overloaded-unfoldings` to be able to control this
behaviour.

For ghc's boot libraries file size grew by less than 1% when it was
enabled. However I refrained from enabling it by default for now.

I've also added a section on specialization more broadly to the users
guide.

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

- - - - -


10 changed files:

- compiler/GHC/Driver/Config/Tidy.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/ExposeOverloaded.hs
- + testsuite/tests/simplCore/should_compile/ExposeOverloaded.stderr
- testsuite/tests/simplCore/should_compile/T16038/Makefile
- testsuite/tests/simplCore/should_compile/all.T


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/Flags.hs
=====================================
@@ -328,6 +328,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
@@ -581,6 +582,7 @@ codeGenFlags = EnumSet.fromList
 
      -- Flags that affect generated code
    , Opt_ExposeAllUnfoldings
+   , Opt_ExposeOverloadedUnfoldings
    , Opt_NoTypeableBinds
    , Opt_Haddock
 


=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2419,6 +2419,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,7 @@ 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
@@ -367,7 +368,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. See Note [Exposing overloaded functions]
   | ExposeAll  -- ^ Expose all unfoldings
   deriving (Show,Eq,Ord)
 
@@ -793,6 +796,10 @@ addExternal opts id
     show_unfold    = show_unfolding unfolding
     never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
     loop_breaker   = isStrongLoopBreaker (occInfo idinfo)
+    -- bottoming_fn: don't inline bottoming functions, unless the
+    -- RHS is very small or trivial (UnfWhen), in which case we
+    -- may as well do so. For example, a cast might cancel with
+    -- the call site.
     bottoming_fn   = isDeadEndSig (dmdSigInfo idinfo)
 
         -- Stuff to do with the Id's unfolding
@@ -800,30 +807,86 @@ addExternal opts id
         -- In GHCi the unfolding is used by importers
 
     show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })
-       = opt_expose_unfoldings opts == ExposeAll
+       = stable || profitable || explicitly_requested
+       where
+        -- Always expose things whose
+        -- source is an inline rule
+        stable = isStableSource src
+        -- Good for perf as it might inline
+        profitable
+          | never_active = False
+          | loop_breaker = False
+          | otherwise =
+              case guidance of
+                UnfWhen {}  -> True
+                UnfIfGoodArgs {} -> not bottoming_fn
+                UnfNever -> False
+        -- Requested by the user through a flag.
+        explicitly_requested =
+          case opt_expose_unfoldings opts of
+            ExposeAll -> True
+            -- Overloaded functions like @foo :: Bar a => ...@
+            -- See Note [Exposing overloaded functions]
+            ExposeOverloaded ->
+              not bottoming_fn && isOverloaded id
             -- 'ExposeAll' says to expose all
             -- unfoldings willy-nilly
-
-       || isStableSource src     -- Always expose things whose
-                                 -- source is an inline rule
-
-       || not dont_inline
-       where
-         dont_inline
-            | never_active = True   -- Will never inline
-            | loop_breaker = True   -- Ditto
-            | otherwise    = case guidance of
-                                UnfWhen {}       -> False
-                                UnfIfGoodArgs {} -> bottoming_fn
-                                UnfNever {}      -> True
-         -- bottoming_fn: don't inline bottoming functions, unless the
-         -- RHS is very small or trivial (UnfWhen), in which case we
-         -- may as well do so For example, a cast might cancel with
-         -- the call site.
+            ExposeSome -> False
+            ExposeNone -> False
 
     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)
+      -- If the specialiser ever starts looking through newtypes properly
+      -- we might want to use a version of tcSplitNestedSigmaTys that looks
+      -- through newtypes.
+      (_ty_vars, constraints, _ty) = tcSplitNestedSigmaTys fun_type
+      -- NB: This will consider functions with only equality constraints overloaded.
+      -- While these sorts of constraints aren't currently useful for specialization
+      -- it's simpler to just include them.
+  in not . null $ 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 when `-fexpose-overloaded-unfoldings is enabled.
+
+We use `tcSplitNestedSigmaTys` to see the constraints deep within in types like:
+  f :: Int -> forall a. Eq a => blah
+
+We could simply use isClassPred to check if any of the constraints responds to
+a class dictionary, but that would miss (perhaps obscure) opportunities
+like the one in the program 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 simply expose all functions which
+have a constraint.
+
+This means we might expose more unhelpful unfoldings. But it seems like the better
+choice.
+-}
+
 {-
 ************************************************************************
 *                                                                      *


=====================================
docs/users_guide/hints.rst
=====================================
@@ -366,6 +366,8 @@ extreme cases making it impossible to compile certain code.
 For this reason GHC offers various ways to tune inlining
 behaviour.
 
+.. _inlining-unfolding-creation:
+
 Unfolding creation
 ~~~~~~~~~~~~~~~~~~
 
@@ -374,8 +376,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
 ~~~~~~~~~~~~~~~~~~
@@ -414,6 +417,97 @@ There are also flags specific to the inlining of generics:
 * :ghc-flag:`-finline-generics`
 * :ghc-flag:`-finline-generics-aggressively`
 
+.. _control-specialization:
+
+Controlling specialization
+--------------------------------------------
+
+.. index::
+    single: specialize-pragma, controlling, specialization
+    single: unfolding, controlling
+
+GHC has the ability to optimize polymorphic code for specific type class instances
+at the use site. We call this specialisation and it's enabled through :ghc-flag:`-fspecialise`
+which is enabled by default at `-O1` or higher.
+
+GHC does this by creating a copy of the overloaded function, optimizing this copy
+for a given type class instance. Calls to the overloaded function using a statically
+known typeclass we created a specialization for will then be replaced by a call
+to the specialized version of the function.
+
+This can often be crucial to avoid overhead at runtime. However since this
+involves potentially making many copies of overloaded functions GHC doesn't
+always apply this optimization by default even in cases where it could do so.
+
+For GHC to be able to specialise, at a miminum the instance it specializes for
+must be known and the overloaded functions unfolding must be available.
+
+Commonly used flag/pragma combinations
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For applications which aren't very compute heavy the defaults are often good enough
+as they try to strike a reasonable balance between compile time and runtime.
+
+For libraries, if exported functions would benefit significantly from specialization,
+it's recommended to enable :ghc-flag:`-fexpose-overloaded-unfoldings` or manually
+attach INLINEABLE pragmas to performance relevant functions.
+This will ensure downstream users can specialize any overloaded functions exposed
+by the library if it's beneficial.
+
+If there are key parts of an application which rely on specialization for performance
+using `SPECIALIZE` pragmas in combination with either :ghc-flag:`-fexpose-overloaded-unfoldings`
+or `INLINEABLE` on key overloaded functions should allow for these functions to
+specialize without affecting overall compile times too much.
+
+For compute heavy code reliant on elimination of as much overhead as possible it's
+recommended to use a combination of :ghc-flag:`-fspecialise-aggressively` and
+:ghc-flag:`-fexpose-overloaded-unfoldings` or :ghc-flag:`-fexpose-all-unfoldings`.
+However this comes at a big cost to compile time.
+
+Unfolding availabiliy
+~~~~~~~~~~~~~~~~~~~~~
+
+Unfolding availabiliy is primarily determined by :ref:`these flags <inlining-unfolding-creation>`.
+
+Of particular interest for specialization are:
+
+* :ghc-flag:`-fexpose-all-unfoldings`
+* :ghc-flag:`-fexpose-overloaded-unfoldings`
+
+The former making *all* unfoldings available, potentially at high compile time cost.
+The later only makes available the functions that are overloaded. It's generally
+better to use :ghc-flag:`-fexpose-overloaded-unfoldings` over :ghc-flag:`-fexpose-all-unfoldings`
+when the goal is to ensure specializations.
+
+When does GHC generate specializations
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Functions get considered for specialization either implicitly when GHC sees a use
+of an overloaded function used with concrete typeclass instances or explicitly
+when a user requests it through pragmas, see :ref:`specialize-pragma` and :ref:`specialize-instance-pragma`.
+
+The specializer then checks a number of conditions *in order* to decide weither or not
+specialization should happen. Below is a best effort of the list of conditions GHC checks
+currently.
+
+* If any of the type class instances have type arguments and :ghc-flag:`-fpolymorphic-specialisation`
+  is not enabled (off by default) the function **won't** be specialised, otherwise
+* if the specialization was requested through a pragma GHC **will** try to create a specialization, otherwise
+* if the function is imported and:
+  + if the unfolding is not available the function **can't** be specialized, otherwise
+  + if :ghc-flag:`-fcross-module-specialise` is not enabled (enabled by `-O`) the
+    function **won't** be specialised, otherwise
+  + if the flag is enabled, and the function has no INLINABLE/INLINE pragma it **won't** be specialised, otherwise
+* if :ghc-flag:`-fspecialise-aggressively` is enabled GHC **will** try to create a specialization, otherwise
+* if the overloaded function is defined in the current module, and all type class instances
+  are statically known it **will** be specialized, otherwise
+* the function **won't** be specialized.
+
+Note that there are some cases in which GHC will try to specialize a function and fail.
+For example if a functions has an OPAQUE pragma or the unfolding is not available.
+
+Once a function is specialized GHC will create a rule, similar to these created by `RULE` pragmas
+which will fire at call sites involving known instances, replacing calls to the overloaded
+function with calls to the specialized function when possible.
 
 .. _hints-os-memory:
 


=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -519,9 +519,45 @@ 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
-    or recursive functions. This allows for all functions to be inlined
-    while usually GHC would avoid inlining larger functions.
+    A flag to expose all unfoldings, even for very large or recursive functions.
+
+    However GHC will still use the usual heuristics to make inlining
+    and specialization choices. This means further measures are needed to
+    get benefits at use sites. Usually this involves one of:
+
+    * :ghc-flag:`-fspecialise-aggressively` to force as much specialization
+      as possible.
+    * `{-# SPECIALIZE #-}` pragmas to ensure specialization to specific types.
+    * Use of the magic `inline` function to force inlining.
+
+.. ghc-flag:: -fexpose-overloaded-unfoldings
+    :shortdesc: Expose unfoldings carrying constraints, even for very large or recursive functions.
+    :type: dynamic
+    :reverse: -fno-expose-overloaded-unfoldings
+    :category:
+
+    :default: off
+
+    This experimental flag is a slightly less heavy weight alternative
+    to :ghc-flag:`-fexpose-all-unfoldings`.
+
+    Instead of exposing all functions it only aims at exposing constrained 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 :ghc-flag:`-fexpose-overloaded-unfoldings` enabled.
+
+    All the other caveats about :ghc-flag:`-fexpose-overloaded-unfoldings`
+    still apply, so please see there for more details.
 
 .. ghc-flag:: -ffloat-in
     :shortdesc: Turn on the float-in transformation. Implied by :ghc-flag:`-O`.
@@ -1120,13 +1156,14 @@ as such you shouldn't need to set any of them explicitly. A flag
 
     :default: off
 
-    By default only type class methods and methods marked ``INLINABLE`` or
-    ``INLINE`` are specialised. This flag will specialise any overloaded function
-    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.
+    This flag controls the specialisation of *imported* functions only.  By default, an imported function
+    is only specialised if it is marked ``INLINEABLE`` or ``INLINE``.
+    But with :ghc-flag:`-fspecialise-aggressively`, an imported function is specialised
+    if its unfolding is available in the interface file.  (Use :ghc-flag:`-fexpose-all-unfoldings`
+    or :ghc-flag:`-fexpose-overloaded-unfoldings` to ensure that the unfolding is put into the interface file.)
 
+    :ghc-flag:`-fspecialise-aggressively` is not included in any optimisation level
+    as it can massively increase code size.
 
 .. ghc-flag:: -fcross-module-specialise
     :shortdesc: Turn on specialisation of overloaded functions imported from


=====================================
testsuite/tests/simplCore/should_compile/ExposeOverloaded.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -O -fno-worker-wrapper -funfolding-creation-threshold=50 -fexpose-overloaded-unfoldings #-}
+
+module ExposeOverloaded where
+
+-- Will get an unfolding because of the Functor
+foo :: Functor f => Maybe (Maybe (Maybe (Maybe (Maybe (Maybe (f a))))))
+    -> (a -> b)
+    -> Maybe (Maybe (Maybe (Maybe (f b))))
+foo (Just (Just (Just (Just (Just (Just x)))))) f = Just $ Just $ Just $ Just $ fmap f x
+foo _ _ = Nothing
+
+type family C a where
+  C Int = Eq Int
+  C Bool = Ord Bool
+
+-- The Enum constraint causes bars unfolding to be exposed.
+bar :: (C a, Enum a) => a -> a -> Bool
+bar a b = fromEnum (succ a) > fromEnum (pred . pred . pred . pred . pred $ b)
+
+
+newtype F t a = F {unF :: (Functor t => t a) }
+
+-- Will get NO unfolding currently since the class dictionary is hidden under the newtype.
+-- We might fix this eventually. But since the specializer doesn't handle this well
+-- this isn't important yet.
+baz :: Maybe (Maybe (Maybe (Maybe (Maybe (Maybe (F t a))))))
+    -> (a -> b)
+    -> Maybe (Maybe (Maybe (Maybe (F t b))))
+baz (Just (Just (Just (Just (Just (Just (x))))))) f = Just $ Just $ Just $ Just $ F $ fmap f (unF x)
+baz _ _ = Nothing
\ No newline at end of file


=====================================
testsuite/tests/simplCore/should_compile/ExposeOverloaded.stderr
=====================================
@@ -0,0 +1,362 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 212, types: 389, coercions: 10, joins: 0/0}
+
+-- RHS size: {terms: 6, types: 8, coercions: 3, joins: 0/0}
+unF :: forall (t :: * -> *) a. F t a -> Functor t => t a
+[GblId[[RecSel]],
+ Arity=2,
+ Str=<1C(1,L)><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True)}]
+unF
+  = \ (@(t_aPC :: * -> *))
+      (@a_aPD)
+      (ds_dWL :: F t_aPC a_aPD)
+      ($dFunctor_aPF :: Functor t_aPC) ->
+      (ds_dWL
+       `cast` (ExposeOverloaded.N:F[0] <t_aPC>_N <a_aPD>_N
+               :: F t_aPC a_aPD ~R# (Functor t_aPC => t_aPC a_aPD)))
+        $dFunctor_aPF
+
+-- RHS size: {terms: 44, types: 123, coercions: 0, joins: 0/0}
+foo
+  :: forall (f :: * -> *) a b.
+     Functor f =>
+     Maybe (Maybe (Maybe (Maybe (Maybe (Maybe (f a))))))
+     -> (a -> b) -> Maybe (Maybe (Maybe (Maybe (f b))))
+[GblId,
+ Arity=3,
+ Str=<MP(1C(1,C(1,L)),A)><1L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=NEVER}]
+foo
+  = \ (@(f_aT4 :: * -> *))
+      (@a_aT5)
+      (@b_aT6)
+      ($dFunctor_aT7 :: Functor f_aT4)
+      (ds_dWq
+         :: Maybe (Maybe (Maybe (Maybe (Maybe (Maybe (f_aT4 a_aT5)))))))
+      (f1_aOI :: a_aT5 -> b_aT6) ->
+      case ds_dWq of {
+        Nothing ->
+          GHC.Internal.Maybe.Nothing @(Maybe (Maybe (Maybe (f_aT4 b_aT6))));
+        Just ds1_dWC ->
+          case ds1_dWC of {
+            Nothing ->
+              GHC.Internal.Maybe.Nothing @(Maybe (Maybe (Maybe (f_aT4 b_aT6))));
+            Just ds2_dWD ->
+              case ds2_dWD of {
+                Nothing ->
+                  GHC.Internal.Maybe.Nothing @(Maybe (Maybe (Maybe (f_aT4 b_aT6))));
+                Just ds3_dWE ->
+                  case ds3_dWE of {
+                    Nothing ->
+                      GHC.Internal.Maybe.Nothing @(Maybe (Maybe (Maybe (f_aT4 b_aT6))));
+                    Just ds4_dWF ->
+                      case ds4_dWF of {
+                        Nothing ->
+                          GHC.Internal.Maybe.Nothing @(Maybe (Maybe (Maybe (f_aT4 b_aT6))));
+                        Just ds5_dWG ->
+                          case ds5_dWG of {
+                            Nothing ->
+                              GHC.Internal.Maybe.Nothing @(Maybe (Maybe (Maybe (f_aT4 b_aT6))));
+                            Just x_aOH ->
+                              GHC.Internal.Maybe.Just
+                                @(Maybe (Maybe (Maybe (f_aT4 b_aT6))))
+                                (GHC.Internal.Maybe.Just
+                                   @(Maybe (Maybe (f_aT4 b_aT6)))
+                                   (GHC.Internal.Maybe.Just
+                                      @(Maybe (f_aT4 b_aT6))
+                                      (GHC.Internal.Maybe.Just
+                                         @(f_aT4 b_aT6)
+                                         (fmap @f_aT4 $dFunctor_aT7 @a_aT5 @b_aT6 f1_aOI x_aOH))))
+                          }
+                      }
+                  }
+              }
+          }
+      }
+
+-- RHS size: {terms: 31, types: 20, coercions: 0, joins: 0/0}
+bar :: forall a. (C a, Enum a) => a -> a -> Bool
+[GblId,
+ Arity=4,
+ Str=<A><SP(MC(1,L),LC(S,L),A,SC(S,L),A,A,A,A)><L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=NEVER}]
+bar
+  = \ (@a_aSb)
+      _ [Occ=Dead]
+      ($dEnum_aSd :: Enum a_aSb)
+      (a1_aOQ :: a_aSb)
+      (b_aOR :: a_aSb) ->
+      case fromEnum @a_aSb $dEnum_aSd (succ @a_aSb $dEnum_aSd a1_aOQ) of
+      { GHC.Types.I# x_aXw ->
+      case fromEnum
+             @a_aSb
+             $dEnum_aSd
+             (pred
+                @a_aSb
+                $dEnum_aSd
+                (pred
+                   @a_aSb
+                   $dEnum_aSd
+                   (pred
+                      @a_aSb
+                      $dEnum_aSd
+                      (pred @a_aSb $dEnum_aSd (pred @a_aSb $dEnum_aSd b_aOR)))))
+      of
+      { GHC.Types.I# y_aXz ->
+      GHC.Prim.tagToEnum# @Bool (GHC.Prim.># x_aXw y_aXz)
+      }
+      }
+
+-- RHS size: {terms: 45, types: 146, coercions: 7, joins: 0/0}
+baz
+  :: forall (t :: * -> *) a b.
+     Maybe (Maybe (Maybe (Maybe (Maybe (Maybe (F t a))))))
+     -> (a -> b) -> Maybe (Maybe (Maybe (Maybe (F t b))))
+[GblId, Arity=2, Str=<1L><L>, Unf=OtherCon []]
+baz
+  = \ (@(t_aR5 :: * -> *))
+      (@a_aR6)
+      (@b_aR7)
+      (ds_dW1
+         :: Maybe (Maybe (Maybe (Maybe (Maybe (Maybe (F t_aR5 a_aR6)))))))
+      (f_aP0 :: a_aR6 -> b_aR7) ->
+      case ds_dW1 of {
+        Nothing ->
+          GHC.Internal.Maybe.Nothing
+            @(Maybe (Maybe (Maybe (F t_aR5 b_aR7))));
+        Just ds1_dWe ->
+          case ds1_dWe of {
+            Nothing ->
+              GHC.Internal.Maybe.Nothing
+                @(Maybe (Maybe (Maybe (F t_aR5 b_aR7))));
+            Just ds2_dWf ->
+              case ds2_dWf of {
+                Nothing ->
+                  GHC.Internal.Maybe.Nothing
+                    @(Maybe (Maybe (Maybe (F t_aR5 b_aR7))));
+                Just ds3_dWg ->
+                  case ds3_dWg of {
+                    Nothing ->
+                      GHC.Internal.Maybe.Nothing
+                        @(Maybe (Maybe (Maybe (F t_aR5 b_aR7))));
+                    Just ds4_dWh ->
+                      case ds4_dWh of {
+                        Nothing ->
+                          GHC.Internal.Maybe.Nothing
+                            @(Maybe (Maybe (Maybe (F t_aR5 b_aR7))));
+                        Just ds5_dWi ->
+                          case ds5_dWi of {
+                            Nothing ->
+                              GHC.Internal.Maybe.Nothing
+                                @(Maybe (Maybe (Maybe (F t_aR5 b_aR7))));
+                            Just x_aOZ ->
+                              GHC.Internal.Maybe.Just
+                                @(Maybe (Maybe (Maybe (F t_aR5 b_aR7))))
+                                (GHC.Internal.Maybe.Just
+                                   @(Maybe (Maybe (F t_aR5 b_aR7)))
+                                   (GHC.Internal.Maybe.Just
+                                      @(Maybe (F t_aR5 b_aR7))
+                                      (GHC.Internal.Maybe.Just
+                                         @(F t_aR5 b_aR7)
+                                         ((\ ($dFunctor_aRQ :: Functor t_aR5) ->
+                                             fmap
+                                               @t_aR5
+                                               $dFunctor_aRQ
+                                               @a_aR6
+                                               @b_aR7
+                                               f_aP0
+                                               ((x_aOZ
+                                                 `cast` (ExposeOverloaded.N:F[0] <t_aR5>_N <a_aR6>_N
+                                                         :: F t_aR5 a_aR6
+                                                            ~R# (Functor t_aR5 => t_aR5 a_aR6)))
+                                                  $dFunctor_aRQ))
+                                          `cast` (Sym (ExposeOverloaded.N:F[0] <t_aR5>_N <b_aR7>_N)
+                                                  :: (Functor t_aR5 => t_aR5 b_aR7)
+                                                     ~R# F t_aR5 b_aR7)))))
+                          }
+                      }
+                  }
+              }
+          }
+      }
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 20 0}]
+ExposeOverloaded.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+ExposeOverloaded.$trModule3
+  = GHC.Types.TrNameS ExposeOverloaded.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 50 0}]
+ExposeOverloaded.$trModule2 = "ExposeOverloaded"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+ExposeOverloaded.$trModule1
+  = GHC.Types.TrNameS ExposeOverloaded.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+ExposeOverloaded.$trModule
+  = GHC.Types.Module
+      ExposeOverloaded.$trModule3 ExposeOverloaded.$trModule1
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$tcF1 [InlPrag=[~]] :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+ExposeOverloaded.$tcF1
+  = GHC.Types.KindRepFun GHC.Types.krep$*Arr* GHC.Types.krep$*Arr*
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep_rXL :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep_rXL = GHC.Types.KindRepVar 1#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep1_rXM :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep1_rXM = GHC.Types.KindRepVar 0#
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep2_rXN :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep2_rXN
+  = GHC.Types.:
+      @GHC.Types.KindRep $krep1_rXM (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep3_rXO :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep3_rXO
+  = GHC.Types.KindRepTyConApp GHC.Internal.Base.$tcFunctor $krep2_rXN
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep4_rXP :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep4_rXP = GHC.Types.KindRepApp $krep1_rXM $krep_rXL
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep5_rXQ :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep5_rXQ = GHC.Types.KindRepFun $krep3_rXO $krep4_rXP
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$tcF3 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 20 0}]
+ExposeOverloaded.$tcF3 = "F"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$tcF2 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+ExposeOverloaded.$tcF2 = GHC.Types.TrNameS ExposeOverloaded.$tcF3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$tcF :: GHC.Types.TyCon
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+ExposeOverloaded.$tcF
+  = GHC.Types.TyCon
+      12501119209406789822#Word64
+      801305613953237324#Word64
+      ExposeOverloaded.$trModule
+      ExposeOverloaded.$tcF2
+      0#
+      ExposeOverloaded.$tcF1
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep6_rXR :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep6_rXR
+  = GHC.Types.:
+      @GHC.Types.KindRep $krep_rXL (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep7_rXS :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep7_rXS = GHC.Types.: @GHC.Types.KindRep $krep1_rXM $krep6_rXR
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep8_rXT :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep8_rXT
+  = GHC.Types.KindRepTyConApp ExposeOverloaded.$tcF $krep7_rXS
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$tc'F1 [InlPrag=[~]] :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+ExposeOverloaded.$tc'F1
+  = GHC.Types.KindRepFun $krep5_rXQ $krep8_rXT
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$tc'F3 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 20 0}]
+ExposeOverloaded.$tc'F3 = "'F"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$tc'F2 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+ExposeOverloaded.$tc'F2 = GHC.Types.TrNameS ExposeOverloaded.$tc'F3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+ExposeOverloaded.$tc'F :: GHC.Types.TyCon
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+ExposeOverloaded.$tc'F
+  = GHC.Types.TyCon
+      4352013886347538781#Word64
+      11126594965226303942#Word64
+      ExposeOverloaded.$trModule
+      ExposeOverloaded.$tc'F2
+      2#
+      ExposeOverloaded.$tc'F1
+
+
+


=====================================
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
=====================================
@@ -34,6 +34,13 @@ test('T7162', normal, compile, [''])
 
 test('dfun-loop', normal, compile, [''])
 test('strict-float', normal, compile, [''])
+
+# Check if overloaded functions get unfoldings
+test('ExposeOverloaded', [only_ways('[optasm]'), grep_errmsg('Unf=Unf')], compile, ['-ddump-simpl -dno-suppress-unfoldings'])
+# Check if it works for newtypes (currently doesn't)
+test('ExposeOverloadedNewtype', [only_ways('[optasm]'), grep_errmsg('Unf=Unf')], compile, ['-ddump-simpl -dno-suppress-unfoldings -dno-typeable-binds'])
+
+
 test('T3118', normal, compile, ['-Wno-overlapping-patterns'])
 test('T4203', normal, compile, [''])
 
@@ -332,7 +339,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'])
@@ -363,7 +370,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'])



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/806d0cda9d236259c77fc2ce3dc3f60af1d18b18
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/20240510/67535dc3/attachment-0001.html>


More information about the ghc-commits mailing list