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