ghc/compiler/absCSyn/PprAbsC.lhs

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