[project @ 2001-03-14 15:26:00 by simonpj]

-------------------------------------
	Import more rules, and fix usage info
	-------------------------------------

1. A rule wasn't being slurped in that should have been.
Reason: wordToWord32# was in the 'TypeEnv', because it's a primop,
so the renamer thought it was already slurped in, which is true.
But it forgot to use the TypeEnv as a source of gates when deciding
which rules to pull in.  Result: a useful rule for the primop wasn't
making it in.  Thanks to Marcin for isolating this one.

2. RnIfaces.recordTypeEnvSlurp (was recordVSlurp) was blindly adding
the name to the iVSlurp set, but the iVSlurp set is supposed to contain
only "big" names (tycons, classes, and Ids that aren't data cons,
class ops etc).  We need to get the big name from the thing.
Mildly tiresomely, this means we have to keep the Class inside
the TyCon derived from that class.   Hence updates to TyCon and Class.

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 95904c9..a4c441e 100644 (file)
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -28,7 +28,7 @@ module HscTypes (
 
        ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..),
        PersistentRenamerState(..), IsBootInterface, DeclsMap,
-       IfaceInsts, IfaceRules, GatedDecl, IsExported,
+       IfaceInsts, IfaceRules, GatedDecl, GatedDecls, IsExported,
        NameSupply(..), OrigNameCache, OrigIParamCache,
        Avails, AvailEnv, GenAvailInfo(..), AvailInfo, RdrAvailInfo, 
        PersistentCompilerState(..),

diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index bb27937..5eb4e30 100644 (file)
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -34,9 +34,13 @@ import RnHiFiles     ( tryLoadInterface, loadHomeInterface,
 import RnSource                ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl )
 import RnEnv
 import RnMonad
-import Id              ( idType )
+import Id              ( idType, idName, globalIdDetails )
+import IdInfo          ( GlobalIdDetails(..) )
 import Type            ( namesOfType )
-import TyCon           ( isSynTyCon, getSynTyConDefn )
+import FieldLabel      ( fieldLabelTyCon )
+import DataCon         ( dataConTyCon )
+import TyCon           ( isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName )
+import Class           ( className )
 import Name            ( Name {-instance NamedThing-}, nameOccName,
                          nameModule, isLocalName, NamedThing(..)
                         )
@@ -50,7 +54,7 @@ import Module         ( Module, ModuleEnv,
                          elemModuleSet, extendModuleSet
                        )
 import PrelInfo                ( wiredInThingEnv )
-import Maybes          ( orElse )
+import Maybes          ( maybeToBool )
 import FiniteMap
 import Outputable
 import Bag
@@ -312,7 +316,28 @@ recordDeclSlurp ifaces@(Ifaces { iDecls  = (decls_map, n_slurped),
     new_decls_map     = foldl delFromNameEnv decls_map (availNames avail)
     new_slurped_names = addAvailToNameSet slurped_names avail
 
-recordVSlurp ifaces name = ifaces { iVSlurp = updateVSlurp (iVSlurp ifaces) name }
+
+-- recordTypeEnvSlurp is used when we slurp something that's
+-- already in the type environment, that was not slurped in an earlier compilation.
+-- We record it in the iVSlurp set, because that's used to
+-- generate usage information
+
+recordTypeEnvSlurp ifaces ty_thing
+  = ifaces { iVSlurp = updateVSlurp (iVSlurp ifaces) (get_main_name ty_thing) }
+  where
+       -- Tiresomely, we must get the "main" name for the 
+       -- thing, because that's what VSlurp contains, and what
+       -- is recorded in the usage information
+    get_main_name (AClass cl) = className cl
+    get_main_name (ATyCon tc)
+       | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas)
+        | otherwise                       = tyConName tc
+    get_main_name (AnId id)
+       = case globalIdDetails id of
+           DataConId     dc -> get_main_name (ATyCon (dataConTyCon dc))
+           DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc))
+           RecordSelId lbl  -> get_main_name (ATyCon (fieldLabelTyCon lbl))
+           other            -> idName id
 
 updateVSlurp (imp_mods, imp_names) main_name
   | isHomeModule mod = (imp_mods,                    addOneToNameSet imp_names main_name)
@@ -490,7 +515,11 @@ getImportedInstDecls gates
     getIfacesRn                                        `thenRn` \ ifaces ->
     getTypeEnvRn                                       `thenRn` \ lookup ->
     let
-       (decls, new_insts) = selectGated gates lookup (iInsts ifaces)
+       available n = n `elemNameSet` gates
+                  || case lookup n of { Just (AClass c) -> True; other -> False }
+               -- See "The gating story" above for the AClass thing
+
+       (decls, new_insts) = selectGated available (iInsts ifaces)
     in
     setIfacesRn (ifaces { iInsts = new_insts })                `thenRn_`
 
@@ -514,9 +543,11 @@ getImportedRules
   = getIfacesRn        `thenRn` \ ifaces ->
     getTypeEnvRn       `thenRn` \ lookup ->
     let
-       gates              = iSlurp ifaces      -- Anything at all that's been slurped
-       rules              = iRules ifaces
-       (decls, new_rules) = selectGated gates lookup rules
+               -- Slurp rules for anything that is slurped, 
+               -- either now or previously
+       gates              = iSlurp ifaces      
+       available n        = n `elemNameSet` gates || maybeToBool (lookup n)
+       (decls, new_rules) = selectGated available (iRules ifaces)
     in
     if null decls then
        returnRn []
