[project @ 2001-11-23 12:06:49 by simonmar]

Use (DefMeth Name) rather than (DefMeth Id) in ClassOpItem.  This not
only eliminates a space leak, because Names generally hold on to much
less stuff than Ids, but also turns out to be a minor cleanup.

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index c375834..cdd2c7e 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -44,7 +44,7 @@ import Class          ( classTyVars, classBigSig, classTyCon, className,
                          Class, ClassOpItem, DefMeth (..) )
 import MkId            ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
 import DataCon         ( mkDataCon )
-import Id              ( idType, idName, setIdLocalExported )
+import Id              ( Id, idType, idName, setIdLocalExported )
 import Module          ( Module )
 import Name            ( Name, NamedThing(..) )
 import NameEnv         ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
@@ -223,32 +223,19 @@ tcClassSig unf_env clas clas_tyvars maybe_dm_env
 
     let
        theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
-       global_ty = mkSigmaTy clas_tyvars theta local_ty
-          -- The default method's type should really come from the
-          -- iface file, since it could be usage-generalised, but this
-          -- requires altering the mess of knots in TcModule and I'm
-          -- too scared to do that.  Instead, I have disabled generalisation
-          -- of types of default methods (and dict funs) by annotating them
-          -- TyGenNever (in MkId).  Ugh!  KSW 1999-09.
 
        -- Build the selector id and default method id
        sel_id = mkDictSelId op_name clas
-       dm_id  = mkDefaultMethodId dm_name global_ty
        DefMeth dm_name = sig_dm
 
        dm_info = case maybe_dm_env of
-                   Nothing     -> iface_dm_info
+                   Nothing     -> sig_dm
                    Just dm_env -> mk_src_dm_info dm_env
 
-       iface_dm_info = case sig_dm of 
-                         NoDefMeth       -> NoDefMeth
-                         GenDefMeth      -> GenDefMeth
-                         DefMeth dm_name -> DefMeth (tcAddImportedIdInfo unf_env dm_id)
-
        mk_src_dm_info dm_env = case lookupNameEnv dm_env op_name of
                                   Nothing    -> NoDefMeth
                                   Just True  -> GenDefMeth
-                                  Just False -> DefMeth dm_id
+                                  Just False -> DefMeth dm_name
     in
     returnTc (local_ty, (sel_id, dm_info))
 \end{code}
@@ -365,18 +352,19 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 each local class decl.
 
 \begin{code}
-tcClassDecls2 :: Module -> [RenamedTyClDecl] -> NF_TcM (LIE, TcMonoBinds)
+tcClassDecls2 :: Module -> [RenamedTyClDecl] -> NF_TcM (LIE, TcMonoBinds, [Id])
 
 tcClassDecls2 this_mod decls
   = foldr combine
-         (returnNF_Tc (emptyLIE, EmptyMonoBinds))
+         (returnNF_Tc (emptyLIE, EmptyMonoBinds, []))
          [tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls] 
                -- The 'Just' picks out source ClassDecls
   where
-    combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
-                     tc2 `thenNF_Tc` \ (lie2, binds2) ->
+    combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1, ids1) ->
+                     tc2 `thenNF_Tc` \ (lie2, binds2, ids2) ->
                      returnNF_Tc (lie1 `plusLIE` lie2,
-                                  binds1 `AndMonoBinds` binds2)
+                                  binds1 `AndMonoBinds` binds2,
+                                  ids1 ++ ids2)
 \end{code}
 
 @tcClassDecl2@ generates bindings for polymorphic default methods
@@ -384,12 +372,12 @@ tcClassDecls2 this_mod decls
 
 \begin{code}
 tcClassDecl2 :: RenamedTyClDecl                -- The class declaration
-            -> NF_TcM (LIE, TcMonoBinds)
+            -> NF_TcM (LIE, TcMonoBinds, [Id])
 
 tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, 
                         tcdMeths = Just default_binds, tcdLoc = src_loc})
   =    -- The 'Just' picks out source ClassDecls
-    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ 
+    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds, [])) $ 
     tcAddSrcLoc src_loc                                          $
     tcLookupClass class_name                             `thenNF_Tc` \ clas ->
 
@@ -406,13 +394,13 @@ tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs,
        prags                    = filter isPragSig sigs
        tc_dm                    = tcDefMeth clas tyvars default_binds prags
     in
-    mapAndUnzipTc tc_dm op_items       `thenTc` \ (defm_binds, const_lies) ->
+    mapAndUnzip3Tc tc_dm op_items      `thenTc` \ (defm_binds, const_lies, dm_ids_s) ->
 
-    returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
+    returnTc (plusLIEs const_lies, andMonoBindList defm_binds, concat dm_ids_s)
     
 
-tcDefMeth clas tyvars binds_in prags (_, NoDefMeth)  = returnTc (EmptyMonoBinds, emptyLIE)
-tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds, emptyLIE)
+tcDefMeth clas tyvars binds_in prags (_, NoDefMeth)  = returnTc (EmptyMonoBinds, emptyLIE, [])
+tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds, emptyLIE, [])
        -- Generate code for polymorphic default methods only
        -- (Generic default methods have turned into instance decls by now.)
        -- This is incompatible with Hugs, which expects a polymorphic 
@@ -420,11 +408,20 @@ tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds,
        -- the programmer supplied an explicit default decl for the class.  
        -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 
-tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id)
+tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
   = tcInstSigTyVars ClsTv tyvars                       `thenNF_Tc` \ clas_tyvars ->
     let
+       dm_ty = idType sel_id   -- Same as dict selector!
+          -- The default method's type should really come from the
+          -- iface file, since it could be usage-generalised, but this
+          -- requires altering the mess of knots in TcModule and I'm
+          -- too scared to do that.  Instead, I have disabled generalisation
+          -- of types of default methods (and dict funs) by annotating them
+          -- TyGenNever (in MkId).  Ugh!  KSW 1999-09.
+
        inst_tys    = mkTyVarTys clas_tyvars
         theta       = [mkClassPred clas inst_tys]
+       dm_id       = mkDefaultMethodId dm_name dm_ty
        local_dm_id = setIdLocalExported dm_id
                -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
     in
@@ -455,7 +452,7 @@ tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id)
                    emptyNameSet        -- No inlines (yet)
                    (dict_binds `andMonoBinds` defm_bind)
     in
-    returnTc (full_bind, const_lie)
+    returnTc (full_bind, const_lie, [dm_id])
   where
     origin = ClassDeclOrigin
 \end{code}
@@ -545,9 +542,9 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
      -- The user didn't supply a method binding, 
      -- so we have to make up a default binding
      -- The RHS of a default method depends on the default-method info
-mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_id)
+mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_name)
   =  -- An polymorphic default method
-    returnTc (HsVar (idName dm_id))
+    returnTc (HsVar dm_name)
 
 mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth
   =    -- No default method

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index ad07abc..6578580 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -534,7 +534,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
 
         (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
@@ -555,14 +554,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

diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs
index 2b7ce52..6181d4f 100644 (file)
--- a/ghc/compiler/types/Class.lhs
+++ b/ghc/compiler/types/Class.lhs
@@ -56,7 +56,7 @@ data Class
 type FunDep a    = ([a],[a])   --  e.g. class C a b c |  a b -> c, a c -> b  where ...
                                --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
 
-type ClassOpItem = (Id, DefMeth Id)
+type ClassOpItem = (Id, DefMeth Name)
        -- Selector function; contains unfolding
        -- Default-method info