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