diff options
author | Ian Lynagh <ian@well-typed.com> | 2012-10-09 00:27:28 +0100 |
---|---|---|
committer | Ian Lynagh <ian@well-typed.com> | 2012-10-09 12:32:04 +0100 |
commit | 0a768bcbe6f7238d0bcdddd85fe24c99189453a0 (patch) | |
tree | a1e75804cc73c1f88fb3deae9fa7aaf0aaa75753 | |
parent | 9c6223dd780b5a41be98702a583a1b7229841305 (diff) | |
download | haskell-0a768bcbe6f7238d0bcdddd85fe24c99189453a0.tar.gz |
Make the opt_UF_* static flags dynamic
I also removed the default values from the "Discounts and thresholds"
note: most of them were no longer up-to-date.
Along the way I added FloatSuffix to the argument parser, analogous to
IntSuffix.
-rw-r--r-- | compiler/basicTypes/MkId.lhs | 7 | ||||
-rw-r--r-- | compiler/coreSyn/CoreUnfold.lhs | 120 | ||||
-rw-r--r-- | compiler/deSugar/DsBinds.lhs | 28 | ||||
-rw-r--r-- | compiler/iface/BuildTyCl.lhs | 10 | ||||
-rw-r--r-- | compiler/iface/TcIface.lhs | 5 | ||||
-rw-r--r-- | compiler/main/CmdLineParser.hs | 10 | ||||
-rw-r--r-- | compiler/main/DynFlags.hs | 33 | ||||
-rw-r--r-- | compiler/main/StaticFlagParser.hs | 7 | ||||
-rw-r--r-- | compiler/main/StaticFlags.hs | 36 | ||||
-rw-r--r-- | compiler/main/TidyPgm.lhs | 17 | ||||
-rw-r--r-- | compiler/simplCore/LiberateCase.lhs | 13 | ||||
-rw-r--r-- | compiler/simplCore/SimplUtils.lhs | 6 | ||||
-rw-r--r-- | compiler/simplCore/Simplify.lhs | 22 | ||||
-rw-r--r-- | compiler/specialise/SpecConstr.lhs | 2 | ||||
-rw-r--r-- | compiler/specialise/Specialise.lhs | 26 | ||||
-rw-r--r-- | compiler/stranal/WorkWrap.lhs | 10 | ||||
-rw-r--r-- | docs/users_guide/flags.xml | 8 |
17 files changed, 197 insertions, 163 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 24c40ccdfd..15f971ae43 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -429,13 +429,14 @@ at the outside. When dealing with classes it's very convenient to recover the original type signature from the class op selector. \begin{code} -mkDictSelId :: Bool -- True <=> don't include the unfolding +mkDictSelId :: DynFlags + -> Bool -- True <=> don't include the unfolding -- Little point on imports without -O, because the -- dictionary itself won't be visible -> Name -- Name of one of the *value* selectors -- (dictionary superclass or method) -> Class -> Id -mkDictSelId no_unf name clas +mkDictSelId dflags no_unf name clas = mkGlobalId (ClassOpId clas) name sel_ty info where sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) @@ -449,7 +450,7 @@ mkDictSelId no_unf name clas `setArityInfo` 1 `setStrictnessInfo` Just strict_sig `setUnfoldingInfo` (if no_unf then noUnfolding - else mkImplicitUnfolding rhs) + else mkImplicitUnfolding dflags rhs) -- In module where class op is defined, we must add -- the unfolding, even though it'll never be inlined -- becuase we use that to generate a top-level binding diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 4153696699..7ed5d2b475 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -45,7 +45,6 @@ module CoreUnfold ( #include "HsVersions.h" -import StaticFlags import DynFlags import CoreSyn import PprCore () -- Instances @@ -80,12 +79,13 @@ import Data.Maybe %************************************************************************ \begin{code} -mkTopUnfolding :: Bool -> CoreExpr -> Unfolding -mkTopUnfolding = mkUnfolding InlineRhs True {- Top level -} +mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding +mkTopUnfolding dflags = mkUnfolding dflags InlineRhs True {- Top level -} -mkImplicitUnfolding :: CoreExpr -> Unfolding +mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding -- For implicit Ids, do a tiny bit of optimising first -mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) +mkImplicitUnfolding dflags expr + = mkTopUnfolding dflags False (simpleOptExpr expr) -- Note [Top-level flag on inline rules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -93,8 +93,8 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) -- top-level flag to True. It gets set more accurately by the simplifier -- Simplify.simplUnfolding. -mkSimpleUnfolding :: CoreExpr -> Unfolding -mkSimpleUnfolding = mkUnfolding InlineRhs False False +mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkSimpleUnfolding dflags = mkUnfolding dflags InlineRhs False False mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding mkDFunUnfolding dfun_ty ops @@ -130,9 +130,9 @@ mkInlineUnfolding mb_arity expr boring_ok = inlineBoringOk expr' -mkInlinableUnfolding :: CoreExpr -> Unfolding -mkInlinableUnfolding expr - = mkUnfolding InlineStable True is_bot expr' +mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkInlinableUnfolding dflags expr + = mkUnfolding dflags InlineStable True is_bot expr' where expr' = simpleOptExpr expr is_bot = isJust (exprBotStrictness_maybe expr') @@ -155,10 +155,11 @@ mkCoreUnfolding src top_lvl expr arity guidance uf_expandable = exprIsExpandable expr, uf_guidance = guidance } -mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding +mkUnfolding :: DynFlags -> UnfoldingSource -> Bool -> Bool -> CoreExpr + -> Unfolding -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it -mkUnfolding src top_lvl is_bottoming expr +mkUnfolding dflags src top_lvl is_bottoming expr | top_lvl && is_bottoming , not (exprIsTrivial expr) = NoUnfolding -- See Note [Do not inline top-level bottoming functions] @@ -173,7 +174,7 @@ mkUnfolding src top_lvl is_bottoming expr uf_is_work_free = exprIsWorkFree expr, uf_guidance = guidance } where - (arity, guidance) = calcUnfoldingGuidance expr + (arity, guidance) = calcUnfoldingGuidance dflags expr -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] \end{code} @@ -232,18 +233,19 @@ inlineBoringOk e go _ _ = boringCxtNotOk calcUnfoldingGuidance - :: CoreExpr -- Expression to look at - -> (Arity, UnfoldingGuidance) -calcUnfoldingGuidance expr + :: DynFlags + -> CoreExpr -- Expression to look at + -> (Arity, UnfoldingGuidance) +calcUnfoldingGuidance dflags expr = case collectBinders expr of { (bndrs, body) -> let - bOMB_OUT_SIZE = opt_UF_CreationThreshold + bOMB_OUT_SIZE = ufCreationThreshold dflags -- Bomb out if size gets bigger than this val_bndrs = filter isId bndrs n_val_bndrs = length val_bndrs guidance - = case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_bndrs body) of + = case sizeExpr dflags (iUnbox bOMB_OUT_SIZE) val_bndrs body of TooBig -> UnfNever SizeIs size cased_bndrs scrut_discount | uncondInline expr n_val_bndrs (iBox size) @@ -375,7 +377,8 @@ uncondInline rhs arity size \begin{code} -sizeExpr :: FastInt -- Bomb out if it gets bigger than this +sizeExpr :: DynFlags + -> FastInt -- Bomb out if it gets bigger than this -> [Id] -- Arguments; we're interested in which of these -- get case'd -> CoreExpr @@ -383,7 +386,7 @@ sizeExpr :: FastInt -- Bomb out if it gets bigger than this -- Note [Computing the size of an expression] -sizeExpr bOMB_OUT_SIZE top_args expr +sizeExpr dflags bOMB_OUT_SIZE top_args expr = size_up expr where size_up (Cast e _) = size_up e @@ -399,7 +402,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr size_up (App fun arg) = size_up arg `addSizeNSD` size_up_app fun [arg] - size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 10) + size_up (Lam b e) | isId b = lamScrutDiscount dflags (size_up e `addSizeN` 10) | otherwise = size_up e size_up (Let (NonRec binder rhs) body) @@ -490,8 +493,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr FCallId _ -> sizeN (10 * (1 + length val_args)) DataConWorkId dc -> conSize dc (length val_args) PrimOpId op -> primOpSize op (length val_args) - ClassOpId _ -> classOpSize top_args val_args - _ -> funSize top_args fun (length val_args) + ClassOpId _ -> classOpSize dflags top_args val_args + _ -> funSize dflags top_args fun (length val_args) ------------ size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 @@ -540,11 +543,11 @@ litSize _other = 0 -- Must match size of nullary constructors -- Key point: if x |-> 4, then x must inline unconditionally -- (eg via case binding) -classOpSize :: [Id] -> [CoreExpr] -> ExprSize +classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize -- See Note [Conlike is interesting] -classOpSize _ [] +classOpSize _ _ [] = sizeZero -classOpSize top_args (arg1 : other_args) +classOpSize dflags top_args (arg1 : other_args) = SizeIs (iUnbox size) arg_discount (_ILIT(0)) where size = 20 + (10 * length other_args) @@ -553,13 +556,13 @@ classOpSize top_args (arg1 : other_args) -- The actual discount is rather arbitrarily chosen arg_discount = case arg1 of Var dict | dict `elem` top_args - -> unitBag (dict, opt_UF_DictDiscount) + -> unitBag (dict, ufDictDiscount dflags) _other -> emptyBag -funSize :: [Id] -> Id -> Int -> ExprSize +funSize :: DynFlags -> [Id] -> Id -> Int -> ExprSize -- Size for functions that are not constructors or primops -- Note [Function applications] -funSize top_args fun n_val_args +funSize dflags top_args fun n_val_args | fun `hasKey` buildIdKey = buildSize | fun `hasKey` augmentIdKey = augmentSize | otherwise = SizeIs (iUnbox size) arg_discount (iUnbox res_discount) @@ -575,12 +578,12 @@ funSize top_args fun n_val_args -- DISCOUNTS -- See Note [Function and non-function discounts] arg_discount | some_val_args && fun `elem` top_args - = unitBag (fun, opt_UF_FunAppDiscount) + = unitBag (fun, ufFunAppDiscount dflags) | otherwise = emptyBag -- If the function is an argument and is applied -- to some values, give it an arg-discount - res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount + res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags | otherwise = 0 -- If the function is partially applied, show a result discount @@ -691,9 +694,9 @@ augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40)) -- e plus ys. The -2 accounts for the \cn -- When we return a lambda, give a discount if it's used (applied) -lamScrutDiscount :: ExprSize -> ExprSize -lamScrutDiscount (SizeIs n vs _) = SizeIs n vs (iUnbox opt_UF_FunAppDiscount) -lamScrutDiscount TooBig = TooBig +lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize +lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (iUnbox (ufFunAppDiscount dflags)) +lamScrutDiscount _ TooBig = TooBig \end{code} Note [addAltSize result discounts] @@ -707,31 +710,31 @@ binary sizes shrink significantly either. Note [Discounts and thresholds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Constants for discounts and thesholds are defined in main/StaticFlags, -all of form opt_UF_xxxx. They are: +Constants for discounts and thesholds are defined in main/DynFlags, +all of form ufXxxx. They are: -opt_UF_CreationThreshold (45) +ufCreationThreshold At a definition site, if the unfolding is bigger than this, we may discard it altogether -opt_UF_UseThreshold (6) +ufUseThreshold At a call site, if the unfolding, less discounts, is smaller than this, then it's small enough inline -opt_UF_KeennessFactor (1.5) +ufKeenessFactor Factor by which the discounts are multiplied before subtracting from size -opt_UF_DictDiscount (1) +ufDictDiscount The discount for each occurrence of a dictionary argument as an argument of a class method. Should be pretty small else big functions may get inlined -opt_UF_FunAppDiscount (6) +ufFunAppDiscount Discount for a function argument that is applied. Quite large, because if we inline we avoid the higher-order call. -opt_UF_DearOp (4) +ufDearOp The size of a foreign call or not-dupable PrimOp @@ -795,33 +798,33 @@ flaggery. Just the same as smallEnoughToInline, except that it has no actual arguments. \begin{code} -couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool -couldBeSmallEnoughToInline threshold rhs - = case sizeExpr (iUnbox threshold) [] body of +couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool +couldBeSmallEnoughToInline dflags threshold rhs + = case sizeExpr dflags (iUnbox threshold) [] body of TooBig -> False _ -> True where (_, body) = collectBinders rhs ---------------- -smallEnoughToInline :: Unfolding -> Bool -smallEnoughToInline (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) - = size <= opt_UF_UseThreshold -smallEnoughToInline _ +smallEnoughToInline :: DynFlags -> Unfolding -> Bool +smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) + = size <= ufUseThreshold dflags +smallEnoughToInline _ _ = False ---------------- -certainlyWillInline :: Unfolding -> Bool +certainlyWillInline :: DynFlags -> Unfolding -> Bool -- Sees if the unfolding is pretty certain to inline -certainlyWillInline (CoreUnfolding { uf_arity = n_vals, uf_guidance = guidance }) +certainlyWillInline dflags (CoreUnfolding { uf_arity = n_vals, uf_guidance = guidance }) = case guidance of UnfNever -> False UnfWhen {} -> True UnfIfGoodArgs { ug_size = size} -> n_vals > 0 -- See Note [certainlyWillInline: be caseful of thunks] - && size - (10 * (n_vals +1)) <= opt_UF_UseThreshold + && size - (10 * (n_vals +1)) <= ufUseThreshold dflags -certainlyWillInline _ +certainlyWillInline _ _ = False \end{code} @@ -979,8 +982,8 @@ tryUnfolding dflags id lone_variable , (text "discounted size =" <+> int discounted_size) ) where discounted_size = size - discount - small_enough = discounted_size <= opt_UF_UseThreshold - discount = computeDiscount uf_arity arg_discounts + small_enough = discounted_size <= ufUseThreshold dflags + discount = computeDiscount dflags uf_arity arg_discounts res_discount arg_infos cont_info \end{code} @@ -1172,8 +1175,9 @@ This kind of thing can occur if you have which Roman did. \begin{code} -computeDiscount :: Int -> [Int] -> Int -> [ArgSummary] -> CallCtxt -> Int -computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info +computeDiscount :: DynFlags -> Int -> [Int] -> Int -> [ArgSummary] -> CallCtxt + -> Int +computeDiscount dflags n_vals_wanted arg_discounts res_discount arg_infos cont_info -- We multiple the raw discounts (args_discount and result_discount) -- ty opt_UnfoldingKeenessFactor because the former have to do with -- *size* whereas the discounts imply that there's some extra @@ -1187,7 +1191,7 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info -- Discount of (un-scaled) 1 for each arg supplied, -- because the result replaces the call - + round (opt_UF_KeenessFactor * + + round (ufKeenessFactor dflags * fromIntegral (arg_discount + res_discount')) where arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos) diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 95d36f3879..1e3eb2d8c4 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -101,23 +101,25 @@ dsLHsBind (L loc bind) dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr)) dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless }) - = do { core_expr <- dsLExpr expr + = do { dflags <- getDynFlags + ; core_expr <- dsLExpr expr -- Dictionary bindings are always VarBinds, -- so we only need do this here ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr | otherwise = var - ; return (unitOL (makeCorePair var' False 0 core_expr)) } + ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) } dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches , fun_co_fn = co_fn, fun_tick = tick , fun_infix = inf }) - = do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches + = do { dflags <- getDynFlags + ; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches ; let body' = mkOptTickBox tick body ; rhs <- dsHsWrapper co_fn (mkLams args body') ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -} - return (unitOL (makeCorePair fun False 0 rhs)) } + return (unitOL (makeCorePair dflags fun False 0 rhs)) } dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty , pat_ticks = (rhs_tick, var_ticks) }) @@ -137,7 +139,8 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts , abs_ev_binds = ev_binds, abs_binds = binds }) | ABE { abe_wrap = wrap, abe_poly = global , abe_mono = local, abe_prags = prags } <- export - = do { bind_prs <- ds_lhs_binds binds + = do { dflags <- getDynFlags + ; bind_prs <- ds_lhs_binds binds ; let core_bind = Rec (fromOL bind_prs) ; ds_binds <- dsTcEvBinds ev_binds ; rhs <- dsHsWrapper wrap $ -- Usually the identity @@ -149,7 +152,7 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts ; (spec_binds, rules) <- dsSpecs rhs prags ; let global' = addIdSpecialisations global rules - main_bind = makeCorePair global' (isDefaultMethod prags) + main_bind = makeCorePair dflags global' (isDefaultMethod prags) (dictArity dicts) rhs ; return (main_bind `consOL` spec_binds) } @@ -158,8 +161,9 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts , abs_exports = exports, abs_ev_binds = ev_binds , abs_binds = binds }) -- See Note [Desugaring AbsBinds] - = do { bind_prs <- ds_lhs_binds binds - ; let core_bind = Rec [ makeCorePair (add_inline lcl_id) False 0 rhs + = do { dflags <- getDynFlags + ; bind_prs <- ds_lhs_binds binds + ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs | (lcl_id, rhs) <- fromOL bind_prs ] -- Monomorphic recursion possible, hence Rec @@ -207,8 +211,8 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id ------------------------ -makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) -makeCorePair gbl_id is_default_method dict_arity rhs +makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) +makeCorePair dflags gbl_id is_default_method dict_arity rhs | is_default_method -- Default methods are *always* inlined = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) @@ -221,7 +225,7 @@ makeCorePair gbl_id is_default_method dict_arity rhs where inline_prag = idInlinePragma gbl_id - inlinable_unf = mkInlinableUnfolding rhs + inlinable_unf = mkInlinableUnfolding dflags rhs inline_pair | Just arity <- inlinePragmaSat inline_prag -- Add an Unfolding for an INLINE (but not for NOINLINE) @@ -463,7 +467,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) (mkVarApps (Var spec_id) bndrs) ; spec_rhs <- dsHsWrapper spec_co poly_rhs - ; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs + ; let spec_pair = makeCorePair dflags spec_id False (dictArity bndrs) spec_rhs ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags) (warnDs (specOnInline poly_name)) diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 5f5e8a1896..be757c62ad 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -37,6 +37,7 @@ import TyCon import Type import Coercion +import DynFlags import TcRnMonad import Util import Outputable @@ -205,6 +206,8 @@ buildClass :: Bool -- True <=> do not include unfoldings buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec = fixM $ \ rec_clas -> -- Only name generation inside loop do { traceIf (text "buildClass") + ; dflags <- getDynFlags + ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc -- The class name is the 'parent' for this datacon, not its tycon, -- because one should import the class to get the binding for @@ -217,7 +220,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec -- Make selectors for the superclasses ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) [1..length sc_theta] - ; let sc_sel_ids = [ mkDictSelId no_unf sc_name rec_clas + ; let sc_sel_ids = [ mkDictSelId dflags no_unf sc_name rec_clas | sc_name <- sc_sel_names] -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we -- can construct names for the selectors. Thus @@ -282,13 +285,14 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec where mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem mk_op_item rec_clas (op_name, dm_spec, _) - = do { dm_info <- case dm_spec of + = do { dflags <- getDynFlags + ; dm_info <- case dm_spec of NoDM -> return NoDefMeth GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc ; return (GenDefMeth dm_name) } VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc ; return (DefMeth dm_name) } - ; return (mkDictSelId no_unf op_name rec_clas, dm_info) } + ; return (mkDictSelId dflags no_unf op_name rec_clas, dm_info) } \end{code} Note [Class newtypes and equality predicates] diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index b9783a8d4f..1efb11e21b 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1198,11 +1198,12 @@ tcIdInfo ignore_prags name ty info \begin{code} tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding tcUnfolding name _ info (IfCoreUnfold stable if_expr) - = do { mb_expr <- tcPragExpr name if_expr + = do { dflags <- getDynFlags + ; mb_expr <- tcPragExpr name if_expr ; let unf_src = if stable then InlineStable else InlineRhs ; return (case mb_expr of Nothing -> NoUnfolding - Just expr -> mkUnfolding unf_src + Just expr -> mkUnfolding dflags unf_src True {- Top level -} is_bottoming expr) } where diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index f87039a2e5..b6618af1a9 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -48,6 +48,7 @@ data OptKind m -- Suppose the flag is -f | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn + | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn | PrefixPred (String -> Bool) (String -> EwM m ()) @@ -188,6 +189,9 @@ processOneArg opt_kind rest arg args IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed float argument in " ++ dash_arg) + OptPrefix f -> Right (f rest_no_eq, args) AnySuffix f -> Right (f dash_arg, args) AnySuffixPred _ f -> Right (f dash_arg, args) @@ -213,6 +217,7 @@ arg_ok (Prefix _) rest _ = notNull rest arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest) arg_ok (OptIntSuffix _) _ _ = True arg_ok (IntSuffix _) _ _ = True +arg_ok (FloatSuffix _) _ _ = True arg_ok (OptPrefix _) _ _ = True arg_ok (PassFlag _) rest _ = null rest arg_ok (AnySuffix _) _ _ = True @@ -228,6 +233,11 @@ parseInt s = case reads s of ((n,""):_) -> Just n _ -> Nothing +parseFloat :: String -> Maybe Float +parseFloat s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + -- | Discards a leading equals sign dropEq :: String -> String dropEq ('=' : s) = s diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 785a676a99..feaa3b54ce 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -646,6 +646,15 @@ data DynFlags = DynFlags { -- flattenExtensionFlags language extensions extensionFlags :: IntSet, + -- Unfolding control + -- See Note [Discounts and thresholds] in CoreUnfold + ufCreationThreshold :: Int, + ufUseThreshold :: Int, + ufFunAppDiscount :: Int, + ufDictDiscount :: Int, + ufKeenessFactor :: Float, + ufDearOp :: Int, + -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, flushOut :: FlushOut, @@ -1173,6 +1182,21 @@ defaultDynFlags mySettings = warnUnsafeOnLoc = noSrcSpan, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], + + -- The ufCreationThreshold threshold must be reasonably high to + -- take account of possible discounts. + -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline + -- into Csg.calc (The unfolding for sqr never makes it into the + -- interface file.) + ufCreationThreshold = 750, + ufUseThreshold = 60, + ufFunAppDiscount = 60, + -- Be fairly keen to inline a fuction if that means + -- we'll be able to pick the right method from a dictionary + ufDictDiscount = 30, + ufKeenessFactor = 1.5, + ufDearOp = 40, + log_action = defaultLogAction, flushOut = defaultFlushOut, flushErr = defaultFlushErr, @@ -2027,6 +2051,12 @@ dynamic_flags = [ , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) , Flag "fhistory-size" (intSuffix (\n d -> d{ historySize = n })) + , Flag "funfolding-creation-threshold" (intSuffix (\n d -> d {ufCreationThreshold = n})) + , Flag "funfolding-use-threshold" (intSuffix (\n d -> d {ufUseThreshold = n})) + , Flag "funfolding-fun-discount" (intSuffix (\n d -> d {ufFunAppDiscount = n})) + , Flag "funfolding-dict-discount" (intSuffix (\n d -> d {ufDictDiscount = n})) + , Flag "funfolding-keeness-factor" (floatSuffix (\n d -> d {ufKeenessFactor = n})) + ------ Profiling ---------------------------------------------------- -- OLD profiling flags @@ -2712,6 +2742,9 @@ sepArg fn = SepArg (upd . fn) intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) intSuffix fn = IntSuffix (\n -> upd (fn n)) +floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +floatSuffix fn = FloatSuffix (\n -> upd (fn n)) + optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 9c98836e63..e1def67f3e 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -138,12 +138,7 @@ isStaticFlag f = ] || any (`isPrefixOf` f) [ "fliberate-case-threshold", - "fmax-worker-args", - "funfolding-creation-threshold", - "funfolding-dict-threshold", - "funfolding-use-threshold", - "funfolding-fun-discount", - "funfolding-keeness-factor" + "fmax-worker-args" ] ----------------------------------------------------------------------------- diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 598ea00848..4414f6b509 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -52,14 +52,6 @@ module StaticFlags ( opt_MaxWorkerArgs, opt_NoFlatCache, - -- Unfolding control - opt_UF_CreationThreshold, - opt_UF_UseThreshold, - opt_UF_FunAppDiscount, - opt_UF_DictDiscount, - opt_UF_KeenessFactor, - opt_UF_DearOp, - -- For the parser addOpt, removeOpt, v_opt_C_ready, @@ -114,7 +106,6 @@ removeOpt f = do lookUp :: FastString -> Bool lookup_def_int :: String -> Int -> Int -lookup_def_float :: String -> Float -> Float lookup_str :: String -> Maybe String -- holds the static opts while they're being collected, before @@ -146,10 +137,12 @@ lookup_def_int sw def = case (lookup_str sw) of Nothing -> def -- Use default Just xx -> try_read sw xx +{- +lookup_def_float :: String -> Float -> Float lookup_def_float sw def = case (lookup_str sw) of Nothing -> def -- Use default Just xx -> try_read sw xx - +-} try_read :: Read a => String -> String -> a -- (try_read sw str) tries to read s; if it fails, it @@ -265,29 +258,6 @@ opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion") opt_NoFlatCache :: Bool opt_NoFlatCache = lookUp (fsLit "-fno-flat-cache") --- Unfolding control --- See Note [Discounts and thresholds] in CoreUnfold - -opt_UF_CreationThreshold, opt_UF_UseThreshold :: Int -opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int -opt_UF_KeenessFactor :: Float - -opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (750::Int) - -- This threshold must be reasonably high to take - -- account of possible discounts. - -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline into Csg.calc - -- (The unfolding for sqr never makes it into the interface file.) - -opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (60::Int) -opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (60::Int) - -opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (30::Int) - -- Be fairly keen to inline a fuction if that means - -- we'll be able to pick the right method from a dictionary - -opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) -opt_UF_DearOp = ( 40 :: Int) - ----------------------------------------------------------------------------- -- Tunneling our global variables into a new instance of the GHC library diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 309f2e2d9b..ebb8f4889a 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -1074,14 +1074,14 @@ tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr where Just (name',show_unfold) = lookupVarEnv unfold_env bndr caf_info = hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs - (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs) + (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) = (tidy_env2, Rec prs') where - prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs) + prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) | (id,rhs) <- prs, let (name',show_unfold) = expectJust "tidyTopBind" $ lookupVarEnv unfold_env id @@ -1100,7 +1100,8 @@ tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) | otherwise = NoCafRefs ----------------------------------------------------------- -tidyTopPair :: Bool -- show unfolding +tidyTopPair :: DynFlags + -> Bool -- show unfolding -> TidyEnv -- The TidyEnv is used to tidy the IdInfo -- It is knot-tied: don't look at it! -> CafInfo @@ -1113,14 +1114,14 @@ tidyTopPair :: Bool -- show unfolding -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group -tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) +tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs) = (bndr1, rhs1) where bndr1 = mkGlobalId details name' ty' idinfo' details = idDetails bndr -- Preserve the IdDetails ty' = tidyTopType (idType bndr) rhs1 = tidyExpr rhs_tidy_env rhs - idinfo' = tidyTopIdInfo rhs_tidy_env name' rhs rhs1 (idInfo bndr) + idinfo' = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr) show_unfold caf_info -- tidyTopIdInfo creates the final IdInfo for top-level @@ -1135,9 +1136,9 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) -- occurrences of the binders in RHSs, and hence to occurrences in -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. -- CoreToStg makes use of this when constructing SRTs. -tidyTopIdInfo :: TidyEnv -> Name -> CoreExpr -> CoreExpr +tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> CafInfo -> IdInfo -tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info +tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; @@ -1182,7 +1183,7 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info unf_info = unfoldingInfo idinfo unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs | otherwise = noUnfolding - unf_from_rhs = mkTopUnfolding is_bot tidy_rhs + unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs is_bot = case final_sig of Just sig -> isBottomingSig sig Nothing -> False diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index 35bfb5fcc1..9f83043740 100644 --- a/compiler/simplCore/LiberateCase.lhs +++ b/compiler/simplCore/LiberateCase.lhs @@ -168,7 +168,7 @@ libCaseBind env (Rec pairs) rhs_small_enough id rhs -- Note [Small enough] = idArity id > 0 -- Note [Only functions!] - && maybe True (\size -> couldBeSmallEnoughToInline size rhs) + && maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs) (bombOutSize env) \end{code} @@ -366,9 +366,7 @@ topLevel = 0 \begin{code} data LibCaseEnv = LibCaseEnv { - lc_size :: Maybe Int, -- Bomb-out size for deciding if - -- potential liberatees are too big. - -- (passed in from cmd-line args) + lc_dflags :: DynFlags, lc_lvl :: LibCaseLevel, -- Current level -- The level is incremented when (and only when) going @@ -405,13 +403,16 @@ data LibCaseEnv initEnv :: DynFlags -> LibCaseEnv initEnv dflags - = LibCaseEnv { lc_size = liberateCaseThreshold dflags, + = LibCaseEnv { lc_dflags = dflags, lc_lvl = 0, lc_lvl_env = emptyVarEnv, lc_rec_env = emptyVarEnv, lc_scruts = [] } +-- Bomb-out size for deciding if +-- potential liberatees are too big. +-- (passed in from cmd-line args) bombOutSize :: LibCaseEnv -> Maybe Int -bombOutSize = lc_size +bombOutSize = liberateCaseThreshold . lc_dflags \end{code} diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 87aefbab89..a5ed3976bd 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -922,14 +922,14 @@ story for now. \begin{code} postInlineUnconditionally - :: SimplEnv -> TopLevelFlag + :: DynFlags -> SimplEnv -> TopLevelFlag -> OutId -- The binder (an InId would be fine too) -- (*not* a CoVar) -> OccInfo -- From the InId -> OutExpr -> Unfolding -> Bool -postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding +postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding | not active = False | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline -- because it might be referred to "earlier" @@ -952,7 +952,7 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding -- This is very important in practice; e.g. wheel-seive1 doubles -- in allocation if you miss this out OneOcc in_lam _one_br int_cxt -- OneOcc => no code-duplication issue - -> smallEnoughToInline unfolding -- Small enough to dup + -> smallEnoughToInline dflags unfolding -- Small enough to dup -- ToDo: consider discount on smallEnoughToInline if int_cxt is true -- -- NB: Do NOT inline arbitrarily big things, even if one_br is True diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index f76fec1033..df301421c0 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -654,7 +654,8 @@ completeBind env top_lvl old_bndr new_bndr new_rhs -- Simplify the unfolding ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf - ; if postInlineUnconditionally env top_lvl new_bndr occ_info + ; dflags <- getDynFlags + ; if postInlineUnconditionally dflags env top_lvl new_bndr occ_info final_rhs new_unfolding -- Inline and discard the binding @@ -749,7 +750,8 @@ simplUnfolding env top_lvl id _ _other -- Happens for INLINABLE things -> let bottoming = isBottomingId id in bottoming `seq` -- See Note [Force bottoming field] - return (mkUnfolding src' is_top_lvl bottoming expr') + do dflags <- getDynFlags + return (mkUnfolding dflags src' is_top_lvl bottoming expr') -- If the guidance is UnfIfGoodArgs, this is an INLINABLE -- unfolding, and we need to make sure the guidance is kept up -- to date with respect to any changes in the unfolding. @@ -762,7 +764,8 @@ simplUnfolding env top_lvl id _ simplUnfolding _ top_lvl id new_rhs _ = let bottoming = isBottomingId id in bottoming `seq` -- See Note [Force bottoming field] - return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs) + do dflags <- getDynFlags + return (mkUnfolding dflags InlineRhs (isTopLevel top_lvl) bottoming new_rhs) -- We make an unfolding *even for loop-breakers*. -- Reason: (a) It might be useful to know that they are WHNF -- (b) In TidyPgm we currently assume that, if we want to @@ -2008,23 +2011,26 @@ simplAlt env scrut imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) simplAlt env scrut _ case_bndr' cont' (LitAlt lit, bndrs, rhs) = ASSERT( null bndrs ) - do { let env' = addBinderUnfolding env scrut case_bndr' - (mkSimpleUnfolding (Lit lit)) + do { dflags <- getDynFlags + ; let env' = addBinderUnfolding env scrut case_bndr' + (mkSimpleUnfolding dflags (Lit lit)) ; rhs' <- simplExprC env' rhs cont' ; return (LitAlt lit, [], rhs') } simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs) - = do { -- Deal with the pattern-bound variables + = do { dflags <- getDynFlags + + -- Deal with the pattern-bound variables -- Mark the ones that are in ! positions in the -- data constructor as certainly-evaluated. -- NB: simplLamBinders preserves this eval info - let vs_with_evals = add_evals (dataConRepStrictness con) + ; let vs_with_evals = add_evals (dataConRepStrictness con) ; (env', vs') <- simplLamBndrs env vs_with_evals -- Bind the case-binder to (con args) ; let inst_tys' = tyConAppArgs (idType case_bndr') con_args = map Type inst_tys' ++ varsToCoreExprs vs' - unf = mkSimpleUnfolding (mkConApp con con_args) + unf = mkSimpleUnfolding dflags (mkConApp con con_args) env'' = addBinderUnfolding env' scrut case_bndr' unf ; rhs' <- simplExprC env'' rhs cont' diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 7661878ac1..b2f83deb91 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -1180,7 +1180,7 @@ scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) scTopBind env (Rec prs) | Just threshold <- sc_size env , not force_spec - , not (all (couldBeSmallEnoughToInline threshold) rhss) + , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss) -- No specialisation = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 083d1502bb..04ef404ab2 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -789,7 +789,9 @@ specCase subst scrut' case_bndr [(con, args, rhs)] | isDictId case_bndr -- See Note [Floating dictionaries out of cases] , interestingDict scrut' , not (isDeadBinder case_bndr && null sc_args') - = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') + = do { dflags <- getDynFlags + + ; (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') [(con, args', Var sc_arg')] @@ -800,8 +802,8 @@ specCase subst scrut' case_bndr [(con, args, rhs)] -- binders so they look interesting to interestingDict mb_sc_flts :: [Maybe DictId] mb_sc_flts = map (lookupVarEnv clone_env) args' - clone_env = zipVarEnv sc_args' (zipWith add_unf sc_args_flt sc_rhss) - subst_prs = (case_bndr, Var (add_unf case_bndr_flt scrut')) + clone_env = zipVarEnv sc_args' (zipWith (add_unf dflags) sc_args_flt sc_rhss) + subst_prs = (case_bndr, Var (add_unf dflags case_bndr_flt scrut')) : [ (arg, Var sc_flt) | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] subst_rhs' = extendIdSubstList subst_rhs subst_prs @@ -828,8 +830,8 @@ specCase subst scrut' case_bndr [(con, args, rhs)] occ = nameOccName name loc = getSrcSpan name - add_unf sc_flt sc_rhs -- Sole purpose: make sc_flt respond True to interestingDictId - = setIdUnfolding sc_flt (mkSimpleUnfolding sc_rhs) + add_unf dflags sc_flt sc_rhs -- Sole purpose: make sc_flt respond True to interestingDictId + = setIdUnfolding sc_flt (mkSimpleUnfolding dflags sc_rhs) arg_set = mkVarSet args' is_flt_sc_arg var = isId var @@ -1114,12 +1116,13 @@ specCalls subst rules_for_me calls_for_me fn rhs ; (rhs_subst1, inst_dict_ids) <- newDictBndrs rhs_subst rhs_dict_ids -- Clone rhs_dicts, including instantiating their types - ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $ + ; dflags <- getDynFlags + + ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts dflags rhs_subst1 $ (my_zipEqual rhs_dict_ids inst_dict_ids call_ds) ty_args = mk_ty_args call_ts poly_tyvars inst_args = ty_args ++ map Var inst_dict_ids - ; dflags <- getDynFlags ; if already_covered dflags inst_args then return Nothing else do @@ -1164,7 +1167,7 @@ specCalls subst rules_for_me calls_for_me fn rhs spec_unf = case inlinePragmaSpec spec_inl_prag of Inline -> mkInlineUnfolding (Just spec_arity) spec_rhs - Inlinable -> mkInlinableUnfolding spec_rhs + Inlinable -> mkInlinableUnfolding dflags spec_rhs _ -> NoUnfolding -------------------------------------- @@ -1188,13 +1191,14 @@ specCalls subst rules_for_me calls_for_me fn rhs | otherwise = zip3 xs ys zs bindAuxiliaryDicts - :: Subst + :: DynFlags + -> Subst -> [(DictId,DictId,CoreExpr)] -- (orig_dict, inst_dict, dx) -> (Subst, -- Substitute for all orig_dicts [CoreBind]) -- Auxiliary bindings -- Bind any dictionary arguments to fresh names, to preserve sharing -- Substitution already substitutes orig_dict -> inst_dict -bindAuxiliaryDicts subst triples = go subst [] triples +bindAuxiliaryDicts dflags subst triples = go subst [] triples where go subst binds [] = (subst, binds) go subst binds ((d, dx_id, dx) : pairs) @@ -1205,7 +1209,7 @@ bindAuxiliaryDicts subst triples = go subst [] triples | otherwise = go subst_w_unf (NonRec dx_id dx : binds) pairs where - dx_id1 = dx_id `setIdUnfolding` mkSimpleUnfolding dx + dx_id1 = dx_id `setIdUnfolding` mkSimpleUnfolding dflags dx subst_w_unf = extendIdSubst subst d (Var dx_id1) -- Important! We're going to substitute dx_id1 for d -- and we want it to look "interesting", else we won't gather *any* diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index e5013debd1..5be63a9bc7 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -261,11 +261,11 @@ tryWW dflags is_rec fn_id rhs | is_thunk && worthSplittingThunk maybe_fn_dmd res_info -- See Note [Thunk splitting] = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive - checkSize new_fn_id rhs $ + checkSize dflags new_fn_id rhs $ splitThunk dflags new_fn_id rhs | is_fun && worthSplittingFun wrap_dmds res_info - = checkSize new_fn_id rhs $ + = checkSize dflags new_fn_id rhs $ splitFun dflags new_fn_id fn_info wrap_dmds res_info rhs | otherwise @@ -294,9 +294,9 @@ tryWW dflags is_rec fn_id rhs is_thunk = not is_fun && not (exprIsHNF rhs) --------------------- -checkSize :: Id -> CoreExpr +checkSize :: DynFlags -> Id -> CoreExpr -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)] -checkSize fn_id rhs thing_inside +checkSize dflags fn_id rhs thing_inside | isStableUnfolding (realIdUnfolding fn_id) = return [ (fn_id, rhs) ] -- See Note [Don't w/w INLINE things] @@ -304,7 +304,7 @@ checkSize fn_id rhs thing_inside -- NB: use realIdUnfolding because we want to see the unfolding -- even if it's a loop breaker! - | certainlyWillInline (idUnfolding fn_id) + | certainlyWillInline dflags (idUnfolding fn_id) = return [ (fn_id `setIdUnfolding` inline_rule, rhs) ] -- Note [Don't w/w inline small non-loop-breaker things] -- NB: use idUnfolding because we don't want to apply diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index a122e5a0ca..26c4464642 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1732,28 +1732,28 @@ <row> <entry><option>-funfolding-creation-threshold</option></entry> <entry>Tweak unfolding settings</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry><option>-fno-unfolding-creation-threshold</option></entry> </row> <row> <entry><option>-funfolding-fun-discount</option></entry> <entry>Tweak unfolding settings</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry><option>-fno-unfolding-fun-discount</option></entry> </row> <row> <entry><option>-funfolding-keeness-factor</option></entry> <entry>Tweak unfolding settings</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry><option>-fno-unfolding-keeness-factor</option></entry> </row> <row> <entry><option>-funfolding-use-threshold</option></entry> <entry>Tweak unfolding settings</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry><option>-fno-unfolding-use-threshold</option></entry> </row> |