ghc/compiler/absCSyn/PprAbsC.lhs

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