@@ -526,9 +557,10 @@ getImportedRules
                  text "Slurped" <+> int (length decls) <+> text "rules"])   `thenRn_`
     returnRn decls
 
-selectGated gates lookup (decl_bag, n_slurped)
-       -- Select only those decls whose gates are *all* in 'gates'
-       -- or are a class in 'lookup'
+selectGated :: (Name->Bool) -> GatedDecls d
+           -> ([(Module,d)], GatedDecls d)
+selectGated available (decl_bag, n_slurped)
+       -- Select only those decls whose gates are *all* available
 #ifdef DEBUG
   | opt_NoPruneDecls   -- Just to try the effect of not gating at all
   = let
@@ -541,9 +573,6 @@ selectGated gates lookup (decl_bag, n_slurped)
   = case foldrBag select ([], emptyBag) decl_bag of
        (decls, new_bag) -> (decls, (new_bag, n_slurped + length decls))
   where
-    available n = n `elemNameSet` gates 
-               || case lookup n of { Just (AClass c) -> True; other -> False }
-
     select (reqd, decl) (yes, no)
        | all available reqd = (decl:yes, no)
        | otherwise          = (yes,      (reqd,decl) `consBag` no)
@@ -576,19 +605,16 @@ importDecl name
     getTypeEnvRn                       `thenRn` \ lookup ->
     case lookup name of {
        Just ty_thing 
-          | name `elemNameEnv` wiredInThingEnv
-          ->   -- When we find a wired-in name we must load its home
+           |   name `elemNameEnv` wiredInThingEnv
+           ->  -- When we find a wired-in name we must load its home
                -- module so that we find any instance decls lurking therein
                loadHomeInterface wi_doc name   `thenRn_`
                returnRn (InTypeEnv ty_thing)
 
-          | otherwise
-          ->   -- Record that we use this thing.  We must do this
-               --  regardless of whether we need to demand-slurp it in
-               --  or we already have it in the type environment.  Why?
-               --  because the slurp information is used to generate usage
-               --  information in the interface.
-               setIfacesRn (recordVSlurp ifaces (getName ty_thing))    `thenRn_`
+           |   otherwise
+           ->  -- Very important: record that we've seen it
+               -- See comments with recordTypeEnvSlurp
+               setIfacesRn (recordTypeEnvSlurp ifaces ty_thing)        `thenRn_`
                returnRn (InTypeEnv ty_thing) ;
 
        Nothing -> 

diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 4e59320..71db387 100644 (file)
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -276,6 +276,12 @@ data Ifaces = Ifaces {
        iSlurp :: NameSet,
                -- All the names (whether "big" or "small", whether wired-in or not,
                -- whether locally defined or not) that have been slurped in so far.
+               --
+               -- It's used for two things:
+               --      a) To record what we've already slurped, so
+               --         we can no-op if we try to slurp it again
+               --      b) As the 'gates' for importing rules.  We import a rule
+               --         if all its LHS free vars have been slurped
 
        iVSlurp :: (ModuleSet, NameSet)
                -- The Names are all the (a) non-wired-in

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 61c4ac4..857d0ab 100644 (file)
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -34,7 +34,7 @@ module TyCon(
        tyConTheta,
        tyConPrimRep,
        tyConArity,
-       isClassTyCon,
+       isClassTyCon, tyConClass_maybe,
        getSynTyConDefn,
 
         maybeTyConSingleCon,
@@ -55,6 +55,7 @@ import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon )
 
 
 import Var             ( TyVar, Id )
+import Class           ( Class )
 import BasicTypes      ( Arity, RecFlag(..), Boxity(..), 
                          isBoxed, EP(..) )
 import Name            ( Name, nameUnique, NamedThing(getName) )
@@ -119,7 +120,7 @@ data TyCon
                                        -- e.g. the TyCon for a Class dictionary,
                                        -- and TyCons with unboxed arguments
 
-       algTyConClass :: Bool           -- True if this tycon comes from a class declaration
+       algTyConClass :: Maybe Class    -- Just cl if this tycon came from a class declaration
     }
 
   | PrimTyCon {                -- Primitive types; cannot be defined in Haskell
@@ -252,7 +253,7 @@ mkAlgTyCon name kind tyvars theta argvrcs cons ncons sels flavour rec
        dataCons                = cons, 
        selIds                  = sels,
        noOfDataCons            = ncons,
-       algTyConClass           = False,
+       algTyConClass           = Nothing,
        algTyConFlavour         = flavour,
        algTyConRec             = rec,
        genInfo                 = gen_info
@@ -270,7 +271,7 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour
        dataCons                = [con],
        selIds                  = [],
        noOfDataCons            = 1,
-       algTyConClass           = True,
+       algTyConClass           = Just clas,
        algTyConFlavour         = flavour,
        algTyConRec             = NonRecursive,
        genInfo                 = Nothing
@@ -456,8 +457,12 @@ maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $
 
 \begin{code}
 isClassTyCon :: TyCon -> Bool
-isClassTyCon (AlgTyCon {algTyConClass = is_class_tycon}) = is_class_tycon
-isClassTyCon other_tycon                                = False
+isClassTyCon (AlgTyCon {algTyConClass = Just _}) = True
+isClassTyCon other_tycon                        = False
+
+tyConClass_maybe :: TyCon -> Maybe Class
+tyConClass_maybe (AlgTyCon {algTyConClass = maybe_clas}) = maybe_clas
+tyConClass_maybe ther_tycon                             = Nothing
 \end{code}