Make the opt_UF_* static flags dynamic
authorIan Lynagh <ian@well-typed.com>
Mon, 8 Oct 2012 23:27:28 +0000 (00:27 +0100)
committerIan Lynagh <ian@well-typed.com>
Tue, 9 Oct 2012 11:32:04 +0000 (12:32 +0100)
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.

17 files changed:
compiler/basicTypes/MkId.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/deSugar/DsBinds.lhs
compiler/iface/BuildTyCl.lhs
compiler/iface/TcIface.lhs
compiler/main/CmdLineParser.hs
compiler/main/DynFlags.hs
compiler/main/StaticFlagParser.hs
compiler/main/StaticFlags.hs
compiler/main/TidyPgm.lhs
compiler/simplCore/LiberateCase.lhs
compiler/simplCore/SimplUtils.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/SpecConstr.lhs
compiler/specialise/Specialise.lhs
compiler/stranal/WorkWrap.lhs
docs/users_guide/flags.xml

index 24c40cc..15f971a 100644 (file)
@@ -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
index 4153696..7ed5d2b 100644 (file)
@@ -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)
index 95d36f3..1e3eb2d 100644 (file)
@@ -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))
index 5f5e8a1..be757c6 100644 (file)
@@ -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]
index b9783a8..1efb11e 100644 (file)
@@ -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
index f87039a..b6618af 100644 (file)
@@ -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
index 785a676..feaa3b5 100644 (file)
@@ -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))
index 9c98836..e1def67 100644 (file)
@@ -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"
      ]
 
 -----------------------------------------------------------------------------
index 598ea00..4414f6b 100644 (file)
@@ -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
 
index 309f2e2..ebb8f48 100644 (file)
@@ -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
index 35bfb5f..9f83043 100644 (file)
@@ -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}
 
index 87aefba..a5ed397 100644 (file)
@@ -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
index f76fec1..df30142 100644 (file)
@@ -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'
index 7661878..b2f83de 100644 (file)
@@ -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
index 083d150..04ef404 100644 (file)
@@ -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*
index e5013de..5be63a9 100644 (file)
@@ -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
index a122e5a..26c4464 100644 (file)
           <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>