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