From: simonpj Date: Mon, 30 Oct 2000 09:52:16 +0000 (+0000) Subject: [project @ 2000-10-30 09:52:14 by simonpj] X-Git-Tag: Approximately_9120_patches~3470 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=2ecf1c9f639dc75f1078e88c2e551116923f742a;p=ghc-hetmet.git [project @ 2000-10-30 09:52:14 by simonpj] First steps to making it work --- diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 1dd74cb..293ec5c 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.101 2000/10/27 16:30:02 simonmar Exp $ +# $Id: Makefile,v 1.102 2000/10/30 09:52:14 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -366,7 +366,7 @@ parser/Parser.hs : parser/Parser.y #----------------------------------------------------------------------------- # Linking -SRC_LD_OPTS += -no-link-chk -ldl +SRC_LD_OPTS += -no-link-chk ifneq "$(GhcWithHscBuiltViaC)" "YES" ifeq "$(GhcReportCompiles)" "YES" diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 2eeb949..84e8655 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -16,7 +16,8 @@ module Name ( nameUnique, setNameUnique, setLocalNameSort, tidyTopName, - nameOccName, nameModule, setNameOcc, nameRdrName, setNameModuleAndLoc, + nameOccName, nameModule, nameModule_maybe, + setNameOcc, nameRdrName, setNameModuleAndLoc, toRdrName, hashName, isUserExportedName, @@ -43,13 +44,10 @@ module Name ( import OccName -- All of it import Module ( Module, moduleName, mkVanillaModule, printModulePrefix, isModuleInThisPackage ) -import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, - rdrNameModule ) -import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, - opt_OmitInterfacePragmas, opt_EnsureSplittableC ) - +import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) +import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc ) -import Unique ( Unique, Uniquable(..), u2i, pprUnique ) +import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 ) import Maybes ( expectJust ) import FastTypes import UniqFM @@ -114,8 +112,12 @@ nameSrcLoc :: Name -> SrcLoc nameUnique name = n_uniq name nameOccName name = n_occ name nameSrcLoc name = n_loc name + nameModule (Name { n_sort = Global mod }) = mod nameModule name = pprPanic "nameModule" (ppr name) + +nameModule_maybe (Name { n_sort = Global mod }) = Just mod +nameModule_maybe name = Nothing \end{code} \begin{code} @@ -297,16 +299,23 @@ are exported. But also: \begin{code} tidyTopName :: Module -> TidyOccEnv -> Name -> (TidyOccEnv, Name) -tidyTopName mod env name - = (env', name') +tidyTopName mod env + name@(Name { n_occ = occ, n_sort = sort, n_uniq = uniq, n_loc = loc }) + = case sort of + System -> localise -- System local Ids + Local -> localise -- User non-exported Ids + Exported -> globalise -- User-exported things + Global _ -> no_op -- Constructors, class selectors etc + where - (env', occ') = tidyOccName env (n_occ name) + no_op = (env, name) - name' = Name { n_uniq = n_uniq name, n_sort = mk_top_sort mod, - n_occ = occ', n_loc = n_loc name } + globalise = (env, name { n_sort = Global mod }) -- Don't change occurrence name -mk_top_sort mod | all_toplev_ids_visible = Global mod - | otherwise = Local + localise = (env', name') + (env', occ') = tidyOccName env occ + name' | all_toplev_ids_visible = name { n_occ = occ', n_sort = Global mod } + | otherwise = name { n_occ = occ' } all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make them visible @@ -437,24 +446,28 @@ instance Outputable Name where pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = getPprStyle $ \ sty -> - let local | debugStyle sty - = pprOccName occ <> text "{-" <> pprUnique uniq <> text "-}" - | codeStyle sty - = pprUnique uniq - | otherwise - = pprOccName occ - - global m | codeStyle sty - = ppr (moduleName m) <> char '_' <> pprOccName occ - | debugStyle sty || printModulePrefix m - = ppr (moduleName m) <> dot <> pprOccName occ - | otherwise - = pprOccName occ - in case sort of - System -> local - Local -> local - Exported -> local - Global mod -> global mod + case sort of + Global mod -> pprGlobal sty uniq mod occ + System -> pprSysLocal sty uniq occ + Local -> pprLocal sty uniq occ empty + Exported -> pprLocal sty uniq occ (char 'x') + +pprLocal sty uniq occ pp_export + | codeStyle sty = pprUnique uniq + | debugStyle sty = pprOccName occ <> + text "{-" <> pp_export <+> pprUnique10 uniq <> text "-}" + | otherwise = pprOccName occ + +pprGlobal sty uniq mod occ + | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ + | debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <> + text "{-" <> pprUnique10 uniq <> text "-}" + | printModulePrefix mod = ppr (moduleName mod) <> dot <> pprOccName occ + | otherwise = pprOccName occ + +pprSysLocal sty uniq occ + | codeStyle sty = pprUnique uniq + | otherwise = pprOccName occ <> char '_' <> pprUnique uniq \end{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 1c3cc68..7e29d67 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -133,4 +133,5 @@ instance Outputable SrcLoc where -- so emacs can find the file ppr (UnhelpfulSrcLoc s) = ptext s + ppr NoSrcLoc = ptext SLIT("") \end{code} diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 26b1d0e..b120ca7 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -215,8 +215,7 @@ tidyTopId :: Module -> TidyEnv -> TidyEnv -> Id -> (TidyEnv, Id) tidyTopId mod env@(tidy_env, var_env) env_idinfo id = -- Top level variables let - (tidy_env', name') | exportWithOrigOccName id = (tidy_env, idName id) - | otherwise = tidyTopName mod tidy_env (idName id) + (tidy_env', name') = tidyTopName mod tidy_env (idName id) ty' = tidyTopType (idType id) idinfo' = tidyIdInfo env_idinfo (idInfo id) id' = mkId name' ty' idinfo' diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index be61da2..54f993d 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -238,13 +238,13 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)] tyClDeclNames (TySynonym name _ _ loc) = [(name,loc)] -tyClDeclNames (ClassDecl _ name _ _ sigs _ _ loc) - = (name,loc) : [(name,loc) | ClassOpSig n _ _ loc <- sigs] +tyClDeclNames (ClassDecl _ cls_name _ _ sigs _ _ loc) + = (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs] -tyClDeclNames (TyData _ _ name _ cons _ _ loc _ _) - = (name,loc) : conDeclsNames cons +tyClDeclNames (TyData _ _ tc_name _ cons _ _ loc _ _) + = (tc_name,loc) : conDeclsNames cons -tyClDeclNames (IfaceSig _ _ _ _) = [] +tyClDeclNames (IfaceSig name _ _ loc) = [(name,loc)] type ClassDeclSysNames name = [name] -- [tycon, datacon wrapper, datacon worker, diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 0a7f9e0..c67e0cb 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -34,38 +34,43 @@ source, interface, and object files for a module live. \begin{code} --- caches contents of package directories, never expunged +-- v_PkgDirCache caches contents of package directories, never expunged GLOBAL_VAR(v_PkgDirCache, error "no pkg cache!", FiniteMap String (PackageName, FilePath)) --- caches contents of home directories, expunged whenever we --- create a new finder. +-- v_HomeDirCache caches contents of home directories, +-- expunged whenever we create a new finder. GLOBAL_VAR(v_HomeDirCache, Nothing, Maybe (FiniteMap String FilePath)) initFinder :: PackageConfigInfo -> IO () -initFinder pkgs = do - -- expunge our home cache - writeIORef v_HomeDirCache Nothing - -- lazilly fill in the package cache - writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs)) - pkg_dbg_info <- readIORef v_PkgDirCache - putStrLn (unlines (map show (fmToList pkg_dbg_info))) +initFinder pkgs + = do { -- expunge our home cache + ; writeIORef v_HomeDirCache Nothing + -- lazilly fill in the package cache + ; writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs)) + +-- Debug output +-- ; pkg_dbg_info <- readIORef v_PkgDirCache +-- ; putStrLn (unlines (map show (fmToList pkg_dbg_info))) + } findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -findModule name = do - hPutStr stderr ("findModule: " ++ moduleNameUserString name ++ " ... ") - maybe_m <- findModule_wrk name - case maybe_m of - Nothing -> hPutStrLn stderr "Not Found" - Just mm -> hPutStrLn stderr (showSDoc (ppr (snd mm))) - return maybe_m - +findModule name + = do { hPutStr stderr ("findModule: " ++ moduleNameUserString name ++ " ... ") + ; maybe_m <- findModule_wrk name + ; case maybe_m of + Nothing -> hPutStrLn stderr "Not Found" + Just mm -> hPutStrLn stderr (showSDoc (ppr (snd mm))) + ; return maybe_m + } + findModule_wrk :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -findModule_wrk name = do - j <- maybeHomeModule name - case j of - Just home_module -> return (Just home_module) - Nothing -> maybePackageModule name +findModule_wrk name + = do { j <- maybeHomeModule name + ; case j of + Just home_module -> return (Just home_module) + Nothing -> maybePackageModule name + } maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) maybeHomeModule mod_name = do diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 7ef69b2..b22d33d 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -10,13 +10,9 @@ module HscMain ( HscResult(..), hscMain, #include "HsVersions.h" import Maybe ( isJust ) -import Monad ( when ) -import IO ( hPutStr, hPutStrLn, hClose, stderr, - openFile, IOMode(..) ) +import IO ( hPutStr, hPutStrLn, stderr ) import HsSyn -import RdrHsSyn ( RdrNameHsModule ) -import FastString ( unpackFS ) import StringBuffer ( hGetStringBuffer ) import Parser ( parse ) import Lex ( PState(..), ParseResult(..) ) @@ -31,7 +27,6 @@ import PrelRules ( builtinRules ) import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails, writeIface ) import TcModule ( TcResults(..), typecheckModule ) -import TcEnv ( tcEnvTyCons, tcEnvClasses ) import InstEnv ( emptyInstEnv ) import Desugar ( deSugar ) import SimplCore ( core2core ) @@ -44,36 +39,28 @@ import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CodeOutput ( codeOutput ) -import Module ( ModuleName, moduleNameUserString, - moduleUserString, moduleName, emptyModuleEnv, - extendModuleEnv ) +import Module ( ModuleName, moduleName, emptyModuleEnv ) import CmdLineOpts -import ErrUtils ( ghcExit, doIfSet, dumpIfSet_dyn ) +import ErrUtils ( dumpIfSet_dyn ) import UniqSupply ( mkSplitUniqSupply ) import Bag ( emptyBag ) import Outputable -import Char ( isSpace ) import StgInterp ( stgToInterpSyn ) import HscStats ( ppSourceStats ) import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), - PersistentRenamerState(..), WhatsImported(..), - HomeSymbolTable, PackageSymbolTable, ImportVersion, - GenAvailInfo(..), RdrAvailInfo, OrigNameEnv(..), - PackageRuleBase, HomeIfaceTable, PackageIfaceTable, - extendTypeEnv, groupTyThings, TypeEnv, TyThing, + PersistentRenamerState(..), + HomeSymbolTable, PackageSymbolTable, + OrigNameEnv(..), PackageRuleBase, HomeIfaceTable, + extendTypeEnv, groupTyThings, typeEnvClasses, typeEnvTyCons, emptyIfaceTable ) -import RnMonad ( ExportItem, ParsedIface(..) ) -import CmSummarise ( ModSummary(..), name_of_summary, ms_get_imports, - mimp_name ) +import CmSummarise ( ModSummary(..), ms_get_imports, mimp_name ) import InterpSyn ( UnlinkedIBind ) import StgInterp ( ItblEnv ) import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) -import OccName ( OccName, pprOccName ) -import Name ( Name, nameModule, emptyNameEnv, nameOccName, - getName, extendNameEnv_C, nameEnvElts ) -import VarEnv ( emptyVarEnv ) -import Module ( Module, mkModuleName, lookupModuleEnvByName ) +import OccName ( OccName ) +import Name ( Name, nameModule, emptyNameEnv, nameOccName, getName ) +import Module ( Module, lookupModuleEnvByName ) \end{code} @@ -152,7 +139,6 @@ hscNoRecomp dflags summary maybe_checked_iface hst hit pcs_ch let pcs_tc = tc_pcs tc_result env_tc = tc_env tc_result - binds_tc = tc_binds tc_result local_insts = tc_insts tc_result local_rules = tc_rules tc_result ; @@ -192,12 +178,12 @@ hscRecomp dflags summary maybe_checked_iface hst hit pcs_ch maybe_tc_result <- typecheckModule dflags this_mod pcs_rn hst hit rn_hs_decls; case maybe_tc_result of { - Nothing -> return (HscFail pcs_rn); + Nothing -> do { hPutStrLn stderr "Typechecked failed" + ; return (HscFail pcs_rn) } ; Just tc_result -> do { let pcs_tc = tc_pcs tc_result env_tc = tc_env tc_result - binds_tc = tc_binds tc_result local_insts = tc_insts tc_result ; -- DESUGAR, SIMPLIFY, TIDY-CORE diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 752f2e4..e7f639d 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -308,14 +308,12 @@ data Deprecations = NoDeprecs -- Just "big" names -- We keep the Name in the range, so we can print them out -lookupDeprec :: ModIface -> Name -> Maybe DeprecTxt -lookupDeprec iface name - = case mi_deprecs iface of - NoDeprecs -> Nothing - DeprecAll txt -> Just txt - DeprecSome env -> case lookupNameEnv env name of - Just (_, txt) -> Just txt - Nothing -> Nothing +lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt +lookupDeprec NoDeprecs name = Nothing +lookupDeprec (DeprecAll txt) name = Just txt +lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of + Just (_, txt) -> Just txt + Nothing -> Nothing type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class diff --git a/ghc/compiler/main/TmpFiles.hs b/ghc/compiler/main/TmpFiles.hs index c1d0f4f..90ebcc2 100644 --- a/ghc/compiler/main/TmpFiles.hs +++ b/ghc/compiler/main/TmpFiles.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: TmpFiles.hs,v 1.7 2000/10/27 15:11:37 sewardj Exp $ +-- $Id: TmpFiles.hs,v 1.8 2000/10/30 09:52:15 simonpj Exp $ -- -- Temporary file management -- @@ -47,12 +47,12 @@ cleanTempFiles verbose = do fs <- readIORef v_FilesToClean let blowAway f = - (do when verbose (hPutStrLn stderr ("removing: " ++ f)) + (do when verbose (hPutStrLn stderr ("Removing: " ++ f)) if '*' `elem` f then system ("rm -f " ++ f) >> return () else removeFile f) `catchAllIO` (\_ -> when verbose (hPutStrLn stderr - ("warning: can't remove tmp file" ++ f))) + ("Warning: can't remove tmp file " ++ f))) mapM_ blowAway fs type Suffix = String diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 65f980d..094a01f 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -10,7 +10,7 @@ module Rename ( renameModule, closeIfaceDecls, checkOldIface ) where import HsSyn import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, - RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl + RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl, extractHsTyNames, @@ -26,24 +26,24 @@ import RnIfaces ( slurpImpDecls, mkImportInfo, RecompileRequired, recompileRequired ) import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs ) -import RnEnv ( availName, availsToNameSet, +import RnEnv ( availName, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, lookupOrigNames, lookupGlobalRn, newGlobalName ) import Module ( Module, ModuleName, WhereFrom(..), - moduleNameUserString, moduleName, - lookupModuleEnv + moduleNameUserString, moduleName ) import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, nameOccName, nameModule, mkNameEnv, nameEnvElts, extendNameEnv ) +import RdrName ( elemRdrEnv ) import OccName ( occNameFlavour ) import NameSet import TysWiredIn ( unitTyCon, intTyCon, boolTyCon ) import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, - ioTyCon_RDR, + ioTyCon_RDR, main_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, eqString_RDR ) @@ -61,9 +61,9 @@ import IO ( openFile, IOMode(..) ) import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, ModIface(..), WhatsImported(..), VersionInfo(..), ImportVersion, IfaceDecls(..), - GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo, + GlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo, Provenance(..), ImportReason(..), initialVersionInfo, - Deprecations(..), lookupDeprec + Deprecations(..), lookupDeprec, lookupTable ) import List ( partition, nub ) \end{code} @@ -100,18 +100,21 @@ renameModule dflags hit hst old_pcs this_module rdr_module \begin{code} rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl])) -rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc) - = -- FIND THE GLOBAL NAME ENVIRONMENT - getGlobalNames this_mod `thenRn` \ maybe_stuff -> +rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) + = pushSrcLocRn loc $ - -- CHECK FOR EARLY EXIT - case maybe_stuff of { - Nothing -> -- Everything is up to date; no need to recompile further - rnDump [] [] `thenRn_` - returnRn Nothing ; - - Just (gbl_env, local_gbl_env, export_avails, global_avail_env) -> + -- FIND THE GLOBAL NAME ENVIRONMENT + getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env, + export_avails, global_avail_env) -> + -- Exit if we've found any errors + checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + -- Found errors already, so exit now + rnDump [] [] `thenRn_` + returnRn Nothing + else + -- DEAL WITH DEPRECATIONS rnDeprecs local_gbl_env mod_deprec [d | DeprecD d <- local_decls] `thenRn` \ my_deprecs -> @@ -124,6 +127,9 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls rnSourceDecls local_decls ) `thenRn` \ (rn_local_decls, source_fvs) -> + -- CHECK THAT main IS DEFINED, IF REQUIRED + checkMain this_module local_gbl_env `thenRn_` + -- SLURP IN ALL THE NEEDED DECLARATIONS implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs -> let @@ -157,9 +163,6 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls getNameSupplyRn `thenRn` \ name_supply -> getIfacesRn `thenRn` \ ifaces -> let - direct_import_mods :: [ModuleName] - direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports] - -- We record fixities even for things that aren't exported, -- so that we can change into the context of this moodule easily fixities = mkNameEnv [ (name, fixity) @@ -168,7 +171,7 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls -- Sort the exports to make them easier to compare for versions - my_exports = groupAvails export_avails + my_exports = groupAvails this_module export_avails mod_iface = ModIface { mi_module = this_module, mi_version = initialVersionInfo, @@ -185,13 +188,23 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls in -- REPORT UNUSED NAMES, AND DEBUG DUMP - reportUnusedNames mod_name direct_import_mods - gbl_env global_avail_env - export_avails source_fvs - rn_imp_decls `thenRn_` + reportUnusedNames mod_iface imports global_avail_env + real_source_fvs rn_imp_decls `thenRn_` returnRn (Just (mod_iface, final_decls)) - } + where + mod_name = moduleName this_module +\end{code} + +Checking that main is defined + +\begin{code} +checkMain :: Module -> GlobalRdrEnv -> RnMG () +checkMain this_mod local_env + | moduleName this_mod == mAIN_Name + = checkRn (main_RDR `elemRdrEnv` local_env) noMainErr + | otherwise + = returnRn () \end{code} @implicitFVs@ forces the renamer to slurp in some things which aren't @@ -508,23 +521,22 @@ closeIfaceDecls dflags hit hst pcs %********************************************************* \begin{code} -reportUnusedNames :: ModuleName -> [ModuleName] - -> GlobalRdrEnv -> AvailEnv - -> Avails -> NameSet -> [RenamedHsDecl] +reportUnusedNames :: ModIface -> [RdrNameImportDecl] + -> AvailEnv + -> NameSet + -> [RenamedHsDecl] -> RnMG () -reportUnusedNames mod_name direct_import_mods - gbl_env avail_env - export_avails mentioned_names - imported_decls +reportUnusedNames my_mod_iface imports avail_env + used_names imported_decls = warnUnusedModules unused_imp_mods `thenRn_` warnUnusedLocalBinds bad_locals `thenRn_` warnUnusedImports bad_imp_names `thenRn_` - printMinimalImports mod_name minimal_imports `thenRn_` - warnDeprecations really_used_names `thenRn_` + printMinimalImports my_mod_iface minimal_imports `thenRn_` + warnDeprecations my_mod_iface really_used_names `thenRn_` returnRn () where - used_names = mentioned_names `unionNameSets` availsToNameSet export_avails + gbl_env = mi_globals my_mod_iface -- Now, a use of C implies a use of T, -- if C was brought into scope by T(..) or T(C) @@ -603,7 +615,10 @@ reportUnusedNames mod_name direct_import_mods | otherwise = addToFM acc m emptyAvailEnv -- Add an empty collection of imports for a module -- from which we have sucked only instance decls - + + direct_import_mods :: [ModuleName] + direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports] + -- unused_imp_mods are the directly-imported modules -- that are not mentioned in minimal_imports unused_imp_mods = [m | m <- direct_import_mods, @@ -614,7 +629,7 @@ reportUnusedNames mod_name direct_import_mods module_unused mod = moduleName mod `elem` unused_imp_mods -warnDeprecations used_names +warnDeprecations my_mod_iface used_names = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> if not warn_drs then returnRn () else @@ -629,17 +644,16 @@ warnDeprecations used_names mapRn_ warnDeprec deprecs where - lookup_deprec hit pit n - = case lookupModuleEnv hit mod of - Just iface -> lookupDeprec iface n - Nothing -> case lookupModuleEnv pit mod of - Just iface -> lookupDeprec iface n - Nothing -> pprPanic "warnDeprecations:" (ppr n) - where - mod = nameModule n + mod = mi_module my_mod_iface + my_deprecs = mi_deprecs my_mod_iface + lookup_deprec hit pit n + | isLocalThing mod n = lookupDeprec my_deprecs n + | otherwise = case lookupTable hit pit n of + Just iface -> lookupDeprec (mi_deprecs iface) n + Nothing -> pprPanic "warnDeprecations:" (ppr n) -- ToDo: deal with original imports with 'qualified' and 'as M' clauses -printMinimalImports mod_name imps +printMinimalImports my_mod_iface imps = doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal -> if not dump_minimal then returnRn () else @@ -649,7 +663,8 @@ printMinimalImports mod_name imps }) `thenRn_` returnRn () where - filename = moduleNameUserString mod_name ++ ".imports" + filename = moduleNameUserString (moduleName (mi_module my_mod_iface)) + ++ ".imports" ppr_mod_ie (mod_name, ies) | mod_name == pRELUDE_Name = empty @@ -786,6 +801,10 @@ dupFixityDecl rdr_name loc1 loc2 badDeprec d = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"), nest 4 (ppr d)] + +noMainErr + = hsep [ptext SLIT("Module"), quotes (ppr mAIN_Name), + ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))] \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 4fc2a3a..023e10c 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -21,7 +21,7 @@ import RnMonad import Name ( Name, NamedThing(..), getSrcLoc, mkLocalName, mkImportedLocalName, mkGlobalName, - mkIPName, nameOccName, nameModule, + mkIPName, nameOccName, nameModule_maybe, extendNameEnv_C, plusNameEnv_C, nameEnvElts, setNameModuleAndLoc ) @@ -49,10 +49,25 @@ import FastString ( FastString ) \begin{code} newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name + -- newTopBinder puts into the cache the binder with the + -- module information set correctly. When the decl is later renamed, + -- the binding site will thereby get the correct module. + -- There maybe occurrences that don't have the correct Module, but + -- by the typechecker will propagate the binding definition to all + -- the occurrences, so that doesn't matter + newTopBinder mod rdr_name loc = -- First check the cache traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_` + -- There should never be a qualified name in a binding position (except in instance decls) + -- The parser doesn't check this because the same parser parses instance decls + (if isQual rdr_name then + qualNameErr (text "its declaration") (rdr_name,loc) + else + returnRn () + ) `thenRn_` + getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> let occ = rdrNameOcc rdr_name @@ -639,10 +654,10 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail filterAvail ie avail = Nothing ------------------------------------- -groupAvails :: Avails -> [(ModuleName, Avails)] +groupAvails :: Module -> Avails -> [(ModuleName, Avails)] -- Group by module and sort by occurrence -- This keeps the list in canonical order -groupAvails avails +groupAvails this_mod avails = [ (mkSysModuleNameFS fs, sortLt lt avails) | (fs,avails) <- fmToList groupFM ] @@ -654,7 +669,10 @@ groupAvails avails add env avail = addToFM_C combine env mod_fs [avail] where - mod_fs = moduleNameFS (moduleName (nameModule (availName avail))) + mod_fs = moduleNameFS (moduleName avail_mod) + avail_mod = case nameModule_maybe (availName avail) of + Just m -> m + Nothing -> this_mod combine old _ = avail:old a1 `lt` a2 = occ1 < occ2 diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 9a13669..77f753a 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -87,9 +87,14 @@ loadInterface doc mod from Just err -> failWithRn ifaces err tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message) - -- Returns (Just err) if an error happened - -- Guarantees to return with iImpModInfo m --> (..., True) - -- (If the load fails, we plug in a vanilla placeholder) + -- Returns (Just err) if an error happened + -- It *doesn't* add an error to the monad, because sometimes it's ok to fail... + -- Specifically, when we read the usage information from an interface file, + -- we try to read the interfaces it mentions. But it's OK to fail; perhaps + -- the module has changed, and that interface is no longer used. + + -- tryLoadInterface guarantees to return with iImpModInfo m --> (..., True) + -- (If the load fails, we plug in a vanilla placeholder) tryLoadInterface doc_str mod_name from = getHomeIfaceTableRn `thenRn` \ hit -> getIfacesRn `thenRn` \ ifaces -> @@ -271,14 +276,12 @@ loadExport this_mod (mod, entities) = mapRn (load_entity mod) entities `thenRn` \ avails -> returnRn (mod, avails) where - new_name mod occ = newGlobalName mod occ - load_entity mod (Avail occ) - = new_name mod occ `thenRn` \ name -> + = newGlobalName mod occ `thenRn` \ name -> returnRn (Avail name) load_entity mod (AvailTC occ occs) - = new_name mod occ `thenRn` \ name -> - mapRn (new_name mod) occs `thenRn` \ names -> + = newGlobalName mod occ `thenRn` \ name -> + mapRn (newGlobalName mod) occs `thenRn` \ names -> returnRn (AvailTC name names) @@ -298,7 +301,7 @@ loadDecl :: Module -> (Version, RdrNameTyClDecl) -> RnM d (NameEnv Version, DeclsMap) loadDecl mod (version_map, decls_map) (version, decl) - = getIfaceDeclBinders new_name decl `thenRn` \ full_avail -> + = getIfaceDeclBinders mod decl `thenRn` \ full_avail -> let main_name = availName full_avail new_decls_map = extendNameEnvList decls_map stuff @@ -308,15 +311,6 @@ loadDecl mod (version_map, decls_map) (version, decl) new_version_map = extendNameEnv version_map main_name version in returnRn (new_version_map, new_decls_map) - where - -- newTopBinder puts into the cache the binder with the - -- module information set correctly. When the decl is later renamed, - -- the binding site will thereby get the correct module. - -- There maybe occurrences that don't have the correct Module, but - -- by the typechecker will propagate the binding definition to all - -- the occurrences, so that doesn't matter - new_name rdr_name loc = newTopBinder mod rdr_name loc - ----------------------------------------------------- -- Loading fixity decls @@ -427,27 +421,27 @@ are handled by the sourc-code specific stuff in @RnNames@. \begin{code} getIfaceDeclBinders, getTyClDeclBinders - :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function + :: Module -> RdrNameTyClDecl -> RnM d AvailInfo -getIfaceDeclBinders new_name tycl_decl - = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail -> - getSysTyClDeclBinders new_name tycl_decl `thenRn` \ extras -> +getIfaceDeclBinders mod tycl_decl + = getTyClDeclBinders mod tycl_decl `thenRn` \ avail -> + getSysTyClDeclBinders mod tycl_decl `thenRn` \ extras -> returnRn (addSysAvails avail extras) -- Add the sys-binders to avail. When we import the decl, -- it's full_avail that will get added to the 'already-slurped' set (iSlurp) -- If we miss out sys-binders, we'll read the decl multiple times! -getTyClDeclBinders new_name (IfaceSig var ty prags src_loc) - = new_name var src_loc `thenRn` \ var_name -> +getTyClDeclBinders mod (IfaceSig var ty prags src_loc) + = newTopBinder mod var src_loc `thenRn` \ var_name -> returnRn (Avail var_name) -getTyClDeclBinders new_name tycl_decl +getTyClDeclBinders mod tycl_decl = mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) -> returnRn (AvailTC main_name (main_name : sub_names)) where - do_one (name,loc) = new_name name loc + do_one (name,loc) = newTopBinder mod name loc \end{code} @getDeclSysBinders@ gets the implicit binders introduced by a decl. @@ -460,13 +454,13 @@ and the dict fun of an instance decl, because both of these have bindings of their own elsewhere. \begin{code} -getSysTyClDeclBinders new_name (ClassDecl _ cname _ _ sigs _ names src_loc) - = sequenceRn [new_name n src_loc | n <- names] +getSysTyClDeclBinders mod (ClassDecl _ cname _ _ sigs _ names src_loc) + = sequenceRn [newTopBinder mod n src_loc | n <- names] -getSysTyClDeclBinders new_name (TyData _ _ _ _ cons _ _ _ _ _) - = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons] +getSysTyClDeclBinders mod (TyData _ _ _ _ cons _ _ _ _ _) + = sequenceRn [newTopBinder mod wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons] -getSysTyClDeclBinders new_name other_decl +getSysTyClDeclBinders mod other_decl = returnRn [] \end{code} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 7d85e22..9d0ffaf 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -250,17 +250,7 @@ mkImportInfo this_mod imports -- For (a) a library module, we don't record it at all unless it contains orphans -- (We must never lose track of orphans.) -- - -- (b) a source-imported module, don't record the dependency at all - -- - -- (b) may seem a bit strange. The idea is that the usages in a .hi file records - -- *all* the module's dependencies other than the loop-breakers. We use - -- this info in findAndReadInterface to decide whether to look for a .hi file or - -- a .hi-boot file. - -- - -- This means we won't track version changes, or orphans, from .hi-boot files. - -- The former is potentially rather bad news. It could be fixed by recording - -- whether something is a boot file along with the usage info for it, but - -- I can't be bothered just now. + -- (b) a home-package module mk_imp_info mod_name (has_orphans, is_boot, opened) so_far | mod_name == this_mod -- Check if M appears in the set of modules 'below' M @@ -279,11 +269,15 @@ mkImportInfo this_mod imports go_for_it NothingAtAll - | is_lib_module && not has_orphans - = so_far - - | is_lib_module -- Record the module version only - = go_for_it (Everything module_vers) + | is_lib_module + -- Ignore modules from other packages, unless it has + -- orphans, in which case we must remember it in our + -- dependencies. But in that case we only record the + -- module version, nothing more detailed + = if has_orphans then + go_for_it (Everything module_vers) + else + so_far | otherwise = go_for_it whats_imported @@ -654,6 +648,9 @@ data ImportDeclResult importDecl name = -- Check if it was loaded before beginning this module + if isLocallyDefined name then + returnRn AlreadySlurped + else checkAlreadyAvailable name `thenRn` \ done -> if done then returnRn AlreadySlurped diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index e2094c8..eaffb11 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -28,16 +28,15 @@ import FiniteMap import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR ) import UniqFM ( lookupUFM ) import Bag ( bagToList ) -import Module ( ModuleName, mkModuleInThisPackage, WhereFrom(..) ) +import Module ( ModuleName, moduleName, WhereFrom(..) ) import NameSet import Name ( Name, nameSrcLoc, setLocalNameSort, nameOccName, nameEnvElts ) import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, GenAvailInfo(..), AvailInfo, Avails, AvailEnv ) -import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isUnqual ) +import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual ) import OccName ( setOccNameSpace, dataName ) import NameSet ( elemNameSet, emptyNameSet ) -import SrcLoc ( SrcLoc ) import Outputable import Maybes ( maybeToBool, catMaybes, mapMaybe ) import UniqFM ( emptyUFM, listToUFM ) @@ -55,19 +54,17 @@ import List ( partition ) %************************************************************************ \begin{code} -getGlobalNames :: RdrNameHsModule - -> RnMG (Maybe (GlobalRdrEnv, -- Maps all in-scope things - GlobalRdrEnv, -- Maps just *local* things - Avails, -- The exported stuff - AvailEnv -- Maps a name to its parent AvailInfo - -- Just for in-scope things only - )) - -- Nothing => no need to recompile - -getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) +getGlobalNames :: Module -> RdrNameHsModule + -> RnMG (GlobalRdrEnv, -- Maps all in-scope things + GlobalRdrEnv, -- Maps just *local* things + Avails, -- The exported stuff + AvailEnv) -- Maps a name to its parent AvailInfo + -- Just for in-scope things only + +getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) = -- These two fix-loops are to get the right -- provenance information into a Name - fixRn ( \ ~(Just (rec_gbl_env, _, rec_export_avails, _)) -> + fixRn ( \ ~(rec_gbl_env, _, rec_export_avails, _) -> let rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified? @@ -80,8 +77,7 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) -- PROCESS LOCAL DECLS -- Do these *first* so that the correct provenance gets -- into the global name cache. - importsFromLocalDecls this_mod rec_exp_fn decls - `thenRn` \ (local_gbl_env, local_mod_avails) -> + importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) -> -- PROCESS IMPORT DECLS -- Do the non {- SOURCE -} ones first, so that we get a helpful @@ -91,10 +87,8 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True is_source_import other = False in - mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary - `thenRn` \ (imp_gbl_envs1, imp_avails_s1) -> - mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source - `thenRn` \ (imp_gbl_envs2, imp_avails_s2) -> + mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) -> + mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) -> -- COMBINE RESULTS -- We put the local env second, so that a local provenance @@ -106,46 +100,29 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) all_avails :: ExportAvails all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1) + (_, global_avail_env) = all_avails in - -- TRY FOR EARLY EXIT - -- We can't go for an early exit before this because we have to check - -- for name clashes. Consider: - -- - -- module A where module B where - -- import B h = True - -- f = h - -- - -- Suppose I've compiled everything up, and then I add a - -- new definition to module B, that defines "f". - -- - -- Then I must detect the name clash in A before going for an early - -- exit. The early-exit code checks what's actually needed from B - -- to compile A, and of course that doesn't include B.f. That's - -- why we wait till after the plusEnv stuff to do the early-exit. - - -- Check For early exit - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - returnRn Nothing - else - - -- PROCESS EXPORT LISTS - exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ export_avails -> - + -- PROCESS EXPORT LIST (but not if we've had errors already) + checkErrsRn `thenRn` \ no_errs_so_far -> + (if no_errs_so_far then + exportsFromAvail this_mod_name exports all_avails gbl_env + else + returnRn [] + ) `thenRn` \ export_avails -> -- ALL DONE - returnRn (Just (gbl_env, local_gbl_env, export_avails, global_avail_env)) + returnRn (gbl_env, local_gbl_env, export_avails, global_avail_env) ) where + this_mod_name = moduleName this_mod all_imports = prel_imports ++ imports -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); -- because the former doesn't even look at Prelude.hi for instance declarations, -- whereas the latter does. - prel_imports | this_mod == pRELUDE_Name || + prel_imports | this_mod_name == pRELUDE_Name || explicit_prelude_import || opt_NoImplicitPrelude = [] @@ -197,8 +174,8 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i \begin{code} -importsFromLocalDecls mod_name rec_exp_fn decls - = mapRn (getLocalDeclBinders (newLocalName mod rec_exp_fn)) decls `thenRn` \ avails_s -> +importsFromLocalDecls this_mod rec_exp_fn decls + = mapRn (getLocalDeclBinders this_mod rec_exp_fn) decls `thenRn` \ avails_s -> let avails = concat avails_s @@ -216,32 +193,33 @@ importsFromLocalDecls mod_name rec_exp_fn decls recordLocalSlurps avails `thenRn_` -- Build the environment - qualifyImports mod_name + qualifyImports (moduleName this_mod) True -- Want unqualified names Nothing -- no 'as M' [] -- Hide nothing (\n -> LocalDef) -- Provenance is local avails - where - mod = mkModuleInThisPackage mod_name --------------------------- -getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) +getLocalDeclBinders :: Module + -> (Name -> Bool) -- Whether exported -> RdrNameHsDecl -> RnMG Avails -getLocalDeclBinders new_name (ValD binds) - = mapRn do_one (bagToList (collectTopBinders binds)) - where - do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name -> - returnRn (Avail name) - -getLocalDeclBinders new_name (TyClD tycl_decl) - = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail -> +getLocalDeclBinders mod rec_exp_fn (TyClD tycl_decl) + = -- For type and class decls, we generate Global names, with + -- no export indicator. They need to be global because they get + -- permanently bound into the TyCons and Classes. They don't need + -- an export indicator because they are all implicitly exported. + getTyClDeclBinders mod tycl_decl `thenRn` \ avail -> returnRn [avail] -getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ ext_nm _ loc)) +getLocalDeclBinders mod rec_exp_fn (ValD binds) + = mapRn (newLocalBinder mod rec_exp_fn) + (bagToList (collectTopBinders binds)) + +getLocalDeclBinders mod rec_exp_fn (ForD (ForeignDecl nm kind _ ext_nm _ loc)) | binds_haskell_name kind - = new_name nm loc `thenRn` \ name -> - returnRn [Avail name] + = newLocalBinder mod rec_exp_fn (nm, loc) `thenRn` \ avail -> + returnRn [avail] | otherwise -- a foreign export = lookupOrigName nm `thenRn_` @@ -251,25 +229,17 @@ getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ ext_nm _ loc)) binds_haskell_name FoLabel = True binds_haskell_name FoExport = isDynamicExtName ext_nm -getLocalDeclBinders new_name (FixD _) = returnRn [] -getLocalDeclBinders new_name (DeprecD _) = returnRn [] -getLocalDeclBinders new_name (DefD _) = returnRn [] -getLocalDeclBinders new_name (InstD _) = returnRn [] -getLocalDeclBinders new_name (RuleD _) = returnRn [] - +getLocalDeclBinders mod rec_exp_fn (FixD _) = returnRn [] +getLocalDeclBinders mod rec_exp_fn (DeprecD _) = returnRn [] +getLocalDeclBinders mod rec_exp_fn (DefD _) = returnRn [] +getLocalDeclBinders mod rec_exp_fn (InstD _) = returnRn [] +getLocalDeclBinders mod rec_exp_fn (RuleD _) = returnRn [] --------------------------- -newLocalName mod rec_exp_fn rdr_name loc - = check_unqual rdr_name loc `thenRn_` +newLocalBinder mod rec_exp_fn (rdr_name, loc) + = -- Generate a local name, and with a suitable export indicator newTopBinder mod rdr_name loc `thenRn` \ name -> - returnRn (setLocalNameSort name (rec_exp_fn name)) - where - -- There should never be a qualified name in a binding position (except in instance decls) - -- The parser doesn't check this because the same parser parses instance decls - check_unqual rdr_name loc - | isUnqual rdr_name = returnRn () - | otherwise = qualNameErr (text "the binding for" <+> quotes (ppr rdr_name)) - (rdr_name,loc) + returnRn (Avail (setLocalNameSort name (rec_exp_fn name))) \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 51af082..693c600 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -414,6 +414,9 @@ rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- G returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs) where meth_doc = text "the default-methods for class" <+> ppr cname + +rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs) + -- Not a class declaration \end{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index a33e7f4..0b9bc20 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -758,8 +758,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs -- which is just waht check_one_sig looks for mapTc check_one_sig sigs `thenTc_` mapTc check_main_ctxt sigs `thenTc_` - - returnTc (Just ([], emptyLIE)) + returnTc (Just ([], emptyLIE)) | not (null sigs) = mapTc check_one_sig sigs `thenTc_` diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index bbb8573..9ce440b 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -33,8 +33,8 @@ module TcEnv( newLocalId, newSpecPragmaId, newDefaultMethodName, newDFunName, - -- ??? - tcSetEnv, explicitLookupId + -- Misc + isLocalThing, tcSetEnv, explicitLookupId ) where #include "HsVersions.h" @@ -44,7 +44,7 @@ import TcMonad import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType, tcInstTyVars, zonkTcTyVars, ) -import Id ( idName, mkUserLocal, isDataConWrapId_maybe ) +import Id ( mkUserLocal, isDataConWrapId_maybe ) import IdInfo ( vanillaIdInfo ) import MkId ( mkSpecPragmaId ) import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) @@ -60,7 +60,7 @@ import Class ( Class, ClassOpItem, ClassContext ) import Subst ( substTy ) import Name ( Name, OccName, NamedThing(..), nameOccName, nameModule, getSrcLoc, mkGlobalName, - isLocallyDefined, nameModule, + isLocallyDefined, nameModule_maybe, NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv ) @@ -281,6 +281,14 @@ newDefaultMethodName op_name loc loc) \end{code} +\begin{code} +isLocalThing :: NamedThing a => Module -> a -> Bool + -- True if the thing has a Local name, + -- or a Global name from the specified module +isLocalThing mod thing = case nameModule_maybe (getName thing) of + Nothing -> True -- A local name + Just m -> m == mod -- A global thing +\end{code} %************************************************************************ %* * @@ -318,14 +326,14 @@ tcLookupGlobal name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing -> case maybe_thing of Just thing -> returnNF_Tc thing - other -> notFound "tcLookupGlobal:" name + other -> notFound "tcLookupGlobal" name tcLookupGlobalId :: Name -> NF_TcM Id tcLookupGlobalId name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id -> case maybe_id of Just (AnId clas) -> returnNF_Tc clas - other -> notFound "tcLookupGlobalId:" name + other -> notFound "tcLookupGlobalId" name tcLookupDataCon :: Name -> TcM DataCon tcLookupDataCon con_name @@ -340,14 +348,14 @@ tcLookupClass name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas -> case maybe_clas of Just (AClass clas) -> returnNF_Tc clas - other -> notFound "tcLookupClass:" name + other -> notFound "tcLookupClass" name tcLookupTyCon :: Name -> NF_TcM TyCon tcLookupTyCon name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc -> case maybe_tc of Just (ATyCon tc) -> returnNF_Tc tc - other -> notFound "tcLookupTyCon:" name + other -> notFound "tcLookupTyCon" name \end{code} @@ -368,7 +376,7 @@ tcLookup name = tcLookup_maybe name `thenNF_Tc` \ maybe_thing -> case maybe_thing of Just thing -> returnNF_Tc thing - other -> notFound "tcLookup:" name + other -> notFound "tcLookup" name -- Extract the IdInfo from an IfaceSig imported from an interface file \end{code} @@ -525,7 +533,7 @@ simpleInstInfoTyCon inst Just (tycon, _) -> tycon isLocalInst :: Module -> InstInfo -> Bool -isLocalInst mod info = mod == nameModule (idName (iDFunId info)) +isLocalInst mod info = isLocalThing mod (iDFunId info) \end{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 9106c2e..6565f1e 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -25,8 +25,8 @@ import Inst ( plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) -import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookupGlobal_maybe, - tcEnvTyCons, tcEnvClasses, +import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, + tcEnvTyCons, tcEnvClasses, isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv ) import TcRules ( tcRules ) @@ -42,13 +42,12 @@ import Type ( funResultTy, splitForAllTys ) import Bag ( isEmptyBag ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn ) import Id ( idType, idName, idUnfolding ) -import Module ( Module, moduleName, plusModuleEnv ) -import Name ( Name, nameOccName, isLocallyDefined, isGlobalName, - toRdrName, nameEnvElts, emptyNameEnv, lookupNameEnv +import Module ( Module, plusModuleEnv ) +import Name ( Name, nameOccName, isLocallyDefined, isGlobalName, getName, + toRdrName, nameEnvElts, lookupNameEnv, mkNameEnv ) import TyCon ( tyConGenInfo, isClassTyCon ) import OccName ( isSysOcc ) -import PrelNames ( mAIN_Name, mainName ) import Maybes ( thenMaybe ) import Util import BasicTypes ( EP(..), Fixity ) @@ -58,7 +57,7 @@ import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable, PackageSymbolTable, DFunId, ModIface(..), TypeEnv, extendTypeEnv, lookupTable, TyThing(..), groupTyThings ) -import FiniteMap ( FiniteMap, delFromFM, lookupWithDefaultFM ) +import List ( partition ) \end{code} Outside-world interface: @@ -90,7 +89,7 @@ typecheckModule typecheckModule dflags this_mod pcs hst hit decls = do env <- initTcEnv global_symbol_table - (maybe_result, (errs,warns)) <- initTc dflags env tc_module + (maybe_result, (warns,errs)) <- initTc dflags env tc_module let { maybe_tc_result :: Maybe TcResults ; maybe_tc_result = case maybe_result of @@ -101,9 +100,9 @@ typecheckModule dflags this_mod pcs hst hit decls printTcDump dflags maybe_tc_result if isEmptyBag errs then - return Nothing - else return maybe_tc_result + else + return Nothing where global_symbol_table = pcs_PST pcs `plusModuleEnv` hst @@ -222,9 +221,6 @@ tcModule pcs hst get_fixity this_mod decls unf_env in tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> - -- Check that Main defines main - checkMain this_mod `thenTc_` - -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. let @@ -243,14 +239,14 @@ tcModule pcs hst get_fixity this_mod decls unf_env zonkRules local_rules `thenNF_Tc` \ local_rules' -> - let groups :: FiniteMap Module TypeEnv - groups = groupTyThings (nameEnvElts (getTcGEnv final_env)) - + let (local_things, imported_things) = partition (isLocalThing this_mod) + (nameEnvElts (getTcGEnv final_env)) + local_type_env :: TypeEnv - local_type_env = lookupWithDefaultFM groups emptyNameEnv this_mod + local_type_env = mkNameEnv [(getName thing, thing) | thing <- local_things] new_pst :: PackageSymbolTable - new_pst = extendTypeEnv (pcs_PST pcs) (delFromFM groups this_mod) + new_pst = extendTypeEnv (pcs_PST pcs) (groupTyThings imported_things) final_pcs :: PersistentCompilerState final_pcs = pcs { pcs_PST = new_pst, @@ -271,22 +267,6 @@ get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] \end{code} -\begin{code} -checkMain :: Module -> TcM () -checkMain this_mod - | moduleName this_mod == mAIN_Name - = tcLookupGlobal_maybe mainName `thenNF_Tc` \ maybe_main -> - case maybe_main of - Just (AnId _) -> returnTc () - other -> addErrTc noMainErr - - | otherwise = returnTc () - -noMainErr - = hsep [ptext SLIT("Module"), quotes (ppr mAIN_Name), - ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))] -\end{code} - %************************************************************************ %* * diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 7432dc7..4d38539 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -125,7 +125,7 @@ type TcRef a = IORef a initTc :: DynFlags -> TcEnv -> TcM r - -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg)) + -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg)) initTc dflags tc_env do_this = do { diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 16fb692..da8fda7 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -19,11 +19,10 @@ import TcType ( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy ) import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars ) import TcExpr ( tcExpr ) -import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv ) +import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing ) import Rules ( extendRuleBase ) import Inst ( LIE, emptyLIE, plusLIEs, instToId ) import Id ( idType, idName, mkVanillaId ) -import Name ( nameModule ) import Module ( Module ) import VarSet import Type ( tyVarsOfTypes, openTypeKind ) @@ -47,7 +46,7 @@ tcRules pkg_rule_base mod decls -- When relinking this module from its interface-file decls -- we'll have IfaceRules that are in fact local to this module - is_local (IfaceRuleOut n _) = mod == nameModule (idName n) + is_local (IfaceRuleOut n _) = isLocalThing mod n is_local other = True tcRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl) diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 532729f..db58f67 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -21,8 +21,8 @@ import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, tyClDeclFVs ) import BasicTypes ( RecFlag(..), NewOrData(..) ) import TcMonad -import TcEnv ( TcEnv, TyThing(..), TyThingDetails(..), - tcExtendKindEnv, tcLookupGlobal, tcExtendGlobalEnv ) +import TcEnv ( TcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..), + tcExtendKindEnv, tcLookup, tcExtendGlobalEnv ) import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep ) import TcClassDcl ( tcClassDecl1 ) import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars ) @@ -251,11 +251,12 @@ kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its t -- the kind of the tycon/class. Give it to the thing inside, and -- check the result kind matches kcTyClDeclBody tc_name hs_tyvars thing_inside - = tcLookupGlobal tc_name `thenNF_Tc` \ thing -> + = tcLookup tc_name `thenNF_Tc` \ thing -> let kind = case thing of - ATyCon tc -> tyConKind tc - AClass cl -> tyConKind (classTyCon cl) + AGlobal (ATyCon tc) -> tyConKind tc + AGlobal (AClass cl) -> tyConKind (classTyCon cl) + AThing kind -> kind -- For some odd reason, a class doesn't include its kind (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 6ad66a4..5a675a4 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -47,7 +47,7 @@ module Type ( TauType, RhoType, SigmaType, PredType(..), ThetaType, ClassPred, ClassContext, mkClassPred, - getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds, + getClassTys_maybe, ipName_maybe, classesOfPreds, isTauTy, mkRhoTy, splitRhoTy, mkSigmaTy, isSigmaTy, splitSigmaTy, getDFunTyKey, @@ -713,9 +713,6 @@ ipName_maybe :: PredType -> Maybe Name ipName_maybe (IParam n _) = Just n ipName_maybe _ = Nothing -classesToPreds :: ClassContext -> ThetaType -classesToPreds cts = map (uncurry Class) cts - classesOfPreds :: ThetaType -> ClassContext classesOfPreds theta = [(clas,tys) | Class clas tys <- theta] \end{code}