2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[CLabel]{@CLabel@: Information to make C Labels}
8 CLabel, -- abstract type
15 mkStaticConEntryLabel,
18 mkPhantomInfoTableLabel,
20 mkStaticInfoTableLabel,
24 mkConUpdCodePtrVecLabel,
25 mkStdUpdCodePtrVecLabel,
27 mkInfoTableVecTblLabel,
38 mkBlackHoleInfoTableLabel,
40 needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
43 #if ! OMIT_NATIVE_CODEGEN
49 #include "HsVersions.h"
51 #if ! OMIT_NATIVE_CODEGEN
52 import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
55 import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
56 import CStrings ( pp_cSEP )
57 import Id ( externallyVisibleId, cmpId_withSpecDataCon,
58 isDataCon, isDictFunId,
59 isDefaultMethodId_maybe,
64 import Maybes ( maybeToBool )
65 import PprType ( showTyCon, GenType{-instance Outputable-} )
66 import TyCon ( TyCon{-instance Eq-} )
67 import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
68 import Util ( assertPanic{-, pprTraceToDo:rm-} )
72 things we want to find out:
74 * should the labelled things be declared "static" (visible only in this file)?
76 * should it be declared "const" (read-only text space)?
78 * does it need declarations at all? (v common Prelude things are pre-declared)
82 = IdLabel -- A family of labels related to the
83 CLabelId -- definition of a particular Id
84 IdLabelInfo -- Includes DataCon
86 | TyConLabel -- A family of labels related to the
87 TyCon -- definition of a data type
90 | CaseLabel -- A family of labels related to a particular case expression
91 Unique -- Unique says which case expression
96 | RtsLabel RtsLabelInfo
101 The CLabelId is simply so we can declare alternative Eq and Ord
102 instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
103 comparing the Uniques of two specialised data constructors (which have
104 the same as the uniques their respective unspecialised data
105 constructors). Instead, the specialising types and the uniques of the
106 unspecialised constructors are compared.
109 data CLabelId = CLabelId Id
111 instance Eq CLabelId where
112 CLabelId a == CLabelId b = case (a `compare` b) of { EQ -> True; _ -> False }
113 CLabelId a /= CLabelId b = case (a `compare` b) of { EQ -> False; _ -> True }
115 instance Ord CLabelId where
116 CLabelId a <= CLabelId b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
117 CLabelId a < CLabelId b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
118 CLabelId a >= CLabelId b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
119 CLabelId a > CLabelId b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
120 compare (CLabelId a) (CLabelId b) = a `cmpId_withSpecDataCon` b
125 = Closure -- Label for (static???) closure
126 | StaticClosure -- Static closure -- e.g., nullary constructor
128 | InfoTbl -- Info table for a closure; always read-only
130 | EntryStd -- Thunk, or "slow", code entry point (requires arg satis check)
131 | EntryFast Int -- entry pt when no arg satisfaction chk needed;
132 -- Int is the arity of the function (to be
133 -- encoded into the name)
135 | ConEntry -- the only kind of entry pt for constructors
136 | ConInfoTbl -- corresponding info table
138 | StaticConEntry -- static constructor entry point
139 | StaticInfoTbl -- corresponding info table
141 | PhantomInfoTbl -- for phantom constructors that only exist in regs
143 | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
146 -- Ticky-ticky counting
147 | RednCounts -- Label of place to keep reduction-count info for this Id
152 = UnvecConUpdCode -- Update code for the data type if it's unvectored
154 | VecConUpdCode ConTag -- One for each constructor which returns in
155 -- regs; this code actually performs an update
157 | StdUpdCode ConTag -- Update code for all constructors which return
158 -- in heap. There are a small number of variants,
159 -- so that the update code returns (vectored/n or
160 -- unvectored) in the right way.
161 -- ToDo: maybe replace TyCon/Int with return conv.
163 | InfoTblVecTbl -- For tables of info tables
165 | StdUpdVecTbl -- Labels the update code, or table of update codes,
166 -- for a particular type.
177 = RtsShouldNeverHappenCode
179 | RtsBlackHoleInfoTbl
181 | RtsSelectorInfoTbl -- Selectors
182 Bool -- True <=> the update-reqd version;
183 -- False <=> the no-update-reqd version
184 Int -- 0-indexed Offset from the "goods"
186 | RtsSelectorEntry -- Ditto entry code
193 mkClosureLabel id = IdLabel (CLabelId id) Closure
194 mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
195 mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
196 mkFastEntryLabel id arity = ASSERT(arity > 0)
197 IdLabel (CLabelId id) (EntryFast arity)
199 mkStaticClosureLabel con = ASSERT(isDataCon con)
200 IdLabel (CLabelId con) StaticClosure
201 mkStaticInfoTableLabel con = ASSERT(isDataCon con)
202 IdLabel (CLabelId con) StaticInfoTbl
203 mkConInfoTableLabel con = ASSERT(isDataCon con)
204 IdLabel (CLabelId con) ConInfoTbl
205 mkPhantomInfoTableLabel con = ASSERT(isDataCon con)
206 IdLabel (CLabelId con) PhantomInfoTbl
207 mkConEntryLabel con = ASSERT(isDataCon con)
208 IdLabel (CLabelId con) ConEntry
209 mkStaticConEntryLabel con = ASSERT(isDataCon con)
210 IdLabel (CLabelId con) StaticConEntry
212 mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
213 mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
214 mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
216 mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
217 mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
219 mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl
220 mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl
222 mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
223 mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
224 mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
225 mkDefaultLabel uniq = CaseLabel uniq CaseDefault
227 mkAsmTempLabel = AsmTempLabel
229 -- Some fixed runtime system labels
231 mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
232 mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
236 needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother
237 isReadOnly :: CLabel -> Bool -- lives in C "text space"
238 isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
239 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
242 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
243 object. {\em Also:} No need to spit out labels for things generated
244 by the flattener (in @AbsCUtils@)---it is careful to ensure references
245 to them are always backwards. These are return-point and vector-table
248 Declarations for (non-prelude) @Id@-based things are needed because of
251 needsCDecl (IdLabel _ _) = True
252 needsCDecl (CaseLabel _ _) = False
254 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
255 needsCDecl (TyConLabel _ InfoTblVecTbl) = False
256 needsCDecl (TyConLabel _ other) = True
258 needsCDecl (AsmTempLabel _) = False
259 needsCDecl (RtsLabel _) = False
261 needsCDecl other = True
264 Whether the labelled thing can be put in C "text space":
266 isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
267 isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other
268 isReadOnly (IdLabel _ StaticInfoTbl) = True
269 isReadOnly (IdLabel _ PhantomInfoTbl) = True
270 isReadOnly (IdLabel _ (VapInfoTbl _)) = True
271 isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
273 isReadOnly (TyConLabel _ _) = True
274 isReadOnly (CaseLabel _ _) = True
275 isReadOnly (AsmTempLabel _) = True
276 isReadOnly (RtsLabel _) = True
279 Whether the label is an assembler temporary:
281 isAsmTemp (AsmTempLabel _) = True
285 C ``static'' or not...
286 From the point of view of the code generator, a name is
287 externally visible if it should be given put in the .o file's
288 symbol table; that is, made static.
291 externallyVisibleCLabel (TyConLabel tc _) = True
292 externallyVisibleCLabel (CaseLabel _ _) = False
293 externallyVisibleCLabel (AsmTempLabel _) = False
294 externallyVisibleCLabel (RtsLabel _) = True
295 externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
298 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
299 right places. It is used to detect when the abstractC statement of an
300 CCodeBlock actually contains the code for a slow entry point. -- HWL
302 We need at least @Eq@ for @CLabels@, because we want to avoid
303 duplicate declarations in generating C (see @labelSeenTE@ in
307 -- specialised for PprAsm: saves lots of arg passing in NCG
308 #if ! OMIT_NATIVE_CODEGEN
309 pprCLabel_asm = pprCLabel
312 pprCLabel :: CLabel -> SDoc
314 #if ! OMIT_NATIVE_CODEGEN
315 pprCLabel (AsmTempLabel u)
316 = text (fmtAsmLbl (showUnique u))
320 #if ! OMIT_NATIVE_CODEGEN
321 getPprStyle $ \ sty ->
322 if asmStyle sty && underscorePrefix then
323 pp_cSEP <> pprCLbl lbl
329 pprCLbl (TyConLabel tc UnvecConUpdCode)
330 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc,
331 pp_cSEP, ptext SLIT("upd")]
333 pprCLbl (TyConLabel tc (VecConUpdCode tag))
334 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc, pp_cSEP,
335 int tag, pp_cSEP, ptext SLIT("upd")]
337 pprCLbl (TyConLabel tc (StdUpdCode tag))
338 = case (ctrlReturnConvAlg tc) of
339 UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir")
340 VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG))
342 pprCLbl (TyConLabel tc InfoTblVecTbl)
343 = hcat [ppr_tycon tc, pp_cSEP, ptext SLIT("itblvtbl")]
345 pprCLbl (TyConLabel tc StdUpdVecTbl)
346 = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon tc,
347 pp_cSEP, ptext SLIT("upd")]
349 pprCLbl (CaseLabel u CaseReturnPt)
350 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
351 pprCLbl (CaseLabel u CaseVecTbl)
352 = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u]
353 pprCLbl (CaseLabel u (CaseAlt tag))
354 = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
355 pprCLbl (CaseLabel u CaseDefault)
356 = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
358 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
360 pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
362 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
363 = hcat [ptext SLIT("__sel_info_"), text (show offset),
364 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
367 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
368 = hcat [ptext SLIT("__sel_entry_"), text (show offset),
369 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
372 pprCLbl (IdLabel (CLabelId id) flavor)
373 = ppr id <> ppFlavor flavor
376 ppr_u u = pprUnique u
378 ppr_tycon :: TyCon -> SDoc
379 ppr_tycon tc = ppr tc
384 --pprTrace "ppr_tycon:" (text str) $
388 ppFlavor :: IdLabelInfo -> SDoc
390 ppFlavor x = (<>) pp_cSEP
392 Closure -> ptext SLIT("closure")
393 InfoTbl -> ptext SLIT("info")
394 EntryStd -> ptext SLIT("entry")
395 EntryFast arity -> --false:ASSERT (arity > 0)
396 (<>) (ptext SLIT("fast")) (int arity)
397 StaticClosure -> ptext SLIT("static_closure")
398 ConEntry -> ptext SLIT("con_entry")
399 ConInfoTbl -> ptext SLIT("con_info")
400 StaticConEntry -> ptext SLIT("static_entry")
401 StaticInfoTbl -> ptext SLIT("static_info")
402 PhantomInfoTbl -> ptext SLIT("inregs_info")
403 VapInfoTbl True -> ptext SLIT("vap_info")
404 VapInfoTbl False -> ptext SLIT("vap_noupd_info")
405 VapEntry True -> ptext SLIT("vap_entry")
406 VapEntry False -> ptext SLIT("vap_noupd_entry")
407 RednCounts -> ptext SLIT("ct")