[Git][ghc/ghc][wip/T14003] spec-constr: Lift argument limit for SPEC-marked functions
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Sat Sep 9 18:35:08 UTC 2023
Ben Gamari pushed to branch wip/T14003 at Glasgow Haskell Compiler / GHC
Commits:
571b48f9 by Ben Gamari at 2023-09-09T14:35:01-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
=====================================
@@ -528,6 +528,8 @@ sc_force to True when calling specLoop. This flag does four things:
(see argToPat; #4448)
* Only specialise on recursive types a finite number of times
(see is_too_recursive; #5550; Note [Limit recursive specialisation])
+ * Lift the restriction on the maximum number of arguments which
+ the optimisation will specialise (sc_max_args)
The flag holds only for specialising a single binding group, and NOT
for nested bindings. (So really it should be passed around explicitly
@@ -2401,6 +2403,9 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
-- Remove ones that have too many worker variables
small_pats = filterOut too_big non_dups
+
+ too_big _
+ | sc_force env = False -- See Note [Forcing specialisation]
too_big (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'.
=====================================
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,206 @@
+
+==================== SpecConstr ====================
+Result size of SpecConstr
+ = {terms: 126, types: 85, 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
+
+Rec {
+-- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0}
+$shi_sFi :: Int# -> Int# -> Int -> Int
+[LclId[StrictWorker([])], Arity=3, Str=<L><L><L>]
+$shi_sFi
+ = \ (sc_sFd :: Int#) (sc_sFc :: Int#) (sc_sFb :: Int) ->
+ + @Int
+ GHC.Num.$fNumInt
+ (+ @Int GHC.Num.$fNumInt sc_sFb (GHC.Types.I# sc_sFc))
+ (GHC.Types.I# sc_sFd)
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$shi_sFj :: Int -> Int
+[LclId[StrictWorker([])], Arity=1, Str=<L>]
+$shi_sFj = \ (sc_sFe :: Int) -> GHC.Types.I# 42#
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$shi_sFk :: Int -> Int
+[LclId[StrictWorker([])], Arity=1, Str=<L>]
+$shi_sFk = \ (sc_sFf :: Int) -> GHC.Types.I# 42#
+
+-- RHS size: {terms: 4, types: 2, coercions: 0, joins: 0/0}
+$shi_sFl :: Int -> Int -> Int
+[LclId[StrictWorker([])], Arity=2, Str=<L><L>]
+$shi_sFl = \ (sc_sFh :: Int) (sc_sFg :: Int) -> GHC.Types.I# 42#
+
+-- RHS size: {terms: 48, types: 28, coercions: 0, joins: 0/0}
+hi [Occ=LoopBreaker]
+ :: SPEC -> Maybe Int -> Maybe Int -> Maybe Int -> Int
+[LclId,
+ Arity=4,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [150 40 110 110] 450 10},
+ RULES: "SC:hi0"
+ forall (sc_sFd :: Int#) (sc_sFc :: Int#) (sc_sFb :: Int).
+ hi GHC.Types.SPEC
+ (GHC.Maybe.Just @Int sc_sFb)
+ (GHC.Maybe.Just @Int (GHC.Types.I# sc_sFc))
+ (GHC.Maybe.Just @Int (GHC.Types.I# sc_sFd))
+ = $shi_sFi sc_sFd sc_sFc sc_sFb
+ "SC:hi1"
+ forall (sc_sFe :: Int).
+ hi GHC.Types.SPEC
+ (GHC.Maybe.Nothing @Int)
+ (GHC.Maybe.Just @Int sc_sFe)
+ (GHC.Maybe.Nothing @Int)
+ = $shi_sFj sc_sFe
+ "SC:hi2"
+ forall (sc_sFf :: Int).
+ hi GHC.Types.SPEC
+ (GHC.Maybe.Nothing @Int)
+ (GHC.Maybe.Nothing @Int)
+ (GHC.Maybe.Just @Int sc_sFf)
+ = $shi_sFk sc_sFf
+ "SC:hi3"
+ forall (sc_sFh :: Int) (sc_sFg :: Int).
+ hi GHC.Types.SPEC
+ (GHC.Maybe.Nothing @Int)
+ (GHC.Maybe.Just @Int sc_sFg)
+ (GHC.Maybe.Just @Int sc_sFh)
+ = $shi_sFl sc_sFh sc_sFg]
+hi
+ = \ (ds_dEM :: SPEC)
+ (ds_dEN :: Maybe Int)
+ (ds_dEO :: Maybe Int)
+ (ds_dEP :: Maybe Int) ->
+ case ds_dEM of {
+ SPEC ->
+ case ds_dEN of {
+ Nothing -> GHC.Types.I# 42#;
+ Just x_ayD ->
+ case ds_dEO of {
+ Nothing ->
+ hi
+ GHC.Types.SPEC
+ (GHC.Maybe.Just @Int x_ayD)
+ (GHC.Maybe.Just @Int (GHC.Types.I# 42#))
+ (GHC.Maybe.Nothing @Int);
+ Just y_ayE ->
+ case ds_dEP of {
+ Nothing ->
+ hi
+ GHC.Types.SPEC
+ (GHC.Maybe.Just @Int x_ayD)
+ (GHC.Maybe.Just @Int (GHC.Types.I# 42#))
+ (GHC.Maybe.Nothing @Int);
+ Just z_ayF ->
+ + @Int GHC.Num.$fNumInt (+ @Int GHC.Num.$fNumInt x_ayD y_ayE) z_ayF
+ }
+ }
+ };
+ SPEC2 ->
+ case Control.Exception.Base.patError
+ @LiftedRep @() "T14003.hs:(12,1)-(14,39)|function hi"#
+ of {}
+ }
+end Rec }
+
+-- RHS size: {terms: 11, types: 4, coercions: 0, joins: 0/0}
+pat1 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0] 100 0}]
+pat1
+ = \ (n_aBn :: Int) ->
+ hi
+ GHC.Types.SPEC
+ (GHC.Maybe.Just @Int n_aBn)
+ (GHC.Maybe.Just @Int (GHC.Types.I# 4#))
+ (GHC.Maybe.Just @Int (GHC.Types.I# 0#))
+
+-- RHS size: {terms: 7, types: 4, coercions: 0, joins: 0/0}
+pat2 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0] 60 0}]
+pat2
+ = \ (n_aBo :: Int) ->
+ hi
+ GHC.Types.SPEC
+ (GHC.Maybe.Nothing @Int)
+ (GHC.Maybe.Just @Int n_aBo)
+ (GHC.Maybe.Nothing @Int)
+
+-- RHS size: {terms: 7, types: 4, coercions: 0, joins: 0/0}
+pat3 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0] 60 0}]
+pat3
+ = \ (n_aBp :: Int) ->
+ hi
+ GHC.Types.SPEC
+ (GHC.Maybe.Nothing @Int)
+ (GHC.Maybe.Nothing @Int)
+ (GHC.Maybe.Just @Int n_aBp)
+
+-- RHS size: {terms: 8, types: 4, coercions: 0, joins: 0/0}
+pat4 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0] 70 0}]
+pat4
+ = \ (n_aBq :: Int) ->
+ hi
+ GHC.Types.SPEC
+ (GHC.Maybe.Nothing @Int)
+ (GHC.Maybe.Just @Int n_aBq)
+ (GHC.Maybe.Just @Int n_aBq)
+
+
+
=====================================
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', 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/571b48f9f55fc5e42ed11708aa2ab8a8e3f1fa83
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/571b48f9f55fc5e42ed11708aa2ab8a8e3f1fa83
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/20230909/f939f66d/attachment-0001.html>
More information about the ghc-commits
mailing list