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