[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.

ghc/compiler/absCSyn/AbsCSyn.lhs

 %
 % (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*

ghc/compiler/absCSyn/CLabel.lhs

 %
 % (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 <>

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]

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))

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}

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

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}