Fix several bugs related to finding free variables

Now that coercion variables mention types, a type-lambda binder can
have free variables.  This patch adjusts the free-variable finder
to take account of this, by treating Ids and TyVars more uniformly.

In addition, I fixed a bug in the specialiser that was missing a
free type variable in a binder.  And a bug in tyVarsOfInst that
was missing the type variables in the kinds of the quantified tyvars.

diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index 566d502..cd21b9d 100644 (file)
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -7,7 +7,7 @@
 \begin{code}
 module Var (
        Var, 
-       varName, varUnique, 
+       varName, varUnique, varType,
        setVarName, setVarUnique, 
 
        -- TyVars
@@ -71,7 +71,7 @@ data Var
        realUnique :: FastInt,          -- Key for fast comparison
                                        -- Identical to the Unique in the name,
                                        -- cached here for speed
-       tyVarKind :: Kind,
+       varType       :: Kind,
         isCoercionVar :: Bool
  }
 
@@ -80,14 +80,14 @@ data Var
                                        -- inference, as well
        varName        :: !Name,
        realUnique     :: FastInt,
-       tyVarKind      :: Kind,
+       varType        :: Kind,
        tcTyVarDetails :: TcTyVarDetails }
 
   | GlobalId {                         -- Used for imported Ids, dict selectors etc
                                -- See Note [GlobalId/LocalId] below
        varName    :: !Name,    -- Always an External or WiredIn Name
        realUnique :: FastInt,
-       idType     :: Type,
+       varType    :: Type,
        idInfo_    :: IdInfo,
        gblDetails :: GlobalIdDetails }
 
@@ -95,7 +95,7 @@ data Var
                                -- See Note [GlobalId/LocalId] below
        varName    :: !Name,
        realUnique :: FastInt,
-       idType     :: Type,
+       varType    :: Type,
        idInfo_    :: IdInfo,
        lclDetails :: LocalIdDetails }
 
@@ -181,12 +181,13 @@ setVarName var new_name
 type TyVar = Var
 
 tyVarName = varName
+tyVarKind = varType
 
 setTyVarUnique = setVarUnique
 setTyVarName   = setVarName
 
 setTyVarKind :: TyVar -> Kind -> TyVar
-setTyVarKind tv k = tv {tyVarKind = k}
+setTyVarKind tv k = tv {varType = k}
 \end{code}
 
 \begin{code}
@@ -194,7 +195,7 @@ mkTyVar :: Name -> Kind -> TyVar
 mkTyVar name kind = ASSERT( not (isCoercionKind kind ) )
                    TyVar { varName    = name
                          , realUnique = getKey# (nameUnique name)
-                         , tyVarKind  = kind
+                         , varType  = kind
                           , isCoercionVar    = False
                        }
 
@@ -203,7 +204,7 @@ mkTcTyVar name kind details
   = ASSERT( not (isCoercionKind kind) )
     TcTyVar {  varName    = name,
                realUnique = getKey# (nameUnique name),
-               tyVarKind  = kind,
+               varType  = kind,
                tcTyVarDetails = details
        }
 \end{code}
@@ -226,7 +227,7 @@ mkCoVar :: Name -> Kind -> CoVar
 mkCoVar name kind = ASSERT( isCoercionKind kind )
                    TyVar { varName    = name
                          , realUnique = getKey# (nameUnique name)
-                         , tyVarKind  = kind
+                         , varType  = kind
                           , isCoercionVar    = True
                        }
 
@@ -237,7 +238,7 @@ mkWildCoVar kind
   = ASSERT( isCoercionKind kind )
     TyVar { varName = mkSysTvName wild_uniq FSLIT("co_wild"),
             realUnique = _ILIT(1),
-            tyVarKind = kind,
+            varType = kind,
             isCoercionVar = True }
   where
     wild_uniq = mkBuiltinUnique 1
@@ -259,6 +260,7 @@ type DictId = Id
 \begin{code}
 idName    = varName
 idUnique  = varUnique
+idType    = varType
 
 setIdUnique :: Id -> Unique -> Id
 setIdUnique = setVarUnique
