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