From: simonpj Date: Tue, 8 Mar 2005 10:14:34 +0000 (+0000) Subject: [project @ 2005-03-08 10:14:32 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~951 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=2f17466f56b1f3e0aef92aed1aa7e307a3227515 [project @ 2005-03-08 10:14:32 by simonpj] Avoid losing location info for ghci; please merge --- diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index 90aac7b..d36dce4 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -4,7 +4,7 @@ module IfaceEnv ( newGlobalBinder, newIPName, newImplicitBinder, lookupIfaceTop, lookupIfaceExt, - lookupOrig, lookupIfaceTc, + lookupOrig, lookupAvail, lookupIfaceTc, newIfaceName, newIfaceNames, extendIfaceIdEnv, extendIfaceTyVarEnv, tcIfaceLclId, tcIfaceTyVar, @@ -18,7 +18,7 @@ module IfaceEnv ( import TcRnMonad import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName ) import TysWiredIn ( tupleTyCon, tupleCon ) -import HscTypes ( NameCache(..), HscEnv(..), OrigNameCache ) +import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..), OrigNameCache ) import TyCon ( TyCon, tyConName ) import DataCon ( dataConWorkId, dataConName ) import Var ( TyVar, Id, varName ) @@ -60,6 +60,7 @@ newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name newGlobalBinder mod occ mb_parent loc = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help + ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc) ; name_supply <- getNameCache ; let (name_supply', name) = allocateGlobalBinder name_supply mod occ @@ -74,12 +75,11 @@ allocateGlobalBinder allocateGlobalBinder name_supply mod occ mb_parent loc = case lookupOrigNameCache (nsNames name_supply) mod occ of -- A hit in the cache! We are at the binding site of the name. - -- This is the moment when we know the defining Module and SrcLoc + -- This is the moment when we know the defining parent and SrcLoc -- of the Name, so we set these fields in the Name we return. -- - -- This is essential, to get the right Module in a Name. - -- Also: then (bogus) multiple bindings of the same Name - -- get different SrcLocs can can be reported as such. + -- Then (bogus) multiple bindings of the same Name + -- get different SrcLocs can can be reported as such. -- -- Possible other reason: it might be in the cache because we -- encountered an occurrence before the binding site for an @@ -127,6 +127,35 @@ newImplicitBinder base_name mk_sys_occ Just parent_name -> parent_name Nothing -> base_name +lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name] +-- Find all the names arising from an import +-- Make sure the parent info is correct, even though we may not +-- yet have read the interface for this module +lookupAvail mod (Avail n) = do { n' <- lookupOrig mod n; + ; return [n'] } +lookupAvail mod (AvailTC p_occ occs) + = do { p_name <- lookupOrig mod p_occ + ; let lookup_sub occ | occ == p_occ = return p_name + | otherwise = lookup_orig mod occ (Just p_name) + ; mappM lookup_sub occs } + -- Remember that 'occs' is all the exported things, including + -- the parent. It's possible to export just class ops without + -- the class, via C( op ). If the class was exported too we'd + -- have C( C, op ) + + -- The use of lookupOrigSub here (rather than lookupOrig) + -- ensures that the subordinate names record their parent; + -- and that in turn ensures that the GlobalRdrEnv + -- has the correct parent for all the names in its range. + -- For imported things, we may only suck in the interface later, if ever. + -- Reason for all this: + -- Suppose module M exports type A.T, and constructor A.MkT + -- Then, we know that A.MkT is a subordinate name of A.T, + -- even though we aren't at the binding site of A.T + -- And it's important, because we may simply re-export A.T + -- without ever sucking in the declaration itself. + + lookupOrig :: Module -> OccName -> TcRnIf a b Name -- Even if we get a miss in the original-name cache, we -- make a new External Name. @@ -134,8 +163,11 @@ lookupOrig :: Module -> OccName -> TcRnIf a b Name -- SrcLoc to noSrcLoc -- Parent no Nothing -- They'll be overwritten, in due course, by LoadIface.loadDecl. +lookupOrig mod occ = lookup_orig mod occ Nothing -lookupOrig mod occ +lookup_orig :: Module -> OccName -> Maybe Name -> TcRnIf a b Name +-- Used when we know the parent of the thing we are looking up +lookup_orig mod occ mb_parent = do { -- First ensure that mod and occ are evaluated -- If not, chaos can ensue: -- we read the name-cache @@ -151,7 +183,7 @@ lookupOrig mod occ { let { (us', us1) = splitUniqSupply (nsUniqs name_supply) ; uniq = uniqFromSupply us1 - ; name = mkExternalName uniq mod occ Nothing noSrcLoc + ; name = mkExternalName uniq mod occ mb_parent noSrcLoc ; new_cache = extend_name_cache (nsNames name_supply) mod occ name ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} } diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index e5e7a5a..a760b83 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -24,15 +24,13 @@ import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName ) -import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc, - lookupOrig ) +import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc, lookupAvail ) import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats, ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv, lookupIfaceByModule, emptyPackageIfaceTable, IsBootInterface, mkIfaceFixCache, Gated, - implicitTyThings, addRulesToPool, addInstsToPool, - availNames + implicitTyThings, addRulesToPool, addInstsToPool ) import BasicTypes ( Version, Fixity(..), FixityDirection(..), @@ -120,9 +118,10 @@ loadHiBootInterface do { -- Load it (into the PTE), and return the exported names iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True - ; sequenceM [ lookupOrig mod_nm occ - | (mod,avails) <- mi_exports iface, - avail <- avails, occ <- availNames avail] + ; ns_s <- sequenceM [ lookupAvail mod_nm avail + | (mod,avails) <- mi_exports iface, + avail <- avails ] + ; return (concat ns_s) }}} where mk_doc mod = ptext SLIT("Need the hi-boot interface for") <+> ppr mod diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 8773732..a4c75eb 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -17,15 +17,14 @@ import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, ForeignDecl(..), HsGroup(..), HsBindGroup(..), Sig(..), collectGroupBinders, tyClDeclNames ) -import RnEnv -import IfaceEnv ( lookupOrig, newGlobalBinder ) +oimport RnEnv +import IfaceEnv ( lookupAvail ) import LoadIface ( loadSrcInterface ) import TcRnMonad import FiniteMap import PrelNames ( pRELUDE, isUnboundName, main_RDR_Unqual ) -import Module ( Module, moduleUserString, - unitModuleEnv, unitModuleEnv, +import Module ( Module, moduleUserString, unitModuleEnv, lookupModuleEnv, moduleEnvElts, foldModuleEnv ) import Name ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName, nameParent, nameParent_maybe, isExternalName, @@ -49,7 +48,7 @@ import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, isLocalGRE, pprNameProvenance ) import Outputable import Maybes ( isNothing, catMaybes, mapCatMaybes, seqMaybe, orElse ) -import SrcLoc ( noSrcLoc, Located(..), mkGeneralSrcSpan, +import SrcLoc ( Located(..), mkGeneralSrcSpan, unLoc, noLoc, srcLocSpan, combineSrcSpans, SrcSpan ) import BasicTypes ( DeprecTxt ) import ListSetOps ( removeDups ) @@ -252,34 +251,8 @@ exportsToAvails exports = foldlM do_one emptyNameSet exports where do_one acc (mod, exports) = foldlM (do_avail mod) acc exports - do_avail mod acc (Avail n) = do { n' <- lookupOrig mod n; - ; return (addOneToNameSet acc n') } - do_avail mod acc (AvailTC p_occ occs) - = do { p_name <- lookupOrig mod p_occ - ; ns <- mappM (lookup_sub p_name) occs - ; return (addListToNameSet acc ns) } - -- Remember that 'occs' is all the exported things, including - -- the parent. It's possible to export just class ops without - -- the class, via C( op ). If the class was exported too we'd - -- have C( C, op ) - where - lookup_sub parent occ - = newGlobalBinder mod occ mb_parent noSrcLoc - where - mb_parent | occ == p_occ = Nothing - | otherwise = Just parent - - -- The use of newGlobalBinder here (rather than lookupOrig) - -- ensures that the subordinate names record their parent; - -- and that in turn ensures that the GlobalRdrEnv - -- has the correct parent for all the names in its range. - -- For imported things, we may only suck in the interface later, if ever. - -- Reason for all this: - -- Suppose module M exports type A.T, and constructor A.MkT - -- Then, we know that A.MkT is a subordinate name of A.T, - -- even though we aren't at the binding site of A.T - -- And it's important, because we may simply re-export A.T - -- without ever sucking in the declaration itself. + do_avail mod acc avail = do { ns <- lookupAvail mod avail + ; return (addListToNameSet acc ns) } warnRedundantSourceImport mod_name = ptext SLIT("Unnecessary {- SOURCE -} in the import of module")