\section[CLabel]{@CLabel@: Information to make C Labels}
\begin{code}
-#include "HsVersions.h"
-
module CLabel (
CLabel, -- abstract type
#endif
) where
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(AbsCLoop) ( CtrlReturnConvention(..),
- ctrlReturnConvAlg
- )
+
+#include "HsVersions.h"
+
#if ! OMIT_NATIVE_CODEGEN
-IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl )
+import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
#endif
+import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
import CStrings ( pp_cSEP )
-import Id ( externallyVisibleId, cmpId_withSpecDataCon,
- isDataCon, isDictFunId,
- isConstMethodId_maybe,
- isDefaultMethodId_maybe,
- isSuperDictSelId_maybe, fIRST_TAG,
- SYN_IE(ConTag), GenId{-instance Outputable-}
+import Id ( externallyVisibleId,
+ isDataCon,
+ fIRST_TAG,
+ ConTag,
+ Id
)
import Maybes ( maybeToBool )
-import PprStyle ( PprStyle(..) )
-import PprType ( showTyCon, GenType{-instance Outputable-} )
-import Pretty ( prettyToUn{-, ppPStr ToDo:rm-} )
-import TyCon ( TyCon{-instance Eq-} )
-import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
-import Unpretty -- NOTE!! ********************
+import PprType ( showTyCon )
+import TyCon ( TyCon )
+import Unique ( showUnique, pprUnique, Unique )
import Util ( assertPanic{-, pprTraceToDo:rm-} )
+import Outputable
\end{code}
things we want to find out:
\begin{code}
data CLabelId = CLabelId Id
-instance Ord3 CLabelId where
- cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
-
instance Eq CLabelId where
- CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
- CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+ 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 `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
- CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
- CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
- CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ 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
\end{code}
\begin{code}
\end{code}
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.
+
\begin{code}
externallyVisibleCLabel (TyConLabel tc _) = True
externallyVisibleCLabel (CaseLabel _ _) = False
externallyVisibleCLabel (AsmTempLabel _) = False
externallyVisibleCLabel (RtsLabel _) = True
-externallyVisibleCLabel (IdLabel (CLabelId id) _)
- | isDataCon id = True
- | is_ConstMethodId id = True -- These are here to ensure splitting works
- | isDictFunId id = True -- when these values have not been exported
- | is_DefaultMethodId id = True
- | is_SuperDictSelId id = True
- | otherwise = externallyVisibleId id
- where
- is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id)
- is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
- is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id)
+externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
\end{code}
OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
\begin{code}
-- specialised for PprAsm: saves lots of arg passing in NCG
#if ! OMIT_NATIVE_CODEGEN
-pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
+pprCLabel_asm = pprCLabel
#endif
-pprCLabel :: PprStyle -> CLabel -> Unpretty
+pprCLabel :: CLabel -> SDoc
-pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
- = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
+#if ! OMIT_NATIVE_CODEGEN
+pprCLabel (AsmTempLabel u)
+ = text (fmtAsmLbl (showUnique u))
+#endif
+
+pprCLabel lbl =
+#if ! OMIT_NATIVE_CODEGEN
+ getPprStyle $ \ sty ->
+ if asmStyle sty && underscorePrefix then
+ pp_cSEP <> pprCLbl lbl
+ else
+#endif
+ pprCLbl lbl
-pprCLabel (PprForAsm prepend_cSEP _) lbl
- = if prepend_cSEP
- then uppBeside pp_cSEP prLbl
- else prLbl
- where
- prLbl = pprCLabel PprForC lbl
-pprCLabel sty (TyConLabel tc UnvecConUpdCode)
- = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
- pp_cSEP, uppPStr SLIT("upd")]
+pprCLbl (TyConLabel tc UnvecConUpdCode)
+ = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc,
+ pp_cSEP, ptext SLIT("upd")]
-pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
- = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
- uppInt tag, pp_cSEP, uppPStr 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")]
-pprCLabel sty (TyConLabel tc (StdUpdCode tag))
+pprCLbl (TyConLabel tc (StdUpdCode tag))
= case (ctrlReturnConvAlg tc) of
- UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
- VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
+ 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")]
-pprCLabel sty (TyConLabel tc InfoTblVecTbl)
- = uppBesides [ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("itblvtbl")]
+pprCLbl (TyConLabel tc StdUpdVecTbl)
+ = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon tc,
+ pp_cSEP, ptext SLIT("upd")]
-pprCLabel sty (TyConLabel tc StdUpdVecTbl)
- = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
- pp_cSEP, uppPStr SLIT("upd")]
+pprCLbl (CaseLabel u CaseReturnPt)
+ = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
+pprCLbl (CaseLabel u CaseVecTbl)
+ = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u]
+pprCLbl (CaseLabel u (CaseAlt tag))
+ = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
+pprCLbl (CaseLabel u CaseDefault)
+ = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
-pprCLabel sty (CaseLabel u CaseReturnPt)
- = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
-pprCLabel sty (CaseLabel u CaseVecTbl)
- = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
-pprCLabel sty (CaseLabel u (CaseAlt tag))
- = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
-pprCLabel sty (CaseLabel u CaseDefault)
- = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
+pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
-pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
+pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
-pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_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("__")]
-pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
- = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
- uppStr (if upd_reqd then "upd" else "noupd"),
- uppPStr SLIT("__")]
+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("__")]
-pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
- = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
- uppStr (if upd_reqd then "upd" else "noupd"),
- uppPStr SLIT("__")]
+pprCLbl (IdLabel (CLabelId id) flavor)
+ = ppr id <> ppFlavor flavor
-pprCLabel sty (IdLabel (CLabelId id) flavor)
- = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
-ppr_u u = prettyToUn (pprUnique u)
+ppr_u u = pprUnique u
-ppr_tycon sty tc
+ppr_tycon :: TyCon -> SDoc
+ppr_tycon tc = ppr tc
+{-
= let
- str = showTyCon sty tc
+ str = showTyCon tc
in
- --pprTrace "ppr_tycon:" (ppStr str) $
- uppStr str
+ --pprTrace "ppr_tycon:" (text str) $
+ text str
+-}
-ppFlavor :: IdLabelInfo -> Unpretty
+ppFlavor :: IdLabelInfo -> SDoc
-ppFlavor x = uppBeside pp_cSEP
+ppFlavor x = (<>) pp_cSEP
(case x of
- Closure -> uppPStr SLIT("closure")
- InfoTbl -> uppPStr SLIT("info")
- EntryStd -> uppPStr SLIT("entry")
+ Closure -> ptext SLIT("closure")
+ InfoTbl -> ptext SLIT("info")
+ EntryStd -> ptext SLIT("entry")
EntryFast arity -> --false:ASSERT (arity > 0)
- uppBeside (uppPStr SLIT("fast")) (uppInt arity)
- StaticClosure -> uppPStr SLIT("static_closure")
- ConEntry -> uppPStr SLIT("con_entry")
- ConInfoTbl -> uppPStr SLIT("con_info")
- StaticConEntry -> uppPStr SLIT("static_entry")
- StaticInfoTbl -> uppPStr SLIT("static_info")
- PhantomInfoTbl -> uppPStr SLIT("inregs_info")
- VapInfoTbl True -> uppPStr SLIT("vap_info")
- VapInfoTbl False -> uppPStr SLIT("vap_noupd_info")
- VapEntry True -> uppPStr SLIT("vap_entry")
- VapEntry False -> uppPStr SLIT("vap_noupd_entry")
- RednCounts -> uppPStr SLIT("ct")
+ (<>) (ptext SLIT("fast")) (int arity)
+ 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}
projects / ghc-hetmet.git / blobdiff