[project @ 2002-07-29 12:22:37 by simonpj]

[ghc-hetmet.git] / ghc / compiler / rename / RnIfaces.lhs

diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index ba2b1cd..c591bb3 100644 (file)
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -42,7 +42,7 @@ import DataCon                ( dataConTyCon )
 import TyCon           ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName )
 import Class           ( className )
 import Name            ( Name {-instance NamedThing-}, nameOccName,
-                         nameModule, isLocalName, NamedThing(..)
+                         nameModule, isInternalName, NamedThing(..)
                         )
 import NameEnv                 ( elemNameEnv, delFromNameEnv, lookupNameEnv )
 import NameSet
@@ -59,7 +59,7 @@ import Maybe          ( isJust )
 import FiniteMap
 import Outputable
 import Bag
-import Util            ( sortLt )
+import Util            ( sortLt, seqList )
 \end{code}
 
 
@@ -242,7 +242,11 @@ mkImportInfo this_mod imports
            maybe_export_vers | import_all_mod = Just (vers_exports version_info)
                              | otherwise      = Nothing
     in
-    returnRn import_info
+
+    -- seq the list of ImportVersions returned: occasionally these
+    -- don't get evaluated for a while and we can end up hanging on to
+    -- the entire collection of Ifaces.
+    seqList import_info (returnRn import_info)
 \end{code}
 
 %*********************************************************
@@ -321,43 +325,42 @@ slurpSourceRefs source_fvs
 -------------------------------------------------------
 -- closeDecls keeps going until the free-var set is empty
 closeDecls decls needed
-  | not (isEmptyFVs needed)
-  = slurpDecls decls needed    `thenRn` \ (decls1, needed1) ->
-    closeDecls decls1 needed1
-
-  | otherwise
-  = getImportedRules                   `thenRn` \ rule_decls ->
+  = slurpIfaceDecls decls needed       `thenRn` \ decls1 ->
+    getImportedRules                   `thenRn` \ rule_decls ->
     case rule_decls of
-       []    -> returnRn decls -- No new rules, so we are done
+       []    -> returnRn decls1        -- No new rules, so we are done
        other -> rnIfaceDecls rnIfaceRuleDecl rule_decls        `thenRn` \ rule_decls' ->
                 let
                        rule_fvs = plusFVs (map ruleDeclFVs rule_decls')
                 in
-                traceRn (text "closeRules" <+> ppr rule_decls' $$ fsep (map ppr (nameSetToList rule_fvs)))     `thenRn_`
-                closeDecls (map RuleD rule_decls' ++ decls) rule_fvs
-
+                traceRn (text "closeRules" <+> ppr rule_decls' $$ 
+                         fsep (map ppr (nameSetToList rule_fvs)))      `thenRn_`
+                closeDecls (map RuleD rule_decls' ++ decls1) rule_fvs
                 
 
 -------------------------------------------------------
--- Augment decls with any decls needed by needed.
--- Return also free vars of the new decls (only)
-slurpDecls decls needed
-  = go decls emptyFVs (nameSetToList needed) 
+-- Augment decls with any decls needed by needed,
+-- and so on transitively
+slurpIfaceDecls :: [RenamedHsDecl] -> FreeVars -> RnMG [RenamedHsDecl]
+slurpIfaceDecls decls needed
+  = slurp decls (nameSetToList needed) 
   where
-    go decls fvs []         = returnRn (decls, fvs)
-    go decls fvs (ref:refs) = slurpDecl decls fvs ref  `thenRn` \ (decls1, fvs1) ->
-                             go decls1 fvs1 refs
-
--------------------------------------------------------
-slurpDecl decls fvs wanted_name
-  = importDecl wanted_name             `thenRn` \ import_result ->
-    case import_result of
-       -- Found a declaration... rename it
-       HereItIs decl -> rnIfaceTyClDecl decl           `thenRn` \ (new_decl, fvs1) ->
-                        returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs)
-
-       -- No declaration... (wired in thing, or deferred, or already slurped)
-       other -> returnRn (decls, fvs)
+    slurp decls []     = returnRn decls
+    slurp decls (n:ns) = slurp_one decls n     `thenRn` \ decls1 ->
+                        slurp decls1 ns
+
+    slurp_one decls wanted_name
+      = importDecl wanted_name                 `thenRn` \ import_result ->
+       case import_result of
+         HereItIs decl ->      -- Found a declaration... rename it
+                               -- and get the things it needs
+                  rnIfaceTyClDecl decl         `thenRn` \ (new_decl, fvs) ->
+                  slurp (TyClD new_decl : decls) (nameSetToList fvs)
+  
+         
+         other ->      -- No declaration... (wired in thing, or deferred, 
+                       --      or already slurped)
+                  returnRn decls
 
 
 -------------------------------------------------------
@@ -380,7 +383,7 @@ recordDeclSlurp ifaces@(Ifaces { iDecls  = (decls_map, n_slurped),
                                 iSlurp  = slurped_names, 
                                 iVSlurp = vslurp })
            avail
-  = ASSERT2( not (isLocalName (availName avail)), ppr avail )
+  = ASSERT2( not (isInternalName (availName avail)), ppr avail )
     ifaces { iDecls = (new_decls_map, n_slurped+1),
             iSlurp  = new_slurped_names, 
             iVSlurp = updateVSlurp vslurp (availName avail) }
@@ -512,6 +515,7 @@ getGates source_fvs decl
 
 get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon
 get_gates is_used (IfaceSig    {tcdType = ty})    = extractHsTyNames ty
+get_gates is_used (CoreDecl    {tcdType = ty})    = extractHsTyNames ty
 
 get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
   = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets`