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