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

@@ -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'		  

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

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 $

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

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}
 

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

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
-