[project @ 2001-10-25 02:13:10 by sof]

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index f0c5950..b992ce1 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -52,12 +52,13 @@ import DataCon              ( classDataCon )
 import Class           ( Class, DefMeth(..), classBigSig )
 import Var             ( idName, idType )
 import VarSet          ( emptyVarSet )
+import Id              ( setIdLocalExported )
 import MkId            ( mkDictFunId )
 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 )
@@ -65,6 +66,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, 
@@ -329,7 +331,7 @@ get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods,
   | null groups                
   = returnTc [] -- The comon case: no generic default methods
 
-  | otherwise  -- A local class decl with generic default methods
+  | otherwise  -- A source class decl with generic default methods
   = recoverNF_Tc (returnNF_Tc [])                              $
     tcAddDeclCtxt decl                                         $
     tcLookupClass class_name                                   `thenTc` \ clas ->
@@ -347,7 +349,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_`
@@ -603,14 +605,22 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
 
        -- Create the result bindings
     let
+       local_dfun_id = setIdLocalExported dfun_id
+               -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
+
         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
@@ -642,7 +652,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`