From f8031f577f9667ef1ab439b11fdd15fc39a79630 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 9 Jul 2003 11:06:32 +0000 Subject: [PATCH] [project @ 2003-07-09 11:06:31 by simonpj] -------------------------- Fix two External-Core bugs -------------------------- 1. An inadvertent "let x = ...x..." bug in TcRnDriver 2. Adjust the new -main-is story, so that the root module is called ":Main" instead of "$Main". This means that the z-encoded module name is "ZCMain" rather than "zdMain", which in keeps the External-Core lexer happy. And is more consistent generally. 3. Make the renamer happy to see definitions from modules other than the "home" one, when doing External Core. In the main module, there'll be a definition for ZCMain.main. --- ghc/compiler/codeGen/CodeGen.lhs | 6 +++--- ghc/compiler/prelude/PrelNames.lhs | 16 ++++++++++------ ghc/compiler/rename/RnEnv.lhs | 22 ++++++++++++++++++---- ghc/compiler/typecheck/TcRnDriver.lhs | 20 ++++++++++---------- 4 files changed, 41 insertions(+), 23 deletions(-) diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 8606ff9..5b01138 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -28,7 +28,7 @@ import DriverState ( v_Build_tag, v_MainModIs ) import StgSyn import CgMonad import AbsCSyn -import PrelNames ( gHC_PRIM, dOLLAR_MAIN, mAIN_Name ) +import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN_Name ) import CLabel ( mkSRTLabel, mkClosureLabel, mkPlainModuleInitLabel, mkModuleInitLabel ) import PprAbsC ( dumpRealC ) @@ -148,7 +148,7 @@ mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mo register_mod_imports = map mk_import_register imported_mods -- When compiling the module in which the 'main' function lives, - -- we inject an extra stg_init procedure for stg_init_zdMain, for the + -- we inject an extra stg_init procedure for stg_init_ZCMain, for the -- RTS to invoke. We must consult the -main-is flag in case the -- user specified a different function to Main.main main_mod_name = case mb_main_mod of @@ -158,7 +158,7 @@ mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mo | Module.moduleName this_mod /= main_mod_name = AbsCNop -- The normal case | otherwise -- this_mod contains the main function - = CCodeBlock (mkPlainModuleInitLabel dOLLAR_MAIN) + = CCodeBlock (mkPlainModuleInitLabel rOOT_MAIN) (CJump (CLbl (mkPlainModuleInitLabel this_mod) CodePtrRep)) in diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 2ecfaa5..a77a4db 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -299,9 +299,13 @@ pRELUDE = mkBasePkgModule pRELUDE_Name -- MetaHaskell Extension text2 from Meta/work/gen.hs mETA_META_Name = mkModuleName "Language.Haskell.THSyntax" -dOLLAR_MAIN_Name = mkModuleName "$Main" -- Root module for initialisation -dOLLAR_MAIN = mkHomeModule dOLLAR_MAIN_Name -iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive") +rOOT_MAIN_Name = mkModuleName ":Main" -- Root module for initialisation +rOOT_MAIN = mkHomeModule rOOT_MAIN_Name + -- The ':xxx' makes a moudle name that the user can never + -- use himself. The z-encoding for ':' is "ZC", so the z-encoded + -- module name still starts with a capital letter, which keeps + -- the z-encoded version consistent. +iNTERACTIVE = mkHomeModule (mkModuleName ":Interactive") \end{code} %************************************************************************ @@ -474,8 +478,8 @@ and it's convenient to write them all down in one place. \begin{code} -dollarMainName = varQual dOLLAR_MAIN_Name FSLIT("main") dollarMainKey -runIOName = varQual pREL_TOP_HANDLER_Name FSLIT("runIO") runMainKey +rootMainName = varQual rOOT_MAIN_Name FSLIT("main") rootMainKey +runIOName = varQual pREL_TOP_HANDLER_Name FSLIT("runIO") runMainKey -- Stuff from GHC.Prim superKindName = kindQual FSLIT("KX") kindConKey @@ -978,7 +982,7 @@ otherwiseIdKey = mkPreludeMiscIdUnique 51 assertIdKey = mkPreludeMiscIdUnique 53 runSTRepIdKey = mkPreludeMiscIdUnique 54 -dollarMainKey = mkPreludeMiscIdUnique 55 +rootMainKey = mkPreludeMiscIdUnique 55 runMainKey = mkPreludeMiscIdUnique 56 andIdKey = mkPreludeMiscIdUnique 57 diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index e08a8c0..255356c 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -40,7 +40,8 @@ import PrelNames ( mkUnboundName, intTyConName, boolTyConName, funTyConName, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, printName, integerTyConName, - bindIOName, returnIOName, failIOName, thenIOName + bindIOName, returnIOName, failIOName, thenIOName, + rOOT_MAIN_Name ) #ifdef GHCI import DsMeta ( templateHaskellNames, qTyConName ) @@ -70,11 +71,24 @@ newTopBinder mod rdr_name loc | Just name <- isExact_maybe rdr_name = returnM name - | otherwise - = ASSERT( not (isOrig rdr_name) || rdrNameModule rdr_name == moduleName mod ) + | isOrig rdr_name + = ASSERT( rdr_mod == moduleName mod || rdr_mod == rOOT_MAIN_Name ) -- When reading External Core we get Orig names as binders, -- but they should agree with the module gotten from the monad - newGlobalName mod (rdrNameOcc rdr_name) loc + -- + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module + -- + -- Because of this latter case, we take the module from the RdrName, + -- not from the environment. In principle, it'd be fine to have an + -- arbitrary mixture of external core definitions in a single module, + -- (apart from module-initialisation issues, perhaps). + newGlobalName (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) loc + + | otherwise + = newGlobalName mod (rdrNameOcc rdr_name) loc + where + rdr_mod = rdrNameModule rdr_name newGlobalName :: Module -> OccName -> SrcLoc -> TcRn m Name newGlobalName mod occ loc diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index c127b2c..463ff1d 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -33,7 +33,7 @@ import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr, import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, returnIOName, runIOName, - dollarMainName, itName, mAIN_Name, unsafeCoerceName + rootMainName, itName, mAIN_Name, unsafeCoerceName ) import RdrName ( RdrName, getRdrName, mkRdrUnqual, lookupRdrEnv, elemRdrEnv ) @@ -64,7 +64,7 @@ import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds ) import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 ) -import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) +import TcSimplify ( tcSimplifyTop, tcSimplifyInteractive, tcSimplifyInfer ) import TcTyClsDecls ( tcTyAndClassDecls ) import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, @@ -425,7 +425,7 @@ tc_stmts stmts -- and then let it = e -- It's the simplify step that rejects the first. traceTc (text "tcs 3") ; - const_binds <- tcSimplifyTop lie ; + const_binds <- tcSimplifyInteractive lie ; -- Build result expression and zonk it let { expr = mkHsLet const_binds tc_expr } ; @@ -461,7 +461,7 @@ tcRnExpr hsc_env pcs ictxt rdr_expr -- it might have a rank-2 type (e.g. :t runST) ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; - tcSimplifyTop lie_top ; + tcSimplifyInteractive lie_top ; let { all_expr_ty = mkForAllTys qtvs $ mkFunTys (map idType dict_ids) $ @@ -556,13 +556,13 @@ tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) -- rnSrcDecls handles fixity decls etc too, which won't occur -- but that doesn't matter let { local_group = mkGroup decls } ; - (_, rn_decls, dus) <- initRn (InterfaceMode this_mod) - (rnSrcDecls local_group) ; + (_, rn_src_decls, dus) <- initRn (InterfaceMode this_mod) + (rnSrcDecls local_group) ; failIfErrsM ; -- Get the supporting decls rn_imp_decls <- slurpImpDecls (duUses dus) ; - let { rn_decls = rn_decls `addImpDecls` rn_imp_decls } ; + let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; @@ -1159,12 +1159,12 @@ check_main ghci_mode tcg_env main_mod main_fn addErrCtxt mainCtxt $ setGblEnv tcg_env $ do { - -- $main :: IO () = runIO main + -- :Main.main :: IO () = runIO main let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ; (main_expr, ty) <- tcInferRho rhs ; - let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ; - main_bind = VarMonoBind dollar_main_id main_expr ; + let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ; + main_bind = VarMonoBind root_main_id main_expr ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` main_bind } } ; -- 1.7.10.4