Commit d28ba8c8 authored by simonpj's avatar simonpj
Browse files

[project @ 2003-06-23 10:35:15 by simonpj]

-------------------
	Dealing with 'main'
	-------------------

1.  In GHC 6.0, a module with no "module Main ... where" header
    elicited an error "main is not in scope" if 'main' is not defined.  We
    don't want this behaviour in GHCi.  This happened because the parser
    expanded the (absent) header to "module Main( main ) where", and the
    'main' in the export list isn't.

Solution: elaborate HsModule to record whether the 'module ..." header was
given explicitly by the user or not.


2.  Add a -main-is flag, and document it, so that you can have a 'main' function
that is not Main.main.  Summary of changes

* The -main-is flag nominates what the main function is to be (see the documentation).
	No -main-is flag 	says that the main function is Main.main
	-main-is Foo.baz	says that the main function is Foo.baz
	-main-is Foo		says that the main function is Foo.main
	-main-is baz		says that the main function is Main.baz

  Let's say  you say -main-is Foo.baz

* TcRnDriver injects the extra definition
	$Mian.main :: IO t
	$Main.main = baz
  in the module Foo.   Note the naming, which is a bit different than before;
  previously the extra defn was for Main.$main.  The RTS invokes zdMain_main_closure.

* CodeGen injects an extra initialisation block into module Foo, thus
	stginit_zdMain {
		stginit_Foo
	}
  That ensures that the RTS can initialise stginit_zdMain.
