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