Skip to content

GitLab

Commit 0a768bcb authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

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.
parent 9c6223dd
Hide whitespace changes
Inline Side-by-side
compiler/basicTypes/MkId.lhs
View file @ 0a768bcb
......@@ -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
......
compiler/coreSyn/CoreUnfold.lhs
View file @ 0a768bcb
......@@ -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)
......
compiler/deSugar/DsBinds.lhs
View file @ 0a768bcb
......@@ -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))
......
compiler/iface/BuildTyCl.lhs
View file @ 0a768bcb
......@@ -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]
......
compiler/iface/TcIface.lhs
View file @ 0a768bcb
......@@ -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
......
compiler/main/CmdLineParser.hs
View file @ 0a768bcb
......@@ -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
......
compiler/main/DynFlags.hs
View file @ 0a768bcb
......@@ -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))
......
compiler/main/StaticFlagParser.hs
View file @ 0a768bcb
......@@ -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"
]
-----------------------------------------------------------------------------
......
compiler/main/StaticFlags.hs
View file @ 0a768bcb
......@@ -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