summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIan Lynagh <ian@well-typed.com>2012-10-09 00:27:28 +0100
committerIan Lynagh <ian@well-typed.com>2012-10-09 12:32:04 +0100
commit0a768bcbe6f7238d0bcdddd85fe24c99189453a0 (patch)
treea1e75804cc73c1f88fb3deae9fa7aaf0aaa75753
parent9c6223dd780b5a41be98702a583a1b7229841305 (diff)
downloadhaskell-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.lhs7
-rw-r--r--compiler/coreSyn/CoreUnfold.lhs120
-rw-r--r--compiler/deSugar/DsBinds.lhs28
-rw-r--r--compiler/iface/BuildTyCl.lhs10
-rw-r--r--compiler/iface/TcIface.lhs5
-rw-r--r--compiler/main/CmdLineParser.hs10
-rw-r--r--compiler/main/DynFlags.hs33
-rw-r--r--compiler/main/StaticFlagParser.hs7
-rw-r--r--compiler/main/StaticFlags.hs36
-rw-r--r--compiler/main/TidyPgm.lhs17
-rw-r--r--compiler/simplCore/LiberateCase.lhs13
-rw-r--r--compiler/simplCore/SimplUtils.lhs6
-rw-r--r--compiler/simplCore/Simplify.lhs22
-rw-r--r--compiler/specialise/SpecConstr.lhs2
-rw-r--r--compiler/specialise/Specialise.lhs26
-rw-r--r--compiler/stranal/WorkWrap.lhs10
-rw-r--r--docs/users_guide/flags.xml8
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>