Skip to content

GitLab

Commit 3990d444 authored by partain's avatar partain
Browse files
Options

[project @ 1996-05-06 09:54:05 by partain] 

Sansom 1.3 changes through 960503
parent ca5a4a48
Hide whitespace changes
Inline Side-by-side
Showing with 167 additions and 85 deletions
ghc/compiler/rename/ParseIface.y
View file @ 3990d444
......@@ -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
......
ghc/compiler/rename/ParseUtils.lhs
View file @ 3990d444
......@@ -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
-----------------------------------------------------------------
......
ghc/compiler/rename/Rename.lhs
View file @ 3990d444
......@@ -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)
......
ghc/compiler/rename/RnHsSyn.lhs
View file @ 3990d444
......@@ -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}
ghc/compiler/rename/RnIfaces.lhs
View file @ 3990d444
......@@ -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]
......
ghc/compiler/rename/RnNames.lhs
View file @ 3990d444
......@@ -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)
......
ghc/compiler/rename/RnSource.lhs
View file @ 3990d444
......@@ -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])
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment