diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index eb66139f52618794c2468a85df8ea47978e63025..554c3bdc6ce65c68f50272f31c97d1712f37317a 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/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
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 90bc8f94a1296a74f3e2792cebc57e0cf8a9c2b0..8eab80e904a7d7ed786e0f4b5379eb4e99cf3a5c 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/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
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index bca30af92b2f060ece64af2e7ac470ba74405754..bf73147772adc9521df45a53efd878ed758aad10 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/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 )
diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 3ce6bcd77524a2d1535227f976927e8c1ed305a8..51c5a08f116e0630502eb369e2f4ad40c8da31d6 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/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 */
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 7612f78f4c9a63653353a2edaad412b8a5f43907..8d09e720b3279dea2da9a756ac86bfc358bb8ef6 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/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
diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index ccfddd5e5115cdc913dc74b4a82fc372df7623ed..3b0444fb281e4e76977d6eafbbafdb411b2fd60e 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/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,
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 8eec30d61434fdb0c02a37bf27d1f61dee69adab..6fbf4ae5a00d250d68033925c85dbf13e0aa3db1 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/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
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index c3a1e3209a47bf9a0fe2beed758de151e47af416..f080bd942ef0c320444e181e11153926c64e6c9e 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/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
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 97f505e673166c37e12de3f2585f058473ee36d6..5dcf056081f763984a3ebb8ed2e96fdfde5ca5f3 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/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 )
diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs
index ca381a37ba1bce113a419eaec7449c793f36713d..26f905b17a20ae880a1be576d627c0a46bfd0628 100644
--- a/ghc/compiler/rename/RnHiFiles.lhs
+++ b/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(..),
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 8d371ceac936f5f5756e441bdcba3cf9fb805713..70844a07c101e854072763c4adef8aab28da03f6 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/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(..),
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 12f40893c22f7d6fdca34336eb3df473118873fd..a1b9d7732d0210931b30139aad40c9c727e22acc 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/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 )
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index d7da12c6223242ef99be8b5d5ced166ad3588262..67b17c470efc316cc2dd490040473a245d42a29c 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/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,
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 04e679b9d3cd85e0f271bc33bf1e93973b031d28..bf2ef1d3d0876c99a27dc70a4b94d80529165311 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/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 )
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 7edd70c38b1b9df2d0d2d71ef68d98c5b51d59ac..bc1a87d09a699b870b0d16336817ef73c4ce82a1 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/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
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 4f4ac881f2b32be277ca6ead4f0d9c55bcbdcf49..b92276e023576a47af6b11bfd579cda0f66bc908 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/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 )
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index fbd55bf1155a525e0e73116621a048645926dd1f..637ea1f812ba5e49004ab5078633924ec796be8a 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/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