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 Outputable
  57 import FastString
  58 import Util             ( lengthExceeds )
  59
  60 #if __GLASGOW_HASKELL__ >= 504
  61 import Data.Array.ST
  62 #endif
  63
  64 #ifdef DEBUG
  65 import Util             ( listLengthCmp )
  66 #endif
  67
  68 import Maybe            ( isJust )
  69 import GLAEXTS
  70 import MONAD_ST
  71
  72 infixr 9 `thenTE`
  73 \end{code}
  74
  75 For spitting out the costs of an abstract~C expression, @writeRealC@
  76 now not only prints the C~code of the @absC@ arg but also adds a macro
  77 call to a cost evaluation function @GRAN_EXEC@. For that,
  78 @pprAbsC@ has a new ``costs'' argument.  %% HWL
  79
  80 \begin{code}
  81 {-
  82 writeRealC :: Handle -> AbstractC -> IO ()
  83 writeRealC handle absC
  84      -- avoid holding on to the whole of absC in the !Gransim case.
  85      if opt_GranMacros
  86         then printForCFast fp (pprAbsC absC (costs absC))
  87         else printForCFast fp (pprAbsC absC (panic "costs"))
  88              --printForC handle (pprAbsC absC (panic "costs"))
  89 dumpRealC :: AbstractC -> SDoc
  90 dumpRealC absC = pprAbsC absC (costs absC)
  91 -}
  92
  93 writeRealC :: Handle -> AbstractC -> IO ()
  94 --writeRealC handle absC =
  95 -- _scc_ "writeRealC"
  96 -- printDoc LeftMode handle (pprAbsC absC (costs absC))
  97
  98 writeRealC handle absC
  99  | opt_GranMacros = _scc_ "writeRealC" printForC handle $
 100                                        pprCode CStyle (pprAbsC absC (costs absC))
 101  | otherwise      = _scc_ "writeRealC" printForC handle $
 102                                        pprCode CStyle (pprAbsC absC (panic "costs"))
 103
 104 dumpRealC :: AbstractC -> SDoc
 105 dumpRealC absC
 106  | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC))
 107  | otherwise      = pprCode CStyle (pprAbsC absC (panic "costs"))
 108
 109 \end{code}
 110
 111 This emits the macro,  which is used in GrAnSim  to compute the total costs
 112 from a cost 5 tuple. %%  HWL
 113
 114 \begin{code}
 115 emitMacro :: CostRes -> SDoc
 116
 117 emitMacro _ | not opt_GranMacros = empty
 118
 119 emitMacro (Cost (i,b,l,s,f))
 120   = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
 121                           int i, comma, int b, comma, int l, comma,
 122                           int s, comma, int f, pp_paren_semi ]
 123
 124 pp_paren_semi = text ");"
 125 \end{code}
 126
 127 New type: Now pprAbsC also takes the costs for evaluating the Abstract C
 128 code as an argument (that's needed when spitting out the GRAN_EXEC macro
 129 which must be done before the return i.e. inside absC code)   HWL
 130
 131 \begin{code}
 132 pprAbsC :: AbstractC -> CostRes -> SDoc
 133 pprAbsC AbsCNop _ = empty
 134 pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
 135
 136 pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
 137
 138 pprAbsC (CJump target) c
 139   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
 140              (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
 141
 142 pprAbsC (CFallThrough target) c
 143   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CFallThrough */"-} ])
 144              (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
 145
 146 -- --------------------------------------------------------------------------
 147 -- Spit out GRAN_EXEC macro immediately before the return                 HWL
 148
 149 pprAbsC (CReturn am return_info)  c
 150   = ($$) (hcat [emitMacro c {-WDP:, text "/* <----  CReturn */"-} ])
 151              (hcat [text jmp_lit, target, pp_paren_semi ])
 152   where
 153    target = case return_info of
 154         DirectReturn -> hcat [ptext SLIT("ENTRY_CODE"), lparen,
 155                               pprAmode am, rparen]
 156         DynamicVectoredReturn am' -> mk_vector (pprAmode am')
 157         StaticVectoredReturn n -> mk_vector (int n)     -- Always positive
 158    mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma,
 159                        x, rparen ]
 160
 161 pprAbsC (CSplitMarker) _ = ptext SLIT("__STG_SPLIT_MARKER")
 162
 163 -- we optimise various degenerate cases of CSwitches.
 164
 165 -- --------------------------------------------------------------------------
 166 -- Assume: CSwitch is also end of basic block
 167 --         costs function yields nullCosts for whole switch
 168 --         ==> inherited costs c are those of basic block up to switch
 169 --         ==> inherit c + costs for the corresponding branch
 170 --                                                                       HWL
 171 -- --------------------------------------------------------------------------
 172
 173 pprAbsC (CSwitch discrim [] deflt) c
 174   = pprAbsC deflt (c + costs deflt)
 175     -- Empty alternative list => no costs for discrim as nothing cond. here HWL
 176
 177 pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
 178   = case (nonemptyAbsC deflt) of
 179       Nothing ->                -- one alt and no default
 180                  pprAbsC alt_code (c + costs alt_code)
 181                  -- Nothing conditional in here either  HWL
 182
 183       Just dc ->                -- make it an "if"
 184                  do_if_stmt discrim tag alt_code dc c
 185
 186 -- What problem is the re-ordering trying to solve ?
 187 pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1),
 188                           (tag2@(MachInt i2), alt_code2)] deflt) c
 189   | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
 190   = if (i1 == 0) then
 191         do_if_stmt discrim tag1 alt_code1 alt_code2 c
 192     else
 193         do_if_stmt discrim tag2 alt_code2 alt_code1 c
 194   where
 195     empty_deflt = not (isJust (nonemptyAbsC deflt))
 196
 197 pprAbsC (CSwitch discrim alts deflt) c -- general case
 198   | isFloatingRep (getAmodeRep discrim)
 199     = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
 200   | otherwise
 201     = vcat [
 202         hcat [text "switch (", pp_discrim, text ") {"],
 203         nest 2 (vcat (map ppr_alt alts)),
 204         (case (nonemptyAbsC deflt) of
 205            Nothing -> empty
 206            Just dc ->
 207             nest 2 (vcat [ptext SLIT("default:"),
 208                                   pprAbsC dc (c + switch_head_cost
 209                                                     + costs dc),
 210                                   ptext SLIT("break;")])),
 211         char '}' ]
 212   where
 213     pp_discrim
 214       = pprAmode discrim
 215
 216     ppr_alt (lit, absC)
 217       = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'],
 218                    nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC))
 219                                        (ptext SLIT("break;"))) ]
 220
 221     -- Costs for addressing header of switch and cond. branching        -- HWL
 222     switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
 223
 224 pprAbsC stmt@(COpStmt results (StgFCallOp fcall uniq) args vol_regs) _
 225   = pprFCall fcall uniq args results vol_regs
 226
 227 pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _
 228   = let
 229         non_void_args = grab_non_void_amodes args
 230         non_void_results = grab_non_void_amodes results
 231         -- if just one result, we print in the obvious "assignment" style;
 232         -- if 0 or many results, we emit a macro call, w/ the results
 233         -- followed by the arguments.  The macro presumably knows which
 234         -- are which :-)
 235
 236         the_op = ppr_op_call non_void_results non_void_args
 237                 -- liveness mask is *in* the non_void_args
 238     in
 239     if primOpNeedsWrapper op then
 240         case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
 241         vcat [  pp_saves,
 242                 the_op,
 243                 pp_restores
 244              ]
 245         }
 246     else
 247         the_op
 248   where
 249     ppr_op_call results args
 250       = hcat [ ppr op, lparen,
 251         hcat (punctuate comma (map ppr_op_result results)),
 252         if null results || null args then empty else comma,
 253         hcat (punctuate comma (map pprAmode args)),
 254         pp_paren_semi ]
 255
 256     ppr_op_result r = ppr_amode r
 257       -- primop macros do their own casting of result;
 258       -- hence we can toss the provided cast...
 259
 260 -- NEW CASES FOR EXPANDED PRIMOPS
 261
 262 pprAbsC stmt@(CMachOpStmt res mop [arg1,arg2] maybe_vols) _
 263   = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr, MO_NatS_MulMayOflo]
 264     in
 265     case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
 266     saves $$
 267     hcat (
 268        [ppr_amode res, equals]
 269        ++ (if prefix_fn
 270            then [pprMachOp_for_C mop, parens (pprAmode arg1 <> comma <> pprAmode arg2)]
 271            else [pprAmode arg1, pprMachOp_for_C mop, pprAmode arg2])
 272        ++ [semi]
 273     )
 274     $$ restores
 275     }
 276
 277 pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _
 278   = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
 279     saves $$
 280     hcat [ppr_amode res, equals,
 281           pprMachOp_for_C mop, parens (pprAmode arg1),
 282           semi]
 283     $$ restores
 284     }
 285
 286 pprAbsC stmt@(CSequential stuff) c
 287   = vcat (map (flip pprAbsC c) stuff)
 288
 289 -- end of NEW CASES FOR EXPANDED PRIMOPS
 290
 291 pprAbsC stmt@(CSRT lbl closures) c
 292   = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
 293          pp_exts
 294       $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen
 295       $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
 296          <> ptext SLIT("};")
 297   }
 298
 299 pprAbsC stmt@(CBitmap liveness@(Liveness lbl size mask)) c
 300   = pprWordArray lbl (mkWordCLit (fromIntegral size) : bitmapAddrModes mask)
 301
 302 pprAbsC stmt@(CSRTDesc desc_lbl srt_lbl off len bitmap) c
 303   = pprWordArray desc_lbl (
 304         CAddr (CIndex (CLbl srt_lbl DataPtrRep) (mkIntCLit off) WordRep) :
 305         mkWordCLit (fromIntegral len) :
 306         bitmapAddrModes bitmap
 307      )
 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   =  pprWordArray 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) (tyConDataCons tycon)
 477         )
 478    ) $$ ptext SLIT("};")
 479
 480 pprAbsC stmt@(CRetDirect uniq code srt liveness) _
 481   =  pprWordArray 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   = pprWordArray 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 pprWordArray lbl amodes
 509   = (case snd (initTE (ppr_decls_Amodes amodes)) of
 510         Just pp -> pp
 511         Nothing -> empty)
 512   $$ hcat [ ppLocalness lbl, ptext SLIT("StgWord "),
 513             pprCLabel 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 (CVal reg_rel@(CIndex _ _ _) kind)
1133   = case (pprRegRelative False{-no sign wanted-} reg_rel) of
1134         (pp_reg, Nothing)     -> panic "ppr_amode: CIndex"
1135         (pp_reg, Just offset) ->
1136            hcat [ char '*', parens (pprPrimKind kind <> char '*'),
1137                   parens (pp_reg <> char '+' <> offset) ]
1138 \end{code}
1139
1140 Now the rest of the cases for ``workhorse'' @ppr_amode@:
1141
1142 \begin{code}
1143 ppr_amode (CVal reg_rel _)
1144   = case (pprRegRelative False{-no sign wanted-} reg_rel) of
1145         (pp_reg, Nothing)     -> (<>)  (char '*') pp_reg
1146         (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
1147
1148 ppr_amode (CAddr reg_rel)
1149   = case (pprRegRelative True{-sign wanted-} reg_rel) of
1150         (pp_reg, Nothing)     -> pp_reg
1151         (pp_reg, Just offset) -> pp_reg <> offset
1152
1153 ppr_amode (CReg magic_id) = pprMagicId magic_id
1154
1155 ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
1156
1157 ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl
1158
1159 ppr_amode (CCharLike ch)
1160   = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
1161 ppr_amode (CIntLike int)
1162   = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
1163
1164 ppr_amode (CLit lit) = pprBasicLit lit
1165
1166 ppr_amode (CJoinPoint _)
1167   = panic "ppr_amode: CJoinPoint"
1168
1169 ppr_amode (CMacroExpr pk macro as)
1170   = parens (ptext (cExprMacroText macro) <>
1171             parens (hcat (punctuate comma (map pprAmode as))))
1172 \end{code}
1173
1174 \begin{code}
1175 cExprMacroText ENTRY_CODE               = SLIT("ENTRY_CODE")
1176 cExprMacroText ARG_TAG                  = SLIT("ARG_TAG")
1177 cExprMacroText GET_TAG                  = SLIT("GET_TAG")
1178 cExprMacroText UPD_FRAME_UPDATEE        = SLIT("UPD_FRAME_UPDATEE")
1179 cExprMacroText CCS_HDR                  = SLIT("CCS_HDR")
1180 cExprMacroText BYTE_ARR_CTS             = SLIT("BYTE_ARR_CTS")
1181 cExprMacroText PTRS_ARR_CTS             = SLIT("PTRS_ARR_CTS")
1182 cExprMacroText ForeignObj_CLOSURE_DATA  = SLIT("ForeignObj_CLOSURE_DATA")
1183
1184 cStmtMacroText UPD_CAF                  = SLIT("UPD_CAF")
1185 cStmtMacroText UPD_BH_UPDATABLE         = SLIT("UPD_BH_UPDATABLE")
1186 cStmtMacroText UPD_BH_SINGLE_ENTRY      = SLIT("UPD_BH_SINGLE_ENTRY")
1187 cStmtMacroText PUSH_UPD_FRAME           = SLIT("PUSH_UPD_FRAME")
1188 cStmtMacroText SET_TAG                  = SLIT("SET_TAG")
1189 cStmtMacroText DATA_TO_TAGZH            = SLIT("dataToTagzh")
1190 cStmtMacroText REGISTER_FOREIGN_EXPORT  = SLIT("REGISTER_FOREIGN_EXPORT")
1191 cStmtMacroText REGISTER_IMPORT          = SLIT("REGISTER_IMPORT")
1192 cStmtMacroText REGISTER_DIMPORT         = SLIT("REGISTER_DIMPORT")
1193 cStmtMacroText GRAN_FETCH               = SLIT("GRAN_FETCH")
1194 cStmtMacroText GRAN_RESCHEDULE          = SLIT("GRAN_RESCHEDULE")
1195 cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE")
1196 cStmtMacroText THREAD_CONTEXT_SWITCH    = SLIT("THREAD_CONTEXT_SWITCH")
1197 cStmtMacroText GRAN_YIELD               = SLIT("GRAN_YIELD")
1198
1199 cCheckMacroText HP_CHK_NP               = SLIT("HP_CHK_NP")
1200 cCheckMacroText STK_CHK_NP              = SLIT("STK_CHK_NP")
1201 cCheckMacroText HP_STK_CHK_NP           = SLIT("HP_STK_CHK_NP")
1202 cCheckMacroText HP_CHK_FUN              = SLIT("HP_CHK_FUN")
1203 cCheckMacroText STK_CHK_FUN             = SLIT("STK_CHK_FUN")
1204 cCheckMacroText HP_STK_CHK_FUN          = SLIT("HP_STK_CHK_FUN")
1205 cCheckMacroText HP_CHK_NOREGS           = SLIT("HP_CHK_NOREGS")
1206 cCheckMacroText HP_CHK_UNPT_R1          = SLIT("HP_CHK_UNPT_R1")
1207 cCheckMacroText HP_CHK_UNBX_R1          = SLIT("HP_CHK_UNBX_R1")
1208 cCheckMacroText HP_CHK_F1               = SLIT("HP_CHK_F1")
1209 cCheckMacroText HP_CHK_D1               = SLIT("HP_CHK_D1")
1210 cCheckMacroText HP_CHK_L1               = SLIT("HP_CHK_L1")
1211 cCheckMacroText HP_CHK_UNBX_TUPLE       = SLIT("HP_CHK_UNBX_TUPLE")
1212 \end{code}
1213
1214 %************************************************************************
1215 %*                                                                      *
1216 \subsection[ppr-liveness-masks]{Liveness Masks}
1217 %*                                                                      *
1218 %************************************************************************
1219
1220 \begin{code}
1221 bitmapAddrModes [] = [mkWordCLit 0]
1222 bitmapAddrModes xs = map mkWordCLit xs
1223 \end{code}
1224
1225 %************************************************************************
1226 %*                                                                      *
1227 \subsection[a2r-MagicIds]{Magic ids}
1228 %*                                                                      *
1229 %************************************************************************
1230
1231 @pprRegRelative@ returns a pair of the @Doc@ for the register
1232 (some casting may be required), and a @Maybe Doc@ for the offset
1233 (zero offset gives a @Nothing@).
1234
1235 \begin{code}
1236 addPlusSign :: Bool -> SDoc -> SDoc
1237 addPlusSign False p = p
1238 addPlusSign True  p = (<>) (char '+') p
1239
1240 pprSignedInt :: Bool -> Int -> Maybe SDoc       -- Nothing => 0
1241 pprSignedInt sign_wanted n
1242  = if n == 0 then Nothing else
1243    if n > 0  then Just (addPlusSign sign_wanted (int n))
1244    else           Just (int n)
1245
1246 pprRegRelative :: Bool          -- True <=> Print leading plus sign (if +ve)
1247                -> RegRelative
1248                -> (SDoc, Maybe SDoc)
1249
1250 pprRegRelative sign_wanted (SpRel off)
1251   = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))
1252
1253 pprRegRelative sign_wanted r@(HpRel o)
1254   = let pp_Hp    = pprMagicId Hp; off = I# o
1255     in
1256     if off == 0 then
1257         (pp_Hp, Nothing)
1258     else
1259         (pp_Hp, Just ((<>) (char '-') (int off)))
1260
1261 pprRegRelative sign_wanted (NodeRel o)
1262   = let pp_Node = pprMagicId node; off = I# o
1263     in
1264     if off == 0 then
1265         (pp_Node, Nothing)
1266     else
1267         (pp_Node, Just (addPlusSign sign_wanted (int off)))
1268
1269 pprRegRelative sign_wanted (CIndex base offset kind)
1270   = ( hcat [text "((", pprPrimKind kind, text " *)(", ppr_amode base, text "))"]
1271     , Just (hcat [if sign_wanted then char '+' else empty,
1272             text "(I_)(", ppr_amode offset, ptext SLIT(")")])
1273     )
1274 \end{code}
1275
1276 @pprMagicId@ just prints the register name.  @VanillaReg@ registers are
1277 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1278 to select the union tag.
1279
1280 \begin{code}
1281 pprMagicId :: MagicId -> SDoc
1282
1283 pprMagicId BaseReg                  = ptext SLIT("BaseReg")
1284 pprMagicId (VanillaReg pk n)
1285                                     = hcat [ pprVanillaReg n, char '.',
1286                                                   pprUnionTag pk ]
1287 pprMagicId (FloatReg  n)            = ptext SLIT("F") <> int (I# n)
1288 pprMagicId (DoubleReg n)            = ptext SLIT("D") <> int (I# n)
1289 pprMagicId (LongReg _ n)            = ptext SLIT("L") <> int (I# n)
1290 pprMagicId Sp                       = ptext SLIT("Sp")
1291 pprMagicId SpLim                    = ptext SLIT("SpLim")
1292 pprMagicId Hp                       = ptext SLIT("Hp")
1293 pprMagicId HpLim                    = ptext SLIT("HpLim")
1294 pprMagicId CurCostCentre            = ptext SLIT("CCCS")
1295 pprMagicId VoidReg                  = panic "pprMagicId:VoidReg!"
1296
1297 pprVanillaReg :: Int# -> SDoc
1298 pprVanillaReg n = char 'R' <> int (I# n)
1299
1300 pprUnionTag :: PrimRep -> SDoc
1301
1302 pprUnionTag PtrRep              = char 'p'
1303 pprUnionTag CodePtrRep          = ptext SLIT("fp")
1304 pprUnionTag DataPtrRep          = char 'd'
1305 pprUnionTag RetRep              = char 'p'
1306 pprUnionTag CostCentreRep       = panic "pprUnionTag:CostCentre?"
1307
1308 pprUnionTag CharRep             = char 'c'
1309 pprUnionTag Int8Rep             = ptext SLIT("i8")
1310 pprUnionTag IntRep              = char 'i'
1311 pprUnionTag WordRep             = char 'w'
1312 pprUnionTag Int32Rep            = char 'i'
1313 pprUnionTag Word32Rep           = char 'w'
1314 pprUnionTag AddrRep             = char 'a'
1315 pprUnionTag FloatRep            = char 'f'
1316 pprUnionTag DoubleRep           = panic "pprUnionTag:Double?"
1317
1318 pprUnionTag StablePtrRep        = char 'p'
1319
1320 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
1321 \end{code}
1322
1323
1324 Find and print local and external declarations for a list of
1325 Abstract~C statements.
1326 \begin{code}
1327 pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
1328 pprTempAndExternDecls AbsCNop = (empty, empty)
1329
1330 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1331   = initTE (ppr_decls_AbsC stmt1        `thenTE` \ (t_p1, e_p1) ->
1332             ppr_decls_AbsC stmt2        `thenTE` \ (t_p2, e_p2) ->
1333             case (catMaybes [t_p1, t_p2])        of { real_temps ->
1334             case (catMaybes [e_p1, e_p2])        of { real_exts ->
1335             returnTE (vcat real_temps, vcat real_exts) }}
1336            )
1337
1338 pprTempAndExternDecls other_stmt
1339   = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1340             returnTE (
1341                 case maybe_t of
1342                   Nothing -> empty
1343                   Just pp -> pp,
1344
1345                 case maybe_e of
1346                   Nothing -> empty
1347                   Just pp -> pp )
1348            )
1349
1350 pprBasicLit :: Literal -> SDoc
1351 pprPrimKind :: PrimRep -> SDoc
1352
1353 pprBasicLit  lit = ppr lit
1354 pprPrimKind  k   = ppr k
1355 \end{code}
1356
1357
1358 %************************************************************************
1359 %*                                                                      *
1360 \subsection[a2r-monad]{Monadery}
1361 %*                                                                      *
1362 %************************************************************************
1363
1364 We need some monadery to keep track of temps and externs we have already
1365 printed.  This info must be threaded right through the Abstract~C, so
1366 it's most convenient to hide it in this monad.
1367
1368 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1369 \tr{(UniqSet, CLabelSet)}.  Allegedly for efficiency.
1370
1371 \begin{code}
1372 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1373 emptyCLabelSet = emptyFM
1374 x `elementOfCLabelSet` labs
1375   = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1376
1377 addToCLabelSet set x = addToFM set x ()
1378
1379 type TEenv = (UniqSet Unique, CLabelSet)
1380
1381 type TeM result =  TEenv -> (TEenv, result)
1382
1383 initTE :: TeM a -> a
1384 initTE sa
1385   = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1386     result }
1387
1388 {-# INLINE thenTE #-}
1389 {-# INLINE returnTE #-}
1390
1391 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1392 thenTE a b u
1393   = case a u        of { (u_1, result_of_a) ->
1394     b result_of_a u_1 }
1395
1396 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1397 mapTE f []     = returnTE []
1398 mapTE f (x:xs)
1399   = f x         `thenTE` \ r  ->
1400     mapTE f xs  `thenTE` \ rs ->
1401     returnTE (r : rs)
1402
1403 returnTE :: a -> TeM a
1404 returnTE result env = (env, result)
1405
1406 -- these next two check whether the thing is already
1407 -- recorded, and THEN THEY RECORD IT
1408 -- (subsequent calls will return False for the same uniq/label)
1409
1410 tempSeenTE :: Unique -> TeM Bool
1411 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1412   = if (uniq `elementOfUniqSet` seen_uniqs)
1413     then (env, True)
1414     else ((addOneToUniqSet seen_uniqs uniq,
1415           seen_labels),
1416           False)
1417
1418 labelSeenTE :: CLabel -> TeM Bool
1419 labelSeenTE lbl env@(seen_uniqs, seen_labels)
1420   = if (lbl `elementOfCLabelSet` seen_labels)
1421     then (env, True)
1422     else ((seen_uniqs,
1423           addToCLabelSet seen_labels lbl),
1424           False)
1425 \end{code}
1426
1427 \begin{code}
1428 pprTempDecl :: Unique -> PrimRep -> SDoc
1429 pprTempDecl uniq kind
1430   = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
1431
1432 pprExternDecl :: Bool -> CLabel -> SDoc
1433 pprExternDecl in_srt clabel
1434   | not (needsCDecl clabel) = empty -- do not print anything for "known external" things
1435   | otherwise               =
1436         hcat [ ppLocalnessMacro (not in_srt) clabel,
1437                lparen, dyn_wrapper (pprCLabel clabel), pp_paren_semi ]
1438  where
1439   dyn_wrapper d
1440     | in_srt && labelDynamic clabel = text "DLL_IMPORT_DATA_VAR" <> parens d
1441     | otherwise                     = d
1442
1443 \end{code}
1444
1445 \begin{code}
1446 ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})
1447
1448 ppr_decls_AbsC AbsCNop          = returnTE (Nothing, Nothing)
1449
1450 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1451   = ppr_decls_AbsC stmts_1  `thenTE` \ p1 ->
1452     ppr_decls_AbsC stmts_2  `thenTE` \ p2 ->
1453     returnTE (maybe_vcat [p1, p2])
1454
1455 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1456
1457 ppr_decls_AbsC (CAssign dest source)
1458   = ppr_decls_Amode dest    `thenTE` \ p1 ->
1459     ppr_decls_Amode source  `thenTE` \ p2 ->
1460     returnTE (maybe_vcat [p1, p2])
1461
1462 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1463
1464 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1465
1466 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1467
1468 ppr_decls_AbsC (CSwitch discrim alts deflt)
1469   = ppr_decls_Amode discrim     `thenTE` \ pdisc ->
1470     mapTE ppr_alt_stuff alts    `thenTE` \ palts  ->
1471     ppr_decls_AbsC deflt        `thenTE` \ pdeflt ->
1472     returnTE (maybe_vcat (pdisc:pdeflt:palts))
1473   where
1474     ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1475
1476 ppr_decls_AbsC (CCodeBlock lbl absC)
1477   = ppr_decls_AbsC absC
1478
1479 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre _)
1480         -- ToDo: strictly speaking, should chk "cost_centre" amode
1481   = labelSeenTE info_lbl     `thenTE` \  label_seen ->
1482     returnTE (Nothing,
1483               if label_seen then
1484                   Nothing
1485               else
1486                   Just (pprExternDecl False{-not in an SRT decl-} info_lbl))
1487   where
1488     info_lbl = infoTableLabelFromCI cl_info
1489
1490 ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (res : args)
1491 ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args)
1492
1493 ppr_decls_AbsC (CSimultaneous abc)        = ppr_decls_AbsC abc
1494
1495 ppr_decls_AbsC (CSequential abcs)
1496   = mapTE ppr_decls_AbsC abcs   `thenTE` \ t_and_e_s ->
1497     returnTE (maybe_vcat t_and_e_s)
1498
1499 ppr_decls_AbsC (CCheck              _ amodes code) =
1500      ppr_decls_Amodes amodes `thenTE` \p1 ->
1501      ppr_decls_AbsC code     `thenTE` \p2 ->
1502      returnTE (maybe_vcat [p1,p2])
1503
1504 ppr_decls_AbsC (CMacroStmt          _ amodes)   = ppr_decls_Amodes amodes
1505
1506 ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)   = ppr_decls_Amodes [] -- *****!!!
1507   -- you get some nasty re-decls of stdio.h if you compile
1508   -- the prelude while looking inside those amodes;
1509   -- no real reason to, anyway.
1510 ppr_decls_AbsC (CCallProfCCMacro    _ amodes)   = ppr_decls_Amodes amodes
1511
1512 ppr_decls_AbsC (CStaticClosure _ closure_info cost_centre amodes)
1513         -- ToDo: strictly speaking, should chk "cost_centre" amode
1514   = ppr_decls_Amodes amodes
1515
1516 ppr_decls_AbsC (CClosureInfoAndCode cl_info entry)
1517   = ppr_decls_Amodes [entry_lbl]                `thenTE` \ p1 ->
1518     ppr_decls_AbsC entry                        `thenTE` \ p2 ->
1519     returnTE (maybe_vcat [p1, p2])
1520   where
1521     entry_lbl = CLbl (entryLabelFromCI cl_info) CodePtrRep
1522
1523 ppr_decls_AbsC (CSRT _ closure_lbls)
1524   = mapTE labelSeenTE closure_lbls              `thenTE` \ seen ->
1525     returnTE (Nothing,
1526               if and seen then Nothing
1527                 else Just (vcat [ pprExternDecl True{-in SRT decl-} l
1528                                 | (l,False) <- zip closure_lbls seen ]))
1529
1530 ppr_decls_AbsC (CRetDirect     _ code _ _)   = ppr_decls_AbsC code
1531 ppr_decls_AbsC (CRetVector _ amodes _ _)     = ppr_decls_Amodes amodes
1532 ppr_decls_AbsC (CModuleInitBlock _ _ code)   = ppr_decls_AbsC code
1533
1534 ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)
1535 \end{code}
1536
1537 \begin{code}
1538 ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
1539 ppr_decls_Amode (CVal  (CIndex base offset _) _) = ppr_decls_Amodes [base,offset]
1540 ppr_decls_Amode (CAddr (CIndex base offset _))   = ppr_decls_Amodes [base,offset]
1541 ppr_decls_Amode (CVal _ _)      = returnTE (Nothing, Nothing)
1542 ppr_decls_Amode (CAddr _)       = returnTE (Nothing, Nothing)
1543 ppr_decls_Amode (CReg _)        = returnTE (Nothing, Nothing)
1544 ppr_decls_Amode (CLit _)        = returnTE (Nothing, Nothing)
1545
1546 -- CIntLike must be a literal -- no decls
1547 ppr_decls_Amode (CIntLike int)  = returnTE (Nothing, Nothing)
1548
1549 -- CCharLike too
1550 ppr_decls_Amode (CCharLike char) = returnTE (Nothing, Nothing)
1551
1552 -- now, the only place where we actually print temps/externs...
1553 ppr_decls_Amode (CTemp uniq kind)
1554   = case kind of
1555       VoidRep -> returnTE (Nothing, Nothing)
1556       other ->
1557         tempSeenTE uniq `thenTE` \ temp_seen ->
1558         returnTE
1559           (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1560
1561 ppr_decls_Amode (CLbl lbl VoidRep)
1562   = returnTE (Nothing, Nothing)
1563
1564 ppr_decls_Amode (CLbl lbl kind)
1565   = labelSeenTE lbl `thenTE` \ label_seen ->
1566     returnTE (Nothing,
1567               if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl))
1568
1569 ppr_decls_Amode (CMacroExpr _ _ amodes)
1570   = ppr_decls_Amodes amodes
1571
1572 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1573
1574
1575 maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
1576 maybe_vcat ps
1577   = case (unzip ps)     of { (ts, es) ->
1578     case (catMaybes ts) of { real_ts  ->
1579     case (catMaybes es) of { real_es  ->
1580     (if (null real_ts) then Nothing else Just (vcat real_ts),
1581      if (null real_es) then Nothing else Just (vcat real_es))
1582     } } }
1583 \end{code}
1584
1585 \begin{code}
1586 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
1587 ppr_decls_Amodes amodes
1588   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1589     returnTE ( maybe_vcat ps )
1590 \end{code}
1591
1592 Print out a C Label where you want the *address* of the label, not the
1593 object it refers to.  The distinction is important when the label may
1594 refer to a C structure (info tables and closures, for instance).
1595
1596 When just generating a declaration for the label, use pprCLabel.
1597
1598 \begin{code}
1599 pprCLabelAddr :: CLabel -> SDoc
1600 pprCLabelAddr clabel =
1601   case labelType clabel of
1602      InfoTblType    -> addr_of_label
1603      RetInfoTblType -> addr_of_label
1604      ClosureType    -> addr_of_label
1605      VecTblType     -> addr_of_label
1606      DataType       -> addr_of_label
1607
1608      _              -> pp_label
1609   where
1610     addr_of_label = ptext SLIT("(P_)&") <> pp_label
1611     pp_label = pprCLabel clabel
1612 \end{code}
1613
1614 -----------------------------------------------------------------------------
1615 Initialising static objects with floating-point numbers.  We can't
1616 just emit the floating point number, because C will cast it to an int
1617 by rounding it.  We want the actual bit-representation of the float.
1618
1619 This is a hack to turn the floating point numbers into ints that we
1620 can safely initialise to static locations.
1621
1622 \begin{code}
1623 big_doubles = (getPrimRepSize DoubleRep) /= 1
1624
1625 #if __GLASGOW_HASKELL__ >= 504
1626 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
1627 newFloatArray = newArray_
1628
1629 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
1630 newDoubleArray = newArray_
1631
1632 castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
1633 castFloatToIntArray = castSTUArray
1634
1635 castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
1636 castDoubleToIntArray = castSTUArray
1637
1638 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
1639 writeFloatArray = writeArray
1640
1641 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
1642 writeDoubleArray = writeArray
1643
1644 readIntArray :: STUArray s Int Int -> Int -> ST s Int
1645 readIntArray = readArray
1646
1647 #else
1648
1649 castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
1650 castFloatToIntArray = return
1651
1652 castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
1653 castDoubleToIntArray = return
1654
1655 #endif
1656
1657 -- floats are always 1 word
1658 floatToWord :: CAddrMode -> CAddrMode
1659 floatToWord (CLit (MachFloat r))
1660   = runST (do
1661         arr <- newFloatArray ((0::Int),0)
1662         writeFloatArray arr 0 (fromRational r)
1663         arr' <- castFloatToIntArray arr
1664         i <- readIntArray arr' 0
1665         return (CLit (MachInt (toInteger i)))
1666     )
1667
1668 doubleToWords :: CAddrMode -> [CAddrMode]
1669 doubleToWords (CLit (MachDouble r))
1670   | big_doubles                         -- doubles are 2 words
1671   = runST (do
1672         arr <- newDoubleArray ((0::Int),1)
1673         writeDoubleArray arr 0 (fromRational r)
1674         arr' <- castDoubleToIntArray arr
1675         i1 <- readIntArray arr' 0
1676         i2 <- readIntArray arr' 1
1677         return [ CLit (MachInt (toInteger i1))
1678                , CLit (MachInt (toInteger i2))
1679                ]
1680     )
1681   | otherwise                           -- doubles are 1 word
1682   = runST (do
1683         arr <- newDoubleArray ((0::Int),0)
1684         writeDoubleArray arr 0 (fromRational r)
1685         arr' <- castDoubleToIntArray arr
1686         i <- readIntArray arr' 0
1687         return [ CLit (MachInt (toInteger i)) ]
1688     )
1689 \end{code}