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 ) ...@@ -28,7 +28,7 @@ import DriverState ( v_Build_tag, v_MainModIs )
import StgSyn import StgSyn
import CgMonad import CgMonad
import AbsCSyn import AbsCSyn
import PrelNames ( gHC_PRIM, dOLLAR_MAIN, mAIN_Name ) import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN_Name )
import CLabel ( mkSRTLabel, mkClosureLabel, import CLabel ( mkSRTLabel, mkClosureLabel,
mkPlainModuleInitLabel, mkModuleInitLabel ) mkPlainModuleInitLabel, mkModuleInitLabel )
import PprAbsC ( dumpRealC ) import PprAbsC ( dumpRealC )
...@@ -148,7 +148,7 @@ mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mo ...@@ -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 register_mod_imports = map mk_import_register imported_mods
-- When compiling the module in which the 'main' function lives, -- 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 -- RTS to invoke. We must consult the -main-is flag in case the
-- user specified a different function to Main.main -- user specified a different function to Main.main
main_mod_name = case mb_main_mod of 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 ...@@ -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 | Module.moduleName this_mod /= main_mod_name
= AbsCNop -- The normal case = AbsCNop -- The normal case
| otherwise -- this_mod contains the main function | otherwise -- this_mod contains the main function
= CCodeBlock (mkPlainModuleInitLabel dOLLAR_MAIN) = CCodeBlock (mkPlainModuleInitLabel rOOT_MAIN)
(CJump (CLbl (mkPlainModuleInitLabel this_mod) CodePtrRep)) (CJump (CLbl (mkPlainModuleInitLabel this_mod) CodePtrRep))
in in
......
...@@ -299,9 +299,13 @@ pRELUDE = mkBasePkgModule pRELUDE_Name ...@@ -299,9 +299,13 @@ pRELUDE = mkBasePkgModule pRELUDE_Name
-- MetaHaskell Extension text2 from Meta/work/gen.hs -- MetaHaskell Extension text2 from Meta/work/gen.hs
mETA_META_Name = mkModuleName "Language.Haskell.THSyntax" mETA_META_Name = mkModuleName "Language.Haskell.THSyntax"
dOLLAR_MAIN_Name = mkModuleName "$Main" -- Root module for initialisation rOOT_MAIN_Name = mkModuleName ":Main" -- Root module for initialisation
dOLLAR_MAIN = mkHomeModule dOLLAR_MAIN_Name rOOT_MAIN = mkHomeModule rOOT_MAIN_Name
iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive") -- 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} \end{code}
%************************************************************************ %************************************************************************
...@@ -474,7 +478,7 @@ and it's convenient to write them all down in one place. ...@@ -474,7 +478,7 @@ and it's convenient to write them all down in one place.
\begin{code} \begin{code}
dollarMainName = varQual dOLLAR_MAIN_Name FSLIT("main") dollarMainKey rootMainName = varQual rOOT_MAIN_Name FSLIT("main") rootMainKey
runIOName = varQual pREL_TOP_HANDLER_Name FSLIT("runIO") runMainKey runIOName = varQual pREL_TOP_HANDLER_Name FSLIT("runIO") runMainKey
-- Stuff from GHC.Prim -- Stuff from GHC.Prim
...@@ -978,7 +982,7 @@ otherwiseIdKey = mkPreludeMiscIdUnique 51 ...@@ -978,7 +982,7 @@ otherwiseIdKey = mkPreludeMiscIdUnique 51
assertIdKey = mkPreludeMiscIdUnique 53 assertIdKey = mkPreludeMiscIdUnique 53
runSTRepIdKey = mkPreludeMiscIdUnique 54 runSTRepIdKey = mkPreludeMiscIdUnique 54
dollarMainKey = mkPreludeMiscIdUnique 55 rootMainKey = mkPreludeMiscIdUnique 55
runMainKey = mkPreludeMiscIdUnique 56 runMainKey = mkPreludeMiscIdUnique 56
andIdKey = mkPreludeMiscIdUnique 57 andIdKey = mkPreludeMiscIdUnique 57
......
...@@ -40,7 +40,8 @@ import PrelNames ( mkUnboundName, intTyConName, ...@@ -40,7 +40,8 @@ import PrelNames ( mkUnboundName, intTyConName,
boolTyConName, funTyConName, boolTyConName, funTyConName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName, printName, integerTyConName, eqStringName, printName, integerTyConName,
bindIOName, returnIOName, failIOName, thenIOName bindIOName, returnIOName, failIOName, thenIOName,
rOOT_MAIN_Name
) )
#ifdef GHCI #ifdef GHCI
import DsMeta ( templateHaskellNames, qTyConName ) import DsMeta ( templateHaskellNames, qTyConName )
...@@ -70,11 +71,24 @@ newTopBinder mod rdr_name loc ...@@ -70,11 +71,24 @@ newTopBinder mod rdr_name loc
| Just name <- isExact_maybe rdr_name | Just name <- isExact_maybe rdr_name
= returnM name = returnM name
| otherwise | isOrig rdr_name
= ASSERT( not (isOrig rdr_name) || rdrNameModule rdr_name == moduleName mod ) = ASSERT( rdr_mod == moduleName mod || rdr_mod == rOOT_MAIN_Name )
-- When reading External Core we get Orig names as binders, -- When reading External Core we get Orig names as binders,
-- but they should agree with the module gotten from the monad -- 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 :: Module -> OccName -> SrcLoc -> TcRn m Name
newGlobalName mod occ loc newGlobalName mod occ loc
......
...@@ -33,7 +33,7 @@ import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr, ...@@ -33,7 +33,7 @@ import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames,
returnIOName, runIOName, returnIOName, runIOName,
dollarMainName, itName, mAIN_Name, unsafeCoerceName rootMainName, itName, mAIN_Name, unsafeCoerceName
) )
import RdrName ( RdrName, getRdrName, mkRdrUnqual, import RdrName ( RdrName, getRdrName, mkRdrUnqual,
lookupRdrEnv, elemRdrEnv ) lookupRdrEnv, elemRdrEnv )
...@@ -64,7 +64,7 @@ import TcRules ( tcRules ) ...@@ -64,7 +64,7 @@ import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports ) import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds ) import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 ) import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) import TcSimplify ( tcSimplifyTop, tcSimplifyInteractive, tcSimplifyInfer )
import TcTyClsDecls ( tcTyAndClassDecls ) import TcTyClsDecls ( tcTyAndClassDecls )
import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
...@@ -425,7 +425,7 @@ tc_stmts stmts ...@@ -425,7 +425,7 @@ tc_stmts stmts
-- and then let it = e -- and then let it = e
-- It's the simplify step that rejects the first. -- It's the simplify step that rejects the first.
traceTc (text "tcs 3") ; traceTc (text "tcs 3") ;
const_binds <- tcSimplifyTop lie ; const_binds <- tcSimplifyInteractive lie ;
-- Build result expression and zonk it -- Build result expression and zonk it
let { expr = mkHsLet const_binds tc_expr } ; let { expr = mkHsLet const_binds tc_expr } ;
...@@ -461,7 +461,7 @@ tcRnExpr hsc_env pcs ictxt rdr_expr ...@@ -461,7 +461,7 @@ tcRnExpr hsc_env pcs ictxt rdr_expr
-- it might have a rank-2 type (e.g. :t runST) -- it might have a rank-2 type (e.g. :t runST)
((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; ((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 $ let { all_expr_ty = mkForAllTys qtvs $
mkFunTys (map idType dict_ids) $ mkFunTys (map idType dict_ids) $
...@@ -556,13 +556,13 @@ tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) ...@@ -556,13 +556,13 @@ tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc)
-- rnSrcDecls handles fixity decls etc too, which won't occur -- rnSrcDecls handles fixity decls etc too, which won't occur
-- but that doesn't matter -- but that doesn't matter
let { local_group = mkGroup decls } ; let { local_group = mkGroup decls } ;
(_, rn_decls, dus) <- initRn (InterfaceMode this_mod) (_, rn_src_decls, dus) <- initRn (InterfaceMode this_mod)
(rnSrcDecls local_group) ; (rnSrcDecls local_group) ;
failIfErrsM ; failIfErrsM ;
-- Get the supporting decls -- Get the supporting decls
rn_imp_decls <- slurpImpDecls (duUses dus) ; 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 -- Dump trace of renaming part
rnDump (ppr rn_decls) ; rnDump (ppr rn_decls) ;
...@@ -1159,12 +1159,12 @@ check_main ghci_mode tcg_env main_mod main_fn ...@@ -1159,12 +1159,12 @@ check_main ghci_mode tcg_env main_mod main_fn
addErrCtxt mainCtxt $ addErrCtxt mainCtxt $
setGblEnv tcg_env $ do { setGblEnv tcg_env $ do {
-- $main :: IO () = runIO main -- :Main.main :: IO () = runIO main
let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ; let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
(main_expr, ty) <- tcInferRho rhs ; (main_expr, ty) <- tcInferRho rhs ;
let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ; let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ;
main_bind = VarMonoBind dollar_main_id main_expr ; main_bind = VarMonoBind root_main_id main_expr ;
tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env
`andMonoBinds` main_bind } } ; `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