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 [text "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 [text (show 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 [text (show 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 reg_rel cost_centre) _
 342   = hcat [ ptext SLIT("SET_HDR_"), char '(',
 343                 ppr_amode (CAddr reg_rel), 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
1040         if neither side is a @CVal@ addressing mode for any register
1041         which can point into the heap or B stack.
1042
1043 Why?  Because the heap and B stack are used to store miscellaneous things,
1044 whereas the A stack, temporaries, registers, etc., are only used for things
1045 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 (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
1148   -- ToDo: are these *used* for anything?
1149
1150 ppr_amode (CLit lit) = pprBasicLit lit
1151
1152 ppr_amode (CLitLit str _) = ptext str
1153
1154 ppr_amode (CJoinPoint _)
1155   = panic "ppr_amode: CJoinPoint"
1156
1157 ppr_amode (CTableEntry base index kind)
1158   = hcat [text "((", pprPrimKind kind, text " *)(",
1159                ppr_amode base, text "))[(I_)(", ppr_amode index,
1160                ptext SLIT(")]")]
1161
1162 ppr_amode (CMacroExpr pk macro as)
1163   = parens (pprPrimKind pk) <+>
1164     parens (text (show macro) <>
1165             parens (hcat (punctuate comma (map pprAmode as))))
1166 \end{code}
1167
1168 %************************************************************************
1169 %*                                                                      *
1170 \subsection[ppr-liveness-masks]{Liveness Masks}
1171 %*                                                                      *
1172 %************************************************************************
1173
1174 \begin{code}
1175 pp_liveness :: Liveness -> SDoc
1176 pp_liveness lv =
1177    case lv of
1178         LvSmall mask -> int (intBS mask)
1179         LvLarge lbl  -> char '&' <> pprCLabel lbl
1180 \end{code}
1181
1182 %************************************************************************
1183 %*                                                                      *
1184 \subsection[a2r-MagicIds]{Magic ids}
1185 %*                                                                      *
1186 %************************************************************************
1187
1188 @pprRegRelative@ returns a pair of the @Doc@ for the register
1189 (some casting may be required), and a @Maybe Doc@ for the offset
1190 (zero offset gives a @Nothing@).
1191
1192 \begin{code}
1193 addPlusSign :: Bool -> SDoc -> SDoc
1194 addPlusSign False p = p
1195 addPlusSign True  p = (<>) (char '+') p
1196
1197 pprSignedInt :: Bool -> Int -> Maybe SDoc       -- Nothing => 0
1198 pprSignedInt sign_wanted n
1199  = if n == 0 then Nothing else
1200    if n > 0  then Just (addPlusSign sign_wanted (int n))
1201    else           Just (int n)
1202
1203 pprRegRelative :: Bool          -- True <=> Print leading plus sign (if +ve)
1204                -> RegRelative
1205                -> (SDoc, Maybe SDoc)
1206
1207 pprRegRelative sign_wanted (SpRel off)
1208   = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))
1209
1210 pprRegRelative sign_wanted r@(HpRel o)
1211   = let pp_Hp    = pprMagicId Hp; off = I# o
1212     in
1213     if off == 0 then
1214         (pp_Hp, Nothing)
1215     else
1216         (pp_Hp, Just ((<>) (char '-') (int off)))
1217
1218 pprRegRelative sign_wanted (NodeRel o)
1219   = let pp_Node = pprMagicId node; off = I# o
1220     in
1221     if off == 0 then
1222         (pp_Node, Nothing)
1223     else
1224         (pp_Node, Just (addPlusSign sign_wanted (int off)))
1225
1226 \end{code}
1227
1228 @pprMagicId@ just prints the register name.  @VanillaReg@ registers are
1229 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1230 to select the union tag.
1231
1232 \begin{code}
1233 pprMagicId :: MagicId -> SDoc
1234
1235 pprMagicId BaseReg                  = ptext SLIT("BaseReg")
1236 pprMagicId (VanillaReg pk n)
1237                                     = hcat [ pprVanillaReg n, char '.',
1238                                                   pprUnionTag pk ]
1239 pprMagicId (FloatReg  n)            = (<>) (ptext SLIT("F")) (int IBOX(n))
1240 pprMagicId (DoubleReg n)            = (<>) (ptext SLIT("D")) (int IBOX(n))
1241 pprMagicId (LongReg _ n)            = (<>) (ptext SLIT("L")) (int IBOX(n))
1242 pprMagicId Sp                       = ptext SLIT("Sp")
1243 pprMagicId Su                       = ptext SLIT("Su")
1244 pprMagicId SpLim                    = ptext SLIT("SpLim")
1245 pprMagicId Hp                       = ptext SLIT("Hp")
1246 pprMagicId HpLim                    = ptext SLIT("HpLim")
1247 pprMagicId CurCostCentre            = ptext SLIT("CCCS")
1248 pprMagicId VoidReg                  = panic "pprMagicId:VoidReg!"
1249
1250 pprVanillaReg :: FAST_INT -> SDoc
1251 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
1252
1253 pprUnionTag :: PrimRep -> SDoc
1254
1255 pprUnionTag PtrRep              = char 'p'
1256 pprUnionTag CodePtrRep          = ptext SLIT("fp")
1257 pprUnionTag DataPtrRep          = char 'd'
1258 pprUnionTag RetRep              = char 'p'
1259 pprUnionTag CostCentreRep       = panic "pprUnionTag:CostCentre?"
1260
1261 pprUnionTag CharRep             = char 'c'
1262 pprUnionTag IntRep              = char 'i'
1263 pprUnionTag WordRep             = char 'w'
1264 pprUnionTag AddrRep             = char 'a'
1265 pprUnionTag FloatRep            = char 'f'
1266 pprUnionTag DoubleRep           = panic "pprUnionTag:Double?"
1267
1268 pprUnionTag StablePtrRep        = char 'i'
1269 pprUnionTag StableNameRep       = char 'p'
1270 pprUnionTag WeakPtrRep          = char 'p'
1271 pprUnionTag ForeignObjRep       = char 'p'
1272
1273 pprUnionTag ThreadIdRep         = char 't'
1274
1275 pprUnionTag ArrayRep            = char 'p'
1276 pprUnionTag ByteArrayRep        = char 'b'
1277
1278 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
1279 \end{code}
1280
1281
1282 Find and print local and external declarations for a list of
1283 Abstract~C statements.
1284 \begin{code}
1285 pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
1286 pprTempAndExternDecls AbsCNop = (empty, empty)
1287
1288 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1289   = initTE (ppr_decls_AbsC stmt1        `thenTE` \ (t_p1, e_p1) ->
1290             ppr_decls_AbsC stmt2        `thenTE` \ (t_p2, e_p2) ->
1291             case (catMaybes [t_p1, t_p2])        of { real_temps ->
1292             case (catMaybes [e_p1, e_p2])        of { real_exts ->
1293             returnTE (vcat real_temps, vcat real_exts) }}
1294            )
1295
1296 pprTempAndExternDecls other_stmt
1297   = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1298             returnTE (
1299                 case maybe_t of
1300                   Nothing -> empty
1301                   Just pp -> pp,
1302
1303                 case maybe_e of
1304                   Nothing -> empty
1305                   Just pp -> pp )
1306            )
1307
1308 pprBasicLit :: Literal -> SDoc
1309 pprPrimKind :: PrimRep -> SDoc
1310
1311 pprBasicLit  lit = ppr lit
1312 pprPrimKind  k   = ppr k
1313 \end{code}
1314
1315
1316 %************************************************************************
1317 %*                                                                      *
1318 \subsection[a2r-monad]{Monadery}
1319 %*                                                                      *
1320 %************************************************************************
1321
1322 We need some monadery to keep track of temps and externs we have already
1323 printed.  This info must be threaded right through the Abstract~C, so
1324 it's most convenient to hide it in this monad.
1325
1326 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1327 \tr{(UniqSet, CLabelSet)}.  Allegedly for efficiency.
1328
1329 \begin{code}
1330 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1331 emptyCLabelSet = emptyFM
1332 x `elementOfCLabelSet` labs
1333   = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1334
1335 addToCLabelSet set x = addToFM set x ()
1336
1337 type TEenv = (UniqSet Unique, CLabelSet)
1338
1339 type TeM result =  TEenv -> (TEenv, result)
1340
1341 initTE :: TeM a -> a
1342 initTE sa
1343   = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1344     result }
1345
1346 {-# INLINE thenTE #-}
1347 {-# INLINE returnTE #-}
1348
1349 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1350 thenTE a b u
1351   = case a u        of { (u_1, result_of_a) ->
1352     b result_of_a u_1 }
1353
1354 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1355 mapTE f []     = returnTE []
1356 mapTE f (x:xs)
1357   = f x         `thenTE` \ r  ->
1358     mapTE f xs  `thenTE` \ rs ->
1359     returnTE (r : rs)
1360
1361 returnTE :: a -> TeM a
1362 returnTE result env = (env, result)
1363
1364 -- these next two check whether the thing is already
1365 -- recorded, and THEN THEY RECORD IT
1366 -- (subsequent calls will return False for the same uniq/label)
1367
1368 tempSeenTE :: Unique -> TeM Bool
1369 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1370   = if (uniq `elementOfUniqSet` seen_uniqs)
1371     then (env, True)
1372     else ((addOneToUniqSet seen_uniqs uniq,
1373           seen_labels),
1374           False)
1375
1376 labelSeenTE :: CLabel -> TeM Bool
1377 labelSeenTE label env@(seen_uniqs, seen_labels)
1378   = if (label `elementOfCLabelSet` seen_labels)
1379     then (env, True)
1380     else ((seen_uniqs,
1381           addToCLabelSet seen_labels label),
1382           False)
1383 \end{code}
1384
1385 \begin{code}
1386 pprTempDecl :: Unique -> PrimRep -> SDoc
1387 pprTempDecl uniq kind
1388   = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
1389
1390 pprExternDecl :: Bool -> CLabel -> SDoc
1391 pprExternDecl in_srt clabel
1392   | not (needsCDecl clabel) = empty -- do not print anything for "known external" things
1393   | otherwise               =
1394         hcat [ ppLocalnessMacro (not in_srt) clabel,
1395                lparen, dyn_wrapper (pprCLabel clabel), pp_paren_semi ]
1396  where
1397   dyn_wrapper d
1398     | in_srt && labelDynamic clabel = text "DLL_IMPORT_DATA_VAR" <> parens d
1399     | otherwise                     = d
1400
1401 \end{code}
1402
1403 \begin{code}
1404 ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})
1405
1406 ppr_decls_AbsC AbsCNop          = returnTE (Nothing, Nothing)
1407
1408 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1409   = ppr_decls_AbsC stmts_1  `thenTE` \ p1 ->
1410     ppr_decls_AbsC stmts_2  `thenTE` \ p2 ->
1411     returnTE (maybe_vcat [p1, p2])
1412
1413 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1414
1415 ppr_decls_AbsC (CAssign dest source)
1416   = ppr_decls_Amode dest    `thenTE` \ p1 ->
1417     ppr_decls_Amode source  `thenTE` \ p2 ->
1418     returnTE (maybe_vcat [p1, p2])
1419
1420 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1421
1422 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1423
1424 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1425
1426 ppr_decls_AbsC (CSwitch discrim alts deflt)
1427   = ppr_decls_Amode discrim     `thenTE` \ pdisc ->
1428     mapTE ppr_alt_stuff alts    `thenTE` \ palts  ->
1429     ppr_decls_AbsC deflt        `thenTE` \ pdeflt ->
1430     returnTE (maybe_vcat (pdisc:pdeflt:palts))
1431   where
1432     ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1433
1434 ppr_decls_AbsC (CCodeBlock label absC)
1435   = ppr_decls_AbsC absC
1436
1437 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
1438         -- ToDo: strictly speaking, should chk "cost_centre" amode
1439   = labelSeenTE info_lbl     `thenTE` \  label_seen ->
1440     returnTE (Nothing,
1441               if label_seen then
1442                   Nothing
1443               else
1444                   Just (pprExternDecl False{-not in an SRT decl-} info_lbl))
1445   where
1446     info_lbl = infoTableLabelFromCI cl_info
1447
1448 ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args)
1449 ppr_decls_AbsC (CSimultaneous abc)          = ppr_decls_AbsC abc
1450
1451 ppr_decls_AbsC (CCheck              _ amodes code) =
1452      ppr_decls_Amodes amodes `thenTE` \p1 ->
1453      ppr_decls_AbsC code     `thenTE` \p2 ->
1454      returnTE (maybe_vcat [p1,p2])
1455
1456 ppr_decls_AbsC (CMacroStmt          _ amodes)   = ppr_decls_Amodes amodes
1457
1458 ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)   = ppr_decls_Amodes [] -- *****!!!
1459   -- you get some nasty re-decls of stdio.h if you compile
1460   -- the prelude while looking inside those amodes;
1461   -- no real reason to, anyway.
1462 ppr_decls_AbsC (CCallProfCCMacro    _ amodes)   = ppr_decls_Amodes amodes
1463
1464 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1465         -- ToDo: strictly speaking, should chk "cost_centre" amode
1466   = ppr_decls_Amodes amodes
1467
1468 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _)
1469   = ppr_decls_Amodes [entry_lbl]                `thenTE` \ p1 ->
1470     ppr_decls_AbsC slow                         `thenTE` \ p2 ->
1471     (case maybe_fast of
1472         Nothing   -> returnTE (Nothing, Nothing)
1473         Just fast -> ppr_decls_AbsC fast)       `thenTE` \ p3 ->
1474     returnTE (maybe_vcat [p1, p2, p3])
1475   where
1476     entry_lbl = CLbl slow_lbl CodePtrRep
1477     slow_lbl    = case (nonemptyAbsC slow) of
1478                     Nothing -> mkErrorStdEntryLabel
1479                     Just _  -> entryLabelFromCI cl_info
1480
1481 ppr_decls_AbsC (CSRT lbl closure_lbls)
1482   = mapTE labelSeenTE closure_lbls              `thenTE` \ seen ->
1483     returnTE (Nothing,
1484               if and seen then Nothing
1485                 else Just (vcat [ pprExternDecl True{-in SRT decl-} l
1486                                 | (l,False) <- zip closure_lbls seen ]))
1487
1488 ppr_decls_AbsC (CRetDirect     _ code _ _)   = ppr_decls_AbsC code
1489 ppr_decls_AbsC (CRetVector _ amodes _ _)     = ppr_decls_Amodes amodes
1490 \end{code}
1491
1492 \begin{code}
1493 ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
1494 ppr_decls_Amode (CVal _ _)      = returnTE (Nothing, Nothing)
1495 ppr_decls_Amode (CAddr _)       = returnTE (Nothing, Nothing)
1496 ppr_decls_Amode (CReg _)        = returnTE (Nothing, Nothing)
1497 ppr_decls_Amode (CString _)     = returnTE (Nothing, Nothing)
1498 ppr_decls_Amode (CLit _)        = returnTE (Nothing, Nothing)
1499 ppr_decls_Amode (CLitLit _ _)   = returnTE (Nothing, Nothing)
1500
1501 -- CIntLike must be a literal -- no decls
1502 ppr_decls_Amode (CIntLike int)  = returnTE (Nothing, Nothing)
1503
1504 -- CCharLike may have be arbitrary value -- may have decls
1505 ppr_decls_Amode (CCharLike char)
1506   = ppr_decls_Amode char
1507
1508 -- now, the only place where we actually print temps/externs...
1509 ppr_decls_Amode (CTemp uniq kind)
1510   = case kind of
1511       VoidRep -> returnTE (Nothing, Nothing)
1512       other ->
1513         tempSeenTE uniq `thenTE` \ temp_seen ->
1514         returnTE
1515           (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1516
1517 ppr_decls_Amode (CLbl label VoidRep)
1518   = returnTE (Nothing, Nothing)
1519
1520 ppr_decls_Amode (CLbl label kind)
1521   = labelSeenTE label `thenTE` \ label_seen ->
1522     returnTE (Nothing,
1523               if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} label))
1524
1525 ppr_decls_Amode (CTableEntry base index _)
1526   = ppr_decls_Amode base    `thenTE` \ p1 ->
1527     ppr_decls_Amode index   `thenTE` \ p2 ->
1528     returnTE (maybe_vcat [p1, p2])
1529
1530 ppr_decls_Amode (CMacroExpr _ _ amodes)
1531   = ppr_decls_Amodes amodes
1532
1533 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1534
1535
1536 maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
1537 maybe_vcat ps
1538   = case (unzip ps)     of { (ts, es) ->
1539     case (catMaybes ts) of { real_ts  ->
1540     case (catMaybes es) of { real_es  ->
1541     (if (null real_ts) then Nothing else Just (vcat real_ts),
1542      if (null real_es) then Nothing else Just (vcat real_es))
1543     } } }
1544 \end{code}
1545
1546 \begin{code}
1547 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
1548 ppr_decls_Amodes amodes
1549   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1550     returnTE ( maybe_vcat ps )
1551 \end{code}
1552
1553 Print out a C Label where you want the *address* of the label, not the
1554 object it refers to.  The distinction is important when the label may
1555 refer to a C structure (info tables and closures, for instance).
1556
1557 When just generating a declaration for the label, use pprCLabel.
1558
1559 \begin{code}
1560 pprCLabelAddr :: CLabel -> SDoc
1561 pprCLabelAddr clabel =
1562   case labelType clabel of
1563      InfoTblType -> addr_of_label
1564      ClosureType -> addr_of_label
1565      VecTblType  -> addr_of_label
1566      _           -> pp_label
1567   where
1568     addr_of_label = ptext SLIT("(P_)&") <> pp_label
1569     pp_label = pprCLabel clabel
1570
1571 \end{code}
1572
1573 -----------------------------------------------------------------------------
1574 Initialising static objects with floating-point numbers.  We can't
1575 just emit the floating point number, because C will cast it to an int
1576 by rounding it.  We want the actual bit-representation of the float.
1577
1578 This is a hack to turn the floating point numbers into ints that we
1579 can safely initialise to static locations.
1580
1581 \begin{code}
1582 big_doubles = (getPrimRepSize DoubleRep) /= 1
1583
1584 -- floatss are always 1 word
1585 floatToWord :: CAddrMode -> CAddrMode
1586 floatToWord (CLit (MachFloat r))
1587   = runST (do
1588         arr <- newFloatArray ((0::Int),0)
1589         writeFloatArray arr 0 (fromRational r)
1590         i <- readIntArray arr 0
1591         return (CLit (MachInt (toInteger i) True))
1592     )
1593
1594 doubleToWords :: CAddrMode -> [CAddrMode]
1595 doubleToWords (CLit (MachDouble r))
1596   | big_doubles                         -- doubles are 2 words
1597   = runST (do
1598         arr <- newDoubleArray ((0::Int),1)
1599         writeDoubleArray arr 0 (fromRational r)
1600         i1 <- readIntArray arr 0
1601         i2 <- readIntArray arr 1
1602         return [ CLit (MachInt (toInteger i1) True)
1603                , CLit (MachInt (toInteger i2) True)
1604                ]
1605     )
1606   | otherwise                           -- doubles are 1 word
1607   = runST (do
1608         arr <- newDoubleArray ((0::Int),0)
1609         writeDoubleArray arr 0 (fromRational r)
1610         i <- readIntArray arr 0
1611         return [ CLit (MachInt (toInteger i) True) ]
1612     )
1613 \end{code}