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