[project @ 1998-08-05 09:33:56 by simonpj]

Fix tyvar scope problem

diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs
index b0b39e3..5095994 100644 (file)
--- a/ghc/compiler/coreSyn/FreeVars.lhs
+++ b/ghc/compiler/coreSyn/FreeVars.lhs
@@ -6,7 +6,7 @@ Taken quite directly from the Peyton Jones/Lester paper.
 \begin{code}
 module FreeVars (
        -- Cheap and cheerful variant...
-       exprFreeVars,
+       exprFreeVars, exprFreeTyVars,
 
        -- Complicated and expensive variant for float-out
        freeVars,
@@ -31,11 +31,11 @@ import IdInfo               ( ArityInfo(..) )
 import PrimOp          ( PrimOp(..) )
 import Type            ( tyVarsOfType, Type )
 import TyVar           ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
-                         intersectTyVarSets,
+                         intersectTyVarSets, unionManyTyVarSets,
                          TyVarSet, TyVar
                        )
 import BasicTypes      ( Unused )
-import UniqSet         ( unionUniqSets, addOneToUniqSet )
+import UniqSet         ( unionUniqSets, addOneToUniqSet, delOneFromUniqSet )
 import Util            ( panic, assertPanic )
 
 \end{code}
@@ -77,6 +77,7 @@ aFreeTyVar t   = unitTyVarSet t
 is_among       = elementOfIdSet
 munge_id_ty  i = tyVarsOfType (idType i)
 combine               = unionUniqSets -- used both for {Id,TyVar}Sets
+without               = delOneFromUniqSet
 add           = addOneToUniqSet
 
 combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
@@ -450,3 +451,60 @@ id_fvs fv_cand in_scope v
   | fv_cand v                  = aFreeId v
   | otherwise                  = noFreeIds
 \end{code}
+
+
+\begin{code}
+exprFreeTyVars ::  CoreExpr -> TyVarSet
+exprFreeTyVars = expr_ftvs
+
+expr_ftvs :: CoreExpr -> TyVarSet
+expr_ftvs (Var v)        = noFreeTyVars
+expr_ftvs (Lit lit)      = noFreeTyVars
+expr_ftvs (Con con args) = args_ftvs args
+expr_ftvs (Prim op args) = args_ftvs args
+expr_ftvs (Note _ expr)  = expr_ftvs expr
+expr_ftvs (App fun arg)  = expr_ftvs fun `combine` arg_ftvs arg
+
+expr_ftvs (Lam (ValBinder b) body) = expr_ftvs body
+expr_ftvs (Lam (TyBinder b)  body) = expr_ftvs body `without` b
+
+expr_ftvs (Case scrut alts)
+  = expr_ftvs scrut `combine` alts_ftvs
+  where
+    alts_ftvs
+      = case alts of
+         AlgAlts alg_alts deflt -> unionManyTyVarSets (deflt_ftvs : alt_ftvs)
+           where
+             alt_ftvs   = map do_alg_alt alg_alts
+             deflt_ftvs = do_deflt deflt
+
+         PrimAlts prim_alts deflt -> unionManyTyVarSets (deflt_ftvs : alt_ftvs)
+           where
+             alt_ftvs   = map do_prim_alt prim_alts
+             deflt_ftvs = do_deflt deflt
+
+    do_alg_alt :: (Id, [Id], CoreExpr) -> TyVarSet
+    do_alg_alt (con, args, rhs) = expr_ftvs rhs
+
+    do_prim_alt (lit, rhs) = expr_ftvs rhs
+
+    do_deflt NoDefault          = noFreeTyVars
+    do_deflt (BindDefault b rhs) = expr_ftvs rhs
+
+expr_ftvs (Let (NonRec b r) body)
+  = bind_ftvs (b,r) `combine` expr_ftvs body
+
+expr_ftvs (Let (Rec pairs) body)
+  = foldr (combine . bind_ftvs) noFreeTyVars pairs `combine`
+    expr_ftvs body
+
+--------------------------------------
+bind_ftvs (b,e) = tyVarsOfType (idType b) `combine` expr_ftvs e
+
+--------------------------------------
+arg_ftvs (TyArg ty) = tyVarsOfType ty
+arg_ftvs other_arg  = noFreeTyVars
+
+--------------------------------------
+args_ftvs args = foldr (combine . arg_ftvs) noFreeTyVars args
+\end{code}

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 5d082ca..601ab87 100644 (file)
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -31,7 +31,7 @@ import TyVar          ( TyVar, mkTyVar, mkSysTyVar,
                        )
 import Kind            ( mkBoxedTypeKind )
 import CoreSyn
-import FreeVars                ( exprFreeVars )
+import FreeVars                ( exprFreeVars, exprFreeTyVars )
 import PprCore         ()      -- Instances 
 import Name            ( NamedThing(..), getSrcLoc, mkSysLocalName, isLocallyDefined )
 import SrcLoc          ( noSrcLoc )
@@ -965,8 +965,8 @@ plusUDList = foldr plusUDs emptyUDs
 
 mkDB dict rhs = (dict, rhs, db_ftvs, db_fvs)
              where
-               db_ftvs = tyVarsOfType (idType dict)    -- Superset of RHS fvs
-               db_fvs  = dictRhsFVs rhs
+               db_ftvs = exprFreeTyVars rhs
+               db_fvs  = exprFreeVars isLocallyDefined rhs
 
 addDictBind uds dict rhs = uds { dict_binds = mkDB dict rhs `consBag` dict_binds uds }
 
@@ -1092,9 +1092,6 @@ lookupId env id = case lookupIdEnv env id of
                        Nothing  -> id
                        Just id' -> id'
 
-dictRhsFVs :: CoreExpr -> IdSet
-dictRhsFVs e = exprFreeVars isLocallyDefined e
-
 addIdSpecialisations id spec_stuff
   = (if not (null errs) then
        pprTrace "Duplicate specialisations" (vcat (map ppr errs))