2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CLabel.lhs,v 1.22 1998/12/18 17:40:34 simonpj Exp $
6 \section[CLabel]{@CLabel@: Information to make C Labels}
10 CLabel, -- abstract type
18 mkStaticConEntryLabel,
22 mkStaticInfoTableLabel,
39 mkBlackHoleInfoTableLabel,
45 mkCC_Label, mkCCS_Label,
47 needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
49 CLabelType(..), labelType,
52 #if ! OMIT_NATIVE_CODEGEN
58 #include "HsVersions.h"
60 #if ! OMIT_NATIVE_CODEGEN
61 import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
64 import CStrings ( pp_cSEP )
65 import DataCon ( ConTag, DataCon )
66 import Name ( Name, isExternallyVisibleName )
67 import TyCon ( TyCon )
68 import Unique ( pprUnique, Unique )
69 import PrimOp ( PrimOp, pprPrimOp )
70 import CostCentre ( CostCentre, CostCentreStack )
75 things we want to find out:
77 * should the labelled things be declared "static" (visible only in this file)?
79 * should it be declared "const" (read-only text space)?
81 * does it need declarations at all? (v common Prelude things are pre-declared)
83 * what type does it have? (for generating accurate enough C declarations
84 so that the C compiler won't complain).
88 = IdLabel -- A family of labels related to the
89 Name -- definition of a particular Id
92 | DataConLabel -- Ditto data constructors
96 | CaseLabel -- A family of labels related to a particular case expression
97 Unique -- Unique says which case expression
100 | TyConLabel TyCon -- currently only one kind of TyconLabel,
101 -- a 'Closure Table'.
103 | AsmTempLabel Unique
105 | RtsLabel RtsLabelInfo
107 | CC_Label CostCentre
108 | CCS_Label CostCentreStack
115 = Closure -- Label for (static???) closure
117 | SRT -- Static reference table
119 | InfoTbl -- Info table for a closure; always read-only
121 | EntryStd -- Thunk, or "slow", code entry point
123 | EntryFast Int -- entry pt when no arg satisfaction chk needed;
124 -- Int is the arity of the function (to be
125 -- encoded into the name)
127 -- Ticky-ticky counting
128 | RednCounts -- Label of place to keep reduction-count info for
132 data DataConLabelInfo
133 = ConEntry -- the only kind of entry pt for constructors
134 | ConInfoTbl -- corresponding info table
136 | StaticClosure -- Static constructor closure
137 -- e.g., nullary constructor
138 | StaticConEntry -- static constructor entry point
139 | StaticInfoTbl -- corresponding info table
152 = RtsShouldNeverHappenCode
154 | RtsBlackHoleInfoTbl
158 | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks
159 | RtsSelectorEntry Bool{-updatable-} Int{-offset-}
161 | RtsApInfoTbl Bool{-updatable-} Int{-arity-} -- AP thunks
162 | RtsApEntry Bool{-updatable-} Int{-arity-}
168 -- Label Type: for generating C declarations.
179 mkClosureLabel id = IdLabel id Closure
180 mkSRTLabel id = IdLabel id SRT
181 mkInfoTableLabel id = IdLabel id InfoTbl
182 mkStdEntryLabel id = IdLabel id EntryStd
183 mkFastEntryLabel id arity = ASSERT(arity > 0)
184 IdLabel id (EntryFast arity)
186 mkRednCountsLabel id = IdLabel id RednCounts
188 mkStaticClosureLabel con = DataConLabel con StaticClosure
189 mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl
190 mkConInfoTableLabel con = DataConLabel con ConInfoTbl
191 mkConEntryLabel con = DataConLabel con ConEntry
192 mkStaticConEntryLabel con = DataConLabel con StaticConEntry
195 mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
196 mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo
197 mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
198 mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
199 mkDefaultLabel uniq = CaseLabel uniq CaseDefault
200 mkBitmapLabel uniq = CaseLabel uniq CaseBitmap
202 mkClosureTblLabel tycon = TyConLabel tycon
204 mkAsmTempLabel = AsmTempLabel
206 -- Some fixed runtime system labels
208 mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
209 mkUpdEntryLabel = RtsLabel RtsUpdEntry
210 mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
211 mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
213 mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTbl upd off)
214 mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off)
216 mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTbl upd off)
217 mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off)
221 mkCC_Label cc = CC_Label cc
222 mkCCS_Label ccs = CCS_Label ccs
226 needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother
227 isReadOnly :: CLabel -> Bool -- lives in C "text space"
228 isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
229 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
232 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
233 object. {\em Also:} No need to spit out labels for things generated
234 by the flattener (in @AbsCUtils@)---it is careful to ensure references
235 to them are always backwards. These are return-point and vector-table
238 Declarations for (non-prelude) @Id@-based things are needed because of
241 Declarations for direct return points are needed, because they may be
242 let-no-escapes, which can be recursive.
245 needsCDecl (IdLabel _ _) = True
246 needsCDecl (CaseLabel _ CaseReturnPt) = True
247 needsCDecl (DataConLabel _ _) = True
248 needsCDecl (CaseLabel _ _) = False
250 needsCDecl (AsmTempLabel _) = False
251 needsCDecl (TyConLabel _) = False
252 needsCDecl (RtsLabel _) = False
253 needsCDecl (CC_Label _) = False
254 needsCDecl (CCS_Label _) = False
257 Whether the labelled thing can be put in C "text space":
260 isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
261 isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
263 isReadOnly (DataConLabel _ _) = True -- and so on, for other
264 isReadOnly (TyConLabel _) = True
265 isReadOnly (CaseLabel _ _) = True
266 isReadOnly (AsmTempLabel _) = True
267 isReadOnly (RtsLabel _) = True
268 isReadOnly (CC_Label _) = True
269 isReadOnly (CCS_Label _) = True
272 Whether the label is an assembler temporary:
275 isAsmTemp (AsmTempLabel _) = True
279 C ``static'' or not...
280 From the point of view of the code generator, a name is
281 externally visible if it has to be declared as exported
282 in the .o file's symbol table; that is, made non-static.
285 externallyVisibleCLabel (DataConLabel _ _) = True
286 externallyVisibleCLabel (TyConLabel tc) = True
287 externallyVisibleCLabel (CaseLabel _ _) = False
288 externallyVisibleCLabel (AsmTempLabel _) = False
289 externallyVisibleCLabel (RtsLabel _) = True
290 externallyVisibleCLabel (IdLabel id _) = isExternallyVisibleName id
291 externallyVisibleCLabel (CC_Label _) = False -- not strictly true
292 externallyVisibleCLabel (CCS_Label _) = False -- not strictly true
295 For generating correct types in label declarations...
298 labelType :: CLabel -> CLabelType
299 labelType (RtsLabel RtsBlackHoleInfoTbl) = InfoTblType
300 labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
301 labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType
302 labelType (CaseLabel _ CaseReturnInfo) = InfoTblType
303 labelType (CaseLabel _ CaseReturnPt) = CodeType
304 labelType (CaseLabel _ CaseVecTbl) = VecTblType
306 labelType (IdLabel _ info) =
308 InfoTbl -> InfoTblType
309 Closure -> ClosureType
312 labelType (DataConLabel _ info) =
314 ConInfoTbl -> InfoTblType
315 StaticInfoTbl -> InfoTblType
316 StaticClosure -> ClosureType
319 labelType _ = DataType
322 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
323 right places. It is used to detect when the abstractC statement of an
324 CCodeBlock actually contains the code for a slow entry point. -- HWL
326 We need at least @Eq@ for @CLabels@, because we want to avoid
327 duplicate declarations in generating C (see @labelSeenTE@ in
330 -----------------------------------------------------------------------------
331 Printing out CLabels.
337 where <name> is <Module>_<name> for external names and <unique> for
338 internal names. <type> is one of the following:
341 srt Static reference table
343 ret Direct return address
345 <n>_alt Case alternative (tag n)
346 dflt Default case alternative
347 btm Large bitmap vector
348 closure Static closure
349 static_closure Static closure (???)
350 con_entry Dynamic Constructor entry code
351 con_info Dynamic Constructor info table
352 static_entry Static Constructor entry code
353 static_info Static Constructor info table
354 sel_info Selector info table
355 sel_entry Selector entry code
358 -- specialised for PprAsm: saves lots of arg passing in NCG
359 #if ! OMIT_NATIVE_CODEGEN
360 pprCLabel_asm = pprCLabel
363 pprCLabel :: CLabel -> SDoc
365 #if ! OMIT_NATIVE_CODEGEN
366 pprCLabel (AsmTempLabel u)
367 = text (fmtAsmLbl (show u))
371 #if ! OMIT_NATIVE_CODEGEN
372 getPprStyle $ \ sty ->
373 if asmStyle sty && underscorePrefix then
374 pp_cSEP <> pprCLbl lbl
379 pprCLbl (CaseLabel u CaseReturnPt)
380 = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
381 pprCLbl (CaseLabel u CaseReturnInfo)
382 = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
383 pprCLbl (CaseLabel u CaseVecTbl)
384 = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
385 pprCLbl (CaseLabel u (CaseAlt tag))
386 = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
387 pprCLbl (CaseLabel u CaseDefault)
388 = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
389 pprCLbl (CaseLabel u CaseBitmap)
390 = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]
392 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry")
394 pprCLbl (RtsLabel RtsUpdEntry) = ptext SLIT("Upd_frame_entry")
396 pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BLACKHOLE_info")
398 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
399 = hcat [ptext SLIT("__sel_"), text (show offset),
401 then SLIT("_upd_info")
402 else SLIT("_noupd_info"))
405 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
406 = hcat [ptext SLIT("__sel_"), text (show offset),
408 then SLIT("_upd_entry")
409 else SLIT("_noupd_entry"))
412 pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
413 = hcat [ptext SLIT("__ap_"), text (show arity),
415 then SLIT("_upd_info")
416 else SLIT("_noupd_info"))
419 pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
420 = hcat [ptext SLIT("__ap_"), text (show arity),
422 then SLIT("_upd_entry")
423 else SLIT("_noupd_entry"))
426 pprCLbl (RtsLabel (RtsPrimOp primop))
427 = pprPrimOp primop <> ptext SLIT("_fast")
429 pprCLbl (TyConLabel tc)
430 = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
432 pprCLbl (IdLabel id flavor) = ppr id <> ppIdFlavor flavor
433 pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
435 pprCLbl (CC_Label cc) = ppr cc
436 pprCLbl (CCS_Label ccs) = ppr ccs
438 ppIdFlavor :: IdLabelInfo -> SDoc
440 ppIdFlavor x = pp_cSEP <>
442 Closure -> ptext SLIT("closure")
443 SRT -> ptext SLIT("srt")
444 InfoTbl -> ptext SLIT("info")
445 EntryStd -> ptext SLIT("entry")
446 EntryFast arity -> --false:ASSERT (arity > 0)
447 (<>) (ptext SLIT("fast")) (int arity)
448 RednCounts -> ptext SLIT("ct")
451 ppConFlavor x = pp_cSEP <>
453 StaticClosure -> ptext SLIT("static_closure")
454 ConEntry -> ptext SLIT("con_entry")
455 ConInfoTbl -> ptext SLIT("con_info")
456 StaticConEntry -> ptext SLIT("static_entry")
457 StaticInfoTbl -> ptext SLIT("static_info")