Commit f8031f57 authored by simonpj's avatar simonpj

[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.
parent 38c8801e
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 } } ;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment