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