diff options
| -rw-r--r-- | compiler/coreSyn/CoreUnfold.lhs | 51 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 2 | ||||
| -rw-r--r-- | compiler/specialise/SpecConstr.lhs | 2 | ||||
| -rw-r--r-- | compiler/stranal/WwLib.lhs | 24 | ||||
| -rw-r--r-- | docs/users_guide/flags.xml | 11 |
5 files changed, 65 insertions, 25 deletions
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index d49717c4fa..513bb22166 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -61,6 +61,7 @@ import IdInfo import BasicTypes ( Arity ) import Type import PrelNames +import TysPrim ( realWorldStatePrimTy ) import Bag import Util import FastTypes @@ -395,16 +396,19 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr size_up (Type _) = sizeZero -- Types cost nothing size_up (Coercion _) = sizeZero size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) = size_up_call f [] -- Make sure we get constructor - -- discounts even on nullary constructors + size_up (Var f) | isRealWorldId f = sizeZero + -- Make sure we get constructor discounts even + -- on nullary constructors + | otherwise = size_up_call f [] 0 - size_up (App fun (Type _)) = size_up fun - size_up (App fun (Coercion _)) = size_up fun - size_up (App fun arg) = size_up arg `addSizeNSD` - size_up_app fun [arg] + size_up (App fun arg) + | isTyCoArg arg = size_up fun + | otherwise = size_up arg `addSizeNSD` + size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0) - size_up (Lam b e) | isId b = lamScrutDiscount dflags (size_up e `addSizeN` 10) - | otherwise = size_up e + size_up (Lam b e) + | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10) + | otherwise = size_up e size_up (Let (NonRec binder rhs) body) = size_up rhs `addSizeNSD` @@ -480,22 +484,23 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr ------------ -- size_up_app is used when there's ONE OR MORE value args - size_up_app (App fun arg) args - | isTyCoArg arg = size_up_app fun args - | otherwise = size_up arg `addSizeNSD` - size_up_app fun (arg:args) - size_up_app (Var fun) args = size_up_call fun args - size_up_app other args = size_up other `addSizeN` length args + size_up_app (App fun arg) args voids + | isTyCoArg arg = size_up_app fun args voids + | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1) + | otherwise = size_up arg `addSizeNSD` + size_up_app fun (arg:args) voids + size_up_app (Var fun) args voids = size_up_call fun args voids + size_up_app other args voids = size_up other `addSizeN` (length args - voids) ------------ - size_up_call :: Id -> [CoreExpr] -> ExprSize - size_up_call fun val_args + size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize + size_up_call fun val_args voids = case idDetails fun of FCallId _ -> sizeN (10 * (1 + length val_args)) DataConWorkId dc -> conSize dc (length val_args) PrimOpId op -> primOpSize op (length val_args) ClassOpId _ -> classOpSize dflags top_args val_args - _ -> funSize dflags top_args fun (length val_args) + _ -> funSize dflags top_args fun (length val_args) voids ------------ size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 @@ -528,6 +533,12 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) (xs `unionBags` ys) d2 -- Ignore d1 + + isRealWorldId id = idType id `eqType` realWorldStatePrimTy + + -- an expression of type State# RealWorld must be a variable + isRealWorldExpr (Var id) = isRealWorldId id + isRealWorldExpr _ = False \end{code} @@ -560,17 +571,17 @@ classOpSize dflags top_args (arg1 : other_args) -> unitBag (dict, ufDictDiscount dflags) _other -> emptyBag -funSize :: DynFlags -> [Id] -> Id -> Int -> ExprSize +funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize -- Size for functions that are not constructors or primops -- Note [Function applications] -funSize dflags top_args fun n_val_args +funSize dflags top_args fun n_val_args voids | fun `hasKey` buildIdKey = buildSize | fun `hasKey` augmentIdKey = augmentSize | otherwise = SizeIs (iUnbox size) arg_discount (iUnbox res_discount) where some_val_args = n_val_args > 0 - size | some_val_args = 10 * (1 + n_val_args) + size | some_val_args = 10 * (1 + n_val_args - voids) | otherwise = 0 -- The 1+ is for the function itself -- Add 1 for each non-trivial arg; diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ba860622ed..24c573b366 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -299,6 +299,7 @@ data GeneralFlag | Opt_CmmElimCommonBlocks | Opt_OmitYields | Opt_SimpleListLiterals + | Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas -- Interface files | Opt_IgnoreInterfacePragmas @@ -2487,6 +2488,7 @@ fFlags = [ ( "cmm-elim-common-blocks", Opt_CmmElimCommonBlocks, nop ), ( "omit-yields", Opt_OmitYields, nop ), ( "simple-list-literals", Opt_SimpleListLiterals, nop ), + ( "fun-to-thunk", Opt_FunToThunk, nop ), ( "gen-manifest", Opt_GenManifest, nop ), ( "embed-manifest", Opt_EmbedManifest, nop ), ( "ext-core", Opt_EmitExternalCore, nop ), diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index d03baf04ae..16c368e5c5 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -1409,7 +1409,7 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) `setIdArity` count isId spec_lam_args spec_str = calcSpecStrictness fn spec_lam_args pats -- Conditionally use result of new worker-wrapper transform - (spec_lam_args, spec_call_args) = mkWorkerArgs qvars False body_ty + (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) qvars False body_ty -- Usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index fb9396e5ea..810db2069b 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -140,7 +140,7 @@ mkWwBodies dflags fun_ty demands res_info one_shots -- Do CPR w/w. See Note [Always do CPR w/w] ; (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) <- mkWWcpr res_ty res_info - ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args all_one_shots cpr_res_ty + ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args all_one_shots cpr_res_ty ; return ([idDemandInfo v | v <- work_call_args, isId v], wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) } @@ -184,23 +184,39 @@ add a void argument. E.g. We use the state-token type which generates no code. \begin{code} -mkWorkerArgs :: [Var] +mkWorkerArgs :: DynFlags -> [Var] -> Bool -- Whether all arguments are one-shot -> Type -- Type of body -> ([Var], -- Lambda bound args [Var]) -- Args at call site -mkWorkerArgs args all_one_shot res_ty - | any isId args || not (isUnLiftedType res_ty) +mkWorkerArgs dflags args all_one_shot res_ty + | any isId args || not needsAValueLambda = (args, args) | otherwise = (args ++ [newArg], args ++ [realWorldPrimId]) where + needsAValueLambda = + isUnLiftedType res_ty + || not (gopt Opt_FunToThunk dflags) + -- see Note [Protecting the last value argument] + -- see Note [All One-Shot Arguments of a Worker] newArg = if all_one_shot then setOneShotLambda voidArgId else voidArgId \end{code} +Note [Protecting the last value argument] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If the user writes (\_ -> E), they might be intentionally disallowing +the sharing of E. Since absence analysis and worker-wrapper are keen +to remove such unused arguments, we add in a void argument to prevent +the function from becoming a thunk. + +The user can avoid that argument with the -ffun-to-thunk +flag. However, removing all the value argus may introduce space leaks. + Note [All One-Shot Arguments of a Worker] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 4766e5a520..5366360f37 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1551,6 +1551,17 @@ </row> <row> + <entry><option>-ffun-to-thunk</option></entry> + <entry>Worker-wrapper removes unused arguments; this flag + lets it thusly remove all value lambdas. Doing so creates + a thunk where it was previously a function closure, which + may save recomputation but also risks a space leak. Off by + default.</entry> + <entry>dynamic</entry> + <entry><option>-fno-fun-to-thunk</option></entry> + </row> + + <row> <entry><option>-fdo-eta-reduction</option></entry> <entry>Enable eta-reduction. Implied by <option>-O</option>.</entry> <entry>dynamic</entry> |