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