[project @ 2003-04-10 14:44:18 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / Subst.lhs

diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index 745f0a1..212e914 100644 (file)
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -28,10 +28,10 @@ module Subst (
 
        -- Type stuff
        mkTyVarSubst, mkTopTyVarSubst, 
-       substTyWith, substTy, substTheta,
+       substTyWith, substTy, substTheta, deShadowTy,
 
        -- Expression stuff
-       substExpr
+       substExpr, substRules
     ) where
 
 #include "HsVersions.h"
@@ -45,7 +45,7 @@ import CoreSyn                ( Expr(..), Bind(..), Note(..), CoreExpr,
 import CoreFVs         ( exprFreeVars )
 import TypeRep         ( Type(..), TyNote(..) )  -- friend
 import Type            ( ThetaType, SourceType(..), PredType,
-                         tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy
+                         tyVarsOfType, tyVarsOfTypes, mkAppTy, 
                        )
 import VarSet
 import VarEnv
@@ -249,12 +249,10 @@ zapSubstEnv :: Subst -> Subst
 zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
 
 extendSubst :: Subst -> Var -> SubstResult -> Subst
-extendSubst (Subst in_scope env) v r = UASSERT( case r of { DoneTy ty -> not (isUTy ty) ; _ -> True } )
-                                       Subst in_scope (extendSubstEnv env v r)
+extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
 
 extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
-extendSubstList (Subst in_scope env) v r = UASSERT( all (\ r1 -> case r1 of { DoneTy ty -> not (isUTy ty) ; _ -> True }) r )
-                                           Subst in_scope (extendSubstEnvList env v r)
+extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
 
 lookupSubst :: Subst -> Var -> Maybe SubstResult
 lookupSubst (Subst _ env) v = lookupSubstEnv env v
@@ -375,13 +373,21 @@ type TyVarSubst = Subst   -- TyVarSubst are expected to have range elements
 -- it'll never be evaluated
 mkTyVarSubst :: [TyVar] -> [Type] -> Subst
 mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys)) 
-                               (zip_ty_env tyvars tys emptySubstEnv)
+                               (zipTyEnv tyvars tys)
 
 -- mkTopTyVarSubst is called when doing top-level substitutions.
 -- Here we expect that the free vars of the range of the
 -- substitution will be empty.
 mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
-mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
+mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zipTyEnv tyvars tys)
+
+zipTyEnv tyvars tys
+#ifdef DEBUG
+  | length tyvars /= length tys
+  = pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv
+  | otherwise
+#endif
+  = zip_ty_env tyvars tys emptySubstEnv
 
 zip_ty_env []       []       env = env
 zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
@@ -409,6 +415,9 @@ substTy :: Subst -> Type  -> Type
 substTy subst ty | isEmptySubst subst = ty
                 | otherwise          = subst_ty subst ty
 
+deShadowTy :: Type -> Type             -- Remove any shadowing from the type
+deShadowTy ty = subst_ty emptySubst ty
+
 substTheta :: TyVarSubst -> ThetaType -> ThetaType
 substTheta subst theta
   | isEmptySubst subst = theta
@@ -440,8 +449,6 @@ subst_ty subst ty
                                        
     go (ForAllTy tv ty)                   = case substTyVar subst tv of
                                        (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
-
-    go (UsageTy u ty)              = mkUTy (go u) $! (go ty)
 \end{code}
 
 Here is where we invent a new binder if necessary.
@@ -744,7 +751,6 @@ substIdInfo subst is_fragile_occ info
   | otherwise     = Just (info `setOccInfo`              (if zap_occ then NoOccInfo else old_occ)
                               `setSpecInfo`      substRules  subst old_rules
                               `setWorkerInfo`    substWorker subst old_wrkr
-                              `setLBVarInfo`     substLBVar  subst old_lbv
                               `setUnfoldingInfo` noUnfolding)
                        -- setSpecInfo does a seq
                        -- setWorkerInfo does a seq
@@ -752,14 +758,12 @@ substIdInfo subst is_fragile_occ info
     nothing_to_do = not zap_occ && 
                    isEmptyCoreRules old_rules &&
                    not (workerExists old_wrkr) &&
-                   hasNoLBVarInfo old_lbv &&
                    not (hasUnfolding (unfoldingInfo info))
     
     zap_occ   = is_fragile_occ old_occ
     old_occ   = occInfo info
     old_rules = specInfo info
     old_wrkr  = workerInfo info
-    old_lbv   = lbvarInfo info
 
 ------------------
 substIdType :: Subst -> Id -> Id
@@ -824,10 +828,4 @@ substVarSet subst fvs
                            DoneEx expr     -> exprFreeVars expr
                            DoneTy ty       -> tyVarsOfType ty 
                            ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
-
-------------------
-substLBVar subst NoLBVarInfo    = NoLBVarInfo
-substLBVar subst (LBVarInfo ty) = ty1 `seq` LBVarInfo ty1
-                               where
-                                 ty1 = substTy subst ty
 \end{code}