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, pprTrace{-ToDo: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...
294 externallyVisibleCLabel (TyConLabel tc _) = True
295 externallyVisibleCLabel (CaseLabel _ _) = False
296 externallyVisibleCLabel (AsmTempLabel _) = False
297 externallyVisibleCLabel (RtsLabel _) = True
298 externallyVisibleCLabel (IdLabel (CLabelId id) _)
299 | isDataCon id = True
300 | is_ConstMethodId id = True -- These are here to ensure splitting works
301 | isDictFunId id = True -- when these values have not been exported
302 | is_DefaultMethodId id = True
303 | is_SuperDictSelId id = True
304 | otherwise = externallyVisibleId id
306 is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id)
307 is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
308 is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id)
311 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
312 right places. It is used to detect when the abstractC statement of an
313 CCodeBlock actually contains the code for a slow entry point. -- HWL
315 We need at least @Eq@ for @CLabels@, because we want to avoid
316 duplicate declarations in generating C (see @labelSeenTE@ in
320 -- specialised for PprAsm: saves lots of arg passing in NCG
321 #if ! OMIT_NATIVE_CODEGEN
322 pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
325 pprCLabel :: PprStyle -> CLabel -> Unpretty
327 pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
328 = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
330 pprCLabel (PprForAsm prepend_cSEP _) lbl
332 then uppBeside pp_cSEP prLbl
335 prLbl = pprCLabel PprForC lbl
337 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
338 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
339 pp_cSEP, uppPStr SLIT("upd")]
341 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
342 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
343 uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
345 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
346 = case (ctrlReturnConvAlg tc) of
347 UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
348 VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
350 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
351 = uppBesides [ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("itblvtbl")]
353 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
354 = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
355 pp_cSEP, uppPStr SLIT("upd")]
357 pprCLabel sty (CaseLabel u CaseReturnPt)
358 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
359 pprCLabel sty (CaseLabel u CaseVecTbl)
360 = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
361 pprCLabel sty (CaseLabel u (CaseAlt tag))
362 = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
363 pprCLabel sty (CaseLabel u CaseDefault)
364 = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
366 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
368 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
370 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
371 = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
372 uppStr (if upd_reqd then "upd" else "noupd"),
375 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
376 = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
377 uppStr (if upd_reqd then "upd" else "noupd"),
380 pprCLabel sty (IdLabel (CLabelId id) flavor)
381 = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
383 ppr_u u = prettyToUn (pprUnique u)
387 str = showTyCon sty tc
389 --pprTrace "ppr_tycon:" (ppStr str) $
392 ppFlavor :: IdLabelInfo -> Unpretty
394 ppFlavor x = uppBeside pp_cSEP
396 Closure -> uppPStr SLIT("closure")
397 InfoTbl -> uppPStr SLIT("info")
398 EntryStd -> uppPStr SLIT("entry")
399 EntryFast arity -> --false:ASSERT (arity > 0)
400 uppBeside (uppPStr SLIT("fast")) (uppInt arity)
401 StaticClosure -> uppPStr SLIT("static_closure")
402 ConEntry -> uppPStr SLIT("con_entry")
403 ConInfoTbl -> uppPStr SLIT("con_info")
404 StaticConEntry -> uppPStr SLIT("static_entry")
405 StaticInfoTbl -> uppPStr SLIT("static_info")
406 PhantomInfoTbl -> uppPStr SLIT("inregs_info")
407 VapInfoTbl True -> uppPStr SLIT("vap_info")
408 VapInfoTbl False -> uppPStr SLIT("vap_noupd_info")
409 VapEntry True -> uppPStr SLIT("vap_entry")
410 VapEntry False -> uppPStr SLIT("vap_noupd_entry")
411 RednCounts -> uppPStr SLIT("ct")