[project @ 1998-04-29 09:30:24 by simonpj]

Alleged fix to SpecEnv muddle for recursive bindings

ghc/compiler/simplCore/SimplUtils.lhs

@@ -16,7 +16,9 @@ module SimplUtils (
 
 	simplIdWantsToBeINLINEd,
 
-	singleConstructorType, typeOkForCase
+	singleConstructorType, typeOkForCase,
+
+	substSpecEnvRhs
     ) where
 
 #include "HsVersions.h"
@@ -29,6 +31,7 @@ import MkId		( mkSysLocal )
 import Id		( idType, isBottomingId, getIdArity,
 			  addInlinePragma, addIdDemandInfo,
 			  idWantsToBeINLINEd, dataConArgTys, Id,
+			  lookupIdEnv, delOneFromIdEnv
 			)
 import IdInfo		( ArityInfo(..), DemandInfo )
 import Maybes		( maybeToBool )
@@ -37,10 +40,10 @@ import PrimOp		( primOpIsCheap )
 import SimplEnv
 import SimplMonad
 import Type		( tyVarsOfType, mkForAllTys, mkTyVarTys, getTyVar_maybe,
-			  splitAlgTyConApp_maybe, Type
+			  splitAlgTyConApp_maybe, instantiateTy, Type
 			)
 import TyCon		( isDataTyCon )
-import TyVar		( elementOfTyVarSet )
+import TyVar		( elementOfTyVarSet, delFromTyVarEnv )
 import SrcLoc		( noSrcLoc )
 import Util		( isIn, zipWithEqual, panic, assertPanic )
 
