ghc/compiler/absCSyn/PprAbsC.lhs

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