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 -- import Char  ( Char, isDigit, isPrint )
  23 -- import GlaExts       ( Addr(..) )
  24
  25 import AbsCSyn
  26 import ClosureInfo
  27 import AbsCUtils        ( getAmodeRep, nonemptyAbsC,
  28                           mixedPtrLocn, mixedTypeLocn
  29                         )
  30 import Constants        ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
  31 import CLabel           ( externallyVisibleCLabel, mkErrorStdEntryLabel,
  32                           isReadOnly, needsCDecl, pprCLabel,
  33                           CLabel{-instance Ord-}
  34                         )
  35 import CmdLineOpts      ( opt_SccProfilingOn )
  36 import CostCentre       ( uppCostCentre, uppCostCentreDecl )
  37 import Costs            ( costs, addrModeCosts, CostRes(..), Side(..) )
  38 import CStrings         ( stringToC )
  39 import FiniteMap        ( addToFM, emptyFM, lookupFM, FiniteMap )
  40 import HeapOffs         ( isZeroOff, subOff, pprHeapOffset )
  41 import Literal          ( showLiteral, Literal(..) )
  42 import Maybes           ( maybeToBool, catMaybes )
  43 import PrimOp           ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
  44 import PrimRep          ( isFloatingRep, PrimRep(..) )
  45 import SMRep            ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
  46                           isConstantRep, isSpecRep, isPhantomRep
  47                         )
  48 import Unique           ( pprUnique, Unique{-instance NamedThing-} )
  49 import UniqSet          ( emptyUniqSet, elementOfUniqSet,
  50                           addOneToUniqSet, UniqSet
  51                         )
  52 import Outputable
  53 import Util             ( nOfThem, panic, assertPanic )
  54
  55 infixr 9 `thenTE`
  56 \end{code}
  57
  58 For spitting out the costs of an abstract~C expression, @writeRealC@
  59 now not only prints the C~code of the @absC@ arg but also adds a macro
  60 call to a cost evaluation function @GRAN_EXEC@. For that,
  61 @pprAbsC@ has a new ``costs'' argument.  %% HWL
  62
  63 \begin{code}
  64 writeRealC :: Handle -> AbstractC -> IO ()
  65 writeRealC handle absC = printForC handle (pprAbsC absC (costs absC))
  66
  67 dumpRealC :: AbstractC -> SDoc
  68 dumpRealC absC = pprAbsC absC (costs absC)
  69 \end{code}
  70
  71 This emits the macro,  which is used in GrAnSim  to compute the total costs
  72 from a cost 5 tuple. %%  HWL
  73
  74 \begin{code}
  75 emitMacro :: CostRes -> SDoc
  76
  77 -- ToDo: Check a compile time flag to decide whether a macro should be emitted
  78 emitMacro (Cost (i,b,l,s,f))
  79   = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
  80                           int i, comma, int b, comma, int l, comma,
  81                           int s, comma, int f, pp_paren_semi ]
  82 \end{code}
  83
  84 \begin{code}
  85 pp_paren_semi = text ");"
  86
  87 -- ---------------------------------------------------------------------------
  88 -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
  89 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
  90 -- which must be done before the return i.e. inside absC code)   HWL
  91 -- ---------------------------------------------------------------------------
  92
  93 pprAbsC :: AbstractC -> CostRes -> SDoc
  94
  95 pprAbsC AbsCNop _ = empty
  96 pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
  97
  98 pprAbsC (CClosureUpdInfo info) c
  99   = pprAbsC info c
 100
 101 pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
 102
 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 -- ---------------------------------------------------------------------------
 505 -- Changes for GrAnSim:
 506 --  draw costs for computation in head of if into both branches;
 507 --  as no abstractC data structure is given for the head, one is constructed
 508 --  guessing unknown values and fed into the costs function
 509 -- ---------------------------------------------------------------------------
 510
 511 do_if_stmt discrim tag alt_code deflt c
 512   = case tag of
 513       -- This special case happens when testing the result of a comparison.
 514       -- We can just avoid some redundant clutter in the output.
 515       MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim)
 516                                       deflt alt_code
 517                                       (addrModeCosts discrim Rhs) c
 518       other              -> let
 519                                cond = hcat [ pprAmode discrim,
 520                                           ptext SLIT(" == "),
 521                                           pprAmode (CLit tag) ]
 522                             in
 523                             ppr_if_stmt cond
 524                                          alt_code deflt
 525                                          (addrModeCosts discrim Rhs) c
 526
 527 ppr_if_stmt pp_pred then_part else_part discrim_costs c
 528   = vcat [
 529       hcat [text "if (", pp_pred, text ") {"],
 530       nest 8 (pprAbsC then_part         (c + discrim_costs +
 531                                         (Cost (0, 2, 0, 0, 0)) +
 532                                         costs then_part)),
 533       (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
 534       nest 8 (pprAbsC else_part  (c + discrim_costs +
 535                                         (Cost (0, 1, 0, 0, 0)) +
 536                                         costs else_part)),
 537       char '}' ]
 538     {- Total costs = inherited costs (before if) + costs for accessing discrim
 539                      + costs for cond branch ( = (0, 1, 0, 0, 0) )
 540                      + costs for that alternative
 541     -}
 542 \end{code}
 543
 544 Historical note: this used to be two separate cases -- one for `ccall'
 545 and one for `casm'.  To get round a potential limitation to only 10
 546 arguments, the numbering of arguments in @process_casm@ was beefed up a
 547 bit. ADR
 548
 549 Some rough notes on generating code for @CCallOp@:
 550
 551 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
 552 2) Save any essential registers (heap, stack, etc).
 553
 554    ToDo: If stable pointers are in use, these must be saved in a place
 555    where the runtime system can get at them so that the Stg world can
 556    be restarted during the call.
 557
 558 3) Save any temporary registers that are currently in use.
 559 4) Do the call putting result into a local variable
 560 5) Restore essential registers
 561 6) Restore temporaries
 562
 563    (This happens after restoration of essential registers because we
 564    might need the @Base@ register to access all the others correctly.)
 565
 566 {- Doesn't apply anymore with ForeignObj, structure create via primop.
 567    makeForeignObj (ForeignObj is not CReturnable)
 568 7) If returning Malloc Pointer, build a closure containing the
 569    appropriate value.
 570 -}
 571    Otherwise, copy local variable into result register.
 572
 573 8) If ccall (not casm), declare the function being called as extern so
 574    that C knows if it returns anything other than an int.
 575
 576 \begin{pseudocode}
 577 { ResultType _ccall_result;
 578   basic_saves;
 579   saves;
 580   _ccall_result = f( args );
 581   basic_restores;
 582   restores;
 583
 584   return_reg = _ccall_result;
 585 }
 586 \end{pseudocode}
 587
 588 Amendment to the above: if we can GC, we have to:
 589
 590 * make sure we save all our registers away where the garbage collector
 591   can get at them.
 592 * be sure that there are no live registers or we're in trouble.
 593   (This can cause problems if you try something foolish like passing
 594    an array or foreign obj to a _ccall_GC_ thing.)
 595 * increment/decrement the @inCCallGC@ counter before/after the call so
 596   that the runtime check that PerformGC is being used sensibly will work.
 597
 598 \begin{code}
 599 pprCCall op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs
 600   = if (may_gc && liveness_mask /= noLiveRegsMask)
 601     then pprPanic "Live register in _casm_GC_ "
 602                   (doubleQuotes (text casm_str) <+> hsep pp_non_void_args)
 603     else
 604     vcat [
 605       char '{',
 606       declare_local_vars,   -- local var for *result*
 607       vcat local_arg_decls,
 608       -- if is_asm then empty else declareExtern,
 609       pp_save_context,
 610       process_casm local_vars pp_non_void_args casm_str,
 611       pp_restore_context,
 612       assign_results,
 613       char '}'
 614     ]
 615   where
 616     (pp_saves, pp_restores) = ppr_vol_regs vol_regs
 617     (pp_save_context, pp_restore_context) =
 618         if may_gc
 619         then (  text "do { extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
 620                 text "inCCallGC--; RestoreAllStgRegs();} while(0);")
 621         else (  pp_basic_saves $$ pp_saves,
 622                 pp_basic_restores $$ pp_restores)
 623
 624     non_void_args =
 625         let nvas = tail args
 626         in ASSERT (all non_void nvas) nvas
 627     -- the first argument will be the "I/O world" token (a VoidRep)
 628     -- all others should be non-void
 629
 630     non_void_results =
 631         let nvrs = grab_non_void_amodes results
 632         in ASSERT (length nvrs <= 1) nvrs
 633     -- there will usually be two results: a (void) state which we
 634     -- should ignore and a (possibly void) result.
 635
 636     (local_arg_decls, pp_non_void_args)
 637       = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
 638
 639     pp_liveness = pprAmode (mkIntCLit liveness_mask)
 640
 641     (declare_local_vars, local_vars, assign_results)
 642       = ppr_casm_results non_void_results pp_liveness
 643
 644     casm_str = if is_asm then _UNPK_ op_str else ccall_str
 645
 646     -- Remainder only used for ccall
 647
 648     ccall_str = showSDoc
 649         (hcat [
 650                 if null non_void_results
 651                   then empty
 652                   else text "%r = ",
 653                 lparen, ptext op_str, lparen,
 654                   hcat (punctuate comma ccall_args),
 655                 text "));"
 656         ])
 657     num_args = length non_void_args
 658     ccall_args = take num_args [ (<>) (char '%') (int i) | i <- [0..] ]
 659 \end{code}
 660
 661 If the argument is a heap object, we need to reach inside and pull out
 662 the bit the C world wants to see.  The only heap objects which can be
 663 passed are @Array@s, @ByteArray@s and @ForeignObj@s.
 664
 665 \begin{code}
 666 ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
 667     -- (a) decl and assignment, (b) local var to be used later
 668
 669 ppr_casm_arg amode a_num
 670   = let
 671         a_kind   = getAmodeRep amode
 672         pp_amode = pprAmode amode
 673         pp_kind  = pprPrimKind a_kind
 674
 675         local_var  = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
 676
 677         (arg_type, pp_amode2)
 678           = case a_kind of
 679
 680               -- for array arguments, pass a pointer to the body of the array
 681               -- (PTRS_ARR_CTS skips over all the header nonsense)
 682               ArrayRep      -> (pp_kind,
 683                                 hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
 684               ByteArrayRep -> (pp_kind,
 685                                 hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
 686
 687               -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
 688               ForeignObjRep -> (ptext SLIT("StgForeignObj"),
 689                                 hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(',
 690                                             pp_amode, char ')'])
 691               other         -> (pp_kind, pp_amode)
 692
 693         declare_local_var
 694           = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
 695     in
 696     (declare_local_var, local_var)
 697 \end{code}
 698
 699 For l-values, the critical questions are:
 700
 701 1) Are there any results at all?
 702
 703    We only allow zero or one results.
 704
 705 {- With the introduction of ForeignObj (MallocPtr++), no longer necess.
 706 2) Is the result is a foreign obj?
 707
 708    The mallocptr must be encapsulated immediately in a heap object.
 709 -}
 710 \begin{code}
 711 ppr_casm_results
 712         :: [CAddrMode]  -- list of results (length <= 1)
 713         -> SDoc -- liveness mask
 714         ->
 715         ( SDoc,         -- declaration of any local vars
 716           [SDoc],       -- list of result vars (same length as results)
 717           SDoc )        -- assignment (if any) of results in local var to registers
 718
 719 ppr_casm_results [] liveness
 720   = (empty, [], empty)  -- no results
 721
 722 ppr_casm_results [r] liveness
 723   = let
 724         result_reg = ppr_amode r
 725         r_kind     = getAmodeRep r
 726
 727         local_var  = ptext SLIT("_ccall_result")
 728
 729         (result_type, assign_result)
 730           = case r_kind of
 731 {-
 732    @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
 733    Instead, external references have to explicitly turned into ForeignObjs
 734    using the primop makeForeignObj#. Benefit: Multiple finalisation
 735    routines can be accommodated and the below special case is not needed.
 736    Price is, of course, that you have to explicitly wrap `foreign objects'
 737    with makeForeignObj#.
 738
 739               ForeignObjRep ->
 740                 (ptext SLIT("StgForeignObj"),
 741                  hcat [ ptext SLIT("constructForeignObj"),char '(',
 742                                 liveness, comma,
 743                                 result_reg, comma,
 744                                 local_var,
 745                              pp_paren_semi ])
 746 -}
 747               _ ->
 748                 (pprPrimKind r_kind,
 749                  hcat [ result_reg, equals, local_var, semi ])
 750
 751         declare_local_var = hcat [ result_type, space, local_var, semi ]
 752     in
 753     (declare_local_var, [local_var], assign_result)
 754
 755 ppr_casm_results rs liveness
 756   = panic "ppr_casm_results: ccall/casm with many results"
 757 \end{code}
 758
 759
 760 Note the sneaky way _the_ result is represented by a list so that we
 761 can complain if it's used twice.
 762
 763 ToDo: Any chance of giving line numbers when process-casm fails?
 764       Or maybe we should do a check _much earlier_ in compiler. ADR
 765
 766 \begin{code}
 767 process_casm ::
 768         [SDoc]          -- results (length <= 1)
 769         -> [SDoc]               -- arguments
 770         -> String               -- format string (with embedded %'s)
 771         ->
 772         SDoc                    -- code being generated
 773
 774 process_casm results args string = process results args string
 775  where
 776   process []    _ "" = empty
 777   process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
 778
 779   process ress args ('%':cs)
 780     = case cs of
 781         [] ->
 782             error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
 783
 784         ('%':css) ->
 785             (<>) (char '%') (process ress args css)
 786
 787         ('r':css)  ->
 788           case ress of
 789             []  -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
 790             [r] -> (<>) r (process [] args css)
 791             _   -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
 792
 793         other ->
 794           let
 795                 read_int :: ReadS Int
 796                 read_int = reads
 797           in
 798           case (read_int other) of
 799             [(num,css)] ->
 800                   if 0 <= num && num < length args
 801                   then (<>) (parens (args !! num))
 802                                  (process ress args css)
 803                     else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
 804             _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
 805
 806   process ress args (other_c:cs)
 807     = (<>) (char other_c) (process ress args cs)
 808 \end{code}
 809
 810 %************************************************************************
 811 %*                                                                      *
 812 \subsection[a2r-assignments]{Assignments}
 813 %*                                                                      *
 814 %************************************************************************
 815
 816 Printing assignments is a little tricky because of type coercion.
 817
 818 First of all, the kind of the thing being assigned can be gotten from
 819 the destination addressing mode.  (It should be the same as the kind
 820 of the source addressing mode.)  If the kind of the assignment is of
 821 @VoidRep@, then don't generate any code at all.
 822
 823 \begin{code}
 824 pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc
 825
 826 pprAssign VoidRep dest src = empty
 827 \end{code}
 828
 829 Special treatment for floats and doubles, to avoid unwanted conversions.
 830
 831 \begin{code}
 832 pprAssign FloatRep dest@(CVal reg_rel _) src
 833   = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
 834
 835 pprAssign DoubleRep dest@(CVal reg_rel _) src
 836   = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
 837 \end{code}
 838
 839 Lastly, the question is: will the C compiler think the types of the
 840 two sides of the assignment match?
 841
 842         We assume that the types will match
 843         if neither side is a @CVal@ addressing mode for any register
 844         which can point into the heap or B stack.
 845
 846 Why?  Because the heap and B stack are used to store miscellaneous things,
 847 whereas the A stack, temporaries, registers, etc., are only used for things
 848 of fixed type.
 849
 850 \begin{code}
 851 pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
 852   = hcat [ pprVanillaReg dest, equals,
 853                 pprVanillaReg src, semi ]
 854
 855 pprAssign kind dest src
 856   | mixedTypeLocn dest
 857     -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
 858   = hcat [ ppr_amode dest, equals,
 859                 text "(W_)(",   -- Here is the cast
 860                 ppr_amode src, pp_paren_semi ]
 861
 862 pprAssign kind dest src
 863   | mixedPtrLocn dest && getAmodeRep src /= PtrRep
 864     -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
 865   = hcat [ ppr_amode dest, equals,
 866                 text "(P_)(",   -- Here is the cast
 867                 ppr_amode src, pp_paren_semi ]
 868
 869 pprAssign ByteArrayRep dest src
 870   | mixedPtrLocn src
 871     -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
 872   = hcat [ ppr_amode dest, equals,
 873                 text "(B_)(",   -- Here is the cast
 874                 ppr_amode src, pp_paren_semi ]
 875
 876 pprAssign kind other_dest src
 877   = hcat [ ppr_amode other_dest, equals,
 878                 pprAmode  src, semi ]
 879 \end{code}
 880
 881
 882 %************************************************************************
 883 %*                                                                      *
 884 \subsection[a2r-CAddrModes]{Addressing modes}
 885 %*                                                                      *
 886 %************************************************************************
 887
 888 @pprAmode@ is used to print r-values (which may need casts), whereas
 889 @ppr_amode@ is used for l-values {\em and} as a help function for
 890 @pprAmode@.
 891
 892 \begin{code}
 893 pprAmode, ppr_amode :: CAddrMode -> SDoc
 894 \end{code}
 895
 896 For reasons discussed above under assignments, @CVal@ modes need
 897 to be treated carefully.  First come special cases for floats and doubles,
 898 similar to those in @pprAssign@:
 899
 900 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
 901 question.)
 902
 903 \begin{code}
 904 pprAmode (CVal reg_rel FloatRep)
 905   = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
 906 pprAmode (CVal reg_rel DoubleRep)
 907   = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
 908 \end{code}
 909
 910 Next comes the case where there is some other cast need, and the
 911 no-cast case:
 912
 913 \begin{code}
 914 pprAmode amode
 915   | mixedTypeLocn amode
 916   = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("),
 917                 ppr_amode amode ])
 918   | otherwise   -- No cast needed
 919   = ppr_amode amode
 920 \end{code}
 921
 922 Now the rest of the cases for ``workhorse'' @ppr_amode@:
 923
 924 \begin{code}
 925 ppr_amode (CVal reg_rel _)
 926   = case (pprRegRelative False{-no sign wanted-} reg_rel) of
 927         (pp_reg, Nothing)     -> (<>)  (char '*') pp_reg
 928         (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
 929
 930 ppr_amode (CAddr reg_rel)
 931   = case (pprRegRelative True{-sign wanted-} reg_rel) of
 932         (pp_reg, Nothing)     -> pp_reg
 933         (pp_reg, Just offset) -> (<>) pp_reg offset
 934
 935 ppr_amode (CReg magic_id) = pprMagicId magic_id
 936
 937 ppr_amode (CTemp uniq kind) = pprUnique uniq <> char '_'
 938
 939 ppr_amode (CLbl label kind) = pprCLabel label
 940
 941 ppr_amode (CUnVecLbl direct vectored)
 942   = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel direct, comma,
 943                pprCLabel vectored, rparen]
 944
 945 ppr_amode (CCharLike ch)
 946   = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
 947 ppr_amode (CIntLike int)
 948   = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
 949
 950 ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
 951   -- ToDo: are these *used* for anything?
 952
 953 ppr_amode (CLit lit) = pprBasicLit lit
 954
 955 ppr_amode (CLitLit str _) = ptext str
 956
 957 ppr_amode (COffset off) = pprHeapOffset off
 958
 959 ppr_amode (CCode abs_C)
 960   = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ]
 961
 962 ppr_amode (CLabelledCode label abs_C)
 963   = vcat [ hcat [pprCLabel label, ptext SLIT(" = { -- CLabelledCode")],
 964                nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ]
 965
 966 ppr_amode (CJoinPoint _ _)
 967   = panic "ppr_amode: CJoinPoint"
 968
 969 ppr_amode (CTableEntry base index kind)
 970   = hcat [text "((", pprPrimKind kind, text " *)(",
 971                ppr_amode base, text "))[(I_)(", ppr_amode index,
 972                ptext SLIT(")]")]
 973
 974 ppr_amode (CMacroExpr pk macro as)
 975   = hcat [lparen, pprPrimKind pk, text ")(", text (show macro), lparen,
 976                hcat (punctuate comma (map pprAmode as)), text "))"]
 977
 978 ppr_amode (CCostCentre cc print_as_string)
 979   = uppCostCentre print_as_string cc
 980 \end{code}
 981
 982 %************************************************************************
 983 %*                                                                      *
 984 \subsection[a2r-MagicIds]{Magic ids}
 985 %*                                                                      *
 986 %************************************************************************
 987
 988 @pprRegRelative@ returns a pair of the @Doc@ for the register
 989 (some casting may be required), and a @Maybe Doc@ for the offset
 990 (zero offset gives a @Nothing@).
 991
 992 \begin{code}
 993 addPlusSign :: Bool -> SDoc -> SDoc
 994 addPlusSign False p = p
 995 addPlusSign True  p = (<>) (char '+') p
 996
 997 pprSignedInt :: Bool -> Int -> Maybe SDoc       -- Nothing => 0
 998 pprSignedInt sign_wanted n
 999  = if n == 0 then Nothing else
1000    if n > 0  then Just (addPlusSign sign_wanted (int n))
1001    else           Just (int n)
1002
1003 pprRegRelative :: Bool          -- True <=> Print leading plus sign (if +ve)
1004                -> RegRelative
1005                -> (SDoc, Maybe SDoc)
1006
1007 pprRegRelative sign_wanted (SpARel spA off)
1008   = (pprMagicId SpA, pprSignedInt sign_wanted (spARelToInt spA off))
1009
1010 pprRegRelative sign_wanted (SpBRel spB off)
1011   = (pprMagicId SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
1012
1013 pprRegRelative sign_wanted r@(HpRel hp off)
1014   = let to_print = hp `subOff` off
1015         pp_Hp    = pprMagicId Hp
1016     in
1017     if isZeroOff to_print then
1018         (pp_Hp, Nothing)
1019     else
1020         (pp_Hp, Just ((<>) (char '-') (pprHeapOffset to_print)))
1021                                 -- No parens needed because pprHeapOffset
1022                                 -- does them when necessary
1023
1024 pprRegRelative sign_wanted (NodeRel off)
1025   = let pp_Node = pprMagicId node
1026     in
1027     if isZeroOff off then
1028         (pp_Node, Nothing)
1029     else
1030         (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset off)))
1031
1032 \end{code}
1033
1034 @pprMagicId@ just prints the register name.  @VanillaReg@ registers are
1035 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1036 to select the union tag.
1037
1038 \begin{code}
1039 pprMagicId :: MagicId -> SDoc
1040
1041 pprMagicId BaseReg                  = ptext SLIT("BaseReg")
1042 pprMagicId StkOReg                  = ptext SLIT("StkOReg")
1043 pprMagicId (VanillaReg pk n)
1044                                     = hcat [ pprVanillaReg n, char '.',
1045                                                   pprUnionTag pk ]
1046 pprMagicId (FloatReg  n)        = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
1047 pprMagicId (DoubleReg n)            = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
1048 pprMagicId TagReg                   = ptext SLIT("TagReg")
1049 pprMagicId RetReg                   = ptext SLIT("RetReg")
1050 pprMagicId SpA              = ptext SLIT("SpA")
1051 pprMagicId SuA              = ptext SLIT("SuA")
1052 pprMagicId SpB              = ptext SLIT("SpB")
1053 pprMagicId SuB              = ptext SLIT("SuB")
1054 pprMagicId Hp               = ptext SLIT("Hp")
1055 pprMagicId HpLim                    = ptext SLIT("HpLim")
1056 pprMagicId LivenessReg      = ptext SLIT("LivenessReg")
1057 pprMagicId StdUpdRetVecReg      = ptext SLIT("StdUpdRetVecReg")
1058 pprMagicId StkStubReg       = ptext SLIT("StkStubReg")
1059 pprMagicId CurCostCentre            = ptext SLIT("CCC")
1060 pprMagicId VoidReg                  = panic "pprMagicId:VoidReg!"
1061
1062 pprVanillaReg :: FAST_INT -> SDoc
1063
1064 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
1065
1066 pprUnionTag :: PrimRep -> SDoc
1067
1068 pprUnionTag PtrRep              = char 'p'
1069 pprUnionTag CodePtrRep          = ptext SLIT("fp")
1070 pprUnionTag DataPtrRep          = char 'd'
1071 pprUnionTag RetRep              = char 'r'
1072 pprUnionTag CostCentreRep       = panic "pprUnionTag:CostCentre?"
1073
1074 pprUnionTag CharRep             = char 'c'
1075 pprUnionTag IntRep              = char 'i'
1076 pprUnionTag WordRep             = char 'w'
1077 pprUnionTag AddrRep             = char 'v'
1078 pprUnionTag FloatRep            = char 'f'
1079 pprUnionTag DoubleRep           = panic "pprUnionTag:Double?"
1080
1081 pprUnionTag StablePtrRep        = char 'i'
1082 pprUnionTag ForeignObjRep       = char 'p'
1083
1084 pprUnionTag ArrayRep            = char 'p'
1085 pprUnionTag ByteArrayRep        = char 'b'
1086
1087 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
1088 \end{code}
1089
1090
1091 Find and print local and external declarations for a list of
1092 Abstract~C statements.
1093 \begin{code}
1094 pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
1095 pprTempAndExternDecls AbsCNop = (empty, empty)
1096
1097 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1098   = initTE (ppr_decls_AbsC stmt1        `thenTE` \ (t_p1, e_p1) ->
1099             ppr_decls_AbsC stmt2        `thenTE` \ (t_p2, e_p2) ->
1100             case (catMaybes [t_p1, t_p2])        of { real_temps ->
1101             case (catMaybes [e_p1, e_p2])        of { real_exts ->
1102             returnTE (vcat real_temps, vcat real_exts) }}
1103            )
1104
1105 pprTempAndExternDecls other_stmt
1106   = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1107             returnTE (
1108                 case maybe_t of
1109                   Nothing -> empty
1110                   Just pp -> pp,
1111
1112                 case maybe_e of
1113                   Nothing -> empty
1114                   Just pp -> pp )
1115            )
1116
1117 pprBasicLit :: Literal -> SDoc
1118 pprPrimKind :: PrimRep -> SDoc
1119
1120 pprBasicLit  lit = ppr lit
1121 pprPrimKind  k   = ppr k
1122 \end{code}
1123
1124
1125 %************************************************************************
1126 %*                                                                      *
1127 \subsection[a2r-monad]{Monadery}
1128 %*                                                                      *
1129 %************************************************************************
1130
1131 We need some monadery to keep track of temps and externs we have already
1132 printed.  This info must be threaded right through the Abstract~C, so
1133 it's most convenient to hide it in this monad.
1134
1135 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1136 \tr{(UniqSet, CLabelSet)}.  Allegedly for efficiency.
1137
1138 \begin{code}
1139 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1140 emptyCLabelSet = emptyFM
1141 x `elementOfCLabelSet` labs
1142   = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1143 addToCLabelSet set x = addToFM set x ()
1144
1145 type TEenv = (UniqSet Unique, CLabelSet)
1146
1147 type TeM result =  TEenv -> (TEenv, result)
1148
1149 initTE :: TeM a -> a
1150 initTE sa
1151   = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1152     result }
1153
1154 {-# INLINE thenTE #-}
1155 {-# INLINE returnTE #-}
1156
1157 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1158 thenTE a b u
1159   = case a u        of { (u_1, result_of_a) ->
1160     b result_of_a u_1 }
1161
1162 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1163 mapTE f []     = returnTE []
1164 mapTE f (x:xs)
1165   = f x         `thenTE` \ r  ->
1166     mapTE f xs  `thenTE` \ rs ->
1167     returnTE (r : rs)
1168
1169 returnTE :: a -> TeM a
1170 returnTE result env = (env, result)
1171
1172 -- these next two check whether the thing is already
1173 -- recorded, and THEN THEY RECORD IT
1174 -- (subsequent calls will return False for the same uniq/label)
1175
1176 tempSeenTE :: Unique -> TeM Bool
1177 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1178   = if (uniq `elementOfUniqSet` seen_uniqs)
1179     then (env, True)
1180     else ((addOneToUniqSet seen_uniqs uniq,
1181           seen_labels),
1182           False)
1183
1184 labelSeenTE :: CLabel -> TeM Bool
1185 labelSeenTE label env@(seen_uniqs, seen_labels)
1186   = if (label `elementOfCLabelSet` seen_labels)
1187     then (env, True)
1188     else ((seen_uniqs,
1189           addToCLabelSet seen_labels label),
1190           False)
1191 \end{code}
1192
1193 \begin{code}
1194 pprTempDecl :: Unique -> PrimRep -> SDoc
1195 pprTempDecl uniq kind
1196   = hcat [ pprPrimKind kind, space, pprUnique uniq, ptext SLIT("_;") ]
1197
1198 pprExternDecl :: CLabel -> PrimRep -> SDoc
1199
1200 pprExternDecl clabel kind
1201   = if not (needsCDecl clabel) then
1202         empty -- do not print anything for "known external" things (e.g., < PreludeCore)
1203     else
1204         case (
1205             case kind of
1206               CodePtrRep -> ppLocalnessMacro True{-function-} clabel
1207               _          -> ppLocalnessMacro False{-data-}    clabel
1208         ) of { pp_macro_str ->
1209
1210         hcat [ pp_macro_str, lparen, pprCLabel clabel, pp_paren_semi ]
1211         }
1212 \end{code}
1213
1214 \begin{code}
1215 ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})
1216
1217 ppr_decls_AbsC AbsCNop          = returnTE (Nothing, Nothing)
1218
1219 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1220   = ppr_decls_AbsC stmts_1  `thenTE` \ p1 ->
1221     ppr_decls_AbsC stmts_2  `thenTE` \ p2 ->
1222     returnTE (maybe_vcat [p1, p2])
1223
1224 ppr_decls_AbsC (CClosureUpdInfo info)
1225   = ppr_decls_AbsC info
1226
1227 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1228
1229 ppr_decls_AbsC (CAssign dest source)
1230   = ppr_decls_Amode dest    `thenTE` \ p1 ->
1231     ppr_decls_Amode source  `thenTE` \ p2 ->
1232     returnTE (maybe_vcat [p1, p2])
1233
1234 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1235
1236 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1237
1238 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1239
1240 ppr_decls_AbsC (CSwitch discrim alts deflt)
1241   = ppr_decls_Amode discrim     `thenTE` \ pdisc ->
1242     mapTE ppr_alt_stuff alts    `thenTE` \ palts  ->
1243     ppr_decls_AbsC deflt        `thenTE` \ pdeflt ->
1244     returnTE (maybe_vcat (pdisc:pdeflt:palts))
1245   where
1246     ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1247
1248 ppr_decls_AbsC (CCodeBlock label absC)
1249   = ppr_decls_AbsC absC
1250
1251 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1252         -- ToDo: strictly speaking, should chk "cost_centre" amode
1253   = labelSeenTE info_lbl     `thenTE` \  label_seen ->
1254     returnTE (Nothing,
1255               if label_seen then
1256                   Nothing
1257               else
1258                   Just (pprExternDecl info_lbl PtrRep))
1259   where
1260     info_lbl = infoTableLabelFromCI cl_info
1261
1262 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1263 ppr_decls_AbsC (CSimultaneous abc)          = ppr_decls_AbsC abc
1264
1265 ppr_decls_AbsC (CMacroStmt          _ amodes)   = ppr_decls_Amodes amodes
1266
1267 ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)   = ppr_decls_Amodes [] -- *****!!!
1268   -- you get some nasty re-decls of stdio.h if you compile
1269   -- the prelude while looking inside those amodes;
1270   -- no real reason to, anyway.
1271 ppr_decls_AbsC (CCallProfCCMacro    _ amodes)   = ppr_decls_Amodes amodes
1272
1273 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1274         -- ToDo: strictly speaking, should chk "cost_centre" amode
1275   = ppr_decls_Amodes amodes
1276
1277 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1278   = ppr_decls_Amodes [entry_lbl, upd_lbl]       `thenTE` \ p1 ->
1279     ppr_decls_AbsC slow                         `thenTE` \ p2 ->
1280     (case maybe_fast of
1281         Nothing   -> returnTE (Nothing, Nothing)
1282         Just fast -> ppr_decls_AbsC fast)       `thenTE` \ p3 ->
1283     returnTE (maybe_vcat [p1, p2, p3])
1284   where
1285     entry_lbl = CLbl slow_lbl CodePtrRep
1286     slow_lbl    = case (nonemptyAbsC slow) of
1287                     Nothing -> mkErrorStdEntryLabel
1288                     Just _  -> entryLabelFromCI cl_info
1289
1290 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1291   = ppr_decls_Amodes (catMaybes maybe_amodes)   `thenTE` \ p1 ->
1292     ppr_decls_AbsC   absC                       `thenTE` \ p2 ->
1293     returnTE (maybe_vcat [p1, p2])
1294
1295 ppr_decls_AbsC (CRetUnVector   _ amode)  = ppr_decls_Amode amode
1296 ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
1297 \end{code}
1298
1299 \begin{code}
1300 ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
1301 ppr_decls_Amode (CVal _ _)      = returnTE (Nothing, Nothing)
1302 ppr_decls_Amode (CAddr _)       = returnTE (Nothing, Nothing)
1303 ppr_decls_Amode (CReg _)        = returnTE (Nothing, Nothing)
1304 ppr_decls_Amode (CString _)     = returnTE (Nothing, Nothing)
1305 ppr_decls_Amode (CLit _)        = returnTE (Nothing, Nothing)
1306 ppr_decls_Amode (CLitLit _ _)   = returnTE (Nothing, Nothing)
1307 ppr_decls_Amode (COffset _)     = returnTE (Nothing, Nothing)
1308
1309 -- CIntLike must be a literal -- no decls
1310 ppr_decls_Amode (CIntLike int)  = returnTE (Nothing, Nothing)
1311
1312 -- CCharLike may have be arbitrary value -- may have decls
1313 ppr_decls_Amode (CCharLike char)
1314   = ppr_decls_Amode char
1315
1316 -- now, the only place where we actually print temps/externs...
1317 ppr_decls_Amode (CTemp uniq kind)
1318   = case kind of
1319       VoidRep -> returnTE (Nothing, Nothing)
1320       other ->
1321         tempSeenTE uniq `thenTE` \ temp_seen ->
1322         returnTE
1323           (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1324
1325 ppr_decls_Amode (CLbl label VoidRep)
1326   = returnTE (Nothing, Nothing)
1327
1328 ppr_decls_Amode (CLbl label kind)
1329   = labelSeenTE label `thenTE` \ label_seen ->
1330     returnTE (Nothing,
1331               if label_seen then Nothing else Just (pprExternDecl label kind))
1332
1333 {- WRONG:
1334 ppr_decls_Amode (CUnVecLbl direct vectored)
1335   = labelSeenTE direct   `thenTE` \ dlbl_seen ->
1336     labelSeenTE vectored `thenTE` \ vlbl_seen ->
1337     let
1338         ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
1339         vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
1340     in
1341     returnTE (Nothing,
1342                 if (dlbl_seen || not (needsCDecl direct)) &&
1343                    (vlbl_seen || not (needsCDecl vectored)) then Nothing
1344                 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1345 -}
1346
1347 ppr_decls_Amode (CUnVecLbl direct vectored)
1348   = -- We don't mark either label as "seen", because
1349     -- we don't know which one will be used and which one tossed
1350     -- by the C macro...
1351     --labelSeenTE direct   `thenTE` \ dlbl_seen ->
1352     --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1353     let
1354         ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
1355         vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
1356     in
1357     returnTE (Nothing,
1358                 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1359                    ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1360                 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1361
1362 ppr_decls_Amode (CTableEntry base index _)
1363   = ppr_decls_Amode base    `thenTE` \ p1 ->
1364     ppr_decls_Amode index   `thenTE` \ p2 ->
1365     returnTE (maybe_vcat [p1, p2])
1366
1367 ppr_decls_Amode (CMacroExpr _ _ amodes)
1368   = ppr_decls_Amodes amodes
1369
1370 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1371
1372
1373 maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
1374 maybe_vcat ps
1375   = case (unzip ps)     of { (ts, es) ->
1376     case (catMaybes ts) of { real_ts  ->
1377     case (catMaybes es) of { real_es  ->
1378     (if (null real_ts) then Nothing else Just (vcat real_ts),
1379      if (null real_es) then Nothing else Just (vcat real_es))
1380     } } }
1381 \end{code}
1382
1383 \begin{code}
1384 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
1385 ppr_decls_Amodes amodes
1386   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1387     returnTE ( maybe_vcat ps )
1388 \end{code}