[project @ 2001-11-26 09:20:25 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcInstDcls.lhs

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 540c92e..f171f16 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -23,10 +23,11 @@ import TcHsSyn              ( TcMonoBinds, mkHsConApp )
 import TcBinds         ( tcSpecSigs )
 import TcClassDcl      ( tcMethodBind, badMethodErr )
 import TcMonad       
-import TcMType         ( tcInstTyVars, checkValidTheta, checkValidInstHead, instTypeErr,
+import TcMType         ( tcInstSigTyVars, checkValidTheta, checkValidInstHead, instTypeErr, 
                          UserTypeCtxt(..), SourceTyCtxt(..) )
-import TcType          ( tcSplitDFunTy, mkClassPred, mkTyVarTy,
-                         tcSplitSigmaTy, tcSplitPredTy_maybe, getClassPredTys
+import TcType          ( tcSplitDFunTy, mkClassPred, mkTyVarTy, mkTyVarTys,
+                         tcSplitSigmaTy, tcSplitPredTy_maybe, getClassPredTys,
+                         TyVarDetails(..)
                        )
 import Inst            ( InstOrigin(..),
                          newDicts, instToId,
@@ -41,7 +42,8 @@ import TcEnv          ( TcEnv, tcExtendGlobalValEnv,
                        )
 import InstEnv         ( InstEnv, extendInstEnv )
 import PprType         ( pprClassPred )
-import TcMonoType      ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType, checkSigTyVars )
+import TcMonoType      ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType )
+import TcUnify         ( checkSigTyVars )
 import TcSimplify      ( tcSimplifyCheck )
 import HscTypes                ( HomeSymbolTable, DFunId,
                          ModDetails(..), PackageInstEnv, PersistentRenamerState
@@ -49,7 +51,7 @@ import HscTypes               ( HomeSymbolTable, DFunId,
 
 import Subst           ( substTy, substTheta )
 import DataCon         ( classDataCon )
-import Class           ( Class, DefMeth(..), classBigSig )
+import Class           ( Class, classBigSig )
 import Var             ( idName, idType )
 import VarSet          ( emptyVarSet )
 import Id              ( setIdLocalExported )
@@ -58,7 +60,7 @@ import FunDeps                ( checkInstFDs )
 import Generics                ( validGenericInstanceType )
 import Module          ( Module, foldModuleEnv )
 import Name            ( getSrcLoc )
-import NameSet         ( unitNameSet, nameSetToList )
+import NameSet         ( unitNameSet, emptyNameSet, nameSetToList )
 import PrelInfo                ( eRROR_ID )
 import TyCon           ( TyCon )
 import Subst           ( mkTopTyVarSubst, substTheta )
@@ -66,6 +68,7 @@ import TysWiredIn     ( genericTyCons )
 import Name             ( Name )
 import SrcLoc           ( SrcLoc )
 import Unique          ( Uniquable(..) )
+import Util             ( lengthExceeds )
 import BasicTypes      ( NewOrData(..), Fixity )
 import ErrUtils                ( dumpIfSet_dyn )
 import ListSetOps      ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, 
@@ -348,7 +351,7 @@ get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods,
        tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 
        bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
-                             length group > 1]
+                             group `lengthExceeds` 1]
        get_uniq (tc,_) = getUnique tc
     in
     mapTc (addErrTc . dupGenericInsts) bad_groups      `thenTc_`
@@ -523,15 +526,15 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
     let
        (inst_tyvars, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
     in
-    tcInstTyVars inst_tyvars           `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
+    tcInstSigTyVars InstTv inst_tyvars         `thenNF_Tc` \ inst_tyvars' ->
     let
+       tenv        = mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')
        inst_tys'   = map (substTy tenv) inst_tys
        dfun_theta' = substTheta tenv dfun_theta
        origin      = InstanceDeclOrigin
 
         (class_tyvars, sc_theta, _, op_items) = classBigSig clas
 
-       dm_ids    = [dm_id | (_, DefMeth dm_id) <- op_items]
        sel_names = [idName sel_id | (sel_id, _) <- op_items]
 
         -- Instantiate the super-class context with inst_tys
@@ -552,14 +555,15 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
        -- The type variable from the dict fun actually scope 
        -- over the bindings.  They were gotten from
        -- the original instance declaration
-       tcExtendGlobalValEnv dm_ids (
-               -- Default-method Ids may be mentioned in synthesised RHSs 
+
+               -- Default-method Ids may be mentioned in synthesised RHSs,
+               -- but they'll already be in the environment.
 
        mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
                                     dfun_theta'
                                     monobinds uprags True)
                       op_items
-    ))                 `thenTc` \ (method_binds_s, insts_needed_s, meth_insts) ->
+    )                  `thenTc` \ (method_binds_s, insts_needed_s, meth_insts) ->
 
        -- Deal with SPECIALISE instance pragmas by making them
        -- look like SPECIALISE pragmas for the dfun
@@ -610,11 +614,16 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
         dict_constr   = classDataCon clas
        scs_and_meths = map instToId (sc_dicts ++ meth_insts)
        this_dict_id  = instToId this_dict
-       inlines       = unitNameSet (idName dfun_id)
+       inlines       | null dfun_arg_dicts = emptyNameSet
+                     | otherwise           = unitNameSet (idName dfun_id)
                -- Always inline the dfun; this is an experimental decision
                -- because it makes a big performance difference sometimes.
                -- Often it means we can do the method selection, and then
                -- inline the method as well.  Marcin's idea; see comments below.
+               --
+               -- BUT: don't inline it if it's a constant dictionary;
+               -- we'll get all the benefit without inlining, and we get
+               -- a **lot** of code duplication if we inline it
 
        dict_rhs
          | null scs_and_meths
@@ -646,7 +655,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
          = AbsBinds
                 zonked_inst_tyvars
                 (map instToId dfun_arg_dicts)
-                [(inst_tyvars', dfun_id, this_dict_id)] 
+                [(inst_tyvars', local_dfun_id, this_dict_id)] 
                 inlines
                 (lie_binds1    `AndMonoBinds` 
                  lie_binds2    `AndMonoBinds`