X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=1cb95da528381c125b7cbcf5b60ee8b37bdfad2a;hb=b085ee40c7f265a5977ea6ec1c415e573be5ff8c;hp=6835f93a45007e38a8617bee943cc9e67ff3bda5;hpb=f587e76c3314fb89ba898b4c2aa2f5e5ef56c4f6;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 6835f93..1cb95da 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,6 +10,7 @@ module RnEnv where -- Export everything import {-# SOURCE #-} RnHiFiles +import FlattenInfo ( namesNeededForFlattening ) import HsSyn import RdrHsSyn ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, @@ -21,14 +22,14 @@ import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), - ModIface(..), + ModIface(..), GhciMode(..), Deprecations(..), lookupDeprec, extendLocalRdrEnv ) import RnMonad import Name ( Name, getSrcLoc, nameIsLocalOrFrom, - mkLocalName, mkGlobalName, + mkInternalName, mkExternalName, mkIPName, nameOccName, nameModule_maybe, setNameModuleAndLoc ) @@ -39,12 +40,12 @@ import Module ( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS, WhereFrom(..) ) import PrelNames ( mkUnboundName, derivingOccurrences, - mAIN_Name, pREL_MAIN_Name, - ioTyConName, intTyConName, + mAIN_Name, main_RDR_Unqual, + runMainName, intTyConName, boolTyConName, funTyConName, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, printName, - bindIOName, returnIOName, failIOName + bindIOName, returnIOName, failIOName, thenIOName ) import TysWiredIn ( unitTyCon ) -- A little odd import FiniteMap @@ -117,7 +118,7 @@ newTopBinder mod rdr_name loc Nothing -> let (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 - new_name = mkGlobalName uniq mod occ loc + new_name = mkExternalName uniq mod occ loc new_cache = addToFM cache key new_name in setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` @@ -160,7 +161,7 @@ newGlobalName mod_name occ (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 mod = mkVanillaModule mod_name - name = mkGlobalName uniq mod occ noSrcLoc + name = mkExternalName uniq mod occ noSrcLoc new_cache = addToFM cache key name newIPName rdr_name_ip @@ -210,12 +211,28 @@ lookupTopBndrRn rdr_name -- The parser reads the special syntax and returns an Orig RdrName -- But the global_env contains only Qual RdrNames, so we won't -- find it there; instead just get the name via the Orig route - = lookupOrigName rdr_name + -- + = -- This is a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + getModuleRn `thenRn` \ mod -> + checkRn (moduleName mod == rdrNameModule rdr_name) + (badOrigBinding rdr_name) `thenRn_` + lookupOrigName rdr_name | otherwise = getModeRn `thenRn` \ mode -> if isInterfaceMode mode - then lookupIfaceName rdr_name + then lookupSysBinder rdr_name + -- lookupSysBinder uses the Module in the monad to set + -- the correct module for the binder. This is important because + -- when GHCi is reading in an old interface, it just sucks it + -- in entire (Rename.loadHomeDecls) which uses lookupTopBndrRn + -- rather than via the iface file cache which uses newTopBndrRn + -- We must get the correct Module into the thing. + else getModuleRn `thenRn` \ mod -> getGlobalNameEnv `thenRn` \ global_env -> @@ -346,7 +363,9 @@ lookupSrcName global_env rdr_name lookupOrigName :: RdrName -> RnM d Name lookupOrigName rdr_name - = ASSERT( isOrig rdr_name ) + = -- NO: ASSERT( isOrig rdr_name ) + -- Now that .hi-boot files are read by the main parser, they contain + -- ordinary qualified names (which we treat as Orig names here). newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) lookupIfaceUnqual :: RdrName -> RnM d Name @@ -410,20 +429,16 @@ mentioned explicitly, but which might be needed by the type checker. \begin{code} getImplicitStmtFVs -- Compiling a statement - = returnRn (mkFVs [printName, bindIOName, returnIOName, failIOName] + = returnRn (mkFVs [printName, bindIOName, thenIOName, + returnIOName, failIOName] `plusFV` ubiquitousNames) -- These are all needed implicitly when compiling a statement -- See TcModule.tc_stmts -getImplicitModuleFVs mod_name decls -- Compiling a module +getImplicitModuleFVs decls -- Compiling a module = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> - returnRn (deriving_names `plusFV` implicit_main `plusFV` ubiquitousNames) + returnRn (deriving_names `plusFV` ubiquitousNames) where - -- Add occurrences for IO or PrimIO - implicit_main | mod_name == mAIN_Name - || mod_name == pREL_MAIN_Name = unitFV ioTyConName - | otherwise = emptyFVs - -- deriv_classes is now a list of HsTypes, so a "normal" one -- appears as a (HsClassP c []). The non-normal ones for the new -- newtype-deriving extension, and they don't require any @@ -444,6 +459,34 @@ ubiquitousNames -- Add occurrences for very frequently used types. -- (e.g. we don't want to be bothered with making funTyCon a -- free var at every function application!) + `plusFV` + namesNeededForFlattening + -- this will be empty unless flattening is activated + +checkMain ghci_mode mod_name gbl_env + -- LOOKUP main IF WE'RE IN MODULE Main + -- The main point of this is to drag in the declaration for 'main', + -- its in another module, and for the Prelude function 'runMain', + -- so that the type checker will find them + -- + -- We have to return the main_name separately, because it's a + -- bona fide 'use', and should be recorded as such, but the others + -- aren't + | mod_name /= mAIN_Name + = returnRn (Nothing, emptyFVs, emptyFVs) + + | not (main_RDR_Unqual `elemRdrEnv` gbl_env) + = complain_no_main `thenRn_` + returnRn (Nothing, emptyFVs, emptyFVs) + + | otherwise + = lookupSrcName gbl_env main_RDR_Unqual `thenRn` \ main_name -> + returnRn (Just main_name, unitFV main_name, unitFV runMainName) + + where + complain_no_main | ghci_mode == Interactive = addWarnRn noMainMsg + | otherwise = addErrRn noMainMsg + -- In interactive mode, only warn about the absence of main \end{code} %************************************************************************ @@ -504,7 +547,7 @@ newLocalsRn rdr_names_w_loc let (us', us1) = splitUniqSupply (nsUniqs name_supply) uniqs = uniqsFromSupply us1 - names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc + names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs ] in @@ -560,7 +603,7 @@ bindCoreLocalRn rdr_name enclosed_scope let (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 - name = mkLocalName uniq (rdrNameOcc rdr_name) loc + name = mkInternalName uniq (rdrNameOcc rdr_name) loc in setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` let @@ -1009,11 +1052,17 @@ shadowedNameWarn shadow quotes (ppr shadow), ptext SLIT("shadows an existing binding")] +noMainMsg = ptext SLIT("No 'main' defined in module Main") + unknownNameErr name = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] where flavour = occNameFlavour (rdrNameOcc name) +badOrigBinding name + = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) + -- The rdrNameOcc is because we don't want to print Prelude.(,) + qualNameErr descriptor (name,loc) = pushSrcLocRn loc $ addErrRn (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name),