mkConEntryLabel,
mkStaticConEntryLabel,
mkRednCountsLabel,
+ mkConInfoTableLabel,
mkPhantomInfoTableLabel,
+ mkStaticClosureLabel,
mkStaticInfoTableLabel,
mkVapEntryLabel,
mkVapInfoTableLabel,
needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
- pprCLabel, pprCLabel_asm
-
-#ifdef GRAN
- , isSlowEntryCCodeBlock
+ pprCLabel
+#if ! OMIT_NATIVE_CODEGEN
+ , pprCLabel_asm
#endif
) where
-import Ubiq{-uitous-}
-import AbsCLoop ( CtrlReturnConvention(..),
- ctrlReturnConvAlg
- )
-import NcgLoop ( underscorePrefix, fmtAsmLbl )
+IMP_Ubiq(){-uitous-}
+
+
+#if ! OMIT_NATIVE_CODEGEN
+# if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
+IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl )
+# else
+import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
+# endif
+#endif
+import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
import CStrings ( pp_cSEP )
import Id ( externallyVisibleId, cmpId_withSpecDataCon,
isDataCon, isDictFunId,
- isConstMethodId_maybe,
isDefaultMethodId_maybe,
isSuperDictSelId_maybe, fIRST_TAG,
- ConTag(..), GenId{-instance Outputable-}
+ SYN_IE(ConTag), GenId{-instance Outputable-},
+ SYN_IE(Id)
)
import Maybes ( maybeToBool )
-import PprStyle ( PprStyle(..) )
+import Outputable ( Outputable(..), PprStyle(..) )
import PprType ( showTyCon, GenType{-instance Outputable-} )
-import Pretty ( prettyToUn )
import TyCon ( TyCon{-instance Eq-} )
import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
-import Unpretty -- NOTE!! ********************
-import Util ( assertPanic )
+import Pretty
+import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) )
\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 cmpId_withSpecDataCon a b of { EQ_ -> True; _ -> False }
- CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True }
+ CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord CLabelId where
- CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> True; EQ_ -> True; GT__ -> False }
- CLabelId a < CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> True; EQ_ -> False; GT__ -> False }
- CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> False; EQ_ -> True; GT__ -> True }
- CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b
- of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ 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 }
\end{code}
\begin{code}
data IdLabelInfo
= Closure -- Label for (static???) closure
+ | StaticClosure -- Static closure -- e.g., nullary constructor
| InfoTbl -- Info table for a closure; always read-only
-- encoded into the name)
| ConEntry -- the only kind of entry pt for constructors
- | StaticConEntry -- static constructor entry point
+ | ConInfoTbl -- corresponding info table
+ | 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
+ | VapEntry Bool
-- Ticky-ticky counting
| RednCounts -- Label of place to keep reduction-count info for this Id
\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 (CLabelId id) Closure
+mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
+mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
mkFastEntryLabel id arity = ASSERT(arity > 0)
- IdLabel (CLabelId id) (EntryFast arity)
-mkConEntryLabel id = IdLabel (CLabelId id) ConEntry
-mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry
-mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
-mkPhantomInfoTableLabel id = IdLabel (CLabelId id) PhantomInfoTbl
-mkStaticInfoTableLabel id = IdLabel (CLabelId id) StaticInfoTbl
-mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
-mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
+ 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)
Whether the labelled thing can be put in C "text space":
\begin{code}
-isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
-isReadOnly (IdLabel _ StaticInfoTbl) = True -- and so on, for other
-isReadOnly (IdLabel _ PhantomInfoTbl) = True
-isReadOnly (IdLabel _ (VapInfoTbl _)) = True
-isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
+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
\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}
-These GRAN functions are needed for spitting out GRAN_FETCH() at the
+OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
right places. It is used to detect when the abstractC statement of an
CCodeBlock actually contains the code for a slow entry point. -- HWL
-\begin{code}
-#ifdef GRAN
-
-isSlowEntryCCodeBlock :: CLabel -> Bool
-isSlowEntryCCodeBlock _ = False
--- Worth keeping? ToDo (WDP)
-
-#endif {-GRAN-}
-\end{code}
-
We need at least @Eq@ for @CLabels@, because we want to avoid
duplicate declarations in generating C (see @labelSeenTE@ in
@PprAbsC@).
\begin{code}
-- specialised for PprAsm: saves lots of arg passing in NCG
+#if ! OMIT_NATIVE_CODEGEN
pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
+#endif
-pprCLabel :: PprStyle -> CLabel -> Unpretty
+pprCLabel :: PprStyle -> CLabel -> Doc
pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
- = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
+ = text (fmtAsmLbl (showUnique u))
pprCLabel (PprForAsm prepend_cSEP _) lbl
= if prepend_cSEP
- then uppBeside pp_cSEP prLbl
+ then (<>) pp_cSEP prLbl
else prLbl
where
prLbl = pprCLabel PprForC lbl
pprCLabel sty (TyConLabel tc UnvecConUpdCode)
- = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
- pp_cSEP, uppPStr SLIT("upd")]
+ = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
+ pp_cSEP, ptext SLIT("upd")]
pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
- = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP,
- uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
+ = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
+ int tag, pp_cSEP, ptext SLIT("upd")]
pprCLabel sty (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))
pprCLabel sty (TyConLabel tc InfoTblVecTbl)
- = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
+ = hcat [ppr_tycon sty tc, pp_cSEP, ptext SLIT("itblvtbl")]
pprCLabel sty (TyConLabel tc StdUpdVecTbl)
- = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
- pp_cSEP, uppPStr SLIT("upd")]
+ = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
+ pp_cSEP, ptext SLIT("upd")]
pprCLabel sty (CaseLabel u CaseReturnPt)
- = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
+ = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
pprCLabel sty (CaseLabel u CaseVecTbl)
- = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
+ = hcat [ptext 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]
+ = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
pprCLabel sty (CaseLabel u CaseDefault)
- = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
+ = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
-pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
+pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
-pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
+pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
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("__")]
+ = hcat [ptext SLIT("__sel_info_"), 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("__")]
+ = hcat [ptext SLIT("__sel_entry_"), text (show offset),
+ ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
+ ptext SLIT("__")]
pprCLabel sty (IdLabel (CLabelId id) flavor)
- = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
+ = (<>) (ppr sty id) (ppFlavor flavor)
+
+ppr_u u = pprUnique u
-ppr_u u = prettyToUn (pprUnique u)
+ppr_tycon sty tc
+ = let
+ str = showTyCon sty tc
+ in
+ --pprTrace "ppr_tycon:" (text str) $
+ text str
-ppFlavor :: IdLabelInfo -> Unpretty
+ppFlavor :: IdLabelInfo -> Doc
-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)
- ConEntry -> uppPStr SLIT("entry")
- 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}