ghc/compiler/absCSyn/PprAbsC.lhs

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