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