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-}
66 import Maybes ( maybeToBool )
67 import PprStyle ( PprStyle(..) )
68 import PprType ( showTyCon, GenType{-instance Outputable-} )
69 import Pretty ( prettyToUn{-, ppPStr ToDo:rm-} )
70 import TyCon ( TyCon{-instance Eq-} )
71 import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
72 import Unpretty -- NOTE!! ********************
73 import Util ( assertPanic{-, pprTraceToDo:rm-} )
76 things we want to find out:
78 * should the labelled things be declared "static" (visible only in this file)?
80 * should it be declared "const" (read-only text space)?
82 * does it need declarations at all? (v common Prelude things are pre-declared)
86 = IdLabel -- A family of labels related to the
87 CLabelId -- definition of a particular Id
88 IdLabelInfo -- Includes DataCon
90 | TyConLabel -- A family of labels related to the
91 TyCon -- definition of a data type
94 | CaseLabel -- A family of labels related to a particular case expression
95 Unique -- Unique says which case expression
100 | RtsLabel RtsLabelInfo
105 The CLabelId is simply so we can declare alternative Eq and Ord
106 instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
107 comparing the Uniques of two specialised data constructors (which have
108 the same as the uniques their respective unspecialised data
109 constructors). Instead, the specialising types and the uniques of the
110 unspecialised constructors are compared.
113 data CLabelId = CLabelId Id
115 instance Ord3 CLabelId where
116 cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
118 instance Eq CLabelId where
119 CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
120 CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
122 instance Ord CLabelId where
123 CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
124 CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
125 CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
126 CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
127 _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
132 = Closure -- Label for (static???) closure
133 | StaticClosure -- Static closure -- e.g., nullary constructor
135 | InfoTbl -- Info table for a closure; always read-only
137 | EntryStd -- Thunk, or "slow", code entry point (requires arg satis check)
138 | EntryFast Int -- entry pt when no arg satisfaction chk needed;
139 -- Int is the arity of the function (to be
140 -- encoded into the name)
142 | ConEntry -- the only kind of entry pt for constructors
143 | ConInfoTbl -- corresponding info table
145 | StaticConEntry -- static constructor entry point
146 | StaticInfoTbl -- corresponding info table
148 | PhantomInfoTbl -- for phantom constructors that only exist in regs
150 | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
153 -- Ticky-ticky counting
154 | RednCounts -- Label of place to keep reduction-count info for this Id
159 = UnvecConUpdCode -- Update code for the data type if it's unvectored
161 | VecConUpdCode ConTag -- One for each constructor which returns in
162 -- regs; this code actually performs an update
164 | StdUpdCode ConTag -- Update code for all constructors which return
165 -- in heap. There are a small number of variants,
166 -- so that the update code returns (vectored/n or
167 -- unvectored) in the right way.
168 -- ToDo: maybe replace TyCon/Int with return conv.
170 | InfoTblVecTbl -- For tables of info tables
172 | StdUpdVecTbl -- Labels the update code, or table of update codes,
173 -- for a particular type.
184 = RtsShouldNeverHappenCode
186 | RtsBlackHoleInfoTbl
188 | RtsSelectorInfoTbl -- Selectors
189 Bool -- True <=> the update-reqd version;
190 -- False <=> the no-update-reqd version
191 Int -- 0-indexed Offset from the "goods"
193 | RtsSelectorEntry -- Ditto entry code
200 mkClosureLabel id = IdLabel (CLabelId id) Closure
201 mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
202 mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
203 mkFastEntryLabel id arity = ASSERT(arity > 0)
204 IdLabel (CLabelId id) (EntryFast arity)
206 mkStaticClosureLabel con = ASSERT(isDataCon con)
207 IdLabel (CLabelId con) StaticClosure
208 mkStaticInfoTableLabel con = ASSERT(isDataCon con)
209 IdLabel (CLabelId con) StaticInfoTbl
210 mkConInfoTableLabel con = ASSERT(isDataCon con)
211 IdLabel (CLabelId con) ConInfoTbl
212 mkPhantomInfoTableLabel con = ASSERT(isDataCon con)
213 IdLabel (CLabelId con) PhantomInfoTbl
214 mkConEntryLabel con = ASSERT(isDataCon con)
215 IdLabel (CLabelId con) ConEntry
216 mkStaticConEntryLabel con = ASSERT(isDataCon con)
217 IdLabel (CLabelId con) StaticConEntry
219 mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
220 mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
221 mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
223 mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
224 mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
226 mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl
227 mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl
229 mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
230 mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
231 mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
232 mkDefaultLabel uniq = CaseLabel uniq CaseDefault
234 mkAsmTempLabel = AsmTempLabel
236 -- Some fixed runtime system labels
238 mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
239 mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
243 needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother
244 isReadOnly :: CLabel -> Bool -- lives in C "text space"
245 isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
246 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
249 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
250 object. {\em Also:} No need to spit out labels for things generated
251 by the flattener (in @AbsCUtils@)---it is careful to ensure references
252 to them are always backwards. These are return-point and vector-table
255 Declarations for (non-prelude) @Id@-based things are needed because of
258 needsCDecl (IdLabel _ _) = True
259 needsCDecl (CaseLabel _ _) = False
261 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
262 needsCDecl (TyConLabel _ InfoTblVecTbl) = False
263 needsCDecl (TyConLabel _ other) = True
265 needsCDecl (AsmTempLabel _) = False
266 needsCDecl (RtsLabel _) = False
268 needsCDecl other = True
271 Whether the labelled thing can be put in C "text space":
273 isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
274 isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other
275 isReadOnly (IdLabel _ StaticInfoTbl) = True
276 isReadOnly (IdLabel _ PhantomInfoTbl) = True
277 isReadOnly (IdLabel _ (VapInfoTbl _)) = True
278 isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
280 isReadOnly (TyConLabel _ _) = True
281 isReadOnly (CaseLabel _ _) = True
282 isReadOnly (AsmTempLabel _) = True
283 isReadOnly (RtsLabel _) = True
286 Whether the label is an assembler temporary:
288 isAsmTemp (AsmTempLabel _) = True
292 C ``static'' or not...
293 From the point of view of the code generator, a name is
294 externally visible if it should be given put in the .o file's
295 symbol table; that is, made static.
298 externallyVisibleCLabel (TyConLabel tc _) = True
299 externallyVisibleCLabel (CaseLabel _ _) = False
300 externallyVisibleCLabel (AsmTempLabel _) = False
301 externallyVisibleCLabel (RtsLabel _) = True
302 externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
305 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
306 right places. It is used to detect when the abstractC statement of an
307 CCodeBlock actually contains the code for a slow entry point. -- HWL
309 We need at least @Eq@ for @CLabels@, because we want to avoid
310 duplicate declarations in generating C (see @labelSeenTE@ in
314 -- specialised for PprAsm: saves lots of arg passing in NCG
315 #if ! OMIT_NATIVE_CODEGEN
316 pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
319 pprCLabel :: PprStyle -> CLabel -> Unpretty
321 pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
322 = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
324 pprCLabel (PprForAsm prepend_cSEP _) lbl
326 then uppBeside pp_cSEP prLbl
329 prLbl = pprCLabel PprForC lbl
331 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
332 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
333 pp_cSEP, uppPStr SLIT("upd")]
335 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
336 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
337 uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
339 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
340 = case (ctrlReturnConvAlg tc) of
341 UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
342 VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
344 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
345 = uppBesides [ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("itblvtbl")]
347 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
348 = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
349 pp_cSEP, uppPStr SLIT("upd")]
351 pprCLabel sty (CaseLabel u CaseReturnPt)
352 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
353 pprCLabel sty (CaseLabel u CaseVecTbl)
354 = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
355 pprCLabel sty (CaseLabel u (CaseAlt tag))
356 = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
357 pprCLabel sty (CaseLabel u CaseDefault)
358 = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
360 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
362 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
364 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
365 = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
366 uppPStr (if upd_reqd then SLIT("upd") else SLIT("noupd")),
369 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
370 = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
371 uppPStr (if upd_reqd then SLIT("upd") else SLIT("noupd")),
374 pprCLabel sty (IdLabel (CLabelId id) flavor)
375 = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
377 ppr_u u = prettyToUn (pprUnique u)
381 str = showTyCon sty tc
383 --pprTrace "ppr_tycon:" (ppStr str) $
386 ppFlavor :: IdLabelInfo -> Unpretty
388 ppFlavor x = uppBeside pp_cSEP
390 Closure -> uppPStr SLIT("closure")
391 InfoTbl -> uppPStr SLIT("info")
392 EntryStd -> uppPStr SLIT("entry")
393 EntryFast arity -> --false:ASSERT (arity > 0)
394 uppBeside (uppPStr SLIT("fast")) (uppInt arity)
395 StaticClosure -> uppPStr SLIT("static_closure")
396 ConEntry -> uppPStr SLIT("con_entry")
397 ConInfoTbl -> uppPStr SLIT("con_info")
398 StaticConEntry -> uppPStr SLIT("static_entry")
399 StaticInfoTbl -> uppPStr SLIT("static_info")
400 PhantomInfoTbl -> uppPStr SLIT("inregs_info")
401 VapInfoTbl True -> uppPStr SLIT("vap_info")
402 VapInfoTbl False -> uppPStr SLIT("vap_noupd_info")
403 VapEntry True -> uppPStr SLIT("vap_entry")
404 VapEntry False -> uppPStr SLIT("vap_noupd_entry")
405 RednCounts -> uppPStr SLIT("ct")