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