From 3990d44447b6c38a2effd68beb50da459dfd19fc Mon Sep 17 00:00:00 2001 From: partain Date: Mon, 6 May 1996 09:54:13 +0000 Subject: [PATCH] [project @ 1996-05-06 09:54:05 by partain] Sansom 1.3 changes through 960503 --- ghc/compiler/rename/ParseIface.y | 4 +- ghc/compiler/rename/ParseUtils.lhs | 25 +++--- ghc/compiler/rename/Rename.lhs | 2 +- ghc/compiler/rename/RnHsSyn.lhs | 5 ++ ghc/compiler/rename/RnIfaces.lhs | 151 +++++++++++++++++++++++++++--------- ghc/compiler/rename/RnNames.lhs | 41 +++++----- ghc/compiler/rename/RnSource.lhs | 24 +++--- 7 files changed, 167 insertions(+), 85 deletions(-) diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 790b802..bae7fda 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -19,7 +19,7 @@ import Name ( ExportFlag(..), mkTupNameStr, import Outputable -- ToDo:rm import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging import SrcLoc ( mkIfaceSrcLoc ) -import Util ( pprPanic{-ToDo:rm-} ) +import Util ( panic, pprPanic{-ToDo:rm-} ) ----------------------------------------------------------------- @@ -84,7 +84,7 @@ iface : INTERFACE CONID INTEGER exports_part inst_modules_part fixities_part decls_part instances_part pragmas_part { case $9 of { (tm, vm) -> - ParsedIface $2 (fromInteger $3) Nothing{-src version-} + ParsedIface $2 (panic "merge modules") (fromInteger $3) Nothing{-src version-} $4 -- usages $5 -- local versions $6 -- exports map diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs index 3283794..3d40da1 100644 --- a/ghc/compiler/rename/ParseUtils.lhs +++ b/ghc/compiler/rename/ParseUtils.lhs @@ -47,18 +47,19 @@ type PragmaStuff = String data ParsedIface = ParsedIface - Module -- Module name - Version -- Module version number - (Maybe Version) -- Source version number - UsagesMap -- Used when compiling this module - VersionsMap -- Version numbers of things from this module - ExportsMap -- Exported names - (Bag Module) -- Special instance modules - FixitiesMap -- fixities of local things - LocalTyDefsMap -- Local TyCon/Class names defined - LocalValDefsMap -- Local value names defined - (Bag RdrIfaceInst)-- Local instance declarations - LocalPragmasMap -- Pragmas for local names + Module -- Module name + (Bool, Bag Module) -- From a merging of these modules; True => merging occured + Version -- Module version number + (Maybe Version) -- Source version number + UsagesMap -- Used when compiling this module + VersionsMap -- Version numbers of things from this module + ExportsMap -- Exported names + (Bag Module) -- Special instance modules + FixitiesMap -- fixities of local things + LocalTyDefsMap -- Local TyCon/Class names defined + LocalValDefsMap -- Local value names defined + (Bag RdrIfaceInst) -- Local instance declarations + LocalPragmasMap -- Pragmas for local names ----------------------------------------------------------------- diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 4751fef..c5d1811 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -123,7 +123,7 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) multiple_occs (rn, (o1:o2:_)) = True multiple_occs _ = False in - return (rn_module, imp_mods, + return (rn_module, imp_mods, top_errs `unionBags` src_errs, top_warns `unionBags` src_warns `unionBags` listToBag occ_warns, occ_fm, export_fn) diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index ff88c4f..5107304 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -191,5 +191,10 @@ collectQualBinders quals collect (GeneratorQual pat _) = collectPatBinders pat collect (FilterQual expr) = [] collect (LetQual binds) = collectTopLevelBinders binds + +fixDeclName :: FixityDecl name -> name +fixDeclName (InfixL name i) = name +fixDeclName (InfixR name i) = name +fixDeclName (InfixN name i) = name \end{code} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index d2f62e4..0f09497 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -33,16 +33,15 @@ import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), VersionsMap(..), UsagesMap(..) ) -import Bag ( emptyBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList ) +import Bag ( emptyBag, unitBag, consBag, snocBag, + unionBags, unionManyBags, isEmptyBag, bagToList ) import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix ) import ErrUtils ( Error(..), Warning(..) ) -import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM, +import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, plusFM_C, eltsFM, fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-} ) import Maybes ( maybeToBool ) -import Name ( moduleNamePair, origName, isRdrLexCon, - RdrName(..){-instance NamedThing-} - ) +import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..) ) import PprStyle -- ToDo:rm import Outputable -- ToDo:rm import PrelInfo ( builtinNameInfo ) @@ -59,8 +58,11 @@ type ModuleToIfaceContents = FiniteMap Module ParsedIface type ModuleToIfaceFilePath = FiniteMap Module FilePath type IfaceCache - = MutableVar _RealWorld (ModuleToIfaceContents, - ModuleToIfaceFilePath) + = MutableVar _RealWorld + (ModuleToIfaceContents, -- interfaces for individual interface files + ModuleToIfaceContents, -- merged interfaces based on module name + -- used for extracting info about original names + ModuleToIfaceFilePath) \end{code} ********************************************************* @@ -145,16 +147,35 @@ Return cached info about a Module's interface; otherwise, read the interface (using our @ModuleToIfaceFilePath@ map to decide where to look). +Note: we have two notions of interface + * the interface for a particular file name + * the (combined) interface for a particular module name + +The idea is that two source files may declare a module +with the same name with the declarations being merged. + +This allows us to have file PreludeList.hs producing +PreludeList.hi but defining part of module Prelude. +When PreludeList is imported its contents will be +added to Prelude. In this way all the original names +for a particular module will be available the imported +decls are renamed. + +ToDo: Check duplicate definitons are the same. +ToDo: Check/Merge duplicate pragmas. + + \begin{code} -cachedIface :: IfaceCache +cachedIface :: Bool -- True => want merged interface for original name + -> IfaceCache -- False => want file interface only -> Module -> IO (MaybeErr ParsedIface Error) -cachedIface iface_cache mod - = readVar iface_cache `thenPrimIO` \ (iface_fm, file_fm) -> +cachedIface want_orig_iface iface_cache mod + = readVar iface_cache `thenPrimIO` \ (iface_fm, orig_fm, file_fm) -> case (lookupFM iface_fm mod) of - Just iface -> return (Succeeded iface) + Just iface -> return (want_iface iface orig_fm) Nothing -> case (lookupFM file_fm mod) of Nothing -> return (Failed (noIfaceErr mod)) @@ -166,9 +187,52 @@ cachedIface iface_cache mod Succeeded iface -> let iface_fm' = addToFM iface_fm mod iface + orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface in - writeVar iface_cache (iface_fm', file_fm) `seqPrimIO` - return (Succeeded iface) + writeVar iface_cache (iface_fm', orig_fm', file_fm) `seqPrimIO` + return (want_iface iface orig_fm') + where + want_iface iface orig_fm + | want_orig_iface + = case lookupFM orig_fm of + Nothing -> Failed (noOrigIfaceErr mod) + Just orig_iface -> Succeeded orig_iface + | otherwise + = Succeeded iface + + iface_mod (ParsedIface mod _ _ _ _ _ _ _ _ _ _ _ _) = mod + +---------- +mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1) + (ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2) + = pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)), + ppStr "merged with", ppPStr mod1]) $ + ASSERT(mod1 == mod2) + ParsedIface mod1 + (True, unionBags files1 files2) + (panic "mergeIface: module version numbers") + (panic "mergeIface: source version numbers") -- Version numbers etc must be extracted from + (panic "mergeIface: usage version numbers") -- the merged file interfaces named above + (panic "mergeIface: decl version numbers") + (panic "mergeIface: exports") + (panic "mergeIface: instance modules") + (plusFM_C (dup_merge "fixity" (ppr PprDebug . fixDeclName)) fixes1 fixes2) + (plusFM_C (dup_merge "tycon/class" (ppr PprDebug . idecl_nm)) tdefs1 tdefs2) + (plusFM_C (dup_merge "value" (ppr PprDebug . idecl_nm)) vdefs1 vdefs2) + (unionBags idefs1 idefs2) + (plusFM_C (dup_merge "pragma" ppStr) prags1 prags2) + where + dup_merge str ppr_dup dup1 dup2 + = pprTrace "mergeIfaces:" + (ppCat [ppPStr mod, ppPStr mod1, ppStr ": dup", ppStr str, ppStr "decl", + ppr_dup dup1, ppr_dup dup2]) $ + dup2 + + idecl_nm (TypeSig n _ _) = n + idecl_nm (NewTypeSig n _ _ _) = n + idecl_nm (DataSig n _ _ _ _) = n + idecl_nm (ClassSig n _ _ _) = n + idecl_nm (ValSig n _ _) = n ---------- cachedDecl :: IfaceCache @@ -176,14 +240,11 @@ cachedDecl :: IfaceCache -> RdrName -> IO (MaybeErr RdrIfaceDecl Error) --- ToDo: this is where the check for Prelude.map being --- located in PreludeList.map should be done ... - cachedDecl iface_cache class_or_tycon orig - = cachedIface iface_cache mod >>= \ maybe_iface -> + = cachedIface True iface_cache mod >>= \ maybe_iface -> case maybe_iface of Failed err -> return (Failed err) - Succeeded (ParsedIface _ _ _ _ _ exps _ _ tdefs vdefs _ _) -> + Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) -> case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of Just decl -> return (Succeeded decl) Nothing -> return (Failed (noDeclInIfaceErr mod str)) @@ -258,7 +319,10 @@ readIface file mod Right contents -> hPutStr stderr " parsing" >> let parsed = parseIface contents in hPutStr stderr " done\n" >> - return parsed + return (Succeeded (init_merge mod parsed)) + where + init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags) + = ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags \end{code} @@ -387,19 +451,26 @@ rnIfaces iface_cache imp_mods us -- pprTrace "do_decls:done:" (ppr PprDebug n) $ do_decls ns down to_return - Nothing -> -- OK, see what the cache has for us... + Nothing + | fst (moduleNamePair n) == modname -> + -- avoid looking in interface for the module being compiled + -- pprTrace "do_decls:this module error:" (ppr PprDebug n) $ + do_decls ns down (add_err (thisModImplicitErr modname n) to_return) - cachedDeclByType iface_cache n >>= \ maybe_ans -> - case maybe_ans of - Failed err -> -- add the error, but keep going: - -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $ - do_decls ns down (add_err err to_return) + | otherwise -> + -- OK, see what the cache has for us... - Succeeded iface_decl -> -- something needing renaming! - let + cachedDeclByType iface_cache n >>= \ maybe_ans -> + case maybe_ans of + Failed err -> -- add the error, but keep going: + -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $ + do_decls ns down (add_err err to_return) + + Succeeded iface_decl -> -- something needing renaming! + let (us1, us2) = splitUniqSupply (uniqsupply down) - in - case (initRn False{-iface-} modname (occenv down) us1 ( + in + case (initRn False{-iface-} modname (occenv down) us1 ( setExtraRn emptyUFM{-no fixities-} $ rnIfaceDecl iface_decl)) of { ((if_decl, if_defd, if_implicits), if_errs, if_warns) -> @@ -420,7 +491,7 @@ rnIfaces iface_cache imp_mods us add_implicits if_implicits $ add_errs if_errs $ add_warns if_warns to_return) - } + } ----------- type Go_Down = (RnEnv, -- stuff we already have defns for; @@ -575,19 +646,19 @@ sub (val_ment, tc_ment) (val_defds, tc_defds) \begin{code} cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error) cacheInstModules iface_cache imp_mods - = readVar iface_cache `thenPrimIO` \ (iface_fm, _) -> + = readVar iface_cache `thenPrimIO` \ (iface_fm, _, _) -> let imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ] (imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces))) - get_ims (ParsedIface _ _ _ _ _ _ ims _ _ _ _ _) = ims + get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims in - accumulate (map (cachedIface iface_cache) imp_imods) >>= \ err_or_ifaces -> + accumulate (map (cachedIface False iface_cache) imp_imods) >>= \ err_or_ifaces -> -- Sanity Check: -- Assert that instance modules given by direct imports contains -- instance modules extracted from all visited modules - readVar iface_cache `thenPrimIO` \ (all_iface_fm, _) -> + readVar iface_cache `thenPrimIO` \ (all_iface_fm, _, _) -> let all_ifaces = eltsFM all_iface_fm (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces)))) @@ -623,9 +694,9 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return = -- all the instance decls we might even want to consider -- are in the ParsedIfaces that are in our cache - readVar iface_cache `thenPrimIO` \ (iface_fm, _) -> + readVar iface_cache `thenPrimIO` \ (_, orig_iface_fm, _) -> let - all_ifaces = eltsFM iface_fm + all_ifaces = eltsFM orig_iface_fm all_insts = unionManyBags (map get_insts all_ifaces) interesting_insts = filter want_inst (bagToList all_insts) @@ -659,7 +730,7 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)) } where - get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ insts _) = insts + get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ _ insts _) = insts add_done_inst (InstSig clas tycon _ _) inst_env = addToFM_C (+) inst_env (tycon,clas) 1 @@ -728,9 +799,15 @@ finalIfaceInfo iface_cache if_final_env@((qual, unqual, tc_qual, tc_unqual), sta \begin{code} +thisModImplicitErr mod n sty + = ppCat [ppPStr SLIT("Implicit import of"), ppr sty n, ppPStr SLIT("when compiling"), ppPStr mod] + noIfaceErr mod sty = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod] +noOrigIfaceErr mod sty + = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod] + noDeclInIfaceErr mod str sty = ppBesides [ppPStr SLIT("Could not find interface declaration of: "), ppPStr mod, ppStr ".", ppPStr str] diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 27dd750..e106696 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -336,41 +336,44 @@ doImportDecls iface_cache g_info us src_imps i_info = (g_info, emptyFM, emptyFM, rec_imp_fn) in + -- cache the imported modules + -- this ensures that all directly imported modules + -- will have their original name iface in scope + accumulate (map (cachedIface False iface_cache) imp_mods) >> + + -- process the imports doImports iface_cache i_info us all_imps + ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) -> return (vals, tcs, imp_mods, unquals, fixes, errs, imp_warns `unionBags` warns) where - (src_qprels, ok_imps) = partition qual_prel src_imps - the_imps = ok_imps ++ prel_imp - all_imps = the_imps ++ qprel_imp + the_imps = implicit_prel ++ src_imps + all_imps = implicit_qprel ++ the_imps - qual_prel (ImportDecl mod qual imp_as _ _) - = fromPrelude mod && qual && not (maybeToBool imp_as) + implicit_qprel = if opt_NoImplicitPrelude + then [{- no "import qualified Prelude" -}] + else [ImportDecl pRELUDE True Nothing Nothing prel_loc] - explicit_prelude_import - = null [() | (ImportDecl mod qual _ _ _) <- ok_imps, fromPrelude mod] + explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, + mod == pRELUDE ]) - qprel_imp = if opt_NoImplicitPrelude - then [{-the flag really means it: *NO* implicit "import Prelude" -}] - else [ImportDecl pRELUDE True Nothing Nothing prel_loc] - - prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude - then - [{- no "import Prelude" -}] - else - [ImportDecl pRELUDE False Nothing Nothing prel_loc] + implicit_prel = if explicit_prelude_imp || opt_NoImplicitPrelude + then [{- no "import Prelude" -}] + else [ImportDecl pRELUDE False Nothing Nothing prel_loc] prel_loc = mkBuiltinSrcLoc (uniq_imps, imp_dups) = removeDups cmp_mod the_imps cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2 + qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- prel_imps ] + imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ] imp_warns = listToBag (map dupImportWarn imp_dups) `unionBags` - listToBag (map qualPreludeImportWarn src_qprels) + listToBag (map qualPreludeImportWarn qprel_imps) doImports iface_cache i_info us [] @@ -414,7 +417,7 @@ doImport :: IfaceCache Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) - = cachedIface iface_cache mod >>= \ maybe_iface -> + = cachedIface False iface_cache mod >>= \ maybe_iface -> case maybe_iface of Failed err -> return (emptyBag, emptyBag, emptyBag, emptyBag, @@ -618,7 +621,7 @@ getFixityDecl iface_cache rn = let (mod, str) = moduleNamePair rn in - cachedIface iface_cache mod >>= \ maybe_iface -> + cachedIface True iface_cache mod >>= \ maybe_iface -> case maybe_iface of Failed err -> return (Nothing, unitBag err) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index dd5be0c..0291b37 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -27,8 +27,8 @@ import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) import Name ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), nameImportFlag, RdrName, pprNonSym ) -import Outputable -- ToDo:rm -import PprStyle -- ToDo:rm +import Outputable -- ToDo:rm +import PprStyle -- ToDo:rm import PrelInfo ( consDataCon ) import Pretty import SrcLoc ( SrcLoc ) @@ -53,7 +53,7 @@ Checks the (..) etc constraints in the export list. \begin{code} -rnSource :: [Module] +rnSource :: [Module] -- imported modules -> Bag (Module,RnName) -- unqualified imports from module -> Bag RenamedFixityDecl -- fixity info for imported names -> RdrNameHsModule @@ -75,7 +75,7 @@ rnSource imp_mods unqual_imps imp_fixes all_fixes = src_fixes ++ bagToList imp_fixes all_fixes_fm = listToUFM (map pair_name all_fixes) - pair_name inf = (nameFixDecl inf, inf) + pair_name inf = (fixDeclName inf, inf) in setExtraRn all_fixes_fm $ @@ -544,7 +544,7 @@ rnFixes fixities = getSrcLocRn `thenRn` \ src_loc -> let (_, dup_fixes) = removeDups cmp_fix fixities - cmp_fix fix1 fix2 = nameFixDecl fix1 `cmp` nameFixDecl fix2 + cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2 rn_fixity fix@(InfixL name i) = rn_fixity_pieces InfixL name i fix @@ -563,10 +563,6 @@ rnFixes fixities mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_` mapRn rn_fixity fixities `thenRn` \ fixes_maybe -> returnRn (catMaybes fixes_maybe) - -nameFixDecl (InfixL name i) = name -nameFixDecl (InfixR name i) = name -nameFixDecl (InfixN name i) = name \end{code} %********************************************************* @@ -692,16 +688,16 @@ importAllErr rn locn badModExportErr mod locn = addShortErrLocLine locn (\ sty -> - ppCat [ ppStr "unknown module in export list:", ppPStr mod]) - -dupModExportWarn locn mods@(mod:_) - = addShortErrLocLine locn (\ sty -> - ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]) + ppCat [ ppStr "unknown module in export list: module", ppPStr mod]) emptyModExportWarn locn mod = addShortErrLocLine locn (\ sty -> ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]) +dupModExportWarn locn mods@(mod:_) + = addShortErrLocLine locn (\ sty -> + ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]) + derivingNonStdClassErr clas locn = addShortErrLocLine locn (\ sty -> ppCat [ppStr "non-standard class in deriving:", ppr sty clas]) -- 1.7.10.4