TupCon(..), tupleParens,
OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc,
- isDeadOcc, isLoopBreaker, isNoOcc,
+ isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch,
| IAmDead -- Marks unused variables. Sometimes useful for
-- lambda and case-bound variables.
- | OneOcc !InsideLam -- Occurs exactly once, not inside a rule
- !OneBranch
- !InterestingCxt
+ | OneOcc -- Occurs exactly once, not inside a rule
+ !InsideLam
+ !OneBranch
+ !InterestingCxt
| IAmALoopBreaker -- Used by the occurrence analyser to mark loop-breakers
-- in a group of recursive definitions
+ !Bool -- True <=> This loop breaker occurs only the RHS of a RULE
+\end{code}
+
+Note [RulesOnly]
+~~~~~~~~~~~~~~~~
+The RulesOnly constructor records if an Id occurs only in the RHS of a Rule.
+Similarly, the boolean in IAmLoopbreaker True if the only reason the Id is a
+loop-breaker only because of recursion through a RULE. In that case,
+we can ignore the loop-breaker-ness for inlining purposes. Example
+(from GHC.Enum):
+
+ eftInt :: Int# -> Int# -> [Int]
+ eftInt x y = ...(non-recursive)...
+
+ {-# INLINE [0] eftIntFB #-}
+ eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
+ eftIntFB c n x y = ...(non-recursive)...
+ {-# RULES
+ "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
+ "eftIntList" [1] eftIntFB (:) [] = eftInt
+ #-}
+
+The two look mutually recursive only because of their RULES;
+we don't want that to inhibit inlining!
+
+\begin{code}
isNoOcc :: OccInfo -> Bool
isNoOcc NoOccInfo = True
isNoOcc other = False
notOneBranch = False
isLoopBreaker :: OccInfo -> Bool
-isLoopBreaker IAmALoopBreaker = True
-isLoopBreaker other = False
+isLoopBreaker (IAmALoopBreaker _) = True
+isLoopBreaker other = False
+
+isNonRuleLoopBreaker :: OccInfo -> Bool
+isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle
+isNonRuleLoopBreaker other = False
isDeadOcc :: OccInfo -> Bool
isDeadOcc IAmDead = True
\begin{code}
instance Outputable OccInfo where
-- only used for debugging; never parsed. KSW 1999-07
- ppr NoOccInfo = empty
- ppr RulesOnly = ptext SLIT("RulesOnly")
- ppr IAmALoopBreaker = ptext SLIT("LoopBreaker")
- ppr IAmDead = ptext SLIT("Dead")
+ ppr NoOccInfo = empty
+ ppr RulesOnly = ptext SLIT("RulesOnly")
+ ppr (IAmALoopBreaker ro) = ptext SLIT("LoopBreaker") <> if ro then char '!' else empty
+ ppr IAmDead = ptext SLIT("Dead")
ppr (OneOcc inside_lam one_branch int_cxt)
= ptext SLIT("Once") <> pp_lam <> pp_br <> pp_args
where
yes_or_no
| not active_inline = False
| otherwise = case occ of
- IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False
- IAmALoopBreaker -> False
- --OneOcc in_lam _ _ -> (not in_lam || is_cheap) && consider_safe True
- other -> is_cheap && consider_safe False
- -- we consider even the once-in-one-branch
+ IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False
+ IAmALoopBreaker False -> False -- Note [RulesOnly] in BasicTypes
+ --OneOcc in_lam _ _ -> (not in_lam || is_cheap) && consider_safe True
+ other -> is_cheap && consider_safe False
+ -- We consider even the once-in-one-branch
-- occurrences, because they won't all have been
-- caught by preInlineUnconditionally. In particular,
-- if the occurrence is once inside a lambda, and the
import IdInfo {- loads of stuff -}
import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId )
import NewDemand ( isBottomingSig, topSig )
-import BasicTypes ( Arity, isNeverActive )
+import BasicTypes ( Arity, isNeverActive, isNonRuleLoopBreaker )
import Name ( Name, getOccName, nameOccName, mkInternalName,
localiseName, isExternalName, nameSrcLoc, nameParent_maybe,
isWiredInName, getName
idinfo = idInfo id
dont_inline = isNeverActive (inlinePragInfo idinfo)
- loop_breaker = isLoopBreaker (occInfo idinfo)
+ loop_breaker = isNonRuleLoopBreaker (occInfo idinfo)
bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
spec_ids = specInfoFreeVars (specInfo idinfo)
worker_info = workerInfo idinfo
import Digraph ( stronglyConnCompR, SCC(..) )
import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
import Unique ( Unique )
-import UniqFM ( keysUFM, lookupUFM_Directly )
+import UniqFM ( keysUFM )
import Util ( zipWithEqual, mapAndUnzip )
import Outputable
\end{code}
~~~~~~~~
\begin{code}
-type IdWithOccInfo = Id -- An Id with fresh PragmaInfo attached
-
-type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
- -- which is gotten from the Id.
-type Details1 = (Id, UsageDetails, CoreExpr)
-type Details2 = (IdWithOccInfo, CoreExpr)
-
-
occAnalBind :: OccEnv
-> CoreBind
-> UsageDetails -- Usage details of scope
details = [details | (details, _, _) <- cycle]
bndrs = [bndr | (bndr, _, _) <- details]
rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details]
- total_usage = foldr combineUsageDetails body_usage rhs_usages
+ rhs_usage = foldr1 combineUsageDetails rhs_usages
+ total_usage = rhs_usage `combineUsageDetails` body_usage
(combined_usage, tagged_bndrs) = tagBinders total_usage bndrs
- final_bind = Rec (doReorder edges)
+
+ new_cycle :: [Node Details2]
+ new_cycle = zipWithEqual "reorder" mk_node tagged_bndrs cycle
+ final_bind = Rec (reOrderCycle rhs_usage new_cycle)
+ mk_node tagged_bndr ((_, _, rhs'), key, keys) = ((tagged_bndr, rhs'), key, keys)
+
+{- An alternative; rebuild the edges. No semantic difference, but perf might change
-- Hopefully 'bndrs' is a relatively small group now
-- Now get ready for the loop-breaking phase, this time ignoring RulesOnly references
-- We've done dead-code elimination already, so no worries about un-referenced binders
- edges :: [Node Details2]
- edges = zipWithEqual "reorder" mk_edge tagged_bndrs details
keys = map idUnique bndrs
- mk_edge tagged_bndr (_, rhs_usage, rhs')
+ mk_node tagged_bndr (_, rhs_usage, rhs')
= ((tagged_bndr, rhs'), idUnique tagged_bndr, used)
where
used = [key | key <- keys, used_outside_rule rhs_usage key ]
Nothing -> False
Just RulesOnly -> False -- Ignore rules
other -> True
+-}
\end{code}
@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
strongly connected component (there's guaranteed to be a cycle). It returns the
same pairs, but
a) in a better order,
- b) with some of the Ids having a IMustNotBeINLINEd pragma
+ b) with some of the Ids having a IAmALoopBreaker pragma
-The "no-inline" Ids are sufficient to break all cycles in the SCC. This means
+The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
that the simplifier can guarantee not to loop provided it never records an inlining
for these no-inline guys.
Perhaps something cleverer would suffice.
===============
-You might think that you can prevent non-termination simply by making
-sure that we simplify a recursive binding's RHS in an environment that
-simply clones the recursive Id. But no. Consider
-
- letrec f = \x -> let z = f x' in ...
-
- in
- let n = f y
- in
- case n of { ... }
-
-We bind n to its *simplified* RHS, we then *re-simplify* it when
-we inline n. Then we may well inline f; and then the same thing
-happens with z!
-
-I don't think it's possible to prevent non-termination by environment
-manipulation in this way. Apart from anything else, successive
-iterations of the simplifier may unroll recursive loops in cases like
-that above. The idea of beaking every recursive loop with an
-IMustNotBeINLINEd pragma is much much better.
-
\begin{code}
-doReorder :: [Node Details2] -> [Details2]
--- Sorted into a plausible order. Enough of the Ids have
--- dontINLINE pragmas that there are no loops left.
-doReorder nodes = concatMap reOrderRec (stronglyConnCompR nodes)
-
-reOrderRec :: SCC (Node Details2) -> [Details2]
-
- -- Non-recursive case
-reOrderRec (AcyclicSCC (bind, _, _)) = [bind]
+type IdWithOccInfo = Id -- An Id with fresh PragmaInfo attached
- -- Common case of simple self-recursion
-reOrderRec (CyclicSCC [])
- = panic "reOrderRec"
+type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
+ -- which is gotten from the Id.
+type Details1 = (Id, UsageDetails, CoreExpr)
+type Details2 = (IdWithOccInfo, CoreExpr)
-reOrderRec (CyclicSCC [bind])
- = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
+reOrderRec :: UsageDetails -> SCC (Node Details2) -> [Details2]
+-- Sorted into a plausible order. Enough of the Ids have
+-- IAmALoopBreaker pragmas that there are no loops left.
+reOrderRec rhs_usg (AcyclicSCC (bind, _, _)) = [bind]
+reOrderRec rhs_usg (CyclicSCC cycle) = reOrderCycle rhs_usg cycle
+
+reOrderCycle :: UsageDetails -> [Node Details2] -> [Details2]
+reOrderCycle rhs_usg []
+ = panic "reOrderCycle"
+reOrderCycle rhs_usg [bind] -- Common case of simple self-recursion
+ = [(makeLoopBreaker rhs_usg tagged_bndr, rhs)]
where
((tagged_bndr, rhs), _, _) = bind
-reOrderRec (CyclicSCC (bind : binds))
+reOrderCycle rhs_usg (bind : binds)
= -- Choose a loop breaker, mark it no-inline,
-- do SCC analysis on the rest, and recursively sort them out
- doReorder unchosen ++
- [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
+ concatMap (reOrderRec rhs_usg) (stronglyConnCompR unchosen) ++
+ [(makeLoopBreaker rhs_usg tagged_bndr, rhs)]
where
(chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
-- But we won't because constructor args are marked "Many".
not_fun_ty ty = not (isFunTy (dropForAlls ty))
+
+makeLoopBreaker :: UsageDetails -> Id -> Id
+-- Set the loop-breaker flag, recording whether the thing occurs only in
+-- the RHS of a RULE (in this recursive group)
+makeLoopBreaker rhs_usg bndr
+ = setIdOccInfo bndr (IAmALoopBreaker rules_only)
+ where
+ rules_only = case lookupVarEnv rhs_usg bndr of
+ Just RulesOnly -> True
+ other -> False
\end{code}
@occAnalRhs@ deals with the question of bindings where the Id is marked
-> Bool
postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
| not active = False
- | isLoopBreaker occ_info = False
+ | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, dont' inline
+ -- because it might be referred to "earlier"
| isExportedId bndr = False
| exprIsTrivial rhs = True
| otherwise
idNewDemandInfo, setIdInfo,
setIdOccInfo, zapLamIdInfo, setOneShotLambda
)
-import IdInfo ( OccInfo(..), isLoopBreaker,
- setArityInfo, zapDemandInfo,
- setUnfoldingInfo,
- occInfo
+import IdInfo ( OccInfo(..), setArityInfo, zapDemandInfo,
+ setUnfoldingInfo, occInfo
)
import NewDemand ( isStrictDmd )
import TcGadt ( dataConCanMatch )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
- RecFlag(..), isNonRec
+ RecFlag(..), isNonRec, isNonRuleLoopBreaker
)
import OrdList
import List ( nub )
| otherwise
= let
- -- Add arity info
+ -- Arity info
new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
+ -- Unfolding info
-- Add the unfolding *only* for non-loop-breakers
-- Making loop breakers not have an unfolding at all
-- means that we can avoid tests in exprIsConApp, for example.
-- This is important: if exprIsConApp says 'yes' for a recursive
-- thing, then we can get into an infinite loop
+
+ -- Demand info
-- If the unfolding is a value, the demand info may
-- go pear-shaped, so we nuke it. Example:
-- let x = (a,b) in
returnSmpl (unitFloat env final_id new_rhs, env)
where
unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
- loop_breaker = isLoopBreaker occ_info
+ loop_breaker = isNonRuleLoopBreaker occ_info
old_info = idInfo old_bndr
occ_info = occInfo old_info
\end{code}
projects / ghc-hetmet.git / commitdiff