[project @ 2000-10-31 12:07:43 by simonpj]

Improve MkIface; get ready for NameEnv.lhs

ghc/compiler/basicTypes/Name.lhs

@@ -29,7 +29,7 @@ module Name (
 	-- Environment
 	NameEnv, mkNameEnv,
 	emptyNameEnv, unitNameEnv, nameEnvElts, 
-	extendNameEnv_C, extendNameEnv, 
+	extendNameEnv_C, extendNameEnv, foldNameEnv,
 	plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList,
 	lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv, 
 
@@ -49,8 +49,8 @@ import RdrName		( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule )
 import CmdLineOpts	( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
 import SrcLoc		( builtinSrcLoc, noSrcLoc, SrcLoc )
 import Unique		( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 )
-import Maybes		( expectJust )
 import FastTypes
+import Maybes		( expectJust )
 import UniqFM
 import Outputable
 \end{code}
@@ -430,8 +430,10 @@ unitNameEnv    	 :: Name -> a -> NameEnv a
 lookupNameEnv  	 :: NameEnv a -> Name -> Maybe a
 lookupNameEnv_NF :: NameEnv a -> Name -> a
 mapNameEnv	 :: (a->b) -> NameEnv a -> NameEnv b
+foldNameEnv	 :: (a -> b -> b) -> b -> NameEnv a -> b
 
 emptyNameEnv   	 = emptyUFM
+foldNameEnv	 = foldUFM
 mkNameEnv	 = listToUFM
 nameEnvElts    	 = eltsUFM
 extendNameEnv_C  = addToUFM_C

ghc/compiler/codeGen/CodeGen.lhs

@@ -38,7 +38,6 @@ import Id               ( Id, idName )
 import Module           ( Module )
 import PrimRep		( PrimRep(..) )
 import TyCon            ( TyCon, isDataTyCon )
-import Class		( Class, classTyCon )
 import BasicTypes	( TopLevelFlag(..) )
 import UniqSupply	( mkSplitUniqSupply )
 import ErrUtils		( dumpIfSet_dyn )
@@ -55,12 +54,12 @@ codeGen :: DynFlags
 	    [CostCentre],	-- "extern" cost-centres needing declaring
 	    [CostCentreStack])  -- Pre-defined "singleton" cost centre stacks
 	-> [Id]			-- foreign-exported binders
-	-> [TyCon] -> [Class]	-- Local tycons and classes
+	-> [TyCon] 		-- Local tycons, including ones from classes
 	-> [(StgBinding,[Id])]	-- Bindings to convert, with SRTs
 	-> IO AbstractC		-- Output
 
 codeGen dflags mod_name imported_modules cost_centre_info fe_binders
-	tycons classes stg_binds
+	tycons stg_binds
   = mkSplitUniqSupply 'f'	>>= \ fl_uniqs  -> -- absC flattener
     let
 	datatype_stuff 	  = genStaticConBits cinfo data_tycons
@@ -82,9 +81,7 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders
     return flat_abstractC
 
   where
-    data_tycons = filter isDataTyCon (tycons ++ map classTyCon classes)
-			-- Generate info tables  for the data constrs arising
-			-- from class decls as well
+    data_tycons = filter isDataTyCon tycons
 
     maybe_split = if opt_EnsureSplittableC 
 		  then CSplitMarker 

ghc/compiler/deSugar/DsMonad.lhs

@@ -38,7 +38,8 @@ import UniqSupply	( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
 			  UniqSM, UniqSupply )
 import Unique		( Unique )
 import Util		( zipWithEqual )
-import Name		( Name, lookupNameEnv )
+import Name		( Name )
+import Name		( lookupNameEnv )
 import HscTypes		( HomeSymbolTable, PersistentCompilerState(..), 
 			  TyThing(..), TypeEnv, lookupType )
 import CmdLineOpts	( DynFlags )

ghc/compiler/main/CodeOutput.lhs

@@ -47,16 +47,15 @@ import IO		( IOMode(..), hClose, openFile, Handle )
 \begin{code}
 codeOutput :: DynFlags
 	   -> Module
-	   -> [TyCon] -> [Class]	-- Local tycons and classes
+	   -> [TyCon]			-- Local tycons
 	   -> [CoreBind]		-- Core bindings
 	   -> [(StgBinding,[Id])]	-- The STG program with SRTs
 	   -> SDoc 		-- C stubs for foreign exported functions
 	   -> SDoc		-- Header file prototype for foreign exported functions
 	   -> AbstractC		-- Compiled abstract C
-	   -> UniqSupply
 	   -> IO (Maybe FilePath, Maybe FilePath)
-codeOutput dflags mod_name tycons classes core_binds stg_binds 
-	   c_code h_code flat_abstractC ncg_uniqs
+codeOutput dflags mod_name tycons core_binds stg_binds 
+	   c_code h_code flat_abstractC
   = -- You can have C (c_output) or assembly-language (ncg_output),
     -- but not both.  [Allowing for both gives a space leak on
     -- flat_abstractC.  WDP 94/10]
@@ -67,7 +66,7 @@ codeOutput dflags mod_name tycons classes core_binds stg_binds
        stub_names <- outputForeignStubs dflags c_code h_code
        case dopt_HscLang dflags of
           HscInterpreted -> return stub_names
-          HscAsm         -> outputAsm dflags filenm flat_abstractC ncg_uniqs
+          HscAsm         -> outputAsm dflags filenm flat_abstractC
                             >> return stub_names
           HscC           -> outputC dflags filenm flat_abstractC	
                             >> return stub_names
@@ -104,15 +103,18 @@ outputC dflags filenm flat_absC
 %************************************************************************
 
 \begin{code}
-outputAsm dflags filenm flat_absC ncg_uniqs
+outputAsm dflags filenm flat_absC
 
 #ifndef OMIT_NATIVE_CODEGEN
 
-  = do dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
+  = do ncg_uniqs <- mkSplitUniqSupply 'n'
+       let
+	    (stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs
+       in
+       dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
        dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" ncg_output_d
        doOutput filenm ( \f -> printForAsm f ncg_output_d)
   where
-    (stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs
 
 #else /* OMIT_NATIVE_CODEGEN */
 

ghc/compiler/main/HscMain.lhs

@@ -57,7 +57,8 @@ import InterpSyn	( UnlinkedIBind )
 import StgInterp	( ItblEnv )
 import FiniteMap	( FiniteMap, plusFM, emptyFM, addToFM )
 import OccName		( OccName )
-import Name		( Name, nameModule, emptyNameEnv, nameOccName, getName  )
+import Name		( Name, nameModule, nameOccName, getName  )
+import Name		( emptyNameEnv )
 import Module		( Module, lookupModuleEnvByName )
 
 \end{code}
@@ -258,22 +259,22 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_
  = do (ibinds,itbl_env) 
          <- stgToInterpSyn (map fst stg_binds) local_tycons local_classes
       return (Nothing, Nothing, Just (ibinds,itbl_env))
+
  | otherwise
  = do --------------------------  Code generation -------------------------------
       show_pass dflags "CodeGen"
       -- _scc_     "CodeGen"
       abstractC <- codeGen dflags this_mod imported_modules
                            cost_centre_info fe_binders
-                           local_tycons local_classes stg_binds
+                           local_tycons stg_binds
 
       --------------------------  Code output -------------------------------
       show_pass dflags "CodeOutput"
       -- _scc_     "CodeOutput"
-      ncg_uniqs <- mkSplitUniqSupply 'n'
       (maybe_stub_h_name, maybe_stub_c_name)
-         <- codeOutput dflags this_mod local_tycons local_classes
+         <- codeOutput dflags this_mod local_tycons
                        oa_tidy_binds stg_binds
-                       c_code h_code abstractC ncg_uniqs
+                       c_code h_code abstractC
 
       return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
  where

ghc/compiler/main/HscTypes.lhs

@@ -45,11 +45,9 @@ module HscTypes (
 #include "HsVersions.h"
 
 import RdrName		( RdrNameEnv, emptyRdrEnv )
-import Name		( Name, NameEnv, NamedThing,
-			  emptyNameEnv, extendNameEnv, 
-			  lookupNameEnv, emptyNameEnv, nameEnvElts,
-			  isLocallyDefined, getName, nameModule,
-			  nameSrcLoc )
+import Name		( Name, NamedThing, isLocallyDefined, 
+			  getName, nameModule, nameSrcLoc )
+import Name -- Env
 import NameSet		( NameSet )
 import OccName		( OccName )
 import Module		( Module, ModuleName, ModuleEnv,

ghc/compiler/main/MkIface.lhs

@@ -42,10 +42,9 @@ import CoreSyn		( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule,
 import CoreFVs		( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
 import CoreUnfold	( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
 import Name		( isLocallyDefined, getName, 
-			  Name, NamedThing(..),
-			  plusNameEnv, lookupNameEnv, emptyNameEnv, mkNameEnv,
-			  extendNameEnv, lookupNameEnv_NF, nameEnvElts
+			  Name, NamedThing(..)
 			)
+import Name 	-- Env
 import OccName		( pprOccName )
 import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
 			  tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
@@ -84,6 +83,14 @@ mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
 	-- 	a) keeping the types and classes
 	--	b) removing all Ids, and Ids with correct IdInfo
 	--		gotten from the bindings
+	-- From (b) 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
+	--
+	-- However, we do keep things like constructors, which should not appear 
+	-- in interface files, because they are needed by importing modules when
+	-- using the compilation manager
     new_type_env = mkNameEnv [(getName tycl, tycl) | tycl <- orig_type_env, isTyClThing tycl]
 			`plusNameEnv`
 		   mkNameEnv [(idName id, AnId id) | id <- final_ids]
@@ -136,7 +143,7 @@ completeIface maybe_old_iface new_iface mod_details
 			      dcl_rules = rule_dcls }
 
      inst_dcls   = map ifaceInstance (md_insts mod_details)
-     ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types mod_details))
+     ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details)
      rule_dcls   = map ifaceRule (md_rules mod_details)
 \end{code}
 
@@ -148,19 +155,21 @@ completeIface maybe_old_iface new_iface mod_details
 %************************************************************************
 
 \begin{code}
-ifaceTyCls :: TyThing -> RenamedTyClDecl
-ifaceTyCls (AClass clas)
-  = ClassDecl (toHsContext sc_theta)
-	      (getName clas)
-	      (toHsTyVars clas_tyvars)
-	      (toHsFDs clas_fds)
-	      (map toClassOpSig op_stuff)
-	      EmptyMonoBinds
-	      [] noSrcLoc
+ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
+ifaceTyCls (AClass clas) so_far
+  = cls_decl : so_far
   where
-     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
+    cls_decl = ClassDecl (toHsContext sc_theta)
+			 (getName clas)		 
+			 (toHsTyVars clas_tyvars)
+			 (toHsFDs clas_fds)
+			 (map toClassOpSig op_stuff)
+			 EmptyMonoBinds
+			 [] noSrcLoc
+
+    (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
 
-     toClassOpSig (sel_id, def_meth)
+    toClassOpSig (sel_id, def_meth)
 	= ASSERT(sel_tyvars == clas_tyvars)
 	  ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
 	where
@@ -170,22 +179,26 @@ ifaceTyCls (AClass clas)
 			 GenDefMeth -> GenDefMeth
 			 DefMeth id -> DefMeth (getName id)
 
-ifaceTyCls (ATyCon tycon)
-  | isSynTyCon tycon
-  = TySynonym (getName tycon)(toHsTyVars tyvars) (toHsType ty) noSrcLoc
-  where
-    (tyvars, ty) = getSynTyConDefn tycon
-
-ifaceTyCls (ATyCon tycon)
-  | isAlgTyCon tycon
-  = TyData new_or_data (toHsContext (tyConTheta tycon))
-	   (getName tycon)
-	   (toHsTyVars tyvars)
-	   (map ifaceConDecl (tyConDataCons tycon))
-	   (tyConFamilySize tycon)
-	   Nothing noSrcLoc (panic "gen1") (panic "gen2")
+ifaceTyCls (ATyCon tycon) so_far
+  = ty_decl : so_far
+  
   where
-    tyvars = tyConTyVars tycon
+    ty_decl | isSynTyCon tycon
+	    = TySynonym (getName tycon)(toHsTyVars tyvars) 
+			(toHsType syn_ty) noSrcLoc
+
+	    | isAlgTyCon tycon
+	    = TyData new_or_data (toHsContext (tyConTheta tycon))
+		     (getName tycon)      
+		     (toHsTyVars tyvars)
+		     (map ifaceConDecl (tyConDataCons tycon))
+		     (tyConFamilySize tycon)
+		     Nothing noSrcLoc (panic "gen1") (panic "gen2")
+
+	    | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
+
+    tyvars      = tyConTyVars tycon
+    (_, syn_ty) = getSynTyConDefn tycon
     new_or_data | isNewTyCon tycon = NewType
 	        | otherwise	   = DataType
 
@@ -212,11 +225,12 @@ ifaceTyCls (ATyCon tycon)
     mk_field strict_mark field_label
 	= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
 
-ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
-
-ifaceTyCls (AnId id) 
-  = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
+ifaceTyCls (AnId id) so_far
+  | omitIfaceSigForId id = so_far
+  | otherwise 		 = iface_sig : so_far
   where
+    iface_sig = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
+
     id_type = idType id
     id_info = idInfo id
 
@@ -326,17 +340,11 @@ bindsToIds needed_ids codegen_ids binds
 	| otherwise 		     = emitted
 
     go needed (NonRec id rhs : binds) emitted
-	| need_id needed id
-	= if omitIfaceSigForId id then
-	    go (needed `delVarSet` id) binds (id:emitted)
-	  else
-	    go ((needed `unionVarSet` extras) `delVarSet` id)
-	       binds
-	       (new_id:emitted)
-	| otherwise
-	= go needed binds emitted
+	| need_id needed id = go new_needed binds (new_id:emitted)
+	| otherwise	    = go needed     binds emitted
 	where
 	  (new_id, extras) = mkFinalId codegen_ids False id rhs
+	  new_needed       = (needed `unionVarSet` extras) `delVarSet` id
 
 	-- Recursive groups are a bit more of a pain.  We may only need one to
 	-- start with, but it may call out the next one, and so on.  So we
@@ -369,12 +377,15 @@ bindsToIds needed_ids codegen_ids binds
 
 \begin{code}
 mkFinalId :: IdSet		-- The Ids with arity info from the code generator
-	  -> Bool			-- True <=> recursive, so don't include unfolding
+	  -> Bool		-- True <=> recursive, so don't include unfolding
 	  -> Id
 	  -> CoreExpr		-- The Id's right hand side
-	  -> (Id, IdSet)		-- The emitted id, plus any *extra* needed Ids
+	  -> (Id, IdSet)	-- The emitted id, plus any *extra* needed Ids
 
 mkFinalId codegen_ids is_rec id rhs
+  | omitIfaceSigForId id 
+  = (id, emptyVarSet)		-- An optimisation for top-level constructors and suchlike
+  | otherwise
   = (id `setIdInfo` new_idinfo, new_needed_ids)
   where
     core_idinfo = idInfo id

ghc/compiler/rename/Rename.lhs

@@ -39,8 +39,8 @@ import Module           ( Module, ModuleName, WhereFrom(..),
 import Name		( Name, NamedThing(..), getSrcLoc,
 			  nameIsLocalOrFrom,
 			  nameOccName, nameModule,
-			  mkNameEnv, nameEnvElts, extendNameEnv
 			)
+import Name		( mkNameEnv, nameEnvElts, extendNameEnv )
 import RdrName		( elemRdrEnv )
 import OccName		( occNameFlavour )
 import NameSet

ghc/compiler/rename/RnEnv.lhs

@@ -22,9 +22,9 @@ import Name		( Name, NamedThing(..),
 			  getSrcLoc, 
 			  mkLocalName, mkImportedLocalName, mkGlobalName,
 			  mkIPName, nameOccName, nameModule_maybe,
-			  extendNameEnv_C, plusNameEnv_C, nameEnvElts,
 			  setNameModuleAndLoc
 			)
+import Name		( extendNameEnv_C, plusNameEnv_C, nameEnvElts )
 import NameSet
 import OccName		( OccName, occNameUserString, occNameFlavour )
 import Module		( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS )

ghc/compiler/rename/RnHiFiles.lhs

@@ -42,8 +42,8 @@ import ParseIface	( parseIface, IfaceStuff(..) )
 import Name		( Name {-instance NamedThing-}, nameOccName,
 			  nameModule, isLocalName, nameIsLocalOrFrom,
 			  NamedThing(..),
-			  mkNameEnv, extendNameEnv
 			 )
+import Name		( mkNameEnv, extendNameEnv )
 import Module		( Module, 
 			  moduleName, isModuleInThisPackage,
 			  ModuleName, WhereFrom(..),

ghc/compiler/rename/RnIfaces.lhs

@@ -38,8 +38,8 @@ import TyCon		( isSynTyCon, getSynTyConDefn )
 import Name		( Name {-instance NamedThing-}, nameOccName,
 			  nameModule, isLocalName, nameUnique,
 			  NamedThing(..),
-			  elemNameEnv
 			 )
+import Name 		( elemNameEnv )
 import Module		( Module, ModuleEnv, 
 			  moduleName, isModuleInThisPackage,
 			  ModuleName, WhereFrom(..),

ghc/compiler/rename/RnMonad.lhs

@@ -54,10 +54,9 @@ import RdrName		( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
 			)
 import Name		( Name, OccName, NamedThing(..), getSrcLoc,
 			  nameOccName,
-			  decode, mkLocalName, mkKnownKeyGlobal,
-			  NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, 
-			  extendNameEnvList
+			  decode, mkLocalName, mkKnownKeyGlobal
 			)
+import Name		( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList )
 import Module		( Module, ModuleName, ModuleSet, emptyModuleSet )
 import NameSet		
 import CmdLineOpts	( DynFlags, DynFlag(..), dopt )

ghc/compiler/typecheck/TcClassDcl.lhs

@@ -43,9 +43,8 @@ import MkId		( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
 import DataCon		( mkDataCon, notMarkedStrict )
 import Id		( Id, idType, idName )
 import Module		( Module )
-import Name		( Name, NamedThing(..), isFrom,
-			  NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, 
-			  plusNameEnv, nameEnvElts )
+import Name		( Name, NamedThing(..), isFrom )
+import Name		( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
 import NameSet		( emptyNameSet )
 import Outputable
 import Type		( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred,

ghc/compiler/typecheck/TcEnv.lhs

@@ -60,10 +60,9 @@ import Class		( Class, ClassOpItem, ClassContext )
 import Subst		( substTy )
 import Name		( Name, OccName, NamedThing(..), 
 			  nameOccName, nameModule, getSrcLoc, mkGlobalName,
-			  isLocalName, nameModule_maybe,
-			  NameEnv, lookupNameEnv, nameEnvElts, 
-			  extendNameEnvList, emptyNameEnv
+			  isLocalName, nameModule_maybe
 			)
+import Name		( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv )
 import OccName		( mkDFunOcc, mkDefaultMethodOcc, occNameString )
 import HscTypes		( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv )
 import Module		( Module )

ghc/compiler/typecheck/TcModule.lhs

@@ -43,9 +43,8 @@ import Bag		( isEmptyBag )
 import ErrUtils		( printErrorsAndWarnings, dumpIfSet_dyn )
 import Id		( idType, idUnfolding )
 import Module           ( Module )
-import Name		( Name, isLocallyDefined, 
-			  toRdrName, nameEnvElts, lookupNameEnv, 
-			)
+import Name		( Name, isLocallyDefined, toRdrName )
+import Name		( nameEnvElts, lookupNameEnv )
 import TyCon		( tyConGenInfo )
 import Maybes		( thenMaybe )
 import Util

ghc/compiler/typecheck/TcTyClsDecls.lhs

@@ -39,9 +39,8 @@ import DataCon		( isNullaryDataCon )
 import Var		( varName )
 import FiniteMap
 import Digraph		( stronglyConnComp, SCC(..) )
-import Name		( Name, NamedThing(..), NameEnv, getSrcLoc, 
-			  mkNameEnv, lookupNameEnv_NF, isTyVarName
-			)
+import Name		( Name, NamedThing(..), getSrcLoc, isTyVarName )
+import Name		( NameEnv, mkNameEnv, lookupNameEnv_NF )
 import NameSet
 import Outputable
 import Maybes		( mapMaybe )

ghc/compiler/types/PprType.lhs

@@ -36,7 +36,7 @@ import Class		( Class )
 
 -- others:
 import Maybes		( maybeToBool )
-import Name		( getOccString )
+import Name		( getOccString, getOccName )
 import Outputable
 import PprEnv
 import Unique		( Uniquable(..) )
@@ -121,11 +121,10 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys)
 	-- 	type constructor (must be Boxed, Unboxed, AnyBox)
 	-- Otherwise print as (Type x)
     case ty1 of
-	TyConApp bx [] -> ppr bx
+	TyConApp bx [] -> ppr (getOccName bx)	-- Always unqualified
 	other	       -> maybeParen ctxt_prec tYCON_PREC 
 				     (sep [ppr tycon, nest 4 tys_w_spaces])
 		       
-	
 	-- TUPLE CASE (boxed and unboxed)
   |  isTupleTyCon tycon
   && length tys == tyConArity tycon	-- no magic if partially applied