@@ -267,7 +269,7 @@ setIdName :: Id -> Name -> Id
 setIdName = setVarName
 
 setIdType :: Id -> Type -> Id
-setIdType id ty = id {idType = ty}
+setIdType id ty = id {varType = ty}
 
 setIdExported :: Id -> Id
 -- Can be called on GlobalIds, such as data cons and class ops,
@@ -283,7 +285,7 @@ globaliseId :: GlobalIdDetails -> Id -> Id
 -- If it's a local, make it global
 globaliseId details id = GlobalId { varName    = varName id,
                                    realUnique = realUnique id,
-                                   idType     = idType id,
+                                   varType    = varType id,
                                    idInfo_    = idInfo id,
                                    gblDetails = details }
 
@@ -322,7 +324,7 @@ mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
 mkGlobalId details name ty info 
   = GlobalId { varName    = name, 
                realUnique = getKey# (nameUnique name),         -- Cache the unique
-               idType     = ty,        
+               varType     = ty,       
                gblDetails = details,
                idInfo_    = info }
 
@@ -330,7 +332,7 @@ mk_local_id :: Name -> Type -> LocalIdDetails -> IdInfo -> Id
 mk_local_id name ty details info
   = LocalId {  varName    = name, 
                realUnique = getKey# (nameUnique name),         -- Cache the unique
-               idType     = ty,        
+               varType     = ty,       
                lclDetails = details,
                idInfo_    = info }
 

diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index c32ca7c..bda9342 100644 (file)
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -13,7 +13,7 @@ module CoreFVs (
        exprSomeFreeVars, exprsSomeFreeVars,
        exprFreeNames, exprsFreeNames,
 
-       idRuleVars, idFreeVars, idFreeTyVars, 
+       idRuleVars, idFreeVars, varTypeTyVars, 
        ruleRhsFreeVars, rulesRhsFreeVars,
        ruleLhsFreeNames, ruleLhsFreeIds, 
 
@@ -138,10 +138,10 @@ keep_it fv_cand in_scope var
 
 addBndr :: CoreBndr -> FV -> FV
 addBndr bndr fv fv_cand in_scope
-  | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
-  | otherwise = inside_fvs
-  where
-    inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr) 
+  = someVars (varTypeTyVars bndr) fv_cand in_scope
+       -- Include type varibles in the binder's type
+       --      (not just Ids; coercion variables too!)
+    `unionVarSet`  fv fv_cand (in_scope `extendVarSet` bndr) 
 
 addBndrs :: [CoreBndr] -> FV -> FV
 addBndrs bndrs fv = foldr addBndr fv bndrs
@@ -318,18 +318,18 @@ delBinderFV :: Var -> VarSet -> VarSet
 --                       where
 --                         bottom = bottom -- Never evaluated
 
-delBinderFV b s | isId b    = (s `delVarSet` b) `unionFVs` idFreeVars b
-               | otherwise = s `delVarSet` b
+delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b
+       -- Include coercion variables too!
 
-idFreeVars :: Id -> VarSet
-idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
+varTypeTyVars :: Var -> TyVarSet
+-- Find the type variables free in the type of the variable
+-- Remember, coercion variables can mention type variables...
+varTypeTyVars var
+  | isLocalId var || isCoVar var = tyVarsOfType (idType var)
+  | otherwise = emptyVarSet    -- Global Ids and non-coercion TyVars
 
-idFreeTyVars :: Id -> TyVarSet
--- Only local Ids conjured up locally, can have free type variables.
--- (During type checking top-level Ids can have free tyvars)
-idFreeTyVars id = tyVarsOfType (idType id)
---  | isLocalId id = tyVarsOfType (idType id)
---  | otherwise    = emptyVarSet
+idFreeVars :: Id -> VarSet
+idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` varTypeTyVars id
 
 idRuleVars ::Id -> VarSet
 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
@@ -369,7 +369,6 @@ freeVars (App fun arg)
     arg2 = freeVars arg
 
 freeVars (Case scrut bndr ty alts)
--- gaw 2004
   = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
      AnnCase scrut2 bndr ty alts2)
   where
@@ -384,7 +383,8 @@ freeVars (Case scrut bndr ty alts)
                             rhs2 = freeVars rhs
 
 freeVars (Let (NonRec binder rhs) body)
-  = (freeVarsOf rhs2 `unionFVs` body_fvs,
+  = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` idRuleVars binder,
+               -- Remember any rules; cf rhs_fvs above
      AnnLet (AnnNonRec binder rhs2) body2)
   where
     rhs2     = freeVars rhs
