diff options
Diffstat (limited to 'compiler/GHC/Core/Opt/WorkWrap/Utils.hs')
| -rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 207 |
1 files changed, 105 insertions, 102 deletions
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 |