X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=f27dec8312d12c8337aaca859b2a8192b9451e46;hb=09845f43fee5d0843737bcfa70c4626751159a4d;hp=adc5a063db9579a6d6af318c9fb4804a1e870b7d;hpb=e4b0fab5a594c4ea29ddecdf216b4887420f26a4;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index adc5a06..f27dec8 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -22,7 +22,7 @@ import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, - mkIPName, isSystemName, + mkIPName, isSystemName, isWiredInName, nameOccName, setNameModule, nameModule, pprOccName, isLocallyDefined, nameUnique, nameOccName, occNameUserString, @@ -35,7 +35,7 @@ import OccName ( OccName, ) import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) import Type ( funTyCon ) -import Module ( ModuleName, mkThisModule, mkVanillaModule, moduleName ) +import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule ) import TyCon ( TyCon ) import FiniteMap import Unique ( Unique, Uniquable(..) ) @@ -57,8 +57,82 @@ import Maybes ( mapMaybe ) %********************************************************* \begin{code} -newImportedGlobalName :: ModuleName -> OccName -> Module -> RnM d Name -newImportedGlobalName mod_name occ mod +newLocalTopBinder :: Module -> OccName + -> (Name -> ExportFlag) -> SrcLoc + -> RnM d Name +newLocalTopBinder mod occ rec_exp_fn loc + = newTopBinder mod occ (\name -> setNameProvenance name (LocalDef loc (rec_exp_fn name))) + -- We must set the provenance of the thing in the cache + -- correctly, particularly whether or not it is locally defined. + -- + -- Since newLocalTopBinder is used only + -- at binding occurrences, we may as well get the provenance + -- dead right first time; hence the rec_exp_fn passed in + +newImportedBinder :: Module -> RdrName -> RnM d Name +newImportedBinder mod rdr_name + = ASSERT2( isUnqual rdr_name, ppr rdr_name ) + newTopBinder mod (rdrNameOcc rdr_name) (\name -> name) + -- Provenance is already implicitImportProvenance + +implicitImportProvenance = NonLocalDef ImplicitImport False + +newTopBinder :: Module -> OccName -> (Name -> Name) -> RnM d Name +newTopBinder mod occ set_prov + = -- First check the cache + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> + let + key = (moduleName mod, occ) + in + case lookupFM cache key of + + -- A hit in the cache! + -- Set the Module of the thing, and set its provenance (hack pending + -- spj update) + -- + -- It also means that if there are two defns for the same thing + -- in a module, then each gets a separate SrcLoc + -- + -- There's a complication for wired-in names. We don't want to + -- forget that they are wired in even when compiling that module + -- (else we spit out redundant defns into the interface file) + -- So for them we just set the provenance + + Just name -> let + new_name = set_prov (setNameModule name mod) + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_` + returnRn new_name + + -- Miss in the cache! + -- Build a completely new Name, and put it in the cache + Nothing -> let + (us', us1) = splitUniqSupply us + uniq = uniqFromSupply us1 + new_name = set_prov (mkGlobalName uniq mod occ implicitImportProvenance) + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` + returnRn new_name + + +mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name + -- Used for *occurrences*. We make a place-holder Name, really just + -- to agree on its unique, which gets overwritten when we read in + -- the binding occurence later (newImportedBinder) + -- The place-holder Name doesn't have the right Provenance, and its + -- Module won't have the right Package either + -- + -- This means that a renamed program may have incorrect info + -- on implicitly-imported occurrences, but the correct info on the + -- *binding* declaration. It's the type checker that propagates the + -- correct information to all the occurrences. + -- Since implicitly-imported names never occur in error messages, + -- it doesn't matter that we get the correct info in place till later, + -- (but since it affects DLL-ery it does matter that we get it right + -- in the end). +mkImportedGlobalName mod_name occ = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> let key = (mod_name, occ) @@ -70,7 +144,8 @@ newImportedGlobalName mod_name occ mod where (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 - name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport False) + mod = mkVanillaModule mod_name + name = mkGlobalName uniq mod occ implicitImportProvenance new_cache = addToFM cache key name updateProvenances :: [Name] -> RnM d () @@ -84,17 +159,7 @@ updateProvenances names where key = (moduleName (nameModule name), nameOccName name) -newImportedBinder :: Module -> RdrName -> RnM d Name -newImportedBinder mod rdr_name - = ASSERT2( isUnqual rdr_name, ppr rdr_name ) - newImportedGlobalName (moduleName mod) (rdrNameOcc rdr_name) mod --- Make an imported global name, checking first to see if it's in the cache -mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name -mkImportedGlobalName mod_name occ - = lookupModuleRn mod_name `thenRn` \ mod -> - newImportedGlobalName mod_name occ mod --(mkVanillaModule mod_name) - mkImportedGlobalFromRdrName :: RdrName -> RnM d Name mkImportedGlobalFromRdrName rdr_name | isQual rdr_name @@ -108,49 +173,6 @@ mkImportedGlobalFromRdrName rdr_name mkImportedGlobalName mod_name (rdrNameOcc rdr_name) -newLocalTopBinder :: Module -> OccName - -> (Name -> ExportFlag) -> SrcLoc - -> RnM d Name -newLocalTopBinder mod occ rec_exp_fn loc - = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> - let - key = (moduleName mod,occ) - mk_prov name = LocalDef loc (rec_exp_fn name) - -- We must set the provenance of the thing in the cache - -- correctly, particularly whether or not it is locally defined. - -- - -- Since newLocallyDefinedGlobalName is used only - -- at binding occurrences, we may as well get the provenance - -- dead right first time; hence the rec_exp_fn passed in - in - case lookupFM cache key of - - -- A hit in the cache! - -- Overwrite whatever provenance is in the cache already; - -- this updates WiredIn things and known-key things, - -- which are there from the start, to LocalDef. - -- - -- It also means that if there are two defns for the same thing - -- in a module, then each gets a separate SrcLoc - Just name -> let - new_name = setNameProvenance name (mk_prov new_name) - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_` - returnRn new_name - - -- Miss in the cache! - -- Build a new original name, and put it in the cache - Nothing -> let - (us', us1) = splitUniqSupply us - uniq = uniqFromSupply us1 - new_name = mkGlobalName uniq mod occ (mk_prov new_name) - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` - returnRn new_name - getIPName rdr_name = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> case lookupFM ipcache key of @@ -590,7 +612,7 @@ mkExportAvails mod_name unqual_imp name_env avails plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails plusExportAvails (m1, e1) (m2, e2) - = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2) + = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2) -- ToDo: wasteful: we do this once for each constructor! \end{code} @@ -599,12 +621,24 @@ plusExportAvails (m1, e1) (m2, e2) \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 -plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) +plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2)) -- Added SOF 4/97 #ifdef DEBUG plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2]) #endif +addAvail :: AvailEnv -> AvailInfo -> AvailEnv +addAvail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail + +emptyAvailEnv = emptyNameEnv +unitAvailEnv :: AvailInfo -> AvailEnv +unitAvailEnv a = unitNameEnv (availName a) a + +plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv +plusAvailEnv = plusNameEnv_C plusAvail + +availEnvElts = nameEnvElts + addAvailToNameSet :: NameSet -> AvailInfo -> NameSet addAvailToNameSet names avail = addListToNameSet names (availNames avail) @@ -658,20 +692,12 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail filterAvail ie avail = Nothing +pprAvail :: AvailInfo -> SDoc +pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of + [] -> empty + ns' -> parens (hsep (punctuate comma (map ppr ns'))) --- In interfaces, pprAvail gets given the OccName of the "host" thing -pprAvail avail = getPprStyle $ \ sty -> - if ifaceStyle sty then - ppr_avail (pprOccName . nameOccName) avail - else - ppr_avail ppr avail - -ppr_avail pp_name (AvailTC n ns) = hsep [ - pp_name n, - parens $ hsep $ punctuate comma $ - map pp_name ns - ] -ppr_avail pp_name (Avail n) = pp_name n +pprAvail (Avail n) = ppr n \end{code}