@@ -392,16 +392,16 @@ freeVars (Let (NonRec binder rhs) body)
     body_fvs = binder `delBinderFV` freeVarsOf body2
 
 freeVars (Let (Rec binds) body)
-  = (foldl delVarSet group_fvs binders,
-       -- The "delBinderFV" part may have added one of the binders
-       -- via the idSpecVars part, so we must delete it again
+  = (delBindersFV binders all_fvs,
      AnnLet (AnnRec (binders `zip` rhss2)) body2)
   where
     (binders, rhss) = unzip binds
 
     rhss2     = map freeVars rhss
-    all_fvs   = foldr (unionFVs . fst) body_fvs rhss2
-    group_fvs = delBindersFV binders all_fvs
+    rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
+    all_fvs      = foldr (unionFVs . idRuleVars) rhs_body_fvs binders
+       -- The "delBinderFV" happens after adding the idSpecVars,
+       -- since the latter may add some of the binders as fvs
 
     body2     = freeVars body
     body_fvs  = freeVarsOf body2

diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 225dea5..5dbaec6 100644 (file)
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -771,8 +771,7 @@ absVarsOf dest_lvl (_, lvl_env, _, id_env) v
                        Just (abs_vars, _) -> abs_vars
                        Nothing            -> [v]
 
-    add_tyvars v | isId v    = v : varSetElems (idFreeTyVars v)
-                | otherwise = [v]
+    add_tyvars v = v : varSetElems (varTypeTyVars v)
 
        -- We are going to lambda-abstract, so nuke any IdInfo,
        -- and add the tyvars of the Id (if necessary)

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index fa9d253..86fd2fa 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -23,7 +23,7 @@ import VarSet
 import VarEnv
 import CoreSyn
 import CoreUtils       ( applyTypeToArgs, mkPiTypes )
-import CoreFVs         ( exprFreeVars, exprsFreeVars, idRuleVars )
+import CoreFVs         ( exprFreeVars, exprsFreeVars, idFreeVars )
 import CoreTidy                ( tidyRules )
 import CoreLint                ( showPass, endPass )
 import Rules           ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds )
@@ -1072,10 +1072,12 @@ bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs
                             bndrs = map fst prs
                             rhs_fvs = unionVarSets (map pair_fvs prs)
 
-pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idRuleVars bndr
+pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
        -- Don't forget variables mentioned in the
        -- rules of the bndr.  C.f. OccAnal.addRuleUsage
-
+       -- Also tyvars mentioned in its type; they may not appear in the RHS
+       --      type T a = Int
+       --      x :: T a = 3
 
 addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
 

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 49fba35..a11efe0 100644 (file)
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -161,12 +161,14 @@ ipNamesOfInst other                            = []
 tyVarsOfInst :: Inst -> TcTyVarSet
 tyVarsOfInst (LitInst {tci_ty = ty})  = tyVarsOfType  ty
 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
-tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
+tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
                                 -- The id might have free type variables; in the case of
                                 -- locally-overloaded class methods, for example
 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
-  = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) `minusVarSet` mkVarSet tvs
-
+  = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) 
+    `minusVarSet` mkVarSet tvs
+    `unionVarSet` unionVarSets (map varTypeTyVars tvs)
+               -- Remember the free tyvars of a coercion
 
 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 5fda4f4..e7fd6ca 100644 (file)
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -924,7 +924,7 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
   where
     bound_ids = collectPatsBinders pats
     show_ids = filter is_interesting bound_ids
-    is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
+    is_interesting id = any (`elemVarSet` varTypeTyVars id) bound_tvs
 
     ppr_id id ty = ppr id <+> dcolon <+> ppr ty
        -- Don't zonk the types so we get the separate, un-unified versions