[project @ 2000-11-14 11:25:22 by simonpj]

[ghc-hetmet.git] / ghc / compiler / main / MkIface.lhs

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index adf89db..9ff18cb 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -28,7 +28,7 @@ import HscTypes               ( VersionInfo(..), ModIface(..), ModDetails(..),
                        )
 
 import CmdLineOpts
-import Id              ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
+import Id              ( Id, idType, idInfo, omitIfaceSigForId, isExportedId, hasNoBinding,
                          idSpecialisation, idName, setIdInfo
                        )
 import Var             ( isId )
@@ -39,15 +39,13 @@ import CoreSyn              ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule,
                          isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules,
                          bindersOfBinds
                        )
-import CoreFVs         ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
+import CoreFVs         ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars, mustHaveLocalBinding )
 import CoreUnfold      ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
-import Name            ( isLocallyDefined, getName, 
-                         Name, NamedThing(..)
-                       )
+import Name            ( getName, nameModule, Name, NamedThing(..) )
 import Name    -- Env
 import OccName         ( pprOccName )
 import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
-                         tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
+                         tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
                        )
 import Class           ( classExtraBigSig, DefMeth(..) )
 import FieldLabel      ( fieldLabelType )
@@ -80,9 +78,10 @@ mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
   where
        -- The competed type environment is gotten from
        --      a) keeping the types and classes
-       --      b) removing all Ids, and Ids with correct IdInfo
+       --      b) removing all Ids, 
+       --      c) adding Ids with correct IdInfo, including unfoldings,
        --              gotten from the bindings
-       -- From (b) we keep only those Ids with Global names, plus Ids
+       -- From (c) we keep only those Ids with Global names, plus Ids
        --          accessible from them (notably via unfoldings)
        -- This truncates the type environment to include only the 
        -- exported Ids and things needed from them, which saves space
@@ -176,8 +175,8 @@ ifaceTyCls (AClass clas) so_far
                         DefMeth id -> DefMeth (getName id)
 
 ifaceTyCls (ATyCon tycon) so_far
-  = ty_decl : so_far
-  
+  | isClassTyCon tycon = so_far
+  | otherwise         = ty_decl : so_far
   where
     ty_decl | isSynTyCon tycon
            = TySynonym (getName tycon)(toHsTyVars tyvars) 
@@ -327,7 +326,7 @@ bindsToIds needed_ids codegen_ids binds
        -- The 'needed' set contains the Ids that are needed by earlier
        -- interface file emissions.  If the Id isn't in this set, and isn't
        -- exported, there's no need to emit anything
-    need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id 
+    need_id needed_set id = id `elemVarSet` needed_set || isExportedId id 
 
     go needed [] emitted
        | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" 
@@ -391,7 +390,7 @@ mkFinalId codegen_ids is_rec id rhs
                                    idInfo id
 
     new_idinfo | opt_OmitInterfacePragmas
-              = vanillaIdInfo
+              = constantIdInfo
               | otherwise                
               = core_idinfo `setArityInfo`      arity_info
                             `setCafInfo`        cafInfo stg_idinfo
@@ -478,7 +477,7 @@ mkFinalId codegen_ids is_rec id rhs
 
     find_fvs expr = exprSomeFreeVars interestingId expr
 
-interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
+interestingId id = isId id && mustHaveLocalBinding id
 \end{code}
 
 
@@ -612,9 +611,13 @@ diffDecls old_vers old_fixities new_fixities old new
 writeIface :: FilePath -> ModIface -> IO ()
 writeIface hi_path mod_iface
   = do { if_hdl <- openFile hi_path WriteMode
-       ; printForIface if_hdl (pprIface mod_iface)
+       ; printForIface if_hdl from_this_mod (pprIface mod_iface)
        ; hClose if_hdl
        }
+  where
+       -- Print names unqualified if they are from this module
+    from_this_mod n = nameModule n == this_mod
+    this_mod = mi_module mod_iface
         
 pprIface :: ModIface -> SDoc
 pprIface iface
@@ -721,10 +724,10 @@ pprDeprecs NoDeprecs = empty
 pprDeprecs deprecs   = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
                     where
                       guts = case deprecs of
-                               DeprecAll txt  -> ptext txt
+                               DeprecAll txt  -> doubleQuotes (ptext txt)
                                DeprecSome env -> pp_deprecs env
 
 pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
               where
-                pp_deprec (name, txt) = pprOcc name <+> ptext txt
+                pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ptext txt)
 \end{code}