%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.47 2002/04/29 14:03:39 simonmar Exp $
+% $Id: AbsCSyn.lhs,v 1.48 2002/07/16 14:56:09 simonmar Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
TyCon -- which TyCon this table is for
| CModuleInitBlock -- module initialisation block
- CLabel -- label for init block
+ CLabel -- "plain" label for init block
+ CLabel -- label for init block (with ver + way info)
AbstractC -- initialisation code
| CCostCentreDecl -- A cost centre *declaration*
flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CModuleInitBlock _ _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt)
\end{code}
\begin{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CLabel.lhs,v 1.52 2002/04/29 14:03:39 simonmar Exp $
+% $Id: CLabel.lhs,v 1.53 2002/07/16 14:56:09 simonmar Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
mkAsmTempLabel,
mkModuleInitLabel,
+ mkPlainModuleInitLabel,
mkErrorStdEntryLabel,
import Unique ( pprUnique, Unique )
import PrimOp ( PrimOp )
import CostCentre ( CostCentre, CostCentreStack )
+import BasicTypes ( Version )
import Outputable
import FastString
\end{code}
| AsmTempLabel Unique
- | ModuleInitLabel Module
+ | ModuleInitLabel
+ Module -- the module name
+ Version -- its version (same as the interface file ver)
+ String -- its "way"
+
+ | PlainModuleInitLabel Module -- without the vesrion & way info
| RtsLabel RtsLabelInfo
mkAsmTempLabel = AsmTempLabel
mkModuleInitLabel = ModuleInitLabel
+mkPlainModuleInitLabel = PlainModuleInitLabel
-- Some fixed runtime system labels
needsCDecl (CaseLabel _ CaseReturnPt) = True
needsCDecl (DataConLabel _ _) = True
needsCDecl (TyConLabel _) = True
-needsCDecl (ModuleInitLabel _) = True
+needsCDecl (ModuleInitLabel _ _ _) = True
+needsCDecl (PlainModuleInitLabel _) = True
needsCDecl (CaseLabel _ _) = False
needsCDecl (AsmTempLabel _) = False
externallyVisibleCLabel (TyConLabel tc) = True
externallyVisibleCLabel (CaseLabel _ _) = False
externallyVisibleCLabel (AsmTempLabel _) = False
-externallyVisibleCLabel (ModuleInitLabel _)= True
+externallyVisibleCLabel (ModuleInitLabel _ _ _)= True
+externallyVisibleCLabel (PlainModuleInitLabel _)= True
externallyVisibleCLabel (RtsLabel RtsModuleRegd) = False --hack
externallyVisibleCLabel (RtsLabel _) = True
externallyVisibleCLabel (ForeignLabel _ _) = True
labelType (CaseLabel _ CaseReturnPt) = CodeType
labelType (CaseLabel _ CaseVecTbl) = VecTblType
labelType (TyConLabel _) = ClosureTblType
-labelType (ModuleInitLabel _ ) = CodeType
+labelType (ModuleInitLabel _ _ _) = CodeType
+labelType (PlainModuleInitLabel _) = CodeType
labelType (IdLabel _ info) =
case info of
DataConLabel n k -> isDllName n
TyConLabel tc -> isDllName (getName tc)
ForeignLabel _ d -> d
- ModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
+ ModuleInitLabel m _ _ -> (not opt_Static) && (not (isHomeModule m))
+ PlainModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
_ -> False
\end{code}
pprCLbl (CC_Label cc) = ppr cc
pprCLbl (CCS_Label ccs) = ppr ccs
-pprCLbl (ModuleInitLabel mod)
+pprCLbl (ModuleInitLabel mod ver way)
+ = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
+ <> char '_' <> int ver <> char '_' <> text way
+
+pprCLbl (PlainModuleInitLabel mod)
= ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
ppIdFlavor :: IdLabelInfo -> SDoc
(ptext SLIT("RET_VEC_BIG"))
-pprAbsC stmt@(CModuleInitBlock lbl code) _
+pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
= vcat [
- ptext SLIT("START_MOD_INIT") <> parens (pprCLabel lbl),
+ ptext SLIT("START_MOD_INIT") <>
+ parens (pprCLabel plain_lbl <> comma <> pprCLabel lbl),
case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
pprAbsC code (costs code),
hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code
ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes
-ppr_decls_AbsC (CModuleInitBlock _ code) = ppr_decls_AbsC code
+ppr_decls_AbsC (CModuleInitBlock _ _ code) = ppr_decls_AbsC code
ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)
\end{code}
-- bother to compile it.
import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT
+import DriverState ( v_Build_tag )
import StgSyn
import CgMonad
import AbsCSyn
-import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel )
+import PrelNames ( gHC_PRIM )
+import CLabel ( CLabel, mkSRTLabel, mkClosureLabel,
+ mkPlainModuleInitLabel, mkModuleInitLabel )
import PprAbsC ( dumpRealC )
import AbsCUtils ( mkAbstractCs, flattenAbsC )
import Module ( Module )
import PrimRep ( PrimRep(..) )
import TyCon ( TyCon, isDataTyCon )
-import BasicTypes ( TopLevelFlag(..) )
+import BasicTypes ( TopLevelFlag(..), Version )
import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Panic ( assertPanic )
#ifdef DEBUG
import Outputable
#endif
+
+import IOExts ( readIORef )
\end{code}
\begin{code}
codeGen :: DynFlags
-> Module -- Module name
- -> [Module] -- Import names
+ -> Version -- Module version
+ -> [(Module,Version)] -- Import names & versions
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [Id] -- foreign-exported binders
-> [TyCon] -- Local tycons, including ones from classes
-> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
-> IO AbstractC -- Output
-codeGen dflags mod_name imported_modules cost_centre_info fe_binders
+codeGen dflags mod_name mod_ver imported_modules cost_centre_info fe_binders
tycons stg_binds
- = do { showPass dflags "CodeGen"
- ; fl_uniqs <- mkSplitUniqSupply 'f'
- ; dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
- ; let flat_abstractC = flattenAbsC fl_uniqs abstractC
- ; return flat_abstractC
- }
- where
- data_tycons = filter isDataTyCon tycons
- cinfo = MkCompInfo mod_name
-
- datatype_stuff = genStaticConBits cinfo data_tycons
- code_stuff = initC cinfo (mapCs cgTopBinding stg_binds)
- init_stuff = mkModuleInit fe_binders mod_name imported_modules
- cost_centre_info
-
- abstractC = mkAbstractCs [ maybeSplitCode,
- init_stuff,
- code_stuff,
- datatype_stuff]
- -- Put datatype_stuff after code_stuff, because the
- -- datatype closure table (for enumeration types)
- -- to (say) PrelBase_True_closure, which is defined in code_stuff
-
+ = do
+ showPass dflags "CodeGen"
+ fl_uniqs <- mkSplitUniqSupply 'f'
+ way <- readIORef v_Build_tag
+
+ let
+ data_tycons = filter isDataTyCon tycons
+ cinfo = MkCompInfo mod_name
+
+ datatype_stuff = genStaticConBits cinfo data_tycons
+ code_stuff = initC cinfo (mapCs cgTopBinding stg_binds)
+ init_stuff = mkModuleInit fe_binders mod_name mod_ver way
+ imported_modules cost_centre_info
+
+ abstractC = mkAbstractCs [ maybeSplitCode,
+ init_stuff,
+ code_stuff,
+ datatype_stuff]
+ -- Put datatype_stuff after code_stuff, because the
+ -- datatype closure table (for enumeration types) to
+ -- (say) PrelBase_True_closure, which is defined in
+ -- code_stuff
+
+ dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
+
+ return $! flattenAbsC fl_uniqs abstractC
\end{code}
%************************************************************************
mkModuleInit
:: [Id] -- foreign exported functions
-> Module -- module name
- -> [Module] -- import names
+ -> Version -- module version
+ -> String -- the "way"
+ -> [(Module,Version)] -- import names & versions
-> CollectedCCs -- cost centre info
-> AbstractC
-mkModuleInit fe_binders mod imps cost_centre_info
+mkModuleInit fe_binders mod ver way imps cost_centre_info
= let
register_fes =
map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels
(cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
- mk_import_register imp =
- CMacroStmt REGISTER_IMPORT [
- CLbl (mkModuleInitLabel imp) AddrRep
- ]
+ -- we don't want/need to init GHC.Prim, so filter it out
+ mk_import_register (imp,ver)
+ | imp == gHC_PRIM = AbsCNop
+ | otherwise = CMacroStmt REGISTER_IMPORT [
+ CLbl (mkModuleInitLabel imp ver way) AddrRep
+ ]
register_imports = map mk_import_register imps
in
mkAbstractCs [
cc_decls,
- CModuleInitBlock (mkModuleInitLabel mod)
+ CModuleInitBlock (mkPlainModuleInitLabel mod)
+ (mkModuleInitLabel mod ver way)
(mkAbstractCs (register_fes ++
cc_regs :
register_imports))
#else
import HscMain ( initPersistentCompilerState )
#endif
-import HscTypes hiding ( moduleNameToModule )
+import HscTypes
import Name ( Name, NamedThing(..), nameRdrName, nameModule,
isHomePackageName, isExternalName )
import NameEnv
import Parser
import Lex ( ParseResult(..), ExtFlags(..), mkPState )
import SrcLoc ( mkSrcLoc )
-import Finder ( findModule )
import Rename ( checkOldIface, renameModule, renameExtCore,
closeIfaceDecls, RnResult(..) )
import Rules ( emptyRuleBase )
import Name ( Name, nameModule, nameOccName, getName )
import NameEnv ( emptyNameEnv, mkNameEnv )
import Module ( Module )
+import BasicTypes ( Version )
import FastString
import Maybes ( expectJust )
import Util ( seqList )
import MkExternalCore ( emitExternalCore )
import ParserCore
import ParserCoreUtils
-
\end{code}
pcs_tc, ds_details, foreign_stuff) -> do {
let {
+ imported_module_names :: [ModuleName];
imported_module_names =
filter (/= gHC_PRIM_Name) $
map ideclName (hsModuleImports rdr_module);
+ imported_modules :: [(Module,Version)];
imported_modules =
- map (moduleNameToModule hit (pcs_PIT pcs_tc))
+ map (getModuleAndVersion hit (pcs_PIT pcs_tc))
imported_module_names;
}
-- force this out now, so we don't keep a hold of rdr_module or pcs_tc
; seqList imported_modules (return ())
+ -- this module's version
+ ; version <- return $! vers_module (mi_version new_iface)
+
-------------------
-- FLATTENING
-------------------
-- flat_details
-- imported_modules (seq'd)
-- new_iface
+ -- version
-------------------
-- SIMPLIFY
else do
------------------ Code generation ------------------
abstractC <- _scc_ "CodeGen"
- codeGen dflags this_mod imported_modules
+ codeGen dflags this_mod version
+ imported_modules
cost_centre_info fe_binders
local_tycons stg_binds
HomeSymbolTable, emptySymbolTable,
PackageTypeEnv,
HomeIfaceTable, PackageIfaceTable, emptyIfaceTable,
- lookupIface, lookupIfaceByModName, moduleNameToModule,
+ lookupIface, lookupIfaceByModName, getModuleAndVersion,
emptyModIface,
InteractiveContext(..),
-- Use instead of Finder.findModule if possible: this way doesn't
-- require filesystem operations, and it is guaranteed not to fail
-- when the IfaceTables are properly populated (i.e. after the renamer).
-moduleNameToModule :: HomeIfaceTable -> PackageIfaceTable -> ModuleName
- -> Module
-moduleNameToModule hit pit mod
- = mi_module (fromJust (lookupIfaceByModName hit pit mod))
+getModuleAndVersion :: HomeIfaceTable -> PackageIfaceTable -> ModuleName
+ -> (Module,Version)
+getModuleAndVersion hit pit mod
+ = ((,) $! mi_module iface) $! vers_module (mi_version iface)
+ where iface = fromJust (lookupIfaceByModName hit pit mod)
\end{code}
(tyConDataCons tycon) )
]
- gentopcode stmt@(CModuleInitBlock lbl absC)
+ gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC)
= gencode absC `thenUs` \ code ->
getUniqLabelNCG `thenUs` \ tmp_lbl ->
getUniqLabelNCG `thenUs` \ flag_lbl ->
: StLabel flag_lbl
: StData IntRep [StInt 0]
: StSegment TextSegment
+ : StLabel plain_lbl
+ : StJump NoDestInfo (StCLbl lbl)
: StLabel lbl
: StCondJump tmp_lbl (StMachOp MO_Nat_Ne
[StInd IntRep (StCLbl flag_lbl),
/* -----------------------------------------------------------------------------
- * $Id: StgMacros.h,v 1.46 2002/02/15 22:14:27 sof Exp $
+ * $Id: StgMacros.h,v 1.47 2002/07/16 14:56:08 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* -----------------------------------------------------------------------------
Module initialisation
+
+ The module initialisation code looks like this, roughly:
+
+ FN(__stginit_Foo) {
+ JMP_(__stginit_Foo_1_p)
+ }
+
+ FN(__stginit_Foo_1_p) {
+ ...
+ }
+
+ We have one version of the init code with a module version and the
+ 'way' attached to it. The version number helps to catch cases
+ where modules are not compiled in dependency order before being
+ linked: if a module has been compiled since any modules which depend on
+ it, then the latter modules will refer to a different version in their
+ init blocks and a link error will ensue.
+
+ The 'way' suffix helps to catch cases where modules compiled in different
+ ways are linked together (eg. profiled and non-profiled).
+
+ We provide a plain, unadorned, version of the module init code
+ which just jumps to the version with the label and way attached. The
+ reason for this is that when using foreign exports, the caller of
+ startupHaskell() must supply the name of the init function for the "top"
+ module in the program, and we don't want to require that this name
+ has the version and way info appended to it.
-------------------------------------------------------------------------- */
#define PUSH_INIT_STACK(reg_function) \
#define POP_INIT_STACK() \
*(--Sp)
-#define START_MOD_INIT(reg_mod_name) \
+#define MOD_INIT_WRAPPER(label,real_init) \
+
+
+#define START_MOD_INIT(plain_lbl, real_lbl) \
static int _module_registered = 0; \
- FN_(reg_mod_name) { \
+ EF_(real_lbl); \
+ FN_(plain_lbl) { \
+ FB_ \
+ JMP_(real_lbl); \
+ FE_ \
+ } \
+ FN_(real_lbl) { \
FB_; \
if (! _module_registered) { \
_module_registered = 1; \
/* -----------------------------------------------------------------------------
- * $Id: StgStartup.hc,v 1.18 2002/02/12 15:17:23 simonmar Exp $
+ * $Id: StgStartup.hc,v 1.19 2002/07/16 14:56:09 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
JMP_(POP_INIT_STACK());
FE_
}
-
-/* GHC.Prim doesn't really exist... */
-
-START_MOD_INIT(__stginit_GHCziPrim);
-END_MOD_INIT();
projects / ghc-hetmet.git / commitdiff