ghc/compiler/absCSyn/PprAbsC.lhs

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