2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[CLabel]{@CLabel@: Information to make C Labels}
7 #include "HsVersions.h"
10 CLabel, -- abstract type
17 mkStaticConEntryLabel,
20 mkPhantomInfoTableLabel,
22 mkStaticInfoTableLabel,
26 mkConUpdCodePtrVecLabel,
27 mkStdUpdCodePtrVecLabel,
29 mkInfoTableVecTblLabel,
40 mkBlackHoleInfoTableLabel,
42 needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
45 #if ! OMIT_NATIVE_CODEGEN
51 IMPORT_DELOOPER(AbsCLoop) ( CtrlReturnConvention(..),
54 #if ! OMIT_NATIVE_CODEGEN
55 IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl )
58 import CStrings ( pp_cSEP )
59 import Id ( externallyVisibleId, cmpId_withSpecDataCon,
60 isDataCon, isDictFunId,
61 isConstMethodId_maybe,
62 isDefaultMethodId_maybe,
63 isSuperDictSelId_maybe, fIRST_TAG,
64 SYN_IE(ConTag), GenId{-instance Outputable-},
67 import Maybes ( maybeToBool )
68 import PprStyle ( PprStyle(..) )
69 import PprType ( showTyCon, GenType{-instance Outputable-} )
70 import TyCon ( TyCon{-instance Eq-} )
71 import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
73 import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) )
74 #if __GLASGOW_HASKELL__ >= 202
75 import Outputable ( Outputable(..) )
80 things we want to find out:
82 * should the labelled things be declared "static" (visible only in this file)?
84 * should it be declared "const" (read-only text space)?
86 * does it need declarations at all? (v common Prelude things are pre-declared)
90 = IdLabel -- A family of labels related to the
91 CLabelId -- definition of a particular Id
92 IdLabelInfo -- Includes DataCon
94 | TyConLabel -- A family of labels related to the
95 TyCon -- definition of a data type
98 | CaseLabel -- A family of labels related to a particular case expression
99 Unique -- Unique says which case expression
102 | AsmTempLabel Unique
104 | RtsLabel RtsLabelInfo
109 The CLabelId is simply so we can declare alternative Eq and Ord
110 instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
111 comparing the Uniques of two specialised data constructors (which have
112 the same as the uniques their respective unspecialised data
113 constructors). Instead, the specialising types and the uniques of the
114 unspecialised constructors are compared.
117 data CLabelId = CLabelId Id
119 instance Ord3 CLabelId where
120 cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
122 instance Eq CLabelId where
123 CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
124 CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
126 instance Ord CLabelId where
127 CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
128 CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
129 CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
130 CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
131 _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
136 = Closure -- Label for (static???) closure
137 | StaticClosure -- Static closure -- e.g., nullary constructor
139 | InfoTbl -- Info table for a closure; always read-only
141 | EntryStd -- Thunk, or "slow", code entry point (requires arg satis check)
142 | EntryFast Int -- entry pt when no arg satisfaction chk needed;
143 -- Int is the arity of the function (to be
144 -- encoded into the name)
146 | ConEntry -- the only kind of entry pt for constructors
147 | ConInfoTbl -- corresponding info table
149 | StaticConEntry -- static constructor entry point
150 | StaticInfoTbl -- corresponding info table
152 | PhantomInfoTbl -- for phantom constructors that only exist in regs
154 | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
157 -- Ticky-ticky counting
158 | RednCounts -- Label of place to keep reduction-count info for this Id
163 = UnvecConUpdCode -- Update code for the data type if it's unvectored
165 | VecConUpdCode ConTag -- One for each constructor which returns in
166 -- regs; this code actually performs an update
168 | StdUpdCode ConTag -- Update code for all constructors which return
169 -- in heap. There are a small number of variants,
170 -- so that the update code returns (vectored/n or
171 -- unvectored) in the right way.
172 -- ToDo: maybe replace TyCon/Int with return conv.
174 | InfoTblVecTbl -- For tables of info tables
176 | StdUpdVecTbl -- Labels the update code, or table of update codes,
177 -- for a particular type.
188 = RtsShouldNeverHappenCode
190 | RtsBlackHoleInfoTbl
192 | RtsSelectorInfoTbl -- Selectors
193 Bool -- True <=> the update-reqd version;
194 -- False <=> the no-update-reqd version
195 Int -- 0-indexed Offset from the "goods"
197 | RtsSelectorEntry -- Ditto entry code
204 mkClosureLabel id = IdLabel (CLabelId id) Closure
205 mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
206 mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
207 mkFastEntryLabel id arity = ASSERT(arity > 0)
208 IdLabel (CLabelId id) (EntryFast arity)
210 mkStaticClosureLabel con = ASSERT(isDataCon con)
211 IdLabel (CLabelId con) StaticClosure
212 mkStaticInfoTableLabel con = ASSERT(isDataCon con)
213 IdLabel (CLabelId con) StaticInfoTbl
214 mkConInfoTableLabel con = ASSERT(isDataCon con)
215 IdLabel (CLabelId con) ConInfoTbl
216 mkPhantomInfoTableLabel con = ASSERT(isDataCon con)
217 IdLabel (CLabelId con) PhantomInfoTbl
218 mkConEntryLabel con = ASSERT(isDataCon con)
219 IdLabel (CLabelId con) ConEntry
220 mkStaticConEntryLabel con = ASSERT(isDataCon con)
221 IdLabel (CLabelId con) StaticConEntry
223 mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
224 mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
225 mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
227 mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
228 mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
230 mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl
231 mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl
233 mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
234 mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
235 mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
236 mkDefaultLabel uniq = CaseLabel uniq CaseDefault
238 mkAsmTempLabel = AsmTempLabel
240 -- Some fixed runtime system labels
242 mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
243 mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
247 needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother
248 isReadOnly :: CLabel -> Bool -- lives in C "text space"
249 isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
250 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
253 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
254 object. {\em Also:} No need to spit out labels for things generated
255 by the flattener (in @AbsCUtils@)---it is careful to ensure references
256 to them are always backwards. These are return-point and vector-table
259 Declarations for (non-prelude) @Id@-based things are needed because of
262 needsCDecl (IdLabel _ _) = True
263 needsCDecl (CaseLabel _ _) = False
265 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
266 needsCDecl (TyConLabel _ InfoTblVecTbl) = False
267 needsCDecl (TyConLabel _ other) = True
269 needsCDecl (AsmTempLabel _) = False
270 needsCDecl (RtsLabel _) = False
272 needsCDecl other = True
275 Whether the labelled thing can be put in C "text space":
277 isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
278 isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other
279 isReadOnly (IdLabel _ StaticInfoTbl) = True
280 isReadOnly (IdLabel _ PhantomInfoTbl) = True
281 isReadOnly (IdLabel _ (VapInfoTbl _)) = True
282 isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
284 isReadOnly (TyConLabel _ _) = True
285 isReadOnly (CaseLabel _ _) = True
286 isReadOnly (AsmTempLabel _) = True
287 isReadOnly (RtsLabel _) = True
290 Whether the label is an assembler temporary:
292 isAsmTemp (AsmTempLabel _) = True
296 C ``static'' or not...
297 From the point of view of the code generator, a name is
298 externally visible if it should be given put in the .o file's
299 symbol table; that is, made static.
302 externallyVisibleCLabel (TyConLabel tc _) = True
303 externallyVisibleCLabel (CaseLabel _ _) = False
304 externallyVisibleCLabel (AsmTempLabel _) = False
305 externallyVisibleCLabel (RtsLabel _) = True
306 externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
309 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
310 right places. It is used to detect when the abstractC statement of an
311 CCodeBlock actually contains the code for a slow entry point. -- HWL
313 We need at least @Eq@ for @CLabels@, because we want to avoid
314 duplicate declarations in generating C (see @labelSeenTE@ in
318 -- specialised for PprAsm: saves lots of arg passing in NCG
319 #if ! OMIT_NATIVE_CODEGEN
320 pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
323 pprCLabel :: PprStyle -> CLabel -> Doc
325 pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
326 = text (fmtAsmLbl (_UNPK_ (showUnique u)))
328 pprCLabel (PprForAsm prepend_cSEP _) lbl
330 then (<>) pp_cSEP prLbl
333 prLbl = pprCLabel PprForC lbl
335 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
336 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
337 pp_cSEP, ptext SLIT("upd")]
339 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
340 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
341 int tag, pp_cSEP, ptext SLIT("upd")]
343 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
344 = case (ctrlReturnConvAlg tc) of
345 UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir")
346 VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG))
348 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
349 = hcat [ppr_tycon sty tc, pp_cSEP, ptext SLIT("itblvtbl")]
351 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
352 = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
353 pp_cSEP, ptext SLIT("upd")]
355 pprCLabel sty (CaseLabel u CaseReturnPt)
356 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
357 pprCLabel sty (CaseLabel u CaseVecTbl)
358 = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u]
359 pprCLabel sty (CaseLabel u (CaseAlt tag))
360 = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
361 pprCLabel sty (CaseLabel u CaseDefault)
362 = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
364 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
366 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
368 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
369 = hcat [ptext SLIT("__sel_info_"), text (show offset),
370 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
373 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
374 = hcat [ptext SLIT("__sel_entry_"), text (show offset),
375 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
378 pprCLabel sty (IdLabel (CLabelId id) flavor)
379 = (<>) (ppr sty id) (ppFlavor flavor)
381 ppr_u u = pprUnique u
385 str = showTyCon sty tc
387 --pprTrace "ppr_tycon:" (text str) $
390 ppFlavor :: IdLabelInfo -> Doc
392 ppFlavor x = (<>) pp_cSEP
394 Closure -> ptext SLIT("closure")
395 InfoTbl -> ptext SLIT("info")
396 EntryStd -> ptext SLIT("entry")
397 EntryFast arity -> --false:ASSERT (arity > 0)
398 (<>) (ptext SLIT("fast")) (int arity)
399 StaticClosure -> ptext SLIT("static_closure")
400 ConEntry -> ptext SLIT("con_entry")
401 ConInfoTbl -> ptext SLIT("con_info")
402 StaticConEntry -> ptext SLIT("static_entry")
403 StaticInfoTbl -> ptext SLIT("static_info")
404 PhantomInfoTbl -> ptext SLIT("inregs_info")
405 VapInfoTbl True -> ptext SLIT("vap_info")
406 VapInfoTbl False -> ptext SLIT("vap_noupd_info")
407 VapEntry True -> ptext SLIT("vap_entry")
408 VapEntry False -> ptext SLIT("vap_noupd_entry")
409 RednCounts -> ptext SLIT("ct")