2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[CLabelInfo]{@CLabelInfo@: Information to make C Labels}
7 #include "HsVersions.h"
10 CLabel, -- abstract type
17 mkStaticConEntryLabel,
19 mkPhantomInfoTableLabel,
20 mkStaticInfoTableLabel,
24 --UNUSED: mkConUpdCodePtrUnvecLabel,
25 mkConUpdCodePtrVecLabel,
26 mkStdUpdCodePtrVecLabel,
28 mkInfoTableVecTblLabel,
39 mkBlackHoleInfoTableLabel,
40 --UNUSED: mkSelectorInfoTableLabel,
41 --UNUSED: mkSelectorEntryLabel,
44 mkLocalLabel, isLocalLabel, isNestableBlockLabel,
45 isGlobalDataLabel, isDataLabel,
46 needsApalDecl, isVectorTableLabel, isSlowFastLabelPair,
47 #endif {- Data Parallel Haskell -}
49 needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
51 cSEP, identToC, modnameToC, stringToC, charToC, charToEasyHaskell,
55 isSlowEntryCCodeBlock,
58 -- and to make the interface self-sufficient...
62 import AbsUniType ( showTyCon, cmpTyCon, isBigTupleTyCon,
65 import Id ( externallyVisibleId, cmpId_withSpecDataCon,
66 isDataCon, isDictFunId, isConstMethodId_maybe,
67 isClassOpId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
68 Id, Class, ClassOp, DataCon(..), ConTag(..), fIRST_TAG
71 #endif {- Data Parallel Haskell -}
75 import Pretty ( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt,
76 ppInteger, ppBeside, ppIntersperse, prettyToUn
78 #ifdef USE_ATTACK_PRAGMAS
81 import Unpretty -- NOTE!! ********************
82 import Unique ( cmpUnique, showUnique, pprUnique, Unique )
86 import AbsCSyn ( MagicId )
87 import PprAbsC ( pprMagicId )
88 #endif {- Data Parallel Haskell -}
90 -- Sigh... Shouldn't this file (CLabelInfo) live in codeGen?
91 import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
95 things we want to find out:
97 * should the labelled things be declared "static" (visible only in this file)?
99 * should it be declared "const" (read-only text space)?
101 * does it need declarations at all? (v common Prelude things are pre-declared)
105 = IdLabel -- A family of labels related to the
106 CLabelId -- definition of a particular Id
107 IdLabelInfo -- Includes DataCon
109 | TyConLabel -- A family of labels related to the
110 TyCon -- definition of a data type
113 | CaseLabel -- A family of labels related to a particular case expression
114 Unique -- Unique says which case expression
117 | AsmTempLabel Unique
119 | RtsLabel RtsLabelInfo
122 | ALocalLabel Unique -- Label within a code block.
124 #endif {- Data Parallel Haskell -}
128 The CLabelId is simply so we can declare alternative Eq and Ord
129 instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
130 comparing the Uniques of two specialised data constructors (which have
131 the same as the uniques their respective unspecialised data
132 constructors). Instead, the specialising types and the uniques of the
133 unspecialised constructors are compared.
136 data CLabelId = CLabelId Id
138 instance Eq CLabelId where
139 CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True; _ -> False }
140 CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True }
142 instance Ord CLabelId where
143 CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b
144 of { LT_ -> True; EQ_ -> True; GT__ -> False }
145 CLabelId a < CLabelId b = case cmpId_withSpecDataCon a b
146 of { LT_ -> True; EQ_ -> False; GT__ -> False }
147 CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b
148 of { LT_ -> False; EQ_ -> True; GT__ -> True }
149 CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b
150 of { LT_ -> False; EQ_ -> False; GT__ -> True }
151 #ifdef __GLASGOW_HASKELL__
152 _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b
153 of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
159 = Closure -- Label for (static???) closure
161 | InfoTbl -- Info table for a closure; always read-only
163 | EntryStd -- Thunk, or "slow", code entry point (requires arg satis check)
164 | EntryFast Int -- entry pt when no arg satisfaction chk needed;
165 -- Int is the arity of the function (to be
166 -- encoded into the name)
168 | ConEntry -- the only kind of entry pt for constructors
169 | StaticConEntry -- static constructor entry point
171 | StaticInfoTbl -- corresponding info table
173 | PhantomInfoTbl -- for phantom constructors that only exist in regs
175 | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
178 -- Ticky-ticky counting
179 | RednCounts -- Label of place to keep reduction-count info for this Id
184 = UnvecConUpdCode -- Update code for the data type if it's unvectored
186 | VecConUpdCode ConTag -- One for each constructor which returns in
187 -- regs; this code actually performs an update
189 | StdUpdCode ConTag -- Update code for all constructors which return
190 -- in heap. There are a small number of variants,
191 -- so that the update code returns (vectored/n or
192 -- unvectored) in the right way.
193 -- ToDo: maybe replace TyCon/Int with return conv.
195 | InfoTblVecTbl -- For tables of info tables
197 | StdUpdVecTbl -- Labels the update code, or table of update codes,
198 -- for a particular type.
209 = RtsShouldNeverHappenCode
211 | RtsBlackHoleInfoTbl
213 | RtsSelectorInfoTbl -- Selectors
214 Bool -- True <=> the update-reqd version;
215 -- False <=> the no-update-reqd version
216 Int -- 0-indexed Offset from the "goods"
218 | RtsSelectorEntry -- Ditto entry code
225 mkClosureLabel id = IdLabel (CLabelId id) Closure
226 mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
227 mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
228 mkFastEntryLabel id arity = ASSERT(arity > 0)
229 IdLabel (CLabelId id) (EntryFast arity)
230 mkConEntryLabel id = IdLabel (CLabelId id) ConEntry
231 mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry
232 mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
233 mkPhantomInfoTableLabel id = IdLabel (CLabelId id) PhantomInfoTbl
234 mkStaticInfoTableLabel id = IdLabel (CLabelId id) StaticInfoTbl
235 mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
236 mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
238 --UNUSED:mkConUpdCodePtrUnvecLabel tycon = TyConLabel tycon UnvecConUpdCode
239 mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
240 mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
242 mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl
243 mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl
245 mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
246 mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
247 mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
248 mkDefaultLabel uniq = CaseLabel uniq CaseDefault
250 mkAsmTempLabel = AsmTempLabel
252 -- Some fixed runtime system labels
254 mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
255 mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
256 --UNUSED:mkSelectorInfoTableLabel upd_reqd offset = RtsLabel (RtsSelectorInfoTbl upd_reqd offset)
257 --UNUSED: mkSelectorEntryLabel upd_reqd offset = RtsLabel (RtsSelectorEntry upd_reqd offset)
260 mkLocalLabel = ALocalLabel
261 #endif {- Data Parallel Haskell -}
265 needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother
266 isReadOnly :: CLabel -> Bool -- lives in C "text space"
267 isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
268 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
271 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
272 object. {\em Also:} No need to spit out labels for things generated
273 by the flattener (in @AbsCFuns@)---it is careful to ensure references
274 to them are always backwards. These are return-point and vector-table
277 Declarations for (non-prelude) @Id@-based things are needed because of
280 needsCDecl (IdLabel _ _) = True -- OLD: not (fromPreludeCore id)
281 needsCDecl (CaseLabel _ _) = False
283 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
284 needsCDecl (TyConLabel _ InfoTblVecTbl) = False
285 needsCDecl (TyConLabel _ other) = True
287 needsCDecl (AsmTempLabel _) = False
288 needsCDecl (RtsLabel _) = False
291 needsCDecl (ALocalLabel _ _) = panic "needsCDecl: Shouldn't call"
292 #endif {- Data Parallel Haskell -}
294 needsCDecl other = True
297 Whether the labelled thing can be put in C "text space":
299 isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
300 isReadOnly (IdLabel _ StaticInfoTbl) = True -- and so on, for other
301 isReadOnly (IdLabel _ PhantomInfoTbl) = True
302 isReadOnly (IdLabel _ (VapInfoTbl _)) = True
303 isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
305 isReadOnly (TyConLabel _ _) = True
306 isReadOnly (CaseLabel _ _) = True
307 isReadOnly (AsmTempLabel _) = True
308 isReadOnly (RtsLabel _) = True
311 isReadOnly (ALocalLabel _ _) = panic "isReadOnly: Shouldn't call"
312 #endif {- Data Parallel Haskell -}
315 Whether the label is an assembler temporary:
317 isAsmTemp (AsmTempLabel _) = True
321 C ``static'' or not...
323 externallyVisibleCLabel (TyConLabel tc _) = True
324 externallyVisibleCLabel (CaseLabel _ _) = False
325 externallyVisibleCLabel (AsmTempLabel _) = False
326 externallyVisibleCLabel (RtsLabel _) = True
330 externallyVisibleCLabel (IdLabel (CLabelId id) _)
331 | isDataCon id = True
332 | is_ConstMethodId id = True -- These are here to ensure splitting works
333 | isDictFunId id = True -- when these values have not been exported
334 | isClassOpId id = True
335 | is_DefaultMethodId id = True
336 | is_SuperDictSelId id = True
337 | otherwise = externallyVisibleId id
339 is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id)
340 is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
341 is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id)
343 -- DPH pays a big price for exported identifiers. For example with
344 -- a statically allocated closure, if it is local to a file it will
345 -- only take up 1 word of storage; exported closures have to go
346 -- in a data section of their own, which gets padded out to a plane size---
347 -- on the DAP510 this is 32 words, DAP610 128 words, DAP710 512 words :-(
348 -- NOTE:16/07/93 Used isInvented (these worker things are globally visible).
349 -- Local labels (i.e ones within a code block) are not visible outside
352 externallyVisibleCLabel (IdLabel (CLabelId id) _) = isInventedTopLevId id || isExported id
353 externallyVisibleCLabel (ALocalLabel _ _) = False
354 #endif {- Data Parallel Haskell -}
357 @isLocalLabel@ determines if a label is local to a block---a different
358 machine code jump is generated.
360 Note(hack after 0.16): Blocks with direct entry points can appear
361 within blocks labelled with a direct entry
362 point --- something todo with let-no-escape.
363 Fast entry blocks arent nestable, however we
364 special case fall through.
367 isLocalLabel::CLabel -> Bool
368 isLocalLabel (ALocalLabel _ _) = True
369 isLocalLabel _ = False
371 isNestableBlockLabel (ALocalLabel _ _) = True
372 isNestableBlockLabel (IdLabel _ EntryStd) = True
373 isNestableBlockLabel (IdLabel _ ConEntry) = True
374 isNestableBlockLabel (IdLabel _ StaticConEntry) = True
375 isNestableBlockLabel _ = False
377 isSlowFastLabelPair :: CLabel -> CLabel -> Bool
378 isSlowFastLabelPair (IdLabel clid EntryStd) (IdLabel clid' (EntryFast _)) = clid == clid'
379 isSlowFastLabelPair _ _ = False
380 #endif {- Data Parallel Haskell -}
383 We need to determine if a label represents a code entity, an ordinary
384 data entity, or a special global data entity (placed at an absolute
385 address by the runtime system that ensures fast loading of variable
386 contents---global ``registers'' such as SuA are placed here as well)
387 (different instructions are used in the DAP machine code).
390 isGlobalDataLabel _ = False
392 isDataLabel :: CLabel -> Bool
393 isDataLabel (IdLabel _ Closure) = True
394 isDataLabel _ = False
396 isVectorTableLabel :: CLabel -> Bool
397 isVectorTableLabel (VecTblCLabel _) = True
398 isVectorTableLabel _ = False
399 #endif {- Data Parallel Haskell -}
402 Sort of like the needsCDecl, we need to stop the assembler from complaining
403 about various data sections :-)
406 needsApalDecl :: CLabel -> Bool
407 needsApalDecl (IdLabel (CLabelId id) Closure) = not (isLocallyDefined id)
408 needsApalDecl _ = False
409 #endif {- Data Parallel Haskell -}
412 These GRAN functions are needed for spitting out GRAN_FETCH() at the
413 right places. It is used to detect when the abstractC statement of an
414 CCodeBlock actually contains the code for a slow entry point. -- HWL
419 isSlowEntryCCodeBlock :: CLabel -> Bool
420 isSlowEntryCCodeBlock _ = False
421 -- Worth keeping? ToDo (WDP)
426 We need at least @Eq@ for @CLabels@, because we want to avoid
427 duplicate declarations in generating C (see @labelSeenTE@ in
431 pprCLabel :: PprStyle -> CLabel -> Unpretty
433 pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u)
434 = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
436 pprCLabel (PprForAsm sw_chker prepend_cSEP _) lbl
438 then uppBeside pp_cSEP prLbl
441 prLbl = pprCLabel (PprForC sw_chker) lbl
443 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
444 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
445 pp_cSEP, uppPStr SLIT("upd")]
447 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
448 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP,
449 uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
451 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
452 = case (ctrlReturnConvAlg tc) of
453 UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
454 VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
456 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
457 = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
459 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
460 = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
461 pp_cSEP, uppPStr SLIT("upd")]
463 pprCLabel sty (CaseLabel u CaseReturnPt)
464 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
465 pprCLabel sty (CaseLabel u CaseVecTbl)
466 = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
467 pprCLabel sty (CaseLabel u (CaseAlt tag))
468 = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
469 pprCLabel sty (CaseLabel u CaseDefault)
470 = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
472 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
474 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
476 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
477 = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
478 uppStr (if upd_reqd then "upd" else "noupd"),
481 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
482 = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
483 uppStr (if upd_reqd then "upd" else "noupd"),
486 pprCLabel sty (IdLabel (CLabelId id) flavor)
487 = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
490 pprCLabel sty (ALocalLabel u str) = uppBeside (uppStr str) (ppr_u u)
491 #endif {- Data Parallel Haskell -}
493 ppr_u u = prettyToUn (pprUnique u)
495 ppFlavor :: IdLabelInfo -> Unpretty
497 ppFlavor x = uppBeside pp_cSEP
499 Closure -> uppPStr SLIT("closure")
500 InfoTbl -> uppPStr SLIT("info")
501 EntryStd -> uppPStr SLIT("entry")
502 EntryFast arity -> --false:ASSERT (arity > 0)
503 uppBeside (uppPStr SLIT("fast")) (uppInt arity)
504 ConEntry -> uppPStr SLIT("entry")
505 StaticConEntry -> uppPStr SLIT("static_entry")
506 StaticInfoTbl -> uppPStr SLIT("static_info")
507 PhantomInfoTbl -> uppPStr SLIT("inregs_info")
508 VapInfoTbl True -> uppPStr SLIT("vap_info")
509 VapInfoTbl False -> uppPStr SLIT("vap_noupd_info")
510 VapEntry True -> uppPStr SLIT("vap_entry")
511 VapEntry False -> uppPStr SLIT("vap_noupd_entry")
512 RednCounts -> uppPStr SLIT("ct")
515 ppFlavor x = uppStr (case x of
519 EntryFast arity -> "_fast" ++ show arity
521 StaticConEntry -> "_statentr"
522 StaticInfoTbl -> "_statinfo"
523 PhantomInfoTbl -> "_irinfo"
526 #endif {- Data Parallel Haskell -}
538 ' Zq (etc for ops ??)
539 <funny char> Z[hex-digit][hex-digit]
546 cSEP = SLIT("_") -- official C separator
547 pp_cSEP = uppChar '_'
549 identToC :: FAST_STRING -> Pretty
550 modnameToC :: FAST_STRING -> FAST_STRING
551 stringToC :: String -> String
552 charToC, charToEasyHaskell :: Char -> String
554 -- stringToC: the hassle is what to do w/ strings like "ESC 0"...
557 stringToC [c] = charToC c
559 -- if we have something "octifiable" in "c", we'd better "octify"
560 -- the rest of the string, too.
561 = if (c < ' ' || c > '~')
562 then (charToC c) ++ (concat (map char_to_C cs))
563 else (charToC c) ++ (stringToC cs)
565 char_to_C c | c == '\n' = "\\n" -- use C escapes when we can
567 | c == '\b' = "\\b" -- ToDo: chk some of these...
572 | otherwise = '\\' : (octify (ord c))
574 -- OLD?: stringToC str = concat (map charToC str)
576 charToC c = if (c >= ' ' && c <= '~') -- non-portable...
589 else '\\' : (octify (ord c))
591 -- really: charToSimpleHaskell
594 = if (c >= 'a' && c <= 'z')
595 || (c >= 'A' && c <= 'Z')
596 || (c >= '0' && c <= '9')
599 _ -> '\\' : 'o' : (octify (ord c))
601 octify :: Int -> String
606 octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
614 's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
618 (if (all isAlphanum str) -- we gamble that this test will succeed...
620 else ppIntersperse ppNil (map char_to_c str))
622 char_to_c 'Z' = ppPStr SLIT("ZZ")
623 char_to_c '&' = ppPStr SLIT("Za")
624 char_to_c '|' = ppPStr SLIT("Zb")
625 char_to_c ':' = ppPStr SLIT("Zc")
626 char_to_c '/' = ppPStr SLIT("Zd")
627 char_to_c '=' = ppPStr SLIT("Ze")
628 char_to_c '>' = ppPStr SLIT("Zg")
629 char_to_c '#' = ppPStr SLIT("Zh")
630 char_to_c '<' = ppPStr SLIT("Zl")
631 char_to_c '-' = ppPStr SLIT("Zm")
632 char_to_c '!' = ppPStr SLIT("Zn")
633 char_to_c '.' = ppPStr SLIT("Zo")
634 char_to_c '+' = ppPStr SLIT("Zp")
635 char_to_c '\'' = ppPStr SLIT("Zq")
636 char_to_c '*' = ppPStr SLIT("Zt")
637 char_to_c '_' = ppPStr SLIT("Zu")
639 char_to_c c = if isAlphanum c
641 else ppBeside (ppChar 'Z') (ppInt (ord c))
644 For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
645 chars) in the name. Rare.
651 if not (any quote_here str) then
654 _PK_ (concat (map char_to_c str))
656 quote_here '\'' = True
660 = if isAlphanum c then [c] else 'Z' : (show (ord c))