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 DataCon(..), Id, fIRST_TAG, ConTag(..)
69 #endif {- Data Parallel Haskell -}
72 import Pretty ( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt,
73 ppInteger, ppBeside, ppIntersperse, prettyToUn
75 #ifdef USE_ATTACK_PRAGMAS
78 import Unpretty -- NOTE!! ********************
79 import Unique ( cmpUnique, showUnique, pprUnique, Unique )
83 import AbsCSyn ( MagicId )
84 import PprAbsC ( pprMagicId )
85 #endif {- Data Parallel Haskell -}
87 -- Sigh... Shouldn't this file (CLabelInfo) live in codeGen?
88 import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
92 things we want to find out:
94 * should the labelled things be declared "static" (visible only in this file)?
96 * should it be declared "const" (read-only text space)?
98 * does it need declarations at all? (v common Prelude things are pre-declared)
102 = IdLabel -- A family of labels related to the
103 CLabelId -- definition of a particular Id
104 IdLabelInfo -- Includes DataCon
106 | TyConLabel -- A family of labels related to the
107 TyCon -- definition of a data type
110 | CaseLabel -- A family of labels related to a particular case expression
111 Unique -- Unique says which case expression
114 | AsmTempLabel Unique
116 | RtsLabel RtsLabelInfo
119 | ALocalLabel Unique -- Label within a code block.
121 #endif {- Data Parallel Haskell -}
125 The CLabelId is simply so we can declare alternative Eq and Ord
126 instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
127 comparing the Uniques of two specialised data constructors (which have
128 the same as the uniques their respective unspecialised data
129 constructors). Instead, the specialising types and the uniques of the
130 unspecialised constructors are compared.
133 data CLabelId = CLabelId Id
135 instance Eq CLabelId where
136 CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True; _ -> False }
137 CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True }
139 instance Ord CLabelId where
140 CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b
141 of { LT_ -> True; EQ_ -> True; GT__ -> False }
142 CLabelId a < CLabelId b = case cmpId_withSpecDataCon a b
143 of { LT_ -> True; EQ_ -> False; GT__ -> False }
144 CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b
145 of { LT_ -> False; EQ_ -> True; GT__ -> True }
146 CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b
147 of { LT_ -> False; EQ_ -> False; GT__ -> True }
148 #ifdef __GLASGOW_HASKELL__
149 _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b
150 of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
156 = Closure -- Label for (static???) closure
158 | InfoTbl -- Info table for a closure; always read-only
160 | EntryStd -- Thunk, or "slow", code entry point (requires arg satis check)
161 | EntryFast Int -- entry pt when no arg satisfaction chk needed;
162 -- Int is the arity of the function (to be
163 -- encoded into the name)
165 | ConEntry -- the only kind of entry pt for constructors
166 | StaticConEntry -- static constructor entry point
168 | StaticInfoTbl -- corresponding info table
170 | PhantomInfoTbl -- for phantom constructors that only exist in regs
172 | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
175 -- Ticky-ticky counting
176 | RednCounts -- Label of place to keep reduction-count info for this Id
181 = UnvecConUpdCode -- Update code for the data type if it's unvectored
183 | VecConUpdCode ConTag -- One for each constructor which returns in
184 -- regs; this code actually performs an update
186 | StdUpdCode ConTag -- Update code for all constructors which return
187 -- in heap. There are a small number of variants,
188 -- so that the update code returns (vectored/n or
189 -- unvectored) in the right way.
190 -- ToDo: maybe replace TyCon/Int with return conv.
192 | InfoTblVecTbl -- For tables of info tables
194 | StdUpdVecTbl -- Labels the update code, or table of update codes,
195 -- for a particular type.
206 = RtsShouldNeverHappenCode
208 | RtsBlackHoleInfoTbl
210 | RtsSelectorInfoTbl -- Selectors
211 Bool -- True <=> the update-reqd version;
212 -- False <=> the no-update-reqd version
213 Int -- 0-indexed Offset from the "goods"
215 | RtsSelectorEntry -- Ditto entry code
222 mkClosureLabel id = IdLabel (CLabelId id) Closure
223 mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
224 mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
225 mkFastEntryLabel id arity = --false:ASSERT(arity > 0)
226 IdLabel (CLabelId id) (EntryFast arity)
227 mkConEntryLabel id = IdLabel (CLabelId id) ConEntry
228 mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry
229 mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
230 mkPhantomInfoTableLabel id = IdLabel (CLabelId id) PhantomInfoTbl
231 mkStaticInfoTableLabel id = IdLabel (CLabelId id) StaticInfoTbl
232 mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
233 mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
235 --UNUSED:mkConUpdCodePtrUnvecLabel tycon = TyConLabel tycon UnvecConUpdCode
236 mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
237 mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
239 mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl
240 mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl
242 mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
243 mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
244 mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
245 mkDefaultLabel uniq = CaseLabel uniq CaseDefault
247 mkAsmTempLabel = AsmTempLabel
249 -- Some fixed runtime system labels
251 mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
252 mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
253 --UNUSED:mkSelectorInfoTableLabel upd_reqd offset = RtsLabel (RtsSelectorInfoTbl upd_reqd offset)
254 --UNUSED: mkSelectorEntryLabel upd_reqd offset = RtsLabel (RtsSelectorEntry upd_reqd offset)
257 mkLocalLabel = ALocalLabel
258 #endif {- Data Parallel Haskell -}
262 needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother
263 isReadOnly :: CLabel -> Bool -- lives in C "text space"
264 isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
265 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
268 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
269 object. {\em Also:} No need to spit out labels for things generated
270 by the flattener (in @AbsCFuns@)---it is careful to ensure references
271 to them are always backwards. These are return-point and vector-table
274 Declarations for (non-prelude) @Id@-based things are needed because of
277 needsCDecl (IdLabel _ _) = True -- OLD: not (fromPreludeCore id)
278 needsCDecl (CaseLabel _ _) = False
280 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
281 needsCDecl (TyConLabel _ InfoTblVecTbl) = False
282 needsCDecl (TyConLabel _ other) = True
284 needsCDecl (AsmTempLabel _) = False
285 needsCDecl (RtsLabel _) = False
288 needsCDecl (ALocalLabel _ _) = panic "needsCDecl: Shouldn't call"
289 #endif {- Data Parallel Haskell -}
291 needsCDecl other = True
294 Whether the labelled thing can be put in C "text space":
296 isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
297 isReadOnly (IdLabel _ StaticInfoTbl) = True -- and so on, for other
298 isReadOnly (IdLabel _ PhantomInfoTbl) = True
299 isReadOnly (IdLabel _ (VapInfoTbl _)) = True
300 isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
302 isReadOnly (TyConLabel _ _) = True
303 isReadOnly (CaseLabel _ _) = True
304 isReadOnly (AsmTempLabel _) = True
305 isReadOnly (RtsLabel _) = True
308 isReadOnly (ALocalLabel _ _) = panic "isReadOnly: Shouldn't call"
309 #endif {- Data Parallel Haskell -}
312 Whether the label is an assembler temporary:
314 isAsmTemp (AsmTempLabel _) = True
318 C ``static'' or not...
320 externallyVisibleCLabel (TyConLabel tc _) = not (isBigTupleTyCon tc)
321 -- i.e. not generated for
322 -- purely-local use...
323 externallyVisibleCLabel (CaseLabel _ _) = False
324 externallyVisibleCLabel (AsmTempLabel _) = False
325 externallyVisibleCLabel (RtsLabel _) = True
329 externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
332 -- DPH pays a big price for exported identifiers. For example with
333 -- a statically allocated closure, if it is local to a file it will
334 -- only take up 1 word of storage; exported closures have to go
335 -- in a data section of their own, which gets padded out to a plane size---
336 -- on the DAP510 this is 32 words, DAP610 128 words, DAP710 512 words :-(
337 -- NOTE:16/07/93 Used isInvented (these worker things are globally visible).
338 -- Local labels (i.e ones within a code block) are not visible outside
341 externallyVisibleCLabel (IdLabel (CLabelId id) _) = isInventedTopLevId id || isExported id
342 externallyVisibleCLabel (ALocalLabel _ _) = False
343 #endif {- Data Parallel Haskell -}
346 @isLocalLabel@ determines if a label is local to a block---a different
347 machine code jump is generated.
349 Note(hack after 0.16): Blocks with direct entry points can appear
350 within blocks labelled with a direct entry
351 point --- something todo with let-no-escape.
352 Fast entry blocks arent nestable, however we
353 special case fall through.
356 isLocalLabel::CLabel -> Bool
357 isLocalLabel (ALocalLabel _ _) = True
358 isLocalLabel _ = False
360 isNestableBlockLabel (ALocalLabel _ _) = True
361 isNestableBlockLabel (IdLabel _ EntryStd) = True
362 isNestableBlockLabel (IdLabel _ ConEntry) = True
363 isNestableBlockLabel (IdLabel _ StaticConEntry) = True
364 isNestableBlockLabel _ = False
366 isSlowFastLabelPair :: CLabel -> CLabel -> Bool
367 isSlowFastLabelPair (IdLabel clid EntryStd) (IdLabel clid' (EntryFast _)) = clid == clid'
368 isSlowFastLabelPair _ _ = False
369 #endif {- Data Parallel Haskell -}
372 We need to determine if a label represents a code entity, an ordinary
373 data entity, or a special global data entity (placed at an absolute
374 address by the runtime system that ensures fast loading of variable
375 contents---global ``registers'' such as SuA are placed here as well)
376 (different instructions are used in the DAP machine code).
379 isGlobalDataLabel _ = False
381 isDataLabel :: CLabel -> Bool
382 isDataLabel (IdLabel _ Closure) = True
383 isDataLabel _ = False
385 isVectorTableLabel :: CLabel -> Bool
386 isVectorTableLabel (VecTblCLabel _) = True
387 isVectorTableLabel _ = False
388 #endif {- Data Parallel Haskell -}
391 Sort of like the needsCDecl, we need to stop the assembler from complaining
392 about various data sections :-)
395 needsApalDecl :: CLabel -> Bool
396 needsApalDecl (IdLabel (CLabelId id) Closure) = not (isLocallyDefined id)
397 needsApalDecl _ = False
398 #endif {- Data Parallel Haskell -}
401 These GRAN functions are needed for spitting out GRAN_FETCH() at the
402 right places. It is used to detect when the abstractC statement of an
403 CCodeBlock actually contains the code for a slow entry point. -- HWL
408 isSlowEntryCCodeBlock :: CLabel -> Bool
409 isSlowEntryCCodeBlock _ = False
410 -- Worth keeping? ToDo (WDP)
415 We need at least @Eq@ for @CLabels@, because we want to avoid
416 duplicate declarations in generating C (see @labelSeenTE@ in
420 pprCLabel :: PprStyle -> CLabel -> Unpretty
422 pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u)
423 = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
425 pprCLabel (PprForAsm sw_chker prepend_cSEP _) lbl
427 then uppBeside pp_cSEP prLbl
430 prLbl = pprCLabel (PprForC sw_chker) lbl
432 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
433 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
434 pp_cSEP, uppPStr SLIT("upd")]
436 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
437 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP,
438 uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
440 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
441 = case (ctrlReturnConvAlg tc) of
442 UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
443 VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
445 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
446 = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
448 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
449 = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
450 pp_cSEP, uppPStr SLIT("upd")]
452 pprCLabel sty (CaseLabel u CaseReturnPt)
453 = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
454 pprCLabel sty (CaseLabel u CaseVecTbl)
455 = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
456 pprCLabel sty (CaseLabel u (CaseAlt tag))
457 = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
458 pprCLabel sty (CaseLabel u CaseDefault)
459 = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
461 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
463 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
465 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
466 = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
467 uppStr (if upd_reqd then "upd" else "noupd"),
470 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
471 = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
472 uppStr (if upd_reqd then "upd" else "noupd"),
475 pprCLabel sty (IdLabel (CLabelId id) flavor)
476 = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
479 pprCLabel sty (ALocalLabel u str) = uppBeside (uppStr str) (ppr_u u)
480 #endif {- Data Parallel Haskell -}
482 ppr_u u = prettyToUn (pprUnique u)
484 ppFlavor :: IdLabelInfo -> Unpretty
486 ppFlavor x = uppBeside pp_cSEP
488 Closure -> uppPStr SLIT("closure")
489 InfoTbl -> uppPStr SLIT("info")
490 EntryStd -> uppPStr SLIT("entry")
491 EntryFast arity -> --false:ASSERT (arity > 0)
492 uppBeside (uppPStr SLIT("fast")) (uppInt arity)
493 ConEntry -> uppPStr SLIT("entry")
494 StaticConEntry -> uppPStr SLIT("static_entry")
495 StaticInfoTbl -> uppPStr SLIT("static_info")
496 PhantomInfoTbl -> uppPStr SLIT("inregs_info")
497 VapInfoTbl True -> uppPStr SLIT("vap_info")
498 VapInfoTbl False -> uppPStr SLIT("vap_noupd_info")
499 VapEntry True -> uppPStr SLIT("vap_entry")
500 VapEntry False -> uppPStr SLIT("vap_noupd_entry")
501 RednCounts -> uppPStr SLIT("ct")
504 ppFlavor x = uppStr (case x of
508 EntryFast arity -> "_fast" ++ show arity
510 StaticConEntry -> "_statentr"
511 StaticInfoTbl -> "_statinfo"
512 PhantomInfoTbl -> "_irinfo"
515 #endif {- Data Parallel Haskell -}
527 ' Zq (etc for ops ??)
528 <funny char> Z[hex-digit][hex-digit]
535 cSEP = SLIT("_") -- official C separator
536 pp_cSEP = uppChar '_'
538 identToC :: FAST_STRING -> Pretty
539 modnameToC :: FAST_STRING -> FAST_STRING
540 stringToC :: String -> String
541 charToC, charToEasyHaskell :: Char -> String
543 -- stringToC: the hassle is what to do w/ strings like "ESC 0"...
546 stringToC [c] = charToC c
548 -- if we have something "octifiable" in "c", we'd better "octify"
549 -- the rest of the string, too.
550 = if (c < ' ' || c > '~')
551 then (charToC c) ++ (concat (map char_to_C cs))
552 else (charToC c) ++ (stringToC cs)
554 char_to_C c | c == '\n' = "\\n" -- use C escapes when we can
556 | c == '\b' = "\\b" -- ToDo: chk some of these...
561 | otherwise = '\\' : (octify (ord c))
563 -- OLD?: stringToC str = concat (map charToC str)
565 charToC c = if (c >= ' ' && c <= '~') -- non-portable...
578 else '\\' : (octify (ord c))
580 -- really: charToSimpleHaskell
583 = if (c >= 'a' && c <= 'z')
584 || (c >= 'A' && c <= 'Z')
585 || (c >= '0' && c <= '9')
588 _ -> '\\' : 'o' : (octify (ord c))
590 octify :: Int -> String
595 octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
603 's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
607 (if (all isAlphanum str) -- we gamble that this test will succeed...
609 else ppIntersperse ppNil (map char_to_c str))
611 char_to_c 'Z' = ppPStr SLIT("ZZ")
612 char_to_c '&' = ppPStr SLIT("Za")
613 char_to_c '|' = ppPStr SLIT("Zb")
614 char_to_c ':' = ppPStr SLIT("Zc")
615 char_to_c '/' = ppPStr SLIT("Zd")
616 char_to_c '=' = ppPStr SLIT("Ze")
617 char_to_c '>' = ppPStr SLIT("Zg")
618 char_to_c '#' = ppPStr SLIT("Zh")
619 char_to_c '<' = ppPStr SLIT("Zl")
620 char_to_c '-' = ppPStr SLIT("Zm")
621 char_to_c '!' = ppPStr SLIT("Zn")
622 char_to_c '.' = ppPStr SLIT("Zo")
623 char_to_c '+' = ppPStr SLIT("Zp")
624 char_to_c '\'' = ppPStr SLIT("Zq")
625 char_to_c '*' = ppPStr SLIT("Zt")
626 char_to_c '_' = ppPStr SLIT("Zu")
628 char_to_c c = if isAlphanum c
630 else ppBeside (ppChar 'Z') (ppInt (ord c))
633 For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
634 chars) in the name. Rare.
640 if not (any quote_here str) then
643 _PK_ (concat (map char_to_c str))
645 quote_here '\'' = True
649 = if isAlphanum c then [c] else 'Z' : (show (ord c))