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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
52 IMPORT_DELOOPER(AbsCLoop) ( CtrlReturnConvention(..),
56 import {-# SOURCE #-} CgRetConv
60 #if ! OMIT_NATIVE_CODEGEN
61 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
62 IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl )
64 import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
68 import CStrings ( pp_cSEP )
69 import Id ( externallyVisibleId, cmpId_withSpecDataCon,
70 isDataCon, isDictFunId,
71 isConstMethodId_maybe,
72 isDefaultMethodId_maybe,
73 isSuperDictSelId_maybe, fIRST_TAG,
74 SYN_IE(ConTag), GenId{-instance Outputable-},
77 import Maybes ( maybeToBool )
78 import Outputable ( Outputable(..), PprStyle(..) )
79 import PprType ( showTyCon, GenType{-instance Outputable-} )
80 import TyCon ( TyCon{-instance Eq-} )
81 import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
83 import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) )
86 things we want to find out:
88 * should the labelled things be declared "static" (visible only in this file)?
90 * should it be declared "const" (read-only text space)?
92 * does it need declarations at all? (v common Prelude things are pre-declared)
96 = IdLabel -- A family of labels related to the
97 CLabelId -- definition of a particular Id
98 IdLabelInfo -- Includes DataCon
100 | TyConLabel -- A family of labels related to the
101 TyCon -- definition of a data type
104 | CaseLabel -- A family of labels related to a particular case expression
105 Unique -- Unique says which case expression
108 | AsmTempLabel Unique
110 | RtsLabel RtsLabelInfo
115 The CLabelId is simply so we can declare alternative Eq and Ord
116 instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
117 comparing the Uniques of two specialised data constructors (which have
118 the same as the uniques their respective unspecialised data
119 constructors). Instead, the specialising types and the uniques of the
120 unspecialised constructors are compared.
123 data CLabelId = CLabelId Id
125 instance Ord3 CLabelId where
126 cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
128 instance Eq CLabelId where
129 CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
130 CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
132 instance Ord CLabelId where
133 CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
134 CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
135 CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
136 CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
137 _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
142 = Closure -- Label for (static???) closure
143 | StaticClosure -- Static closure -- e.g., nullary constructor
145 | InfoTbl -- Info table for a closure; always read-only
147 | EntryStd -- Thunk, or "slow", code entry point (requires arg satis check)
148 | EntryFast Int -- entry pt when no arg satisfaction chk needed;
149 -- Int is the arity of the function (to be
150 -- encoded into the name)
152 | ConEntry -- the only kind of entry pt for constructors
153 | ConInfoTbl -- corresponding info table
155 | StaticConEntry -- static constructor entry point
156 | StaticInfoTbl -- corresponding info table
158 | PhantomInfoTbl -- for phantom constructors that only exist in regs
160 | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
163 -- Ticky-ticky counting
164 | RednCounts -- Label of place to keep reduction-count info for this Id
169 = UnvecConUpdCode -- Update code for the data type if it's unvectored
171 | VecConUpdCode ConTag -- One for each constructor which returns in
172 -- regs; this code actually performs an update
174 | StdUpdCode ConTag -- Update code for all constructors which return
175 -- in heap. There are a small number of variants,
176 -- so that the update code returns (vectored/n or
177 -- unvectored) in the right way.
178 -- ToDo: maybe replace TyCon/Int with return conv.
180 | InfoTblVecTbl -- For tables of info tables
182 | StdUpdVecTbl -- Labels the update code, or table of update codes,
183 -- for a particular type.
194 = RtsShouldNeverHappenCode
196 | RtsBlackHoleInfoTbl
198 | RtsSelectorInfoTbl -- Selectors
199 Bool -- True <=> the update-reqd version;
200 -- False <=> the no-update-reqd version
201 Int -- 0-indexed Offset from the "goods"
203 | RtsSelectorEntry -- Ditto entry code
210 mkClosureLabel id = IdLabel (CLabelId id) Closure
211 mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
212 mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
213 mkFastEntryLabel id arity = ASSERT(arity > 0)
214 IdLabel (CLabelId id) (EntryFast arity)
216 mkStaticClosureLabel con = ASSERT(isDataCon con)
217 IdLabel (CLabelId con) StaticClosure
218 mkStaticInfoTableLabel con = ASSERT(isDataCon con)
219 IdLabel (CLabelId con) StaticInfoTbl
220 mkConInfoTableLabel con = ASSERT(isDataCon con)
221 IdLabel (CLabelId con) ConInfoTbl
222 mkPhantomInfoTableLabel con = ASSERT(isDataCon con)
223 IdLabel (CLabelId con) PhantomInfoTbl
224 mkConEntryLabel con = ASSERT(isDataCon con)
225 IdLabel (CLabelId con) ConEntry
226 mkStaticConEntryLabel con = ASSERT(isDataCon con)
227 IdLabel (CLabelId con) StaticConEntry
229 mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
230 mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
231 mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
233 mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
234 mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
236 mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl
237 mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl
239 mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
240 mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
241 mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
242 mkDefaultLabel uniq = CaseLabel uniq CaseDefault
244 mkAsmTempLabel = AsmTempLabel
246 -- Some fixed runtime system labels
248 mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
249 mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
253 needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother
254 isReadOnly :: CLabel -> Bool -- lives in C "text space"
255 isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
256 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
259 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
260 object. {\em Also:} No need to spit out labels for things generated
261 by the flattener (in @AbsCUtils@)---it is careful to ensure references
262 to them are always backwards. These are return-point and vector-table
265 Declarations for (non-prelude) @Id@-based things are needed because of
268 needsCDecl (IdLabel _ _) = True
269 needsCDecl (CaseLabel _ _) = False
271 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
272 needsCDecl (TyConLabel _ InfoTblVecTbl) = False
273 needsCDecl (TyConLabel _ other) = True
275 needsCDecl (AsmTempLabel _) = False
276 needsCDecl (RtsLabel _) = False
278 needsCDecl other = True
281 Whether the labelled thing can be put in C "text space":
283 isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
284 isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other
285 isReadOnly (IdLabel _ StaticInfoTbl) = True
286 isReadOnly (IdLabel _ PhantomInfoTbl) = True
287 isReadOnly (IdLabel _ (VapInfoTbl _)) = True
288 isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
290 isReadOnly (TyConLabel _ _) = True
291 isReadOnly (CaseLabel _ _) = True
292 isReadOnly (AsmTempLabel _) = True
293 isReadOnly (RtsLabel _) = True
296 Whether the label is an assembler temporary:
298 isAsmTemp (AsmTempLabel _) = True
302 C ``static'' or not...
303 From the point of view of the code generator, a name is
304 externally visible if it should be given put in the .o file's
305 symbol table; that is, made static.
308 externallyVisibleCLabel (TyConLabel tc _) = True
309 externallyVisibleCLabel (CaseLabel _ _) = False
310 externallyVisibleCLabel (AsmTempLabel _) = False
311 externallyVisibleCLabel (RtsLabel _) = True
312 externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
315 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
316 right places. It is used to detect when the abstractC statement of an
317 CCodeBlock actually contains the code for a slow entry point. -- HWL
319 We need at least @Eq@ for @CLabels@, because we want to avoid
320 duplicate declarations in generating C (see @labelSeenTE@ in
324 -- specialised for PprAsm: saves lots of arg passing in NCG
325 #if ! OMIT_NATIVE_CODEGEN
326 pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
329 pprCLabel :: PprStyle -> CLabel -> Doc
331 pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
332 = text (fmtAsmLbl (_UNPK_ (showUnique u)))
334 pprCLabel (PprForAsm prepend_cSEP _) lbl
336 then (<>) pp_cSEP prLbl
339 prLbl = pprCLabel PprForC lbl
341 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
342 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
343 pp_cSEP, ptext SLIT("upd")]
345 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
346 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
347 int tag, pp_cSEP, ptext SLIT("upd")]
349 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
350 = case (ctrlReturnConvAlg tc) of
351 UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir")
352 VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG))
354 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
355 = hcat [ppr_tycon sty tc, pp_cSEP, ptext SLIT("itblvtbl")]
357 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
358 = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
359 pp_cSEP, ptext SLIT("upd")]
361 pprCLabel sty (CaseLabel u CaseReturnPt)
362 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
363 pprCLabel sty (CaseLabel u CaseVecTbl)
364 = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u]
365 pprCLabel sty (CaseLabel u (CaseAlt tag))
366 = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
367 pprCLabel sty (CaseLabel u CaseDefault)
368 = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
370 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
372 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
374 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
375 = hcat [ptext SLIT("__sel_info_"), text (show offset),
376 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
379 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
380 = hcat [ptext SLIT("__sel_entry_"), text (show offset),
381 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
384 pprCLabel sty (IdLabel (CLabelId id) flavor)
385 = (<>) (ppr sty id) (ppFlavor flavor)
387 ppr_u u = pprUnique u
391 str = showTyCon sty tc
393 --pprTrace "ppr_tycon:" (text str) $
396 ppFlavor :: IdLabelInfo -> Doc
398 ppFlavor x = (<>) pp_cSEP
400 Closure -> ptext SLIT("closure")
401 InfoTbl -> ptext SLIT("info")
402 EntryStd -> ptext SLIT("entry")
403 EntryFast arity -> --false:ASSERT (arity > 0)
404 (<>) (ptext SLIT("fast")) (int arity)
405 StaticClosure -> ptext SLIT("static_closure")
406 ConEntry -> ptext SLIT("con_entry")
407 ConInfoTbl -> ptext SLIT("con_info")
408 StaticConEntry -> ptext SLIT("static_entry")
409 StaticInfoTbl -> ptext SLIT("static_info")
410 PhantomInfoTbl -> ptext SLIT("inregs_info")
411 VapInfoTbl True -> ptext SLIT("vap_info")
412 VapInfoTbl False -> ptext SLIT("vap_noupd_info")
413 VapEntry True -> ptext SLIT("vap_entry")
414 VapEntry False -> ptext SLIT("vap_noupd_entry")
415 RednCounts -> ptext SLIT("ct")