From: simonmar Date: Thu, 16 Mar 2000 12:37:06 +0000 (+0000) Subject: [project @ 2000-03-16 12:37:05 by simonmar] X-Git-Tag: Approximately_9120_patches~4969 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0f3bf3545a6b6da4c891900916b61ba2ca768c6a;p=ghc-hetmet.git [project @ 2000-03-16 12:37:05 by simonmar] Clean up the module initialisation stuff a bit, and add support for module initialisation blocks in the native code generator. --- diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 8b3bfd4..74da4a3 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.27 2000/03/08 17:48:24 simonmar Exp $ +% $Id: AbsCSyn.lhs,v 1.28 2000/03/16 12:37:06 simonmar Exp $ % \section[AbstractC]{Abstract C: the last stop before machine code} @@ -202,7 +202,7 @@ stored in a mixed type location.) TyCon -- which TyCon this table is for | CModuleInitBlock -- module initialisation block - CAddrMode -- label for init block + CLabel -- label for init block AbstractC -- initialisation code | CCostCentreDecl -- A cost centre *declaration* diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 3d0ade9..546c060 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.30 1999/12/02 17:57:13 simonmar Exp $ +% $Id: CLabel.lhs,v 1.31 2000/03/16 12:37:06 simonmar Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} @@ -34,6 +34,8 @@ module CLabel ( mkAsmTempLabel, + mkModuleInitLabel, + mkErrorStdEntryLabel, mkUpdInfoLabel, mkTopTickyCtrLabel, @@ -42,6 +44,8 @@ module CLabel ( mkSECAFBlackHoleInfoTableLabel, mkRtsPrimOpLabel, + moduleRegdLabel, + mkSelectorInfoLabel, mkSelectorEntryLabel, @@ -67,7 +71,7 @@ import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) import CStrings ( pp_cSEP ) import DataCon ( ConTag, DataCon ) -import Module ( isDynamicModule ) +import Module ( isDynamicModule, ModuleName, moduleNameString ) import Name ( Name, getName, isExternallyVisibleName, nameModule, isLocallyDefinedName ) import TyCon ( TyCon ) import Unique ( pprUnique, Unique ) @@ -107,6 +111,8 @@ data CLabel | AsmTempLabel Unique + | ModuleInitLabel ModuleName + | RtsLabel RtsLabelInfo | CC_Label CostCentre @@ -170,6 +176,8 @@ data RtsLabelInfo | RtsTopTickyCtr + | RtsModuleRegd + deriving (Eq, Ord) -- Label Type: for generating C declarations. @@ -211,6 +219,8 @@ mkClosureTblLabel tycon = TyConLabel tycon mkAsmTempLabel = AsmTempLabel +mkModuleInitLabel = ModuleInitLabel + -- Some fixed runtime system labels mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode @@ -224,6 +234,8 @@ mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then panic "mkSECAFBlackHoleInfoTableLabel requires -ticky" mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) +moduleRegdLabel = RtsLabel RtsModuleRegd + mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTbl upd off) mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) @@ -262,6 +274,7 @@ needsCDecl (CaseLabel _ _) = False needsCDecl (TyConLabel _) = True needsCDecl (AsmTempLabel _) = False +needsCDecl (ModuleInitLabel _) = False needsCDecl (RtsLabel _) = False needsCDecl (CC_Label _) = False needsCDecl (CCS_Label _) = False @@ -284,6 +297,8 @@ externallyVisibleCLabel (DataConLabel _ _) = True externallyVisibleCLabel (TyConLabel tc) = True externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (AsmTempLabel _) = False +externallyVisibleCLabel (ModuleInitLabel _)= True +externallyVisibleCLabel (RtsLabel RtsModuleRegd) = False --hack externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (IdLabel id _) = isExternallyVisibleName id externallyVisibleCLabel (CC_Label _) = False -- not strictly true @@ -448,6 +463,9 @@ pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) pprCLbl (RtsLabel (RtsPrimOp primop)) = pprPrimOp primop <> ptext SLIT("_fast") +pprCLbl (RtsLabel RtsModuleRegd) + = ptext SLIT("module_registered") + pprCLbl (TyConLabel tc) = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")] @@ -457,6 +475,8 @@ pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs +pprCLbl (ModuleInitLabel mod) = ptext SLIT("__init_") <> ptext mod + ppIdFlavor :: IdLabelInfo -> SDoc ppIdFlavor x = pp_cSEP <> diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 008cada..ff1e5c3 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -563,9 +563,9 @@ pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ LvLarge _ -> SLIT("RET_VEC_BIG") -pprAbsC stmt@(CModuleInitBlock label code) _ +pprAbsC stmt@(CModuleInitBlock lbl code) _ = vcat [ - ptext SLIT("START_MOD_INIT") <> parens (ppr_amode label), + ptext SLIT("START_MOD_INIT") <> parens (pprCLabel lbl), case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts }, pprAbsC code (costs code), hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen] diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 2e374b4..a2dcbc9 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -22,7 +22,7 @@ module CodeGen ( codeGen ) where import StgSyn import CgMonad import AbsCSyn -import CLabel ( CLabel, mkSRTLabel, mkClosureLabel ) +import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel ) import PprAbsC ( dumpRealC ) import AbsCUtils ( mkAbstractCs, mkAbsCStmts, flattenAbsC ) @@ -117,17 +117,16 @@ mkModuleInit fe_binders mod imps cost_centre_info (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info - mk_reg_lbl mod_name - = CLitLit (_PK_ ("__init_" ++ moduleNameString mod_name)) AddrRep - mk_import_register import_name - = CMacroStmt REGISTER_IMPORT [mk_reg_lbl import_name] + = CMacroStmt REGISTER_IMPORT [ + CLbl (mkModuleInitLabel import_name) AddrRep + ] register_imports = map mk_import_register imps in - mkAbstractCs [ + mkAbstractCs [ cc_decls, - CModuleInitBlock (mk_reg_lbl (Module.moduleName mod)) + CModuleInitBlock (mkModuleInitLabel (Module.moduleName mod)) (mkAbstractCs (register_fes ++ cc_regs : register_imports)) diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index df6ea2e..c918451 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -23,7 +23,8 @@ import SMRep ( fixedItblSize, ) import Constants ( mIN_UPD_SIZE ) import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, - mkClosureTblLabel, mkStaticClosureLabel ) + mkClosureTblLabel, mkStaticClosureLabel, + moduleRegdLabel ) import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI, closureUpdReqd, staticClosureNeedsLink @@ -150,10 +151,26 @@ Here we handle top-level things, like @CCodeBlock@s and (tyConDataCons tycon) ) ] + gentopcode stmt@(CModuleInitBlock lbl absC) + = gencode absC `thenUs` \ code -> + getUniqLabelNCG `thenUs` \ tmp_lbl -> + returnUs ( StSegment DataSegment + : StLabel moduleRegdLabel + : StData IntRep [StInt 0] + : StSegment TextSegment + : StLabel lbl + : StCondJump tmp_lbl (StPrim IntNeOp [StCLbl moduleRegdLabel, + StInt 0]) + : StAssign IntRep (StInd IntRep (StCLbl moduleRegdLabel)) (StInt 1) + : code + [ StLabel tmp_lbl + , StAssign PtrRep stgSp (StPrim IntSubOp [stgSp, StInt 4]) + , StJump (StInd WordRep stgSp) + ]) + gentopcode absC = gencode absC `thenUs` \ code -> returnUs (StSegment TextSegment : code []) - \end{code} \begin{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 2433bb1..621b9f7 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -65,6 +65,7 @@ stmt2Instrs stmt = case stmt of LABEL lab))) StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)), returnNat nilOL) + StLabel lab -> returnNat (unitOL (LABEL lab)) StJump arg -> genJump arg diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 4af972d..522aceb 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -166,19 +166,28 @@ macroCode SET_TAG [tag] case stgReg tagreg of Always _ -> returnUs id Save _ -> returnUs (\ xs -> set_tag : xs) +\end{code} + +----------------------------------------------------------------------------- + +\begin{code} +macroCode REGISTER_IMPORT [arg] + = returnUs ( + \xs -> StAssign WordRep (StInd WordRep stgSp) (amodeToStix arg) + : StAssign PtrRep stgSp (StPrim IntAddOp [stgSp, StInt 4]) + : xs + ) + +macroCode REGISTER_FOREIGN_EXPORT [arg] + = returnUs ( + \xs -> StCall SLIT("getStablePtr") cCallConv VoidRep [amodeToStix arg] + : xs + ) macroCode other args = case other of - ARGS_CHK -> error "foobarxyzzy1" - ARGS_CHK_LOAD_NODE -> error "foobarxyzzy2" - UPD_CAF -> error "foobarxyzzy3" - UPD_BH_UPDATABLE -> error "foobarxyzzy4" - UPD_BH_SINGLE_ENTRY -> error "foobarxyzzy5" - PUSH_UPD_FRAME -> error "foobarxyzzy6" - PUSH_SEQ_FRAME -> error "foobarxyzzy7" - UPDATE_SU_FROM_UPD_FRAME -> error "foobarxyzzy8" - SET_TAG -> error "foobarxyzzy9" - + SET_TAG -> error "foobarxyzzy8" + _ -> error "StixMacro.macroCode: unknown macro/args" \end{code}