ghc/compiler/absCSyn/PprAbsC.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[PprAbsC]{Pretty-printing Abstract~C}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module PprAbsC (
  14         writeRealC,
  15         dumpRealC
  16 #ifdef DEBUG
  17         , pprAmode -- otherwise, not exported
  18 #endif
  19     ) where
  20
  21 IMP_Ubiq(){-uitous-}
  22 IMPORT_DELOOPER(AbsCLoop)               -- break its dependence on ClosureInfo
  23 IMPORT_1_3(IO(Handle))
  24 IMPORT_1_3(Char(isDigit,isPrint))
  25 #if __GLASGOW_HASKELL__ == 201
  26 IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards
  27 #elif __GLASGOW_HASKELL__ >= 202
  28 import GlaExts (Addr(..))
  29 #endif
  30
  31 import AbsCSyn
  32
  33 import AbsCUtils        ( getAmodeRep, nonemptyAbsC,
  34                           mixedPtrLocn, mixedTypeLocn
  35                         )
  36 import Constants        ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
  37 import CLabel           ( externallyVisibleCLabel, mkErrorStdEntryLabel,
  38                           isReadOnly, needsCDecl, pprCLabel,
  39                           CLabel{-instance Ord-}
  40                         )
  41 import CmdLineOpts      ( opt_SccProfilingOn )
  42 import CostCentre       ( uppCostCentre, uppCostCentreDecl )
  43 import Costs            ( costs, addrModeCosts, CostRes(..), Side(..) )
  44 import CStrings         ( stringToC )
  45 import FiniteMap        ( addToFM, emptyFM, lookupFM, FiniteMap )
  46 import HeapOffs         ( isZeroOff, subOff, pprHeapOffset )
  47 import Literal          ( showLiteral, Literal(..) )
  48 import Maybes           ( maybeToBool, catMaybes )
  49 import PprStyle         ( PprStyle(..) )
  50 import Pretty
  51 import PrimOp           ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
  52 import PrimRep          ( isFloatingRep, showPrimRep, PrimRep(..) )
  53 import SMRep            ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
  54                           isConstantRep, isSpecRep, isPhantomRep
  55                         )
  56 import Unique           ( pprUnique, Unique{-instance NamedThing-} )
  57 import UniqSet          ( emptyUniqSet, elementOfUniqSet,
  58                           addOneToUniqSet, SYN_IE(UniqSet)
  59                         )
  60 import Outputable       ( printDoc )
  61 import Util             ( nOfThem, panic, assertPanic )
  62
  63 infixr 9 `thenTE`
  64 \end{code}
  65
  66 For spitting out the costs of an abstract~C expression, @writeRealC@
  67 now not only prints the C~code of the @absC@ arg but also adds a macro
  68 call to a cost evaluation function @GRAN_EXEC@. For that,
  69 @pprAbsC@ has a new ``costs'' argument.  %% HWL
  70
  71 \begin{code}
  72 writeRealC :: Handle -> AbstractC -> IO ()
  73 writeRealC handle absC = printDoc LeftMode handle (pprAbsC PprForC absC (costs absC))
  74
  75 dumpRealC :: AbstractC -> String
  76 dumpRealC absC = show (pprAbsC PprForC absC (costs absC))
  77 \end{code}
  78
  79 This emits the macro,  which is used in GrAnSim  to compute the total costs
  80 from a cost 5 tuple. %%  HWL
  81
  82 \begin{code}
  83 emitMacro :: CostRes -> Doc
  84
  85 -- ToDo: Check a compile time flag to decide whether a macro should be emitted
  86 emitMacro (Cost (i,b,l,s,f))
  87   = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
  88                           int i, comma, int b, comma, int l, comma,
  89                           int s, comma, int f, pp_paren_semi ]
  90 \end{code}
  91
  92 \begin{code}
  93 pp_paren_semi = text ");"
  94
  95 -- ---------------------------------------------------------------------------
  96 -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
  97 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
  98 -- which must be done before the return i.e. inside absC code)   HWL
  99 -- ---------------------------------------------------------------------------
 100
 101 pprAbsC :: PprStyle -> AbstractC -> CostRes -> Doc
 102
 103 pprAbsC sty AbsCNop _ = empty
 104 pprAbsC sty (AbsCStmts s1 s2) c = ($$) (pprAbsC sty s1 c) (pprAbsC sty s2 c)
 105
 106 pprAbsC sty (CClosureUpdInfo info) c
 107   = pprAbsC sty info c
 108
 109 pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
 110
 111 pprAbsC sty (CJump target) c
 112   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
 113              (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
 114
 115 pprAbsC sty (CFallThrough target) c
 116   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CFallThrough */"-} ])
 117              (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
 118
 119 -- --------------------------------------------------------------------------
 120 -- Spit out GRAN_EXEC macro immediately before the return                 HWL
 121
 122 pprAbsC sty (CReturn am return_info)  c
 123   = ($$) (hcat [emitMacro c {-WDP:, text "/* <----  CReturn */"-} ])
 124              (hcat [text jmp_lit, target, pp_paren_semi ])
 125   where
 126    target = case return_info of
 127         DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode sty am, rparen]
 128         DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
 129         StaticVectoredReturn n -> mk_vector (int n)     -- Always positive
 130    mk_vector x = hcat [parens (pprAmode sty am), brackets (text "RVREL" <> parens x)]
 131
 132 pprAbsC sty (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
 133
 134 -- we optimise various degenerate cases of CSwitches.
 135
 136 -- --------------------------------------------------------------------------
 137 -- Assume: CSwitch is also end of basic block
 138 --         costs function yields nullCosts for whole switch
 139 --         ==> inherited costs c are those of basic block up to switch
 140 --         ==> inherit c + costs for the corresponding branch
 141 --                                                                       HWL
 142 -- --------------------------------------------------------------------------
 143
 144 pprAbsC sty (CSwitch discrim [] deflt) c
 145   = pprAbsC sty deflt (c + costs deflt)
 146     -- Empty alternative list => no costs for discrim as nothing cond. here HWL
 147
 148 pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
 149   = case (nonemptyAbsC deflt) of
 150       Nothing ->                -- one alt and no default
 151                  pprAbsC sty alt_code (c + costs alt_code)
 152                  -- Nothing conditional in here either  HWL
 153
 154       Just dc ->                -- make it an "if"
 155                  do_if_stmt sty discrim tag alt_code dc c
 156
 157 pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
 158                               (tag2@(MachInt i2 _), alt_code2)] deflt) c
 159   | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
 160   = if (i1 == 0) then
 161         do_if_stmt sty discrim tag1 alt_code1 alt_code2 c
 162     else
 163         do_if_stmt sty discrim tag2 alt_code2 alt_code1 c
 164   where
 165     empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
 166
 167 pprAbsC sty (CSwitch discrim alts deflt) c -- general case
 168   | isFloatingRep (getAmodeRep discrim)
 169     = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
 170   | otherwise
 171     = vcat [
 172         hcat [text "switch (", pp_discrim, text ") {"],
 173         nest 2 (vcat (map (ppr_alt sty) alts)),
 174         (case (nonemptyAbsC deflt) of
 175            Nothing -> empty
 176            Just dc ->
 177             nest 2 (vcat [ptext SLIT("default:"),
 178                                   pprAbsC sty dc (c + switch_head_cost
 179                                                     + costs dc),
 180                                   ptext SLIT("break;")])),
 181         char '}' ]
 182   where
 183     pp_discrim
 184       = pprAmode sty discrim
 185
 186     ppr_alt sty (lit, absC)
 187       = vcat [ hcat [ptext SLIT("case "), pprBasicLit sty lit, char ':'],
 188                    nest 2 (($$) (pprAbsC sty absC (c + switch_head_cost + costs absC))
 189                                        (ptext SLIT("break;"))) ]
 190
 191     -- Costs for addressing header of switch and cond. branching        -- HWL
 192     switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
 193
 194 pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _
 195   = pprCCall sty op args results liveness_mask vol_regs
 196
 197 pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
 198   = let
 199         non_void_args = grab_non_void_amodes args
 200         non_void_results = grab_non_void_amodes results
 201         -- if just one result, we print in the obvious "assignment" style;
 202         -- if 0 or many results, we emit a macro call, w/ the results
 203         -- followed by the arguments.  The macro presumably knows which
 204         -- are which :-)
 205
 206         the_op = ppr_op_call non_void_results non_void_args
 207                 -- liveness mask is *in* the non_void_args
 208     in
 209     case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) ->
 210     if primOpNeedsWrapper op then
 211         vcat [  pp_saves,
 212                     the_op,
 213                     pp_restores
 214                  ]
 215     else
 216         the_op
 217     }
 218   where
 219     ppr_op_call results args
 220       = hcat [ pprPrimOp sty op, lparen,
 221         hcat (punctuate comma (map ppr_op_result results)),
 222         if null results || null args then empty else comma,
 223         hcat (punctuate comma (map (pprAmode sty) args)),
 224         pp_paren_semi ]
 225
 226     ppr_op_result r = ppr_amode sty r
 227       -- primop macros do their own casting of result;
 228       -- hence we can toss the provided cast...
 229
 230 pprAbsC sty (CSimultaneous abs_c) c
 231   = hcat [ptext SLIT("{{"), pprAbsC sty abs_c c, ptext SLIT("}}")]
 232
 233 pprAbsC sty stmt@(CMacroStmt macro as) _
 234   = hcat [text (show macro), lparen,
 235         hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] -- no casting
 236 pprAbsC sty stmt@(CCallProfCtrMacro op as) _
 237   = hcat [ptext op, lparen,
 238         hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
 239 pprAbsC sty stmt@(CCallProfCCMacro op as) _
 240   = hcat [ptext op, lparen,
 241         hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
 242
 243 pprAbsC sty (CCodeBlock label abs_C) _
 244   = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
 245     case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
 246     vcat [
 247         hcat [text (if (externallyVisibleCLabel label)
 248                           then "FN_("   -- abbreviations to save on output
 249                           else "IFN_("),
 250                    pprCLabel sty label, text ") {"],
 251         case sty of
 252           PprForC -> ($$) pp_exts pp_temps
 253           _ -> empty,
 254         nest 8 (ptext SLIT("FB_")),
 255         nest 8 (pprAbsC sty abs_C (costs abs_C)),
 256         nest 8 (ptext SLIT("FE_")),
 257         char '}' ]
 258     }
 259
 260 pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
 261   = hcat [ pp_init_hdr, text "_HDR(",
 262                 ppr_amode sty (CAddr reg_rel), comma,
 263                 pprCLabel sty info_lbl, comma,
 264                 if_profiling sty (pprAmode sty cost_centre), comma,
 265                 pprHeapOffset sty size, comma, int ptr_wds, pp_paren_semi ]
 266   where
 267     info_lbl    = infoTableLabelFromCI cl_info
 268     sm_rep      = closureSMRep     cl_info
 269     size        = closureSizeWithoutFixedHdr cl_info
 270     ptr_wds     = closurePtrsSize  cl_info
 271
 272     pp_init_hdr = text (if inplace_upd then
 273                             getSMUpdInplaceHdrStr sm_rep
 274                         else
 275                             getSMInitHdrStr sm_rep)
 276
 277 pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
 278   = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
 279     vcat [
 280         case sty of
 281           PprForC -> pp_exts
 282           _ -> empty,
 283         hcat [
 284                 ptext SLIT("SET_STATIC_HDR"),char '(',
 285                 pprCLabel sty closure_lbl,                      comma,
 286                 pprCLabel sty info_lbl,                         comma,
 287                 if_profiling sty (pprAmode sty cost_centre),    comma,
 288                 ppLocalness closure_lbl,                        comma,
 289                 ppLocalnessMacro False{-for data-} info_lbl,
 290                 char ')'
 291                 ],
 292         nest 2 (hcat (map (ppr_item sty) amodes)),
 293         nest 2 (hcat (map (ppr_item sty) padding_wds)),
 294         ptext SLIT("};") ]
 295     }
 296   where
 297     info_lbl = infoTableLabelFromCI cl_info
 298
 299     ppr_item sty item
 300       = if getAmodeRep item == VoidRep
 301         then text ", (W_) 0" -- might not even need this...
 302         else (<>) (text ", (W_)") (ppr_amode sty item)
 303
 304     padding_wds =
 305         if not (closureUpdReqd cl_info) then
 306             []
 307         else
 308             case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
 309             nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
 310
 311 {-
 312    STATIC_INIT_HDR(c,i,localness) blows into:
 313         localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
 314
 315    then *NO VarHdr STUFF FOR STATIC*...
 316
 317    then the amodes are dropped in...
 318         ,a1 ,a2 ... ,aN
 319    then a close brace:
 320         };
 321 -}
 322
 323 pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
 324   = vcat [
 325         hcat [
 326             pp_info_rep,
 327             ptext SLIT("_ITBL"),char '(',
 328             pprCLabel sty info_lbl,                     comma,
 329
 330                 -- CONST_ITBL needs an extra label for
 331                 -- the static version of the object.
 332             if isConstantRep sm_rep
 333             then (<>) (pprCLabel sty (closureLabelFromCI cl_info)) comma
 334             else empty,
 335
 336             pprCLabel sty slow_lbl,     comma,
 337             pprAmode sty upd,           comma,
 338             int liveness,               comma,
 339
 340             pp_tag,                     comma,
 341             pp_size,                    comma,
 342             pp_ptr_wds,                 comma,
 343
 344             ppLocalness info_lbl,                               comma,
 345             ppLocalnessMacro True{-function-} slow_lbl,         comma,
 346
 347             if is_selector
 348             then (<>) (int select_word_i) comma
 349             else empty,
 350
 351             if_profiling sty pp_kind, comma,
 352             if_profiling sty pp_descr, comma,
 353             if_profiling sty pp_type,
 354             text ");"
 355         ],
 356         pp_slow,
 357         case maybe_fast of
 358             Nothing -> empty
 359             Just fast -> let stuff = CCodeBlock fast_lbl fast in
 360                          pprAbsC sty stuff (costs stuff)
 361     ]
 362   where
 363     info_lbl    = infoTableLabelFromCI cl_info
 364     fast_lbl    = fastLabelFromCI cl_info
 365     sm_rep      = closureSMRep    cl_info
 366
 367     (slow_lbl, pp_slow)
 368       = case (nonemptyAbsC slow) of
 369           Nothing -> (mkErrorStdEntryLabel, empty)
 370           Just xx -> (entryLabelFromCI cl_info,
 371                        let stuff = CCodeBlock slow_lbl xx in
 372                        pprAbsC sty stuff (costs stuff))
 373
 374     maybe_selector = maybeSelectorInfo cl_info
 375     is_selector = maybeToBool maybe_selector
 376     (Just (_, select_word_i)) = maybe_selector
 377
 378     pp_info_rep     -- special stuff if it's a selector; otherwise, just the SMrep
 379       = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
 380
 381     pp_tag = int (closureSemiTag cl_info)
 382
 383     is_phantom = isPhantomRep sm_rep
 384
 385     pp_size = if isSpecRep sm_rep then  -- exploiting: SPEC_VHS == 0 (always)
 386                  int (closureNonHdrSize cl_info)
 387
 388               else if is_phantom then   -- do not have sizes for these
 389                  empty
 390               else
 391                  pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
 392
 393     pp_ptr_wds  = if is_phantom then
 394                      empty
 395                   else
 396                      int (closurePtrsSize cl_info)
 397
 398     pp_kind  = text (closureKind cl_info)
 399     pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
 400     pp_type  = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
 401
 402 pprAbsC sty (CRetVector lbl maybes deflt) c
 403   = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
 404                nest 8 (sep (map (ppr_maybe_amode sty) maybes)),
 405                text "} /*default=*/ {", pprAbsC sty deflt c,
 406                char '}']
 407   where
 408     ppr_maybe_amode sty Nothing  = ptext SLIT("/*default*/")
 409     ppr_maybe_amode sty (Just a) = pprAmode sty a
 410
 411 pprAbsC sty stmt@(CRetUnVector label amode) _
 412   = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel sty label, comma,
 413             pprAmode sty amode, rparen]
 414   where
 415     pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
 416
 417 pprAbsC sty stmt@(CFlatRetVector label amodes) _
 418   =     case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
 419         vcat [
 420             case sty of
 421               PprForC -> pp_exts
 422               _ -> empty,
 423             hcat [ppLocalness label, ptext SLIT(" W_ "),
 424                        pprCLabel sty label, text "[] = {"],
 425             nest 2 (sep (punctuate comma (map (ppr_item sty) amodes))),
 426             text "};" ] }
 427   where
 428     ppr_item sty item = (<>) (text "(W_) ") (ppr_amode sty item)
 429
 430 pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
 431 \end{code}
 432
 433 \begin{code}
 434 ppLocalness label
 435   = (<>) static const
 436   where
 437     static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ")
 438     const  = if not (isReadOnly label)          then empty else ptext SLIT("const")
 439
 440 ppLocalnessMacro for_fun{-vs data-} clabel
 441   = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
 442                  if for_fun then
 443                     ptext SLIT("F_")
 444                  else
 445                     (<>) (ptext SLIT("D_"))
 446                               (if isReadOnly clabel then
 447                                   ptext SLIT("RO_")
 448                                else
 449                                   empty)]
 450 \end{code}
 451
 452 \begin{code}
 453 jmp_lit = "JMP_("
 454
 455 grab_non_void_amodes amodes
 456   = filter non_void amodes
 457
 458 non_void amode
 459   = case (getAmodeRep amode) of
 460       VoidRep -> False
 461       k -> True
 462 \end{code}
 463
 464 \begin{code}
 465 ppr_vol_regs :: PprStyle -> [MagicId] -> (Doc, Doc)
 466
 467 ppr_vol_regs sty [] = (empty, empty)
 468 ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
 469 ppr_vol_regs sty (r:rs)
 470   = let pp_reg = case r of
 471                     VanillaReg pk n -> pprVanillaReg n
 472                     _ -> pprMagicId sty r
 473         (more_saves, more_restores) = ppr_vol_regs sty rs
 474     in
 475     (($$) ((<>) (ptext SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
 476      ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
 477
 478 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
 479 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
 480 -- depending on the platform.  (The "volatile regs" stuff handles all
 481 -- other registers.)  Just be *sure* BaseReg is OK before trying to do
 482 -- anything else.
 483 pp_basic_saves
 484   = vcat [
 485         ptext SLIT("CALLER_SAVE_Base"),
 486         ptext SLIT("CALLER_SAVE_SpA"),
 487         ptext SLIT("CALLER_SAVE_SuA"),
 488         ptext SLIT("CALLER_SAVE_SpB"),
 489         ptext SLIT("CALLER_SAVE_SuB"),
 490         ptext SLIT("CALLER_SAVE_Ret"),
 491 --      ptext SLIT("CALLER_SAVE_Activity"),
 492         ptext SLIT("CALLER_SAVE_Hp"),
 493         ptext SLIT("CALLER_SAVE_HpLim") ]
 494
 495 pp_basic_restores
 496   = vcat [
 497         ptext SLIT("CALLER_RESTORE_Base"), -- must be first!
 498         ptext SLIT("CALLER_RESTORE_SpA"),
 499         ptext SLIT("CALLER_RESTORE_SuA"),
 500         ptext SLIT("CALLER_RESTORE_SpB"),
 501         ptext SLIT("CALLER_RESTORE_SuB"),
 502         ptext SLIT("CALLER_RESTORE_Ret"),
 503 --      ptext SLIT("CALLER_RESTORE_Activity"),
 504         ptext SLIT("CALLER_RESTORE_Hp"),
 505         ptext SLIT("CALLER_RESTORE_HpLim"),
 506         ptext SLIT("CALLER_RESTORE_StdUpdRetVec"),
 507         ptext SLIT("CALLER_RESTORE_StkStub") ]
 508 \end{code}
 509
 510 \begin{code}
 511 if_profiling sty pretty
 512   = case sty of
 513       PprForC -> if  opt_SccProfilingOn
 514                  then pretty
 515                  else char '0' -- leave it out!
 516
 517       _ -> {-print it anyway-} pretty
 518
 519 -- ---------------------------------------------------------------------------
 520 -- Changes for GrAnSim:
 521 --  draw costs for computation in head of if into both branches;
 522 --  as no abstractC data structure is given for the head, one is constructed
 523 --  guessing unknown values and fed into the costs function
 524 -- ---------------------------------------------------------------------------
 525
 526 do_if_stmt sty discrim tag alt_code deflt c
 527   = case tag of
 528       -- This special case happens when testing the result of a comparison.
 529       -- We can just avoid some redundant clutter in the output.
 530       MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
 531                                       deflt alt_code
 532                                       (addrModeCosts discrim Rhs) c
 533       other              -> let
 534                                cond = hcat [ pprAmode sty discrim,
 535                                           ptext SLIT(" == "),
 536                                           pprAmode sty (CLit tag) ]
 537                             in
 538                             ppr_if_stmt sty cond
 539                                          alt_code deflt
 540                                          (addrModeCosts discrim Rhs) c
 541
 542 ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
 543   = vcat [
 544       hcat [text "if (", pp_pred, text ") {"],
 545       nest 8 (pprAbsC sty then_part     (c + discrim_costs +
 546                                         (Cost (0, 2, 0, 0, 0)) +
 547                                         costs then_part)),
 548       (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
 549       nest 8 (pprAbsC sty else_part  (c + discrim_costs +
 550                                         (Cost (0, 1, 0, 0, 0)) +
 551                                         costs else_part)),
 552       char '}' ]
 553     {- Total costs = inherited costs (before if) + costs for accessing discrim
 554                      + costs for cond branch ( = (0, 1, 0, 0, 0) )
 555                      + costs for that alternative
 556     -}
 557 \end{code}
 558
 559 Historical note: this used to be two separate cases -- one for `ccall'
 560 and one for `casm'.  To get round a potential limitation to only 10
 561 arguments, the numbering of arguments in @process_casm@ was beefed up a
 562 bit. ADR
 563
 564 Some rough notes on generating code for @CCallOp@:
 565
 566 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
 567 2) Save any essential registers (heap, stack, etc).
 568
 569    ToDo: If stable pointers are in use, these must be saved in a place
 570    where the runtime system can get at them so that the Stg world can
 571    be restarted during the call.
 572
 573 3) Save any temporary registers that are currently in use.
 574 4) Do the call putting result into a local variable
 575 5) Restore essential registers
 576 6) Restore temporaries
 577
 578    (This happens after restoration of essential registers because we
 579    might need the @Base@ register to access all the others correctly.)
 580
 581 {- Doesn't apply anymore with ForeignObj, structure create via primop.
 582    makeForeignObj (ForeignObj is not CReturnable)
 583 7) If returning Malloc Pointer, build a closure containing the
 584    appropriate value.
 585 -}
 586    Otherwise, copy local variable into result register.
 587
 588 8) If ccall (not casm), declare the function being called as extern so
 589    that C knows if it returns anything other than an int.
 590
 591 \begin{pseudocode}
 592 { ResultType _ccall_result;
 593   basic_saves;
 594   saves;
 595   _ccall_result = f( args );
 596   basic_restores;
 597   restores;
 598
 599   return_reg = _ccall_result;
 600 }
 601 \end{pseudocode}
 602
 603 Amendment to the above: if we can GC, we have to:
 604
 605 * make sure we save all our registers away where the garbage collector
 606   can get at them.
 607 * be sure that there are no live registers or we're in trouble.
 608   (This can cause problems if you try something foolish like passing
 609    an array or foreign obj to a _ccall_GC_ thing.)
 610 * increment/decrement the @inCCallGC@ counter before/after the call so
 611   that the runtime check that PerformGC is being used sensibly will work.
 612
 613 \begin{code}
 614 pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs
 615   = if (may_gc && liveness_mask /= noLiveRegsMask)
 616     then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (show (hsep pp_non_void_args)) ++ "\n")
 617     else
 618     vcat [
 619       char '{',
 620       declare_local_vars,   -- local var for *result*
 621       vcat local_arg_decls,
 622       -- if is_asm then empty else declareExtern,
 623       pp_save_context,
 624       process_casm local_vars pp_non_void_args casm_str,
 625       pp_restore_context,
 626       assign_results,
 627       char '}'
 628     ]
 629   where
 630     (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
 631     (pp_save_context, pp_restore_context) =
 632         if may_gc
 633         then (  text "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
 634                 text "inCCallGC--; RestoreAllStgRegs();")
 635         else (  pp_basic_saves $$ pp_saves,
 636                 pp_basic_restores $$ pp_restores)
 637
 638     non_void_args =
 639         let nvas = tail args
 640         in ASSERT (all non_void nvas) nvas
 641     -- the first argument will be the "I/O world" token (a VoidRep)
 642     -- all others should be non-void
 643
 644     non_void_results =
 645         let nvrs = grab_non_void_amodes results
 646         in ASSERT (length nvrs <= 1) nvrs
 647     -- there will usually be two results: a (void) state which we
 648     -- should ignore and a (possibly void) result.
 649
 650     (local_arg_decls, pp_non_void_args)
 651       = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ]
 652
 653     pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
 654
 655     (declare_local_vars, local_vars, assign_results)
 656       = ppr_casm_results sty non_void_results pp_liveness
 657
 658     casm_str = if is_asm then _UNPK_ op_str else ccall_str
 659
 660     -- Remainder only used for ccall
 661
 662     ccall_str = show
 663         (hcat [
 664                 if null non_void_results
 665                   then empty
 666                   else text "%r = ",
 667                 lparen, ptext op_str, lparen,
 668                   hcat (punctuate comma ccall_args),
 669                 text "));"
 670         ])
 671     num_args = length non_void_args
 672     ccall_args = take num_args [ (<>) (char '%') (int i) | i <- [0..] ]
 673 \end{code}
 674
 675 If the argument is a heap object, we need to reach inside and pull out
 676 the bit the C world wants to see.  The only heap objects which can be
 677 passed are @Array@s, @ByteArray@s and @ForeignObj@s.
 678
 679 \begin{code}
 680 ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Doc, Doc)
 681     -- (a) decl and assignment, (b) local var to be used later
 682
 683 ppr_casm_arg sty amode a_num
 684   = let
 685         a_kind   = getAmodeRep amode
 686         pp_amode = pprAmode sty amode
 687         pp_kind  = pprPrimKind sty a_kind
 688
 689         local_var  = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
 690
 691         (arg_type, pp_amode2)
 692           = case a_kind of
 693
 694               -- for array arguments, pass a pointer to the body of the array
 695               -- (PTRS_ARR_CTS skips over all the header nonsense)
 696               ArrayRep      -> (pp_kind,
 697                                 hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
 698               ByteArrayRep -> (pp_kind,
 699                                 hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
 700
 701               -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
 702               ForeignObjRep -> (ptext SLIT("StgForeignObj"),
 703                                 hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(',
 704                                             pp_amode, char ')'])
 705               other         -> (pp_kind, pp_amode)
 706
 707         declare_local_var
 708           = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
 709     in
 710     (declare_local_var, local_var)
 711 \end{code}
 712
 713 For l-values, the critical questions are:
 714
 715 1) Are there any results at all?
 716
 717    We only allow zero or one results.
 718
 719 {- With the introduction of ForeignObj (MallocPtr++), no longer necess.
 720 2) Is the result is a foreign obj?
 721
 722    The mallocptr must be encapsulated immediately in a heap object.
 723 -}
 724 \begin{code}
 725 ppr_casm_results ::
 726         PprStyle        -- style
 727         -> [CAddrMode]  -- list of results (length <= 1)
 728         -> Doc  -- liveness mask
 729         ->
 730         ( Doc,  -- declaration of any local vars
 731           [Doc],        -- list of result vars (same length as results)
 732           Doc ) -- assignment (if any) of results in local var to registers
 733
 734 ppr_casm_results sty [] liveness
 735   = (empty, [], empty)  -- no results
 736
 737 ppr_casm_results sty [r] liveness
 738   = let
 739         result_reg = ppr_amode sty r
 740         r_kind     = getAmodeRep r
 741
 742         local_var  = ptext SLIT("_ccall_result")
 743
 744         (result_type, assign_result)
 745           = case r_kind of
 746 {-
 747    @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
 748    Instead, external references have to explicitly turned into ForeignObjs
 749    using the primop makeForeignObj#. Benefit: Multiple finalisation
 750    routines can be accommodated and the below special case is not needed.
 751    Price is, of course, that you have to explicitly wrap `foreign objects'
 752    with makeForeignObj#.
 753
 754               ForeignObjRep ->
 755                 (ptext SLIT("StgForeignObj"),
 756                  hcat [ ptext SLIT("constructForeignObj"),char '(',
 757                                 liveness, comma,
 758                                 result_reg, comma,
 759                                 local_var,
 760                              pp_paren_semi ])
 761 -}
 762               _ ->
 763                 (pprPrimKind sty r_kind,
 764                  hcat [ result_reg, equals, local_var, semi ])
 765
 766         declare_local_var = hcat [ result_type, space, local_var, semi ]
 767     in
 768     (declare_local_var, [local_var], assign_result)
 769
 770 ppr_casm_results sty rs liveness
 771   = panic "ppr_casm_results: ccall/casm with many results"
 772 \end{code}
 773
 774
 775 Note the sneaky way _the_ result is represented by a list so that we
 776 can complain if it's used twice.
 777
 778 ToDo: Any chance of giving line numbers when process-casm fails?
 779       Or maybe we should do a check _much earlier_ in compiler. ADR
 780
 781 \begin{code}
 782 process_casm ::
 783         [Doc]           -- results (length <= 1)
 784         -> [Doc]                -- arguments
 785         -> String               -- format string (with embedded %'s)
 786         ->
 787         Doc                     -- code being generated
 788
 789 process_casm results args string = process results args string
 790  where
 791   process []    _ "" = empty
 792   process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
 793
 794   process ress args ('%':cs)
 795     = case cs of
 796         [] ->
 797             error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
 798
 799         ('%':css) ->
 800             (<>) (char '%') (process ress args css)
 801
 802         ('r':css)  ->
 803           case ress of
 804             []  -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
 805             [r] -> (<>) r (process [] args css)
 806             _   -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
 807
 808         other ->
 809           let
 810                 read_int :: ReadS Int
 811                 read_int = reads
 812           in
 813           case (read_int other) of
 814             [(num,css)] ->
 815                   if 0 <= num && num < length args
 816                   then (<>) (parens (args !! num))
 817                                  (process ress args css)
 818                     else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
 819             _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
 820
 821   process ress args (other_c:cs)
 822     = (<>) (char other_c) (process ress args cs)
 823 \end{code}
 824
 825 %************************************************************************
 826 %*                                                                      *
 827 \subsection[a2r-assignments]{Assignments}
 828 %*                                                                      *
 829 %************************************************************************
 830
 831 Printing assignments is a little tricky because of type coercion.
 832
 833 First of all, the kind of the thing being assigned can be gotten from
 834 the destination addressing mode.  (It should be the same as the kind
 835 of the source addressing mode.)  If the kind of the assignment is of
 836 @VoidRep@, then don't generate any code at all.
 837
 838 \begin{code}
 839 pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Doc
 840
 841 pprAssign sty VoidRep dest src = empty
 842 \end{code}
 843
 844 Special treatment for floats and doubles, to avoid unwanted conversions.
 845
 846 \begin{code}
 847 pprAssign sty FloatRep dest@(CVal reg_rel _) src
 848   = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
 849
 850 pprAssign sty DoubleRep dest@(CVal reg_rel _) src
 851   = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
 852 \end{code}
 853
 854 Lastly, the question is: will the C compiler think the types of the
 855 two sides of the assignment match?
 856
 857         We assume that the types will match
 858         if neither side is a @CVal@ addressing mode for any register
 859         which can point into the heap or B stack.
 860
 861 Why?  Because the heap and B stack are used to store miscellaneous things,
 862 whereas the A stack, temporaries, registers, etc., are only used for things
 863 of fixed type.
 864
 865 \begin{code}
 866 pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
 867   = hcat [ pprVanillaReg dest, equals,
 868                 pprVanillaReg src, semi ]
 869
 870 pprAssign sty kind dest src
 871   | mixedTypeLocn dest
 872     -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
 873   = hcat [ ppr_amode sty dest, equals,
 874                 text "(W_)(",   -- Here is the cast
 875                 ppr_amode sty src, pp_paren_semi ]
 876
 877 pprAssign sty kind dest src
 878   | mixedPtrLocn dest && getAmodeRep src /= PtrRep
 879     -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
 880   = hcat [ ppr_amode sty dest, equals,
 881                 text "(P_)(",   -- Here is the cast
 882                 ppr_amode sty src, pp_paren_semi ]
 883
 884 pprAssign sty ByteArrayRep dest src
 885   | mixedPtrLocn src
 886     -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
 887   = hcat [ ppr_amode sty dest, equals,
 888                 text "(B_)(",   -- Here is the cast
 889                 ppr_amode sty src, pp_paren_semi ]
 890
 891 pprAssign sty kind other_dest src
 892   = hcat [ ppr_amode sty other_dest, equals,
 893                 pprAmode  sty src, semi ]
 894 \end{code}
 895
 896
 897 %************************************************************************
 898 %*                                                                      *
 899 \subsection[a2r-CAddrModes]{Addressing modes}
 900 %*                                                                      *
 901 %************************************************************************
 902
 903 @pprAmode@ is used to print r-values (which may need casts), whereas
 904 @ppr_amode@ is used for l-values {\em and} as a help function for
 905 @pprAmode@.
 906
 907 \begin{code}
 908 pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Doc
 909 \end{code}
 910
 911 For reasons discussed above under assignments, @CVal@ modes need
 912 to be treated carefully.  First come special cases for floats and doubles,
 913 similar to those in @pprAssign@:
 914
 915 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
 916 question.)
 917
 918 \begin{code}
 919 pprAmode sty (CVal reg_rel FloatRep)
 920   = hcat [ text "PK_FLT(", ppr_amode sty (CAddr reg_rel), rparen ]
 921 pprAmode sty (CVal reg_rel DoubleRep)
 922   = hcat [ text "PK_DBL(", ppr_amode sty (CAddr reg_rel), rparen ]
 923 \end{code}
 924
 925 Next comes the case where there is some other cast need, and the
 926 no-cast case:
 927
 928 \begin{code}
 929 pprAmode sty amode
 930   | mixedTypeLocn amode
 931   = parens (hcat [ pprPrimKind sty (getAmodeRep amode), ptext SLIT(")("),
 932                 ppr_amode sty amode ])
 933   | otherwise   -- No cast needed
 934   = ppr_amode sty amode
 935 \end{code}
 936
 937 Now the rest of the cases for ``workhorse'' @ppr_amode@:
 938
 939 \begin{code}
 940 ppr_amode sty (CVal reg_rel _)
 941   = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
 942         (pp_reg, Nothing)     -> (<>)  (char '*') pp_reg
 943         (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
 944
 945 ppr_amode sty (CAddr reg_rel)
 946   = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
 947         (pp_reg, Nothing)     -> pp_reg
 948         (pp_reg, Just offset) -> (<>) pp_reg offset
 949
 950 ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
 951
 952 ppr_amode sty (CTemp uniq kind) = pprUnique uniq
 953
 954 ppr_amode sty (CLbl label kind) = pprCLabel sty label
 955
 956 ppr_amode sty (CUnVecLbl direct vectored)
 957   = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel sty direct, comma,
 958                pprCLabel sty vectored, rparen]
 959
 960 ppr_amode sty (CCharLike ch)
 961   = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode sty ch, rparen ]
 962 ppr_amode sty (CIntLike int)
 963   = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode sty int, rparen ]
 964
 965 ppr_amode sty (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
 966   -- ToDo: are these *used* for anything?
 967
 968 ppr_amode sty (CLit lit) = pprBasicLit sty lit
 969
 970 ppr_amode sty (CLitLit str _) = ptext str
 971
 972 ppr_amode sty (COffset off) = pprHeapOffset sty off
 973
 974 ppr_amode sty (CCode abs_C)
 975   = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
 976
 977 ppr_amode sty (CLabelledCode label abs_C)
 978   = vcat [ hcat [pprCLabel sty label, ptext SLIT(" = { -- CLabelledCode")],
 979                nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
 980
 981 ppr_amode sty (CJoinPoint _ _)
 982   = panic "ppr_amode: CJoinPoint"
 983
 984 ppr_amode sty (CTableEntry base index kind)
 985   = hcat [text "((", pprPrimKind sty kind, text " *)(",
 986                ppr_amode sty base, text "))[(I_)(", ppr_amode sty index,
 987                ptext SLIT(")]")]
 988
 989 ppr_amode sty (CMacroExpr pk macro as)
 990   = hcat [lparen, pprPrimKind sty pk, text ")(", text (show macro), lparen,
 991                hcat (punctuate comma (map (pprAmode sty) as)), text "))"]
 992
 993 ppr_amode sty (CCostCentre cc print_as_string)
 994   = uppCostCentre sty print_as_string cc
 995 \end{code}
 996
 997 %************************************************************************
 998 %*                                                                      *
 999 \subsection[a2r-MagicIds]{Magic ids}
1000 %*                                                                      *
1001 %************************************************************************
1002
1003 @pprRegRelative@ returns a pair of the @Doc@ for the register
1004 (some casting may be required), and a @Maybe Doc@ for the offset
1005 (zero offset gives a @Nothing@).
1006
1007 \begin{code}
1008 addPlusSign :: Bool -> Doc -> Doc
1009 addPlusSign False p = p
1010 addPlusSign True  p = (<>) (char '+') p
1011
1012 pprSignedInt :: Bool -> Int -> Maybe Doc        -- Nothing => 0
1013 pprSignedInt sign_wanted n
1014  = if n == 0 then Nothing else
1015    if n > 0  then Just (addPlusSign sign_wanted (int n))
1016    else           Just (int n)
1017
1018 pprRegRelative :: PprStyle
1019                -> Bool          -- True <=> Print leading plus sign (if +ve)
1020                -> RegRelative
1021                -> (Doc, Maybe Doc)
1022
1023 pprRegRelative sty sign_wanted (SpARel spA off)
1024   = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
1025
1026 pprRegRelative sty sign_wanted (SpBRel spB off)
1027   = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
1028
1029 pprRegRelative sty sign_wanted r@(HpRel hp off)
1030   = let to_print = hp `subOff` off
1031         pp_Hp    = pprMagicId sty Hp
1032     in
1033     if isZeroOff to_print then
1034         (pp_Hp, Nothing)
1035     else
1036         (pp_Hp, Just ((<>) (char '-') (pprHeapOffset sty to_print)))
1037                                 -- No parens needed because pprHeapOffset
1038                                 -- does them when necessary
1039
1040 pprRegRelative sty sign_wanted (NodeRel off)
1041   = let pp_Node = pprMagicId sty node
1042     in
1043     if isZeroOff off then
1044         (pp_Node, Nothing)
1045     else
1046         (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off)))
1047
1048 \end{code}
1049
1050 @pprMagicId@ just prints the register name.  @VanillaReg@ registers are
1051 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1052 to select the union tag.
1053
1054 \begin{code}
1055 pprMagicId :: PprStyle -> MagicId -> Doc
1056
1057 pprMagicId sty BaseReg              = ptext SLIT("BaseReg")
1058 pprMagicId sty StkOReg              = ptext SLIT("StkOReg")
1059 pprMagicId sty (VanillaReg pk n)
1060                                     = hcat [ pprVanillaReg n, char '.',
1061                                                   pprUnionTag pk ]
1062 pprMagicId sty (FloatReg  n)        = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
1063 pprMagicId sty (DoubleReg n)        = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
1064 pprMagicId sty TagReg               = ptext SLIT("TagReg")
1065 pprMagicId sty RetReg               = ptext SLIT("RetReg")
1066 pprMagicId sty SpA                  = ptext SLIT("SpA")
1067 pprMagicId sty SuA                  = ptext SLIT("SuA")
1068 pprMagicId sty SpB                  = ptext SLIT("SpB")
1069 pprMagicId sty SuB                  = ptext SLIT("SuB")
1070 pprMagicId sty Hp                   = ptext SLIT("Hp")
1071 pprMagicId sty HpLim                = ptext SLIT("HpLim")
1072 pprMagicId sty LivenessReg          = ptext SLIT("LivenessReg")
1073 pprMagicId sty StdUpdRetVecReg      = ptext SLIT("StdUpdRetVecReg")
1074 pprMagicId sty StkStubReg           = ptext SLIT("StkStubReg")
1075 pprMagicId sty CurCostCentre        = ptext SLIT("CCC")
1076 pprMagicId sty VoidReg              = panic "pprMagicId:VoidReg!"
1077
1078 pprVanillaReg :: FAST_INT -> Doc
1079
1080 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
1081
1082 pprUnionTag :: PrimRep -> Doc
1083
1084 pprUnionTag PtrRep              = char 'p'
1085 pprUnionTag CodePtrRep          = ptext SLIT("fp")
1086 pprUnionTag DataPtrRep          = char 'd'
1087 pprUnionTag RetRep              = char 'r'
1088 pprUnionTag CostCentreRep       = panic "pprUnionTag:CostCentre?"
1089
1090 pprUnionTag CharRep             = char 'c'
1091 pprUnionTag IntRep              = char 'i'
1092 pprUnionTag WordRep             = char 'w'
1093 pprUnionTag AddrRep             = char 'v'
1094 pprUnionTag FloatRep            = char 'f'
1095 pprUnionTag DoubleRep           = panic "pprUnionTag:Double?"
1096
1097 pprUnionTag StablePtrRep        = char 'i'
1098 pprUnionTag ForeignObjRep       = char 'p'
1099
1100 pprUnionTag ArrayRep            = char 'p'
1101 pprUnionTag ByteArrayRep        = char 'b'
1102
1103 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
1104 \end{code}
1105
1106
1107 Find and print local and external declarations for a list of
1108 Abstract~C statements.
1109 \begin{code}
1110 pprTempAndExternDecls :: AbstractC -> (Doc{-temps-}, Doc{-externs-})
1111 pprTempAndExternDecls AbsCNop = (empty, empty)
1112
1113 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1114   = initTE (ppr_decls_AbsC stmt1        `thenTE` \ (t_p1, e_p1) ->
1115             ppr_decls_AbsC stmt2        `thenTE` \ (t_p2, e_p2) ->
1116             case (catMaybes [t_p1, t_p2])        of { real_temps ->
1117             case (catMaybes [e_p1, e_p2])        of { real_exts ->
1118             returnTE (vcat real_temps, vcat real_exts) }}
1119            )
1120
1121 pprTempAndExternDecls other_stmt
1122   = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1123             returnTE (
1124                 case maybe_t of
1125                   Nothing -> empty
1126                   Just pp -> pp,
1127
1128                 case maybe_e of
1129                   Nothing -> empty
1130                   Just pp -> pp )
1131            )
1132
1133 pprBasicLit :: PprStyle -> Literal -> Doc
1134 pprPrimKind :: PprStyle -> PrimRep -> Doc
1135
1136 pprBasicLit  sty lit = text (showLiteral  sty lit)
1137 pprPrimKind  sty k   = text (showPrimRep k)
1138 \end{code}
1139
1140
1141 %************************************************************************
1142 %*                                                                      *
1143 \subsection[a2r-monad]{Monadery}
1144 %*                                                                      *
1145 %************************************************************************
1146
1147 We need some monadery to keep track of temps and externs we have already
1148 printed.  This info must be threaded right through the Abstract~C, so
1149 it's most convenient to hide it in this monad.
1150
1151 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1152 \tr{(UniqSet, CLabelSet)}.  Allegedly for efficiency.
1153
1154 \begin{code}
1155 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1156 emptyCLabelSet = emptyFM
1157 x `elementOfCLabelSet` labs
1158   = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1159 addToCLabelSet set x = addToFM set x ()
1160
1161 type TEenv = (UniqSet Unique, CLabelSet)
1162
1163 type TeM result =  TEenv -> (TEenv, result)
1164
1165 initTE :: TeM a -> a
1166 initTE sa
1167   = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1168     result }
1169
1170 {-# INLINE thenTE #-}
1171 {-# INLINE returnTE #-}
1172
1173 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1174 thenTE a b u
1175   = case a u        of { (u_1, result_of_a) ->
1176     b result_of_a u_1 }
1177
1178 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1179 mapTE f []     = returnTE []
1180 mapTE f (x:xs)
1181   = f x         `thenTE` \ r  ->
1182     mapTE f xs  `thenTE` \ rs ->
1183     returnTE (r : rs)
1184
1185 returnTE :: a -> TeM a
1186 returnTE result env = (env, result)
1187
1188 -- these next two check whether the thing is already
1189 -- recorded, and THEN THEY RECORD IT
1190 -- (subsequent calls will return False for the same uniq/label)
1191
1192 tempSeenTE :: Unique -> TeM Bool
1193 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1194   = if (uniq `elementOfUniqSet` seen_uniqs)
1195     then (env, True)
1196     else ((addOneToUniqSet seen_uniqs uniq,
1197           seen_labels),
1198           False)
1199
1200 labelSeenTE :: CLabel -> TeM Bool
1201 labelSeenTE label env@(seen_uniqs, seen_labels)
1202   = if (label `elementOfCLabelSet` seen_labels)
1203     then (env, True)
1204     else ((seen_uniqs,
1205           addToCLabelSet seen_labels label),
1206           False)
1207 \end{code}
1208
1209 \begin{code}
1210 pprTempDecl :: Unique -> PrimRep -> Doc
1211 pprTempDecl uniq kind
1212   = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, semi ]
1213
1214 pprExternDecl :: CLabel -> PrimRep -> Doc
1215
1216 pprExternDecl clabel kind
1217   = if not (needsCDecl clabel) then
1218         empty -- do not print anything for "known external" things (e.g., < PreludeCore)
1219     else
1220         case (
1221             case kind of
1222               CodePtrRep -> ppLocalnessMacro True{-function-} clabel
1223               _          -> ppLocalnessMacro False{-data-}    clabel
1224         ) of { pp_macro_str ->
1225
1226         hcat [ pp_macro_str, lparen, pprCLabel PprForC clabel, pp_paren_semi ]
1227         }
1228 \end{code}
1229
1230 \begin{code}
1231 ppr_decls_AbsC :: AbstractC -> TeM (Maybe Doc{-temps-}, Maybe Doc{-externs-})
1232
1233 ppr_decls_AbsC AbsCNop          = returnTE (Nothing, Nothing)
1234
1235 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1236   = ppr_decls_AbsC stmts_1  `thenTE` \ p1 ->
1237     ppr_decls_AbsC stmts_2  `thenTE` \ p2 ->
1238     returnTE (maybe_vcat [p1, p2])
1239
1240 ppr_decls_AbsC (CClosureUpdInfo info)
1241   = ppr_decls_AbsC info
1242
1243 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1244
1245 ppr_decls_AbsC (CAssign dest source)
1246   = ppr_decls_Amode dest    `thenTE` \ p1 ->
1247     ppr_decls_Amode source  `thenTE` \ p2 ->
1248     returnTE (maybe_vcat [p1, p2])
1249
1250 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1251
1252 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1253
1254 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1255
1256 ppr_decls_AbsC (CSwitch discrim alts deflt)
1257   = ppr_decls_Amode discrim     `thenTE` \ pdisc ->
1258     mapTE ppr_alt_stuff alts    `thenTE` \ palts  ->
1259     ppr_decls_AbsC deflt        `thenTE` \ pdeflt ->
1260     returnTE (maybe_vcat (pdisc:pdeflt:palts))
1261   where
1262     ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1263
1264 ppr_decls_AbsC (CCodeBlock label absC)
1265   = ppr_decls_AbsC absC
1266
1267 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1268         -- ToDo: strictly speaking, should chk "cost_centre" amode
1269   = labelSeenTE info_lbl     `thenTE` \  label_seen ->
1270     returnTE (Nothing,
1271               if label_seen then
1272                   Nothing
1273               else
1274                   Just (pprExternDecl info_lbl PtrRep))
1275   where
1276     info_lbl = infoTableLabelFromCI cl_info
1277
1278 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1279 ppr_decls_AbsC (CSimultaneous abc)          = ppr_decls_AbsC abc
1280
1281 ppr_decls_AbsC (CMacroStmt          _ amodes)   = ppr_decls_Amodes amodes
1282
1283 ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)   = ppr_decls_Amodes [] -- *****!!!
1284   -- you get some nasty re-decls of stdio.h if you compile
1285   -- the prelude while looking inside those amodes;
1286   -- no real reason to, anyway.
1287 ppr_decls_AbsC (CCallProfCCMacro    _ amodes)   = ppr_decls_Amodes amodes
1288
1289 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1290         -- ToDo: strictly speaking, should chk "cost_centre" amode
1291   = ppr_decls_Amodes amodes
1292
1293 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1294   = ppr_decls_Amodes [entry_lbl, upd_lbl]       `thenTE` \ p1 ->
1295     ppr_decls_AbsC slow                         `thenTE` \ p2 ->
1296     (case maybe_fast of
1297         Nothing   -> returnTE (Nothing, Nothing)
1298         Just fast -> ppr_decls_AbsC fast)       `thenTE` \ p3 ->
1299     returnTE (maybe_vcat [p1, p2, p3])
1300   where
1301     entry_lbl = CLbl slow_lbl CodePtrRep
1302     slow_lbl    = case (nonemptyAbsC slow) of
1303                     Nothing -> mkErrorStdEntryLabel
1304                     Just _  -> entryLabelFromCI cl_info
1305
1306 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1307   = ppr_decls_Amodes (catMaybes maybe_amodes)   `thenTE` \ p1 ->
1308     ppr_decls_AbsC   absC                       `thenTE` \ p2 ->
1309     returnTE (maybe_vcat [p1, p2])
1310
1311 ppr_decls_AbsC (CRetUnVector   _ amode)  = ppr_decls_Amode amode
1312 ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
1313 \end{code}
1314
1315 \begin{code}
1316 ppr_decls_Amode :: CAddrMode -> TeM (Maybe Doc, Maybe Doc)
1317 ppr_decls_Amode (CVal _ _)      = returnTE (Nothing, Nothing)
1318 ppr_decls_Amode (CAddr _)       = returnTE (Nothing, Nothing)
1319 ppr_decls_Amode (CReg _)        = returnTE (Nothing, Nothing)
1320 ppr_decls_Amode (CString _)     = returnTE (Nothing, Nothing)
1321 ppr_decls_Amode (CLit _)        = returnTE (Nothing, Nothing)
1322 ppr_decls_Amode (CLitLit _ _)   = returnTE (Nothing, Nothing)
1323 ppr_decls_Amode (COffset _)     = returnTE (Nothing, Nothing)
1324
1325 -- CIntLike must be a literal -- no decls
1326 ppr_decls_Amode (CIntLike int)  = returnTE (Nothing, Nothing)
1327
1328 -- CCharLike may have be arbitrary value -- may have decls
1329 ppr_decls_Amode (CCharLike char)
1330   = ppr_decls_Amode char
1331
1332 -- now, the only place where we actually print temps/externs...
1333 ppr_decls_Amode (CTemp uniq kind)
1334   = case kind of
1335       VoidRep -> returnTE (Nothing, Nothing)
1336       other ->
1337         tempSeenTE uniq `thenTE` \ temp_seen ->
1338         returnTE
1339           (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1340
1341 ppr_decls_Amode (CLbl label VoidRep)
1342   = returnTE (Nothing, Nothing)
1343
1344 ppr_decls_Amode (CLbl label kind)
1345   = labelSeenTE label `thenTE` \ label_seen ->
1346     returnTE (Nothing,
1347               if label_seen then Nothing else Just (pprExternDecl label kind))
1348
1349 {- WRONG:
1350 ppr_decls_Amode (CUnVecLbl direct vectored)
1351   = labelSeenTE direct   `thenTE` \ dlbl_seen ->
1352     labelSeenTE vectored `thenTE` \ vlbl_seen ->
1353     let
1354         ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
1355         vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
1356     in
1357     returnTE (Nothing,
1358                 if (dlbl_seen || not (needsCDecl direct)) &&
1359                    (vlbl_seen || not (needsCDecl vectored)) then Nothing
1360                 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1361 -}
1362
1363 ppr_decls_Amode (CUnVecLbl direct vectored)
1364   = -- We don't mark either label as "seen", because
1365     -- we don't know which one will be used and which one tossed
1366     -- by the C macro...
1367     --labelSeenTE direct   `thenTE` \ dlbl_seen ->
1368     --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1369     let
1370         ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
1371         vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
1372     in
1373     returnTE (Nothing,
1374                 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1375                    ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1376                 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1377
1378 ppr_decls_Amode (CTableEntry base index _)
1379   = ppr_decls_Amode base    `thenTE` \ p1 ->
1380     ppr_decls_Amode index   `thenTE` \ p2 ->
1381     returnTE (maybe_vcat [p1, p2])
1382
1383 ppr_decls_Amode (CMacroExpr _ _ amodes)
1384   = ppr_decls_Amodes amodes
1385
1386 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1387
1388
1389 maybe_vcat :: [(Maybe Doc, Maybe Doc)] -> (Maybe Doc, Maybe Doc)
1390 maybe_vcat ps
1391   = case (unzip ps)     of { (ts, es) ->
1392     case (catMaybes ts) of { real_ts  ->
1393     case (catMaybes es) of { real_es  ->
1394     (if (null real_ts) then Nothing else Just (vcat real_ts),
1395      if (null real_es) then Nothing else Just (vcat real_es))
1396     } } }
1397 \end{code}
1398
1399 \begin{code}
1400 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Doc, Maybe Doc)
1401 ppr_decls_Amodes amodes
1402   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1403     returnTE ( maybe_vcat ps )
1404 \end{code}