From 5f67848a9c686f64bd4960a40a0e109f286df74b Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 31 Oct 2000 12:07:44 +0000 Subject: [PATCH] [project @ 2000-10-31 12:07:43 by simonpj] Improve MkIface; get ready for NameEnv.lhs --- ghc/compiler/basicTypes/Name.lhs | 6 +- ghc/compiler/codeGen/CodeGen.lhs | 9 +-- ghc/compiler/deSugar/DsMonad.lhs | 3 +- ghc/compiler/main/CodeOutput.lhs | 18 +++--- ghc/compiler/main/HscMain.lhs | 11 ++-- ghc/compiler/main/HscTypes.lhs | 8 +-- ghc/compiler/main/MkIface.lhs | 101 +++++++++++++++++-------------- ghc/compiler/rename/Rename.lhs | 2 +- ghc/compiler/rename/RnEnv.lhs | 2 +- ghc/compiler/rename/RnHiFiles.lhs | 2 +- ghc/compiler/rename/RnIfaces.lhs | 2 +- ghc/compiler/rename/RnMonad.lhs | 5 +- ghc/compiler/typecheck/TcClassDcl.lhs | 5 +- ghc/compiler/typecheck/TcEnv.lhs | 5 +- ghc/compiler/typecheck/TcModule.lhs | 5 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 5 +- ghc/compiler/types/PprType.lhs | 5 +- 17 files changed, 100 insertions(+), 94 deletions(-) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index eb66139..554c3bd 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 90bc8f9..8eab80e 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 bca30af..bf73147 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 3ce6bcd..51c5a08 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 7612f78..8d09e72 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 ccfddd5..3b0444f 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 8eec30d..6fbf4ae 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 c3a1e32..f080bd9 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 97f505e..5dcf056 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 ca381a3..26f905b 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 8d371ce..70844a0 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 12f4089..a1b9d77 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 d7da12c..67b17c4 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 04e679b..bf2ef1d 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 7edd70c..bc1a87d 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 4f4ac88..b92276e 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 fbd55bf..637ea1f 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 -- 1.7.10.4