[Git][ghc/ghc][master] spec-constr: Lift argument limit for SPEC-marked functions

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Wed Sep 13 23:22:03 UTC 2023



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
56b403c9 by Ben Gamari at 2023-09-13T19:21:36-04:00
spec-constr: Lift argument limit for SPEC-marked functions

When the user adds a SPEC argument to a function, they are informing us
that they expect the function to be specialised. However, previously
this instruction could be preempted by the specialised-argument limit
(sc_max_args). Fix this.

This fixes #14003.

- - - - -


4 changed files:

- compiler/GHC/Core/Opt/SpecConstr.hs
- + testsuite/tests/simplCore/should_compile/T14003.hs
- + testsuite/tests/simplCore/should_compile/T14003.stderr
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -519,14 +519,17 @@ This is all quite ugly; we ought to come up with a better design.
 ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
 sc_force to True when calling specLoop. This flag does four things:
 
-  * Ignore specConstrThreshold, to specialise functions of arbitrary size
+(FS1) Ignore specConstrThreshold, to specialise functions of arbitrary size
         (see scTopBind)
-  * Ignore specConstrCount, to make arbitrary numbers of specialisations
+(FS2) Ignore specConstrCount, to make arbitrary numbers of specialisations
         (see specialise)
-  * Specialise even for arguments that are not scrutinised in the loop
+(FS3) Specialise even for arguments that are not scrutinised in the loop
         (see argToPat; #4448)
-  * Only specialise on recursive types a finite number of times
-        (see is_too_recursive; #5550; Note [Limit recursive specialisation])
+(FS4) Only specialise on recursive types a finite number of times
+        (see sc_recursive; #5550; Note [Limit recursive specialisation])
+(FS5) Lift the restriction on the maximum number of arguments which
+        the optimisation will specialise.
+        (see `too_many_worker_args` in `callsToNewPats`; #14003)
 
 The flag holds only for specialising a single binding group, and NOT
 for nested bindings.  (So really it should be passed around explicitly
@@ -1403,7 +1406,7 @@ scBind top_lvl env (NonRec bndr rhs) do_body
 scBind top_lvl env (Rec prs) do_body
   | isTopLevel top_lvl
   , Just threshold <- sc_size (sc_opts env)
-  , not force_spec
+  , not force_spec -- See Note [Forcing specialisation], point (FS1)
   , not (all (couldBeSmallEnoughToInline (sc_uf_opts (sc_opts env)) threshold) rhss)
   = -- Do no specialisation if the RHSs are too big
     -- ToDo: I'm honestly not sure of the rationale of this size-testing, nor
@@ -1773,6 +1776,7 @@ specRec env body_calls rhs_infos
       , sc_force env || isNothing (sc_count opts)
            -- If both of these are false, the sc_count
            -- threshold will prevent non-termination
+           -- See Note [Forcing specialisation], point (FS4) and (FS2)
       , any ((> the_limit) . si_n_specs) spec_infos
       = -- Give up on specialisation, but don't forget to include the rhs_usg
         -- for the unspecialised function, since it may now be called
@@ -2399,8 +2403,11 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
               non_dups = nubBy samePat new_pats
 
               -- Remove ones that have too many worker variables
-              small_pats = filterOut too_big non_dups
-              too_big (CP { cp_qvars = vars, cp_args = args })
+              small_pats = filterOut too_many_worker_args non_dups
+
+              too_many_worker_args _
+                | sc_force env = False -- See (FS5) of Note [Forcing specialisation]
+              too_many_worker_args (CP { cp_qvars = vars, cp_args = args })
                 = not (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars)
                   -- We are about to construct w/w pair in 'spec_one'.
                   -- Omit specialisation leading to high arity workers.
@@ -2693,6 +2700,7 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str
   -- In that case it counts as "interesting"
 argToPat1 env in_scope val_env (Var v) arg_occ arg_str
   | sc_force env || specialisableArgOcc arg_occ  -- (a)
+    -- See Note [Forcing specialisation], point (FS3)
   , is_value                                     -- (b)
        -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]
        -- So sc_keen focused just on f (I# x), where we have freshly-allocated


=====================================
testsuite/tests/simplCore/should_compile/T14003.hs
=====================================
@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -fspec-constr -fmax-worker-args=2 #-}
+
+-- | Ensure that functions with SPEC arguments are constructor-specialised
+-- even if their argument count exceeds -fmax-worker-args.
+module T14003 (pat1, pat2, pat3, pat4) where
+
+import GHC.Exts
+
+hi :: SPEC
+   -> Maybe Int
+   -> Maybe Int
+   -> Maybe Int
+   -> Int
+hi SPEC (Just x) (Just y) (Just z) = x+y+z
+hi SPEC (Just x) _        _        = hi SPEC (Just x) (Just 42) Nothing
+hi SPEC Nothing  _        _        = 42
+
+pat1 :: Int -> Int
+pat1 n = hi SPEC (Just n) (Just 4) (Just 0)
+
+pat2 :: Int -> Int
+pat2 n = hi SPEC Nothing (Just n) Nothing
+
+pat3 :: Int -> Int
+pat3 n = hi SPEC Nothing Nothing (Just n)
+
+pat4 :: Int -> Int
+pat4 n = hi SPEC Nothing (Just n) (Just n)
+
+


=====================================
testsuite/tests/simplCore/should_compile/T14003.stderr
=====================================
@@ -0,0 +1,349 @@
+
+==================== SpecConstr ====================
+Result size of SpecConstr
+  = {terms: 179, types: 124, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule_sF4 :: Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 20 0}]
+$trModule_sF4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule_sF5 :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+$trModule_sF5 = GHC.Types.TrNameS $trModule_sF4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule_sF6 :: Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 30 0}]
+$trModule_sF6 = "T14003"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule_sF7 :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+$trModule_sF7 = GHC.Types.TrNameS $trModule_sF6
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T14003.$trModule :: GHC.Types.Module
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+T14003.$trModule = GHC.Types.Module $trModule_sF5 $trModule_sF7
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+lvl_sFY :: Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 100 0}]
+lvl_sFY = "T14003.hs:(14,1)-(16,39)|function hi"#
+
+-- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0}
+lvl_sFp :: ()
+[LclId,
+ Str=b,
+ Cpr=b,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=False, ConLike=False, WorkFree=False, Expandable=False,
+         Guidance=NEVER}]
+lvl_sFp = Control.Exception.Base.patError @LiftedRep @() lvl_sFY
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl_sFm :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+lvl_sFm = GHC.Types.I# 42#
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+lvl_sFn :: Maybe Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+lvl_sFn = GHC.Maybe.Just @Int lvl_sFm
+
+Rec {
+-- RHS size: {terms: 8, types: 4, coercions: 0, joins: 0/0}
+$s$whi_sGi :: Int# -> Int -> Int#
+[LclId[StrictWorker([])], Arity=2, Str=<L><L>]
+$s$whi_sGi
+  = \ (sc_sGf :: Int#) (sc_sGe :: Int) ->
+      $whi_sFB
+        GHC.Types.SPEC
+        (GHC.Maybe.Just @Int sc_sGe)
+        lvl_sFn
+        (GHC.Maybe.Nothing @Int)
+
+-- RHS size: {terms: 11, types: 5, coercions: 0, joins: 0/0}
+$s$whi_sGa :: Int# -> Int# -> Int -> Int#
+[LclId[StrictWorker([])], Arity=3, Str=<L><L><L>]
+$s$whi_sGa
+  = \ (sc_sG5 :: Int#) (sc_sG4 :: Int#) (sc_sG3 :: Int) ->
+      case sc_sG3 of { I# x_aFe -> +# (+# x_aFe sc_sG4) sc_sG5 }
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+$s$whi_sGb :: Int -> Int#
+[LclId[StrictWorker([])], Arity=1, Str=<L>]
+$s$whi_sGb = \ (sc_sG6 :: Int) -> 42#
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+$s$whi_sGc :: Int -> Int#
+[LclId[StrictWorker([])], Arity=1, Str=<L>]
+$s$whi_sGc = \ (sc_sG7 :: Int) -> 42#
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$s$whi_sGd :: Int -> Int -> Int#
+[LclId[StrictWorker([])], Arity=2, Str=<L><L>]
+$s$whi_sGd = \ (sc_sG9 :: Int) (sc_sG8 :: Int) -> 42#
+
+-- RHS size: {terms: 47, types: 26, coercions: 0, joins: 0/0}
+$whi_sFB [InlPrag=[2], Occ=LoopBreaker]
+  :: SPEC -> Maybe Int -> Maybe Int -> Maybe Int -> Int#
+[LclId[StrictWorker([])],
+ Arity=4,
+ Str=<SL><SL><L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [30 30 80 62] 212 0},
+ RULES: "SC:$whi4" [2]
+            forall (sc_sGf :: Int#) (sc_sGe :: Int).
+              $whi_sFB GHC.Types.SPEC
+                       (GHC.Maybe.Just @Int sc_sGe)
+                       (GHC.Maybe.Just @Int (GHC.Types.I# sc_sGf))
+                       (GHC.Maybe.Nothing @Int)
+              = $s$whi_sGi sc_sGf sc_sGe
+        "SC:$whi0" [2]
+            forall (sc_sG5 :: Int#) (sc_sG4 :: Int#) (sc_sG3 :: Int).
+              $whi_sFB GHC.Types.SPEC
+                       (GHC.Maybe.Just @Int sc_sG3)
+                       (GHC.Maybe.Just @Int (GHC.Types.I# sc_sG4))
+                       (GHC.Maybe.Just @Int (GHC.Types.I# sc_sG5))
+              = $s$whi_sGa sc_sG5 sc_sG4 sc_sG3
+        "SC:$whi1" [2]
+            forall (sc_sG6 :: Int).
+              $whi_sFB GHC.Types.SPEC
+                       (GHC.Maybe.Nothing @Int)
+                       (GHC.Maybe.Just @Int sc_sG6)
+                       (GHC.Maybe.Nothing @Int)
+              = $s$whi_sGb sc_sG6
+        "SC:$whi2" [2]
+            forall (sc_sG7 :: Int).
+              $whi_sFB GHC.Types.SPEC
+                       (GHC.Maybe.Nothing @Int)
+                       (GHC.Maybe.Nothing @Int)
+                       (GHC.Maybe.Just @Int sc_sG7)
+              = $s$whi_sGc sc_sG7
+        "SC:$whi3" [2]
+            forall (sc_sG9 :: Int) (sc_sG8 :: Int).
+              $whi_sFB GHC.Types.SPEC
+                       (GHC.Maybe.Nothing @Int)
+                       (GHC.Maybe.Just @Int sc_sG8)
+                       (GHC.Maybe.Just @Int sc_sG9)
+              = $s$whi_sGd sc_sG9 sc_sG8]
+$whi_sFB
+  = \ (ds_sFv [Dmd=SL] :: SPEC)
+      (ds_sFw [Dmd=SL] :: Maybe Int)
+      (ds_sFx :: Maybe Int)
+      (ds_sFy :: Maybe Int) ->
+      case ds_sFv of {
+        SPEC ->
+          case ds_sFw of wild_X2 [Dmd=A] {
+            Nothing -> 42#;
+            Just x_ayD [Dmd=S] ->
+              case ds_sFx of {
+                Nothing ->
+                  $whi_sFB GHC.Types.SPEC wild_X2 lvl_sFn (GHC.Maybe.Nothing @Int);
+                Just y_ayE [Dmd=S!P(S)] ->
+                  case ds_sFy of {
+                    Nothing ->
+                      $whi_sFB GHC.Types.SPEC wild_X2 lvl_sFn (GHC.Maybe.Nothing @Int);
+                    Just z_ayF [Dmd=S!P(S)] ->
+                      case x_ayD of { I# x_aFe ->
+                      case y_ayE of { I# y_aFh ->
+                      case z_ayF of { I# y_X7 -> +# (+# x_aFe y_aFh) y_X7 }
+                      }
+                      }
+                  }
+              }
+          };
+        SPEC2 -> case lvl_sFp of {}
+      }
+end Rec }
+
+-- RHS size: {terms: 13, types: 8, coercions: 0, joins: 0/0}
+hi [InlPrag=[2]]
+  :: SPEC -> Maybe Int -> Maybe Int -> Maybe Int -> Int
+[LclId,
+ Arity=4,
+ Str=<SL><SL><L><L>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (ds_sFv [Occ=Once1, Dmd=SL] :: SPEC)
+                 (ds_sFw [Occ=Once1, Dmd=SL] :: Maybe Int)
+                 (ds_sFx [Occ=Once1] :: Maybe Int)
+                 (ds_sFy [Occ=Once1] :: Maybe Int) ->
+                 case $whi_sFB ds_sFv ds_sFw ds_sFx ds_sFy of ww_sFS [Occ=Once1]
+                 { __DEFAULT ->
+                 GHC.Types.I# ww_sFS
+                 }}]
+hi
+  = \ (ds_sFv [Dmd=SL] :: SPEC)
+      (ds_sFw [Dmd=SL] :: Maybe Int)
+      (ds_sFx :: Maybe Int)
+      (ds_sFy :: Maybe Int) ->
+      case $whi_sFB ds_sFv ds_sFw ds_sFx ds_sFy of ww_sFS { __DEFAULT ->
+      GHC.Types.I# ww_sFS
+      }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl_sFq :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+lvl_sFq = GHC.Types.I# 4#
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+lvl_sFr :: Maybe Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+lvl_sFr = GHC.Maybe.Just @Int lvl_sFq
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl_sFs :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+lvl_sFs = GHC.Types.I# 0#
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+lvl_sFt :: Maybe Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [] 10 10}]
+lvl_sFt = GHC.Maybe.Just @Int lvl_sFs
+
+-- RHS size: {terms: 11, types: 3, coercions: 0, joins: 0/0}
+pat1 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<L>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (n_aBn [Occ=Once1] :: Int) ->
+                 hi GHC.Types.SPEC (GHC.Maybe.Just @Int n_aBn) lvl_sFr lvl_sFt}]
+pat1
+  = \ (n_aBn :: Int) ->
+      case $whi_sFB
+             GHC.Types.SPEC (GHC.Maybe.Just @Int n_aBn) lvl_sFr lvl_sFt
+      of ww_sFS
+      { __DEFAULT ->
+      GHC.Types.I# ww_sFS
+      }
+
+-- RHS size: {terms: 11, types: 5, coercions: 0, joins: 0/0}
+pat2 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<L>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (n_aBo [Occ=Once1] :: Int) ->
+                 hi
+                   GHC.Types.SPEC
+                   (GHC.Maybe.Nothing @Int)
+                   (GHC.Maybe.Just @Int n_aBo)
+                   (GHC.Maybe.Nothing @Int)}]
+pat2
+  = \ (n_aBo :: Int) ->
+      case $whi_sFB
+             GHC.Types.SPEC
+             (GHC.Maybe.Nothing @Int)
+             (GHC.Maybe.Just @Int n_aBo)
+             (GHC.Maybe.Nothing @Int)
+      of ww_sFS
+      { __DEFAULT ->
+      GHC.Types.I# ww_sFS
+      }
+
+-- RHS size: {terms: 11, types: 5, coercions: 0, joins: 0/0}
+pat3 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<L>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (n_aBp [Occ=Once1] :: Int) ->
+                 hi
+                   GHC.Types.SPEC
+                   (GHC.Maybe.Nothing @Int)
+                   (GHC.Maybe.Nothing @Int)
+                   (GHC.Maybe.Just @Int n_aBp)}]
+pat3
+  = \ (n_aBp :: Int) ->
+      case $whi_sFB
+             GHC.Types.SPEC
+             (GHC.Maybe.Nothing @Int)
+             (GHC.Maybe.Nothing @Int)
+             (GHC.Maybe.Just @Int n_aBp)
+      of ww_sFS
+      { __DEFAULT ->
+      GHC.Types.I# ww_sFS
+      }
+
+-- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0}
+pat4 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<L>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (n_aBq :: Int) ->
+                 hi
+                   GHC.Types.SPEC
+                   (GHC.Maybe.Nothing @Int)
+                   (GHC.Maybe.Just @Int n_aBq)
+                   (GHC.Maybe.Just @Int n_aBq)}]
+pat4
+  = \ (n_aBq :: Int) ->
+      case $whi_sFB
+             GHC.Types.SPEC
+             (GHC.Maybe.Nothing @Int)
+             (GHC.Maybe.Just @Int n_aBq)
+             (GHC.Maybe.Just @Int n_aBq)
+      of ww_sFS
+      { __DEFAULT ->
+      GHC.Types.I# ww_sFS
+      }
+
+
+


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -254,6 +254,7 @@ test('T13658', normal, compile, ['-dcore-lint'])
 test('T14779a', normal, compile, ['-dcore-lint'])
 test('T14779b', normal, compile, ['-dcore-lint'])
 test('T13708', normal, compile, [''])
+test('T14003', [only_ways(['optasm']), grep_errmsg('SC:')], compile, ['-ddump-spec-constr'])
 
 # thunk should inline here, so check whether or not it appears in the Core
 # (we skip profasm because it might not inline there)



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56b403c908b0e64ae44817be3e92c2e98e813a78
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/20230913/82383bb9/attachment-0001.html>


More information about the ghc-commits mailing list