Commit 9a972425 authored by simonmar's avatar simonmar
Browse files

[project @ 2002-07-16 14:56:08 by simonmar]

Implement a primitive failsafe mechanism for protecting against
linking inconsistent object files.  The idea is that if object files
which were compiled in the wrong order (non-dependency order) or
compiled in different ways (eg. profiled vs. non-profiled) are linked
together, a link error will result.

This is achieved by adding the module version and the way to the
module init label.  For example, previously the init label for a
module Foo was named

	__stginit_Foo

now it is named

	__stginit_Foo_<version>_<way>

where <version> is the module version of Foo (same as the version in
the interface file), and <way> is the current way (or empty).

We also have to have a way to refer to the old plain init label, for
using as the argument to shutdownHaskell() in a program using foreign
exports.  So the old label now points to a jump instruction which
transfers control to the new init code.
parent 8c086331
%
% (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}
......@@ -221,7 +221,8 @@ stored in a mixed type location.)
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*
......
......@@ -426,7 +426,7 @@ flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
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}
......@@ -34,6 +34,7 @@ module CLabel (
mkAsmTempLabel,
mkModuleInitLabel,
mkPlainModuleInitLabel,
mkErrorStdEntryLabel,
......@@ -89,6 +90,7 @@ import TyCon ( TyCon )
import Unique ( pprUnique, Unique )
import PrimOp ( PrimOp )
import CostCentre ( CostCentre, CostCentreStack )
import BasicTypes ( Version )
import Outputable
import FastString
\end{code}
......@@ -123,7 +125,12 @@ data CLabel
| 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
......@@ -237,6 +244,7 @@ mkClosureTblLabel tycon = TyConLabel tycon
mkAsmTempLabel = AsmTempLabel
mkModuleInitLabel = ModuleInitLabel
mkPlainModuleInitLabel = PlainModuleInitLabel
-- Some fixed runtime system labels
......@@ -305,7 +313,8 @@ needsCDecl (IdLabel _ _) = True
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
......@@ -332,7 +341,8 @@ externallyVisibleCLabel (DataConLabel _ _) = True
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
......@@ -354,7 +364,8 @@ labelType (CaseLabel _ CaseReturnInfo) = InfoTblType
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
......@@ -388,7 +399,8 @@ labelDynamic lbl =
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}
......@@ -521,7 +533,11 @@ pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
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
......
......@@ -592,9 +592,10 @@ pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
(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]
......@@ -1708,7 +1709,7 @@ ppr_decls_AbsC (CSRT _ closure_lbls)
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}
......
......@@ -24,10 +24,13 @@ module CodeGen ( codeGen ) where
-- 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 )
......@@ -45,7 +48,7 @@ import OccName ( mkLocalOcc )
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 )
......@@ -53,43 +56,49 @@ 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}
%************************************************************************
......@@ -102,10 +111,12 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders
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
......@@ -115,16 +126,19 @@ mkModuleInit fe_binders mod imps cost_centre_info
(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))
......
......@@ -73,7 +73,7 @@ import HscMain ( initPersistentCompilerState, hscThing,
#else
import HscMain ( initPersistentCompilerState )
#endif
import HscTypes hiding ( moduleNameToModule )
import HscTypes
import Name ( Name, NamedThing(..), nameRdrName, nameModule,
isHomePackageName, isExternalName )
import NameEnv
......
......@@ -46,7 +46,6 @@ import StringBuffer ( hGetStringBuffer, freeStringBuffer )
import Parser
import Lex ( ParseResult(..), ExtFlags(..), mkPState )
import SrcLoc ( mkSrcLoc )
import Finder ( findModule )
import Rename ( checkOldIface, renameModule, renameExtCore,
closeIfaceDecls, RnResult(..) )
import Rules ( emptyRuleBase )
......@@ -84,6 +83,7 @@ import OccName ( OccName )
import Name ( Name, nameModule, nameOccName, getName )
import NameEnv ( emptyNameEnv, mkNameEnv )
import Module ( Module )
import BasicTypes ( Version )
import FastString
import Maybes ( expectJust )
import Util ( seqList )
......@@ -98,7 +98,6 @@ import IO
import MkExternalCore ( emitExternalCore )
import ParserCore
import ParserCoreUtils
\end{code}
......@@ -227,18 +226,23 @@ hscRecomp ghci_mode dflags have_object
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
-------------------
......@@ -275,6 +279,7 @@ hscRecomp ghci_mode dflags have_object
-- flat_details
-- imported_modules (seq'd)
-- new_iface
-- version
-------------------
-- SIMPLIFY
......@@ -392,7 +397,8 @@ hscRecomp ghci_mode dflags have_object
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
......
......@@ -13,7 +13,7 @@ module HscTypes (
HomeSymbolTable, emptySymbolTable,
PackageTypeEnv,
HomeIfaceTable, PackageIfaceTable, emptyIfaceTable,
lookupIface, lookupIfaceByModName, moduleNameToModule,
lookupIface, lookupIfaceByModName, getModuleAndVersion,
emptyModIface,
InteractiveContext(..),
......@@ -302,10 +302,11 @@ lookupIfaceByModName hit pit mod
-- 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}
......
......@@ -181,7 +181,7 @@ Here we handle top-level things, like @CCodeBlock@s and
(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 ->
......@@ -189,6 +189,8 @@ Here we handle top-level things, like @CCodeBlock@s and
: 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
*
......@@ -774,6 +774,33 @@ LoadThreadState (void)
/* -----------------------------------------------------------------------------
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) \
......@@ -782,9 +809,18 @@ LoadThreadState (void)
#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
*
......@@ -155,8 +155,3 @@ STGFUN(stg_init)
JMP_(POP_INIT_STACK());
FE_
}
/* GHC.Prim doesn't really exist... */
START_MOD_INIT(__stginit_GHCziPrim);
END_MOD_INIT();
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