@@ -494,3 +497,35 @@ typeOkForCase ty
       -- currently handle.  (ToDo: when return-in-heap is universal we
       -- don't need to worry about this.)
 \end{code}
+
+
+
+substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
+It exploits the known structure of a SpecEnv's RHS to have fewer
+equations.
+
+\begin{code}
+substSpecEnvRhs te ve rhs
+  = go te ve rhs
+  where
+    go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
+    go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
+							Just (SubstVar v') -> VarArg v'
+							Just (SubstLit l)  -> LitArg l
+							Nothing            -> VarArg v)
+    go te ve (Var v)		  = case lookupIdEnv ve v of
+						Just (SubstVar v') -> Var v'
+						Just (SubstLit l)  -> Lit l
+						Nothing 	   -> Var v
+
+	-- These equations are a bit half baked, because
+	-- they don't deal properly wih capture.
+	-- But I'm sure it'll never matter... sigh.
+    go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
+				        where
+					  te' = delFromTyVarEnv te tyvar
+
+    go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
+				     where
+				       ve' = delOneFromIdEnv ve v
+\end{code}

ghc/compiler/simplCore/SimplVar.lhs

@@ -28,7 +28,7 @@ import Id		( idType, getIdUnfolding,
 			  mkIdWithNewUniq, mkIdWithNewType, 
 			  IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
 			)
-import SpecEnv		( lookupSpecEnv, substSpecEnv, isEmptySpecEnv )
+import SpecEnv		( lookupSpecEnv )
 import OccurAnal	( occurAnalyseGlobalExpr )
 import Literal		( isNoRepLit )
 import MagicUFs		( applyMagicUnfoldingFun, MagicUnfoldingFun )
@@ -196,10 +196,6 @@ simplBinder env (id, occ_info)
        -- id1 has its type zapped
        id1 | empty_ty_subst = id
            | otherwise      = mkIdWithNewType id ty'
-
-       -- id2 has its SpecEnv zapped
-       id2 | isEmptySpecEnv spec_env = id1
-           | otherwise               = setIdSpecialisation id1 spec_env'
     in
     if not_in_scope then
 	-- No need to clone, but we *must* zap any current substitution
@@ -207,19 +203,19 @@ simplBinder env (id, occ_info)
 	--	(\x.e) with id_subst = [x |-> e']
 	-- Here we must simply zap the substitution for x
 	let
-	    env' = setIdEnv env (new_in_scope_ids id2, 
+	    env' = setIdEnv env (new_in_scope_ids id1, 
 				 delOneFromIdEnv id_subst id)
 	in
-	returnSmpl (env', id2)
+	returnSmpl (env', id1)
     else
 	-- Must clone
 	getUniqueSmpl         `thenSmpl` \ uniq ->
 	let
-	    id3 = mkIdWithNewUniq id2 uniq
-	    env' = setIdEnv env (new_in_scope_ids id3,
-				 addOneToIdEnv id_subst id (SubstVar id3))
+	    id2 = mkIdWithNewUniq id1 uniq
+	    env' = setIdEnv env (new_in_scope_ids id2,
+				 addOneToIdEnv id_subst id (SubstVar id2))
 	in
-	returnSmpl (env', id3)
+	returnSmpl (env', id2)
     )
   where
     ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
@@ -231,9 +227,6 @@ simplBinder env (id, occ_info)
     
     ty               	 = idType id
     ty'              	 = instantiateTy ty_subst ty
-    
-    spec_env         	 = getIdSpecialisation id
-    spec_env'        	 = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
 
 simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
 simplBinders env binders = mapAccumLSmpl simplBinder env binders
@@ -266,33 +259,3 @@ simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
 simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
 \end{code}
 
-
-substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
-It exploits the known structure of a SpecEnv's RHS to have fewer
-equations.
-
-\begin{code}
-substSpecEnvRhs te ve rhs
-  = go te ve rhs
-  where
-    go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
-    go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
-							Just (SubstVar v') -> VarArg v'
-							Just (SubstLit l)  -> LitArg l
-							Nothing            -> VarArg v)
-    go te ve (Var v)		  = case lookupIdEnv ve v of
-						Just (SubstVar v') -> Var v'
-						Just (SubstLit l)  -> Lit l
-						Nothing 	   -> Var v
-
-	-- These equations are a bit half baked, because
-	-- they don't deal properly wih capture.
-	-- But I'm sure it'll never matter... sigh.
-    go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
-				        where
-					  te' = delFromTyVarEnv te tyvar
-
-    go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
-				     where
-				       ve' = delOneFromIdEnv ve v
-\end{code}

ghc/compiler/simplCore/Simplify.lhs

@@ -11,7 +11,7 @@ module Simplify ( simplTopBinds, simplExpr, simplBind ) where
 import BinderInfo
 import CmdLineOpts	( SimplifierSwitch(..) )
 import ConFold		( completePrim )
-import CoreUnfold	( Unfolding, mkFormSummary, 
+import CoreUnfold	( Unfolding, mkFormSummary, noUnfolding,
 			  exprIsTrivial, whnfOrBottom, inlineUnconditionally,
 			  FormSummary(..)
 			)
@@ -21,7 +21,7 @@ import CoreUtils	( coreExprType, nonErrorRHSs, maybeErrorApp,
 			  unTagBinders, squashableDictishCcExpr
 			)
 import Id		( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd, 
-			  addIdArity, getIdArity,
+			  addIdArity, getIdArity, getIdSpecialisation, setIdSpecialisation,
 			  getIdDemandInfo, addIdDemandInfo
 			)
 import Name		( isExported, isLocallyDefined )
@@ -35,6 +35,7 @@ import SimplEnv
 import SimplMonad
 import SimplVar		( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders )
 import SimplUtils
+import SpecEnv		( isEmptySpecEnv, substSpecEnv )
 import Type		( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys,
 			  mkFunTys, splitAlgTyConApp_maybe,
 			  splitFunTys, splitFunTy_maybe, isUnpointedType
@@ -1079,10 +1080,7 @@ completeBind :: SimplEnv
 	     -> InBinder -> OutId -> OutExpr		-- Id and RHS
 	     -> (SimplEnv, [(OutId, OutExpr)])		-- Final envt and binding(s)
 
-completeBind env binder@(_,occ_info) new_id new_rhs
-  | idMustNotBeINLINEd new_id		-- Occurrence analyser says "don't inline"
-  = (env, new_binds)
-
+completeBind env binder@(old_id,occ_info) new_id new_rhs
   |  atomic_rhs			-- If rhs (after eta reduction) is atomic
   && not (isExported new_id)	-- and binder isn't exported
   = 	-- Drop the binding completely
@@ -1092,31 +1090,31 @@ completeBind env binder@(_,occ_info) new_id new_rhs
     in
     (env2, [])
 
-{-	This case is WRONG.  It attempts to exploit knowledge that indirections
-	are eliminated (by OccurAnal), but they *aren't* for recursive bindings.
-	If this case is enabled, then 
-		rec { local = (a,b)
-		      global = local
-		      ... = case global of ...
-		    }
-	never gets simplified
-
-  |  atomic_rhs 		-- Rhs is atomic, and new_id is exported
-  && case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False }
-  =	-- The local variable v will be eliminated next time round
-	-- in favour of new_id, so it's a waste to replace all new_id's with v's
-	-- this time round.
-	-- This case is an optional improvement; saves a simplifier iteration
-    (env, [(new_id, eta'd_rhs)])
--}
-
   | otherwise				-- Non-atomic
+	-- The big deal here is that we simplify the 
+	-- SpecEnv of the Id, if any. We used to do that in simplBinders, but
+	-- that didn't work because it didn't take account of the fact that
+	-- one of the mutually recursive group might mention one of the others
+	-- in its SpecEnv
   = let
-	env1 = extendEnvGivenBinding env occ_info new_id new_rhs
-    in 
+	id_w_specenv | isEmptySpecEnv spec_env = new_id
+		     | otherwise	       = setIdSpecialisation new_id spec_env'
+
+	env1 | idMustNotBeINLINEd new_id	-- Occurrence analyser says "don't inline"
+	     = extendEnvGivenUnfolding env id_w_specenv occ_info noUnfolding
+			-- Still need to record the new_id with its SpecEnv
+
+	     | otherwise			-- Can inline it
+	     = extendEnvGivenBinding env occ_info id_w_specenv new_rhs
+
+    in
     (env1, new_binds)
 	     
   where
+    spec_env         	= getIdSpecialisation old_id
+    spec_env'        	= substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
+    (ty_subst,id_subst) = getSubstEnvs env
+
     new_binds  = [(new_id, new_rhs)]
     atomic_rhs = is_atomic eta'd_rhs
     eta'd_rhs  = case lookForConstructor env new_rhs of