ghc/compiler/absCSyn/PprAbsC.lhs

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