From e66018084e22615311828b7a221d5df25cdf09ea Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 5 Feb 2002 15:42:11 +0000 Subject: [PATCH] [project @ 2002-02-05 15:42:04 by simonpj] --------- Main.main --------- A bunch of related fixes concerning 'main' * Arrange that 'main' doesn't need to be defined in module Main; it can be imported. * The typechecker now injects a binding Main.$main = PrelTopHandler.runMain main So the runtime system now calls Main.$main, not PrelMain.main. With z-encoding, this look like Main_zdmain_closure * The function PrelTopHandler.runMain :: IO a -> IO () wraps the programmer's 'main' in an exception-cacthing wrapper. * PrelMain.hs and Main.hi-boot are both removed from lib/std, along with multiple lines of special case handling in lib/std/Makefile. This is a worthwhile cleanup. * Since we now pick up whatever 'main' is in scope, the ranamer gets in on the act (RnRnv.checkMain). There is a little more info to get from the renamer to the typechecker, so I've defined a new type Rename.RnResult (c.f. TcModule.TcResult) * With GHCi, it's now a warning, not an error, to omit the binding of main (RnEnv.checkMain) * It would be easy to add a flag "-main-is foo"; the place to use that information is in RnEnv.checkMain. ------- On the way I made a new type, type HscTypes.FixityEnv = NameEnv Fixity and used it in various places I'd tripped over --- ghc/compiler/main/DriverPipeline.hs | 5 +- ghc/compiler/main/HscMain.lhs | 29 ++----- ghc/compiler/main/HscTypes.lhs | 14 ++- ghc/compiler/main/MkIface.lhs | 8 +- ghc/compiler/prelude/PrelNames.lhs | 27 +++--- ghc/compiler/rename/Rename.lhs | 98 +++++++++++++-------- ghc/compiler/rename/RnEnv.lhs | 41 ++++++--- ghc/compiler/rename/RnHiFiles.lhs | 4 +- ghc/compiler/rename/RnHsSyn.lhs | 3 +- ghc/compiler/rename/RnNames.lhs | 17 ++-- ghc/compiler/rename/RnSource.lhs | 4 +- ghc/compiler/typecheck/TcClassDcl.lhs | 2 +- ghc/compiler/typecheck/TcDeriv.lhs | 15 ++-- ghc/compiler/typecheck/TcEnv.lhs | 5 +- ghc/compiler/typecheck/TcGenDeriv.lhs | 22 ++--- ghc/compiler/typecheck/TcInstDcls.lhs | 20 ++--- ghc/compiler/typecheck/TcModule.lhs | 151 +++++++++++++++------------------ ghc/lib/std/Main.hi-boot | 13 --- ghc/lib/std/Makefile | 18 +--- ghc/lib/std/PrelMain.lhs | 22 ----- ghc/lib/std/PrelTopHandler.hs | 6 +- ghc/rts/Main.c | 6 +- ghc/rts/Prelude.h | 6 +- 23 files changed, 260 insertions(+), 276 deletions(-) delete mode 100644 ghc/lib/std/Main.hi-boot delete mode 100644 ghc/lib/std/PrelMain.lhs diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 345c513..0da82e1 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -45,7 +45,9 @@ import Config import Panic import Util +#ifdef GHCI import Time ( getClockTime ) +#endif import Directory import System import IOExts @@ -910,8 +912,7 @@ doLink o_files = do ++ pkg_extra_ld_opts ++ extra_ld_opts ++ if static && not no_hs_main then - [ "-u", prefixUnderscore "PrelMain_mainIO_closure", - "-u", prefixUnderscore "__stginit_PrelMain"] + [ "-u", prefixUnderscore "Main_zdmain_closure"] else [])) -- parallel only: move binary to another dir -- HWL diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 60c6332..ac90f41 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -66,8 +66,7 @@ import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CodeOutput ( codeOutput ) -import Module ( ModuleName, moduleName, mkHomeModule, - moduleUserString, lookupModuleEnv ) +import Module ( ModuleName, moduleName, mkHomeModule ) import CmdLineOpts import DriverState ( v_HCHeader ) import ErrUtils ( dumpIfSet_dyn, showPass, printError ) @@ -221,33 +220,21 @@ hscRecomp ghci_mode dflags have_object ------------------- -- RENAME ------------------- - ; (pcs_rn, print_unqualified, maybe_rn_result) + ; (pcs_rn, print_unqual, maybe_rn_result) <- _scc_ "Rename" - renameModule dflags hit hst pcs_ch this_mod rdr_module + renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module ; case maybe_rn_result of { - Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); - Just (is_exported, new_iface, rn_hs_decls) -> do { - - -- In interactive mode, we don't want to discard any top-level - -- entities at all (eg. do not inline them away during - -- simplification), and retain them all in the TypeEnv so they are - -- available from the command line. - -- - -- isGlobalName separates the user-defined top-level names from those - -- introduced by the type checker. - - ; let dont_discard | ghci_mode == Interactive = isGlobalName - | otherwise = is_exported + Nothing -> return (HscFail pcs_ch); + Just (dont_discard, new_iface, rn_result) -> do { ------------------- -- TYPECHECK ------------------- ; maybe_tc_result <- _scc_ "TypeCheck" - typecheckModule dflags pcs_rn hst new_iface - print_unqualified rn_hs_decls + typecheckModule dflags pcs_rn hst print_unqual rn_result ; case maybe_tc_result of { - Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); + Nothing -> return (HscFail pcs_ch); Just (pcs_tc, tc_result) -> do { ------------------- @@ -255,7 +242,7 @@ hscRecomp ghci_mode dflags have_object ------------------- ; (ds_details, foreign_stuff) <- _scc_ "DeSugar" - deSugar dflags pcs_tc hst this_mod print_unqualified tc_result + deSugar dflags pcs_tc hst this_mod print_unqual tc_result ; pcs_middle <- _scc_ "pcs_middle" diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index dd5e350..930ea0a 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -21,6 +21,7 @@ module HscTypes ( IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, VersionInfo(..), initialVersionInfo, lookupVersion, + FixityEnv, lookupFixity, TyThing(..), isTyClThing, implicitTyThingIds, @@ -53,7 +54,7 @@ module HscTypes ( #include "HsVersions.h" -import RdrName ( RdrName, RdrNameEnv, addListToRdrEnv, emptyRdrEnv, +import RdrName ( RdrName, RdrNameEnv, addListToRdrEnv, mkRdrUnqual, rdrEnvToList ) import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc ) import NameEnv @@ -67,7 +68,7 @@ import Class ( Class, classSelIds ) import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable ) import DataCon ( dataConId, dataConWrapId ) -import BasicTypes ( Version, initialVersion, Fixity, IPName ) +import BasicTypes ( Version, initialVersion, Fixity, defaultFixity, IPName ) import HsSyn ( DeprecTxt, tyClDeclName, ifaceRuleDeclName ) import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl ) @@ -177,7 +178,7 @@ data ModIface -- Its top level environment or Nothing if we read this -- interface from a file. - mi_fixities :: !(NameEnv Fixity), -- Fixities + mi_fixities :: !FixityEnv, -- Fixities mi_deprecs :: !Deprecations, -- Deprecations mi_decls :: IfaceDecls -- The RnDecls form of ModDetails @@ -492,6 +493,13 @@ pprAvail (AvailTC n ns) = ppr n <> case {- filter (/= n) -} ns of pprAvail (Avail n) = ppr n \end{code} +\begin{code} +type FixityEnv = NameEnv Fixity + +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env n = lookupNameEnv env n `orElse` defaultFixity +\end{code} + %************************************************************************ %* * diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index a3d57e8..de344b7 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -17,14 +17,14 @@ import HsSyn import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr ) import HsTypes ( toHsTyVars ) import TysPrim ( alphaTyVars ) -import BasicTypes ( Fixity(..), NewOrData(..), Activation(..), +import BasicTypes ( NewOrData(..), Activation(..), Version, initialVersion, bumpVersion ) import NewDemand ( isTopSig ) import RnMonad import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..), - ModuleLocation(..), GhciMode(..), + ModuleLocation(..), GhciMode(..), FixityEnv, lookupFixity, IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, TyThing(..), DFunId, Avails, TypeEnv, WhatsImported(..), GenAvailInfo(..), @@ -401,7 +401,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, pp_change False what = text what <+> ptext SLIT("changed") diffDecls :: VersionInfo -- Old version - -> NameEnv Fixity -> NameEnv Fixity -- Old and new fixities + -> FixityEnv -> FixityEnv -- Old and new fixities -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls -> (Bool, -- True <=> no change SDoc, -- Record of differences @@ -414,7 +414,7 @@ diffDecls (VersionInfo { vers_module = old_mod_vers, vers_decls = old_decls_vers -- When seeing if two decls are the same, -- remember to check whether any relevant fixity has changed eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1) - same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n + same_fixity n = lookupFixity old_fixities n == lookupFixity new_fixities n diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers) diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods [] diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 72cd65c..be714d1 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -96,7 +96,7 @@ knownKeyNames = [ -- Type constructors (synonyms especially) ioTyConName, ioDataConName, - mainName, + runMainName, orderingTyConName, rationalTyConName, ratioDataConName, @@ -226,8 +226,8 @@ pREL_PTR_Name = mkModuleName "PrelPtr" pREL_ERR_Name = mkModuleName "PrelErr" pREL_REAL_Name = mkModuleName "PrelReal" pREL_FLOAT_Name = mkModuleName "PrelFloat" +pREL_TOP_HANDLER_Name = mkModuleName "PrelTopHandler" -pREL_MAIN_Name = mkModuleName "PrelMain" mAIN_Name = mkModuleName "Main" pREL_INT_Name = mkModuleName "PrelInt" pREL_WORD_Name = mkModuleName "PrelWord" @@ -308,7 +308,8 @@ compiler (notably the deriving mechanism) need to mention their names, and it's convenient to write them all down in one place. \begin{code} -mainName = varQual mAIN_Name SLIT("main") mainKey +dollarMainName = varQual mAIN_Name SLIT("$main") dollarMainKey +runMainName = varQual pREL_TOP_HANDLER_Name SLIT("runMain") runMainKey -- Stuff from PrelGHC usOnceTyConName = kindQual SLIT(".") usOnceTyConKey @@ -860,6 +861,13 @@ voidArgIdKey = mkPreludeMiscIdUnique 47 splitIdKey = mkPreludeMiscIdUnique 48 fstIdKey = mkPreludeMiscIdUnique 49 sndIdKey = mkPreludeMiscIdUnique 50 +otherwiseIdKey = mkPreludeMiscIdUnique 51 +mapIdKey = mkPreludeMiscIdUnique 52 +assertIdKey = mkPreludeMiscIdUnique 53 +runSTRepIdKey = mkPreludeMiscIdUnique 54 + +dollarMainKey = mkPreludeMiscIdUnique 55 +runMainKey = mkPreludeMiscIdUnique 56 \end{code} Certain class operations from Prelude classes. They get their own @@ -867,6 +875,8 @@ uniques so we can look them up easily when we want to conjure them up during type checking. \begin{code} + -- Just a place holder for unbound variables produced by the renamer: +unboundKey = mkPreludeMiscIdUnique 101 fromIntegerClassOpKey = mkPreludeMiscIdUnique 102 minusClassOpKey = mkPreludeMiscIdUnique 103 fromRationalClassOpKey = mkPreludeMiscIdUnique 104 @@ -879,20 +889,9 @@ geClassOpKey = mkPreludeMiscIdUnique 110 negateClassOpKey = mkPreludeMiscIdUnique 111 failMClassOpKey = mkPreludeMiscIdUnique 112 thenMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=) - -- Just a place holder for unbound variables produced by the renamer: -unboundKey = mkPreludeMiscIdUnique 114 fromEnumClassOpKey = mkPreludeMiscIdUnique 115 - -mainKey = mkPreludeMiscIdUnique 116 returnMClassOpKey = mkPreludeMiscIdUnique 117 -otherwiseIdKey = mkPreludeMiscIdUnique 118 toEnumClassOpKey = mkPreludeMiscIdUnique 119 -mapIdKey = mkPreludeMiscIdUnique 120 -\end{code} - -\begin{code} -assertIdKey = mkPreludeMiscIdUnique 121 -runSTRepIdKey = mkPreludeMiscIdUnique 122 \end{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 53f332f..cc80388 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -5,7 +5,7 @@ \begin{code} module Rename ( - renameModule, renameStmt, renameRdrName, mkGlobalContext, + renameModule, RnResult(..), renameStmt, renameRdrName, mkGlobalContext, closeIfaceDecls, checkOldIface, slurpIface ) where @@ -39,14 +39,14 @@ import RnEnv ( availsToNameSet, warnUnusedLocalBinds, warnUnusedModules, lookupSrcName, getImplicitStmtFVs, getImplicitModuleFVs, newGlobalName, unQualInScope, - ubiquitousNames, lookupOccRn, + ubiquitousNames, lookupOccRn, checkMain, plusGlobalRdrEnv, mkGlobalRdrEnv ) import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, moduleName, moduleEnvElts ) -import Name ( Name, nameModule ) +import Name ( Name, nameModule, isGlobalName ) import NameEnv import NameSet import RdrName ( foldRdrEnv, isQual ) @@ -72,17 +72,17 @@ import List ( partition, nub ) %********************************************************* \begin{code} -renameModule :: DynFlags +renameModule :: DynFlags -> GhciMode -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsModule -> IO (PersistentCompilerState, PrintUnqualified, - Maybe (IsExported, ModIface, [RenamedHsDecl])) + Maybe (IsExported, ModIface, RnResult)) -- Nothing => some error occurred in the renamer -renameModule dflags hit hst pcs this_module rdr_module +renameModule dflags ghci_mode hit hst pcs this_module rdr_module = renameSource dflags hit hst pcs this_module $ - rename this_module rdr_module + rename ghci_mode this_module rdr_module \end{code} \begin{code} @@ -300,9 +300,22 @@ renameSource dflags hit hst old_pcs this_module thing_inside \end{code} \begin{code} -rename :: Module -> RdrNameHsModule - -> RnMG (PrintUnqualified, Maybe (IsExported, ModIface, [RenamedHsDecl])) -rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc) +data RnResult -- A RenamedModule ia passed from renamer to typechecker + = RnResult { rr_mod :: Module, -- Same as in the ModIface, + rr_fixities :: FixityEnv, -- but convenient to have it here + + rr_main :: Maybe Name, -- Just main, for module Main, + -- Nothing for other modules + + rr_decls :: [RenamedHsDecl] + -- The other declarations of the module + -- Fixity and deprecations have already been slurped out + } -- and are now in the ModIface for the module + +rename :: GhciMode -> Module -> RdrNameHsModule + -> RnMG (PrintUnqualified, Maybe (IsExported, ModIface, RnResult)) +rename ghci_mode this_module + contents@(HsModule _ _ exports imports local_decls mod_deprec loc) = pushSrcLocRn loc $ -- FIND THE GLOBAL NAME ENVIRONMENT @@ -352,6 +365,26 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec rnSourceDecls gbl_env global_avail_env local_fixity_env local_decls `thenRn` \ (rn_local_decls, source_fvs) -> + -- GET ANY IMPLICIT FREE VARIALBES + getImplicitModuleFVs rn_local_decls `thenRn` \ implicit_fvs -> + checkMain ghci_mode mod_name gbl_env `thenRn` \ (maybe_main_name, main_fvs, implicit_main_fvs) -> + let + export_fvs = availsToNameSet export_avails + used_fvs = source_fvs `plusFV` export_fvs `plusFV` main_fvs + -- The export_fvs make the exported names look just as if they + -- occurred in the source program. For the reasoning, see the + -- comments with RnIfaces.mkImportInfo + -- It also helps reportUnusedNames, which of course must not complain + -- that 'f' isn't mentioned if it is mentioned in the export list + + needed_fvs = implicit_fvs `plusFV` implicit_main_fvs `plusFV` used_fvs + -- It's important to do the "plus" this way round, so that + -- when compiling the prelude, locally-defined (), Bool, etc + -- override the implicit ones. + + in + traceRn (text "Needed FVs:" <+> fsep (map ppr (nameSetToList needed_fvs))) `thenRn_` + -- EXIT IF ERRORS FOUND -- We exit here if there are any errors in the source, *before* -- we attempt to slurp the decls from the interfaces, otherwise @@ -365,25 +398,7 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec else -- SLURP IN ALL THE NEEDED DECLARATIONS - -- Find out what re-bindable names to use for desugaring - getImplicitModuleFVs mod_name rn_local_decls `thenRn` \ implicit_fvs -> - let - export_fvs = availsToNameSet export_avails - source_fvs2 = source_fvs `plusFV` export_fvs - -- The export_fvs make the exported names look just as if they - -- occurred in the source program. For the reasoning, see the - -- comments with RnIfaces.mkImportInfo - -- It also helps reportUnusedNames, which of course must not complain - -- that 'f' isn't mentioned if it is mentioned in the export list - - source_fvs3 = implicit_fvs `plusFV` source_fvs2 - -- It's important to do the "plus" this way round, so that - -- when compiling the prelude, locally-defined (), Bool, etc - -- override the implicit ones. - - in - traceRn (text "Source FVs:" <+> fsep (map ppr (nameSetToList source_fvs3))) `thenRn_` - slurpImpDecls source_fvs3 `thenRn` \ rn_imp_decls -> + slurpImpDecls needed_fvs `thenRn` \ rn_imp_decls -> rnDump rn_imp_decls rn_local_decls `thenRn_` -- GENERATE THE VERSION/USAGE INFO @@ -402,6 +417,19 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec final_decls = rn_local_decls ++ rn_imp_decls + -- In interactive mode, we don't want to discard any top-level + -- entities at all (eg. do not inline them away during + -- simplification), and retain them all in the TypeEnv so they are + -- available from the command line. + -- + -- isGlobalName separates the user-defined top-level names from those + -- introduced by the type checker. + dont_discard :: Name -> Bool + dont_discard | ghci_mode == Interactive = isGlobalName + | otherwise = (`elemNameSet` exported_names) + + exported_names = availsToNameSet export_avails + mod_iface = ModIface { mi_module = this_module, mi_package = opt_InPackage, mi_version = initialVersionInfo, @@ -415,18 +443,20 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec mi_decls = panic "mi_decls" } - is_exported name = name `elemNameSet` exported_names - exported_names = availsToNameSet export_avails + rn_result = RnResult { rr_mod = this_module, + rr_fixities = fixities, + rr_decls = final_decls, + rr_main = maybe_main_name } in -- REPORT UNUSED NAMES, AND DEBUG DUMP reportUnusedNames mod_iface print_unqualified imports full_avail_env gbl_env - source_fvs2 rn_imp_decls `thenRn_` - -- NB: source_fvs2: include exports (else we get bogus + used_fvs rn_imp_decls `thenRn_` + -- NB: used_fvs: include exports (else we get bogus -- warnings of unused things) but not implicit FVs. - returnRn (print_unqualified, Just (is_exported, mod_iface, final_decls)) + returnRn (print_unqualified, Just (dont_discard, mod_iface, rn_result)) where mod_name = moduleName this_module \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 6835f93..331b0d0 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -21,7 +21,7 @@ import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), - ModIface(..), + ModIface(..), GhciMode(..), Deprecations(..), lookupDeprec, extendLocalRdrEnv ) @@ -39,8 +39,8 @@ 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, @@ -415,15 +415,10 @@ getImplicitStmtFVs -- Compiling a statement -- 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 +439,30 @@ 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!) + +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} %************************************************************************ @@ -1009,6 +1028,8 @@ 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 diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 4838be4..4eb5504 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -16,7 +16,7 @@ module RnHiFiles ( #include "HsVersions.h" -import DriverState ( GhcMode(..), v_GhcMode, isCompManagerMode ) +import DriverState ( v_GhcMode, isCompManagerMode ) import DriverUtil ( splitFilename ) import CmdLineOpts ( opt_IgnoreIfacePragmas ) import HscTypes ( ModuleLocation(..), @@ -28,7 +28,7 @@ import HscTypes ( ModuleLocation(..), AvailInfo, GenAvailInfo(..), Avails, Deprecations(..) ) import HsSyn ( TyClDecl(..), InstDecl(..), - HsType(..), HsPred(..), FixitySig(..), RuleDecl(..), + FixitySig(..), RuleDecl(..), tyClDeclNames, tyClDeclSysNames, hsTyVarNames, getHsInstHead, ) import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 660feca..7a955f1 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -20,11 +20,11 @@ import Outputable \begin{code} +type RenamedHsDecl = HsDecl Name RenamedPat type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat type RenamedClassOpSig = Sig Name type RenamedConDecl = ConDecl Name type RenamedContext = HsContext Name -type RenamedHsDecl = HsDecl Name RenamedPat type RenamedRuleDecl = RuleDecl Name RenamedPat type RenamedTyClDecl = TyClDecl Name RenamedPat type RenamedDefaultDecl = DefaultDecl Name @@ -33,7 +33,6 @@ type RenamedGRHS = GRHS Name RenamedPat type RenamedGRHSs = GRHSs Name RenamedPat type RenamedHsBinds = HsBinds Name RenamedPat type RenamedHsExpr = HsExpr Name RenamedPat -type RenamedHsModule = HsModule Name RenamedPat type RenamedInstDecl = InstDecl Name RenamedPat type RenamedMatchContext = HsMatchContext Name type RenamedMatch = Match Name RenamedPat diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 133b19d..24fe3d9 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -25,7 +25,7 @@ import RnEnv import RnMonad import FiniteMap -import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR_Unqual, isUnboundName ) +import PrelNames ( pRELUDE_Name, mAIN_Name, isUnboundName ) import Module ( ModuleName, moduleName, WhereFrom(..) ) import Name ( Name, nameSrcLoc, nameOccName ) import NameSet @@ -38,7 +38,7 @@ import RdrName ( rdrNameOcc, setRdrNameOcc ) import OccName ( setOccNameSpace, dataName ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable -import Maybes ( maybeToBool, catMaybes, mapMaybe ) +import Maybes ( maybeToBool, catMaybes ) import ListSetOps ( removeDups ) import Util ( sortLt ) import List ( partition ) @@ -449,13 +449,14 @@ exportsFromAvail :: ModuleName -- Complains about exports items not in scope exportsFromAvail this_mod Nothing mod_avail_env entity_avail_env global_name_env - = exportsFromAvail this_mod true_exports mod_avail_env entity_avail_env global_name_env + = exportsFromAvail this_mod (Just true_exports) mod_avail_env + entity_avail_env global_name_env where - true_exports = Just $ if this_mod == mAIN_Name - then [IEVar main_RDR_Unqual] - -- export Main.main *only* unless otherwise specified, - else [IEModuleContents this_mod] - -- but for all other modules export everything. + true_exports + | this_mod == mAIN_Name = [] + -- Export nothing; Main.$main is automatically exported + | otherwise = [IEModuleContents this_mod] + -- but for all other modules export everything. exportsFromAvail this_mod (Just export_items) mod_avail_env entity_avail_env global_name_env diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index b5386a3..b02f49b 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -23,7 +23,7 @@ import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext ) import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs ) import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName, - lookupOrigNames, lookupSysBinder, newLocalsRn, + lookupSysBinder, newLocalsRn, bindLocalsFVRn, bindPatSigTyVars, bindTyVarsRn, extendTyVarEnvFVRn, bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, @@ -35,7 +35,6 @@ import Class ( FunDep, DefMeth (..) ) import DataCon ( dataConId ) import Name ( Name, NamedThing(..) ) import NameSet -import PrelInfo ( derivableClassKeys ) import PrelNames ( deRefStablePtrName, newStablePtrName, bindIOName, returnIOName ) @@ -45,7 +44,6 @@ import Outputable import SrcLoc ( SrcLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars -import Unique ( Uniquable(..) ) import Maybes ( maybeToBool ) \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 9f47b32..a89895a 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -25,7 +25,7 @@ import TcHsSyn ( TcMonoBinds ) import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, instToId, newDicts, newMethod ) -import TcEnv ( RecTcEnv, TyThingDetails(..), +import TcEnv ( TyThingDetails(..), tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, tcExtendLocalValEnv, tcExtendTyVarEnv ) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 6655ad0..8e74966 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -14,11 +14,11 @@ import HsSyn ( HsBinds(..), MonoBinds(..), TyClDecl(..), collectLocatedMonoBinders ) import RdrHsSyn ( RdrNameMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl, RenamedHsPred ) -import CmdLineOpts ( DynFlag(..), DynFlags ) +import CmdLineOpts ( DynFlag(..) ) import TcMonad import TcEnv ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo, - tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv + tcLookupTyCon, tcExtendTyVarEnv ) import TcGenDeriv -- Deriv stuff import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv ) @@ -28,11 +28,11 @@ import TcSimplify ( tcSimplifyDeriv ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) import RnEnv ( bindLocatedLocalsRn ) import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn ) -import HscTypes ( DFunId, PersistentRenamerState ) +import HscTypes ( DFunId, PersistentRenamerState, FixityEnv ) import BasicTypes ( Fixity, NewOrData(..) ) import Class ( className, classKey, classTyVars, Class ) -import ErrUtils ( dumpIfSet_dyn, Message ) +import ErrUtils ( dumpIfSet_dyn ) import MkId ( mkDictFunId ) import DataCon ( dataConRepArgTys, isNullaryDataCon, isExistentialDataCon ) import PrelInfo ( needsDataDeclCtxtClassKeys ) @@ -51,11 +51,10 @@ import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_mayb import Var ( TyVar, tyVarKind ) import VarSet ( mkVarSet, subVarSet ) import PrelNames -import Util ( zipWithEqual, sortLt, eqListBy ) +import Util ( zipWithEqual, sortLt ) import ListSetOps ( removeDups, assoc ) import Outputable import Maybe ( isJust ) -import List ( nub ) import FastString ( FastString ) \end{code} @@ -190,7 +189,7 @@ context to the instance decl. The "offending classes" are tcDeriving :: PersistentRenamerState -> Module -- name of module under scrutiny -> InstEnv -- What we already know about instances - -> (Name -> Maybe Fixity) -- used in deriving Show and Read + -> FixityEnv -- used in deriving Show and Read -> [RenamedTyClDecl] -- All type constructors -> TcM ([InstInfo], -- The generated "instance decls". RenamedHsBinds) -- Extra generated bindings @@ -616,7 +615,7 @@ the renamer. What a great hack! -- Generate the method bindings for the required instance -- (paired with class name, as we need that when renaming -- the method binds) -gen_bind :: (Name -> Maybe Fixity) -> DFunId -> (Name, RdrNameMonoBinds) +gen_bind :: FixityEnv -> DFunId -> (Name, RdrNameMonoBinds) gen_bind get_fixity dfun = (cls_nm, binds) where diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 744fb42..c08e43b 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -45,9 +45,8 @@ import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet, tyVarsOfTypes, tcSplitDFunTy, getDFunTyKey, tcTyConAppTyCon ) -import Id ( idName, isDataConWrapId_maybe ) -import IdInfo ( vanillaIdInfo ) -import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) +import Id ( isDataConWrapId_maybe ) +import Var ( TyVar, Id, idType ) import VarSet import DataCon ( DataCon ) import TyCon ( TyCon ) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index ab74683..ac77456 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -34,7 +34,7 @@ import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) import RdrName ( RdrName, mkUnqual ) import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) - , maxPrecedence, defaultFixity + , maxPrecedence , Boxity(..) ) import FieldLabel ( fieldLabelName ) @@ -48,6 +48,7 @@ import Name ( getOccString, getOccName, getSrcLoc, occNameString, isDataSymOcc, isSymOcc ) +import HscTypes ( FixityEnv, lookupFixity ) import PrelInfo -- Lots of RdrNames import SrcLoc ( generatedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, @@ -60,7 +61,7 @@ import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, import Util ( mapAccumL, zipEqual, zipWithEqual, isSingleton, zipWith3Equal, nOfThem ) import Panic ( panic, assertPanic ) -import Maybes ( maybeToBool, orElse ) +import Maybes ( maybeToBool ) import Constants import List ( partition, intersperse ) @@ -751,7 +752,7 @@ gen_Ix_binds tycon %************************************************************************ \begin{code} -gen_Read_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds +gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds gen_Read_binds get_fixity tycon = reads_prec `AndMonoBinds` read_list @@ -908,7 +909,7 @@ gen_Read_binds get_fixity tycon %************************************************************************ \begin{code} -gen_Show_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds +gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds gen_Show_binds get_fixity tycon = shows_prec `AndMonoBinds` show_list @@ -1012,7 +1013,7 @@ gen_Show_binds get_fixity tycon \end{code} \begin{code} -getLRPrecs :: Bool -> (Name -> Maybe Fixity) -> Name -> [Integer] +getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer] getLRPrecs is_infix get_fixity nm = [lp, rp] where {- @@ -1035,15 +1036,14 @@ getLRPrecs is_infix get_fixity nm = [lp, rp] defaultPrecedence :: Integer defaultPrecedence = fromInt maxPrecedence -getPrecedence :: (Name -> Maybe Fixity) -> Name -> Integer +getPrecedence :: FixityEnv -> Name -> Integer getPrecedence get_fixity nm - = case get_fixity nm of - Just (Fixity x _) -> fromInt x - other -> defaultPrecedence + = case lookupFixity get_fixity nm of + Fixity x _ -> fromInt x -isLRAssoc :: (Name -> Maybe Fixity) -> Name -> (Bool, Bool) +isLRAssoc :: FixityEnv -> Name -> (Bool, Bool) isLRAssoc get_fixity nm = - case get_fixity nm `orElse` defaultFixity of + case lookupFixity get_fixity nm of Fixity _ InfixN -> (False, False) Fixity _ InfixR -> (False, True) Fixity _ InfixL -> (True, False) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 21ed1d5..d0335bc 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -12,12 +12,12 @@ module TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, import CmdLineOpts ( DynFlag(..) ) -import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..), +import HsSyn ( InstDecl(..), TyClDecl(..), HsType(..), MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), HsTyVarBndr(..), andMonoBindList, collectMonoBinders, isClassDecl, toHsType ) -import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, +import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, extractHsTyVars, maybeGenericMatch ) @@ -27,14 +27,14 @@ import TcClassDcl ( tcMethodBind, badMethodErr ) import TcMonad import TcMType ( tcInstSigType, checkValidTheta, checkValidInstHead, instTypeErr, UserTypeCtxt(..), SourceTyCtxt(..) ) -import TcType ( mkClassPred, mkTyVarTy, mkTyVarTys, tcSplitForAllTys, +import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, TyVarDetails(..) ) import Inst ( InstOrigin(..), newDicts, instToId, LIE, mkLIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) -import TcEnv ( TcEnv, tcExtendGlobalValEnv, isLocalThing, +import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, tcLookupId, tcLookupClass, InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, newDFunName @@ -44,11 +44,11 @@ import PprType ( pprClassPred ) import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType ) import TcUnify ( checkSigTyVars ) import TcSimplify ( tcSimplifyCheck ) -import HscTypes ( HomeSymbolTable, DFunId, +import HscTypes ( HomeSymbolTable, DFunId, FixityEnv, PersistentCompilerState(..), PersistentRenamerState, - ModDetails(..), PackageInstEnv + ModDetails(..) ) -import Subst ( substTy, substTheta ) +import Subst ( substTheta ) import DataCon ( classDataCon ) import Class ( Class, classBigSig ) import Var ( idName, idType ) @@ -63,17 +63,15 @@ import NameSet ( unitNameSet, emptyNameSet, nameSetToList ) import TyCon ( TyCon ) import Subst ( mkTopTyVarSubst, substTheta ) import TysWiredIn ( genericTyCons ) -import Name ( Name ) import SrcLoc ( SrcLoc ) import Unique ( Uniquable(..) ) import Util ( lengthExceeds, isSingleton ) -import BasicTypes ( NewOrData(..), Fixity ) +import BasicTypes ( NewOrData(..) ) import ErrUtils ( dumpIfSet_dyn ) import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, assocElts, extendAssoc_C, equivClassesByUniq, minusList ) import Maybe ( catMaybes ) -import List ( partition ) import Outputable \end{code} @@ -163,7 +161,7 @@ Gather up the instance declarations from their various sources tcInstDecls1 -- Deal with source-code instance decls :: PersistentRenamerState -> InstEnv -- Imported instance envt - -> (Name -> Maybe Fixity) -- for deriving Show and Read + -> FixityEnv -- for deriving Show and Read -> Module -- Module for deriving -> [RenamedTyClDecl] -- For deriving stuff -> [RenamedInstDecl] -- Source code instance decls diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 50ff6f7..9baf81b 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -15,45 +15,46 @@ module TcModule ( import CmdLineOpts ( DynFlag(..), DynFlags, dopt ) import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..), - isSourceInstDecl, nullBinds, mkSimpleMatch, placeHolderType + isSourceInstDecl, mkSimpleMatch, placeHolderType ) -import PrelNames ( mAIN_Name, mainName, ioTyConName, printName, - returnIOName, bindIOName, failIOName, - itName +import PrelNames ( ioTyConName, printName, + returnIOName, bindIOName, failIOName, runMainName, + dollarMainName, itName ) import MkId ( unsafeCoerceId ) -import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedStmt, - RenamedHsExpr, RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl ) +import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedHsExpr, + RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl ) import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, TypecheckedForeignDecl, TypecheckedRuleDecl, zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet, zonkExpr, zonkIdBndr ) +import Rename ( RnResult(..) ) import MkIface ( pprModDetails ) import TcExpr ( tcMonoExpr ) import TcMonad -import TcMType ( newTyVarTy, zonkTcType, tcInstType ) +import TcMType ( newTyVarTy, zonkTcType ) import TcType ( Type, liftedTypeKind, openTypeKind, - tyVarsOfType, tidyType, tcFunResultTy, - mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys + tyVarsOfType, tcFunResultTy, + mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys, + tcSplitTyConApp_maybe, isUnitTy ) import TcMatches ( tcStmtsAndThen ) -import Inst ( emptyLIE, plusLIE ) +import Inst ( LIE, emptyLIE, plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults, defaultDefaultTys ) -import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookup_maybe, +import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv, tcExtendGlobalEnv, tcExtendGlobalTypeEnv, tcLookupGlobalId, tcLookupTyCon, - TcTyThing(..), TyThing(..), tcLookupId + TyThing(..), tcLookupId ) import TcRules ( tcIfaceRules, tcSourceRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, initInstEnv, tcInstDecls2 ) -import TcUnify ( unifyTauTy ) import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) import TcTyClsDecls ( tcTyAndClassDecls ) import CoreUnfold ( unfoldingTemplate ) @@ -61,12 +62,11 @@ import TysWiredIn ( mkListTy, unitTy ) import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, dumpIfSet_dyn_or, showPass ) import Rules ( extendRuleBase ) -import Id ( Id, idType, idUnfolding ) -import Module ( Module, moduleName ) -import Name ( Name ) -import NameEnv ( lookupNameEnv ) +import Id ( Id, mkLocalId, idType, idUnfolding, setIdLocalExported ) +import Module ( Module ) +import Name ( Name, getName, getSrcLoc ) import TyCon ( tyConGenInfo ) -import BasicTypes ( EP(..), Fixity, RecFlag(..) ) +import BasicTypes ( EP(..), RecFlag(..) ) import SrcLoc ( noSrcLoc ) import Outputable import IO ( stdout ) @@ -339,9 +339,8 @@ typecheckModule :: DynFlags -> PersistentCompilerState -> HomeSymbolTable - -> ModIface -- Iface for this module -> PrintUnqualified -- For error printing - -> [RenamedHsDecl] + -> RnResult -> IO (Maybe (PersistentCompilerState, TcResults)) -- The new PCS is Augmented with imported information, -- (but not stuff from this module) @@ -357,27 +356,19 @@ data TcResults } -typecheckModule dflags pcs hst mod_iface unqual decls +typecheckModule dflags pcs hst unqual rn_result = do { maybe_tc_result <- typecheck dflags pcs hst unqual $ - tcModule pcs hst get_fixity this_mod decls + tcModule pcs hst rn_result ; printTcDump dflags unqual maybe_tc_result ; return maybe_tc_result } - where - this_mod = mi_module mod_iface - fixity_env = mi_fixities mod_iface - - get_fixity :: Name -> Maybe Fixity - get_fixity nm = lookupNameEnv fixity_env nm - tcModule :: PersistentCompilerState -> HomeSymbolTable - -> (Name -> Maybe Fixity) - -> Module - -> [RenamedHsDecl] + -> RnResult -> TcM (PersistentCompilerState, TcResults) -tcModule pcs hst get_fixity this_mod decls +tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod, + rr_fixities = fix_env, rr_main = maybe_main_name }) = fixTc (\ ~(unf_env, _, _) -> -- Loop back the final environment, including the fully zonked -- versions of bindings from this module. In the presence of mutual @@ -385,7 +376,7 @@ tcModule pcs hst get_fixity this_mod decls -- in this module, which is why the knot is so big -- Type-check the type and class decls, and all imported decls - tcImports unf_env pcs hst get_fixity this_mod + tcImports unf_env pcs hst this_mod tycl_decls iface_inst_decls iface_rule_decls `thenTc` \ (env1, new_pcs) -> tcSetEnv env1 $ @@ -393,7 +384,7 @@ tcModule pcs hst get_fixity this_mod decls -- Do the source-language instances, including derivings initInstEnv new_pcs hst `thenNF_Tc` \ inst_env1 -> tcInstDecls1 (pcs_PRS new_pcs) inst_env1 - get_fixity this_mod + fix_env this_mod tycl_decls src_inst_decls `thenTc` \ (inst_env2, inst_info, deriv_binds) -> tcSetInstEnv inst_env2 $ @@ -428,7 +419,7 @@ tcModule pcs hst get_fixity this_mod decls -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED traceTc (text "Tc10") `thenNF_Tc_` - tcCheckMain this_mod `thenTc_` + tcCheckMain maybe_main_name `thenTc` \ (main_bind, lie_main) -> -- Deal with constant or ambiguous InstIds. How could -- there be ambiguous ones? They can only arise if a @@ -449,19 +440,21 @@ tcModule pcs hst get_fixity this_mod decls lie_instdecls `plusLIE` lie_clasdecls `plusLIE` lie_fodecls `plusLIE` - lie_rules + lie_rules `plusLIE` + lie_main in tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> - traceTc (text "endsimpltop") `thenTc_` + traceTc (text "endsimpltop") `thenTc_` -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. let - all_binds = val_binds `AndMonoBinds` - inst_binds `AndMonoBinds` - cls_dm_binds `AndMonoBinds` - const_inst_binds `AndMonoBinds` - foe_binds + all_binds = val_binds `AndMonoBinds` + inst_binds `AndMonoBinds` + cls_dm_binds `AndMonoBinds` + const_inst_binds `AndMonoBinds` + foe_binds `AndMonoBinds` + main_bind in traceTc (text "Tc7") `thenNF_Tc_` zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) -> @@ -590,7 +583,6 @@ tcIfaceImports this_mod decls tcImports :: RecTcEnv -> PersistentCompilerState -> HomeSymbolTable - -> (Name -> Maybe Fixity) -> Module -> [RenamedTyClDecl] -> [RenamedInstDecl] @@ -608,7 +600,7 @@ tcImports :: RecTcEnv -- tcImports is only called when processing source code, -- so that any interface-file declarations are for other modules, not this one -tcImports unf_env pcs hst get_fixity this_mod +tcImports unf_env pcs hst this_mod tycl_decls inst_decls rule_decls -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas -- which is done lazily [ie failure just drops the pragma @@ -688,48 +680,43 @@ addIfaceRules rule_base rules %************************************************************************ We must check that in module Main, - a) main is defined - b) main :: forall a1...an. IO t, for some type t + a) Main.main is in scope + b) Main.main :: forall a1...an. IO t, for some type t -If we have - main = error "Urk" -then the type of main will be - main :: forall a. a -and that should pass the test too. +Then we build + $main = PrelTopHandler.runMain Main.main -So we just instantiate the type and unify with IO t, and declare -victory if doing so succeeds. +The function + PrelTopHandler :: IO a -> IO () +catches the top level exceptions. +It accepts a Main.main of any type (IO a). \begin{code} -tcCheckMain :: Module -> TcM () -tcCheckMain this_mod - | not (moduleName this_mod == mAIN_Name ) - = returnTc () - - | otherwise - = -- First unify the main_id with IO t, for any old t - tcLookup_maybe mainName `thenNF_Tc` \ maybe_thing -> - case maybe_thing of - Just (ATcId main_id) -> check_main_ty (idType main_id) - other -> addErrTc noMainErr +tcCheckMain :: Maybe Name -> TcM (TypecheckedMonoBinds, LIE) +tcCheckMain Nothing = returnTc (EmptyMonoBinds, emptyLIE) + +tcCheckMain (Just main_name) + = tcLookupId main_name `thenNF_Tc` \ main_id -> + -- If it is not Nothing, it should be in the env + tcAddSrcLoc (getSrcLoc main_id) $ + tcAddErrCtxt mainCtxt $ + newTyVarTy liftedTypeKind `thenNF_Tc` \ ty -> + tcMonoExpr rhs ty `thenTc` \ (main_expr, lie) -> + zonkTcType ty `thenNF_Tc` \ ty -> + ASSERT( is_io_unit ty ) + let + dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) + in + returnTc (VarMonoBind dollar_main_id main_expr, lie) where - check_main_ty main_ty - = tcInstType main_ty `thenNF_Tc` \ (tvs, theta, main_tau) -> - newTyVarTy liftedTypeKind `thenNF_Tc` \ arg_ty -> - tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon -> - tcAddErrCtxtM (mainTypeCtxt main_ty) $ - if not (null theta) then - failWithTc empty -- Context has the error message - else - unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty]) - -mainTypeCtxt main_ty tidy_env - = zonkTcType main_ty `thenNF_Tc` \ main_ty' -> - returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+> - quotes (ppr (tidyType tidy_env main_ty'))) - -noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name), - ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))] + rhs = HsApp (HsVar runMainName) (HsVar main_name) + +is_io_unit :: Type -> Bool -- True for IO () +is_io_unit tau = case tcSplitTyConApp_maybe tau of + Just (tc, [arg]) -> getName tc == ioTyConName && isUnitTy arg + other -> False + +mainCtxt = ptext SLIT("When checking the type of 'main'") \end{code} diff --git a/ghc/lib/std/Main.hi-boot b/ghc/lib/std/Main.hi-boot deleted file mode 100644 index 844073f..0000000 --- a/ghc/lib/std/Main.hi-boot +++ /dev/null @@ -1,13 +0,0 @@ ---------------------------------------------------------------------------- --- Main.hi --- --- This hand-written interface file fakes a "Main" module --- It is used *solely* so that GHCmain generates the right kind of --- external reference to Main.main ---------------------------------------------------------------------------- - -__interface Main 1 where -__export Main main ; -1 main :: __forall a => PrelIOBase.IO a; -- wish this could be __o. KSW 1999-04. - - diff --git a/ghc/lib/std/Makefile b/ghc/lib/std/Makefile index 4b9f456..9248da2 100644 --- a/ghc/lib/std/Makefile +++ b/ghc/lib/std/Makefile @@ -88,26 +88,17 @@ endif DLL_DESCRIPTION="GHC-compiled Haskell Prelude" -ifeq "$(DLLized)" "YES" -EXCLUDED_SRCS += Prelmain.lhs -# PrelMain.dll_o isn't to be included in the final .a, -# but it needs to be generated -all :: PrelMain.dll_o -endif - CLEAN_FILES += PrelGHC.hi-boot PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi) #----------------------------------------------------------------------------- # Building the library for GHCi # -# The procedure differs from that in fptools/mk/target.mk in two ways: -# (a) we don't want PrelMain in the GHCi std library -# (b) on Win32 we must split it into two, because a single .o file can't +# The procedure differs from that in fptools/mk/target.mk in one way: +# (*) on Win32 we must split it into two, because a single .o file can't # have more than 65536 relocations in it. # -# we don't want PrelMain in the GHCi library. -GHCI_LIBOBJS = $(filter-out PrelMain.$(way_)o,$(HS_OBJS)) +GHCI_LIBOBJS = $(HS_OBJS) # Turn off standard rule which creates HSstd.o from LIBOBJS. DONT_WANT_STD_GHCI_LIB_RULE=YES @@ -144,9 +135,6 @@ override datadir:=$(libdir)/imports/std # # Files to install from here # -ifeq "$(DLLized)" "YES" -INSTALL_LIBS += PrelMain.dll_o -endif INSTALL_DATAS += PrelGHC.$(way_)hi diff --git a/ghc/lib/std/PrelMain.lhs b/ghc/lib/std/PrelMain.lhs deleted file mode 100644 index d484482..0000000 --- a/ghc/lib/std/PrelMain.lhs +++ /dev/null @@ -1,22 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelMain.lhs,v 1.9 2001/05/21 14:07:31 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelMain]{Module @PrelMain@} - -\begin{code} -module PrelMain( mainIO ) where - -import {-# SOURCE #-} qualified Main -- for type of "Main.main" - -import IO -import PrelException -import PrelTopHandler - -mainIO :: IO () -- It must be of type (IO t) because that's what - -- the RTS expects. GHC doesn't check this, so - -- make sure this type signature stays! -mainIO = catchException Main.main topHandler -\end{code} diff --git a/ghc/lib/std/PrelTopHandler.hs b/ghc/lib/std/PrelTopHandler.hs index 1159631..9773728 100644 --- a/ghc/lib/std/PrelTopHandler.hs +++ b/ghc/lib/std/PrelTopHandler.hs @@ -20,7 +20,7 @@ -- Note: used to be called PrelTopHandler.lhs, so if you're looking -- for CVS info, try 'cvs log'ging it too. module PrelTopHandler ( - topHandler, reportStackOverflow, reportError + runMain, reportStackOverflow, reportError ) where import IO @@ -30,6 +30,10 @@ import PrelPtr import PrelIOBase import PrelException +-- runMain is applied to Main.main by TcModule +runMain :: IO a -> IO () +runMain main = catchException (main >> return ()) topHandler + topHandler :: Exception -> IO () topHandler err = catchException (real_handler err) topHandler diff --git a/ghc/rts/Main.c b/ghc/rts/Main.c index a8ca10c..def9e55 100644 --- a/ghc/rts/Main.c +++ b/ghc/rts/Main.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Main.c,v 1.32 2002/01/22 13:54:22 simonmar Exp $ + * $Id: Main.c,v 1.33 2002/02/05 15:42:04 simonpj Exp $ * * (c) The GHC Team 1998-2000 * @@ -39,7 +39,7 @@ # include #endif -extern void __stginit_PrelMain(void); +extern void __stginit_Main(void); /* Hack: we assume that we're building a batch-mode system unless * INTERPRETER is set @@ -51,7 +51,7 @@ int main(int argc, char *argv[]) SchedulerStatus status; /* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */ - startupHaskell(argc,argv,__stginit_PrelMain); + startupHaskell(argc,argv,__stginit_Main); /* kick off the computation by creating the main thread with a pointer to mainIO_closure representing the computation of the overall program; diff --git a/ghc/rts/Prelude.h b/ghc/rts/Prelude.h index e83aaa8..4479953 100644 --- a/ghc/rts/Prelude.h +++ b/ghc/rts/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Prelude.h,v 1.17 2002/01/22 13:54:22 simonmar Exp $ + * $Id: Prelude.h,v 1.18 2002/02/05 15:42:04 simonpj Exp $ * * (c) The GHC Team, 1998-2001 * @@ -18,7 +18,7 @@ extern DLL_IMPORT const StgClosure PrelBase_True_closure; extern DLL_IMPORT const StgClosure PrelBase_False_closure; extern DLL_IMPORT const StgClosure PrelPack_unpackCString_closure; extern DLL_IMPORT const StgClosure PrelWeak_runFinalizzerBatch_closure; -extern const StgClosure PrelMain_mainIO_closure; +extern const StgClosure Main_zdmain_closure; extern DLL_IMPORT const StgClosure PrelIOBase_stackOverflow_closure; extern DLL_IMPORT const StgClosure PrelIOBase_heapOverflow_closure; @@ -63,7 +63,7 @@ extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info; #define False_closure (&PrelBase_False_closure) #define unpackCString_closure (&PrelPack_unpackCString_closure) #define runFinalizerBatch_closure (&PrelWeak_runFinalizzerBatch_closure) -#define mainIO_closure (&PrelMain_mainIO_closure) +#define mainIO_closure (&Main_zdmain_closure) #define stackOverflow_closure (&PrelIOBase_stackOverflow_closure) #define heapOverflow_closure (&PrelIOBase_heapOverflow_closure) -- 1.7.10.4