From b8ee6f14ca6e9e49015ee9b404cf8b8191fede05 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 24 Dec 2009 15:39:49 +0000 Subject: [PATCH] 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 --- compiler/coreSyn/CoreArity.lhs | 29 ++++------- compiler/coreSyn/CoreSubst.lhs | 94 +++++++++++++++++++++++----------- compiler/coreSyn/CoreUnfold.lhs | 2 +- compiler/simplCore/SimplCore.lhs | 2 +- compiler/simplCore/SimplEnv.lhs | 34 ++++++++----- compiler/simplCore/SimplUtils.lhs | 28 +++++++---- compiler/simplCore/Simplify.lhs | 97 +++++++++++++++++++++--------------- compiler/specialise/SpecConstr.lhs | 2 +- compiler/specialise/Specialise.lhs | 2 +- 9 files changed, 174 insertions(+), 116 deletions(-) diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs index 49106df..d5849cb 100644 --- a/compiler/coreSyn/CoreArity.lhs +++ b/compiler/coreSyn/CoreArity.lhs @@ -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' diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 9f1e20d..0c0ca15 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -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 diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 8f83dfe..fc31d5a 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -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 $ diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 7449a5a..8ec2d1d 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -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 diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 2a620ff..b341b87 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -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} diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 20f26c2..4a8ad54 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -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 diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 1b4bfe4..2001a17 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -10,7 +10,7 @@ module Simplify ( simplTopBinds, simplExpr ) where import DynFlags import SimplMonad -import Type hiding ( substTy, extendTvSubst ) +import Type hiding ( substTy, extendTvSubst, substTyVar ) import SimplEnv import SimplUtils import FamInstEnv ( FamInstEnv ) @@ -534,6 +534,7 @@ makeTrivial env expr = makeTrivialWithInfo env vanillaIdInfo expr makeTrivialWithInfo :: SimplEnv -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Propagate strictness and demand info to the new binder -- Note [Preserve strictness when floating coercions] +-- Returned SimplEnv has same substitution as incoming one makeTrivialWithInfo env info expr | exprIsTrivial expr = return (env, expr) @@ -542,14 +543,17 @@ makeTrivialWithInfo env info expr ; let name = mkSystemVarName uniq (fsLit "a") var = mkLocalIdWithInfo name (exprType expr) info ; env' <- completeNonRecX env False var var expr - ; return (env', substExpr env' (Var var)) } - -- The substitution is needed becase we're constructing a new binding + ; expr' <- simplVar env' var + ; return (env', expr') } + -- The simplVar is needed becase we're constructing a new binding -- a = rhs -- And if rhs is of form (rhs1 |> co), then we might get -- a1 = rhs1 -- a = a1 |> co -- and now a's RHS is trivial and can be substituted out, and that -- is what completeNonRecX will do + -- To put it another way, it's as if we'd simplified + -- let var = e in var \end{code} @@ -670,15 +674,14 @@ simplUnfolding :: SimplEnv-> TopLevelFlag simplUnfolding env _ _ _ _ (DFunUnfolding con ops) = return (DFunUnfolding con ops') where - ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops + ops' = map (substExpr (text "simplUnfolding") env) ops simplUnfolding env top_lvl id _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity , uf_src = src, uf_guidance = guide }) | isInlineRuleSource src - = -- pprTrace "su" (vcat [ppr id, ppr act, ppr (getMode env), ppr (getMode rule_env)]) $ - do { expr' <- simplExpr rule_env expr - ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src + = do { expr' <- simplExpr rule_env expr + ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } -- See Note [Top-level flag on inline rules] in CoreUnfold where @@ -820,7 +823,7 @@ simplExprF env e cont simplExprF' :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplExprF' env (Var v) cont = simplVar env v cont +simplExprF' env (Var v) cont = simplVarF env v cont simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont simplExprF' env (Note n expr) cont = simplNote env n expr cont simplExprF' env (Cast body co) cont = simplCast env body co cont @@ -990,7 +993,7 @@ simplCast env body co0 cont0 -- (->) t1 t2 ~ (->) s1 s2 [co1, co2] = decomposeCo 2 co new_arg = mkCoerce (mkSymCoercion co1) arg' - arg' = substExpr (arg_se `setInScope` env) arg + arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg add_coerce co _ cont = CoerceIt co cont \end{code} @@ -1092,13 +1095,24 @@ simplNote env (CoreNote s) e cont %************************************************************************ %* * -\subsection{Dealing with calls} + Variables %* * %************************************************************************ \begin{code} -simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplVar env var cont +simplVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplVar env var + | isTyVar var + = return (Type (substTyVar env var)) + | otherwise + = case substId env var of + DoneId var1 -> return (Var var1) + DoneEx e -> return e + ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e + +simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) +simplVarF env var cont = case substId env var of DoneEx e -> simplExprF (zapSubstEnv env) e cont ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont @@ -1120,24 +1134,23 @@ completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) completeCall env var cont = do { ------------- Try inlining ---------------- dflags <- getDOptsSmpl - ; let (args,call_cont) = contArgs cont + ; let (lone_variable, arg_infos, call_cont) = contArgs cont -- The args are OutExprs, obtained by *lazily* substituting -- in the args found in cont. These args are only examined -- to limited depth (unless a rule fires). But we must do -- the substitution; rule matching on un-simplified args would -- be bogus - arg_infos = [interestingArg arg | arg <- args, isValArg arg] n_val_args = length arg_infos interesting_cont = interestingCallContext call_cont unfolding = activeUnfolding env var maybe_inline = callSiteInline dflags var unfolding - (null args) arg_infos interesting_cont + lone_variable arg_infos interesting_cont ; case maybe_inline of { - Just unfolding -- There is an inlining! + Just expr -- There is an inlining! -> do { tick (UnfoldingDone var) - ; trace_inline dflags unfolding args call_cont $ - simplExprF (zapSubstEnv env) unfolding cont } + ; trace_inline dflags expr cont $ + simplExprF (zapSubstEnv env) expr cont } ; Nothing -> do -- No inlining! @@ -1146,7 +1159,7 @@ completeCall env var cont ; rebuildCall env info cont }}} where - trace_inline dflags unfolding args call_cont stuff + trace_inline dflags unfolding cont stuff | not (dopt Opt_D_dump_inlinings dflags) = stuff | not (dopt Opt_D_verbose_core2core dflags) = if isExternalName (idName var) then @@ -1154,9 +1167,8 @@ completeCall env var cont else stuff | otherwise = pprTrace ("Inlining done: " ++ showSDoc (ppr var)) - (vcat [text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "Inlined fn: " <+> nest 2 (ppr unfolding), - text "Cont: " <+> ppr call_cont]) + (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont]) stuff rebuildCall :: SimplEnv @@ -1501,7 +1513,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq' - = do { let rhs' = substExpr env rhs + = do { let rhs' = substExpr (text "rebuild-case") env rhs out_args = [Type (substTy env (idType case_bndr)), Type (exprType rhs'), scrut, rhs'] -- Lazily evaluated, so we don't do most of this @@ -1638,7 +1650,7 @@ simplAlts :: SimplEnv -- it does not return an environment simplAlts env scrut case_bndr alts cont' - = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $ + = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $ do { let env0 = zapFloats env ; (env1, case_bndr1) <- simplBinder env0 case_bndr @@ -1787,23 +1799,8 @@ knownCon :: SimplEnv -> SimplM (SimplEnv, OutExpr) knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont - = do { env' <- bind_args env bs dc_args - ; let - -- It's useful to bind bndr to scrut, rather than to a fresh - -- binding x = Con arg1 .. argn - -- because very often the scrut is a variable, so we avoid - -- creating, and then subsequently eliminating, a let-binding - -- BUT, if scrut is a not a variable, we must be careful - -- about duplicating the arg redexes; in that case, make - -- a new con-app from the args - bndr_rhs | exprIsTrivial scrut = scrut - | otherwise = con_app - con_app = Var (dataConWorkId dc) - `mkTyApps` dc_ty_args - `mkApps` [substExpr env' (varToCoreExpr b) | b <- bs] - -- dc_ty_args are aready OutTypes, but bs are InBndrs - - ; env'' <- simplNonRecX env' bndr bndr_rhs + = do { env' <- bind_args env bs dc_args + ; env'' <- bind_case_bndr env' ; simplExprF env'' rhs cont } where zap_occ = zapCasePatIdOcc bndr -- bndr is an InId @@ -1830,6 +1827,24 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ text "scrut:" <+> ppr scrut + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return env + | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut)) + | otherwise = do { dc_args <- mapM (simplVar env) bs + -- dc_ty_args are aready OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplNonRecX env bndr con_app } + ------------------- missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr) -- This isn't strictly an error, although it is unusual. diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 404b6cc..b95b903 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -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 diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 5d780ea..4342534 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -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: -- 1.7.10.4