diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Core/Opt/SpecConstr.hs | 98 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 47 | ||||
| -rw-r--r-- | compiler/GHC/CoreToStg.hs | 6 |
3 files changed, 89 insertions, 62 deletions
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 89d5e9fd22..7509a4cda3 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1719,30 +1719,27 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) -- And build the results ; let spec_body_ty = exprType spec_body - spec_lam_args1 = qvars ++ extra_bndrs - (spec_lam_args, spec_call_args) = mkWorkerArgs False - spec_lam_args1 spec_body_ty + + (spec_lam_args1, spec_sig, spec_arity, spec_join_arity) + = calcSpecInfo fn call_pat extra_bndrs + -- Annotate the variables with the strictness information from + -- the function (see Note [Strictness information in worker binders]) + + (spec_lam_args, spec_call_args) = mkWorkerArgs fn False + spec_lam_args1 spec_body_ty -- mkWorkerArgs: usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args - spec_str = calcSpecStrictness fn spec_lam_args pats - spec_lam_args_str = handOutStrictnessInformation spec_str spec_lam_args - -- Annotate the variables with the strictness information from - -- the function (see Note [Strictness information in worker binders]) - - spec_join_arity | isJoinId fn = Just (length spec_lam_args) - | otherwise = Nothing spec_id = mkLocalId spec_name Many (mkLamTypes spec_lam_args spec_body_ty) -- See Note [Transfer strictness] - `setIdDmdSig` spec_str - `setIdCprSig` topCprSig - `setIdArity` count isId spec_lam_args + `setIdDmdSig` spec_sig + `setIdCprSig` topCprSig + `setIdArity` spec_arity `asJoinId_maybe` spec_join_arity - -- Conditionally use result of new worker-wrapper transform - spec_rhs = mkLams spec_lam_args_str spec_body + spec_rhs = mkLams spec_lam_args spec_body rule_rhs = mkVarApps (Var spec_id) $ dropTail (length extra_bndrs) spec_call_args inline_act = idInlineActivation fn @@ -1755,31 +1752,46 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) , os_rhs = spec_rhs }) } --- See Note [Strictness information in worker binders] -handOutStrictnessInformation :: DmdSig -> [Var] -> [Var] -handOutStrictnessInformation str vs - = go (fst (splitDmdSig str)) vs - where - go _ [] = [] - go [] vs = vs - go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs - go dmds (v:vs) = v : go dmds vs - -calcSpecStrictness :: Id -- The original function - -> [Var] -> [CoreExpr] -- Call pattern - -> DmdSig -- Strictness of specialised thing +calcSpecInfo :: Id -- The original function + -> CallPat -- Call pattern + -> [Var] -- Extra bndrs + -> ( [Var] -- Demand-decorated binders + , DmdSig -- Strictness of specialised thing + , Arity, Maybe JoinArity ) -- Arities of specialised thing +-- Calcuate bits of IdInfo for the specialised function -- See Note [Transfer strictness] -calcSpecStrictness fn qvars pats - = mkClosedDmdSig spec_dmds div +-- See Note [Strictness information in worker binders] +calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs + | isJoinId fn -- Join points have strictness and arity for LHS only + = ( bndrs_w_dmds + , mkClosedDmdSig qvar_dmds div + , count isId qvars + , Just (length qvars) ) + | otherwise + = ( bndrs_w_dmds + , mkClosedDmdSig (qvar_dmds ++ extra_dmds) div + , count isId qvars + count isId extra_bndrs + , Nothing ) where - spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] - DmdSig (DmdType _ dmds div) = idDmdSig fn + DmdSig (DmdType _ fn_dmds div) = idDmdSig fn + + val_pats = filterOut isTypeArg pats + qvar_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] + extra_dmds = dropList val_pats fn_dmds + + bndrs_w_dmds = set_dmds qvars qvar_dmds + ++ set_dmds extra_bndrs extra_dmds + + set_dmds :: [Var] -> [Demand] -> [Var] + set_dmds [] _ = [] + set_dmds vs [] = vs -- Run out of demands + set_dmds (v:vs) ds@(d:ds') | isTyVar v = v : set_dmds vs ds + | otherwise = setIdDemandInfo v d : set_dmds vs ds' - dmd_env = go emptyVarEnv dmds pats + dmd_env = go emptyVarEnv fn_dmds val_pats go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv - go env ds (Type {} : pats) = go env ds pats - go env ds (Coercion {} : pats) = go env ds pats + -- We've filtered out all the type patterns already go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats go env _ _ = env @@ -1789,7 +1801,8 @@ calcSpecStrictness fn qvars pats | (Var _, args) <- collectArgs e , Just ds <- viewProd (length args) cd = go env ds args - go_one env _ _ = env + go_one env _ _ = env + {- Note [spec_usg includes rhs_usg] @@ -1847,13 +1860,13 @@ The function calcSpecStrictness performs the calculation. Note [Strictness information in worker binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - After having calculated the strictness annotation for the worker (see Note [Transfer strictness] above), we also want to have this information attached to the worker’s arguments, for the benefit of later passes. The function handOutStrictnessInformation decomposes the strictness annotation calculated by calcSpecStrictness and attaches them to the variables. + ************************************************************************ * * \subsection{Argument analysis} @@ -2269,15 +2282,20 @@ argToPat env in_scope val_env arg arg_occ -- Check if the argument is a variable that -- (a) is used in an interesting way in the function body + --- i.e. ScrutOcc. UnkOcc and NoOcc are not interesting + -- (NoOcc means we could drop the argument, but that's the + -- business of absence analysis, not SpecConstr.) -- (b) we know what its value is -- In that case it counts as "interesting" argToPat env in_scope val_env (Var v) arg_occ - | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) - is_value, -- (b) + | sc_force env || case arg_occ of { ScrutOcc {} -> True + ; UnkOcc -> False + ; NoOcc -> False } -- (a) + , 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 -- box that we can eliminate in the caller - not (ignoreType env (varType v)) + , not (ignoreType env (varType v)) = return (True, Var v) where is_value diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 4ef35e9b83..5bd7bdf263 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -189,7 +189,8 @@ mkWwBodies opts rhs_fvs fun_id demands cpr_info ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) <- mkWWcpr_entry opts res_ty cpr_info - ; let (work_lam_args, work_call_args) = mkWorkerArgs (wo_fun_to_thunk opts) work_args cpr_res_ty + ; let (work_lam_args, work_call_args) = mkWorkerArgs fun_id (wo_fun_to_thunk opts) + work_args cpr_res_ty worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args @@ -302,31 +303,39 @@ add a void argument. E.g. We use the state-token type which generates no code. -} -mkWorkerArgs :: Bool +mkWorkerArgs :: Id -- The wrapper Id + -> Bool -> [Var] -> Type -- Type of body -> ([Var], -- Lambda bound args [Var]) -- Args at call site -mkWorkerArgs fun_to_thunk args res_ty - | any isId args || not needsAValueLambda - = (args, args) - | otherwise +mkWorkerArgs wrap_id fun_to_thunk args res_ty + | not (isJoinId wrap_id) -- Join Ids never need an extra arg + , not (any isId args) -- No existing value lambdas + , needs_a_value_lambda -- and we need to add one = (args ++ [voidArgId], args ++ [voidPrimId]) + + | otherwise + = (args, args) where - -- See "Making wrapper args" section above - needsAValueLambda = - lifted - -- We may encounter a levity-polymorphic result, in which case we - -- conservatively assume that we have laziness that needs preservation. - -- See #15186. - || not fun_to_thunk - -- see Note [Protecting the last value argument] + -- If fun_to_thunk is False we always keep at least one value + -- argument: see Note [Protecting the last value argument] + -- If it is True, we only need to keep a value argument if + -- the result type is (or might be) unlifted, in which case + -- dropping the last arg would mean we wrongly used call-by-value + needs_a_value_lambda + = not fun_to_thunk + || might_be_unlifted -- Might the result be lifted? - lifted = - case isLiftedType_maybe res_ty of - Just lifted -> lifted - Nothing -> True + -- False => definitely lifted + -- True => might be unlifted + -- We may encounter a levity-polymorphic result, in which case we + -- conservatively assume that we have laziness that needs + -- preservation. See #15186. + might_be_unlifted = case isLiftedType_maybe res_ty of + Just lifted -> not lifted + Nothing -> True {- Note [Protecting the last value argument] @@ -344,7 +353,6 @@ so f can't be inlined *under a lambda*. Note [Join points and beta-redexes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Originally, the worker would invoke the original function by calling it with arguments, thus producing a beta-redex for the simplifier to munch away: @@ -375,7 +383,6 @@ worry about hygiene, but luckily wy is freshly generated.) Note [Join points returning functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - It is crucial that the arity of a join point depends on its *callers,* not its own syntax. What this means is that a join point can have "extra lambdas": diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 9452015ab4..af8c8ae25b 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -771,8 +771,10 @@ mkStgRhs bndr (PreStgRhs bndrs rhs) -- After this point we know that `bndrs` is empty, -- so this is not a function binding - | isJoinId bndr -- must be a nullary join point - = ASSERT(idJoinArity bndr == 0) + + | isJoinId bndr -- Must be a nullary join point + = -- It might have /type/ arguments (T18328), + -- so its JoinArity might be >0 StgRhsClosure noExtFieldSilent currentCCS ReEntrant -- ignored for LNE |