diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2021-05-22 23:46:43 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-06-18 12:27:33 -0400 |
commit | 3b783496aa6b74cdca767347916de963b34ca718 (patch) | |
tree | 6655fb0d45d73cf4f04ab70d51bb4bf5f318604c | |
parent | a0622459f1d9a7068e81b8a707ffc63e153444f8 (diff) | |
download | haskell-3b783496aa6b74cdca767347916de963b34ca718.tar.gz |
Enhance cast worker/wrapper for INLINABLE
In #19890 we realised that cast worker/wrapper didn't really work
properly for functions with an INLINABLE pragma, and hence a stable
unfolding. This patch fixes the problem.
Instead of disabling cast w/w when there is a stable unfolding (as
we did before), we now tranfer the stable unfolding to the worker.
It turned out that it was easier to do that if I moved the cast
w/w stuff from prepareBinding to completeBind.
No chnages at all in nofib results:
--------------------------------------------------------------------------------
Program Size Allocs Runtime Elapsed TotalMem
--------------------------------------------------------------------------------
Min -0.0% 0.0% -63.8% -78.2% 0.0%
Max -0.0% 0.0% +11.8% +11.7% 0.0%
Geometric Mean -0.0% -0.0% -26.6% -33.4% -0.0%
Small decreases in compile-time allocation for two tests (below)
of around 2%.
T12545 increased in compile-time alloc by 4%, but it's not
reproducible on my machine, and is a known-wobbly test.
Metric Increase:
T12545
Metric Decrease:
T18698a
T18698b
-rw-r--r-- | compiler/GHC/Core.hs | 20 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 243 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap.hs | 44 | ||||
-rw-r--r-- | compiler/GHC/Core/Unfold.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Core/Unfold/Make.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Types/Id.hs | 11 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T18078.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T19890.hs | 8 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T19890.stderr | 178 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T8331.stderr | 42 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T9509.stdout | 4 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 2 |
12 files changed, 411 insertions, 149 deletions
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 05df4a7a7d..a17604300f 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -64,8 +64,8 @@ module GHC.Core ( maybeUnfoldingTemplate, otherCons, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isStableUnfolding, hasCoreUnfolding, hasSomeUnfolding, - isBootUnfolding, + isStableUnfolding, isInlineUnfolding, isBootUnfolding, + hasCoreUnfolding, hasSomeUnfolding, canUnfold, neverUnfoldGuidance, isStableSource, -- * Annotated expression data types @@ -1462,6 +1462,22 @@ isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src isStableUnfolding (DFunUnfolding {}) = True isStableUnfolding _ = False +isInlineUnfolding :: Unfolding -> Bool +-- ^ True of a /stable/ unfolding that is +-- (a) always inlined; that is, with an `UnfWhen` guidance, or +-- (b) a DFunUnfolding which never needs to be inlined +isInlineUnfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) + | isStableSource src + , UnfWhen {} <- guidance + = True + +isInlineUnfolding (DFunUnfolding {}) + = True + +-- Default case +isInlineUnfolding _ = False + + -- | Only returns False if there is no unfolding information available at all hasSomeUnfolding :: Unfolding -> Bool hasSomeUnfolding NoUnfolding = False diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index be8b72ace4..caa18050e2 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -359,8 +359,8 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -- ANF-ise a constructor or PAP rhs -- We get at most one float per argument here - ; (let_floats, bndr2, body2) <- {-#SCC "prepareBinding" #-} - prepareBinding env top_lvl bndr bndr1 body1 + ; (let_floats, body2) <- {-#SCC "prepareBinding" #-} + prepareBinding env top_lvl bndr1 body1 ; let body_floats2 = body_floats1 `addLetFloats` let_floats ; (rhs_floats, rhs') @@ -385,7 +385,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se ; return (floats, rhs') } ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) - top_lvl Nothing bndr bndr2 rhs' + top_lvl Nothing bndr bndr1 rhs' ; return (rhs_floats `addFloats` bind_float, env2) } -------------------------- @@ -442,8 +442,7 @@ completeNonRecX :: TopLevelFlag -> SimplEnv completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs = assertPpr (not (isJoinId new_bndr)) (ppr new_bndr) $ - do { (prepd_floats, new_bndr, new_rhs) - <- prepareBinding env top_lvl old_bndr new_bndr new_rhs + do { (prepd_floats, new_rhs) <- prepareBinding env top_lvl new_bndr new_rhs ; let floats = emptyFloats env `addLetFloats` prepd_floats ; (rhs_floats, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict floats new_rhs @@ -461,22 +460,24 @@ completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs {- ********************************************************************* * * - prepareBinding, prepareRhs, makeTrivial + Cast worker/wrapper * * ************************************************************************ -Note [Cast worker/wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Cast worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~ When we have a binding x = e |> co we want to do something very similar to worker/wrapper: $wx = e x = $wx |> co -So now x can be inlined freely. There's a chance that e will be a -constructor application or function, or something like that, so moving -the coercion to the usage site may well cancel the coercions and lead -to further optimisation. Example: +We call this making a cast worker/wrapper in tryCastWorkerWrapper. + +The main motivaiton is that x can be inlined freely. There's a chance +that e will be a constructor application or function, or something +like that, so moving the coercion to the usage site may well cancel +the coercions and lead to further optimisation. Example: data family T a :: * data instance T Int = T Int @@ -489,39 +490,71 @@ to further optimisation. Example: go n = case t of { T m -> go (n-m) } -- This case should optimise -We call this making a cast worker/wrapper, and it's done by prepareBinding. - -We need to be careful with inline/noinline pragmas: - rec { {-# NOINLINE f #-} - f = (...g...) |> co - ; g = ...f... } -This is legitimate -- it tells GHC to use f as the loop breaker -rather than g. Now we do the cast thing, to get something like - rec { $wf = ...g... - ; f = $wf |> co - ; g = ...f... } -Where should the NOINLINE pragma go? If we leave it on f we'll get - rec { $wf = ...g... - ; {-# NOINLINE f #-} - f = $wf |> co - ; g = ...f... } -and that is bad: the whole point is that we want to inline that -cast! We want to transfer the pagma to $wf: - rec { {-# NOINLINE $wf #-} - $wf = ...g... - ; f = $wf |> co - ; g = ...f... } -It's exactly like worker/wrapper for strictness analysis: +A second reason for doing cast worker/wrapper is that the worker/wrapper +pass after strictness analysis can't deal with RHSs like + f = (\ a b c. blah) |> co +Instead, it relies on cast worker/wrapper to get rid of the cast, +leaving a simpler job for demand-analysis worker/wrapper. See #19874. + +Wrinkles + +1. We must /not/ do cast w/w on + f = g |> co + otherwise it'll just keep repeating forever! You might think this + is avoided because the call to tryCastWorkerWrapper is guarded by + preInlineUnconditinally, but I'm worried that a loop-breaker or an + exported Id might say False to preInlineUnonditionally. + +2. We need to be careful with inline/noinline pragmas: + rec { {-# NOINLINE f #-} + f = (...g...) |> co + ; g = ...f... } + This is legitimate -- it tells GHC to use f as the loop breaker + rather than g. Now we do the cast thing, to get something like + rec { $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + Where should the NOINLINE pragma go? If we leave it on f we'll get + rec { $wf = ...g... + ; {-# NOINLINE f #-} + f = $wf |> co + ; g = ...f... } + and that is bad: the whole point is that we want to inline that + cast! We want to transfer the pagma to $wf: + rec { {-# NOINLINE $wf #-} + $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + +3. We should still do cast w/w even if `f` is INLINEABLE. E.g. + {- f: Stable unfolding = <stable-big> -} + f = (\xy. <big-body>) |> co + Then we want to w/w to + {- $wf: Stable unfolding = <stable-big> |> sym co -} + $wf = \xy. <big-body> + f = $wf |> co + Notice that the stable unfolding moves to the worker! Now demand analysis + will work fine on $wf, whereas it has trouble with the original f. + c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap. + +4. We should /not/ do cast w/w for INLINE functions (hence isInlineUnfolding in + tryCastWorkerWrapper) becuase they'll be inlined, cast and all anyway. And + if we do cast w/w for an INLINE function with arity zero, we get something + really silly: we inline that "worker" right back into the wrapper! Worse than + a no-op, because we haev then lost the stable unfolding. + +Both these wrinkles are exactly like worker/wrapper for strictness analysis: f is the wrapper and must inline like crazy $wf is the worker and must carry f's original pragma -See Note [Worker/wrapper for NOINLINE functions] in -GHC.Core.Opt.WorkWrap. +See Note [Worker/wrapper for INLINABLE functions] +and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. -See #17673, #18093, #18078. +See #17673, #18093, #18078, #19890. Note [Preserve strictness in cast w/w] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the Note [Cast worker/wrappers] transformation, keep the strictness info. +In the Note [Cast worker/wrapper] transformation, keep the strictness info. Eg f = e `cast` co -- f has strictness SSL When we transform to @@ -551,41 +584,79 @@ instead, we use (case erorr ... of {}). So I'm not sure this Note makes much sense any more. -} -prepareBinding :: SimplEnv -> TopLevelFlag - -> InId -> OutId -> OutExpr - -> SimplM (LetFloats, OutId, OutExpr) - -prepareBinding env top_lvl old_bndr bndr rhs - | Cast rhs1 co <- rhs - -- Try for cast worker/wrapper - -- See Note [Cast worker/wrappers] - , not (isStableUnfolding (realIdUnfolding old_bndr)) - -- Don't make a cast w/w if the thing is going to be inlined anyway - , not (exprIsTrivial rhs1) - -- Nor if the RHS is trivial; then again it'll be inlined - , let ty1 = coercionLKind co - , not (isUnliftedType ty1) - -- Not if rhs has an unlifted type; see Note [Cast w/w: unlifted] - = do { (floats, new_id) <- makeTrivialBinding (getMode env) top_lvl - (getOccFS bndr) worker_info rhs1 ty1 - ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) - ; return (floats, bndr', Cast (Var new_id) co) } - - | otherwise - = do { (floats, rhs') <- prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs - ; return (floats, bndr, rhs') } - where - info = idInfo bndr - worker_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info - `setCprSigInfo` cprSigInfo info - `setDemandInfo` demandInfo info - `setInlinePragInfo` inlinePragInfo info - `setArityInfo` arityInfo info - -- We do /not/ want to transfer OccInfo, Rules, Unfolding - -- Note [Preserve strictness in cast w/w] +tryCastWorkerWrapper :: SimplEnv -> TopLevelFlag + -> InId -> OccInfo + -> OutId -> OutExpr + -> SimplM (SimplFloats, SimplEnv) +-- See Note [Cast worker/wrapper] +tryCastWorkerWrapper env top_lvl old_bndr occ_info bndr (Cast rhs co) + | not (isJoinId bndr) -- Not for join points + , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform + -- a DFunUnfolding in mk_worker_unfolding + , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1 + , not (isInlineUnfolding unf) -- Not INLINE things: Wrinkle 4 + , not (isUnliftedType rhs_ty) -- Not if rhs has an unlifted type; + -- see Note [Cast w/w: unlifted] + = do { (rhs_floats, work_rhs) <- prepareRhs mode top_lvl occ_fs rhs + ; uniq <- getUniqueM + ; let work_name = mkSystemVarName uniq occ_fs + work_id = mkLocalIdWithInfo work_name Many rhs_ty worker_info + + ; work_unf <- mk_worker_unfolding work_id work_rhs + ; let work_id_w_unf = work_id `setIdUnfolding` work_unf + floats = emptyFloats env + `addLetFloats` rhs_floats + `addLetFloats` unitLetFloat (NonRec work_id_w_unf work_rhs) + + triv_rhs = Cast (Var work_id_w_unf) co + + ; if postInlineUnconditionally env top_lvl bndr occ_info triv_rhs + -- Almost always True, because the RHS is trivial + -- In that case we want to eliminate the binding fast + -- We conservatively use postInlineUnconditionally so that we + -- check all the right things + then do { tick (PostInlineUnconditionally bndr) + ; return ( floats + , extendIdSubst (setInScopeFromF env floats) old_bndr $ + DoneEx triv_rhs Nothing ) } + + else do { wrap_unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs bndr triv_rhs + ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) + `setIdUnfolding` wrap_unf + floats' = floats `extendFloats` NonRec bndr' triv_rhs + ; return ( floats', setInScopeFromF env floats' ) } } + where + mode = getMode env + occ_fs = getOccFS bndr + rhs_ty = coercionLKind co + info = idInfo bndr + unf = unfoldingInfo info + + worker_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info + `setCprSigInfo` cprSigInfo info + `setDemandInfo` demandInfo info + `setInlinePragInfo` inlinePragInfo info + `setArityInfo` arityInfo info + -- We do /not/ want to transfer OccInfo, Rules + -- Note [Preserve strictness in cast w/w] + -- and Wrinkle 2 of Note [Cast worker/wrapper] + + ----------- Worker unfolding ----------- + -- Stable case: if there is a stable unfolding we have to compose with (Sym co); + -- the next round of simplification will do the job + -- Non-stable case: use work_rhs + -- Wrinkle 3 of Note [Cast worker/wrapper] + mk_worker_unfolding work_id work_rhs + = case unf of + CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src } + | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) }) + _ -> mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs + +tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings + = return (mkFloatBind env (NonRec bndr rhs)) mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma --- See Note [Cast wrappers] +-- See Note [Cast worker/wrapper] mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline] @@ -599,6 +670,19 @@ mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) wrap_act | isNeverActive act = activateDuringFinal | otherwise = act + +{- ********************************************************************* +* * + prepareBinding, prepareRhs, makeTrivial +* * +********************************************************************* -} + +prepareBinding :: SimplEnv -> TopLevelFlag + -> OutId -> OutExpr + -> SimplM (LetFloats, OutExpr) +prepareBinding env top_lvl bndr rhs + = prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs + {- Note [prepareRhs] ~~~~~~~~~~~~~~~~~~~~ prepareRhs takes a putative RHS, checks whether it's a PAP or @@ -806,31 +890,32 @@ completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs do { let old_info = idInfo old_bndr old_unf = unfoldingInfo old_info occ_info = occInfo old_info + mode = getMode env -- Do eta-expansion on the RHS of the binding -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils - ; (new_arity, final_rhs) <- tryEtaExpandRhs (getMode env) new_bndr new_rhs + ; (new_arity, eta_rhs) <- tryEtaExpandRhs mode new_bndr new_rhs -- Simplify the unfolding ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr - final_rhs (idType new_bndr) new_arity old_unf + eta_rhs (idType new_bndr) new_arity old_unf - ; let final_bndr = addLetBndrInfo new_bndr new_arity new_unfolding + ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding -- See Note [In-scope set as a substitution] - ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs + ; if postInlineUnconditionally env top_lvl new_bndr_w_info occ_info eta_rhs then -- Inline and discard the binding do { tick (PostInlineUnconditionally old_bndr) ; return ( emptyFloats env , extendIdSubst env old_bndr $ - DoneEx final_rhs (isJoinId_maybe new_bndr)) } + DoneEx eta_rhs (isJoinId_maybe new_bndr)) } -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding - else -- Keep the binding + else -- Keep the binding; do cast worker/wrapper -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $ - return (mkFloatBind env (NonRec final_bndr final_rhs)) } + tryCastWorkerWrapper env top_lvl old_bndr occ_info new_bndr_w_info eta_rhs } addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId addLetBndrInfo new_bndr new_arity_type new_unf diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 87dcd92d1e..8e5244ff4b 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -225,6 +225,8 @@ function will definitely get a w/w split" and that's hard to predict in advance...the logic in mkWwBodies is complex. So I've left the super-simple test, with this Note to explain. +NB: record selectors are ordinary functions, inlined iff GHC wants to, +so won't be caught by the preceding isInlineUnfolding test in tryWW. Note [Worker/wrapper for NOINLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -511,12 +513,16 @@ tryWW ww_opts is_rec fn_id rhs , Just filler <- mkAbsentFiller ww_opts fn_id = return [(new_fn_id, filler)] + -- See Note [Don't w/w INLINE things] + | hasInlineUnfolding fn_id + = return [(new_fn_id, rhs)] + -- See Note [No worker/wrapper for record selectors] | isRecordSelector fn_id = return [ (new_fn_id, rhs ) ] | is_fun && is_eta_exp - = splitFun ww_opts new_fn_id fn_info wrap_dmds div cpr rhs + = splitFun ww_opts new_fn_id fn_info rhs -- See Note [Thunk splitting] | isNonRec is_rec, is_thunk @@ -526,16 +532,8 @@ tryWW ww_opts is_rec fn_id rhs = return [ (new_fn_id, rhs) ] where - fn_info = idInfo fn_id - (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) - - cpr_ty = getCprSig (cprSigInfo fn_info) - -- Arity of the CPR sig should match idArity when it's not a join point. - -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal - cpr = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info) - (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) - <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $ - ct_cpr cpr_ty + fn_info = idInfo fn_id + (wrap_dmds, _) = splitDmdSig (dmdSigInfo fn_info) new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) -- See Note [Zapping DmdEnv after Demand Analyzer] and @@ -649,7 +647,7 @@ Consider this (#19824 comment on 15 May 21): v = ...big... g x = f v x + 1 -So `f` will generate a worker/wrapper split; and `g` (since it is small +So `f` will generate a worker/wrapper split; and `g` (since it is small) will trigger the certainlyWillInline case of splitFun. The danger is that we end up with g {- StableUnfolding = \x -> f v x + 1 -} @@ -670,22 +668,22 @@ by LitRubbish (see Note [Drop absent bindings]) so there is no great harm. --------------------- -splitFun :: WwOpts -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr - -> UniqSM [(Id, CoreExpr)] -splitFun ww_opts fn_id fn_info wrap_dmds div cpr rhs +splitFun :: WwOpts -> Id -> IdInfo -> CoreExpr -> UniqSM [(Id, CoreExpr)] +splitFun ww_opts fn_id fn_info rhs = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info))) (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $ do { mb_stuff <- mkWwBodies ww_opts rhs_fvs fn_id wrap_dmds use_cpr_info ; case mb_stuff of - Nothing -> return [(fn_id, rhs)] + Nothing -> -- No useful wrapper; leave the binding alone + return [(fn_id, rhs)] Just stuff | Just stable_unf <- certainlyWillInline uf_opts fn_info + -- We could make a w/w split, but in fact the RHS is small + -- See Note [Don't w/w inline small non-loop-breaker things] , let id_w_unf = fn_id `setIdUnfolding` stable_unf -- See Note [Inline pragma for certainlyWillInline] -> return [ (id_w_unf, rhs) ] - -- See Note [Don't w/w INLINE things] - -- See Note [Don't w/w inline small non-loop-breaker things] | otherwise -> do { work_uniq <- getUniqueM @@ -695,6 +693,16 @@ splitFun ww_opts fn_id fn_info wrap_dmds div cpr rhs uf_opts = so_uf_opts (wo_simple_opts ww_opts) rhs_fvs = exprFreeVars rhs + (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) + + cpr_ty = getCprSig (cprSigInfo fn_info) + -- Arity of the CPR sig should match idArity when it's not a join point. + -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal + cpr = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info) + (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) + <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $ + ct_cpr cpr_ty + -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points, -- see Note [Don't w/w join points for CPR]. use_cpr_info | isJoinId fn_id = topCpr diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index bd02bd6fc1..55561c9cbc 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -972,11 +972,11 @@ certainlyWillInline opts fn_info | noinline -> Nothing -- See Note [Worker/wrapper for NOINLINE functions] | otherwise -> case guidance of - UnfNever -> Nothing + UnfNever -> Nothing UnfWhen {} -> Just (fn_unf { uf_src = src' }) -- INLINE functions have UnfWhen UnfIfGoodArgs { ug_size = size, ug_args = args } - -> do_cunf expr size args src' + -> do_cunf expr size args src' where src' = -- Do not change InlineCompulsory! case src of diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs index e911d722ee..378d5a6131 100644 --- a/compiler/GHC/Core/Unfold/Make.hs +++ b/compiler/GHC/Core/Unfold/Make.hs @@ -230,7 +230,7 @@ The semantics of an INLINE pragma is the `UnfoldingGuidance`.) In the example, x's ug_arity is 0, so we should inline it at every use -site. It's rare to have such an INLINE pragma (usually INLINE Is on +site. It's rare to have such an INLINE pragma (usually INLINE is on functions), but it's occasionally very important (#15578, #15519). In #15519 we had something like x = case (g a b) of I# r -> T r diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 55ff3f9335..7c78c1928b 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -94,7 +94,7 @@ module GHC.Types.Id ( -- ** Reading 'IdInfo' fields idArity, idCallArity, idFunRepArity, - idUnfolding, realIdUnfolding, + idUnfolding, realIdUnfolding, hasInlineUnfolding, idSpecialisation, idCoreRules, idHasRules, idCafInfo, idLFInfo_maybe, idOneShotInfo, idStateHackOneShotInfo, @@ -124,7 +124,8 @@ module GHC.Types.Id ( import GHC.Prelude import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, - isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) + isCompulsoryUnfolding, isInlineUnfolding, + Unfolding( NoUnfolding ) ) import GHC.Types.Id.Info import GHC.Types.Basic @@ -721,6 +722,12 @@ idUnfolding id where info = idInfo id +hasInlineUnfolding :: Id -> Bool +-- ^ True of a non-loop-breaker Id that has a /stable/ unfolding that is +-- (a) always inlined; that is, with an `UnfWhen` guidance, or +-- (b) a DFunUnfolding which never needs to be inlined +hasInlineUnfolding id = isInlineUnfolding (idUnfolding id) + realIdUnfolding :: Id -> Unfolding -- Expose the unfolding if there is one, including for loop breakers realIdUnfolding id = unfoldingInfo (idInfo id) diff --git a/testsuite/tests/simplCore/should_compile/T18078.hs b/testsuite/tests/simplCore/should_compile/T18078.hs index e28b4a98ac..776e1194de 100644 --- a/testsuite/tests/simplCore/should_compile/T18078.hs +++ b/testsuite/tests/simplCore/should_compile/T18078.hs @@ -3,7 +3,7 @@ module T18078 where newtype N = N { unN :: Int -> Int } -- This an example of a worker/wrapper thing --- See Note [Cast worker/wrappers] in Simplify +-- See Note [Cast worker/wrapper] in Simplify -- We should get good code, with a $wf calling itself -- but in 8.10 we do not f :: N diff --git a/testsuite/tests/simplCore/should_compile/T19890.hs b/testsuite/tests/simplCore/should_compile/T19890.hs new file mode 100644 index 0000000000..39f89bc1e6 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T19890.hs @@ -0,0 +1,8 @@ +module T19890 where + +newtype Wombat a = Wombat (a->a) + +foo :: Num a => Bool -> Wombat a +{-# INLINEABLE foo #-} +foo True = foo False +foo False = Wombat (\x -> x+1) diff --git a/testsuite/tests/simplCore/should_compile/T19890.stderr b/testsuite/tests/simplCore/should_compile/T19890.stderr new file mode 100644 index 0000000000..9c9857edfc --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T19890.stderr @@ -0,0 +1,178 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 82, types: 41, coercions: 12, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +lvl_rzi :: Integer +[GblId, Unf=OtherCon []] +lvl_rzi = 1 + +Rec { +-- RHS size: {terms: 18, types: 9, coercions: 0, joins: 0/0} +T19890.foo1 [InlPrag=INLINABLE, Occ=LoopBreaker] + :: forall {a}. Num a => Bool -> a -> a +[GblId, + Arity=3, + Str=<SP(SCS(C1(L)),A,A,A,A,A,L)><1L><L>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 70 0] 230 0 + Tmpl= \ (@a_aye) + ($dNum_ayf :: Num a_aye) + (ds_dyN [Occ=Once1!] :: Bool) + (eta_B0 [Occ=Once2] :: a_aye) -> + case ds_dyN of { + False -> + + @a_aye $dNum_ayf eta_B0 (fromInteger @a_aye $dNum_ayf 1); + True -> T19890.foo1 @a_aye $dNum_ayf GHC.Types.False eta_B0 + }}] +T19890.foo1 + = \ (@a_aye) + ($dNum_ayf :: Num a_aye) + (ds_dyN :: Bool) + (eta_B0 :: a_aye) -> + case ds_dyN of { + False -> + + @a_aye $dNum_ayf eta_B0 (fromInteger @a_aye $dNum_ayf lvl_rzi); + True -> T19890.foo1 @a_aye $dNum_ayf GHC.Types.False eta_B0 + } +end Rec } + +-- RHS size: {terms: 1, types: 0, coercions: 12, joins: 0/0} +foo :: forall a. Num a => Bool -> Wombat a +[GblId, + Arity=3, + Str=<SP(SCS(C1(L)),A,A,A,A,A,L)><1L><L>, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] +foo + = T19890.foo1 + `cast` (forall (a :: <*>_N). + <Num a>_R + %<'Many>_N ->_R <Bool>_R + %<'Many>_N ->_R Sym (T19890.N:Wombat[0] <a>_R) + :: (forall {a}. Num a => Bool -> a -> a) + ~R# (forall {a}. Num a => Bool -> Wombat a)) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T19890.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T19890.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T19890.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T19890.$trModule3 = GHC.Types.TrNameS T19890.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T19890.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T19890.$trModule2 = "T19890"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T19890.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T19890.$trModule1 = GHC.Types.TrNameS T19890.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T19890.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T19890.$trModule + = GHC.Types.Module T19890.$trModule3 T19890.$trModule1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$krep_rzj :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep_rzj = GHC.Types.KindRepVar 0# + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep1_rzk :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep1_rzk = GHC.Types.KindRepFun $krep_rzj $krep_rzj + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T19890.$tcWombat2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T19890.$tcWombat2 = "Wombat"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T19890.$tcWombat1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T19890.$tcWombat1 = GHC.Types.TrNameS T19890.$tcWombat2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T19890.$tcWombat :: GHC.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T19890.$tcWombat + = GHC.Types.TyCon + 14886729617606120106## + 9341180610983476309## + T19890.$trModule + T19890.$tcWombat1 + 0# + GHC.Types.krep$*Arr* + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +$krep2_rzl :: [GHC.Types.KindRep] +[GblId, Unf=OtherCon []] +$krep2_rzl + = GHC.Types.: + @GHC.Types.KindRep $krep_rzj (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep3_rzm :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep3_rzm = GHC.Types.KindRepTyConApp T19890.$tcWombat $krep2_rzl + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T19890.$tc'Wombat1 [InlPrag=[~]] :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +T19890.$tc'Wombat1 = GHC.Types.KindRepFun $krep1_rzk $krep3_rzm + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T19890.$tc'Wombat3 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T19890.$tc'Wombat3 = "'Wombat"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T19890.$tc'Wombat2 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T19890.$tc'Wombat2 = GHC.Types.TrNameS T19890.$tc'Wombat3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T19890.$tc'Wombat :: GHC.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T19890.$tc'Wombat + = GHC.Types.TyCon + 2678731069210293856## + 16131282919067740460## + T19890.$trModule + T19890.$tc'Wombat2 + 1# + T19890.$tc'Wombat1 + + + diff --git a/testsuite/tests/simplCore/should_compile/T8331.stderr b/testsuite/tests/simplCore/should_compile/T8331.stderr index 76c8d90817..e84edead21 100644 --- a/testsuite/tests/simplCore/should_compile/T8331.stderr +++ b/testsuite/tests/simplCore/should_compile/T8331.stderr @@ -14,52 +14,10 @@ ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s b) (forall {a} {b}. ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) b)) -"SPEC $c<* @(ST s) _" - forall (@s) (@r) ($dApplicative :: Applicative (ST s)). - $fApplicativeReaderT_$c<* @(ST s) @r $dApplicative - = ($fApplicativeReaderT2 @s @r) - `cast` (forall (a :: <*>_N) (b :: <*>_N). - <ReaderT r (ST s) a>_R - %<'Many>_N ->_R <ReaderT r (ST s) b>_R - %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <a>_R) - ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <a>_N) - :: Coercible - (forall {a} {b}. - ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s a) - (forall {a} {b}. - ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) a)) -"SPEC $c<*> @(ST s) _" - forall (@s) (@r) ($dApplicative :: Applicative (ST s)). - $fApplicativeReaderT5 @(ST s) @r $dApplicative - = ($fApplicativeReaderT6 @s @r) - `cast` (forall (a :: <*>_N) (b :: <*>_N). - <ReaderT r (ST s) (a -> b)>_R - %<'Many>_N ->_R <ReaderT r (ST s) a>_R - %<'Many>_N ->_R <r>_R - %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R) - :: Coercible - (forall {a} {b}. - ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> STRep s b) - (forall {a} {b}. - ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> ST s b)) "SPEC $c>> @(ST s) _" forall (@s) (@r) ($dMonad :: Monad (ST s)). $fMonadReaderT_$c>> @(ST s) @r $dMonad = $fMonadAbstractIOSTReaderT_$s$c>> @s @r -"SPEC $c>>= @(ST s) _" - forall (@s) (@r) ($dMonad :: Monad (ST s)). - $fMonadReaderT1 @(ST s) @r $dMonad - = ($fMonadReaderT2 @s @r) - `cast` (forall (a :: <*>_N) (b :: <*>_N). - <ReaderT r (ST s) a>_R - %<'Many>_N ->_R <a -> ReaderT r (ST s) b>_R - %<'Many>_N ->_R <r>_R - %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R) - :: Coercible - (forall {a} {b}. - ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> STRep s b) - (forall {a} {b}. - ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> ST s b)) "SPEC $cliftA2 @(ST s) _" forall (@s) (@r) ($dApplicative :: Applicative (ST s)). $fApplicativeReaderT_$cliftA2 @(ST s) @r $dApplicative diff --git a/testsuite/tests/simplCore/should_compile/T9509.stdout b/testsuite/tests/simplCore/should_compile/T9509.stdout index 5f272e47e1..c5016afb8b 100644 --- a/testsuite/tests/simplCore/should_compile/T9509.stdout +++ b/testsuite/tests/simplCore/should_compile/T9509.stdout @@ -1,2 +1,2 @@ - Rule: SPEC/T9509 foo @Int - Rule: SPEC/T9509 foo @Int + Rule: SPEC/T9509 foo1 @Int + Rule: SPEC/T9509 foo1 @Int diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index e0f4338328..ed45e9dc65 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -364,3 +364,5 @@ test('T19672', normal, compile, ['-O2 -ddump-rules']) test('T19780', normal, compile, ['-O2']) test('T19794', normal, compile, ['-O']) +test('T19890', [ grep_errmsg(r'= T19890.foo1') ], compile, ['-O -ddump-simpl']) + |