Commit b8ee6f14 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

A bunch of stuff relating to substitutions on core

* I was debugging so I added some call-site info
  (that touches a lot of code)

* I used substExpr a bit less in Simplify, hoping to
  make the simplifier a little faster and cleaner
parent 0252f1a4
......@@ -17,15 +17,13 @@ module CoreArity (
import CoreSyn
import CoreFVs
import CoreUtils
import CoreSubst
import Demand
import TyCon ( isRecursiveTyCon )
import qualified CoreSubst
import CoreSubst ( Subst, substBndr, substBndrs, substExpr
, mkEmptySubst, isEmptySubst )
import Var
import VarEnv
import Id
import Type
import TyCon ( isRecursiveTyCon )
import TcType ( isDictLikeTy )
import Coercion
import BasicTypes
......@@ -613,10 +611,12 @@ mkEtaWW orig_n in_scope orig_ty
-- eta_expand 1 e T
-- We want to get
-- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
go n subst ty' (EtaCo (substTy subst co) : eis)
go n subst ty' (EtaCo (Type.substTy subst co) : eis)
-------
| otherwise -- We have an expression of arity > 0,
= (getTvInScope subst, reverse eis) -- but its type isn't a function.
= WARN( True, ppr orig_n <+> ppr orig_ty )
(getTvInScope subst, reverse eis) -- but its type isn't a function.
-- This *can* legitmately happen:
-- e.g. coerce Int (\x. x) Essentially the programmer is
-- playing fast and loose with types (Happy does this a lot).
......@@ -625,22 +625,13 @@ mkEtaWW orig_n in_scope orig_ty
--------------
-- Avoiding unnecessary substitution
-- Avoiding unnecessary substitution; use short-cutting versions
subst_expr :: Subst -> CoreExpr -> CoreExpr
subst_expr s e | isEmptySubst s = e
| otherwise = substExpr s e
subst_expr = substExprSC (text "CoreArity:substExpr")
subst_bind :: Subst -> CoreBind -> (Subst, CoreBind)
subst_bind subst (NonRec b r)
= (subst', NonRec b' (subst_expr subst r))
where
(subst', b') = substBndr subst b
subst_bind subst (Rec prs)
= (subst', Rec (bs1 `zip` map (subst_expr subst') rhss))
where
(bs, rhss) = unzip prs
(subst', bs1) = substBndrs subst bs
subst_bind = substBindSC
--------------
......@@ -655,7 +646,7 @@ freshEtaId :: Int -> TvSubst -> Type -> (TvSubst, Id)
freshEtaId n subst ty
= (subst', eta_id')
where
ty' = substTy subst ty
ty' = Type.substTy subst ty
eta_id' = uniqAway (getTvInScope subst) $
mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty'
subst' = extendTvInScope subst eta_id'
......
......@@ -12,7 +12,8 @@ module CoreSubst (
-- ** Substituting into expressions and related types
deShadowBinds, substSpec, substRulesForImportedIds,
substTy, substExpr, substBind, substUnfolding,
substTy, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc,
-- ** Operations on substitutions
......@@ -212,13 +213,13 @@ extendSubstList subst [] = subst
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'
......@@ -282,11 +283,20 @@ instance Outputable Subst where
--
-- 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)
......@@ -295,11 +305,11 @@ substExpr subst expr
-- 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' (substExpr subst' body)
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
......@@ -307,7 +317,7 @@ substExpr subst expr
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
......@@ -315,16 +325,32 @@ substExpr subst expr
-- | 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}
......@@ -360,7 +386,7 @@ preserve occ info in rules.
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])
......@@ -371,18 +397,20 @@ substRecBndrs :: Subst -> [Id] -> (Subst, [Id])
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
......@@ -507,11 +535,16 @@ substIdInfo subst new_id info
------------------
-- | 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
substUnfoldingSC subst unf -- Short-cut version
| isEmptySubst subst = unf
| otherwise = substUnfolding subst unf
substUnfolding subst (DFunUnfolding con args)
= DFunUnfolding con (map (substExpr subst) args)
= DFunUnfolding con (map (substExpr (text "dfun-unf") subst) args)
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain an InlineRule!
......@@ -522,7 +555,7 @@ substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
new_src `seq`
unf { uf_tmpl = new_tmpl, uf_src = new_src }
where
new_tmpl = substExpr subst tmpl
new_tmpl = substExpr (text "subst-unf") subst tmpl
new_src = substUnfoldingSource subst src
substUnfolding _ unf = unf -- NoUnfolding, OtherCon
......@@ -551,7 +584,7 @@ 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])
......@@ -585,8 +618,8 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
, 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
......@@ -596,7 +629,7 @@ substVarSet subst fvs
= 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}
......@@ -630,7 +663,8 @@ simpleOptExpr :: CoreExpr -> CoreExpr
-- 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
......@@ -643,7 +677,7 @@ simpleOptExpr expr
-- 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
......
......@@ -1206,7 +1206,7 @@ exprIsConApp_maybe id_unf expr
= Nothing
beta fun pairs args
= case analyse (substExpr subst fun) args of
= case analyse (substExpr (text "subst-expr-is-con-app") subst fun) args of
Nothing -> -- pprTrace "Bale out! exprIsConApp_maybe" doc $
Nothing
Just ans -> -- pprTrace "Woo-hoo! exprIsConApp_maybe" doc $
......
......@@ -568,7 +568,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
let { all_counts = counts `plusSimplCount` counts1
; binds1 = getFloats env1
; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
} ;
-- Stop if nothing happened; don't dump output
......
......@@ -5,8 +5,8 @@
\begin{code}
module SimplEnv (
InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar,
OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar,
InCoercion, OutCoercion,
-- The simplifier mode
......@@ -29,7 +29,7 @@ module SimplEnv (
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
simplBinder, simplBinders, addBndrRules,
substExpr, substTy, getTvSubst, mkCoreSubst,
substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst,
-- Floats
Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
......@@ -50,9 +50,9 @@ import VarEnv
import VarSet
import OrdList
import Id
import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substUnfolding )
import qualified Type ( substTy, substTyVarBndr )
import Type hiding ( substTy, substTyVarBndr )
import qualified CoreSubst
import qualified Type ( substTy, substTyVarBndr, substTyVar )
import Type hiding ( substTy, substTyVarBndr, substTyVar )
import Coercion
import BasicTypes
import MonadUtils
......@@ -70,6 +70,7 @@ import Data.List
\begin{code}
type InBndr = CoreBndr
type InVar = Var -- Not yet cloned
type InId = Id -- Not yet cloned
type InType = Type -- Ditto
type InBind = CoreBind
......@@ -79,6 +80,7 @@ type InArg = CoreArg
type InCoercion = Coercion
type OutBndr = CoreBndr
type OutVar = Var -- Cloned
type OutId = Id -- Cloned
type OutTyVar = TyVar -- Cloned
type OutType = Type -- Cloned
......@@ -673,7 +675,7 @@ addBndrRules env in_id out_id
| isEmptySpecInfo old_rules = (env, out_id)
| otherwise = (modifyInScope env final_id, final_id)
where
subst = mkCoreSubst env
subst = mkCoreSubst (text "local rules") env
old_rules = idSpecialisation in_id
new_rules = CoreSubst.substSpec subst out_id old_rules
final_id = out_id `setIdSpecialisation` new_rules
......@@ -694,6 +696,9 @@ getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
substTy :: SimplEnv -> Type -> Type
substTy env ty = Type.substTy (getTvSubst env) ty
substTyVar :: SimplEnv -> TyVar -> Type
substTyVar env tv = Type.substTyVar (getTvSubst env) tv
substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
substTyVarBndr env tv
= case Type.substTyVarBndr (getTvSubst env) tv of
......@@ -705,15 +710,16 @@ substTyVarBndr env tv
-- here. I think the this will not usually result in a lot of work;
-- the substitutions are typically small, and laziness will avoid work in many cases.
mkCoreSubst :: SimplEnv -> CoreSubst.Subst
mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
= mk_subst tv_env id_env
where
mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
fiddle (DoneEx e) = e
fiddle (DoneId v) = Var v
fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
-- Don't shortcut here
------------------
substIdType :: SimplEnv -> Id -> Id
......@@ -727,12 +733,14 @@ substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
old_ty = idType id
------------------
substExpr :: SimplEnv -> CoreExpr -> CoreExpr
substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr
substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr
substExpr doc env
= CoreSubst.substExprSC (text "SimplEnv.substExpr1" <+> doc)
(mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env)
-- Do *not* short-cut in the case of an empty substitution
-- See CoreSubst: Note [Extending the Subst]
substUnfolding :: SimplEnv -> Unfolding -> Unfolding
substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst env) unf
substUnfolding env unf = CoreSubst.substUnfoldingSC (mkCoreSubst (text "subst-unfolding") env) unf
\end{code}
......@@ -147,8 +147,8 @@ instance Outputable SimplCont where
{- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
ppr (StrictBind b _ _ _ cont) = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
ppr (StrictArg ai _ cont) = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
ppr (Select dup bndr alts _ cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$
(nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
ppr (CoerceIt co cont) = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
data DupFlag = OkToDup | NoDup
......@@ -222,12 +222,21 @@ countArgs :: SimplCont -> Int
countArgs (ApplyTo _ _ _ cont) = 1 + countArgs cont
countArgs _ = 0
contArgs :: SimplCont -> ([OutExpr], SimplCont)
contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
-- Uses substitution to turn each arg into an OutExpr
contArgs cont = go [] cont
contArgs cont@(ApplyTo {})
= case go [] cont of { (args, cont') -> (False, args, cont') }
where
go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont
go args cont = (reverse args, cont)
go args (ApplyTo _ arg se cont)
| isTypeArg arg = go args cont
| otherwise = go (is_interesting arg se : args) cont
go args cont = (reverse args, cont)
is_interesting arg se = interestingArg (substExpr (text "contArgs") se arg)
-- Do *not* use short-cutting substitution here
-- because we want to get as much IdInfo as possible
contArgs cont = (True, [], cont)
pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
pushArgs _env [] cont = cont
......@@ -1282,7 +1291,7 @@ abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExp
abstractFloats main_tvs body_env body
= ASSERT( notNull body_floats )
do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
; return (float_binds, CoreSubst.substExpr subst body) }
; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }
where
main_tv_set = mkVarSet main_tvs
body_floats = getFloats body_env
......@@ -1295,7 +1304,7 @@ abstractFloats main_tvs body_env body
subst' = CoreSubst.extendIdSubst subst id poly_app
; return (subst', (NonRec poly_id poly_rhs)) }
where
rhs' = CoreSubst.substExpr subst rhs
rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions]
| otherwise
= varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
......@@ -1319,7 +1328,8 @@ abstractFloats main_tvs body_env body
abstract subst (Rec prs)
= do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
poly_rhss = [mkLams tvs_here (CoreSubst.substExpr subst' rhs) | rhs <- rhss]
poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs)
| rhs <- rhss]
; return (subst', Rec (poly_ids `zip` poly_rhss)) }
where
(ids,rhss) = unzip prs
......
This diff is collapsed.
......@@ -570,7 +570,7 @@ lookupHowBound :: ScEnv -> Id -> Maybe HowBound
lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
scSubstId :: ScEnv -> Id -> CoreExpr
scSubstId env v = lookupIdSubst (sc_subst env) v
scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
scSubstTy :: ScEnv -> Type -> Type
scSubstTy env ty = substTy (sc_subst env) ty
......
......@@ -588,7 +588,7 @@ specProgram us binds = initSM us $
\begin{code}
specVar :: Subst -> Id -> CoreExpr
specVar subst v = lookupIdSubst subst v
specVar subst v = lookupIdSubst (text "specVar") subst v
specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
-- We carry a substitution down:
......
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