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                           DataCon(..), Id, fIRST_TAG, ConTag(..)
  67 #ifdef DPH
  68                          ,isInventedTopLevId
  69 #endif {- Data Parallel Haskell -}
  70                         )
  71 import Outputable
  72 import Pretty           ( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt,
  73                           ppInteger, ppBeside, ppIntersperse, prettyToUn
  74                         )
  75 #ifdef USE_ATTACK_PRAGMAS
  76 import CharSeq
  77 #endif
  78 import Unpretty         -- NOTE!! ********************
  79 import Unique           ( cmpUnique, showUnique, pprUnique, Unique )
  80 import Util
  81
  82 #ifdef DPH
  83 import AbsCSyn          ( MagicId )
  84 import PprAbsC          ( pprMagicId )
  85 #endif {- Data Parallel Haskell -}
  86
  87 -- Sigh...  Shouldn't this file (CLabelInfo) live in codeGen?
  88 import CgRetConv        ( CtrlReturnConvention(..), ctrlReturnConvAlg )
  89
  90 \end{code}
  91
  92 things we want to find out:
  93
  94 * should the labelled things be declared "static" (visible only in this file)?
  95
  96 * should it be declared "const" (read-only text space)?
  97
  98 * does it need declarations at all? (v common Prelude things are pre-declared)
  99
 100 \begin{code}
 101 data CLabel
 102   = IdLabel                     -- A family of labels related to the
 103         CLabelId                -- definition of a particular Id
 104         IdLabelInfo             -- Includes DataCon
 105
 106   | TyConLabel                  -- A family of labels related to the
 107         TyCon                   -- definition of a data type
 108         TyConLabelInfo
 109
 110   | CaseLabel                   -- A family of labels related to a particular case expression
 111         Unique                  -- Unique says which case expression
 112         CaseLabelInfo
 113
 114   | AsmTempLabel    Unique
 115
 116   | RtsLabel        RtsLabelInfo
 117
 118 #ifdef DPH
 119   | ALocalLabel     Unique      -- Label within a code block.
 120                     String
 121 #endif {- Data Parallel Haskell -}
 122   deriving (Eq, Ord)
 123 \end{code}
 124
 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.
 131
 132 \begin{code}
 133 data CLabelId = CLabelId Id
 134
 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  }
 138
 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 }
 151 #endif
 152 \end{code}
 153
 154 \begin{code}
 155 data IdLabelInfo
 156   = Closure             -- Label for (static???) closure
 157
 158   | InfoTbl             -- Info table for a closure; always read-only
 159
 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)
 164
 165   | ConEntry            -- the only kind of entry pt for constructors
 166   | StaticConEntry      -- static constructor entry point
 167
 168   | StaticInfoTbl       -- corresponding info table
 169
 170   | PhantomInfoTbl      -- for phantom constructors that only exist in regs
 171
 172   | VapInfoTbl Bool     -- True <=> the update-reqd version; False <=> the no-update-reqd version
 173   | VapEntry Bool
 174
 175         -- Ticky-ticky counting
 176   | RednCounts          -- Label of place to keep reduction-count info for this Id
 177   deriving (Eq, Ord)
 178
 179
 180 data TyConLabelInfo
 181   = UnvecConUpdCode      -- Update code for the data type if it's unvectored
 182
 183   | VecConUpdCode ConTag -- One for each constructor which returns in
 184                          -- regs; this code actually performs an update
 185
 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.
 191
 192   | InfoTblVecTbl        -- For tables of info tables
 193
 194   | StdUpdVecTbl         -- Labels the update code, or table of update codes,
 195                          -- for a particular type.
 196   deriving (Eq, Ord)
 197
 198 data CaseLabelInfo
 199   = CaseReturnPt
 200   | CaseVecTbl
 201   | CaseAlt ConTag
 202   | CaseDefault
 203   deriving (Eq, Ord)
 204
 205 data RtsLabelInfo
 206   = RtsShouldNeverHappenCode
 207
 208   | RtsBlackHoleInfoTbl
 209
 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"
 214
 215   | RtsSelectorEntry    -- Ditto entry code
 216         Bool
 217         Int
 218   deriving (Eq, Ord)
 219 \end{code}
 220
 221 \begin{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)
 234
 235 --UNUSED:mkConUpdCodePtrUnvecLabel tycon     = TyConLabel tycon UnvecConUpdCode
 236 mkConUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (VecConUpdCode tag)
 237 mkStdUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (StdUpdCode tag)
 238
 239 mkInfoTableVecTblLabel    tycon     = TyConLabel tycon InfoTblVecTbl
 240 mkStdUpdVecTblLabel       tycon     = TyConLabel tycon StdUpdVecTbl
 241
 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
 246
 247 mkAsmTempLabel                  = AsmTempLabel
 248
 249         -- Some fixed runtime system labels
 250
 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)
 255
 256 #ifdef DPH
 257 mkLocalLabel = ALocalLabel
 258 #endif {- Data Parallel Haskell -}
 259 \end{code}
 260
 261 \begin{code}
 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"
 266 \end{code}
 267
 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
 272 labels.
 273
 274 Declarations for (non-prelude) @Id@-based things are needed because of
 275 mutual recursion.
 276 \begin{code}
 277 needsCDecl (IdLabel _ _)               = True -- OLD: not (fromPreludeCore id)
 278 needsCDecl (CaseLabel _ _)             = False
 279
 280 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
 281 needsCDecl (TyConLabel _ InfoTblVecTbl)  = False
 282 needsCDecl (TyConLabel _ other)          = True
 283
 284 needsCDecl (AsmTempLabel _)            = False
 285 needsCDecl (RtsLabel _)                = False
 286
 287 #ifdef DPH
 288 needsCDecl (ALocalLabel _ _)           = panic "needsCDecl: Shouldn't call"
 289 #endif {- Data Parallel Haskell -}
 290
 291 needsCDecl other                       = True
 292 \end{code}
 293
 294 Whether the labelled thing can be put in C "text space":
 295 \begin{code}
 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
 301
 302 isReadOnly (TyConLabel _ _)    = True
 303 isReadOnly (CaseLabel _ _)     = True
 304 isReadOnly (AsmTempLabel _)    = True
 305 isReadOnly (RtsLabel _)        = True
 306
 307 #ifdef DPH
 308 isReadOnly (ALocalLabel _ _)   = panic "isReadOnly: Shouldn't call"
 309 #endif {- Data Parallel Haskell -}
 310 \end{code}
 311
 312 Whether the label is an assembler temporary:
 313 \begin{code}
 314 isAsmTemp (AsmTempLabel _) = True
 315 isAsmTemp _                = False
 316 \end{code}
 317
 318 C ``static'' or not...
 319 \begin{code}
 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
 326
 327 #ifndef DPH
 328
 329 externallyVisibleCLabel (IdLabel (CLabelId id) _)   = externallyVisibleId id
 330
 331 #else
 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
 339 -- a file.
 340
 341 externallyVisibleCLabel (IdLabel (CLabelId id) _) = isInventedTopLevId id || isExported id
 342 externallyVisibleCLabel (ALocalLabel _ _)         = False
 343 #endif {- Data Parallel Haskell -}
 344 \end{code}
 345
 346 @isLocalLabel@ determines if a label is local to a block---a different
 347 machine code jump is generated.
 348
 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.
 354 \begin{code}
 355 #ifdef DPH
 356 isLocalLabel::CLabel -> Bool
 357 isLocalLabel (ALocalLabel _ _) = True
 358 isLocalLabel _                 = False
 359
 360 isNestableBlockLabel (ALocalLabel _ _)          = True
 361 isNestableBlockLabel (IdLabel _ EntryStd)       = True
 362 isNestableBlockLabel (IdLabel _ ConEntry)       = True
 363 isNestableBlockLabel (IdLabel _ StaticConEntry) = True
 364 isNestableBlockLabel _                          = False
 365
 366 isSlowFastLabelPair :: CLabel -> CLabel -> Bool
 367 isSlowFastLabelPair (IdLabel clid EntryStd) (IdLabel clid' (EntryFast _)) = clid == clid'
 368 isSlowFastLabelPair _                       _                             = False
 369 #endif {- Data Parallel Haskell -}
 370 \end{code}
 371
 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).
 377 \begin{code}
 378 #ifdef DPH
 379 isGlobalDataLabel _ = False
 380
 381 isDataLabel :: CLabel -> Bool
 382 isDataLabel (IdLabel _ Closure) = True
 383 isDataLabel _                   = False
 384
 385 isVectorTableLabel :: CLabel -> Bool
 386 isVectorTableLabel (VecTblCLabel _)   = True
 387 isVectorTableLabel _                  = False
 388 #endif {- Data Parallel Haskell -}
 389 \end{code}
 390
 391 Sort of like the needsCDecl, we need to stop the assembler from complaining
 392 about various data sections :-)
 393 \begin{code}
 394 #ifdef DPH
 395 needsApalDecl :: CLabel -> Bool
 396 needsApalDecl (IdLabel (CLabelId id) Closure)  = not (isLocallyDefined id)
 397 needsApalDecl _                                = False
 398 #endif {- Data Parallel Haskell -}
 399 \end{code}
 400
 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
 404
 405 \begin{code}
 406 #ifdef GRAN
 407
 408 isSlowEntryCCodeBlock :: CLabel -> Bool
 409 isSlowEntryCCodeBlock _ = False
 410 -- Worth keeping?  ToDo (WDP)
 411
 412 #endif {-GRAN-}
 413 \end{code}
 414
 415 We need at least @Eq@ for @CLabels@, because we want to avoid
 416 duplicate declarations in generating C (see @labelSeenTE@ in
 417 @PprAbsC@).
 418
 419 \begin{code}
 420 pprCLabel :: PprStyle -> CLabel -> Unpretty
 421
 422 pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u)
 423   = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
 424
 425 pprCLabel (PprForAsm sw_chker prepend_cSEP _) lbl
 426   = if prepend_cSEP
 427     then uppBeside pp_cSEP prLbl
 428     else prLbl
 429   where
 430     prLbl = pprCLabel (PprForC sw_chker) lbl
 431
 432 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
 433   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
 434                pp_cSEP, uppPStr SLIT("upd")]
 435
 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")]
 439
 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))
 444
 445 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
 446   = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
 447
 448 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
 449   = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
 450                pp_cSEP, uppPStr SLIT("upd")]
 451
 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]
 460
 461 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
 462
 463 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
 464
 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"),
 468                 uppPStr SLIT("__")]
 469
 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"),
 473                 uppPStr SLIT("__")]
 474
 475 pprCLabel sty (IdLabel (CLabelId id) flavor)
 476   = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
 477
 478 #ifdef DPH
 479 pprCLabel sty (ALocalLabel u str) = uppBeside (uppStr str) (ppr_u u)
 480 #endif {- Data Parallel Haskell -}
 481
 482 ppr_u u = prettyToUn (pprUnique u)
 483
 484 ppFlavor :: IdLabelInfo -> Unpretty
 485 #ifndef DPH
 486 ppFlavor x = uppBeside pp_cSEP
 487                       (case x of
 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")
 502                       )
 503 #else
 504 ppFlavor x = uppStr (case x of
 505                        Closure          -> "_clos"
 506                        InfoTbl          -> "_info"
 507                        EntryStd         -> "_entry"
 508                        EntryFast arity  -> "_fast" ++ show arity
 509                        ConEntry         -> "_entry"
 510                        StaticConEntry   -> "_statentr"
 511                        StaticInfoTbl    -> "_statinfo"
 512                        PhantomInfoTbl   -> "_irinfo"
 513                        -- ToDo: add more
 514                     )
 515 #endif {- Data Parallel Haskell -}
 516
 517 \end{code}
 518
 519 ToDo:
 520 use Z as escape char
 521 \begin{verbatim}
 522 _       main separator
 523
 524 orig            becomes
 525 ****            *******
 526 _               Zu
 527 '               Zq (etc for ops ??)
 528 <funny char>    Z[hex-digit][hex-digit]
 529 Prelude<x>      ZP<x>
 530 <std class>     ZC<?>
 531 <std tycon>     ZT<?>
 532 \end{verbatim}
 533
 534 \begin{code}
 535 cSEP = SLIT("_")        -- official C separator
 536 pp_cSEP = uppChar '_'
 537
 538 identToC    :: FAST_STRING -> Pretty
 539 modnameToC  :: FAST_STRING -> FAST_STRING
 540 stringToC   :: String -> String
 541 charToC, charToEasyHaskell :: Char -> String
 542
 543 -- stringToC: the hassle is what to do w/ strings like "ESC 0"...
 544
 545 stringToC ""  = ""
 546 stringToC [c] = charToC c
 547 stringToC (c:cs)
 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)
 553   where
 554     char_to_C c | c == '\n' = "\\n"     -- use C escapes when we can
 555                 | c == '\a' = "\\a"
 556                 | c == '\b' = "\\b"     -- ToDo: chk some of these...
 557                 | c == '\r' = "\\r"
 558                 | c == '\t' = "\\t"
 559                 | c == '\f' = "\\f"
 560                 | c == '\v' = "\\v"
 561                 | otherwise = '\\' : (octify (ord c))
 562
 563 -- OLD?: stringToC str = concat (map charToC str)
 564
 565 charToC c = if (c >= ' ' && c <= '~')   -- non-portable...
 566             then case c of
 567                   '\'' -> "\\'"
 568                   '\\' -> "\\\\"
 569                   '"'  -> "\\\""
 570                   '\n' -> "\\n"
 571                   '\a' -> "\\a"
 572                   '\b' -> "\\b"
 573                   '\r' -> "\\r"
 574                   '\t' -> "\\t"
 575                   '\f' -> "\\f"
 576                   '\v' -> "\\v"
 577                   _    -> [c]
 578             else '\\' : (octify (ord c))
 579
 580 -- really: charToSimpleHaskell
 581
 582 charToEasyHaskell c
 583   = if (c >= 'a' && c <= 'z')
 584     || (c >= 'A' && c <= 'Z')
 585     || (c >= '0' && c <= '9')
 586     then [c]
 587     else case c of
 588           _    -> '\\' : 'o' : (octify (ord c))
 589
 590 octify :: Int -> String
 591 octify n
 592   = if n < 8 then
 593         [chr (n + ord '0')]
 594     else
 595         octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
 596
 597 identToC ps
 598   = let
 599         str = _UNPK_ ps
 600     in
 601     ppBeside
 602         (case str of
 603            's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
 604                             ppChar 'Z'
 605            _             -> ppNil)
 606
 607         (if (all isAlphanum str) -- we gamble that this test will succeed...
 608          then ppPStr ps
 609          else ppIntersperse ppNil (map char_to_c str))
 610   where
 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")
 627
 628     char_to_c c    = if isAlphanum c
 629                      then ppChar c
 630                      else ppBeside (ppChar 'Z') (ppInt (ord c))
 631 \end{code}
 632
 633 For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
 634 chars) in the name.  Rare.
 635 \begin{code}
 636 modnameToC ps
 637   = let
 638         str = _UNPK_ ps
 639     in
 640     if not (any quote_here str) then
 641         ps
 642     else
 643         _PK_ (concat (map char_to_c str))
 644   where
 645     quote_here '\'' = True
 646     quote_here _    = False
 647
 648     char_to_c c
 649       = if isAlphanum c then [c] else 'Z' : (show (ord c))
 650 \end{code}