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 isDefaultMethodId_maybe,
72 isSuperDictSelId_maybe, fIRST_TAG,
73 SYN_IE(ConTag), GenId{-instance Outputable-},
76 import Maybes ( maybeToBool )
77 import Outputable ( Outputable(..), PprStyle(..) )
78 import PprType ( showTyCon, GenType{-instance Outputable-} )
79 import TyCon ( TyCon{-instance Eq-} )
80 import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
82 import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) )
85 things we want to find out:
87 * should the labelled things be declared "static" (visible only in this file)?
89 * should it be declared "const" (read-only text space)?
91 * does it need declarations at all? (v common Prelude things are pre-declared)
95 = IdLabel -- A family of labels related to the
96 CLabelId -- definition of a particular Id
97 IdLabelInfo -- Includes DataCon
99 | TyConLabel -- A family of labels related to the
100 TyCon -- definition of a data type
103 | CaseLabel -- A family of labels related to a particular case expression
104 Unique -- Unique says which case expression
107 | AsmTempLabel Unique
109 | RtsLabel RtsLabelInfo
114 The CLabelId is simply so we can declare alternative Eq and Ord
115 instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
116 comparing the Uniques of two specialised data constructors (which have
117 the same as the uniques their respective unspecialised data
118 constructors). Instead, the specialising types and the uniques of the
119 unspecialised constructors are compared.
122 data CLabelId = CLabelId Id
124 instance Ord3 CLabelId where
125 cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
127 instance Eq CLabelId where
128 CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
129 CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
131 instance Ord CLabelId where
132 CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
133 CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
134 CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
135 CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
136 _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
141 = Closure -- Label for (static???) closure
142 | StaticClosure -- Static closure -- e.g., nullary constructor
144 | InfoTbl -- Info table for a closure; always read-only
146 | EntryStd -- Thunk, or "slow", code entry point (requires arg satis check)
147 | EntryFast Int -- entry pt when no arg satisfaction chk needed;
148 -- Int is the arity of the function (to be
149 -- encoded into the name)
151 | ConEntry -- the only kind of entry pt for constructors
152 | ConInfoTbl -- corresponding info table
154 | StaticConEntry -- static constructor entry point
155 | StaticInfoTbl -- corresponding info table
157 | PhantomInfoTbl -- for phantom constructors that only exist in regs
159 | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
162 -- Ticky-ticky counting
163 | RednCounts -- Label of place to keep reduction-count info for this Id
168 = UnvecConUpdCode -- Update code for the data type if it's unvectored
170 | VecConUpdCode ConTag -- One for each constructor which returns in
171 -- regs; this code actually performs an update
173 | StdUpdCode ConTag -- Update code for all constructors which return
174 -- in heap. There are a small number of variants,
175 -- so that the update code returns (vectored/n or
176 -- unvectored) in the right way.
177 -- ToDo: maybe replace TyCon/Int with return conv.
179 | InfoTblVecTbl -- For tables of info tables
181 | StdUpdVecTbl -- Labels the update code, or table of update codes,
182 -- for a particular type.
193 = RtsShouldNeverHappenCode
195 | RtsBlackHoleInfoTbl
197 | RtsSelectorInfoTbl -- Selectors
198 Bool -- True <=> the update-reqd version;
199 -- False <=> the no-update-reqd version
200 Int -- 0-indexed Offset from the "goods"
202 | RtsSelectorEntry -- Ditto entry code
209 mkClosureLabel id = IdLabel (CLabelId id) Closure
210 mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
211 mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
212 mkFastEntryLabel id arity = ASSERT(arity > 0)
213 IdLabel (CLabelId id) (EntryFast arity)
215 mkStaticClosureLabel con = ASSERT(isDataCon con)
216 IdLabel (CLabelId con) StaticClosure
217 mkStaticInfoTableLabel con = ASSERT(isDataCon con)
218 IdLabel (CLabelId con) StaticInfoTbl
219 mkConInfoTableLabel con = ASSERT(isDataCon con)
220 IdLabel (CLabelId con) ConInfoTbl
221 mkPhantomInfoTableLabel con = ASSERT(isDataCon con)
222 IdLabel (CLabelId con) PhantomInfoTbl
223 mkConEntryLabel con = ASSERT(isDataCon con)
224 IdLabel (CLabelId con) ConEntry
225 mkStaticConEntryLabel con = ASSERT(isDataCon con)
226 IdLabel (CLabelId con) StaticConEntry
228 mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
229 mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
230 mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
232 mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
233 mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
235 mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl
236 mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl
238 mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
239 mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
240 mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
241 mkDefaultLabel uniq = CaseLabel uniq CaseDefault
243 mkAsmTempLabel = AsmTempLabel
245 -- Some fixed runtime system labels
247 mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
248 mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
252 needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother
253 isReadOnly :: CLabel -> Bool -- lives in C "text space"
254 isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
255 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
258 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
259 object. {\em Also:} No need to spit out labels for things generated
260 by the flattener (in @AbsCUtils@)---it is careful to ensure references
261 to them are always backwards. These are return-point and vector-table
264 Declarations for (non-prelude) @Id@-based things are needed because of
267 needsCDecl (IdLabel _ _) = True
268 needsCDecl (CaseLabel _ _) = False
270 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
271 needsCDecl (TyConLabel _ InfoTblVecTbl) = False
272 needsCDecl (TyConLabel _ other) = True
274 needsCDecl (AsmTempLabel _) = False
275 needsCDecl (RtsLabel _) = False
277 needsCDecl other = True
280 Whether the labelled thing can be put in C "text space":
282 isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
283 isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other
284 isReadOnly (IdLabel _ StaticInfoTbl) = True
285 isReadOnly (IdLabel _ PhantomInfoTbl) = True
286 isReadOnly (IdLabel _ (VapInfoTbl _)) = True
287 isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
289 isReadOnly (TyConLabel _ _) = True
290 isReadOnly (CaseLabel _ _) = True
291 isReadOnly (AsmTempLabel _) = True
292 isReadOnly (RtsLabel _) = True
295 Whether the label is an assembler temporary:
297 isAsmTemp (AsmTempLabel _) = True
301 C ``static'' or not...
302 From the point of view of the code generator, a name is
303 externally visible if it should be given put in the .o file's
304 symbol table; that is, made static.
307 externallyVisibleCLabel (TyConLabel tc _) = True
308 externallyVisibleCLabel (CaseLabel _ _) = False
309 externallyVisibleCLabel (AsmTempLabel _) = False
310 externallyVisibleCLabel (RtsLabel _) = True
311 externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
314 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
315 right places. It is used to detect when the abstractC statement of an
316 CCodeBlock actually contains the code for a slow entry point. -- HWL
318 We need at least @Eq@ for @CLabels@, because we want to avoid
319 duplicate declarations in generating C (see @labelSeenTE@ in
323 -- specialised for PprAsm: saves lots of arg passing in NCG
324 #if ! OMIT_NATIVE_CODEGEN
325 pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
328 pprCLabel :: PprStyle -> CLabel -> Doc
330 pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
331 = text (fmtAsmLbl (showUnique u))
333 pprCLabel (PprForAsm prepend_cSEP _) lbl
335 then (<>) pp_cSEP prLbl
338 prLbl = pprCLabel PprForC lbl
340 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
341 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
342 pp_cSEP, ptext SLIT("upd")]
344 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
345 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
346 int tag, pp_cSEP, ptext SLIT("upd")]
348 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
349 = case (ctrlReturnConvAlg tc) of
350 UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir")
351 VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG))
353 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
354 = hcat [ppr_tycon sty tc, pp_cSEP, ptext SLIT("itblvtbl")]
356 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
357 = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
358 pp_cSEP, ptext SLIT("upd")]
360 pprCLabel sty (CaseLabel u CaseReturnPt)
361 = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
362 pprCLabel sty (CaseLabel u CaseVecTbl)
363 = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u]
364 pprCLabel sty (CaseLabel u (CaseAlt tag))
365 = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
366 pprCLabel sty (CaseLabel u CaseDefault)
367 = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
369 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
371 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
373 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
374 = hcat [ptext SLIT("__sel_info_"), text (show offset),
375 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
378 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
379 = hcat [ptext SLIT("__sel_entry_"), text (show offset),
380 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
383 pprCLabel sty (IdLabel (CLabelId id) flavor)
384 = (<>) (ppr sty id) (ppFlavor flavor)
386 ppr_u u = pprUnique u
390 str = showTyCon sty tc
392 --pprTrace "ppr_tycon:" (text str) $
395 ppFlavor :: IdLabelInfo -> Doc
397 ppFlavor x = (<>) pp_cSEP
399 Closure -> ptext SLIT("closure")
400 InfoTbl -> ptext SLIT("info")
401 EntryStd -> ptext SLIT("entry")
402 EntryFast arity -> --false:ASSERT (arity > 0)
403 (<>) (ptext SLIT("fast")) (int arity)
404 StaticClosure -> ptext SLIT("static_closure")
405 ConEntry -> ptext SLIT("con_entry")
406 ConInfoTbl -> ptext SLIT("con_info")
407 StaticConEntry -> ptext SLIT("static_entry")
408 StaticInfoTbl -> ptext SLIT("static_info")
409 PhantomInfoTbl -> ptext SLIT("inregs_info")
410 VapInfoTbl True -> ptext SLIT("vap_info")
411 VapInfoTbl False -> ptext SLIT("vap_noupd_info")
412 VapEntry True -> ptext SLIT("vap_entry")
413 VapEntry False -> ptext SLIT("vap_noupd_entry")
414 RednCounts -> ptext SLIT("ct")