diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/CprAnal.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 177 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 207 | ||||
| -rw-r--r-- | compiler/GHC/Types/Demand.hs | 5 |
4 files changed, 217 insertions, 174 deletions
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index fc5b2abda3..e13be005fb 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -741,7 +741,7 @@ This is all done in 'extendSigEnvForArg'. Note that - * Whether or not something unboxes is decided by 'wantToUnboxArg', else we may + * Whether or not something unboxes is decided by 'canUnboxArg', else we may get over-optimistic CPR results (e.g., from \(x :: a) -> x!). * If the demand unboxes deeply, we can give the binder a /nested/ CPR diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index c7278fa079..add2c922e4 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -31,7 +31,7 @@ import GHC.Types.Id import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type -import GHC.Core.Predicate ( isClassPred ) +import GHC.Core.Predicate( isClassPred ) import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion ) import GHC.Core.TyCo.FVs ( coVarsOfCos ) @@ -282,7 +282,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id -- See Note [Finalising boxity for demand signatures] - id_dmd' = finaliseLetBoxity (ae_fam_envs env) (idType id) id_dmd + id_dmd' = finaliseLetBoxity env (idType id) id_dmd !id' = setBindIdDemandInfo top_lvl id id_dmd' (rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs @@ -963,7 +963,6 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty - -- See Note [Do not unbox class dictionaries] -- See Note [Boxity for bottoming functions] (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' rhs_div `orElse` (rhs_dmds, rhs') @@ -1285,7 +1284,7 @@ wrapper for `indexError` *will* unbox `p`). This pattern often occurs in performance sensitive code that does bounds-checking. It would be a shame to let `Boxed` win for the fields! So here's what we do: -While to summarising `indexError`'s boxity signature in `finaliseArgBoxities`, +While summarising `indexError`'s boxity signature in `finaliseArgBoxities`, we `unboxDeeplyDmd` all its argument demands and are careful not to discard excess boxity in the `StopUnboxing` case, to get the signature `<1!P(!S,!S)><1!S><S!S>b`. @@ -1352,11 +1351,11 @@ Here is a list of different Notes it has to take care of: * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in general, but still allow Note [Unboxing evaluated arguments] * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)` - * Implement fixes for corner cases Note [Do not unbox class dictionaries] - and Note [mkWWstr and unsafeCoerce] + * Note [mkWWstr and unsafeCoerce] -Then, in worker/wrapper blindly trusts the boxity info in the demand signature -and will not look at strictness info *at all*, in 'wantToUnboxArg'. +NB: Then, the worker/wrapper blindly trusts the boxity info in the +demand signature; that is why 'canUnboxArg' does not look at +strictness -- it is redundant to do so. Note [Finalising boxity for let-bound Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1458,7 +1457,7 @@ So here's what we do 'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'. -* Worker/wrapper will consult 'wantToUnboxArg' for its unboxing decision. It will +* Worker/wrapper will consult 'canUnboxArg' for its unboxing decision. It will /not/ look at the strictness bits of the demand, only at Boxity flags. As such, it will happily unbox 'a' despite the lazy demand on it. @@ -1624,7 +1623,6 @@ finaliseArgBoxities env fn arity rhs div -- uses the info on the binders directly. where opts = ae_opts env - fam_envs = ae_fam_envs env is_inlinable_fn = isStableUnfolding (realIdUnfolding fn) (bndrs, _body) = collectBinders rhs max_wkr_args = dmd_max_worker_args opts `max` arity @@ -1637,59 +1635,62 @@ finaliseArgBoxities env fn arity rhs div arg_triples :: [(Type, StrictnessMark, Demand)] arg_triples = take arity $ - map mk_triple $ - filter isRuntimeVar bndrs - - mk_triple :: Id -> (Type,StrictnessMark,Demand) - mk_triple bndr | is_cls_arg ty = (ty, NotMarkedStrict, trimBoxity dmd) - | is_bot_fn = (ty, NotMarkedStrict, unboxDeeplyDmd dmd) - -- See Note [OPAQUE pragma] - -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] - | is_opaque = (ty, NotMarkedStrict, trimBoxity dmd) - | otherwise = (ty, NotMarkedStrict, dmd) - where - ty = idType bndr - dmd = idDemandInfo bndr - is_opaque = isOpaquePragma (idInlinePragma fn) - - -- is_cls_arg: see Note [Do not unbox class dictionaries] - is_cls_arg arg_ty = is_inlinable_fn && isClassPred arg_ty + [ (bndr_ty, NotMarkedStrict, get_dmd bndr bndr_ty) + | bndr <- bndrs + , isRuntimeVar bndr, let bndr_ty = idType bndr ] + + get_dmd :: Id -> Type -> Demand + get_dmd bndr bndr_ty + | isClassPred bndr_ty + , is_inlinable_fn = trimBoxity dmd + -- See Note [Do not unbox class dictionaries] + -- NB: 'ty' has not been normalised, so this will (rightly) + -- catch newtype dictionaries too. + -- NB: even for bottoming functions, don't unbox dictionaries + + | is_bot_fn = unboxDeeplyDmd dmd + -- See Note [Boxity for bottoming functions] + + | is_opaque = trimBoxity dmd + -- See Note [OPAQUE pragma] + -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] + + | otherwise = dmd + where + dmd = idDemandInfo bndr + is_opaque = isOpaquePragma (idInlinePragma fn) + -- is_bot_fn: see Note [Boxity for bottoming functions] - is_bot_fn = div == botDiv + is_bot_fn = div == botDiv go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand]) go_args bg triples = mapAccumL go_arg bg triples go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand) go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _)) - = case wantToUnboxArg False fam_envs ty dmd of - StopUnboxing - | not is_bot_fn - -- If bot: Keep deep boxity even though WW won't unbox - -- See Note [Boxity for bottoming functions] - -> (MkB (bg_top-1) bg_inner, trimBoxity dmd) - - Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds - -> (MkB (bg_top-1) final_bg_inner, final_dmd) + = case wantToUnboxArg env ty str_mark dmd of + FD_Absent -> (bg, dmd) + + FD_Box | is_bot_fn -> (decremented_bg, dmd) + | otherwise -> (decremented_bg, trimBoxity dmd) + -- If bot: Keep deep boxity even though WW won't unbox + -- See Note [Boxity for bottoming functions] + -- trimBoxity: see Note [No lazy, Unboxed demands in demand signature] + + FD_RecBox -> (decremented_bg, trimBoxity dmd) + -- Important: must do trimBoxity for FD_RecBox, even for bottoming fns, + -- else we unbox infinitely (simpl019, T11545, T18304, T4903) + + FD_Unbox triples -> (MkB (bg_top-1) final_bg_inner, final_dmd) where - dc_arity = dataConRepArity dc - arg_tys = dubiousDataConInstArgTys dc tc_args - (bg_inner', dmds') = go_args (incTopBudget bg_inner) $ - zip3 arg_tys (dataConRepStrictness dc) dmds + (bg_inner', dmds') = go_args (incTopBudget bg_inner) triples + -- incTopBudget: give one back for the arg we are unboxing dmd' = n :* (mkProd Unboxed $! dmds') (final_bg_inner, final_dmd) - | dmds `lengthIs` dc_arity - , isStrict n || isMarkedStrict str_mark - -- isStrict: see Note [No lazy, Unboxed demands in demand signature] - -- isMarkedStrict: see Note [Unboxing evaluated arguments] - , positiveTopBudget bg_inner' - , NonRecursiveOrUnsure <- ae_rec_dc env dc - -- See Note [Which types are unboxed?] - -- and Note [Demand analysis for recursive data constructors] - = (bg_inner', dmd') - | otherwise - = (bg_inner, trimBoxity dmd) - _ -> (bg, dmd) + | positiveTopBudget bg_inner' = (bg_inner', dmd') + | otherwise = (bg_inner, trimBoxity dmd) + where + decremented_bg = MkB (bg_top-1) bg_inner add_demands :: [Demand] -> CoreExpr -> CoreExpr -- Attach the demands to the outer lambdas of this expression @@ -1700,7 +1701,7 @@ finaliseArgBoxities env fn arity rhs div add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e) finaliseLetBoxity - :: FamInstEnvs + :: AnalEnv -> Type -- ^ Type of the let-bound Id -> Demand -- ^ How the Id is used -> Demand @@ -1709,21 +1710,61 @@ finaliseLetBoxity -- it has no "budget". It simply unboxes strict demands, and stops -- when it reaches a lazy one. finaliseLetBoxity env ty dmd - = go ty NotMarkedStrict dmd + = go (ty, NotMarkedStrict, dmd) where - go ty mark dmd@(n :* _) = - case wantToUnboxArg False env ty dmd of - DropAbsent -> dmd - StopUnboxing -> trimBoxity dmd - Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds - | isStrict n || isMarkedStrict mark - , dmds `lengthIs` dataConRepArity dc - , let arg_tys = dubiousDataConInstArgTys dc tc_args - dmds' = strictZipWith3 go arg_tys (dataConRepStrictness dc) dmds - -> n :* (mkProd Unboxed $! dmds') - | otherwise - -> trimBoxity dmd - Unlift -> panic "No unlifting in DmdAnal" + go :: (Type,StrictnessMark,Demand) -> Demand + go (ty, str, dmd@(n :* _)) = + case wantToUnboxArg env ty str dmd of + FD_Absent -> dmd + FD_Box -> trimBoxity dmd + FD_RecBox -> trimBoxity dmd + FD_Unbox triples -> n :* (mkProd Unboxed $! map go triples) + +-- The data type `FinalDecision` is entirely local to this one module, +-- and is used only to express the result of `wantToUnboxArg`. +-- +-- `FinalDecision` is a bit like WorkWrap.Utils.UnboxingDecision, but +-- not quite the same, notably because of the need for FD_RecBox. But +-- I decided make `FinalDecision` do just what was needed, rather than +-- to attempt to generalise `UnboxingDecision`, or make it GADT-ish or +-- something. +data FinalDecision + = FD_Absent + | FD_Box -- Keep this argument boxed + | FD_RecBox -- Special case of a strict recursive product! Take care! + | FD_Unbox [(Type, StrictnessMark, Demand)] + +wantToUnboxArg :: AnalEnv -> Type -> StrictnessMark -> Demand -> FinalDecision +wantToUnboxArg env ty str_mark dmd@(n :* _) + | isAbs n + = FD_Absent + + | not (isStrict n || isMarkedStrict str_mark) + = FD_Box -- Don't unbox a lazy field + -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal + + | otherwise + = case canUnboxArg (ae_fam_envs env) ty dmd of + DropAbsent -> FD_Absent + -- The earlier isAbs guard means this case won't happen, in fact; + -- but it does no harm. We can't drop the isAbs guard or we'd + -- wrongly return StopUnboxing for absent args. + + StopUnboxing -> FD_Box + + Unbox (DataConPatContext{ dcpc_dc = dc + , dcpc_tc_args = tc_args + , dcpc_args = dmds }) + -- OK, so we /can/ unbox it; but do we /want/ to? + | DefinitelyRecursive <- ae_rec_dc env dc + -- See Note [Which types are unboxed?] + -- and Note [Demand analysis for recursive data constructors] + -> FD_RecBox + + | otherwise + -> FD_Unbox (zip3 (dubiousDataConInstArgTys dc tc_args) + (dataConRepStrictness dc) + dmds) {- ********************************************************************* diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 1f5cd29a26..f23384d134 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -11,7 +11,7 @@ module GHC.Core.Opt.WorkWrap.Utils ( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one , needsVoidWorkerArg, addVoidWorkerArg , DataConPatContext(..) - , UnboxingDecision(..), wantToUnboxArg + , UnboxingDecision(..), canUnboxArg , findTypeShape, IsRecDataConResult(..), isRecDataCon , mkAbsentFiller , isWorkerSmallEnough, dubiousDataConInstArgTys @@ -221,18 +221,18 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr zapped_arg_vars = map zap_var arg_vars (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars res_ty' = GHC.Core.Subst.substTy subst res_ty - init_cbv_marks = map (const NotMarkedStrict) cloned_arg_vars + init_str_marks = map (const NotMarkedStrict) cloned_arg_vars - ; (useful1, work_args_cbv, wrap_fn_str, fn_args) - <- mkWWstr opts cloned_arg_vars init_cbv_marks + ; (useful1, work_args_str, wrap_fn_str, fn_args) + <- mkWWstr opts cloned_arg_vars init_str_marks - ; let (work_args, work_marks) = unzip work_args_cbv + ; let (work_args, work_marks) = unzip work_args_str -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr) <- mkWWcpr_entry opts res_ty' res_cpr - ; let (work_lam_args, work_call_args, work_call_cbv) + ; let (work_lam_args, work_call_args, work_call_str) | needsVoidWorkerArg fun_id arg_vars work_args = addVoidWorkerArg work_args work_marks | otherwise @@ -243,9 +243,9 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr -- See Note [Join points and beta-redexes] wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work -- See Note [Call-by-value for worker args] - work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_cbv) + work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_str) worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs - worker_args_dmds= [(idDemandInfo v) | v <- work_call_args, isId v] + worker_args_dmds= [ idDemandInfo v | v <- work_call_args, isId v] ; if ((useful1 && not only_one_void_argument) || useful2) then return (Just (worker_args_dmds, length work_call_args, @@ -394,9 +394,9 @@ needsVoidWorkerArg fn_id wrap_args work_args addVoidWorkerArg :: [Var] -> [StrictnessMark] -> ([Var], -- Lambda bound args [Var], -- Args at call site - [StrictnessMark]) -- cbv semantics for the worker args. -addVoidWorkerArg work_args cbv_marks - = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:cbv_marks) + [StrictnessMark]) -- str semantics for the worker args. +addVoidWorkerArg work_args str_marks + = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:str_marks) {- Note [Protecting the last value argument] @@ -554,29 +554,26 @@ see #17478. -- -- * @dc @exs flds :: T tys@ -- * @co :: T tys ~ ty@ -data DataConPatContext +-- +-- 's' will be 'Demand' or 'Cpr'. +data DataConPatContext s = DataConPatContext { dcpc_dc :: !DataCon , dcpc_tc_args :: ![Type] , dcpc_co :: !Coercion + , dcpc_args :: ![s] } -- | Describes the outer shape of an argument to be unboxed or left as-is -- Depending on how @s@ is instantiated (e.g., 'Demand' or 'Cpr'). -data UnboxingDecision s +data UnboxingDecision unboxing_info = StopUnboxing -- ^ We ran out of strictness info. Leave untouched. | DropAbsent -- ^ The argument/field was absent. Drop it. - | Unbox !DataConPatContext [s] - -- ^ The argument is used strictly or the returned product was constructed, so - -- unbox it. - -- The 'DataConPatContext' carries the bits necessary for - -- instantiation with 'dataConRepInstPat'. - -- The @[s]@ carries the bits of information with which we can continue - -- unboxing, e.g. @s@ will be 'Demand' or 'Cpr'. - | Unlift - -- ^ The argument can't be unboxed, but we want it to be passed evaluated to the worker. + | Unbox !unboxing_info + -- ^ The argument is used strictly or the returned product + -- was constructed, so unbox it. -- Do we want to create workers just for unlifting? wwForUnlifting :: WwOpts -> Bool @@ -599,41 +596,34 @@ isGoodWorker = id -- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns -- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon' -- to unbox. -wantToUnboxArg - :: Bool -- ^ Consider unlifting - -> FamInstEnvs - -> Type -- ^ Type of the argument - -> Demand -- ^ How the arg was used - -> UnboxingDecision Demand +canUnboxArg + :: FamInstEnvs + -> Type -- ^ Type of the argument + -> Demand -- ^ How the arg was used + -> UnboxingDecision (DataConPatContext Demand) -- See Note [Which types are unboxed?] -wantToUnboxArg do_unlifting fam_envs ty dmd@(n :* sd) +canUnboxArg fam_envs ty (n :* sd) | isAbs n = DropAbsent + -- From here we are strict and not absent | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty , Just dc <- tyConSingleAlgDataCon_maybe tc , let arity = dataConRepArity dc - , Just (Unboxed, ds) <- viewProd arity sd -- See Note [Boxity analysis] - -- NB: No strictness or evaluatedness checks for unboxing here. - -- That is done by 'finaliseArgBoxities'! - = Unbox (DataConPatContext dc tc_args co) ds - - -- See Note [CBV Function Ids] - | do_unlifting - , isStrUsedDmd dmd - , not (isFunTy ty) - , not (isUnliftedType ty) -- Already unlifted! - -- NB: function arguments have a fixed RuntimeRep, so it's OK to call isUnliftedType here - = Unlift + , Just (Unboxed, dmds) <- viewProd arity sd -- See Note [Boxity analysis] + , dmds `lengthIs` dataConRepArity dc + = Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co, dcpc_args = dmds }) | otherwise = StopUnboxing -- | Unboxing strategy for constructed results. -wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr +canUnboxResult :: FamInstEnvs -> Type -> Cpr + -> UnboxingDecision (DataConPatContext Cpr) -- See Note [Which types are unboxed?] -wantToUnboxResult fam_envs ty cpr +canUnboxResult fam_envs ty cpr | Just (con_tag, arg_cprs) <- asConCpr cpr , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning @@ -648,14 +638,15 @@ wantToUnboxResult fam_envs ty cpr -- Deactivates CPR worker/wrapper splits on constructors with non-linear -- arguments, for the moment, because they require unboxed tuple with variable -- multiplicity fields. - = Unbox (DataConPatContext dc tc_args co) arg_cprs + = Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co, dcpc_args = arg_cprs }) | otherwise = StopUnboxing where -- See Note [non-algebraic or open body type warning] - open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing + open_body_ty_warning = warnPprTrace True "canUnboxResult: non-algebraic or open body type" (ppr ty) Nothing isLinear :: Scaled a -> Bool isLinear (Scaled w _ ) = @@ -697,8 +688,8 @@ Worker/wrapper will unbox to > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #) -The respective tests are in 'wantToUnboxArg' and -'wantToUnboxResult', respectively. +The respective tests are in 'canUnboxArg' and +'canUnboxResult', respectively. Note that the data constructor /can/ have evidence arguments: equality constraints, type classes etc. So it can be GADT. These evidence @@ -756,14 +747,17 @@ Performing W/W might not always be a win. In particular it's easy to break See #20364 for a more detailed explaination. Hence we have the following strategies with different trade-offs: + A) Never do W/W *just* for unlifting of arguments. + Very conservative - doesn't break any rules - Lot's of performance left on the table + B) Do W/W on just about anything where it might be beneficial. + Exploits pretty much every oppertunity for unlifting. - A bit of compile time/code size cost for all the wrappers. - Can break rules which would otherwise fire. See #20364. + C) Unlift *any* (non-boot exported) functions arguments if they are strict. That is instead of creating a Worker with the new calling convention we change the calling convention of the binding itself. @@ -784,11 +778,13 @@ C) Unlift *any* (non-boot exported) functions arguments if they are strict. Currently we use the first approach A) by default, with a flag that allows users to fall back to the more aggressive approach B). + I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903. We could still try to do C) in the future by having PAP calls which will evaluate the required arguments before calling the partially applied function. But this would be neither a small nor simple change so we stick with A) and a flag for B) for now. + See also Note [Tag Inference] and Note [CBV Function Ids] -} @@ -803,7 +799,7 @@ See also Note [Tag Inference] and Note [CBV Function Ids] mkWWstr :: WwOpts -> [Var] -- Wrapper args; have their demand info on them -- *Includes type variables* - -> [StrictnessMark] -- cbv info for arguments + -> [StrictnessMark] -- Strictness-mark info for arguments -> UniqSM (Bool, -- Will this result in a useful worker [(Var,StrictnessMark)], -- Worker args/their call-by-value semantics. CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call @@ -812,20 +808,18 @@ mkWWstr :: WwOpts [CoreExpr]) -- Reboxed args for the call to the -- original RHS. Corresponds one-to-one -- with the wrapper arg vars -mkWWstr opts args cbv_info - = go args cbv_info +mkWWstr opts args str_marks + = go args str_marks where - go_one arg cbv = mkWWstr_one opts arg cbv - - go [] _ = return (badWorker, [], nop_fn, []) - go (arg : args) (cbv:cbvs) - = do { (useful1, args1, wrap_fn1, wrap_arg) <- go_one arg cbv - ; (useful2, args2, wrap_fn2, wrap_args) <- go args cbvs - ; return ( useful1 || useful2 - , args1 ++ args2 - , wrap_fn1 . wrap_fn2 - , wrap_arg:wrap_args ) } - go _ _ = panic "mkWWstr: Impossible - cbv/arg length missmatch" + go [] _ = return (badWorker, [], nop_fn, []) + go (arg : args) (str:strs) + = do { (useful1, args1, wrap_fn1, wrap_arg) <- mkWWstr_one opts arg str + ; (useful2, args2, wrap_fn2, wrap_args) <- go args strs + ; return ( useful1 || useful2 + , args1 ++ args2 + , wrap_fn1 . wrap_fn2 + , wrap_arg:wrap_args ) } + go _ _ = panic "mkWWstr: Impossible - str/arg length missmatch" ---------------------- -- mkWWstr_one wrap_var = (useful, work_args, wrap_fn, wrap_arg) @@ -838,24 +832,28 @@ mkWWstr_one :: WwOpts -> Var -> StrictnessMark -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) -mkWWstr_one opts arg banged = - case wantToUnboxArg True fam_envs arg_ty arg_dmd of +mkWWstr_one opts arg str_mark = + case canUnboxArg fam_envs arg_ty arg_dmd of _ | isTyVar arg -> do_nothing DropAbsent - | Just absent_filler <- mkAbsentFiller opts arg banged + | Just absent_filler <- mkAbsentFiller opts arg str_mark -- Absent case. Dropt the argument from the worker. -- We can't always handle absence for arbitrary -- unlifted types, so we need to choose just the cases we can -- (that's what mkAbsentFiller does) -> return (goodWorker, [], nop_fn, absent_filler) - Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc banged + Unbox dcpc -> unbox_one_arg opts arg dcpc - Unlift -> return ( wwForUnlifting opts - , [(arg, MarkedStrict)] - , nop_fn - , varToCoreExpr arg) + _ | isStrictDmd arg_dmd || isMarkedStrict str_mark + , wwForUnlifting opts + , not (isFunTy arg_ty) + , not (isUnliftedType arg_ty) -- Already unlifted! + -- NB: function arguments have a fixed RuntimeRep, + -- so it's OK to call isUnliftedType here + -> -- See Note [CBV Function Ids] + return (goodWorker, [(arg, MarkedStrict)], nop_fn, varToCoreExpr arg ) _ -> do_nothing -- Other cases, like StopUnboxing @@ -863,37 +861,42 @@ mkWWstr_one opts arg banged = fam_envs = wo_fam_envs opts arg_ty = idType arg arg_dmd = idDemandInfo arg - -- Type args don't get cbv marks - arg_cbv = if isTyVar arg then NotMarkedStrict else banged - - do_nothing = return (badWorker, [(arg,arg_cbv)], nop_fn, varToCoreExpr arg) + arg_str | isTyVar arg = NotMarkedStrict -- Type args don't get stricness marks + | otherwise = str_mark + do_nothing = return (badWorker, [(arg,arg_str)], nop_fn, varToCoreExpr arg) unbox_one_arg :: WwOpts - -> Var - -> [Demand] - -> DataConPatContext - -> StrictnessMark - -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) -unbox_one_arg opts arg_var ds - DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args - , dcpc_co = co } - _marked_cbv + -> Var-> DataConPatContext Demand + -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) +unbox_one_arg opts arg_var + DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co, dcpc_args = ds } = do { pat_bndrs_uniqs <- getUniquesM ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc + -- Create new arguments we get when unboxing dc - (ex_tvs', arg_ids) = - dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg_var) dc tc_args + (ex_tvs', arg_ids) = dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) + pat_bndrs_uniqs (idMult arg_var) dc tc_args con_str_marks = dataConRepStrictness dc - -- Apply str info to new args. Also remove OtherCon unfoldings so they don't end up in lambda binders - -- of the worker. See Note [Never put `OtherCon` unfoldings on lambda binders] - arg_ids' = map zapIdUnfolding $ zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds + + -- Apply str info to new args. Also remove OtherCon unfoldings so they + -- don't end up in lambda binders of the worker. + -- See Note [Never put `OtherCon` unfoldings on lambda binders] + arg_ids' = map zapIdUnfolding $ + zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds + unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var) dc (ex_tvs' ++ arg_ids') - -- Mark arguments coming out of strict fields so we can make the worker strict on those - -- argumnets later. seq them later. See Note [Call-by-value for worker args] - strict_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks - ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ arg_ids') strict_marks + + -- Mark arguments coming out of strict fields so we can seq them in the worker + -- See Note [Call-by-value for worker args] + all_str_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks + + ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) + <- mkWWstr opts (ex_tvs' ++ arg_ids') all_str_marks + ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co + ; return (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) } -- Don't pass the arg, rebox instead @@ -937,7 +940,7 @@ mkAbsentFiller opts arg str {- Note [Worker/wrapper for Strictness and Absence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The worker/wrapper transformation, mkWWstr_one, takes concrete action -based on the 'UnboxingDescision' returned by 'wantToUnboxArg'. +based on the 'UnboxingDecision' returned by 'canUnboxArg'. The latter takes into account several possibilities to decide if the function is worthy for splitting: @@ -951,7 +954,7 @@ function is worthy for splitting: 2. If the argument is evaluated strictly (or known to be eval'd), we can take a view into the product demand ('viewProd'). In accordance - with Note [Boxity analysis], 'wantToUnboxArg' will say 'Unbox'. + with Note [Boxity analysis], 'canUnboxArg' will say 'Unbox'. 'mkWWstr_one' then follows suit it and recurses into the fields of the product demand. For example @@ -973,7 +976,7 @@ function is worthy for splitting: $gw c a b = if c then a else b 2a But do /not/ unbox if Boxity Analysis said "Boxed". - In this case, 'wantToUnboxArg' returns 'StopUnboxing'. + In this case, 'canUnboxArg' returns 'StopUnboxing'. Otherwise we risk decomposing and reboxing a massive tuple which is barely used. Example: @@ -994,7 +997,7 @@ function is worthy for splitting: 3. In all other cases (e.g., lazy, used demand and not eval'd), 'finaliseArgBoxities' will have cleared the Boxity flag to 'Boxed' (see Note [Finalising boxity for demand signatures] in GHC.Core.Opt.DmdAnal) - and 'wantToUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one' + and 'canUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one' stops unboxing. Note [Worker/wrapper for bottoming functions] @@ -1374,7 +1377,7 @@ mkWWcpr _opts vars [] = -- hence stop WW. return (badWorker, toOL vars, map varToCoreExpr vars, nop_fn) mkWWcpr opts vars cprs = do - -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that. + -- No existentials in 'vars'. 'canUnboxResult' should have checked that. massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs) massertPpr (equalLength vars cprs) (ppr vars $$ ppr cprs) (usefuls, varss, rebuilt_results, work_unpack_ress) <- @@ -1388,17 +1391,17 @@ mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResultOne -- ^ See if we want to unbox the result and hand off to 'unbox_one_result'. mkWWcpr_one opts res_bndr cpr | assert (not (isTyVar res_bndr) ) True - , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr - = unbox_one_result opts res_bndr arg_cprs dcpc + , Unbox dcpc <- canUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr + = unbox_one_result opts res_bndr dcpc | otherwise = return (badWorker, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn) unbox_one_result - :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResultOne + :: WwOpts -> Id -> DataConPatContext Cpr -> UniqSM CprWwResultOne -- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR] -unbox_one_result opts res_bndr arg_cprs +unbox_one_result opts res_bndr DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args - , dcpc_co = co } = do + , dcpc_co = co, dcpc_args = arg_cprs } = do -- unboxer (free in `res_bndr`): | builder (where <i> builds what was -- ( case res_bndr of (i, j) -> ) | bound to i) -- ( case i of I# a -> ) | @@ -1407,7 +1410,7 @@ unbox_one_result opts res_bndr arg_cprs pat_bndrs_uniqs <- getUniquesM let (_exs, arg_ids) = dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args - massert (null _exs) -- Should have been caught by wantToUnboxResult + massert (null _exs) -- Should have been caught by canUnboxResult (nested_useful, transit_vars, con_args, work_unbox_res) <- mkWWcpr opts arg_ids arg_cprs diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 8ea0ddc84e..9bd29a5a37 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -2224,11 +2224,10 @@ prependArgsDmdSig :: Int -> DmdSig -> DmdSig prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res)) | new_args == 0 = sig | isNopDmdType dmd_ty = sig - | new_args < 0 = pprPanic "prependArgsDmdSig: negative new_args" - (ppr new_args $$ ppr sig) | otherwise = DmdSig (DmdType env dmds' res) where - dmds' = replicate new_args topDmd ++ dmds + dmds' = assertPpr (new_args > 0) (ppr new_args) $ + replicate new_args topDmd ++ dmds etaConvertDmdSig :: Arity -> DmdSig -> DmdSig -- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to |