From 9a972425548b14c2267e4a82fa1525314ebd7b06 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 16 Jul 2002 14:56:11 +0000 Subject: [PATCH] [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__ where is the module version of Foo (same as the version in the interface file), and 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. --- ghc/compiler/absCSyn/AbsCSyn.lhs | 5 +- ghc/compiler/absCSyn/AbsCUtils.lhs | 2 +- ghc/compiler/absCSyn/CLabel.lhs | 30 +++++++++--- ghc/compiler/absCSyn/PprAbsC.lhs | 7 +-- ghc/compiler/codeGen/CodeGen.lhs | 82 +++++++++++++++++++------------- ghc/compiler/compMan/CompManager.lhs | 2 +- ghc/compiler/main/HscMain.lhs | 14 ++++-- ghc/compiler/main/HscTypes.lhs | 11 +++-- ghc/compiler/nativeGen/AbsCStixGen.lhs | 4 +- ghc/includes/StgMacros.h | 42 ++++++++++++++-- ghc/rts/StgStartup.hc | 7 +-- 11 files changed, 139 insertions(+), 67 deletions(-) diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 2389512..3f6bd24 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (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* diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 5cfe697..9271ba2 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -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} diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index a26d9d7..92ead17 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (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 diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index c08740c..3259aca 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -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} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 477790d..e7c53c1 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -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)) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 449801c..dc5a2db 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -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 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 747a14a..348e562 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -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 diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 045c17f..4dcfaa9 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -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} diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 81a026f..333f986 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -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), diff --git a/ghc/includes/StgMacros.h b/ghc/includes/StgMacros.h index 711db95..86d99da 100644 --- a/ghc/includes/StgMacros.h +++ b/ghc/includes/StgMacros.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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; \ diff --git a/ghc/rts/StgStartup.hc b/ghc/rts/StgStartup.hc index 0121e81..660bf35 100644 --- a/ghc/rts/StgStartup.hc +++ b/ghc/rts/StgStartup.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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(); -- 1.7.10.4