diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index c94e81b39f2f57ddb23b5c88451f676fff11436a..502a904913ea64be47074d79a9708395a8f19db5 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -45,6 +45,7 @@ module IdInfo (
-- Inline prags
InlinePragInfo(..),
inlinePragInfo, setInlinePragInfo, pprInlinePragInfo,
+ isNeverInlinePrag, neverInlinePrag,
-- Occurrence info
OccInfo(..), isFragileOccInfo,
@@ -324,6 +325,16 @@ data InlinePragInfo
(Maybe Int) -- Phase number from pragma, if any
-- The True, Nothing case doesn't need to be recorded
+ -- SEE COMMENTS WITH CoreUnfold.blackListed on the
+ -- exact significance of the IMustNotBeINLINEd pragma
+
+isNeverInlinePrag :: InlinePragInfo -> Bool
+isNeverInlinePrag (IMustNotBeINLINEd True Nothing) = True
+isNeverInlinePrag other = False
+
+neverInlinePrag :: InlinePragInfo
+neverInlinePrag = IMustNotBeINLINEd True Nothing
+
instance Outputable InlinePragInfo where
-- This is now parsed in interface files
ppr NoInlinePragInfo = empty
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 774877898ab28b2300b30b3e9e3a8a34cecefd4d..7276e3480d4fc6412fd8041d3951c892d63a9297 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -54,7 +54,9 @@ import VarSet
import Name ( isLocallyDefined )
import Literal ( isLitLitLit )
import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
-import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), insideLam, workerExists )
+import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..),
+ insideLam, workerExists, isNeverInlinePrag
+ )
import TyCon ( tyConFamilySize )
import Type ( splitFunTy_maybe, isUnLiftedType )
import Unique ( Unique, buildIdKey, augmentIdKey )
@@ -435,16 +437,11 @@ certainlyWillInline :: Id -> Bool
certainlyWillInline v
= case idUnfolding v of
- CoreUnfolding _ _ _ is_value _ (UnfoldIfGoodArgs n_vals _ size _)
+ CoreUnfolding _ _ _ is_value _ g@(UnfoldIfGoodArgs n_vals _ size _)
-> is_value
&& size - (n_vals +1) <= opt_UF_UseThreshold
- && not never_inline
other -> False
- where
- never_inline = case idInlinePragma v of
- IMustNotBeINLINEd False Nothing -> True
- other -> False
\end{code}
@okToUnfoldInHifile@ is used when emitting unfolding info into an interface
@@ -673,7 +670,7 @@ For optimisation we use phase 1,2 and nothing (i.e. no -finline-phase flag)
in that order. The meanings of these are determined by the @blackListed@ function
here.
-The final simplification doesn't have a phase number
+The final simplification doesn't have a phase number.
Pragmas
~~~~~~~
@@ -696,9 +693,7 @@ blackListed :: IdSet -- Used in transformation rules
-- place that the inline phase number is looked at.
blackListed rule_vars Nothing -- Last phase
- = \v -> case idInlinePragma v of
- IMustNotBeINLINEd False Nothing -> True -- An unconditional NOINLINE pragma
- other -> False
+ = \v -> isNeverInlinePrag (idInlinePragma v)
blackListed rule_vars (Just phase)
= \v -> normal_case rule_vars phase v
@@ -712,8 +707,8 @@ normal_case rule_vars phase v
| otherwise -> True -- Always blacklisted
IMustNotBeINLINEd from_inline (Just threshold)
- | from_inline -> phase < threshold && has_rules
- | otherwise -> phase < threshold || has_rules
+ | from_inline -> (phase < threshold && has_rules)
+ | otherwise -> (phase < threshold || has_rules)
where
has_rules = v `elemVarSet` rule_vars
|| not (isEmptyCoreRules (idSpecialisation v))
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 6ed5e4c8b5f7992f5ef8d62dded68023994d0f06..50ebde38374d69c6b10e22ef639d196ce0344f62 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -34,7 +34,7 @@ import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inli
strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
cafInfo, ppCafInfo, specInfo,
cprInfo, ppCprInfo, pprInlinePragInfo,
- occInfo,
+ occInfo, isNeverInlinePrag,
workerExists, workerInfo, ppWorkerInfo, WorkerInfo(..)
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
@@ -372,10 +372,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs
------------ Unfolding --------------
inline_pragma = inlinePragInfo core_idinfo
- dont_inline = case inline_pragma of
- IMustNotBeINLINEd False Nothing -> True -- Unconditional NOINLINE
- other -> False
-
+ dont_inline = isNeverInlinePrag inline_pragma
unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs
| otherwise = empty
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index f6ccf6a39ca1c0666caa4e3491de18d74fe3bca4..92bb34c85081d3b79aa5c21d5e69e0f8b8f4f2e2 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -985,9 +985,9 @@ postInlineUnconditionally :: Bool -- Black listed
-- we'll get another opportunity when we get to the ocurrence(s)
postInlineUnconditionally black_listed occ_info bndr rhs
- | isExportedId bndr ||
- black_listed ||
- isLoopBreaker occ_info = False -- Don't inline these
+ | isExportedId bndr = False -- Don't inline these, ever
+ | black_listed = False
+ | isLoopBreaker occ_info = False
| otherwise = exprIsTrivial rhs -- Duplicating is free
-- Don't inline even WHNFs inside lambdas; doing so may
-- simply increase allocation when the function is called
diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index 3e83e2218cd2fc8fbcfc4a9d9fc4eaaf48272cc0..032176a6e1dd116a7f865383e7dcff3684c8e709 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -17,7 +17,7 @@ import Id ( idType, setIdStrictness, setInlinePragma,
idDemandInfo, setIdDemandInfo, isBottomingId,
Id
)
-import IdInfo ( InlinePragInfo(..) )
+import IdInfo ( neverInlinePrag )
import CoreLint ( beginPass, endPass )
import ErrUtils ( dumpIfSet )
import SaAbsInt
@@ -186,12 +186,12 @@ saTopBind str_env abs_env (Rec pairs)
in
returnSa (new_str_env, new_abs_env, Rec new_pairs)
+-- Hack alert!
-- Top level divergent bindings are marked NOINLINE
-- This avoids fruitless inlining of top level error functions
addStrictnessInfoToTopId str_val abs_val bndr
= if isBottomingId new_id then
- new_id `setInlinePragma` IMustNotBeINLINEd False Nothing
- -- This is a NOINLINE pragma
+ new_id `setInlinePragma` neverInlinePrag
else
new_id
where
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 92eaf088aa0cb9815fbfc9b4f5af3835e0a7347e..15736354b063dcb33d4010cad10f1d28934c27f3 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -23,7 +23,8 @@ import Id ( Id, idType, idStrictness, setIdArityInfo, isOneShotLambda,
import VarSet
import Type ( Type, isNewType, splitForAllTys, splitFunTys )
import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
- CprInfo(..), exactArity, InlinePragInfo(..), WorkerInfo(..)
+ CprInfo(..), exactArity, InlinePragInfo(..), isNeverInlinePrag,
+ WorkerInfo(..)
)
import Demand ( Demand, wwLazy )
import SaLib
@@ -189,8 +190,11 @@ tryWW :: Bool -- True <=> a non-recursive binding
-- if two, then a worker and a
-- wrapper.
tryWW non_rec fn_id rhs
- | non_rec
- && certainlyWillInline fn_id
+ | not (isNeverInlinePrag inline_prag)
+ = -- Don't split things that will never be inlined
+ returnUs [ (fn_id, rhs) ]
+
+ | non_rec && certainlyWillInline fn_id
-- No point in worker/wrappering something that is going to be
-- INLINEd wholesale anyway. If the strictness analyser is run
-- twice, this test also prevents wrappers (which are INLINEd)