From 56b403c908b0e64ae44817be3e92c2e98e813a78 Mon Sep 17 00:00:00 2001 From: Ben Gamari <ben@smart-cactus.org> Date: Sat, 9 Sep 2023 14:26:41 -0400 Subject: [PATCH] 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. --- compiler/GHC/Core/Opt/SpecConstr.hs | 24 +- .../tests/simplCore/should_compile/T14003.hs | 30 ++ .../simplCore/should_compile/T14003.stderr | 349 ++++++++++++++++++ .../tests/simplCore/should_compile/all.T | 1 + 4 files changed, 396 insertions(+), 8 deletions(-) create mode 100644 testsuite/tests/simplCore/should_compile/T14003.hs create mode 100644 testsuite/tests/simplCore/should_compile/T14003.stderr diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 58f5a8476609..1721496f03b6 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/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 diff --git a/testsuite/tests/simplCore/should_compile/T14003.hs b/testsuite/tests/simplCore/should_compile/T14003.hs new file mode 100644 index 000000000000..deef99c0b8c1 --- /dev/null +++ b/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) + + diff --git a/testsuite/tests/simplCore/should_compile/T14003.stderr b/testsuite/tests/simplCore/should_compile/T14003.stderr new file mode 100644 index 000000000000..3198617f28cc --- /dev/null +++ b/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 + } + + + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index c2d83e5a083d..fbeab0238f72 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/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) -- GitLab