parent dd6fe036
...@@ -567,7 +567,6 @@ pprCLbl (CCS_Label ccs) = ppr ccs ...@@ -567,7 +567,6 @@ pprCLbl (CCS_Label ccs) = ppr ccs
pprCLbl (ModuleInitLabel mod way) pprCLbl (ModuleInitLabel mod way)
= ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
<> char '_' <> text way <> char '_' <> text way
pprCLbl (PlainModuleInitLabel mod) pprCLbl (PlainModuleInitLabel mod)
= ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
......
...@@ -24,11 +24,11 @@ module CodeGen ( codeGen ) where ...@@ -24,11 +24,11 @@ module CodeGen ( codeGen ) where
-- bother to compile it. -- bother to compile it.
import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT
import DriverState ( v_Build_tag ) import DriverState ( v_Build_tag, v_MainModIs )
import StgSyn import StgSyn
import CgMonad import CgMonad
import AbsCSyn import AbsCSyn
import PrelNames ( gHC_PRIM ) import PrelNames ( gHC_PRIM, dOLLAR_MAIN, mAIN_Name )
import CLabel ( mkSRTLabel, mkClosureLabel, import CLabel ( mkSRTLabel, mkClosureLabel,
mkPlainModuleInitLabel, mkModuleInitLabel ) mkPlainModuleInitLabel, mkModuleInitLabel )
import PprAbsC ( dumpRealC ) import PprAbsC ( dumpRealC )
...@@ -47,11 +47,12 @@ import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalNa ...@@ -47,11 +47,12 @@ import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalNa
import OccName ( mkLocalOcc ) import OccName ( mkLocalOcc )
import PrimRep ( PrimRep(..) ) import PrimRep ( PrimRep(..) )
import TyCon ( isDataTyCon ) import TyCon ( isDataTyCon )
import Module ( Module ) import Module ( Module, mkModuleName )
import BasicTypes ( TopLevelFlag(..) ) import BasicTypes ( TopLevelFlag(..) )
import UniqSupply ( mkSplitUniqSupply ) import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn, showPass ) import ErrUtils ( dumpIfSet_dyn, showPass )
import Panic ( assertPanic ) import Panic ( assertPanic )
import qualified Module ( moduleName )
#ifdef DEBUG #ifdef DEBUG
import Outputable import Outputable
...@@ -76,6 +77,7 @@ codeGen dflags this_mod type_env foreign_stubs imported_mods ...@@ -76,6 +77,7 @@ codeGen dflags this_mod type_env foreign_stubs imported_mods
showPass dflags "CodeGen" showPass dflags "CodeGen"
fl_uniqs <- mkSplitUniqSupply 'f' fl_uniqs <- mkSplitUniqSupply 'f'
way <- readIORef v_Build_tag way <- readIORef v_Build_tag
mb_main_mod <- readIORef v_MainModIs
let let
tycons = typeEnvTyCons type_env tycons = typeEnvTyCons type_env
...@@ -89,7 +91,8 @@ codeGen dflags this_mod type_env foreign_stubs imported_mods ...@@ -89,7 +91,8 @@ codeGen dflags this_mod type_env foreign_stubs imported_mods
datatype_stuff = genStaticConBits cinfo data_tycons datatype_stuff = genStaticConBits cinfo data_tycons
code_stuff = initC cinfo (mapCs cgTopBinding stg_binds) code_stuff = initC cinfo (mapCs cgTopBinding stg_binds)
init_stuff = mkModuleInit way cost_centre_info this_mod init_stuff = mkModuleInit way cost_centre_info
this_mod mb_main_mod
foreign_stubs imported_mods foreign_stubs imported_mods
abstractC = mkAbstractCs [ maybeSplitCode, abstractC = mkAbstractCs [ maybeSplitCode,
...@@ -117,10 +120,11 @@ mkModuleInit ...@@ -117,10 +120,11 @@ mkModuleInit
:: String -- the "way" :: String -- the "way"
-> CollectedCCs -- cost centre info -> CollectedCCs -- cost centre info
-> Module -> Module
-> Maybe String -- Just m ==> we have flag: -main-is Foo.baz
-> ForeignStubs -> ForeignStubs
-> [Module] -> [Module]
-> AbstractC -> AbstractC
mkModuleInit way cost_centre_info this_mod foreign_stubs imported_mods mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods
= let = let
(cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
...@@ -142,6 +146,21 @@ mkModuleInit way cost_centre_info this_mod foreign_stubs imported_mods ...@@ -142,6 +146,21 @@ mkModuleInit way cost_centre_info this_mod foreign_stubs imported_mods
] ]
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,
-- we inject an extra stg_init procedure for stg_init_zdMain, 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
Just mod_name -> mkModuleName mod_name
Nothing -> mAIN_Name
main_init_block
| Module.moduleName this_mod /= main_mod_name
= AbsCNop -- The normal case
| otherwise -- this_mod contains the main function
= CModuleInitBlock (mkPlainModuleInitLabel dOLLAR_MAIN)
(mkModuleInitLabel dOLLAR_MAIN way)
(mk_import_register this_mod)
in in
mkAbstractCs [ mkAbstractCs [
cc_decls, cc_decls,
...@@ -149,7 +168,8 @@ mkModuleInit way cost_centre_info this_mod foreign_stubs imported_mods ...@@ -149,7 +168,8 @@ mkModuleInit way cost_centre_info this_mod foreign_stubs imported_mods
(mkModuleInitLabel this_mod way) (mkModuleInitLabel this_mod way)
(mkAbstractCs (register_foreign_exports ++ (mkAbstractCs (register_foreign_exports ++
cc_regs : cc_regs :
register_mod_imports)) register_mod_imports)),
main_init_block
] ]
\end{code} \end{code}
......
...@@ -21,7 +21,7 @@ module HsSyn ( ...@@ -21,7 +21,7 @@ module HsSyn (
module HsTypes, module HsTypes,
Fixity, NewOrData, Fixity, NewOrData,
HsModule(..), hsModule, hsImports, HsModule(..),
collectStmtsBinders, collectStmtsBinders,
collectHsBinders, collectLocatedHsBinders, collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders, collectMonoBinders, collectLocatedMonoBinders,
...@@ -51,10 +51,10 @@ All we actually declare here is the top-level structure for a module. ...@@ -51,10 +51,10 @@ All we actually declare here is the top-level structure for a module.
\begin{code} \begin{code}
data HsModule name data HsModule name
= HsModule = HsModule
Module (Maybe Module) -- Nothing => "module X where" is omitted
(Maybe Version) -- source interface version number -- (in which case the next field is Nothing too)
(Maybe [IE name]) -- export list; Nothing => export everything (Maybe [IE name]) -- Export list; Nothing => export list omitted, so export everything
-- Just [] => export *nothing* (???) -- Just [] => export *nothing*
-- Just [...] => as you would expect... -- Just [...] => as you would expect...
[ImportDecl name] -- We snaffle interesting stuff out of the [ImportDecl name] -- We snaffle interesting stuff out of the
-- imported interfaces early on, adding that -- imported interfaces early on, adding that
...@@ -69,8 +69,10 @@ data HsModule name ...@@ -69,8 +69,10 @@ data HsModule name
instance (NamedThing name, OutputableBndr name) instance (NamedThing name, OutputableBndr name)
=> Outputable (HsModule name) where => Outputable (HsModule name) where
ppr (HsModule name iface_version exports imports ppr (HsModule Nothing _ imports decls _ src_loc)
decls deprec src_loc) = pp_nonnull imports $$ pp_nonnull decls
ppr (HsModule (Just name) exports imports decls deprec src_loc)
= vcat [ = vcat [
case exports of case exports of
Nothing -> pp_header (ptext SLIT("where")) Nothing -> pp_header (ptext SLIT("where"))
...@@ -89,11 +91,8 @@ instance (NamedThing name, OutputableBndr name) ...@@ -89,11 +91,8 @@ instance (NamedThing name, OutputableBndr name)
pp_modname = ptext SLIT("module") <+> ppr name pp_modname = ptext SLIT("module") <+> ppr name
pp_nonnull [] = empty pp_nonnull [] = empty
pp_nonnull xs = vcat (map ppr xs) pp_nonnull xs = vcat (map ppr xs)
hsModule (HsModule mod _ _ _ _ _ _) = mod
hsImports (HsModule mod vers exports imports decls deprec src_loc) = imports
\end{code} \end{code}
......
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- $Id: DriverFlags.hs,v 1.115 2003/05/27 12:40:19 simonmar Exp $ -- $Id: DriverFlags.hs,v 1.116 2003/06/23 10:35:17 simonpj Exp $
-- --
-- Driver flags -- Driver flags
-- --
...@@ -225,6 +225,7 @@ static_flags = ...@@ -225,6 +225,7 @@ static_flags =
------- Miscellaneous ----------------------------------------------- ------- Miscellaneous -----------------------------------------------
, ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat
, ( "no-hs-main" , NoArg (writeIORef v_NoHsMain True) ) , ( "no-hs-main" , NoArg (writeIORef v_NoHsMain True) )
, ( "main-is" , SepArg setMainIs )
------- Output Redirection ------------------------------------------ ------- Output Redirection ------------------------------------------
, ( "odir" , HasArg (writeIORef v_Output_dir . Just) ) , ( "odir" , HasArg (writeIORef v_Output_dir . Just) )
...@@ -520,6 +521,21 @@ buildStaticHscOpts = do ...@@ -520,6 +521,21 @@ buildStaticHscOpts = do
return ( static : filtered_opts ) return ( static : filtered_opts )
setMainIs :: String -> IO ()
setMainIs arg
| not (null main_mod) -- The arg looked like "Foo.baz"
= do { writeIORef v_MainFunIs (Just main_fn) ;
writeIORef v_MainModIs (Just main_mod) }
| isUpper (head main_fn) -- The arg looked like "Foo"
= writeIORef v_MainModIs (Just main_fn)
| otherwise -- The arg looked like "baz"
= writeIORef v_MainFunIs (Just main_fn)
where
(main_mod, main_fn) = split_longest_prefix arg (== '.')
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Via-C compilation stuff -- Via-C compilation stuff
......
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- $Id: DriverState.hs,v 1.91 2003/06/12 16:50:19 simonpj Exp $ -- $Id: DriverState.hs,v 1.92 2003/06/23 10:35:17 simonpj Exp $
-- --
-- Settings for the driver -- Settings for the driver
-- --
...@@ -95,6 +95,8 @@ GLOBAL_VAR(v_Scale_sizes_by, 1.0, Double) ...@@ -95,6 +95,8 @@ GLOBAL_VAR(v_Scale_sizes_by, 1.0, Double)
GLOBAL_VAR(v_Static, True, Bool) GLOBAL_VAR(v_Static, True, Bool)
GLOBAL_VAR(v_NoLink, False, Bool) GLOBAL_VAR(v_NoLink, False, Bool)
GLOBAL_VAR(v_NoHsMain, False, Bool) GLOBAL_VAR(v_NoHsMain, False, Bool)
GLOBAL_VAR(v_MainModIs, Nothing, Maybe String)
GLOBAL_VAR(v_MainFunIs, Nothing, Maybe String)
GLOBAL_VAR(v_Recomp, True, Bool) GLOBAL_VAR(v_Recomp, True, Bool)
GLOBAL_VAR(v_Collect_ghc_timing, False, Bool) GLOBAL_VAR(v_Collect_ghc_timing, False, Bool)
GLOBAL_VAR(v_Do_asm_mangling, True, Bool) GLOBAL_VAR(v_Do_asm_mangling, True, Bool)
......
...@@ -22,7 +22,7 @@ import Util ( count ) ...@@ -22,7 +22,7 @@ import Util ( count )
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
ppSourceStats short (HsModule name version exports imports decls _ src_loc) ppSourceStats short (HsModule _ exports imports decls _ src_loc)
= (if short then hcat else vcat) = (if short then hcat else vcat)
(map pp_val (map pp_val
[("ExportAll ", export_all), -- 1 if no export list [("ExportAll ", export_all), -- 1 if no export list
......
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- $Id: Main.hs,v 1.126 2003/06/17 23:26:30 sof Exp $ -- $Id: Main.hs,v 1.127 2003/06/23 10:35:17 simonpj Exp $
-- --
-- GHC Driver program -- GHC Driver program
-- --
...@@ -160,7 +160,7 @@ main = ...@@ -160,7 +160,7 @@ main =
extra_non_static <- processArgs static_flags extra_non_static <- processArgs static_flags
(unreg_opts ++ way_opts ++ pkg_extra_opts) [] (unreg_opts ++ way_opts ++ pkg_extra_opts) []
-- give the static flags to hsc -- Give the static flags to hsc
static_opts <- buildStaticHscOpts static_opts <- buildStaticHscOpts
writeIORef v_Static_hsc_opts static_opts writeIORef v_Static_hsc_opts static_opts
......
{- -*-haskell-*- {- -*-haskell-*-
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
$Id: Parser.y,v 1.118 2003/05/19 15:10:40 simonpj Exp $ $Id: Parser.y,v 1.119 2003/06/23 10:35:22 simonpj Exp $
Haskell grammar. Haskell grammar.
...@@ -265,19 +265,9 @@ REIFY_FIXITY { ITreifyFixity } ...@@ -265,19 +265,9 @@ REIFY_FIXITY { ITreifyFixity }
module :: { RdrNameHsModule } module :: { RdrNameHsModule }
: srcloc 'module' modid maybemoddeprec maybeexports 'where' body : srcloc 'module' modid maybemoddeprec maybeexports 'where' body
{ HsModule (mkHomeModule $3) Nothing $5 (fst $7) (snd $7) $4 $1 } { HsModule (Just (mkHomeModule $3)) $5 (fst $7) (snd $7) $4 $1 }
| srcloc body | srcloc body
{ -- Behave as if we'd said { HsModule Nothing Nothing (fst $2) (snd $2) Nothing $1 }
-- module Main( main ) where ...
let
main_RDR_Unqual = mkUnqual varName FSLIT("main")
-- We definitely don't want an Orig RdrName, because
-- main might, in principle, be imported into module Main
in
HsModule (mkHomeModule mAIN_Name)
Nothing
(Just [IEVar main_RDR_Unqual])
(fst $2) (snd $2) Nothing $1 }
maybemoddeprec :: { Maybe DeprecTxt } maybemoddeprec :: { Maybe DeprecTxt }
: '{-# DEPRECATED' STRING '#-}' { Just $2 } : '{-# DEPRECATED' STRING '#-}' { Just $2 }
......
...@@ -68,7 +68,7 @@ import Outputable ...@@ -68,7 +68,7 @@ import Outputable
module :: { RdrNameHsModule } module :: { RdrNameHsModule }
: '%module' modid tdefs vdefgs : '%module' modid tdefs vdefgs
{ HsModule (mkHomeModule $2) Nothing Nothing { HsModule (Just (mkHomeModule $2)) Nothing
[] ($3 ++ concat $4) Nothing noSrcLoc} [] ($3 ++ concat $4) Nothing noSrcLoc}
tdefs :: { [RdrNameHsDecl] } tdefs :: { [RdrNameHsDecl] }
......
...@@ -287,12 +287,12 @@ pREL_REAL = mkBasePkgModule pREL_REAL_Name ...@@ -287,12 +287,12 @@ pREL_REAL = mkBasePkgModule pREL_REAL_Name
pREL_FLOAT = mkBasePkgModule pREL_FLOAT_Name pREL_FLOAT = mkBasePkgModule pREL_FLOAT_Name
pRELUDE = mkBasePkgModule pRELUDE_Name pRELUDE = mkBasePkgModule pRELUDE_Name
iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive")
-- 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
dOLLAR_MAIN = mkHomeModule dOLLAR_MAIN_Name
iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive")
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -462,7 +462,7 @@ and it's convenient to write them all down in one place. ...@@ -462,7 +462,7 @@ and it's convenient to write them all down in one place.
\begin{code} \begin{code}
dollarMainName = varQual mAIN_Name FSLIT("$main") dollarMainKey dollarMainName = varQual dOLLAR_MAIN_Name FSLIT("main") dollarMainKey
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
......
...@@ -19,7 +19,7 @@ import HsSyn ( IE(..), ieName, ImportDecl(..), ...@@ -19,7 +19,7 @@ import HsSyn ( IE(..), ieName, ImportDecl(..),
ForeignDecl(..), HsGroup(..), ForeignDecl(..), HsGroup(..),
collectLocatedHsBinders, tyClDeclNames collectLocatedHsBinders, tyClDeclNames
) )
import RdrHsSyn ( RdrNameIE, RdrNameImportDecl ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, main_RDR_Unqual )
import RnEnv import RnEnv
import TcRnMonad import TcRnMonad
...@@ -34,7 +34,7 @@ import NameSet ...@@ -34,7 +34,7 @@ import NameSet
import NameEnv import NameEnv
import OccName ( OccName, srcDataName, isTcOcc ) import OccName ( OccName, srcDataName, isTcOcc )
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
GenAvailInfo(..), AvailInfo, Avails, GenAvailInfo(..), AvailInfo, Avails, GhciMode(..),
IsBootInterface, IsBootInterface,
availName, availNames, availsToNameSet, availName, availNames, availsToNameSet,
Deprecations(..), ModIface(..), Dependencies(..), Deprecations(..), ModIface(..), Dependencies(..),
...@@ -528,14 +528,30 @@ type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) ...@@ -528,14 +528,30 @@ type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
-- that have the same occurrence name -- that have the same occurrence name
exportsFromAvail :: Maybe [RdrNameIE] -> TcRn m Avails exportsFromAvail :: Maybe Module -- Nothing => no 'module M(..) where' header at all
-> Maybe [RdrNameIE] -- Nothing => no explicit export list
-> TcRn m Avails
-- Complains if two distinct exports have same OccName -- Complains if two distinct exports have same OccName
-- Warns about identical exports. -- Warns about identical exports.
-- Complains about exports items not in scope -- Complains about exports items not in scope
exportsFromAvail exports exportsFromAvail maybe_mod exports
= do { TcGblEnv { tcg_rdr_env = rdr_env, = do { TcGblEnv { tcg_rdr_env = rdr_env,
tcg_imports = imports } <- getGblEnv ; tcg_imports = imports } <- getGblEnv ;
-- If the module header is omitted altogether, then behave
-- as if the user had written "module Main(main) where..."
-- EXCEPT in interactive mode, when we behave as if he had
-- written "module Main where ..."
-- Reason: don't want to complain about 'main' not in scope
-- in interactive mode
ghci_mode <- getGhciMode ;
let { real_exports
= case maybe_mod of
Just mod -> exports
Nothing | ghci_mode == Interactive -> Nothing
| otherwise -> Just [IEVar main_RDR_Unqual] } ;
exports_from_avail exports rdr_env imports } exports_from_avail exports rdr_env imports }
exports_from_avail Nothing rdr_env exports_from_avail Nothing rdr_env
......
...@@ -21,6 +21,8 @@ import DsMeta ( templateHaskellNames ) ...@@ -21,6 +21,8 @@ import DsMeta ( templateHaskellNames )
#endif #endif
import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
import DriverState ( v_MainModIs, v_MainFunIs )
import DriverUtil ( split_longest_prefix )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
HsGroup(..), SpliceDecl(..), HsGroup(..), SpliceDecl(..),
...@@ -86,7 +88,8 @@ import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors ) ...@@ -86,7 +88,8 @@ import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors )
import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported ) import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
import IdInfo ( GlobalIdDetails(..) ) import IdInfo ( GlobalIdDetails(..) )
import Var ( Var, setGlobalIdDetails ) import Var ( Var, setGlobalIdDetails )
import Module ( Module, moduleName, moduleUserString, moduleEnvElts ) import Module ( Module, ModuleName, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts )
import OccName ( mkVarOcc )
import Name ( Name, isExternalName, getSrcLoc, nameOccName ) import Name ( Name, isExternalName, getSrcLoc, nameOccName )
import NameEnv ( delListFromNameEnv ) import NameEnv ( delListFromNameEnv )
import NameSet import NameSet
...@@ -115,6 +118,8 @@ import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance( ...@@ -115,6 +118,8 @@ import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(
isLocalGRE ) isLocalGRE )
#endif #endif
import DATA_IOREF ( readIORef )
import FastString ( mkFastString )
import Panic ( showException ) import Panic ( showException )
import List ( partition ) import List ( partition )
import Util ( sortLt ) import Util ( sortLt )
...@@ -135,9 +140,13 @@ tcRnModule :: HscEnv -> PersistentCompilerState ...@@ -135,9 +140,13 @@ tcRnModule :: HscEnv -> PersistentCompilerState
-> IO (PersistentCompilerState, Maybe TcGblEnv) -> IO (PersistentCompilerState, Maybe TcGblEnv)
tcRnModule hsc_env pcs tcRnModule hsc_env pcs
(HsModule this_mod _ exports import_decls local_decls mod_deprec loc) (HsModule maybe_mod exports import_decls local_decls mod_deprec loc)
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
let { this_mod = case maybe_mod of
Nothing -> mkHomeModule mAIN_Name -- 'module M where' is omitted
Just mod -> mod } ; -- The normal case
initTc hsc_env pcs this_mod $ addSrcLoc loc $ initTc hsc_env pcs this_mod $ addSrcLoc loc $
do { -- Deal with imports; sets tcg_rdr_env, tcg_imports do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ; (rdr_env, imports) <- rnImports import_decls ;
...@@ -165,7 +174,7 @@ tcRnModule hsc_env pcs ...@@ -165,7 +174,7 @@ tcRnModule hsc_env pcs
$ do { $ do {
-- Process the export list -- Process the export list
export_avails <- exportsFromAvail exports ; export_avails <- exportsFromAvail maybe_mod exports ;
updGblEnv (\gbl -> gbl { tcg_exports = export_avails }) updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
$ do { $ do {
...@@ -528,8 +537,8 @@ tcRnExtCore :: HscEnv -> PersistentCompilerState ...@@ -528,8 +537,8 @@ tcRnExtCore :: HscEnv -> PersistentCompilerState
-> IO (PersistentCompilerState, Maybe ModGuts) -> IO (PersistentCompilerState, Maybe ModGuts)
-- Nothing => some error occurred -- Nothing => some error occurred
tcRnExtCore hsc_env pcs tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc)
(HsModule this_mod _ _ _ local_decls _ loc) -- For external core, the module name is syntactically reqd
-- Rename the (Core) module. It's a bit like an interface -- Rename the (Core) module. It's a bit like an interface
-- file: all names are original names -- file: all names are original names
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
...@@ -539,14 +548,14 @@ tcRnExtCore hsc_env pcs ...@@ -539,14 +548,14 @@ tcRnExtCore hsc_env pcs
-- Rename the source, only in interface mode. -- Rename the source, only in interface mode.
-- 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 local_decls } ; let { local_group = mkGroup decls } ;
(_, rn_local_decls, dus) <- initRn (InterfaceMode this_mod) (_, rn_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_local_decls `addImpDecls` rn_imp_decls } ; let { rn_decls = rn_decls `addImpDecls` rn_imp_decls } ;
-- Dump trace of renaming part -- Dump trace of renaming part
rnDump (ppr rn_decls) ; rnDump (ppr rn_decls) ;
...@@ -558,7 +567,7 @@ tcRnExtCore hsc_env pcs ...@@ -558,7 +567,7 @@ tcRnExtCore hsc_env pcs
setGblEnv tcg_env $ do { setGblEnv tcg_env $ do {
-- Now the core bindings -- Now the core bindings
core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ; core_prs <- tcCoreBinds (hs_coreds rn_decls) ;
tcExtendGlobalValEnv (map fst core_prs) $ do { tcExtendGlobalValEnv (map fst core_prs) $ do {
-- Wrap up -- Wrap up
...@@ -1093,10 +1102,21 @@ noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") ...@@ -1093,10 +1102,21 @@ noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
checkMain checkMain
= do { ghci_mode <- getGhciMode ; = do { ghci_mode <- getGhciMode ;
tcg_env <- getGblEnv ; tcg_env <- getGblEnv ;
check_main ghci_mode tcg_env
mb_main_mod <- readMutVar v_MainModIs ;
mb_main_fn <- readMutVar v_MainFunIs ;
let { main_mod = case mb_main_mod of {
Just mod -> mkModuleName mod ;
Nothing -> mAIN_Name } ;
main_fn = case mb_main_fn of {
Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
Nothing -> main_RDR_Unqual } } ;
check_main ghci_mode tcg_env main_mod main_fn
} }