ghc/compiler/basicTypes/CLabelInfo.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[CLabelInfo]{@CLabelInfo@: Information to make C Labels}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module CLabelInfo (
  10         CLabel, -- abstract type
  11
  12         mkClosureLabel,
  13         mkInfoTableLabel,
  14         mkStdEntryLabel,
  15         mkFastEntryLabel,
  16         mkConEntryLabel,
  17         mkStaticConEntryLabel,
  18         mkRednCountsLabel,
  19         mkPhantomInfoTableLabel,
  20         mkStaticInfoTableLabel,
  21         mkVapEntryLabel,
  22         mkVapInfoTableLabel,
  23
  24 --UNUSED: mkConUpdCodePtrUnvecLabel,
  25         mkConUpdCodePtrVecLabel,
  26         mkStdUpdCodePtrVecLabel,
  27
  28         mkInfoTableVecTblLabel,
  29         mkStdUpdVecTblLabel,
  30
  31         mkReturnPtLabel,
  32         mkVecTblLabel,
  33         mkAltLabel,
  34         mkDefaultLabel,
  35
  36         mkAsmTempLabel,
  37
  38         mkErrorStdEntryLabel,
  39         mkBlackHoleInfoTableLabel,
  40 --UNUSED: mkSelectorInfoTableLabel,
  41 --UNUSED: mkSelectorEntryLabel,
  42
  43 #ifdef DPH
  44         mkLocalLabel, isLocalLabel, isNestableBlockLabel,
  45         isGlobalDataLabel, isDataLabel,
  46         needsApalDecl, isVectorTableLabel, isSlowFastLabelPair,
  47 #endif {- Data Parallel Haskell -}
  48
  49         needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
  50
  51         cSEP, identToC, modnameToC, stringToC, charToC, charToEasyHaskell,
  52         pprCLabel,
  53
  54 #ifdef GRAN
  55         isSlowEntryCCodeBlock,
  56 #endif
  57
  58         -- and to make the interface self-sufficient...
  59         Id, TyCon, Unique
  60     ) where
  61
  62 import AbsUniType       ( showTyCon, cmpTyCon, isBigTupleTyCon,
  63                           TyCon, Unique
  64                         )
  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
  69 #ifdef DPH
  70                          ,isInventedTopLevId
  71 #endif {- Data Parallel Haskell -}
  72                         )
  73 import Maybes
  74 import Outputable
  75 import Pretty           ( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt,
  76                           ppInteger, ppBeside, ppIntersperse, prettyToUn
  77                         )
  78 #ifdef USE_ATTACK_PRAGMAS
  79 import CharSeq
  80 #endif
  81 import Unpretty         -- NOTE!! ********************
  82 import Unique           ( cmpUnique, showUnique, pprUnique, Unique )
  83 import Util
  84
  85 #ifdef DPH
  86 import AbsCSyn          ( MagicId )
  87 import PprAbsC          ( pprMagicId )
  88 #endif {- Data Parallel Haskell -}
  89
  90 -- Sigh...  Shouldn't this file (CLabelInfo) live in codeGen?
  91 import CgRetConv        ( CtrlReturnConvention(..), ctrlReturnConvAlg )
  92
  93 \end{code}
  94
  95 things we want to find out:
  96
  97 * should the labelled things be declared "static" (visible only in this file)?
  98
  99 * should it be declared "const" (read-only text space)?
 100
 101 * does it need declarations at all? (v common Prelude things are pre-declared)
 102
 103 \begin{code}
 104 data CLabel
 105   = IdLabel                     -- A family of labels related to the
 106         CLabelId                -- definition of a particular Id
 107         IdLabelInfo             -- Includes DataCon
 108
 109   | TyConLabel                  -- A family of labels related to the
 110         TyCon                   -- definition of a data type
 111         TyConLabelInfo
 112
 113   | CaseLabel                   -- A family of labels related to a particular case expression
 114         Unique                  -- Unique says which case expression
 115         CaseLabelInfo
 116
 117   | AsmTempLabel    Unique
 118
 119   | RtsLabel        RtsLabelInfo
 120
 121 #ifdef DPH
 122   | ALocalLabel     Unique      -- Label within a code block.
 123                     String
 124 #endif {- Data Parallel Haskell -}
 125   deriving (Eq, Ord)
 126 \end{code}
 127
 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.
 134
 135 \begin{code}
 136 data CLabelId = CLabelId Id
 137
 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  }
 141
 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 }
 154 #endif
 155 \end{code}
 156
 157 \begin{code}
 158 data IdLabelInfo
 159   = Closure             -- Label for (static???) closure
 160
 161   | InfoTbl             -- Info table for a closure; always read-only
 162
 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)
 167
 168   | ConEntry            -- the only kind of entry pt for constructors
 169   | StaticConEntry      -- static constructor entry point
 170
 171   | StaticInfoTbl       -- corresponding info table
 172
 173   | PhantomInfoTbl      -- for phantom constructors that only exist in regs
 174
 175   | VapInfoTbl Bool     -- True <=> the update-reqd version; False <=> the no-update-reqd version
 176   | VapEntry Bool
 177
 178         -- Ticky-ticky counting
 179   | RednCounts          -- Label of place to keep reduction-count info for this Id
 180   deriving (Eq, Ord)
 181
 182
 183 data TyConLabelInfo
 184   = UnvecConUpdCode      -- Update code for the data type if it's unvectored
 185
 186   | VecConUpdCode ConTag -- One for each constructor which returns in
 187                          -- regs; this code actually performs an update
 188
 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.
 194
 195   | InfoTblVecTbl        -- For tables of info tables
 196
 197   | StdUpdVecTbl         -- Labels the update code, or table of update codes,
 198                          -- for a particular type.
 199   deriving (Eq, Ord)
 200
 201 data CaseLabelInfo
 202   = CaseReturnPt
 203   | CaseVecTbl
 204   | CaseAlt ConTag
 205   | CaseDefault
 206   deriving (Eq, Ord)
 207
 208 data RtsLabelInfo
 209   = RtsShouldNeverHappenCode
 210
 211   | RtsBlackHoleInfoTbl
 212
 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"
 217
 218   | RtsSelectorEntry    -- Ditto entry code
 219         Bool
 220         Int
 221   deriving (Eq, Ord)
 222 \end{code}
 223
 224 \begin{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)
 237
 238 --UNUSED:mkConUpdCodePtrUnvecLabel tycon     = TyConLabel tycon UnvecConUpdCode
 239 mkConUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (VecConUpdCode tag)
 240 mkStdUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (StdUpdCode tag)
 241
 242 mkInfoTableVecTblLabel    tycon     = TyConLabel tycon InfoTblVecTbl
 243 mkStdUpdVecTblLabel       tycon     = TyConLabel tycon StdUpdVecTbl
 244
 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
 249
 250 mkAsmTempLabel                  = AsmTempLabel
 251
 252         -- Some fixed runtime system labels
 253
 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)
 258
 259 #ifdef DPH
 260 mkLocalLabel = ALocalLabel
 261 #endif {- Data Parallel Haskell -}
 262 \end{code}
 263
 264 \begin{code}
 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"
 269 \end{code}
 270
 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
 275 labels.
 276
 277 Declarations for (non-prelude) @Id@-based things are needed because of
 278 mutual recursion.
 279 \begin{code}
 280 needsCDecl (IdLabel _ _)               = True -- OLD: not (fromPreludeCore id)
 281 needsCDecl (CaseLabel _ _)             = False
 282
 283 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
 284 needsCDecl (TyConLabel _ InfoTblVecTbl)  = False
 285 needsCDecl (TyConLabel _ other)          = True
 286
 287 needsCDecl (AsmTempLabel _)            = False
 288 needsCDecl (RtsLabel _)                = False
 289
 290 #ifdef DPH
 291 needsCDecl (ALocalLabel _ _)           = panic "needsCDecl: Shouldn't call"
 292 #endif {- Data Parallel Haskell -}
 293
 294 needsCDecl other                       = True
 295 \end{code}
 296
 297 Whether the labelled thing can be put in C "text space":
 298 \begin{code}
 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
 304
 305 isReadOnly (TyConLabel _ _)    = True
 306 isReadOnly (CaseLabel _ _)     = True
 307 isReadOnly (AsmTempLabel _)    = True
 308 isReadOnly (RtsLabel _)        = True
 309
 310 #ifdef DPH
 311 isReadOnly (ALocalLabel _ _)   = panic "isReadOnly: Shouldn't call"
 312 #endif {- Data Parallel Haskell -}
 313 \end{code}
 314
 315 Whether the label is an assembler temporary:
 316 \begin{code}
 317 isAsmTemp (AsmTempLabel _) = True
 318 isAsmTemp _                = False
 319 \end{code}
 320
 321 C ``static'' or not...
 322 \begin{code}
 323 externallyVisibleCLabel (TyConLabel tc _) = True
 324 externallyVisibleCLabel (CaseLabel _ _)   = False
 325 externallyVisibleCLabel (AsmTempLabel _)  = False
 326 externallyVisibleCLabel (RtsLabel _)      = True
 327
 328 #ifndef DPH
 329
 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
 338   where
 339     is_ConstMethodId id   = maybeToBool (isConstMethodId_maybe id)
 340     is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
 341     is_SuperDictSelId id  = maybeToBool (isSuperDictSelId_maybe id)
 342 #else
 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
 350 -- a file.
 351
 352 externallyVisibleCLabel (IdLabel (CLabelId id) _) = isInventedTopLevId id || isExported id
 353 externallyVisibleCLabel (ALocalLabel _ _)         = False
 354 #endif {- Data Parallel Haskell -}
 355 \end{code}
 356
 357 @isLocalLabel@ determines if a label is local to a block---a different
 358 machine code jump is generated.
 359
 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.
 365 \begin{code}
 366 #ifdef DPH
 367 isLocalLabel::CLabel -> Bool
 368 isLocalLabel (ALocalLabel _ _) = True
 369 isLocalLabel _                 = False
 370
 371 isNestableBlockLabel (ALocalLabel _ _)          = True
 372 isNestableBlockLabel (IdLabel _ EntryStd)       = True
 373 isNestableBlockLabel (IdLabel _ ConEntry)       = True
 374 isNestableBlockLabel (IdLabel _ StaticConEntry) = True
 375 isNestableBlockLabel _                          = False
 376
 377 isSlowFastLabelPair :: CLabel -> CLabel -> Bool
 378 isSlowFastLabelPair (IdLabel clid EntryStd) (IdLabel clid' (EntryFast _)) = clid == clid'
 379 isSlowFastLabelPair _                       _                             = False
 380 #endif {- Data Parallel Haskell -}
 381 \end{code}
 382
 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).
 388 \begin{code}
 389 #ifdef DPH
 390 isGlobalDataLabel _ = False
 391
 392 isDataLabel :: CLabel -> Bool
 393 isDataLabel (IdLabel _ Closure) = True
 394 isDataLabel _                   = False
 395
 396 isVectorTableLabel :: CLabel -> Bool
 397 isVectorTableLabel (VecTblCLabel _)   = True
 398 isVectorTableLabel _                  = False
 399 #endif {- Data Parallel Haskell -}
 400 \end{code}
 401
 402 Sort of like the needsCDecl, we need to stop the assembler from complaining
 403 about various data sections :-)
 404 \begin{code}
 405 #ifdef DPH
 406 needsApalDecl :: CLabel -> Bool
 407 needsApalDecl (IdLabel (CLabelId id) Closure)  = not (isLocallyDefined id)
 408 needsApalDecl _                                = False
 409 #endif {- Data Parallel Haskell -}
 410 \end{code}
 411
 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
 415
 416 \begin{code}
 417 #ifdef GRAN
 418
 419 isSlowEntryCCodeBlock :: CLabel -> Bool
 420 isSlowEntryCCodeBlock _ = False
 421 -- Worth keeping?  ToDo (WDP)
 422
 423 #endif {-GRAN-}
 424 \end{code}
 425
 426 We need at least @Eq@ for @CLabels@, because we want to avoid
 427 duplicate declarations in generating C (see @labelSeenTE@ in
 428 @PprAbsC@).
 429
 430 \begin{code}
 431 pprCLabel :: PprStyle -> CLabel -> Unpretty
 432
 433 pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u)
 434   = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
 435
 436 pprCLabel (PprForAsm sw_chker prepend_cSEP _) lbl
 437   = if prepend_cSEP
 438     then uppBeside pp_cSEP prLbl
 439     else prLbl
 440   where
 441     prLbl = pprCLabel (PprForC sw_chker) lbl
 442
 443 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
 444   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
 445                pp_cSEP, uppPStr SLIT("upd")]
 446
 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")]
 450
 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))
 455
 456 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
 457   = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
 458
 459 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
 460   = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
 461                pp_cSEP, uppPStr SLIT("upd")]
 462
 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]
 471
 472 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
 473
 474 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
 475
 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"),
 479                 uppPStr SLIT("__")]
 480
 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"),
 484                 uppPStr SLIT("__")]
 485
 486 pprCLabel sty (IdLabel (CLabelId id) flavor)
 487   = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
 488
 489 #ifdef DPH
 490 pprCLabel sty (ALocalLabel u str) = uppBeside (uppStr str) (ppr_u u)
 491 #endif {- Data Parallel Haskell -}
 492
 493 ppr_u u = prettyToUn (pprUnique u)
 494
 495 ppFlavor :: IdLabelInfo -> Unpretty
 496 #ifndef DPH
 497 ppFlavor x = uppBeside pp_cSEP
 498                       (case x of
 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")
 513                       )
 514 #else
 515 ppFlavor x = uppStr (case x of
 516                        Closure          -> "_clos"
 517                        InfoTbl          -> "_info"
 518                        EntryStd         -> "_entry"
 519                        EntryFast arity  -> "_fast" ++ show arity
 520                        ConEntry         -> "_entry"
 521                        StaticConEntry   -> "_statentr"
 522                        StaticInfoTbl    -> "_statinfo"
 523                        PhantomInfoTbl   -> "_irinfo"
 524                        -- ToDo: add more
 525                     )
 526 #endif {- Data Parallel Haskell -}
 527
 528 \end{code}
 529
 530 ToDo:
 531 use Z as escape char
 532 \begin{verbatim}
 533 _       main separator
 534
 535 orig            becomes
 536 ****            *******
 537 _               Zu
 538 '               Zq (etc for ops ??)
 539 <funny char>    Z[hex-digit][hex-digit]
 540 Prelude<x>      ZP<x>
 541 <std class>     ZC<?>
 542 <std tycon>     ZT<?>
 543 \end{verbatim}
 544
 545 \begin{code}
 546 cSEP = SLIT("_")        -- official C separator
 547 pp_cSEP = uppChar '_'
 548
 549 identToC    :: FAST_STRING -> Pretty
 550 modnameToC  :: FAST_STRING -> FAST_STRING
 551 stringToC   :: String -> String
 552 charToC, charToEasyHaskell :: Char -> String
 553
 554 -- stringToC: the hassle is what to do w/ strings like "ESC 0"...
 555
 556 stringToC ""  = ""
 557 stringToC [c] = charToC c
 558 stringToC (c:cs)
 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)
 564   where
 565     char_to_C c | c == '\n' = "\\n"     -- use C escapes when we can
 566                 | c == '\a' = "\\a"
 567                 | c == '\b' = "\\b"     -- ToDo: chk some of these...
 568                 | c == '\r' = "\\r"
 569                 | c == '\t' = "\\t"
 570                 | c == '\f' = "\\f"
 571                 | c == '\v' = "\\v"
 572                 | otherwise = '\\' : (octify (ord c))
 573
 574 -- OLD?: stringToC str = concat (map charToC str)
 575
 576 charToC c = if (c >= ' ' && c <= '~')   -- non-portable...
 577             then case c of
 578                   '\'' -> "\\'"
 579                   '\\' -> "\\\\"
 580                   '"'  -> "\\\""
 581                   '\n' -> "\\n"
 582                   '\a' -> "\\a"
 583                   '\b' -> "\\b"
 584                   '\r' -> "\\r"
 585                   '\t' -> "\\t"
 586                   '\f' -> "\\f"
 587                   '\v' -> "\\v"
 588                   _    -> [c]
 589             else '\\' : (octify (ord c))
 590
 591 -- really: charToSimpleHaskell
 592
 593 charToEasyHaskell c
 594   = if (c >= 'a' && c <= 'z')
 595     || (c >= 'A' && c <= 'Z')
 596     || (c >= '0' && c <= '9')
 597     then [c]
 598     else case c of
 599           _    -> '\\' : 'o' : (octify (ord c))
 600
 601 octify :: Int -> String
 602 octify n
 603   = if n < 8 then
 604         [chr (n + ord '0')]
 605     else
 606         octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
 607
 608 identToC ps
 609   = let
 610         str = _UNPK_ ps
 611     in
 612     ppBeside
 613         (case str of
 614            's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
 615                             ppChar 'Z'
 616            _             -> ppNil)
 617
 618         (if (all isAlphanum str) -- we gamble that this test will succeed...
 619          then ppPStr ps
 620          else ppIntersperse ppNil (map char_to_c str))
 621   where
 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")
 638
 639     char_to_c c    = if isAlphanum c
 640                      then ppChar c
 641                      else ppBeside (ppChar 'Z') (ppInt (ord c))
 642 \end{code}
 643
 644 For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
 645 chars) in the name.  Rare.
 646 \begin{code}
 647 modnameToC ps
 648   = let
 649         str = _UNPK_ ps
 650     in
 651     if not (any quote_here str) then
 652         ps
 653     else
 654         _PK_ (concat (map char_to_c str))
 655   where
 656     quote_here '\'' = True
 657     quote_here _    = False
 658
 659     char_to_c c
 660       = if isAlphanum c then [c] else 'Z' : (show (ord c))
 661 \end{code}