SimplSR(..), mkContEx, substId, lookupRecBndr,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
- simplBinder, simplBinders, addLetIdInfo,
- substExpr, substTy,
+ simplBinder, simplBinders, addBndrRules,
+ substExpr, substWorker, substTy,
-- Floats
Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
(env', id1) = substIdBndr env bndr
id2 = id1 `setIdUnfolding` substUnfolding env old_unf
---------------
-substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
- -> (SimplEnv, Id) -- Transformed pair
-
--- Returns with:
--- * Unique changed if necessary
--- * Type substituted
--- * Unfolding zapped
--- * Rules, worker, lbvar info all substituted
--- * Fragile occurrence info zapped
--- * The in-scope set extended with the returned Id
--- * The substitution extended with a DoneId if unique changed
--- In this case, the var in the DoneId is the same as the
--- var returned
---
--- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs
-
-substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
- old_id
- = (env { seInScope = in_scope `extendInScopeSet` new_id,
- seIdSubst = new_subst }, new_id)
- where
- -- id1 is cloned if necessary
- id1 = uniqAway in_scope old_id
-
- -- id2 has its type zapped
- id2 = substIdType env id1
-
- -- new_id has the final IdInfo
- subst = mkCoreSubst env
- new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
-
- -- Extend the substitution if the unique has changed
- -- See the notes with substTyVarBndr for the delSubstEnv
- -- Also see Note [Extending the Subst] in CoreSubst
- new_subst | new_id /= old_id
- = extendVarEnv id_subst old_id (DoneId new_id)
- | otherwise
- = delVarEnv id_subst old_id
-\end{code}
-
-\begin{code}
-------------------------------------
-seqTyVar :: TyVar -> ()
-seqTyVar b = b `seq` ()
-
-seqId :: Id -> ()
-seqId id = seqType (idType id) `seq`
- idInfo id `seq`
- ()
-
-seqIds :: [Id] -> ()
-seqIds [] = ()
-seqIds (id:ids) = seqId id `seq` seqIds ids
-\end{code}
-
-%************************************************************************
-%* *
- Let bindings
-%* *
-%************************************************************************
-
-Simplifying let binders
-~~~~~~~~~~~~~~~~~~~~~~~
-Rename the binders if necessary,
-
-\begin{code}
+---------------
simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
+-- A non-recursive let binder
simplNonRecBndr env id
- = do { let (env1, id1) = substLetIdBndr env id
+ = do { let (env1, id1) = substIdBndr env id
; seqId id1 `seq` return (env1, id1) }
---------------
simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
+-- Recursive let binders
simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
- = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
+ = do { let (env1, ids1) = mapAccumL substIdBndr env ids
; seqIds ids1 `seq` return env1 }
---------------
-substLetIdBndr :: SimplEnv
- -> InBndr -- Env and binder to transform
- -> (SimplEnv, OutBndr)
--- C.f. substIdBndr above
+substIdBndr :: SimplEnv
+ -> InBndr -- Env and binder to transform
+ -> (SimplEnv, OutBndr)
-- Clone Id if necessary, substitute its type
-- Return an Id with its
--- UnfoldingInfo zapped
--- Rules, etc, substitutd with rec_subst
--- Robust info, retained especially arity and demand info,
+-- * Type substituted
+-- * UnfoldingInfo, Rules, WorkerInfo zapped
+-- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
+-- * Robust info, retained especially arity and demand info,
-- so that they are available to occurrences that occur in an
-- earlier binding of a letrec
--- Augment the subtitution if the unique changed
+--
+-- For the robust info, see Note [Arity robustness]
+--
+-- Augment the substitution if the unique changed
+-- Extend the in-scope set with the new Id
+--
+-- Similar to CoreSubst.substIdBndr, except that
+-- the type of id_subst differs
+-- all fragile info is zapped
-substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
+substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
old_id
= (env { seInScope = in_scope `extendInScopeSet` new_id,
seIdSubst = new_subst }, new_id)
where
id1 = uniqAway in_scope old_id
id2 = substIdType env id1
- new_id = zapFragileIdInfo id2
+ new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
+ -- and fragile OccInfo
-- Extend the substitution if the unique has changed,
-- or there's some useful occurrence information
= delVarEnv id_subst old_id
\end{code}
-Note [Add IdInfo back onto a let-bound Id]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must transfer the IdInfo of the original binder to the new binder.
-This is crucial, to preserve
- strictness
- rules
- worker info
-etc. To do this we must apply the current substitution,
-which incorporates earlier substitutions in this very letrec group.
-
-NB 1. We do this *before* processing the RHS of the binder, so that
-its substituted rules are visible in its own RHS.
-This is important. Manuel found cases where he really, really
-wanted a RULE for a recursive function to apply in that function's
-own right-hand side.
-
-NB 2: ARITY. We *do* transfer the arity. This is important, so that
-the arity of an Id is visible in its own RHS. For example:
+\begin{code}
+------------------------------------
+seqTyVar :: TyVar -> ()
+seqTyVar b = b `seq` ()
+
+seqId :: Id -> ()
+seqId id = seqType (idType id) `seq`
+ idInfo id `seq`
+ ()
+
+seqIds :: [Id] -> ()
+seqIds [] = ()
+seqIds (id:ids) = seqId id `seq` seqIds ids
+\end{code}
+
+
+Note [Arity robustness]
+~~~~~~~~~~~~~~~~~~~~~~~
+We *do* transfer the arity from from the in_id of a let binding to the
+out_id. This is important, so that the arity of an Id is visible in
+its own RHS. For example:
f = \x. ....g (\y. f y)....
We can eta-reduce the arg to g, becuase f is a value. But that
needs to be visible.
never decreases; its arity started as 1, and we should never eta-reduce
below that.
-NB 3: OccInfo. It's important that we *do* transer the loop-breaker
-OccInfo, because that's what stops the Id getting inlined infinitely,
-in the body of the letrec.
-NB 4: does no harm for non-recursive bindings
+Note [Robust OccInfo]
+~~~~~~~~~~~~~~~~~~~~~
+It's important that we *do* retain the loop-breaker OccInfo, because
+that's what stops the Id getting inlined infinitely, in the body of
+the letrec.
+
+
+Note [Rules in a letrec]
+~~~~~~~~~~~~~~~~~~~~~~~~
+After creating fresh binders for the binders of a letrec, we
+substitute the RULES and add them back onto the binders; this is done
+*before* processing any of the RHSs. This is important. Manuel found
+cases where he really, really wanted a RULE for a recursive function
+to apply in that function's own right-hand side.
+
+See Note [Loop breaking and RULES] in OccAnal.
-NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
- rec { f = g
- h = ...
- RULE h Int = f
- }
-Here, we'll do postInlineUnconditionally on f, and we must "see" that
-when substituting in h's RULE.
\begin{code}
-addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
-addLetIdInfo env in_id out_id
- = case substIdInfo subst (idInfo in_id) of
- Nothing -> (env, out_id)
- Just new_info -> (modifyInScope env out_id final_id, final_id)
- where
- final_id = out_id `setIdInfo` new_info
- where
- subst = mkCoreSubst env
-
-substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
--- Substitute the
--- rules
--- worker info
--- Zap the unfolding
--- Keep only 'robust' OccInfo
--- arity
---
--- Seq'ing on the returned IdInfo is enough to cause all the
--- substitutions to happen completely
-
-substIdInfo subst info
- | nothing_to_do = Nothing
- | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
- `setSpecInfo` CoreSubst.substSpec subst old_rules
- `setWorkerInfo` CoreSubst.substWorker subst old_wrkr
- `setUnfoldingInfo` noUnfolding)
- -- setSpecInfo does a seq
- -- setWorkerInfo does a seq
+addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
+-- Rules are added back in to to hte bin
+addBndrRules env in_id out_id
+ | isEmptySpecInfo old_rules = (env, out_id)
+ | otherwise = (modifyInScope env out_id final_id, final_id)
where
- nothing_to_do = keep_occ &&
- isEmptySpecInfo old_rules &&
- not (workerExists old_wrkr) &&
- not (hasUnfolding (unfoldingInfo info))
-
- keep_occ = not (isFragileOcc old_occ)
- old_occ = occInfo info
- old_rules = specInfo info
- old_wrkr = workerInfo info
+ subst = mkCoreSubst env
+ old_rules = idSpecialisation in_id
+ new_rules = CoreSubst.substSpec subst old_rules
+ final_id = out_id `setIdSpecialisation` new_rules
------------------
substIdType :: SimplEnv -> Id -> Id
old_ty = idType id
------------------
+substUnfolding :: SimplEnv -> Unfolding -> Unfolding
substUnfolding env NoUnfolding = NoUnfolding
substUnfolding env (OtherCon cons) = OtherCon cons
substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs)
substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
+
+------------------
+substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo
+substWorker env NoWorker = NoWorker
+substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info
\end{code}
simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
where
- (env', b') = addLetIdInfo env b (lookupRecBndr env b)
+ (env', b') = addBndrRules env b (lookupRecBndr env b)
\end{code}
-> [(InId, InExpr)]
-> SimplM SimplEnv
simplRecBind env top_lvl pairs
- = do { let (env_with_info, triples) = mapAccumL add_info env pairs
+ = do { let (env_with_info, triples) = mapAccumL add_rules env pairs
; env' <- go (zapFloats env_with_info) triples
; return (env `addRecFloats` env') }
-- addFloats adds the floats from env',
-- *and* updates env with the in-scope set from env'
where
- add_info :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
- -- Substitute in IdInfo, agument envt
- add_info env (bndr, rhs) = (env, (bndr, bndr', rhs))
+ add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
+ -- Add the (substituted) rules to the binder
+ add_rules env (bndr, rhs) = (env, (bndr, bndr', rhs))
where
- (env', bndr') = addLetIdInfo env bndr (lookupRecBndr env bndr)
+ (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
go env [] = return env
-- (for example) be no longer strictly demanded.
-- The solution here is a bit ad hoc...
info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
+ `setWorkerInfo` worker_info
+
final_info | loop_breaker = new_bndr_info
| isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
| otherwise = info_w_unf
return (addNonRec env final_id new_rhs)
where
unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+ worker_info = substWorker env (workerInfo old_info)
loop_breaker = isNonRuleLoopBreaker occ_info
old_info = idInfo old_bndr
occ_info = occInfo old_info
| otherwise
= do { (env1, bndr1) <- simplNonRecBndr env bndr
- ; let (env2, bndr2) = addLetIdInfo env1 bndr bndr1
+ ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
; simplLam env3 bndrs body cont }
\end{code}
projects / ghc-hetmet.git / commitdiff