-- ** Substituting into expressions and related types
deShadowBinds, substSpec, substRulesForImportedIds,
- substTy, substExpr, substBind, substUnfolding,
- substInlineRuleInfo, lookupIdSubst, lookupTvSubst, substIdOcc,
+ substTy, substExpr, substExprSC, substBind, substBindSC,
+ substUnfolding, substUnfoldingSC,
+ substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc,
-- ** Operations on substitutions
emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
import qualified Type
import Type ( Type, TvSubst(..), TvSubstEnv )
+import OptCoercion ( optCoercion )
import VarSet
import VarEnv
import Id
extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
-- | Find the substitution for an 'Id' in the 'Subst'
-lookupIdSubst :: Subst -> Id -> CoreExpr
-lookupIdSubst (Subst in_scope ids _) v
+lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
+lookupIdSubst doc (Subst in_scope ids _) v
| not (isLocalId v) = Var v
| Just e <- lookupVarEnv ids v = e
| Just v' <- lookupInScope in_scope v = Var v'
-- Vital! See Note [Extending the Subst]
- | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope )
+ | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope $$ doc)
Var v
-- | Find the substitution for a 'TyVar' in the 'Subst'
--
-- Do *not* attempt to short-cut in the case of an empty substitution!
-- See Note [Extending the Subst]
-substExpr :: Subst -> CoreExpr -> CoreExpr
-substExpr subst expr
+substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr
+substExprSC _doc subst orig_expr
+ | isEmptySubst subst = orig_expr
+ | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $
+ subst_expr subst orig_expr
+
+substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr
+substExpr _doc subst orig_expr = subst_expr subst orig_expr
+
+subst_expr :: Subst -> CoreExpr -> CoreExpr
+subst_expr subst expr
= go expr
where
- go (Var v) = lookupIdSubst subst v
+ go (Var v) = lookupIdSubst (text "subst_expr") subst v
go (Type ty) = Type (substTy subst ty)
go (Lit lit) = Lit lit
go (App fun arg) = App (go fun) (go arg)
go (Note note e) = Note (go_note note) (go e)
- go (Cast e co) = Cast (go e) (substTy subst co)
- go (Lam bndr body) = Lam bndr' (substExpr subst' body)
+ go (Cast e co) = Cast (go e) (optCoercion (getTvSubst subst) co)
+ -- Optimise coercions as we go; this is good, for example
+ -- in the RHS of rules, which are only substituted in
+
+ go (Lam bndr body) = Lam bndr' (subst_expr subst' body)
where
(subst', bndr') = substBndr subst bndr
- go (Let bind body) = Let bind' (substExpr subst' body)
+ go (Let bind body) = Let bind' (subst_expr subst' body)
where
(subst', bind') = substBind subst bind
where
(subst', bndr') = substBndr subst bndr
- go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
+ go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr subst' rhs)
where
(subst', bndrs') = substBndrs subst bndrs
-- | Apply a substititon to an entire 'CoreBind', additionally returning an updated 'Subst'
-- that should be used by subsequent substitutons.
-substBind :: Subst -> CoreBind -> (Subst, CoreBind)
-substBind subst (NonRec bndr rhs) = (subst', NonRec bndr' (substExpr subst rhs))
+substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind)
+
+substBindSC subst bind -- Short-cut if the substitution is empty
+ | not (isEmptySubst subst)
+ = substBind subst bind
+ | otherwise
+ = case bind of
+ NonRec bndr rhs -> (subst', NonRec bndr' rhs)
+ where
+ (subst', bndr') = substBndr subst bndr
+ Rec pairs -> (subst', Rec (bndrs' `zip` rhss'))
+ where
+ (bndrs, rhss) = unzip pairs
+ (subst', bndrs') = substRecBndrs subst bndrs
+ rhss' | isEmptySubst subst' = rhss
+ | otherwise = map (subst_expr subst') rhss
+
+substBind subst (NonRec bndr rhs) = (subst', NonRec bndr' (subst_expr subst rhs))
where
(subst', bndr') = substBndr subst bndr
-substBind subst (Rec pairs) = (subst', Rec pairs')
+substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss'))
where
- (subst', bndrs') = substRecBndrs subst (map fst pairs)
- pairs' = bndrs' `zip` rhss'
- rhss' = map (substExpr subst' . snd) pairs
+ (bndrs, rhss) = unzip pairs
+ (subst', bndrs') = substRecBndrs subst bndrs
+ rhss' = map (subst_expr subst') rhss
\end{code}
\begin{code}
substBndr :: Subst -> Var -> (Subst, Var)
substBndr subst bndr
| isTyVar bndr = substTyVarBndr subst bndr
- | otherwise = substIdBndr subst subst bndr
+ | otherwise = substIdBndr (text "var-bndr") subst subst bndr
-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
substBndrs :: Subst -> [Var] -> (Subst, [Var])
substRecBndrs subst bndrs
= (new_subst, new_bndrs)
where -- Here's the reason we need to pass rec_subst to subst_id
- (new_subst, new_bndrs) = mapAccumL (substIdBndr new_subst) subst bndrs
+ (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs
\end{code}
\begin{code}
-substIdBndr :: Subst -- ^ Substitution to use for the IdInfo
+substIdBndr :: SDoc
+ -> Subst -- ^ Substitution to use for the IdInfo
-> Subst -> Id -- ^ Substitition and Id to transform
-> (Subst, Id) -- ^ Transformed pair
-- NB: unfolding may be zapped
-substIdBndr rec_subst subst@(Subst in_scope env tvs) old_id
- = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+substIdBndr _doc rec_subst subst@(Subst in_scope env tvs) old_id
+ = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
+ (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
where
id1 = uniqAway in_scope old_id -- id1 is cloned if necessary
id2 | no_type_change = id1
\begin{code}
-- | Very similar to 'substBndr', but it always allocates a new 'Unique' for
--- each variable in its output and removes all 'IdInfo'
+-- each variable in its output. It substitutes the IdInfo though.
cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id)
cloneIdBndr subst us old_id
= clone_id subst subst (old_id, uniqFromSupply us)
-- | See 'Type.substTy'
substTy :: Subst -> Type -> Type
-substTy (Subst in_scope _id_env tv_env) ty
- = Type.substTy (TvSubst in_scope tv_env) ty
+substTy subst ty = Type.substTy (getTvSubst subst) ty
+
+getTvSubst :: Subst -> TvSubst
+getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
\end{code}
------------------
-- | Substitutes for the 'Id's within an unfolding
-substUnfolding :: Subst -> Unfolding -> Unfolding
+substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding
-- Seq'ing on the returned Unfolding is enough to cause
-- all the substitutions to happen completely
-substUnfolding subst (DFunUnfolding con args)
- = DFunUnfolding con (map (substExpr subst) args)
-substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_guidance = guide@(InlineRule {}) })
+substUnfoldingSC subst unf -- Short-cut version
+ | isEmptySubst subst = unf
+ | otherwise = substUnfolding subst unf
+
+substUnfolding subst (DFunUnfolding ar con args)
+ = DFunUnfolding ar con (map (substExpr (text "dfun-unf") subst) args)
+
+substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain an InlineRule!
+ | not (isInlineRuleSource src) -- Always zap a CoreUnfolding, to save substitution work
+ = NoUnfolding
+ | otherwise -- But keep an InlineRule!
= seqExpr new_tmpl `seq`
- new_info `seq`
- unf { uf_tmpl = new_tmpl, uf_guidance = guide { ir_info = new_info } }
+ new_src `seq`
+ unf { uf_tmpl = new_tmpl, uf_src = new_src }
where
- new_tmpl = substExpr subst tmpl
- new_info = substInlineRuleInfo subst (ir_info guide)
-
-substUnfolding _ (CoreUnfolding {}) = NoUnfolding -- Discard
- -- Always zap a CoreUnfolding, to save substitution work
+ new_tmpl = substExpr (text "subst-unf") subst tmpl
+ new_src = substUnfoldingSource subst src
substUnfolding _ unf = unf -- NoUnfolding, OtherCon
-------------------
-substInlineRuleInfo :: Subst -> InlineRuleInfo -> InlineRuleInfo
-substInlineRuleInfo (Subst in_scope ids _) (InlWrapper wkr)
- | Just (Var w1) <- lookupVarEnv ids wkr = InlWrapper w1
- | Just w1 <- lookupInScope in_scope wkr = InlWrapper w1
- | otherwise = WARN( True, text "Interesting! CoreSubst.substWorker:" <+> ppr wkr )
- InlVanilla -- Note [Worker inlining]
-substInlineRuleInfo _ info = info
+substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
+substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
+ | Just wkr_expr <- lookupVarEnv ids wkr
+ = case wkr_expr of
+ Var w1 -> InlineWrapper w1
+ _other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr
+ -- <+> ifPprDebug (equals <+> ppr wkr_expr) )
+ -- Note [Worker inlining]
+ InlineRule -- It's not a wrapper any more, but still inline it!
+
+ | Just w1 <- lookupInScope in_scope wkr = InlineWrapper w1
+ | otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
+ -- This can legitimately happen. The worker has been inlined and
+ -- dropped as dead code, because we don't treat the UnfoldingSource
+ -- as an "occurrence".
+ -- Note [Worker inlining]
+ InlineRule
+
+substUnfoldingSource _ src = src
------------------
substIdOcc :: Subst -> Id -> Id
-- These Ids should not be substituted to non-Ids
-substIdOcc subst v = case lookupIdSubst subst v of
+substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of
Var v' -> v'
other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])
, ru_fn = fn_name, ru_rhs = rhs })
= rule { ru_bndrs = bndrs',
ru_fn = subst_ru_fn fn_name,
- ru_args = map (substExpr subst') args,
- ru_rhs = substExpr subst' rhs }
+ ru_args = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
+ ru_rhs = substExpr (text "subst-rule" <+> ppr fn_name) subst' rhs }
where
(subst', bndrs') = substBndrs subst bndrs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
where
subst_fv subst fv
- | isId fv = exprFreeVars (lookupIdSubst subst fv)
+ | isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
| otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
\end{code}
-- may change radically
simpleOptExpr expr
- = go init_subst (occurAnalyseExpr expr)
+ = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
+ go init_subst (occurAnalyseExpr expr)
where
init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
-- It's potentially important to make a proper in-scope set
-- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
- go subst (Var v) = lookupIdSubst subst v
+ go subst (Var v) = lookupIdSubst (text "simpleOptExpr") subst v
go subst (App e1 e2) = App (go subst e1) (go subst e2)
go subst (Type ty) = Type (substTy subst ty)
go _ (Lit lit) = Lit lit
projects / ghc-hetmet.git / blobdiff