pprCLbl (ModuleInitLabel mod way)
= ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
<> char '_' <> text way
-
pprCLbl (PlainModuleInitLabel mod)
= ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
-- bother to compile it.
import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT
-import DriverState ( v_Build_tag )
+import DriverState ( v_Build_tag, v_MainModIs )
import StgSyn
import CgMonad
import AbsCSyn
-import PrelNames ( gHC_PRIM )
+import PrelNames ( gHC_PRIM, dOLLAR_MAIN, mAIN_Name )
import CLabel ( mkSRTLabel, mkClosureLabel,
mkPlainModuleInitLabel, mkModuleInitLabel )
import PprAbsC ( dumpRealC )
import OccName ( mkLocalOcc )
import PrimRep ( PrimRep(..) )
import TyCon ( isDataTyCon )
-import Module ( Module )
+import Module ( Module, mkModuleName )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Panic ( assertPanic )
+import qualified Module ( moduleName )
#ifdef DEBUG
import Outputable
showPass dflags "CodeGen"
fl_uniqs <- mkSplitUniqSupply 'f'
way <- readIORef v_Build_tag
+ mb_main_mod <- readIORef v_MainModIs
let
tycons = typeEnvTyCons type_env
datatype_stuff = genStaticConBits cinfo data_tycons
code_stuff = initC cinfo (mapCs cgTopBinding stg_binds)
- init_stuff = mkModuleInit way cost_centre_info this_mod
- foreign_stubs imported_mods
+ init_stuff = mkModuleInit way cost_centre_info
+ this_mod mb_main_mod
+ foreign_stubs imported_mods
abstractC = mkAbstractCs [ maybeSplitCode,
init_stuff,
:: String -- the "way"
-> CollectedCCs -- cost centre info
-> Module
+ -> Maybe String -- Just m ==> we have flag: -main-is Foo.baz
-> ForeignStubs
-> [Module]
-> 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
(cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
]
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
mkAbstractCs [
cc_decls,
(mkModuleInitLabel this_mod way)
(mkAbstractCs (register_foreign_exports ++
cc_regs :
- register_mod_imports))
+ register_mod_imports)),
+ main_init_block
]
\end{code}
module HsTypes,
Fixity, NewOrData,
- HsModule(..), hsModule, hsImports,
+ HsModule(..),
collectStmtsBinders,
collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders,
\begin{code}
data HsModule name
= HsModule
- Module
- (Maybe Version) -- source interface version number
- (Maybe [IE name]) -- export list; Nothing => export everything
- -- Just [] => export *nothing* (???)
+ (Maybe Module) -- Nothing => "module X where" is omitted
+ -- (in which case the next field is Nothing too)
+ (Maybe [IE name]) -- Export list; Nothing => export list omitted, so export everything
+ -- Just [] => export *nothing*
-- Just [...] => as you would expect...
[ImportDecl name] -- We snaffle interesting stuff out of the
-- imported interfaces early on, adding that
instance (NamedThing name, OutputableBndr name)
=> Outputable (HsModule name) where
- ppr (HsModule name iface_version exports imports
- decls deprec src_loc)
+ ppr (HsModule Nothing _ imports decls _ src_loc)
+ = pp_nonnull imports $$ pp_nonnull decls
+
+ ppr (HsModule (Just name) exports imports decls deprec src_loc)
= vcat [
case exports of
Nothing -> pp_header (ptext SLIT("where"))
pp_modname = ptext SLIT("module") <+> ppr name
- pp_nonnull [] = empty
- pp_nonnull xs = vcat (map ppr xs)
-
-hsModule (HsModule mod _ _ _ _ _ _) = mod
-hsImports (HsModule mod vers exports imports decls deprec src_loc) = imports
+pp_nonnull [] = empty
+pp_nonnull xs = vcat (map ppr xs)
\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
--
------- Miscellaneous -----------------------------------------------
, ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat
, ( "no-hs-main" , NoArg (writeIORef v_NoHsMain True) )
+ , ( "main-is" , SepArg setMainIs )
------- Output Redirection ------------------------------------------
, ( "odir" , HasArg (writeIORef v_Output_dir . Just) )
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
-----------------------------------------------------------------------------
--- $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
--
GLOBAL_VAR(v_Static, True, Bool)
GLOBAL_VAR(v_NoLink, 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_Collect_ghc_timing, False, Bool)
GLOBAL_VAR(v_Do_asm_mangling, True, Bool)
%************************************************************************
\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)
(map pp_val
[("ExportAll ", export_all), -- 1 if no export list
{-# 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
--
extra_non_static <- processArgs static_flags
(unreg_opts ++ way_opts ++ pkg_extra_opts) []
- -- give the static flags to hsc
+ -- Give the static flags to hsc
static_opts <- buildStaticHscOpts
writeIORef v_Static_hsc_opts static_opts
{- -*-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.
module :: { RdrNameHsModule }
: 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
- { -- Behave as if we'd said
- -- 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 }
+ { HsModule Nothing Nothing (fst $2) (snd $2) Nothing $1 }
maybemoddeprec :: { Maybe DeprecTxt }
: '{-# DEPRECATED' STRING '#-}' { Just $2 }
module :: { RdrNameHsModule }
: '%module' modid tdefs vdefgs
- { HsModule (mkHomeModule $2) Nothing Nothing
+ { HsModule (Just (mkHomeModule $2)) Nothing
[] ($3 ++ concat $4) Nothing noSrcLoc}
tdefs :: { [RdrNameHsDecl] }
pREL_FLOAT = mkBasePkgModule pREL_FLOAT_Name
pRELUDE = mkBasePkgModule pRELUDE_Name
-
-iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive")
-
-- 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")
\end{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
-- Stuff from GHC.Prim
ForeignDecl(..), HsGroup(..),
collectLocatedHsBinders, tyClDeclNames
)
-import RdrHsSyn ( RdrNameIE, RdrNameImportDecl )
+import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, main_RDR_Unqual )
import RnEnv
import TcRnMonad
import NameEnv
import OccName ( OccName, srcDataName, isTcOcc )
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
- GenAvailInfo(..), AvailInfo, Avails,
+ GenAvailInfo(..), AvailInfo, Avails, GhciMode(..),
IsBootInterface,
availName, availNames, availsToNameSet,
Deprecations(..), ModIface(..), Dependencies(..),
-- 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
-- Warns about identical exports.
-- Complains about exports items not in scope
-exportsFromAvail exports
+exportsFromAvail maybe_mod exports
= do { TcGblEnv { tcg_rdr_env = rdr_env,
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 Nothing rdr_env
#endif
import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
+import DriverState ( v_MainModIs, v_MainFunIs )
+import DriverUtil ( split_longest_prefix )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
HsGroup(..), SpliceDecl(..),
import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
import IdInfo ( GlobalIdDetails(..) )
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 NameEnv ( delListFromNameEnv )
import NameSet
isLocalGRE )
#endif
+import DATA_IOREF ( readIORef )
+import FastString ( mkFastString )
import Panic ( showException )
import List ( partition )
import Util ( sortLt )
-> IO (PersistentCompilerState, Maybe TcGblEnv)
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" ;
+ 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 $
do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
$ do {
-- Process the export list
- export_avails <- exportsFromAvail exports ;
+ export_avails <- exportsFromAvail maybe_mod exports ;
updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
$ do {
-> IO (PersistentCompilerState, Maybe ModGuts)
-- Nothing => some error occurred
-tcRnExtCore hsc_env pcs
- (HsModule this_mod _ _ _ local_decls _ loc)
+tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc)
+ -- For external core, the module name is syntactically reqd
-- Rename the (Core) module. It's a bit like an interface
-- file: all names are original names
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
-- Rename the source, only in interface mode.
-- rnSrcDecls handles fixity decls etc too, which won't occur
-- but that doesn't matter
- let { local_group = mkGroup local_decls } ;
- (_, rn_local_decls, dus) <- initRn (InterfaceMode this_mod)
+ let { local_group = mkGroup decls } ;
+ (_, rn_decls, dus) <- initRn (InterfaceMode this_mod)
(rnSrcDecls local_group) ;
failIfErrsM ;
-- Get the supporting decls
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
rnDump (ppr rn_decls) ;
setGblEnv tcg_env $ do {
-- 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 {
-- Wrap up
final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
mod_guts = ModGuts { mg_module = this_mod,
- mg_usages = [], -- ToDo: compute usage
- mg_dir_imps = [], -- ??
+ mg_usages = [], -- ToDo: compute usage
+ mg_dir_imps = [], -- ??
mg_deps = noDependencies, -- ??
mg_exports = my_exports,
mg_types = final_type_env,
checkMain
= do { ghci_mode <- getGhciMode ;
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
}
-check_main ghci_mode tcg_env
+
+check_main ghci_mode tcg_env main_mod main_fn
-- If we are in module Main, check that 'main' is defined.
-- It may be imported from another module, in which case
-- we have to drag in its.
--
-- Blimey: a whole page of code to do this...
- | mod_name /= mAIN_Name
+ | mod_name /= main_mod
= return (tcg_env, emptyFVs)
-- Check that 'main' is in scope
--
-- We use a guard for this (rather than letting lookupSrcName fail)
-- because it's not an error in ghci)
- | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
+ | not (main_fn `elemRdrEnv` rdr_env)
= do { complain_no_main; return (tcg_env, emptyFVs) }
- | otherwise
- = do { main_name <- lookupSrcName main_RDR_Unqual ;
+ | otherwise -- OK, so the appropriate 'main' is in scope
+ --
+ = do { main_name <- lookupSrcName main_fn ;
tcg_env <- importSupportingDecls (unitFV runIOName) ;
-- In other modes, fail altogether, so that we don't go on
-- and complain a second time when processing the export list.
- mainCtxt = ptext SLIT("When checking the type of 'main'")
- noMainMsg = ptext SLIT("No 'main' defined in module Main")
+ mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
+ noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
+ <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
\end{code}
ptext SLIT("#-}")]
ppr_gen_tycons [] = empty
-ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
- vcat (map ppr_gen_tycon tcs),
- ptext SLIT("#-}")
+ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"),
+ nest 2 (vcat (map ppr_gen_tycon tcs))
]
-- x&y are now Id's, not CoreExpr's
invoke <literal>foo()</literal> from C, just <literal>#include
"Foo_stub.h"</literal> and call <literal>foo()</literal>.</para>
- <sect3>
+ <sect3 id="using-own-main">
<title>Using your own <literal>main()</literal></title>
<para>Normally, GHC's runtime system provides a
</varlistentry>
<varlistentry>
+ <term><option>-main-is <replaceable>thing</replaceable></option></term>
+ <indexterm><primary><option>-main-is</option></primary></indexterm>
+ <indexterm><primary>specifying your own main function</primary></indexterm>
+ <listitem>
+ <para> The normal rule in Haskell is that your program must supply a <literal>main</literal>
+ function in module <literal>Main</literal>. When testing, it is often convenient
+ to change which function is the "main" one, and the <option>-main-is</option> flag
+ allows you to do so. The <replaceable>thing</replaceable> can be one of:
+ <itemizedlist>
+ <listitem><para>A lower-case identifier <literal>foo</literal>. GHC assumes that the main function is <literal>Main.foo</literal>.</para></listitem>
+ <listitem><para>An module name <literal>A</literal>. GHC assumes that the main function is <literal>A.main</literal>.</para></listitem>
+ <listitem><para>An qualified name <literal>A.foo</literal>. GHC assumes that the main function is <literal>A.foo</literal>.</para></listitem>
+ </itemizedlist>
+ Strictly speaking, <option>-main-is</option> is not a link-phase flag at all; it has no effect on the link step.
+ The flag must be specified when compiling the module containing the specified main function (e.g. module <literal>A</literal>
+ in the latter two items above. It has no effect for other modules (and hence can safely be given to <literal>ghc --make</literal>).
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
<term><option>-no-hs-main</option></term>
<indexterm><primary><option>-no-hs-main</option></primary></indexterm>
<indexterm><primary>linking Haskell libraries with foreign code</primary></indexterm>
be supplying its definition of <function>main()</function>
at link-time, you will have to. To signal that to the
compiler when linking, use
- <option>-no-hs-main</option>.</para>
+ <option>-no-hs-main</option>. See also <xref linkend="using-own-main">.</para>
<para>Notice that since the command-line passed to the
linker is rather involved, you probably want to use
/* -----------------------------------------------------------------------------
- * $Id: Main.c,v 1.37 2003/03/25 18:00:19 sof Exp $
+ * $Id: Main.c,v 1.38 2003/06/23 10:35:23 simonpj Exp $
*
* (c) The GHC Team 1998-2000
*
# include <windows.h>
#endif
-extern void __stginit_Main(void);
+extern void __stginit_zdMain(void);
/* Hack: we assume that we're building a batch-mode system unless
* INTERPRETER is set
SchedulerStatus status;
/* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */
- startupHaskell(argc,argv,__stginit_Main);
+ startupHaskell(argc,argv,__stginit_zdMain);
/* kick off the computation by creating the main thread with a pointer
to mainIO_closure representing the computation of the overall program;
/* -----------------------------------------------------------------------------
- * $Id: Prelude.h,v 1.22 2003/02/06 09:56:10 simonmar Exp $
+ * $Id: Prelude.h,v 1.23 2003/06/23 10:35:23 simonpj Exp $
*
* (c) The GHC Team, 1998-2001
*
extern DLL_IMPORT StgClosure GHCziBase_False_closure;
extern DLL_IMPORT StgClosure GHCziPack_unpackCString_closure;
extern DLL_IMPORT StgClosure GHCziWeak_runFinalizzerBatch_closure;
-extern StgClosure Main_zdmain_closure;
+extern StgClosure zdMain_main_closure;
extern DLL_IMPORT StgClosure GHCziTopHandler_runIO_closure;
extern DLL_IMPORT StgClosure GHCziTopHandler_runNonIO_closure;
#define False_closure (&GHCziBase_False_closure)
#define unpackCString_closure (&GHCziPack_unpackCString_closure)
#define runFinalizerBatch_closure (&GHCziWeak_runFinalizzerBatch_closure)
-#define mainIO_closure (&Main_zdmain_closure)
+#define mainIO_closure (&zdMain_main_closure)
#define runIO_closure (&GHCziTopHandler_runIO_closure)
#define runNonIO_closure (&GHCziTopHandler_runNonIO_closure)
projects / ghc-hetmet.git / commitdiff