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 = printForC handle (pprAbsC absC (costs absC))
  64
  65 dumpRealC :: AbstractC -> SDoc
  66 dumpRealC absC = pprAbsC absC (costs absC)
  67 \end{code}
  68
  69 This emits the macro,  which is used in GrAnSim  to compute the total costs
  70 from a cost 5 tuple. %%  HWL
  71
  72 \begin{code}
  73 emitMacro :: CostRes -> SDoc
  74
  75 -- ToDo: Check a compile time flag to decide whether a macro should be emitted
  76 emitMacro (Cost (i,b,l,s,f))
  77   = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
  78                           int i, comma, int b, comma, int l, comma,
  79                           int s, comma, int f, pp_paren_semi ]
  80 \end{code}
  81
  82 \begin{code}
  83 pp_paren_semi = text ");"
  84
  85 -- ---------------------------------------------------------------------------
  86 -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
  87 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
  88 -- which must be done before the return i.e. inside absC code)   HWL
  89 -- ---------------------------------------------------------------------------
  90
  91 pprAbsC :: AbstractC -> CostRes -> SDoc
  92
  93 pprAbsC AbsCNop _ = empty
  94 pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
  95
  96 pprAbsC (CClosureUpdInfo info) c
  97   = pprAbsC info c
  98
  99 pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
 100
 101 pprAbsC (CJump target) c
 102   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
 103              (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
 104
 105 pprAbsC (CFallThrough target) c
 106   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CFallThrough */"-} ])
 107              (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
 108
 109 -- --------------------------------------------------------------------------
 110 -- Spit out GRAN_EXEC macro immediately before the return                 HWL
 111
 112 pprAbsC (CReturn am return_info)  c
 113   = ($$) (hcat [emitMacro c {-WDP:, text "/* <----  CReturn */"-} ])
 114              (hcat [text jmp_lit, target, pp_paren_semi ])
 115   where
 116    target = case return_info of
 117         DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode am, rparen]
 118         DynamicVectoredReturn am' -> mk_vector (pprAmode am')
 119         StaticVectoredReturn n -> mk_vector (int n)     -- Always positive
 120    mk_vector x = hcat [parens (pprAmode am), brackets (text "RVREL" <> parens x)]
 121
 122 pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
 123
 124 -- we optimise various degenerate cases of CSwitches.
 125
 126 -- --------------------------------------------------------------------------
 127 -- Assume: CSwitch is also end of basic block
 128 --         costs function yields nullCosts for whole switch
 129 --         ==> inherited costs c are those of basic block up to switch
 130 --         ==> inherit c + costs for the corresponding branch
 131 --                                                                       HWL
 132 -- --------------------------------------------------------------------------
 133
 134 pprAbsC (CSwitch discrim [] deflt) c
 135   = pprAbsC deflt (c + costs deflt)
 136     -- Empty alternative list => no costs for discrim as nothing cond. here HWL
 137
 138 pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
 139   = case (nonemptyAbsC deflt) of
 140       Nothing ->                -- one alt and no default
 141                  pprAbsC alt_code (c + costs alt_code)
 142                  -- Nothing conditional in here either  HWL
 143
 144       Just dc ->                -- make it an "if"
 145                  do_if_stmt discrim tag alt_code dc c
 146
 147 pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
 148                               (tag2@(MachInt i2 _), alt_code2)] deflt) c
 149   | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
 150   = if (i1 == 0) then
 151         do_if_stmt discrim tag1 alt_code1 alt_code2 c
 152     else
 153         do_if_stmt discrim tag2 alt_code2 alt_code1 c
 154   where
 155     empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
 156
 157 pprAbsC (CSwitch discrim alts deflt) c -- general case
 158   | isFloatingRep (getAmodeRep discrim)
 159     = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
 160   | otherwise
 161     = vcat [
 162         hcat [text "switch (", pp_discrim, text ") {"],
 163         nest 2 (vcat (map ppr_alt alts)),
 164         (case (nonemptyAbsC deflt) of
 165            Nothing -> empty
 166            Just dc ->
 167             nest 2 (vcat [ptext SLIT("default:"),
 168                                   pprAbsC dc (c + switch_head_cost
 169                                                     + costs dc),
 170                                   ptext SLIT("break;")])),
 171         char '}' ]
 172   where
 173     pp_discrim
 174       = pprAmode discrim
 175
 176     ppr_alt (lit, absC)
 177       = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'],
 178                    nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC))
 179                                        (ptext SLIT("break;"))) ]
 180
 181     -- Costs for addressing header of switch and cond. branching        -- HWL
 182     switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
 183
 184 pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _
 185   = pprCCall op args results liveness_mask vol_regs
 186
 187 pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _
 188   = let
 189         non_void_args = grab_non_void_amodes args
 190         non_void_results = grab_non_void_amodes results
 191         -- if just one result, we print in the obvious "assignment" style;
 192         -- if 0 or many results, we emit a macro call, w/ the results
 193         -- followed by the arguments.  The macro presumably knows which
 194         -- are which :-)
 195
 196         the_op = ppr_op_call non_void_results non_void_args
 197                 -- liveness mask is *in* the non_void_args
 198     in
 199     case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
 200     if primOpNeedsWrapper op then
 201         vcat [  pp_saves,
 202                     the_op,
 203                     pp_restores
 204                  ]
 205     else
 206         the_op
 207     }
 208   where
 209     ppr_op_call results args
 210       = hcat [ pprPrimOp op, lparen,
 211         hcat (punctuate comma (map ppr_op_result results)),
 212         if null results || null args then empty else comma,
 213         hcat (punctuate comma (map pprAmode args)),
 214         pp_paren_semi ]
 215
 216     ppr_op_result r = ppr_amode r
 217       -- primop macros do their own casting of result;
 218       -- hence we can toss the provided cast...
 219
 220 pprAbsC (CSimultaneous abs_c) c
 221   = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
 222
 223 pprAbsC stmt@(CMacroStmt macro as) _
 224   = hcat [text (show macro), lparen,
 225         hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
 226 pprAbsC stmt@(CCallProfCtrMacro op as) _
 227   = hcat [ptext op, lparen,
 228         hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
 229 pprAbsC stmt@(CCallProfCCMacro op as) _
 230   = hcat [ptext op, lparen,
 231         hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
 232
 233 pprAbsC (CCodeBlock label abs_C) _
 234   = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
 235     case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
 236     vcat [
 237         hcat [text (if (externallyVisibleCLabel label)
 238                           then "FN_("   -- abbreviations to save on output
 239                           else "IFN_("),
 240                    pprCLabel label, text ") {"],
 241
 242         pp_exts, pp_temps,
 243
 244         nest 8 (ptext SLIT("FB_")),
 245         nest 8 (pprAbsC abs_C (costs abs_C)),
 246         nest 8 (ptext SLIT("FE_")),
 247         char '}' ]
 248     }
 249
 250 pprAbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
 251   = hcat [ pp_init_hdr, text "_HDR(",
 252                 ppr_amode (CAddr reg_rel), comma,
 253                 pprCLabel info_lbl, comma,
 254                 if_profiling (pprAmode cost_centre), comma,
 255                 pprHeapOffset size, comma, int ptr_wds, pp_paren_semi ]
 256   where
 257     info_lbl    = infoTableLabelFromCI cl_info
 258     sm_rep      = closureSMRep     cl_info
 259     size        = closureSizeWithoutFixedHdr cl_info
 260     ptr_wds     = closurePtrsSize  cl_info
 261
 262     pp_init_hdr = text (if inplace_upd then
 263                             getSMUpdInplaceHdrStr sm_rep
 264                         else
 265                             getSMInitHdrStr sm_rep)
 266
 267 pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
 268   = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
 269     vcat [
 270         pp_exts,
 271         hcat [
 272                 ptext SLIT("SET_STATIC_HDR"),char '(',
 273                 pprCLabel closure_lbl,                  comma,
 274                 pprCLabel info_lbl,                             comma,
 275                 if_profiling (pprAmode cost_centre),    comma,
 276                 ppLocalness closure_lbl,                        comma,
 277                 ppLocalnessMacro False{-for data-} info_lbl,
 278                 char ')'
 279                 ],
 280         nest 2 (hcat (map ppr_item amodes)),
 281         nest 2 (hcat (map ppr_item padding_wds)),
 282         ptext SLIT("};") ]
 283     }
 284   where
 285     info_lbl = infoTableLabelFromCI cl_info
 286
 287     ppr_item item
 288       = if getAmodeRep item == VoidRep
 289         then text ", (W_) 0" -- might not even need this...
 290         else (<>) (text ", (W_)") (ppr_amode item)
 291
 292     padding_wds =
 293         if not (closureUpdReqd cl_info) then
 294             []
 295         else
 296             case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
 297             nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
 298
 299 {-
 300    STATIC_INIT_HDR(c,i,localness) blows into:
 301         localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
 302
 303    then *NO VarHdr STUFF FOR STATIC*...
 304
 305    then the amodes are dropped in...
 306         ,a1 ,a2 ... ,aN
 307    then a close brace:
 308         };
 309 -}
 310
 311 pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
 312   = vcat [
 313         hcat [
 314             pp_info_rep,
 315             ptext SLIT("_ITBL"),char '(',
 316             pprCLabel info_lbl,                 comma,
 317
 318                 -- CONST_ITBL needs an extra label for
 319                 -- the static version of the object.
 320             if isConstantRep sm_rep
 321             then (<>) (pprCLabel (closureLabelFromCI cl_info)) comma
 322             else empty,
 323
 324             pprCLabel slow_lbl, comma,
 325             pprAmode upd,               comma,
 326             int liveness,               comma,
 327
 328             pp_tag,                     comma,
 329             pp_size,                    comma,
 330             pp_ptr_wds,                 comma,
 331
 332             ppLocalness info_lbl,                               comma,
 333             ppLocalnessMacro True{-function-} slow_lbl,         comma,
 334
 335             if is_selector
 336             then (<>) (int select_word_i) comma
 337             else empty,
 338
 339             if_profiling pp_kind, comma,
 340             if_profiling pp_descr, comma,
 341             if_profiling pp_type,
 342             text ");"
 343         ],
 344         pp_slow,
 345         case maybe_fast of
 346             Nothing -> empty
 347             Just fast -> let stuff = CCodeBlock fast_lbl fast in
 348                          pprAbsC stuff (costs stuff)
 349     ]
 350   where
 351     info_lbl    = infoTableLabelFromCI cl_info
 352     fast_lbl    = fastLabelFromCI cl_info
 353     sm_rep      = closureSMRep    cl_info
 354
 355     (slow_lbl, pp_slow)
 356       = case (nonemptyAbsC slow) of
 357           Nothing -> (mkErrorStdEntryLabel, empty)
 358           Just xx -> (entryLabelFromCI cl_info,
 359                        let stuff = CCodeBlock slow_lbl xx in
 360                        pprAbsC stuff (costs stuff))
 361
 362     maybe_selector = maybeSelectorInfo cl_info
 363     is_selector = maybeToBool maybe_selector
 364     (Just (_, select_word_i)) = maybe_selector
 365
 366     pp_info_rep     -- special stuff if it's a selector; otherwise, just the SMrep
 367       = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
 368
 369     pp_tag = int (closureSemiTag cl_info)
 370
 371     is_phantom = isPhantomRep sm_rep
 372
 373     pp_size = if isSpecRep sm_rep then  -- exploiting: SPEC_VHS == 0 (always)
 374                  int (closureNonHdrSize cl_info)
 375
 376               else if is_phantom then   -- do not have sizes for these
 377                  empty
 378               else
 379                  pprHeapOffset (closureSizeWithoutFixedHdr cl_info)
 380
 381     pp_ptr_wds  = if is_phantom then
 382                      empty
 383                   else
 384                      int (closurePtrsSize cl_info)
 385
 386     pp_kind  = text (closureKind cl_info)
 387     pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
 388     pp_type  = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
 389
 390 pprAbsC (CRetVector lbl maybes deflt) c
 391   = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
 392                nest 8 (sep (map ppr_maybe_amode maybes)),
 393                text "} /*default=*/ {", pprAbsC deflt c,
 394                char '}']
 395   where
 396     ppr_maybe_amode Nothing  = ptext SLIT("/*default*/")
 397     ppr_maybe_amode (Just a) = pprAmode a
 398
 399 pprAbsC stmt@(CRetUnVector label amode) _
 400   = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel label, comma,
 401             pprAmode amode, rparen]
 402   where
 403     pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
 404
 405 pprAbsC stmt@(CFlatRetVector label amodes) _
 406   =     case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
 407         vcat [
 408             pp_exts,
 409             hcat [ppLocalness label, ptext SLIT(" W_ "),
 410                        pprCLabel label, text "[] = {"],
 411             nest 2 (sep (punctuate comma (map ppr_item amodes))),
 412             text "};" ] }
 413   where
 414     ppr_item item = (<>) (text "(W_) ") (ppr_amode item)
 415
 416 pprAbsC (CCostCentreDecl is_local cc) _ = uppCostCentreDecl is_local cc
 417 \end{code}
 418
 419 \begin{code}
 420 ppLocalness label
 421   = (<>) static const
 422   where
 423     static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ")
 424     const  = if not (isReadOnly label)          then empty else ptext SLIT("const")
 425
 426 ppLocalnessMacro for_fun{-vs data-} clabel
 427   = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
 428                  if for_fun then
 429                     ptext SLIT("F_")
 430                  else
 431                     (<>) (ptext SLIT("D_"))
 432                               (if isReadOnly clabel then
 433                                   ptext SLIT("RO_")
 434                                else
 435                                   empty)]
 436 \end{code}
 437
 438 \begin{code}
 439 jmp_lit = "JMP_("
 440
 441 grab_non_void_amodes amodes
 442   = filter non_void amodes
 443
 444 non_void amode
 445   = case (getAmodeRep amode) of
 446       VoidRep -> False
 447       k -> True
 448 \end{code}
 449
 450 \begin{code}
 451 ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
 452
 453 ppr_vol_regs [] = (empty, empty)
 454 ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs
 455 ppr_vol_regs (r:rs)
 456   = let pp_reg = case r of
 457                     VanillaReg pk n -> pprVanillaReg n
 458                     _ -> pprMagicId r
 459         (more_saves, more_restores) = ppr_vol_regs rs
 460     in
 461     (($$) ((<>) (ptext SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
 462      ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
 463
 464 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
 465 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
 466 -- depending on the platform.  (The "volatile regs" stuff handles all
 467 -- other registers.)  Just be *sure* BaseReg is OK before trying to do
 468 -- anything else.
 469 pp_basic_saves
 470   = vcat [
 471         ptext SLIT("CALLER_SAVE_Base"),
 472         ptext SLIT("CALLER_SAVE_SpA"),
 473         ptext SLIT("CALLER_SAVE_SuA"),
 474         ptext SLIT("CALLER_SAVE_SpB"),
 475         ptext SLIT("CALLER_SAVE_SuB"),
 476         ptext SLIT("CALLER_SAVE_Ret"),
 477 --      ptext SLIT("CALLER_SAVE_Activity"),
 478         ptext SLIT("CALLER_SAVE_Hp"),
 479         ptext SLIT("CALLER_SAVE_HpLim") ]
 480
 481 pp_basic_restores
 482   = vcat [
 483         ptext SLIT("CALLER_RESTORE_Base"), -- must be first!
 484         ptext SLIT("CALLER_RESTORE_SpA"),
 485         ptext SLIT("CALLER_RESTORE_SuA"),
 486         ptext SLIT("CALLER_RESTORE_SpB"),
 487         ptext SLIT("CALLER_RESTORE_SuB"),
 488         ptext SLIT("CALLER_RESTORE_Ret"),
 489 --      ptext SLIT("CALLER_RESTORE_Activity"),
 490         ptext SLIT("CALLER_RESTORE_Hp"),
 491         ptext SLIT("CALLER_RESTORE_HpLim"),
 492         ptext SLIT("CALLER_RESTORE_StdUpdRetVec"),
 493         ptext SLIT("CALLER_RESTORE_StkStub") ]
 494 \end{code}
 495
 496 \begin{code}
 497 if_profiling pretty
 498   = if  opt_SccProfilingOn
 499     then pretty
 500     else char '0' -- leave it out!
 501
 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 create via primop.
 565    makeForeignObj (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 addToCLabelSet set x = addToFM set x ()
1142
1143 type TEenv = (UniqSet Unique, CLabelSet)
1144
1145 type TeM result =  TEenv -> (TEenv, result)
1146
1147 initTE :: TeM a -> a
1148 initTE sa
1149   = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1150     result }
1151
1152 {-# INLINE thenTE #-}
1153 {-# INLINE returnTE #-}
1154
1155 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1156 thenTE a b u
1157   = case a u        of { (u_1, result_of_a) ->
1158     b result_of_a u_1 }
1159
1160 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1161 mapTE f []     = returnTE []
1162 mapTE f (x:xs)
1163   = f x         `thenTE` \ r  ->
1164     mapTE f xs  `thenTE` \ rs ->
1165     returnTE (r : rs)
1166
1167 returnTE :: a -> TeM a
1168 returnTE result env = (env, result)
1169
1170 -- these next two check whether the thing is already
1171 -- recorded, and THEN THEY RECORD IT
1172 -- (subsequent calls will return False for the same uniq/label)
1173
1174 tempSeenTE :: Unique -> TeM Bool
1175 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1176   = if (uniq `elementOfUniqSet` seen_uniqs)
1177     then (env, True)
1178     else ((addOneToUniqSet seen_uniqs uniq,
1179           seen_labels),
1180           False)
1181
1182 labelSeenTE :: CLabel -> TeM Bool
1183 labelSeenTE label env@(seen_uniqs, seen_labels)
1184   = if (label `elementOfCLabelSet` seen_labels)
1185     then (env, True)
1186     else ((seen_uniqs,
1187           addToCLabelSet seen_labels label),
1188           False)
1189 \end{code}
1190
1191 \begin{code}
1192 pprTempDecl :: Unique -> PrimRep -> SDoc
1193 pprTempDecl uniq kind
1194   = hcat [ pprPrimKind kind, space, pprUnique uniq, ptext SLIT("_;") ]
1195
1196 pprExternDecl :: CLabel -> PrimRep -> SDoc
1197
1198 pprExternDecl clabel kind
1199   = if not (needsCDecl clabel) then
1200         empty -- do not print anything for "known external" things (e.g., < PreludeCore)
1201     else
1202         case (
1203             case kind of
1204               CodePtrRep -> ppLocalnessMacro True{-function-} clabel
1205               _          -> ppLocalnessMacro False{-data-}    clabel
1206         ) of { pp_macro_str ->
1207
1208         hcat [ pp_macro_str, lparen, pprCLabel clabel, pp_paren_semi ]
1209         }
1210 \end{code}
1211
1212 \begin{code}
1213 ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})
1214
1215 ppr_decls_AbsC AbsCNop          = returnTE (Nothing, Nothing)
1216
1217 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1218   = ppr_decls_AbsC stmts_1  `thenTE` \ p1 ->
1219     ppr_decls_AbsC stmts_2  `thenTE` \ p2 ->
1220     returnTE (maybe_vcat [p1, p2])
1221
1222 ppr_decls_AbsC (CClosureUpdInfo info)
1223   = ppr_decls_AbsC info
1224
1225 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1226
1227 ppr_decls_AbsC (CAssign dest source)
1228   = ppr_decls_Amode dest    `thenTE` \ p1 ->
1229     ppr_decls_Amode source  `thenTE` \ p2 ->
1230     returnTE (maybe_vcat [p1, p2])
1231
1232 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1233
1234 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1235
1236 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1237
1238 ppr_decls_AbsC (CSwitch discrim alts deflt)
1239   = ppr_decls_Amode discrim     `thenTE` \ pdisc ->
1240     mapTE ppr_alt_stuff alts    `thenTE` \ palts  ->
1241     ppr_decls_AbsC deflt        `thenTE` \ pdeflt ->
1242     returnTE (maybe_vcat (pdisc:pdeflt:palts))
1243   where
1244     ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1245
1246 ppr_decls_AbsC (CCodeBlock label absC)
1247   = ppr_decls_AbsC absC
1248
1249 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1250         -- ToDo: strictly speaking, should chk "cost_centre" amode
1251   = labelSeenTE info_lbl     `thenTE` \  label_seen ->
1252     returnTE (Nothing,
1253               if label_seen then
1254                   Nothing
1255               else
1256                   Just (pprExternDecl info_lbl PtrRep))
1257   where
1258     info_lbl = infoTableLabelFromCI cl_info
1259
1260 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1261 ppr_decls_AbsC (CSimultaneous abc)          = ppr_decls_AbsC abc
1262
1263 ppr_decls_AbsC (CMacroStmt          _ amodes)   = ppr_decls_Amodes amodes
1264
1265 ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)   = ppr_decls_Amodes [] -- *****!!!
1266   -- you get some nasty re-decls of stdio.h if you compile
1267   -- the prelude while looking inside those amodes;
1268   -- no real reason to, anyway.
1269 ppr_decls_AbsC (CCallProfCCMacro    _ amodes)   = ppr_decls_Amodes amodes
1270
1271 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1272         -- ToDo: strictly speaking, should chk "cost_centre" amode
1273   = ppr_decls_Amodes amodes
1274
1275 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1276   = ppr_decls_Amodes [entry_lbl, upd_lbl]       `thenTE` \ p1 ->
1277     ppr_decls_AbsC slow                         `thenTE` \ p2 ->
1278     (case maybe_fast of
1279         Nothing   -> returnTE (Nothing, Nothing)
1280         Just fast -> ppr_decls_AbsC fast)       `thenTE` \ p3 ->
1281     returnTE (maybe_vcat [p1, p2, p3])
1282   where
1283     entry_lbl = CLbl slow_lbl CodePtrRep
1284     slow_lbl    = case (nonemptyAbsC slow) of
1285                     Nothing -> mkErrorStdEntryLabel
1286                     Just _  -> entryLabelFromCI cl_info
1287
1288 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1289   = ppr_decls_Amodes (catMaybes maybe_amodes)   `thenTE` \ p1 ->
1290     ppr_decls_AbsC   absC                       `thenTE` \ p2 ->
1291     returnTE (maybe_vcat [p1, p2])
1292
1293 ppr_decls_AbsC (CRetUnVector   _ amode)  = ppr_decls_Amode amode
1294 ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
1295 \end{code}
1296
1297 \begin{code}
1298 ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
1299 ppr_decls_Amode (CVal _ _)      = returnTE (Nothing, Nothing)
1300 ppr_decls_Amode (CAddr _)       = returnTE (Nothing, Nothing)
1301 ppr_decls_Amode (CReg _)        = returnTE (Nothing, Nothing)
1302 ppr_decls_Amode (CString _)     = returnTE (Nothing, Nothing)
1303 ppr_decls_Amode (CLit _)        = returnTE (Nothing, Nothing)
1304 ppr_decls_Amode (CLitLit _ _)   = returnTE (Nothing, Nothing)
1305 ppr_decls_Amode (COffset _)     = returnTE (Nothing, Nothing)
1306
1307 -- CIntLike must be a literal -- no decls
1308 ppr_decls_Amode (CIntLike int)  = returnTE (Nothing, Nothing)
1309
1310 -- CCharLike may have be arbitrary value -- may have decls
1311 ppr_decls_Amode (CCharLike char)
1312   = ppr_decls_Amode char
1313
1314 -- now, the only place where we actually print temps/externs...
1315 ppr_decls_Amode (CTemp uniq kind)
1316   = case kind of
1317       VoidRep -> returnTE (Nothing, Nothing)
1318       other ->
1319         tempSeenTE uniq `thenTE` \ temp_seen ->
1320         returnTE
1321           (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1322
1323 ppr_decls_Amode (CLbl label VoidRep)
1324   = returnTE (Nothing, Nothing)
1325
1326 ppr_decls_Amode (CLbl label kind)
1327   = labelSeenTE label `thenTE` \ label_seen ->
1328     returnTE (Nothing,
1329               if label_seen then Nothing else Just (pprExternDecl label kind))
1330
1331 {- WRONG:
1332 ppr_decls_Amode (CUnVecLbl direct vectored)
1333   = labelSeenTE direct   `thenTE` \ dlbl_seen ->
1334     labelSeenTE vectored `thenTE` \ vlbl_seen ->
1335     let
1336         ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
1337         vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
1338     in
1339     returnTE (Nothing,
1340                 if (dlbl_seen || not (needsCDecl direct)) &&
1341                    (vlbl_seen || not (needsCDecl vectored)) then Nothing
1342                 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1343 -}
1344
1345 ppr_decls_Amode (CUnVecLbl direct vectored)
1346   = -- We don't mark either label as "seen", because
1347     -- we don't know which one will be used and which one tossed
1348     -- by the C macro...
1349     --labelSeenTE direct   `thenTE` \ dlbl_seen ->
1350     --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1351     let
1352         ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
1353         vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
1354     in
1355     returnTE (Nothing,
1356                 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1357                    ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1358                 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1359
1360 ppr_decls_Amode (CTableEntry base index _)
1361   = ppr_decls_Amode base    `thenTE` \ p1 ->
1362     ppr_decls_Amode index   `thenTE` \ p2 ->
1363     returnTE (maybe_vcat [p1, p2])
1364
1365 ppr_decls_Amode (CMacroExpr _ _ amodes)
1366   = ppr_decls_Amodes amodes
1367
1368 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1369
1370
1371 maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
1372 maybe_vcat ps
1373   = case (unzip ps)     of { (ts, es) ->
1374     case (catMaybes ts) of { real_ts  ->
1375     case (catMaybes es) of { real_es  ->
1376     (if (null real_ts) then Nothing else Just (vcat real_ts),
1377      if (null real_es) then Nothing else Just (vcat real_es))
1378     } } }
1379 \end{code}
1380
1381 \begin{code}
1382 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
1383 ppr_decls_Amodes amodes
1384   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1385     returnTE ( maybe_vcat ps )
1386 \end{code}