[project @ 1998-12-02 13:17:09 by simonm]
[ghc-hetmet.git] / ghc / compiler / absCSyn / CLabel.lhs
index 1b760eb..fa05304 100644 (file)
@@ -1,5 +1,7 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CLabel.lhs,v 1.21 1998/12/02 13:17:19 simonm Exp $
 %
 \section[CLabel]{@CLabel@: Information to make C Labels}
 
@@ -8,6 +10,7 @@ module CLabel (
        CLabel, -- abstract type
 
        mkClosureLabel,
+       mkSRTLabel,
        mkInfoTableLabel,
        mkStdEntryLabel,
        mkFastEntryLabel,
@@ -15,30 +18,36 @@ module CLabel (
        mkStaticConEntryLabel,
        mkRednCountsLabel,
        mkConInfoTableLabel,
-       mkPhantomInfoTableLabel,
        mkStaticClosureLabel,
        mkStaticInfoTableLabel,
-       mkVapEntryLabel,
-       mkVapInfoTableLabel,
-
-       mkConUpdCodePtrVecLabel,
-       mkStdUpdCodePtrVecLabel,
-
-       mkInfoTableVecTblLabel,
-       mkStdUpdVecTblLabel,
+       mkApEntryLabel,
+       mkApInfoTableLabel,
 
        mkReturnPtLabel,
+       mkReturnInfoLabel,
        mkVecTblLabel,
        mkAltLabel,
        mkDefaultLabel,
+       mkBitmapLabel,
+
+       mkClosureTblLabel,
 
        mkAsmTempLabel,
 
        mkErrorStdEntryLabel,
+       mkUpdEntryLabel,
        mkBlackHoleInfoTableLabel,
+       mkRtsPrimOpLabel,
+
+       mkSelectorInfoLabel,
+       mkSelectorEntryLabel,
 
+       mkCC_Label, mkCCS_Label,
+       
        needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
 
+       CLabelType(..), labelType,
+
        pprCLabel
 #if ! OMIT_NATIVE_CODEGEN
        , pprCLabel_asm
@@ -52,19 +61,14 @@ module CLabel (
 import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
 #endif
 
-import CgRetConv       ( CtrlReturnConvention(..), ctrlReturnConvAlg )
 import CStrings                ( pp_cSEP )
-import Id              ( externallyVisibleId,
-                         isDataCon,
-                         fIRST_TAG,
-                         ConTag,
-                         Id
-                       )
-import Maybes          ( maybeToBool )
-import PprType         ( showTyCon )
+import DataCon         ( ConTag, DataCon )
+import Name            ( Name, isExternallyVisibleName )
 import TyCon           ( TyCon )
-import Unique          ( showUnique, pprUnique, Unique )
-import Util            ( assertPanic{-, pprTraceToDo:rm-} )
+import Unique          ( pprUnique, Unique )
+import PrimOp          ( PrimOp, pprPrimOp )
+import CostCentre      ( CostCentre, CostCentreStack )
+import Util
 import Outputable
 \end{code}
 
@@ -76,100 +80,72 @@ things we want to find out:
 
 * does it need declarations at all? (v common Prelude things are pre-declared)
 
+* what type does it have? (for generating accurate enough C declarations
+  so that the C compiler won't complain).
+
 \begin{code}
 data CLabel
   = IdLabel                    -- A family of labels related to the
-       CLabelId                -- definition of a particular Id
-       IdLabelInfo             -- Includes DataCon
+       Name                    -- definition of a particular Id
+       IdLabelInfo
 
-  | TyConLabel                 -- A family of labels related to the
-       TyCon                   -- definition of a data type
-       TyConLabelInfo
+  | DataConLabel               -- Ditto data constructors
+       Name
+       DataConLabelInfo
 
   | CaseLabel                  -- A family of labels related to a particular case expression
        Unique                  -- Unique says which case expression
        CaseLabelInfo
 
+  | TyConLabel TyCon           -- currently only one kind of TyconLabel,
+                               -- a 'Closure Table'.
+
   | AsmTempLabel    Unique
 
   | RtsLabel       RtsLabelInfo
 
-  deriving (Eq, Ord)
-\end{code}
-
-The CLabelId is simply so we can declare alternative Eq and Ord
-instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
-comparing the Uniques of two specialised data constructors (which have
-the same as the uniques their respective unspecialised data
-constructors). Instead, the specialising types and the uniques of the
-unspecialised constructors are compared.
+  | CC_Label CostCentre
+  | CCS_Label CostCentreStack
 
-\begin{code}
-data CLabelId = CLabelId Id
-
-instance Eq CLabelId where
-    CLabelId a == CLabelId b = case (a `compare` b) of { EQ -> True;  _ -> False }
-    CLabelId a /= CLabelId b = case (a `compare` b) of { EQ -> False; _ -> True  }
-
-instance Ord CLabelId where
-    CLabelId a <= CLabelId b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
-    CLabelId a <  CLabelId b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
-    CLabelId a >= CLabelId b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
-    CLabelId a >  CLabelId b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
-    compare (CLabelId a) (CLabelId b) = a `compare` b
+  deriving (Eq, Ord)
 \end{code}
 
 \begin{code}
 data IdLabelInfo
   = Closure            -- Label for (static???) closure
-  | StaticClosure      -- Static closure -- e.g., nullary constructor
+
+  | SRT                 -- Static reference table
 
   | InfoTbl            -- Info table for a closure; always read-only
 
-  | EntryStd           -- Thunk, or "slow", code entry point (requires arg satis check)
+  | EntryStd           -- Thunk, or "slow", code entry point
+
   | EntryFast Int      -- entry pt when no arg satisfaction chk needed;
                        -- Int is the arity of the function (to be
                        -- encoded into the name)
 
-  | ConEntry           -- the only kind of entry pt for constructors
+                       -- Ticky-ticky counting
+  | RednCounts         -- Label of place to keep reduction-count info for 
+                       -- this Id
+  deriving (Eq, Ord)
+
+data DataConLabelInfo
+  = ConEntry           -- the only kind of entry pt for constructors
   | ConInfoTbl         -- corresponding info table
 
+  | StaticClosure      -- Static constructor closure
+                       -- e.g., nullary constructor
   | StaticConEntry     -- static constructor entry point
   | StaticInfoTbl      -- corresponding info table
-
-  | PhantomInfoTbl     -- for phantom constructors that only exist in regs
-
-  | VapInfoTbl Bool    -- True <=> the update-reqd version; False <=> the no-update-reqd version
-  | VapEntry   Bool
-
-       -- Ticky-ticky counting
-  | RednCounts         -- Label of place to keep reduction-count info for this Id
-  deriving (Eq, Ord)
-
-
-data TyConLabelInfo
-  = UnvecConUpdCode     -- Update code for the data type if it's unvectored
-
-  | VecConUpdCode ConTag -- One for each constructor which returns in
-                        -- regs; this code actually performs an update
-
-  | StdUpdCode ConTag   -- Update code for all constructors which return
-                        -- in heap.  There are a small number of variants,
-                        -- so that the update code returns (vectored/n or
-                        -- unvectored) in the right way.
-                        -- ToDo: maybe replace TyCon/Int with return conv.
-
-  | InfoTblVecTbl       -- For tables of info tables
-
-  | StdUpdVecTbl        -- Labels the update code, or table of update codes,
-                        -- for a particular type.
   deriving (Eq, Ord)
 
 data CaseLabelInfo
   = CaseReturnPt
+  | CaseReturnInfo
   | CaseVecTbl
   | CaseAlt ConTag
   | CaseDefault
+  | CaseBitmap
   deriving (Eq, Ord)
 
 data RtsLabelInfo
@@ -177,58 +153,73 @@ data RtsLabelInfo
 
   | RtsBlackHoleInfoTbl
 
-  | RtsSelectorInfoTbl -- Selectors
-       Bool            -- True <=> the update-reqd version;
-                       -- False <=> the no-update-reqd version
-       Int             -- 0-indexed Offset from the "goods"
+  | RtsUpdEntry
+
+  | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks
+  | RtsSelectorEntry   Bool{-updatable-} Int{-offset-}
+
+  | RtsApInfoTbl Bool{-updatable-} Int{-arity-}                -- AP thunks
+  | RtsApEntry   Bool{-updatable-} Int{-arity-}
+
+  | RtsPrimOp PrimOp
 
-  | RtsSelectorEntry   -- Ditto entry code
-       Bool
-       Int
   deriving (Eq, Ord)
+
+-- Label Type: for generating C declarations.
+
+data CLabelType
+  = InfoTblType
+  | ClosureType
+  | VecTblType
+  | CodeType
+  | DataType
 \end{code}
 
 \begin{code}
-mkClosureLabel         id              = IdLabel (CLabelId id)  Closure
-mkInfoTableLabel       id              = IdLabel (CLabelId id)  InfoTbl
-mkStdEntryLabel                id              = IdLabel (CLabelId id)  EntryStd
+mkClosureLabel         id              = IdLabel id  Closure
+mkSRTLabel             id              = IdLabel id  SRT
+mkInfoTableLabel       id              = IdLabel id  InfoTbl
+mkStdEntryLabel                id              = IdLabel id  EntryStd
 mkFastEntryLabel       id arity        = ASSERT(arity > 0)
-                                         IdLabel (CLabelId id)  (EntryFast arity)
-
-mkStaticClosureLabel   con             = ASSERT(isDataCon con)
-                                         IdLabel (CLabelId con) StaticClosure
-mkStaticInfoTableLabel  con            = ASSERT(isDataCon con)
-                                         IdLabel (CLabelId con) StaticInfoTbl
-mkConInfoTableLabel     con            = ASSERT(isDataCon con)
-                                         IdLabel (CLabelId con) ConInfoTbl
-mkPhantomInfoTableLabel con            = ASSERT(isDataCon con)
-                                         IdLabel (CLabelId con) PhantomInfoTbl
-mkConEntryLabel                con             = ASSERT(isDataCon con)
-                                         IdLabel (CLabelId con) ConEntry
-mkStaticConEntryLabel  con             = ASSERT(isDataCon con)
-                                         IdLabel (CLabelId con) StaticConEntry
-
-mkRednCountsLabel      id              = IdLabel (CLabelId id)  RednCounts
-mkVapEntryLabel                id upd_flag     = IdLabel (CLabelId id)  (VapEntry upd_flag)
-mkVapInfoTableLabel    id upd_flag     = IdLabel (CLabelId id)  (VapInfoTbl upd_flag)
-
-mkConUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (VecConUpdCode tag)
-mkStdUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (StdUpdCode tag)
-
-mkInfoTableVecTblLabel   tycon     = TyConLabel tycon InfoTblVecTbl
-mkStdUpdVecTblLabel      tycon     = TyConLabel tycon StdUpdVecTbl
+                                         IdLabel id  (EntryFast arity)
+
+mkRednCountsLabel      id              = IdLabel id  RednCounts
+
+mkStaticClosureLabel   con             = DataConLabel con StaticClosure
+mkStaticInfoTableLabel  con            = DataConLabel con StaticInfoTbl
+mkConInfoTableLabel     con            = DataConLabel con ConInfoTbl
+mkConEntryLabel                con             = DataConLabel con ConEntry
+mkStaticConEntryLabel  con             = DataConLabel con StaticConEntry
+
 
 mkReturnPtLabel uniq           = CaseLabel uniq CaseReturnPt
+mkReturnInfoLabel uniq         = CaseLabel uniq CaseReturnInfo
 mkVecTblLabel   uniq           = CaseLabel uniq CaseVecTbl
 mkAltLabel      uniq tag       = CaseLabel uniq (CaseAlt tag)
 mkDefaultLabel  uniq           = CaseLabel uniq CaseDefault
+mkBitmapLabel   uniq           = CaseLabel uniq CaseBitmap
+
+mkClosureTblLabel tycon                = TyConLabel tycon
 
 mkAsmTempLabel                         = AsmTempLabel
 
        -- Some fixed runtime system labels
 
 mkErrorStdEntryLabel           = RtsLabel RtsShouldNeverHappenCode
+mkUpdEntryLabel                        = RtsLabel RtsUpdEntry
 mkBlackHoleInfoTableLabel      = RtsLabel RtsBlackHoleInfoTbl
+mkRtsPrimOpLabel primop                = RtsLabel (RtsPrimOp primop)
+
+mkSelectorInfoLabel  upd off   = RtsLabel (RtsSelectorInfoTbl upd off)
+mkSelectorEntryLabel upd off   = RtsLabel (RtsSelectorEntry   upd off)
+
+mkApInfoTableLabel  upd off    = RtsLabel (RtsApInfoTbl upd off)
+mkApEntryLabel upd off         = RtsLabel (RtsApEntry   upd off)
+
+       -- Cost centres etc.
+
+mkCC_Label     cc              = CC_Label cc
+mkCCS_Label    ccs             = CCS_Label ccs
 \end{code}
 
 \begin{code}
@@ -246,36 +237,40 @@ labels.
 
 Declarations for (non-prelude) @Id@-based things are needed because of
 mutual recursion.
-\begin{code}
-needsCDecl (IdLabel _ _)              = True
-needsCDecl (CaseLabel _ _)            = False
-
-needsCDecl (TyConLabel _ (StdUpdCode _)) = False
-needsCDecl (TyConLabel _ InfoTblVecTbl)  = False
-needsCDecl (TyConLabel _ other)          = True
 
-needsCDecl (AsmTempLabel _)            = False
-needsCDecl (RtsLabel _)                = False
+Declarations for direct return points are needed, because they may be
+let-no-escapes, which can be recursive.
 
-needsCDecl other                      = True
+\begin{code}
+needsCDecl (IdLabel _ _)               = True
+needsCDecl (CaseLabel _ CaseReturnPt)  = True
+needsCDecl (DataConLabel _ _)          = True
+needsCDecl (CaseLabel _ _)             = False
+
+needsCDecl (AsmTempLabel _)            = False
+needsCDecl (TyConLabel _)              = False
+needsCDecl (RtsLabel _)                        = False
+needsCDecl (CC_Label _)                        = False
+needsCDecl (CCS_Label _)               = False
 \end{code}
 
 Whether the labelled thing can be put in C "text space":
+
 \begin{code}
-isReadOnly (IdLabel _ InfoTbl)         = True  -- info-tables: yes
-isReadOnly (IdLabel _ ConInfoTbl)      = True -- and so on, for other
-isReadOnly (IdLabel _ StaticInfoTbl)   = True 
-isReadOnly (IdLabel _ PhantomInfoTbl)  = True
-isReadOnly (IdLabel _ (VapInfoTbl _))  = True
-isReadOnly (IdLabel _ other)           = False -- others: pessimistically, no
-
-isReadOnly (TyConLabel _ _)    = True
-isReadOnly (CaseLabel _ _)     = True
-isReadOnly (AsmTempLabel _)    = True
-isReadOnly (RtsLabel _)        = True
+isReadOnly (IdLabel _ InfoTbl) = True  -- info-tables: yes
+isReadOnly (IdLabel _ other)   = False -- others: pessimistically, no
+
+isReadOnly (DataConLabel _ _)  = True -- and so on, for other
+isReadOnly (TyConLabel _)      = True
+isReadOnly (CaseLabel _ _)     = True
+isReadOnly (AsmTempLabel _)    = True
+isReadOnly (RtsLabel _)                = True
+isReadOnly (CC_Label _)                = True
+isReadOnly (CCS_Label _)       = True
 \end{code}
 
 Whether the label is an assembler temporary:
+
 \begin{code}
 isAsmTemp (AsmTempLabel _) = True
 isAsmTemp _               = False
@@ -283,15 +278,45 @@ isAsmTemp _                  = False
 
 C ``static'' or not...
 From the point of view of the code generator, a name is
-externally visible if it should be given put in the .o file's 
-symbol table; that is, made static.
+externally visible if it has to be declared as exported
+in the .o file's symbol table; that is, made non-static.
+
+\begin{code}
+externallyVisibleCLabel (DataConLabel _ _) = True
+externallyVisibleCLabel (TyConLabel tc)    = True
+externallyVisibleCLabel (CaseLabel _ _)           = False
+externallyVisibleCLabel (AsmTempLabel _)   = False
+externallyVisibleCLabel (RtsLabel _)      = True
+externallyVisibleCLabel (IdLabel id _)     = isExternallyVisibleName id
+externallyVisibleCLabel (CC_Label _)      = False -- not strictly true
+externallyVisibleCLabel (CCS_Label _)     = False -- not strictly true
+\end{code}
+
+For generating correct types in label declarations...
 
 \begin{code}
-externallyVisibleCLabel (TyConLabel tc _) = True
-externallyVisibleCLabel (CaseLabel _ _)          = False
-externallyVisibleCLabel (AsmTempLabel _)  = False
-externallyVisibleCLabel (RtsLabel _)     = True
-externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
+labelType :: CLabel -> CLabelType
+labelType (RtsLabel RtsBlackHoleInfoTbl)      = InfoTblType
+labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
+labelType (RtsLabel (RtsApInfoTbl _ _))       = InfoTblType
+labelType (CaseLabel _ CaseReturnInfo)        = InfoTblType
+labelType (CaseLabel _ CaseReturnPt)         = CodeType
+labelType (CaseLabel _ CaseVecTbl)            = VecTblType
+
+labelType (IdLabel _ info) = 
+  case info of
+    InfoTbl       -> InfoTblType
+    Closure      -> ClosureType
+    _            -> CodeType
+
+labelType (DataConLabel _ info) = 
+  case info of
+     ConInfoTbl    -> InfoTblType
+     StaticInfoTbl -> InfoTblType
+     StaticClosure -> ClosureType
+     _            -> CodeType
+
+labelType _        = DataType
 \end{code}
 
 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
@@ -302,6 +327,33 @@ We need at least @Eq@ for @CLabels@, because we want to avoid
 duplicate declarations in generating C (see @labelSeenTE@ in
 @PprAbsC@).
 
+-----------------------------------------------------------------------------
+Printing out CLabels.
+
+Convention:
+
+      <name>_<type>
+
+where <name> is <Module>_<name> for external names and <unique> for
+internal names. <type> is one of the following:
+
+        info                   Info table
+        srt                    Static reference table
+        entry                  Entry code
+        ret                    Direct return address    
+        vtbl                   Vector table
+        <n>_alt                Case alternative (tag n)
+        dflt                   Default case alternative
+        btm                    Large bitmap vector
+        closure                Static closure
+        static_closure         Static closure (???)
+        con_entry              Dynamic Constructor entry code
+        con_info               Dynamic Constructor info table
+        static_entry           Static Constructor entry code
+        static_info            Static Constructor info table
+        sel_info               Selector info table
+        sel_entry              Selector entry code
+
 \begin{code}
 -- specialised for PprAsm: saves lots of arg passing in NCG
 #if ! OMIT_NATIVE_CODEGEN
@@ -312,7 +364,7 @@ pprCLabel :: CLabel -> SDoc
 
 #if ! OMIT_NATIVE_CODEGEN
 pprCLabel (AsmTempLabel u)
-  = text (fmtAsmLbl (showUnique u))
+  = text (fmtAsmLbl (show u))
 #endif
 
 pprCLabel lbl = 
@@ -324,85 +376,85 @@ pprCLabel lbl =
 #endif
        pprCLbl lbl
 
-
-pprCLbl (TyConLabel tc UnvecConUpdCode)
-  = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc,
-              pp_cSEP, ptext SLIT("upd")]
-
-pprCLbl (TyConLabel tc (VecConUpdCode tag))
-  = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc, pp_cSEP,
-                    int tag, pp_cSEP, ptext SLIT("upd")]
-
-pprCLbl (TyConLabel tc (StdUpdCode tag))
-  = case (ctrlReturnConvAlg tc) of
-       UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir")
-       VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG))
-
-pprCLbl (TyConLabel tc InfoTblVecTbl)
-  = hcat [ppr_tycon tc, pp_cSEP, ptext SLIT("itblvtbl")]
-
-pprCLbl (TyConLabel tc StdUpdVecTbl)
-  = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon tc,
-              pp_cSEP, ptext SLIT("upd")]
-
 pprCLbl (CaseLabel u CaseReturnPt)
