Commit 6a944ae7 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Implement -fexpose-all-unfoldings, and fix a non-termination bug

The -fexpose-all-unfoldings flag arranges to put unfoldings for *everything*
in the interface file.  Of course,  this makes the file a lot bigger, but
it also makes it complete, and that's great for supercompilation; or indeed
any whole-program work.

Consequences:
  * Interface files need to record loop-breaker-hood.  (Previously,
    loop breakers were never exposed, so that info wasn't necessary.)
    Hence a small interface file format change. 

  * When inlining, must check loop-breaker-hood. (Previously, loop
    breakers didn't have an unfolding at all, so no need to check.)

  * Ditto in exprIsConApp_maybe.  Roman actually tripped this bug, 
    because a DFun, which had an unfolding, was also a loop breaker

  * TidyPgm.tidyIdInfo must be careful to preserve loop-breaker-hood

So Id.idUnfolding checks for loop-breaker-hood and returns NoUnfolding
if so. When you want the unfolding regardless of loop-breaker-hood, 
use Id.realIdUnfolding.

I have not documented the flag yet, because it's experimental.  Nor
have I tested it thoroughly.  But with the flag off (the normal case)
everything should work.
parent c93e8323
......@@ -42,8 +42,9 @@ module BasicTypes(
TupCon(..), tupleParens,
OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc,
OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc,
nonRuleLoopBreaker,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch,
......@@ -476,17 +477,20 @@ isNonRuleLoopBreaker :: OccInfo -> Bool
isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle
isNonRuleLoopBreaker _ = False
nonRuleLoopBreaker :: OccInfo
nonRuleLoopBreaker = IAmALoopBreaker False
isDeadOcc :: OccInfo -> Bool
isDeadOcc IAmDead = True
isDeadOcc _ = False
isOneOcc :: OccInfo -> Bool
isOneOcc (OneOcc _ _ _) = True
isOneOcc _ = False
isOneOcc (OneOcc {}) = True
isOneOcc _ = False
isFragileOcc :: OccInfo -> Bool
isFragileOcc (OneOcc _ _ _) = True
isFragileOcc _ = False
zapFragileOcc :: OccInfo -> OccInfo
zapFragileOcc (OneOcc {}) = NoOccInfo
zapFragileOcc occ = occ
\end{code}
\begin{code}
......
......@@ -69,7 +69,7 @@ module Id (
idArity,
idNewDemandInfo, idNewDemandInfo_maybe,
idNewStrictness, idNewStrictness_maybe,
idUnfolding,
idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo,
idLBVarInfo,
......@@ -99,7 +99,7 @@ module Id (
#include "HsVersions.h"
import CoreSyn ( CoreRule, Unfolding )
import CoreSyn ( CoreRule, Unfolding( NoUnfolding ) )
import IdInfo
import BasicTypes
......@@ -510,7 +510,16 @@ isStrictId id
---------------------------------
-- UNFOLDING
idUnfolding :: Id -> Unfolding
idUnfolding id = unfoldingInfo (idInfo id)
-- Do not expose the unfolding of a loop breaker!
idUnfolding id
| isNonRuleLoopBreaker (occInfo info) = NoUnfolding
| otherwise = unfoldingInfo info
where
info = idInfo id
realIdUnfolding :: Id -> Unfolding
-- Expose the unfolding if there is one, including for loop breakers
realIdUnfolding id = unfoldingInfo (idInfo id)
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
......
......@@ -58,7 +58,7 @@ module IdInfo (
-- ** The OccInfo type
OccInfo(..),
isFragileOcc, isDeadOcc, isLoopBreaker,
isDeadOcc, isLoopBreaker,
occInfo, setOccInfo,
InsideLam, OneBranch,
......@@ -723,7 +723,7 @@ zapFragileInfo :: IdInfo -> Maybe IdInfo
zapFragileInfo info
= Just (info `setSpecInfo` emptySpecInfo
`setUnfoldingInfo` noUnfolding
`setOccInfo` if isFragileOcc occ then NoOccInfo else occ)
`setOccInfo` zapFragileOcc occ)
where
occ = occInfo info
\end{code}
......
......@@ -416,8 +416,11 @@ idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars)
idUnfoldingVars :: Id -> VarSet
-- Produce free vars for an unfolding, but NOT for an ordinary
-- (non-inline) unfolding, since it is a dup of the rhs
-- and we'll get exponential behaviour if we look at both unf and rhs!
-- But do look at the *real* unfolding, even for loop breakers, else
-- we might get out-of-scope variables
idUnfoldingVars id
= case idUnfolding id of
= case realIdUnfolding id of
CoreUnfolding { uf_tmpl = rhs, uf_guidance = InlineRule {} }
-> exprFreeVars rhs
DFunUnfolding _ args -> exprsFreeVars args
......
......@@ -633,10 +633,7 @@ instance Outputable CallCtxt where
ppr ValAppCtxt = ptext (sLit "ValAppCtxt")
callSiteInline dflags active_inline id lone_variable arg_infos cont_info
= let
n_val_args = length arg_infos
in
case idUnfolding id of {
= case idUnfolding id of {
NoUnfolding -> Nothing ;
OtherCon _ -> Nothing ;
DFunUnfolding {} -> Nothing ; -- Never unfold a DFun
......@@ -645,6 +642,8 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
-- uf_arity will typically be equal to (idArity id),
-- but may be less for InlineRules
let
n_val_args = length arg_infos
result | yes_or_no = Just unf_template
| otherwise = Nothing
......@@ -1132,7 +1131,9 @@ exprIsConApp_maybe expr
analyse rhs args
where
is_saturated = count isValArg args == idArity fun
unfolding = idUnfolding fun
unfolding = idUnfolding fun -- Does not look through loop breakers
-- ToDo: we *may* look through variables that are NOINLINE
-- in this phase, and that is really not right
analyse _ _ = Nothing
......
......@@ -507,17 +507,20 @@ exprIsCheap' is_conlike (Note _ e) = exprIsCheap' is_conlike e
exprIsCheap' is_conlike (Cast e _) = exprIsCheap' is_conlike e
exprIsCheap' is_conlike (Lam x e) = isRuntimeVar x
|| exprIsCheap' is_conlike e
exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e &&
and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts]
and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
-- (and case __coerce x etc.)
-- This improves arities of overloaded functions where
-- there is only dictionary selection (no construction) involved
exprIsCheap' is_conlike (Let (NonRec x _) e)
| isUnLiftedType (idType x) = exprIsCheap' is_conlike e
| otherwise = False
-- strict lets always have cheap right hand sides,
-- and do no allocation.
-- Strict lets always have cheap right hand sides,
-- and do no allocation, so just look at the body
-- Non-strict lets do allocation so we don't treat them as cheap
exprIsCheap' is_conlike other_expr -- Applications and variables
= go other_expr []
......@@ -725,8 +728,9 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
|| idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
|| is_con_unf (idUnfolding v)
-- Check the thing's unfolding; it might be bound to a value
-- A worry: what if an Id's unfolding is just itself:
-- then we could get an infinite loop...
-- We don't look through loop breakers here, which is a bit conservative
-- but otherwise I worry that if an Id's unfolding is just itself,
-- we could get an infinite loop
is_hnf_like (Lit _) = True
is_hnf_like (Type _) = True -- Types are honorary Values;
......
......@@ -452,7 +452,7 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
| otherwise -> do
{ (spec_unf, unf_pairs) <- specUnfolding wrap_fn (idUnfolding poly_id)
{ (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
; let f_body = fix_up (Let mono_bind (Var mono_id))
spec_ty = exprType ds_spec_expr
......
......@@ -1161,8 +1161,9 @@ instance Binary IfaceInfoItem where
put_ bh (HsStrictness ab) = do
putByte bh 1
put_ bh ab
put_ bh (HsUnfold ad) = do
put_ bh (HsUnfold lb ad) = do
putByte bh 2
put_ bh lb
put_ bh ad
put_ bh (HsInline ad) = do
putByte bh 3
......@@ -1176,8 +1177,9 @@ instance Binary IfaceInfoItem where
return (HsArity aa)
1 -> do ab <- get bh
return (HsStrictness ab)
2 -> do ad <- get bh
return (HsUnfold ad)
2 -> do lb <- get bh
ad <- get bh
return (HsUnfold lb ad)
3 -> do ad <- get bh
return (HsInline ad)
_ -> do return HsNoCafRefs
......
......@@ -202,7 +202,8 @@ data IfaceInfoItem
= HsArity Arity
| HsStrictness StrictSig
| HsInline InlinePragma
| HsUnfold IfaceUnfolding
| HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true
IfaceUnfolding -- See Note [Expose recursive functions]
| HsNoCafRefs
-- NB: Specialisations and rules come in separately and are
......@@ -256,6 +257,13 @@ data IfaceBinding
data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo
\end{code}
Note [Expose recursive functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For supercompilation we want to put *all* unfoldings in the interface
file, even for functions that are recursive (or big). So we need to
know when an unfolding belongs to a loop-breaker so that we can refrain
from inlining it (except during supercompilation).
Note [IdInfo on nested let-bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Occasionally we want to preserve IdInfo on nested let bindings. The one
......@@ -660,7 +668,8 @@ instance Outputable IfaceIdInfo where
ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}")
instance Outputable IfaceInfoItem where
ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+> ppr unf
ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)"))
<> colon <+> ppr unf
ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag
ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity
ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
......@@ -786,8 +795,8 @@ freeNamesIfIdInfo NoInfo = emptyNameSet
freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
freeNamesItem :: IfaceInfoItem -> NameSet
freeNamesItem (HsUnfold u) = freeNamesIfUnfold u
freeNamesItem _ = emptyNameSet
freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
freeNamesItem _ = emptyNameSet
freeNamesIfUnfold :: IfaceUnfolding -> NameSet
freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e
......
......@@ -1471,7 +1471,8 @@ toIfaceIdInfo id_info
_other -> Nothing
------------ Unfolding --------------
unfold_hsinfo = toIfUnfolding (unfoldingInfo id_info)
unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
loop_breaker = isNonRuleLoopBreaker (occInfo id_info)
------------ Inline prag --------------
inline_prag = inlinePragInfo id_info
......@@ -1479,20 +1480,25 @@ toIfaceIdInfo id_info
| otherwise = Just (HsInline inline_prag)
--------------------------
toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem
toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
= case guidance of
InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w)))
InlineRule { ir_sat = InlSat } -> Just (HsUnfold (IfInlineRule arity True (toIfaceExpr rhs)))
InlineRule { ir_sat = InlUnSat } -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs)))
UnfoldNever -> Nothing
UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs)))
toIfUnfolding (DFunUnfolding _con ops)
= Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops)))
InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold lb (IfWrapper arity (idName w)))
InlineRule { ir_sat = InlSat } -> Just (HsUnfold lb (IfInlineRule arity True (toIfaceExpr rhs)))
InlineRule { ir_sat = InlUnSat } -> Just (HsUnfold lb (IfInlineRule arity False (toIfaceExpr rhs)))
UnfoldIfGoodArgs {} -> vanilla_unfold
UnfoldNever -> vanilla_unfold -- Yes, even if guidance is UnfoldNever, expose the unfolding
-- If we didn't want to expose the unfolding, TidyPgm would
-- have stuck in NoUnfolding. For supercompilation we want
-- to see that unfolding!
where
vanilla_unfold = Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs)))
toIfUnfolding lb (DFunUnfolding _con ops)
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
-- No need to serialise the data constructor;
-- we can recover it from the type of the dfun
toIfUnfolding _
toIfUnfolding _ _
= Nothing
--------------------------
......
......@@ -40,6 +40,7 @@ import DataCon
import TysWiredIn
import TysPrim ( anyTyConOfKind )
import Var ( TyVar )
import BasicTypes ( nonRuleLoopBreaker )
import qualified Var
import VarEnv
import Name
......@@ -993,8 +994,11 @@ tcIdInfo ignore_prags name ty info
tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
-- The next two are lazy, so they don't transitively suck stuff in
tcPrag info (HsUnfold if_unf) = do { unf <- tcUnfolding name ty info if_unf
; return (info `setUnfoldingInfoLazily` unf) }
tcPrag info (HsUnfold lb if_unf)
= do { unf <- tcUnfolding name ty info if_unf
; let info1 | lb = info `setOccInfo` nonRuleLoopBreaker
| otherwise = info
; return (info1 `setUnfoldingInfoLazily` unf) }
\end{code}
\begin{code}
......
......@@ -270,8 +270,6 @@ data DynFlag
| Opt_CSE
| Opt_LiberateCase
| Opt_SpecConstr
| Opt_IgnoreInterfacePragmas
| Opt_OmitInterfacePragmas
| Opt_DoLambdaEtaExpansion
| Opt_IgnoreAsserts
| Opt_DoEtaReduction
......@@ -284,6 +282,11 @@ data DynFlag
| Opt_RegsGraph -- do graph coloring register allocation
| Opt_RegsIterative -- do iterative coalescing graph coloring register allocation
-- Interface files
| Opt_IgnoreInterfacePragmas
| Opt_OmitInterfacePragmas
| Opt_ExposeAllUnfoldings
-- profiling opts
| Opt_AutoSccsOnAllToplevs
| Opt_AutoSccsOnExportedToplevs
......@@ -1728,6 +1731,7 @@ fFlags = [
( "cse", Opt_CSE, const Supported ),
( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas, const Supported ),
( "omit-interface-pragmas", Opt_OmitInterfacePragmas, const Supported ),
( "expose-all-unfoldings", Opt_ExposeAllUnfoldings, const Supported ),
( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion, const Supported ),
( "ignore-asserts", Opt_IgnoreAsserts, const Supported ),
( "do-eta-reduction", Opt_DoEtaReduction, const Supported ),
......
......@@ -298,6 +298,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
= do { let { dflags = hsc_dflags hsc_env
; omit_prags = dopt Opt_OmitInterfacePragmas dflags
; expose_all = dopt Opt_ExposeAllUnfoldings dflags
; th = dopt Opt_TemplateHaskell dflags
}
; showPass dflags "Tidy Core"
......@@ -305,7 +306,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
; let { implicit_binds = getImplicitBinds type_env }
; (unfold_env, tidy_occ_env)
<- chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_rules
<- chooseExternalIds hsc_env mod omit_prags expose_all
binds implicit_binds imp_rules
; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env }
-- See Note [Which rules to expose]
......@@ -353,7 +355,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
ModDetails { md_types = tidy_type_env,
md_rules = tidy_rules,
md_insts = tidy_insts,
md_vect_info = tidy_vect_info, md_fam_insts = fam_insts,
md_vect_info = tidy_vect_info,
md_fam_insts = fam_insts,
md_exports = exports,
md_anns = anns -- are already tidy
})
......@@ -550,7 +553,7 @@ getImplicitBinds type_env
implicit_ids _ = []
get_defn :: Id -> CoreBind
get_defn id = NonRec id (unfoldingTemplate (idUnfolding id))
get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
\end{code}
......@@ -572,14 +575,14 @@ type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-})
chooseExternalIds :: HscEnv
-> Module
-> Bool
-> Bool -> Bool
-> [CoreBind]
-> [CoreBind]
-> [CoreRule]
-> IO (UnfoldEnv, TidyOccEnv)
-- Step 1 from the notes above
chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules
chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules
= do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
; tidy_internal internal_ids unfold_env1 occ_env1 }
......@@ -650,7 +653,7 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules
let
(new_ids, show_unfold)
| omit_prags = ([], False)
| otherwise = addExternal refined_id
| otherwise = addExternal expose_all refined_id
-- 'idocc' is an *occurrence*, but we need to see the
-- unfolding in the *definition*; so look up in binder_set
......@@ -672,8 +675,8 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules
let unfold_env' = extendVarEnv unfold_env id (name',False)
tidy_internal ids unfold_env' occ_env'
addExternal :: Id -> ([Id],Bool)
addExternal id = (new_needed_ids, show_unfold)
addExternal :: Bool -> Id -> ([Id],Bool)
addExternal expose_all id = (new_needed_ids, show_unfold)
where
new_needed_ids = unfold_ids ++
filter (\id -> isLocalId id &&
......@@ -695,10 +698,12 @@ addExternal id = (new_needed_ids, show_unfold)
mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold
mb_unfold_ids = case unfoldingInfo idinfo of
CoreUnfolding { uf_tmpl = unf_rhs, uf_guidance = guide }
| not bottoming_fn -- Not necessary
, not dont_inline
, not loop_breaker
, not (neverUnfoldGuidance guide)
| expose_all || -- expose_all says to expose all
-- unfoldings willy-nilly
not (bottoming_fn -- No need to inline bottom functions
|| dont_inline -- Or ones that say not to
|| loop_breaker -- Or that are loop breakers
|| neverUnfoldGuidance guide)
-> Just (exprFvsInOrder unf_rhs)
DFunUnfolding _ ops -> Just (exprsFvsInOrder ops)
_ -> Nothing
......@@ -987,7 +992,8 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs)
idinfo = idInfo bndr
idinfo' = tidyTopIdInfo (isExternalName name')
idinfo unfold_info
arity caf_info
arity caf_info
(occInfo idinfo)
unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs1 (unfoldingInfo idinfo)
| otherwise = noUnfolding
......@@ -1027,19 +1033,21 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs)
-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
-- CoreToStg makes use of this when constructing SRTs.
tidyTopIdInfo :: Bool -> IdInfo -> Unfolding
-> ArityInfo -> CafInfo
-> ArityInfo -> CafInfo -> OccInfo
-> IdInfo
tidyTopIdInfo is_external idinfo unfold_info arity caf_info
tidyTopIdInfo is_external idinfo unfold_info arity caf_info occ_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;
-- c.f. CoreTidy.tidyLetBndr
`setOccInfo` robust_occ_info
`setCafInfo` caf_info
`setArityInfo` arity
`setAllStrictnessInfo` newStrictnessInfo idinfo
| otherwise -- Externally-visible Ids get the whole lot
= vanillaIdInfo
`setOccInfo` robust_occ_info
`setCafInfo` caf_info
`setArityInfo` arity
`setAllStrictnessInfo` newStrictnessInfo idinfo
......@@ -1047,6 +1055,10 @@ tidyTopIdInfo is_external idinfo unfold_info arity caf_info
`setUnfoldingInfo` unfold_info
-- NB: we throw away the Rules
-- They have already been extracted by findExternalRules
where
robust_occ_info = zapFragileOcc occ_info
-- It's important to keep loop-breaker information
-- when we are doing -fexpose-all-unfoldings
......
......@@ -21,7 +21,7 @@ module PrelRules ( primOpRules, builtinRules ) where
import CoreSyn
import MkCore ( mkWildCase )
import Id ( idUnfolding )
import Id ( realIdUnfolding )
import Literal ( Literal(..), mkMachInt, mkMachWord
, literalType
, word2IntLit, int2WordLit
......@@ -551,7 +551,7 @@ match_eq_string _ = Nothing
---------------------------------------------------
-- The rule is this:
-- inline f_ty (f a b c) = <f's unfolding> a b c
-- (if f has an unfolding)
-- (if f has an unfolding, EVEN if it's a loop breaker)
--
-- It's important to allow the argument to 'inline' to have args itself
-- (a) because its more forgiving to allow the programmer to write
......@@ -564,7 +564,7 @@ match_eq_string _ = Nothing
match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_inline (Type _ : e : _)
| (Var f, args1) <- collectArgs e,
Just unf <- maybeUnfoldingTemplate (idUnfolding f)
Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
= Just (mkApps unf args1)
match_inline _ = Nothing
......
......@@ -559,8 +559,9 @@ reOrderCycle depth (bind : binds) pairs
| isOneOcc (idOccInfo bndr) = 2 -- Likely to be inlined
| canUnfold (idUnfolding bndr) = 1
-- the Id has some kind of unfolding
| canUnfold (realIdUnfolding bndr) = 1
-- The Id has some kind of unfolding
-- Ignore loop-breaker-ness here because that is what we are setting!
| otherwise = 0
......
......@@ -35,8 +35,7 @@ import BasicTypes ( isMarkedStrict, Arity )
import CostCentre ( currentCCS, pushCCisNop )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRuleLoopBreaker )
import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
import MonadUtils ( foldlM, mapAccumLM )
import Maybes ( orElse )
import Data.List ( mapAccumL )
......@@ -680,11 +679,14 @@ simplUnfolding env top_lvl _ _ _
(guide { ir_info = mb_wkr' })) }
-- See Note [Top-level flag on inline rules] in CoreUnfold
simplUnfolding _ top_lvl _ occ_info new_rhs _
| omit_unfolding = return NoUnfolding
| otherwise = return (mkUnfolding (isTopLevel top_lvl) new_rhs)
where
omit_unfolding = isNonRuleLoopBreaker occ_info
simplUnfolding _ top_lvl _ _occ_info new_rhs _
= return (mkUnfolding (isTopLevel top_lvl) 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
-- expose the unfolding then indeed we *have* an unfolding
-- to expose. (We could instead use the RHS, but currently
-- we don't.) The simple thing is always to have one.
\end{code}
Note [Arity decrease]
......
......@@ -800,7 +800,7 @@ specDefn subst body_uds fn rhs
where
fn_type = idType fn
fn_arity = idArity fn
fn_unf = idUnfolding fn
fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here
(tyvars, theta, _) = tcSplitSigmaTy fn_type
n_tyvars = length tyvars
n_dicts = length theta
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment