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