A bunch of stuff relating to substitutions on core
authorsimonpj@microsoft.com <unknown>
Thu, 24 Dec 2009 15:39:49 +0000 (15:39 +0000)
committersimonpj@microsoft.com <unknown>
Thu, 24 Dec 2009 15:39:49 +0000 (15:39 +0000)
* 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
compiler/coreSyn/CoreSubst.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/simplCore/SimplCore.lhs
compiler/simplCore/SimplEnv.lhs
compiler/simplCore/SimplUtils.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/SpecConstr.lhs
compiler/specialise/Specialise.lhs

index 49106df..d5849cb 100644 (file)
@@ -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'           
index 9f1e20d..0c0ca15 100644 (file)
@@ -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
index 8f83dfe..fc31d5a 100644 (file)
@@ -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 $
index 7449a5a..8ec2d1d 100644 (file)
@@ -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
index 2a620ff..b341b87 100644 (file)
@@ -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}
 
index 20f26c2..4a8ad54 100644 (file)
@@ -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
index 1b4bfe4..2001a17 100644 (file)
@@ -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. 
index 404b6cc..b95b903 100644 (file)
@@ -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
index 5d780ea..4342534 100644 (file)
@@ -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: