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