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
53 #if ! OMIT_NATIVE_CODEGEN
54 # if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
55 IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl )
57 import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
61 import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
62 import CStrings ( pp_cSEP )
63 import Id ( externallyVisibleId, cmpId_withSpecDataCon,
64 isDataCon, isDictFunId,
65 isDefaultMethodId_maybe,
66 isSuperDictSelId_maybe, fIRST_TAG,
67 SYN_IE(ConTag), GenId{-instance Outputable-},
70 import Maybes ( maybeToBool )
71 import Outputable ( Outputable(..), PprStyle(..) )
72 import PprType ( showTyCon, GenType{-instance Outputable-} )
73 import TyCon ( TyCon{-instance Eq-} )
74 import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
76 import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) )
79 things we want to find out:
81 * should the labelled things be declared "static" (visible only in this file)?
83 * should it be declared "const" (read-only text space)?
85 * does it need declarations at all? (v common Prelude things are pre-declared)
89 = IdLabel -- A family of labels related to the
90 CLabelId -- definition of a particular Id
91 IdLabelInfo -- Includes DataCon
93 | TyConLabel -- A family of labels related to the
94 TyCon -- definition of a data type
97 | CaseLabel -- A family of labels related to a particular case expression
98 Unique -- Unique says which case expression
101 | AsmTempLabel Unique
103 | RtsLabel RtsLabelInfo
108 The CLabelId is simply so we can declare alternative Eq and Ord
109 instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
110 comparing the Uniques of two specialised data constructors (which have
111 the same as the uniques their respective unspecialised data
112 constructors). Instead, the specialising types and the uniques of the
113 unspecialised constructors are compared.
116 data CLabelId = CLabelId Id
118 instance Ord3 CLabelId where
119 cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
121 instance Eq CLabelId where
122 CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
123 CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
125 instance Ord CLabelId where
126 CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
127 CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
128 CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
129 CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
130 _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
135 = Closure -- Label for (static???) closure
136 | StaticClosure -- Static closure -- e.g., nullary constructor
138 | InfoTbl -- Info table for a closure; always read-only
140 | EntryStd -- Thunk, or "slow", code entry point (requires arg satis check)
141 | EntryFast Int -- entry pt when no arg satisfaction chk needed;
142 -- Int is the arity of the function (to be
143 -- encoded into the name)
145 | ConEntry -- the only kind of entry pt for constructors
146 | ConInfoTbl -- corresponding info table
148 | StaticConEntry -- static constructor entry point
149 | StaticInfoTbl -- corresponding info table
151 | PhantomInfoTbl -- for phantom constructors that only exist in regs
153 | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
156 -- Ticky-ticky counting
157 | RednCounts -- Label of place to keep reduction-count info for this Id
162 = UnvecConUpdCode -- Update code for the data type if it's unvectored
164 | VecConUpdCode ConTag -- One for each constructor which returns in
165 -- regs; this code actually performs an update
167 | StdUpdCode ConTag -- Update code for all constructors which return
168 -- in heap. There are a small number of variants,
169 -- so that the update code returns (vectored/n or
170 -- unvectored) in the right way.
171 -- ToDo: maybe replace TyCon/Int with return conv.
173 | InfoTblVecTbl -- For tables of info tables
175 | StdUpdVecTbl -- Labels the update code, or table of update codes,
176 -- for a particular type.
187 = RtsShouldNeverHappenCode
189 | RtsBlackHoleInfoTbl
191 | RtsSelectorInfoTbl -- Selectors
192 Bool -- True <=> the update-reqd version;
193 -- False <=> the no-update-reqd version
194 Int -- 0-indexed Offset from the "goods"
196 | RtsSelectorEntry -- Ditto entry code
203 mkClosureLabel id = IdLabel (CLabelId id) Closure
204 mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
205 mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
206 mkFastEntryLabel id arity = ASSERT(arity > 0)
207 IdLabel (CLabelId id) (EntryFast arity)
209 mkStaticClosureLabel con = ASSERT(isDataCon con)
210 IdLabel (CLabelId con) StaticClosure
211 mkStaticInfoTableLabel con = ASSERT(isDataCon con)
212 IdLabel (CLabelId con) StaticInfoTbl
213 mkConInfoTableLabel con = ASSERT(isDataCon con)
214 IdLabel (CLabelId con) ConInfoTbl
215 mkPhantomInfoTableLabel con = ASSERT(isDataCon con)
216 IdLabel (CLabelId con) PhantomInfoTbl
217 mkConEntryLabel con = ASSERT(isDataCon con)
218 IdLabel (CLabelId con) ConEntry
219 mkStaticConEntryLabel con = ASSERT(isDataCon con)
220 IdLabel (CLabelId con) StaticConEntry
222 mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
223 mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
224 mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
226 mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
227 mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
229 mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl
230 mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl
232 mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
233 mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
234 mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
235 mkDefaultLabel uniq = CaseLabel uniq CaseDefault
237 mkAsmTempLabel = AsmTempLabel
239 -- Some fixed runtime system labels
241 mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
242 mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
246 needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother
247 isReadOnly :: CLabel -> Bool -- lives in C "text space"
248 isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
249 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
252 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
253 object. {\em Also:} No need to spit out labels for things generated
254 by the flattener (in @AbsCUtils@)---it is careful to ensure references
255 to them are always backwards. These are return-point and vector-table
258 Declarations for (non-prelude) @Id@-based things are needed because of
261 needsCDecl (IdLabel _ _) = True
262 needsCDecl (CaseLabel _ _) = False
264 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
265 needsCDecl (TyConLabel _ InfoTblVecTbl) = False
266 needsCDecl (TyConLabel _ other) = True
268 needsCDecl (AsmTempLabel _) = False
269 needsCDecl (RtsLabel _) = False
271 needsCDecl other = True
274 Whether the labelled thing can be put in C "text space":
276 isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
277 isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other
278 isReadOnly (IdLabel _ StaticInfoTbl) = True
279 isReadOnly (IdLabel _ PhantomInfoTbl) = True
280 isReadOnly (IdLabel _ (VapInfoTbl _)) = True
281 isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
283 isReadOnly (TyConLabel _ _) = True
284 isReadOnly (CaseLabel _ _) = True
285 isReadOnly (AsmTempLabel _) = True
286 isReadOnly (RtsLabel _) = True
289 Whether the label is an assembler temporary:
291 isAsmTemp (AsmTempLabel _) = True
295 C ``static'' or not...
296 From the point of view of the code generator, a name is
297 externally visible if it should be given put in the .o file's
298 symbol table; that is, made static.
301 externallyVisibleCLabel (TyConLabel tc _) = True
302 externallyVisibleCLabel (CaseLabel _ _) = False
303 externallyVisibleCLabel (AsmTempLabel _) = False
304 externallyVisibleCLabel (RtsLabel _) = True
305 externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
308 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
309 right places. It is used to detect when the abstractC statement of an
310 CCodeBlock actually contains the code for a slow entry point. -- HWL
312 We need at least @Eq@ for @CLabels@, because we want to avoid
313 duplicate declarations in generating C (see @labelSeenTE@ in
317 -- specialised for PprAsm: saves lots of arg passing in NCG
318 #if ! OMIT_NATIVE_CODEGEN
319 pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
322 pprCLabel :: PprStyle -> CLabel -> Doc
324 pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
325 = text (fmtAsmLbl (showUnique u))
327 pprCLabel (PprForAsm prepend_cSEP _) lbl
329 then (<>) pp_cSEP prLbl
332 prLbl = pprCLabel PprForC lbl
334 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
335 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
336 pp_cSEP, ptext SLIT("upd")]
338 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
339 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
340 int tag, pp_cSEP, ptext SLIT("upd")]
342 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
343 = case (ctrlReturnConvAlg tc) of
344 UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir")
345 VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG))
347 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
348 = hcat [ppr_tycon sty tc, pp_cSEP, ptext SLIT("itblvtbl")]
350 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
351 = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
352 pp_cSEP, ptext SLIT("upd")]
354 pprCLabel sty (CaseLabel u CaseReturnPt)
355 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
356 pprCLabel sty (CaseLabel u CaseVecTbl)
357 = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u]
358 pprCLabel sty (CaseLabel u (CaseAlt tag))
359 = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
360 pprCLabel sty (CaseLabel u CaseDefault)
361 = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
363 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
365 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
367 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
368 = hcat [ptext SLIT("__sel_info_"), text (show offset),
369 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
372 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
373 = hcat [ptext SLIT("__sel_entry_"), text (show offset),
374 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
377 pprCLabel sty (IdLabel (CLabelId id) flavor)
378 = (<>) (ppr sty id) (ppFlavor flavor)
380 ppr_u u = pprUnique u
384 str = showTyCon sty tc
386 --pprTrace "ppr_tycon:" (text str) $
389 ppFlavor :: IdLabelInfo -> Doc
391 ppFlavor x = (<>) pp_cSEP
393 Closure -> ptext SLIT("closure")
394 InfoTbl -> ptext SLIT("info")
395 EntryStd -> ptext SLIT("entry")
396 EntryFast arity -> --false:ASSERT (arity > 0)
397 (<>) (ptext SLIT("fast")) (int arity)
398 StaticClosure -> ptext SLIT("static_closure")
399 ConEntry -> ptext SLIT("con_entry")
400 ConInfoTbl -> ptext SLIT("con_info")
401 StaticConEntry -> ptext SLIT("static_entry")
402 StaticInfoTbl -> ptext SLIT("static_info")
403 PhantomInfoTbl -> ptext SLIT("inregs_info")
404 VapInfoTbl True -> ptext SLIT("vap_info")
405 VapInfoTbl False -> ptext SLIT("vap_noupd_info")
406 VapEntry True -> ptext SLIT("vap_entry")
407 VapEntry False -> ptext SLIT("vap_noupd_entry")
408 RednCounts -> ptext SLIT("ct")