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