projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2001-09-04 18:29:20 by ken]
[ghc-hetmet.git] / ghc / compiler / absCSyn / CLabel.lhs
diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs
index 7d925e6..c8712f5 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.37 2000/07/03 14:59:25 simonmar Exp $
+% $Id: CLabel.lhs,v 1.47 2001/09/04 18:29:20 ken Exp $
 %
 \section[CLabel]{@CLabel@: Information to make C Labels}
 
@@ -48,6 +48,7 @@ module CLabel (
        mkCharlikeClosureLabel,
        mkIntlikeClosureLabel,
        mkMAP_FROZEN_infoLabel,
+        mkEMPTY_MVAR_infoLabel,
 
        mkTopTickyCtrLabel,
        mkBlackHoleInfoTableLabel,
@@ -83,14 +84,14 @@ import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
 
 import CmdLineOpts      ( opt_Static, opt_DoTickyProfiling )
 import CStrings                ( pp_cSEP )
-import DataCon         ( ConTag, DataCon )
-import Module          ( ModuleName )
+import DataCon         ( ConTag )
+import Module          ( moduleName, moduleNameFS, 
+                         Module, isHomeModule )
 import Name            ( Name, getName, isDllName, isExternallyVisibleName )
 import TyCon           ( TyCon )
 import Unique          ( pprUnique, Unique )
-import PrimOp          ( PrimOp, pprPrimOp )
+import PrimOp          ( PrimOp )
 import CostCentre      ( CostCentre, CostCentreStack )
-import Util
 import Outputable
 \end{code}
 
@@ -124,7 +125,7 @@ data CLabel
 
   | AsmTempLabel    Unique
 
-  | ModuleInitLabel ModuleName
+  | ModuleInitLabel Module
 
   | RtsLabel       RtsLabelInfo
 
@@ -241,25 +242,25 @@ mkModuleInitLabel         = ModuleInitLabel
 
        -- Some fixed runtime system labels
 
-mkErrorStdEntryLabel           = RtsLabel RtsShouldNeverHappenCode
-
+mkErrorStdEntryLabel           = RtsLabel RtsShouldNeverHappenCode
 mkStgUpdatePAPLabel            = RtsLabel (Rts_Code "stg_update_PAP")
 mkSplitMarkerLabel             = RtsLabel (Rts_Code "__stg_split_marker")
 mkUpdInfoLabel                 = RtsLabel RtsUpdInfo
 mkSeqInfoLabel                 = RtsLabel RtsSeqInfo
-mkIndInfoLabel                 = RtsLabel (Rts_Info "IND_info")
-mkIndStaticInfoLabel           = RtsLabel (Rts_Info "IND_STATIC_info")
+mkIndInfoLabel                 = RtsLabel (Rts_Info "stg_IND_info")
+mkIndStaticInfoLabel           = RtsLabel (Rts_Info "stg_IND_STATIC_info")
 mkRtsGCEntryLabel str          = RtsLabel (RtsGCEntryLabel str)
 mkMainRegTableLabel            = RtsLabel RtsMainRegTable
-mkCharlikeClosureLabel         = RtsLabel (Rts_Closure "CHARLIKE_closure")
-mkIntlikeClosureLabel          = RtsLabel (Rts_Closure "INTLIKE_closure")
-mkMAP_FROZEN_infoLabel         = RtsLabel (Rts_Info "MUT_ARR_PTRS_FROZEN_info")
+mkCharlikeClosureLabel         = RtsLabel (Rts_Closure "stg_CHARLIKE_closure")
+mkIntlikeClosureLabel          = RtsLabel (Rts_Closure "stg_INTLIKE_closure")
+mkMAP_FROZEN_infoLabel         = RtsLabel (Rts_Info "stg_MUT_ARR_PTRS_FROZEN_info")
+mkEMPTY_MVAR_infoLabel         = RtsLabel (Rts_Info "stg_EMPTY_MVAR_info")
 
 mkTopTickyCtrLabel             = RtsLabel RtsTopTickyCtr
-mkBlackHoleInfoTableLabel      = RtsLabel (RtsBlackHoleInfoTbl SLIT("BLACKHOLE_info"))
-mkCAFBlackHoleInfoTableLabel   = RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info"))
+mkBlackHoleInfoTableLabel      = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_info"))
+mkCAFBlackHoleInfoTableLabel   = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_CAF_BLACKHOLE_info"))
 mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then
-                                    RtsLabel (RtsBlackHoleInfoTbl SLIT("SE_CAF_BLACKHOLE_info"))
+                                    RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_SE_CAF_BLACKHOLE_info"))
                                   else  -- RTS won't have info table unless -ticky is on
                                     panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
 mkRtsPrimOpLabel primop                = RtsLabel (RtsPrimOp primop)
@@ -305,11 +306,11 @@ let-no-escapes, which can be recursive.
 needsCDecl (IdLabel _ _)               = True
 needsCDecl (CaseLabel _ CaseReturnPt)  = True
 needsCDecl (DataConLabel _ _)          = True
-needsCDecl (CaseLabel _ _)             = False
 needsCDecl (TyConLabel _)              = True
+needsCDecl (ModuleInitLabel _)         = True
 
+needsCDecl (CaseLabel _ _)             = False
 needsCDecl (AsmTempLabel _)            = False
-needsCDecl (ModuleInitLabel _)         = False
 needsCDecl (RtsLabel _)                        = False
 needsCDecl (ForeignLabel _ _)          = False
 needsCDecl (CC_Label _)                        = False
@@ -354,6 +355,7 @@ labelType (CaseLabel _ CaseReturnInfo)        = InfoTblType
 labelType (CaseLabel _ CaseReturnPt)         = CodeType
 labelType (CaseLabel _ CaseVecTbl)            = VecTblType
 labelType (TyConLabel _)                     = ClosureTblType
+labelType (ModuleInitLabel _ )                = CodeType
 
 labelType (IdLabel _ info) = 
   case info of
@@ -379,12 +381,16 @@ in a DLL, be it a data reference or not.
 labelDynamic :: CLabel -> Bool
 labelDynamic lbl = 
   case lbl of
-   RtsLabel _              -> not opt_Static  -- i.e., is the RTS in a DLL or not?
-   IdLabel n k      -> isDllName n
-   DataConLabel n k -> isDllName n
-   TyConLabel tc    -> isDllName (getName tc)
-   ForeignLabel _ d -> d
-   _               -> False
+   -- The special case for RtsShouldNeverHappenCode is because the associated address is
+   -- NULL, i.e. not a DLL entry point
+   RtsLabel RtsShouldNeverHappenCode -> False
+   RtsLabel _               -> not opt_Static  -- i.e., is the RTS in a DLL or not?
+   IdLabel n k       -> isDllName n
+   DataConLabel n k  -> isDllName n
+   TyConLabel tc     -> isDllName (getName tc)
+   ForeignLabel _ d  -> d
+   ModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
+   _                -> False
 \end{code}
 
 
@@ -459,10 +465,12 @@ pprCLbl (CaseLabel u CaseDefault)
 pprCLbl (CaseLabel u CaseBitmap)
   = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]
 
-pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry")
+pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("NULL")
+-- used to be stg_error_entry but Windows can't have DLL entry points as static
+-- initialisers, and besides, this ShouldNeverHappen, right?
 
-pprCLbl (RtsLabel RtsUpdInfo)            = ptext SLIT("upd_frame_info")
-pprCLbl (RtsLabel RtsSeqInfo)            = ptext SLIT("seq_frame_info")
+pprCLbl (RtsLabel RtsUpdInfo)            = ptext SLIT("stg_upd_frame_info")
+pprCLbl (RtsLabel RtsSeqInfo)            = ptext SLIT("stg_seq_frame_info")
 pprCLbl (RtsLabel RtsMainRegTable)       = ptext SLIT("MainRegTable")
 pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str
 pprCLbl (RtsLabel (Rts_Closure str))     = text str
@@ -474,35 +482,35 @@ pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
 pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
 
 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
-  = hcat [ptext SLIT("__sel_"), text (show offset),
+  = hcat [ptext SLIT("stg_sel_"), text (show offset),
                ptext (if upd_reqd 
                        then SLIT("_upd_info") 
                        else SLIT("_noupd_info"))
        ]
 
 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
-  = hcat [ptext SLIT("__sel_"), text (show offset),
+  = hcat [ptext SLIT("stg_sel_"), text (show offset),
                ptext (if upd_reqd 
                        then SLIT("_upd_entry") 
                        else SLIT("_noupd_entry"))
        ]
 
 pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
-  = hcat [ptext SLIT("__ap_"), text (show arity),
+  = hcat [ptext SLIT("stg_ap_"), text (show arity),
                ptext (if upd_reqd 
                        then SLIT("_upd_info") 
                        else SLIT("_noupd_info"))
        ]
 
 pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
-  = hcat [ptext SLIT("__ap_"), text (show arity),
+  = hcat [ptext SLIT("stg_ap_"), text (show arity),
                ptext (if upd_reqd 
                        then SLIT("_upd_entry") 
                        else SLIT("_noupd_entry"))
        ]
 
 pprCLbl (RtsLabel (RtsPrimOp primop)) 
-  = pprPrimOp primop <> ptext SLIT("_fast")
+  = ppr primop <> ptext SLIT("_fast")
 
 pprCLbl (RtsLabel RtsModuleRegd)
   = ptext SLIT("module_registered")
@@ -519,7 +527,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
+pprCLbl (ModuleInitLabel mod)  
+   = ptext SLIT("__stginit_") <> ptext (moduleNameFS (moduleName mod))
 
 ppIdFlavor :: IdLabelInfo -> SDoc
 
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)