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