[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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}