-  = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
+  = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
+pprCLbl (CaseLabel u CaseReturnInfo)
+  = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
 pprCLbl (CaseLabel u CaseVecTbl)
-  = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u]
+  = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
 pprCLbl (CaseLabel u (CaseAlt tag))
-  = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
+  = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
 pprCLbl (CaseLabel u CaseDefault)
-  = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
+  = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
+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("StdErrorCode")
+pprCLbl (RtsLabel RtsUpdEntry) = ptext SLIT("Upd_frame_entry")
 
-pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
+pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BLACKHOLE_info")
 
 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
-  = hcat [ptext SLIT("__sel_info_"), text (show offset),
-               ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
-               ptext SLIT("__")]
+  = hcat [ptext SLIT("__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_entry_"), text (show offset),
-               ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
-               ptext SLIT("__")]
-
-pprCLbl (IdLabel (CLabelId id) flavor)
-  = ppr id <> ppFlavor flavor
-
-
-ppr_u u = pprUnique u
-
-ppr_tycon :: TyCon -> SDoc
-ppr_tycon tc = ppr tc
-{- 
-  = let
-       str = showTyCon tc
-    in
-    --pprTrace "ppr_tycon:" (text str) $
-    text str
--}
-
-ppFlavor :: IdLabelInfo -> SDoc
-
-ppFlavor x = (<>) pp_cSEP
-                     (case x of
+  = hcat [ptext SLIT("__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),
+               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),
+               ptext (if upd_reqd 
+                       then SLIT("_upd_entry") 
+                       else SLIT("_noupd_entry"))
+       ]
+
+pprCLbl (RtsLabel (RtsPrimOp primop)) 
+  = pprPrimOp primop <> ptext SLIT("_fast")
+
+pprCLbl (TyConLabel tc)
+  = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
+
+pprCLbl (IdLabel      id  flavor) = ppr id <> ppIdFlavor flavor
+pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
+
+pprCLbl (CC_Label cc)          = ppr cc
+pprCLbl (CCS_Label ccs)        = ppr ccs
+
+ppIdFlavor :: IdLabelInfo -> SDoc
+
+ppIdFlavor x = pp_cSEP <>
+              (case x of
                       Closure          -> ptext SLIT("closure")
+                      SRT              -> ptext SLIT("srt")
                       InfoTbl          -> ptext SLIT("info")
                       EntryStd         -> ptext SLIT("entry")
                       EntryFast arity  -> --false:ASSERT (arity > 0)
                                           (<>) (ptext SLIT("fast")) (int arity)
+                      RednCounts       -> ptext SLIT("ct")
+                     )
+
+ppConFlavor x = pp_cSEP <>
+               (case x of
                       StaticClosure    -> ptext SLIT("static_closure")
                       ConEntry         -> ptext SLIT("con_entry")
                       ConInfoTbl       -> ptext SLIT("con_info")
                       StaticConEntry   -> ptext SLIT("static_entry")
                       StaticInfoTbl    -> ptext SLIT("static_info")
-                      PhantomInfoTbl   -> ptext SLIT("inregs_info")
-                      VapInfoTbl True  -> ptext SLIT("vap_info")
-                      VapInfoTbl False -> ptext SLIT("vap_noupd_info")
-                      VapEntry True    -> ptext SLIT("vap_entry")
-                      VapEntry False   -> ptext SLIT("vap_noupd_entry")
-                      RednCounts       -> ptext SLIT("ct")
-                     )
+               )
 \end{code}
+