[project @ 2004-12-30 22:14:59 by simonpj]

Fix to the pre-Xmas simplifier changes, which should make 
everything work again.  I'd forgotten to attend to this
corner.  Still not properly tested I fear.

Also remove dead code from SimplEnv, and simplify the remainder (hooray).

ghc/compiler/basicTypes/VarEnv.lhs

@@ -7,7 +7,7 @@
 module VarEnv (
 	VarEnv, IdEnv, TyVarEnv,
 	emptyVarEnv, unitVarEnv, mkVarEnv,
-	elemVarEnv, varEnvElts,
+	elemVarEnv, varEnvElts, varEnvKeys,
 	extendVarEnv, extendVarEnv_C, extendVarEnvList,
 	plusVarEnv, plusVarEnv_C,
 	delVarEnvList, delVarEnv,
@@ -22,6 +22,7 @@ module VarEnv (
 	InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet,
 	extendInScopeSet, extendInScopeSetList, modifyInScopeSet,
 	getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, 
+	mapInScopeSet,
 
 	-- RnEnv2 and its operations
 	RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR,
@@ -86,6 +87,9 @@ modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_sco
 delInScopeSet :: InScopeSet -> Var -> InScopeSet
 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
 
+mapInScopeSet :: (Var -> Var) -> InScopeSet -> InScopeSet
+mapInScopeSet f (InScope in_scope n) = InScope (mapVarEnv f in_scope) n
+
 elemInScopeSet :: Var -> InScopeSet -> Bool
 elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
 
@@ -286,6 +290,7 @@ plusVarEnv_C	  :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
 mapVarEnv	  :: (a -> b) -> VarEnv a -> VarEnv b
 modifyVarEnv	  :: (a -> a) -> VarEnv a -> Var -> VarEnv a
 varEnvElts	  :: VarEnv a -> [a]
+varEnvKeys	  :: VarEnv a -> [Unique]
 		  
 isEmptyVarEnv	  :: VarEnv a -> Bool
 lookupVarEnv	  :: VarEnv a -> Var -> Maybe a
@@ -310,6 +315,7 @@ mapVarEnv	 = mapUFM
 mkVarEnv	 = listToUFM
 emptyVarEnv	 = emptyUFM
 varEnvElts	 = eltsUFM
+varEnvKeys	 = keysUFM
 unitVarEnv	 = unitUFM
 isEmptyVarEnv	 = isNullUFM
 foldVarEnv	 = foldUFM

ghc/compiler/coreSyn/CoreLint.lhs

@@ -34,7 +34,8 @@ import Type		( Type, tyVarsOfType, coreEqType,
 			  isUnboxedTupleType, isSubKind,
 			  substTyWith, emptyTvSubst, extendTvInScope, 
 			  TvSubst, TvSubstEnv, setTvSubstEnv, substTy,
-			  extendTvSubst, isInScope )
+			  extendTvSubst, composeTvSubst, isInScope,
+			  getTvSubstEnv, getTvInScope )
 import TyCon		( isPrimTyCon )
 import BasicTypes	( RecFlag(..), Boxity(..), isNonRec )
 import CmdLineOpts
@@ -464,9 +465,11 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
 	      pat_res_ty = dataConResTy con (mkTyVarTys tvs)	      
 
         ; subst <- getTvSubst 
-        ; case coreRefineTys tvs subst pat_res_ty scrut_ty of {
-             Nothing   -> return () ;	-- Alternative is dead code
-             Just senv -> updateTvSubstEnv senv $
+	; let in_scope  = getTvInScope subst
+	      subst_env = getTvSubstEnv subst
+        ; case coreRefineTys in_scope tvs pat_res_ty scrut_ty of {
+             Nothing     -> return () ;	-- Alternative is dead code
+             Just refine -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
     do 	{ tvs'     <- mapM lintTy (mkTyVarTys tvs)
 	; con_type <- lintTyApps (dataConRepType con) tvs'
 	; mapM lintBinder ids	-- Lint Ids in the refined world
@@ -579,7 +582,6 @@ addInScopeVars :: [Var] -> LintM a -> LintM a
 addInScopeVars vars m = 
   LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
 
--- gaw 2004
 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
 updateTvSubstEnv substenv m = 
   LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)

ghc/compiler/main/TidyPgm.lhs

@@ -40,7 +40,6 @@ import HscTypes		( HscEnv(..), NameCache( nsUniqs ),
 			)
 import Maybes		( orElse )
 import ErrUtils		( showPass, dumpIfSet_core )
-import UniqFM		( mapUFM )
 import UniqSupply	( splitUniqSupply, uniqFromSupply )
 import List		( partition )
 import Maybe		( isJust )

ghc/compiler/simplCore/SimplEnv.lhs

@@ -21,7 +21,7 @@ module SimplEnv (
 	SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, 
 	zapSubstEnv, setSubstEnv, 
 	getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
-	getRules,
+	getRules, refineSimplEnv,
 
 	SimplSR(..), mkContEx, substId, 
 
@@ -39,55 +39,31 @@ module SimplEnv (
 #include "HsVersions.h"
 
 import SimplMonad	
-import Rules		( RuleBase, emptyRuleBase )
-import Id		( Id, idType, idOccInfo, idInlinePragma, idUnfolding, setIdUnfolding )
+import Id		( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
 import IdInfo		( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
 			  arityInfo, setArityInfo, workerInfo, setWorkerInfo, 
 			  unfoldingInfo, setUnfoldingInfo, 
 			  unknownArity, workerExists
 			    )
 import CoreSyn
-import CoreUtils	( needsCaseBinding, exprIsTrivial )
+import Rules		( RuleBase )
+import CoreUtils	( needsCaseBinding )
 import PprCore		()	-- Instances
 import CostCentre	( CostCentreStack, subsumedCCS )
 import Var	
 import VarEnv
-import VarSet		( isEmptyVarSet )
+import VarSet		( isEmptyVarSet, elemVarSetByKey, mkVarSet )
 import OrdList
 
 import qualified CoreSubst	( Subst, mkSubst, substExpr, substRules, substWorker )
 import qualified Type		( substTy, substTyVarBndr )
 
-import Type             ( Type, TvSubst(..), TvSubstEnv, isUnLiftedType, seqType, tyVarsOfType )
-import UniqSupply	( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
-			  UniqSupply
-			)
-import FiniteMap
-import BasicTypes	( TopLevelFlag, isTopLevel, isLoopBreaker,
-			  Activation, isActive, isAlwaysActive,
-			  OccInfo(..), isOneOcc, isFragileOcc
-			)
-import CmdLineOpts	( SimplifierSwitch(..), SimplifierMode(..),
-			  DynFlags, DynFlag(..), dopt, 
-			  opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, opt_RulesOff
-			)
-import Unique		( Unique )
+import Type             ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
+			  isUnLiftedType, seqType, tyVarsOfType )
+import BasicTypes	( OccInfo(..), isFragileOcc )
+import CmdLineOpts	( SimplifierMode(..) )
 import Util		( mapAccumL )
 import Outputable
-import FastTypes
-import FastString
-import Maybes		( expectJust )
-
-import GLAEXTS		( indexArray# )
-
-#if __GLASGOW_HASKELL__ < 503
-import PrelArr  ( Array(..) )
-#else
-import GHC.Arr  ( Array(..) )
-#endif
-
-import Array		( array, (//) )
-
 \end{code}
 
 %************************************************************************
@@ -328,6 +304,34 @@ getRules :: SimplEnv -> RuleBase
 getRules = seExtRules
 \end{code}
 
+		GADT stuff
+
+Given an idempotent substitution, generated by the unifier, use it to 
+refine the environment
+
+\begin{code}
+refineSimplEnv :: SimplEnv -> TvSubstEnv -> [OutTyVar] -> SimplEnv
+-- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
+refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
+	       refine_tv_subst tvs
+  = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
+	  seInScope = in_scope' }
+  where
+    in_scope' 
+	| all bound_here (varEnvKeys refine_tv_subst) = in_scope
+		-- The tvs are the tyvars bound here.  If only they 
+		-- are refined, there's no need to do anything 
+	| otherwise = mapInScopeSet refine_id in_scope
+
+    bound_here uniq = elemVarSetByKey uniq tv_set
+    tv_set = mkVarSet tvs
+
+    refine_id v 	-- Only refine its type; any rules will get
+			-- refined if they are used (I hope)
+	| isId v    = setIdType v (Type.substTy refine_subst (idType v))
+	| otherwise = v
+    refine_subst = TvSubst in_scope refine_tv_subst
+\end{code}
 
 %************************************************************************
 %*									*
@@ -361,7 +365,6 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
     refine v = case lookupInScope in_scope v of
 		 Just v' -> v'
 		 Nothing -> WARN( True, ppr v ) v	-- This is an error!
-	
 \end{code}
 
 
@@ -391,7 +394,7 @@ simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
 simplBinder env bndr
   | isTyVar bndr  = do	{ let (env', tv) = substTyVarBndr env bndr
 			; seqTyVar tv `seq` return (env', tv) }
-  | otherwise     = do	{ let (env', id) = substIdBndr False env env bndr
+  | otherwise     = do	{ let (env', id) = substIdBndr env bndr
 			; seqId id `seq` return (env', id) }
 
 -------------
@@ -412,7 +415,7 @@ simplLamBndr env bndr
   | otherwise					= seqId id2 `seq` return (env', id2)
   where
     old_unf = idUnfolding bndr
-    (env', id1) = substIdBndr False env env bndr
+    (env', id1) = substIdBndr env bndr
     id2 = id1 `setIdUnfolding` substUnfolding env old_unf
 
 -------------
@@ -426,48 +429,21 @@ seqId id = seqType (idType id)	`seq`
 \end{code}
 
 \begin{code}
--- substBndr and friends are used when doing expression substitution only
--- In this case we can *preserve* occurrence information, and indeed we *want*
--- to do so else lose useful occ info in rules. 
-
-substBndr :: SimplEnv -> Var -> (SimplEnv, Var)
-substBndr subst bndr
-  | isTyVar bndr  = substTyVarBndr subst bndr
-  | otherwise     = substIdBndr True {- keep fragile info -} subst subst bndr
-
-substBndrs :: SimplEnv -> [Var] -> (SimplEnv, [Var])
-substBndrs subst bndrs = mapAccumL substBndr subst bndrs
-
-substRecBndrs :: SimplEnv -> [Id] -> (SimplEnv, [Id])
--- Substitute a mutually recursive group
-substRecBndrs subst bndrs 
-  = (new_subst, new_bndrs)
-  where
-	-- Here's the reason we need to pass rec_subst to substIdBndr
-    (new_subst, new_bndrs) = mapAccumL (substIdBndr True {- keep fragile info -} new_subst) 
-			 	       subst bndrs
-\end{code}
-
-
-\begin{code}
-substIdBndr :: Bool		-- True <=> keep fragile info
-	 -> SimplEnv		-- Substitution to use for the IdInfo
-	 -> SimplEnv -> Id 	-- Substitition and Id to transform
-	 -> (SimplEnv, Id)	-- Transformed pair
+substIdBndr :: SimplEnv -> Id 	-- Substitition and Id to transform
+	    -> (SimplEnv, Id)	-- Transformed pair
 
 -- Returns with:
 --	* Unique changed if necessary
 --	* Type substituted
 -- 	* Unfolding zapped
 --	* Rules, worker, lbvar info all substituted 
---	* Occurrence info zapped if is_fragile_occ returns True
+--	* Fragile occurrence info zapped
 --	* The in-scope set extended with the returned Id
 --	* The substitution extended with a DoneId if unique changed
 --	  In this case, the var in the DoneId is the same as the
 --	  var returned
 
-substIdBndr keep_fragile rec_env 
-	    env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
+substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
 	    old_id
   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 	   seIdSubst = new_subst }, new_id)
@@ -481,7 +457,7 @@ substIdBndr keep_fragile rec_env
 	-- new_id has the right IdInfo
 	-- The lazy-set is because we're in a loop here, with 
 	-- rec_env, when dealing with a mutually-recursive group
-    new_id = maybeModifyIdInfo (substIdInfo keep_fragile rec_env) id2
+    new_id = maybeModifyIdInfo (substIdInfo env) id2
 
 	-- Extend the substitution if the unique has changed
 	-- See the notes with substTyVarBndr for the delSubstEnv
@@ -570,33 +546,24 @@ simplIdInfo :: SimplEnv -> IdInfo -> IdInfo
   -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
   -- subsequent to simplLetId having zapped its IdInfo
 simplIdInfo env old_info
-  = case substIdInfo False env old_info of 
+  = case substIdInfo env old_info of 
 	Just new_info -> new_info
 	Nothing       -> old_info
 
-substIdInfo :: Bool	-- True <=> keep even fragile info
-	    -> SimplEnv
+substIdInfo :: SimplEnv
 	    -> IdInfo
 	    -> Maybe IdInfo
--- The keep_fragile flag is True when we are running a simple expression
--- substitution that preserves all structure, so that arity and occurrence
--- info are unaffected.  The False state is used more often.
---
 -- Substitute the 
 --	rules
 --	worker info
 -- Zap the unfolding 
--- If keep_fragile then
---	keep OccInfo
---	keep Arity
--- else
---	keep only 'robust' OccInfo
---	zap Arity
+-- Keep only 'robust' OccInfo
+-- Zap Arity
 -- 
 -- Seq'ing on the returned IdInfo is enough to cause all the 
 -- substitutions to happen completely
 
-substIdInfo keep_fragile env info
+substIdInfo env info
   | nothing_to_do = Nothing
   | otherwise     = Just (info `setOccInfo`    	  (if keep_occ then old_occ else NoOccInfo)
 			       `setArityInfo`     (if keep_arity then old_arity else unknownArity)
@@ -612,8 +579,8 @@ substIdInfo keep_fragile env info
 		    not (workerExists old_wrkr) &&
 		    not (hasUnfolding (unfoldingInfo info))
     
-    keep_occ   = keep_fragile || not (isFragileOcc old_occ)
-    keep_arity = keep_fragile || old_arity == unknownArity
+    keep_occ   = not (isFragileOcc old_occ)
+    keep_arity = old_arity == unknownArity
     old_arity = arityInfo info
     old_occ   = occInfo info
     old_rules = specInfo info

ghc/compiler/simplCore/Simplify.lhs

@@ -1500,8 +1500,9 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont'
     simplBinders env tvs			`thenSmpl` \ (env1, tvs') ->
     let
 	pat_res_ty = dataConResTy con (mkTyVarTys tvs')
+	in_scope   = getInScope env1
     in
-    case coreRefineTys tvs' (error "urk") pat_res_ty (idType case_bndr') of {
+    case coreRefineTys in_scope tvs' pat_res_ty (idType case_bndr') of {
 	Nothing 	-- Dead code; for now, I'm just going to put in an
 			-- error case so I can see them
 	    ->	let rhs' = mkApps (Var eRROR_ID) 
@@ -1514,7 +1515,7 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont'
 	Just tv_subst_env -> 	-- The normal case
 
     let 
-	env2  = error "setTvSubstEnv" env1 tv_subst_env
+	env2 = refineSimplEnv env1 tv_subst_env tvs'
 	-- Simplify the Ids in the refined environment, so their types
 	-- reflect the refinement.  Usually this doesn't matter, but it helps
 	-- in mkDupableAlt, when we want to float a lambda that uses these binders

ghc/compiler/types/Type.lhs

@@ -67,11 +67,11 @@ module Type (
 	TvSubstEnv, emptyTvSubst,
 	mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
 	getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
-	extendTvSubst, extendTvSubstList, isInScope,
+ 	extendTvSubst, extendTvSubstList, isInScope, composeTvSubst,
 
 	-- Performing substitution on types
 	substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
-	deShadowTy,
+	deShadowTy, 
 
 	-- Pretty-printing
 	pprType, pprParendType, pprTyThingCategory,
@@ -1026,6 +1026,18 @@ type TvSubstEnv = TyVarEnv Type
 	-- So you have to look at the context to know if it's idempotent or
 	-- apply-once or whatever
 
+composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv
+-- (compose env1 env2)(x) is env1(env2(x)); i.e. apply env2 then env1
+-- It assumes that both are idempotent
+composeTvSubst in_scope env1 env2
+  = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2
+	-- First apply env1 to the range of env2
+	-- Then combine the two, making sure that env1 loses if
+	-- both bind the same variable; that's why env1 is the
+	-- *left* argument to plusVarEnv, becuause the right arg wins
+  where
+    subst1 = TvSubst in_scope env1
+
 emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
 isEmptyTvSubst :: TvSubst -> Bool
 isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env

ghc/compiler/types/Unify.lhs

@@ -198,25 +198,23 @@ gadtMatchTys ex_tvs subst tys1 tys2
   = initUM (bindOnly (mkVarSet ex_tvs)) (unify_tys subst tys1 tys2)
 
 ----------------------------
-coreRefineTys :: [TyVar]	-- Try to unify these
-	      -> TvSubst	-- A full-blown apply-once substitition
+coreRefineTys :: InScopeSet	-- Superset of free vars of either type
+	      -> [TyVar]	-- Try to unify these
 	      -> Type		-- Both types should be a fixed point 
 	      -> Type		--   of the incoming substitution
 	      -> Maybe TvSubstEnv	-- In-scope set is unaffected
 -- Used by Core Lint and the simplifier.  Takes a full apply-once substitution.
 -- The incoming substitution's in-scope set should mention all the variables free 
 -- in the incoming types
-coreRefineTys ex_tvs subst@(TvSubst in_scope orig_env) ty1 ty2
+coreRefineTys in_scope ex_tvs ty1 ty2
   = maybeErrToMaybe $ initUM (tryToBind (mkVarSet ex_tvs)) $
     do	{ 	-- Run the unifier, starting with an empty env
-	; extra_env <- unify emptyTvSubstEnv ty1 ty2
-
-		-- Find the fixed point of the resulting non-idempotent
-		-- substitution, and apply it to the incoming substitution
-	; let extra_subst     = TvSubst in_scope extra_env_fixpt
-	      extra_env_fixpt = mapVarEnv (substTy extra_subst) extra_env
-	      orig_env'	      = mapVarEnv (substTy extra_subst) orig_env
-	; return (orig_env' `plusVarEnv` extra_env_fixpt) }
+	; subst_env <- unify emptyTvSubstEnv ty1 ty2
+
+	-- Find the fixed point of the resulting non-idempotent substitution
+	; let subst  	      = TvSubst in_scope subst_env_fixpt
+	      subst_env_fixpt = mapVarEnv (substTy subst) subst_env
+	; return subst_env_fixpt }
 
 ----------------------------
 tcUnifyTys :: TyVarSet -> [Type] -> [Type] -> Maybe TvSubstEnv