import CoreSyn
import CoreFVs ( idRuleVars )
import CoreUtils ( exprIsTrivial )
-import Id ( isDataConId, isOneShotLambda, setOneShotLambda,
+import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
idOccInfo, setIdOccInfo,
isExportedId, modifyIdInfo, idInfo, idArity,
idSpecialisation, isLocalId,
idType, idUnique, Id
)
-import IdInfo ( OccInfo(..), shortableIdInfo, copyIdInfo )
+import IdInfo ( copyIdInfo )
+import BasicTypes ( OccInfo(..), isOneOcc )
import VarSet
import VarEnv
-import Type ( splitFunTy_maybe, splitForAllTys )
-import Maybes ( maybeToBool, orElse )
+import Type ( isFunTy, dropForAlls )
+import Maybes ( orElse )
import Digraph ( stronglyConnCompR, SCC(..) )
import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
import Unique ( Unique )
import UniqFM ( keysUFM )
import Util ( zipWithEqual, mapAndUnzip )
-import FastTypes
import Outputable
\end{code}
not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
then
+ True
+
+{- No longer needed
if shortableIdInfo (idInfo exported_id) -- Only if its IdInfo is 'shortable'
-- (see the defn of IdInfo.shortableIdInfo)
then True
pprTrace "shortMeOut:" (ppr exported_id)
#endif
False
+-}
else
False
\end{code}
where
(final_body_usage, tagged_binder) = tagBinder body_usage binder
- (rhs_usage, rhs') = occAnalRhs env binder rhs
+ (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
\end{code}
Dropping dead code for recursive bindings is done in a very simple way:
inlineCandidate :: Id -> CoreExpr -> Bool
inlineCandidate id (Note InlineMe _) = True
- inlineCandidate id rhs = case idOccInfo id of
- OneOcc _ _ -> True
- other -> False
+ inlineCandidate id rhs = isOneOcc (idOccInfo id)
-- Real example (the Enum Ordering instance from PrelBase):
-- rec f = \ x -> case d of (p,q,r) -> p x
-- we didn't stupidly choose d as the loop breaker.
-- But we won't because constructor args are marked "Many".
- not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty))
- where
- (_, rho_ty) = splitForAllTys ty
+ not_fun_ty ty = not (isFunTy (dropForAlls ty))
\end{code}
@occAnalRhs@ deals with the question of bindings where the Id is marked
\begin{code}
occAnalRhs :: OccEnv
-> Id -> CoreExpr -- Binder and rhs
+ -- For non-recs the binder is alrady tagged
+ -- with occurrence info
-> (UsageDetails, CoreExpr)
occAnalRhs env id rhs
= (final_usage, rhs')
where
- (rhs_usage, rhs') = occAnal (rhsCtxt env) rhs
+ (rhs_usage, rhs') = occAnal ctxt rhs
+ ctxt | certainly_inline id = env
+ | otherwise = rhsCtxt env
+ -- Note that we generally use an rhsCtxt. This tells the occ anal n
+ -- that it's looking at an RHS, which has an effect in occAnalApp
+ --
+ -- But there's a problem. Consider
+ -- x1 = a0 : []
+ -- x2 = a1 : x1
+ -- x3 = a2 : x2
+ -- g = f x3
+ -- First time round, it looks as if x1 and x2 occur as an arg of a
+ -- let-bound constructor ==> give them a many-occurrence.
+ -- But then x3 is inlined (unconditionally as it happens) and
+ -- next time round, x2 will be, and the next time round x1 will be
+ -- Result: multiple simplifier iterations. Sigh.
+ -- Crude solution: use rhsCtxt for things that occur just once...
+
+ certainly_inline id = case idOccInfo id of
+ OneOcc in_lam one_br -> not in_lam && one_br
+ other -> False
-- [March 98] A new wrinkle is that if the binder has specialisations inside
-- it then we count the specialised Ids as "extra rhs's". That way
add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info
-- (i.e manyOcc) because many copies
-- of the specialised thing can appear
+
\end{code}
Expressions
(binders, body) = collectBinders expr
(linear, env1, _) = oneShotGroup env binders
env2 = env1 `addNewCands` binders -- Add in-scope binders
- env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext
+ env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext
-occAnal env (Case scrut bndr alts)
+occAnal env (Case scrut bndr ty alts)
= case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
- case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') ->
+ case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') ->
-- No need for rhsCtxt
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
(alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
total_usage = scrut_usage `combineUsageDetails` alts_usage1
in
- total_usage `seq` (total_usage, Case scrut' tagged_bndr alts') }}
+ total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
where
alt_env = env `addNewCand` bndr
occAnalApp env (Var fun, args) is_rhs
= case args_stuff of { (args_uds, args') ->
let
- final_uds = fun_uds `combineUsageDetails` args_uds
+ -- We mark the free vars of the argument of a constructor or PAP
+ -- as "many", if it is the RHS of a let(rec).
+ -- This means that nothing gets inlined into a constructor argument
+ -- position, which is what we want. Typically those constructor
+ -- arguments are just variables, or trivial expressions.
+ --
+ -- This is the *whole point* of the isRhsEnv predicate
+ final_args_uds
+ | isRhsEnv env,
+ isDataConWorkId fun || valArgCount args < idArity fun
+ = mapVarEnv markMany args_uds
+ | otherwise = args_uds
in
- (final_uds, mkApps (Var fun) args') }
+ (fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') }
where
fun_uniq = idUnique fun
-- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
-- by floating in the v
- | isRhsEnv env,
- isDataConId fun || valArgCount args < idArity fun
- = case occAnalArgs env args of
- (arg_uds, args') -> (mapVarEnv markMany arg_uds, args')
- -- We mark the free vars of the argument of a constructor or PAP
- -- as "many", if it is the RHS of a let(rec).
- -- This means that nothing gets inlined into a constructor argument
- -- position, which is what we want. Typically those constructor
- -- arguments are just variables, or trivial expressions.
-
| otherwise = occAnalArgs env args
addNewCands :: OccEnv -> [Id] -> OccEnv
addNewCands (OccEnv cands encl ctxt) ids
- = OccEnv (cands `unionVarSet` mkVarSet ids) encl ctxt
+ = OccEnv (extendVarSetList cands ids) encl ctxt
addNewCand :: OccEnv -> Id -> OccEnv
addNewCand (OccEnv cands encl ctxt) id
= case go ctxt bndrs [] of
(new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv cands encl new_ctxt, new_bndrs)
where
- is_one_shot b = isId b && isOneShotLambda b
+ is_one_shot b = isId b && isOneShotBndr b
go ctxt [] rev_bndrs = (ctxt, reverse rev_bndrs)
projects / ghc-hetmet.git / blobdiff