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