compiler/cmm/ZipCfgCmmRep.hs

   1 -- This module is pure representation and should be imported only by
   2 -- clients that need to manipulate representation and know what
   3 -- they're doing.  Clients that need to create flow graphs should
   4 -- instead import MkZipCfgCmm.
   5
   6 module ZipCfgCmmRep
   7   ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
   8   , Middle(..), Last(..), MidCallTarget(..), UpdFrameOffset
   9   , Convention(..), ForeignConvention(..), ForeignSafety(..)
  10   , ValueDirection(..), ForeignHint(..)
  11   , CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted
  12   , insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast
  13   , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast, joinOuts
  14   )
  15 where
  16
  17 import BlockId
  18 import CmmExpr
  19 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
  20            , CallishMachOp(..), ForeignHint(..)
  21            , CmmActuals, CmmFormals, CmmHinted(..)
  22            , CmmStmt(..) -- imported in order to call ppr on Switch and to
  23                          -- implement pprCmmGraphLikeCmm
  24            )
  25 import DFMonad
  26 import PprCmm()
  27 import CmmTx
  28
  29 import CLabel
  30 import FastString
  31 import ForeignCall
  32 import qualified ZipDataflow as DF
  33 import ZipCfg
  34 import MkZipCfg
  35 import Util
  36
  37 import BasicTypes
  38 import Maybes
  39 import Control.Monad
  40 import Outputable
  41 import Prelude hiding (zip, unzip, last)
  42 import SMRep (ByteOff)
  43 import UniqSupply
  44
  45 ----------------------------------------------------------------------
  46 ----- Type synonyms and definitions
  47
  48 type CmmGraph                = LGraph Middle Last
  49 type CmmAGraph               = AGraph Middle Last
  50 type CmmBlock                = Block  Middle Last
  51 type CmmStackInfo            = (ByteOff, Maybe ByteOff)
  52   -- probably want a record; (SP offset on entry, update frame space)
  53 type CmmZ                    = GenCmm    CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
  54 type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
  55 type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
  56 type CmmForwardFixedPoint  a = DF.ForwardFixedPoint  Middle Last a ()
  57
  58 type UpdFrameOffset = ByteOff
  59
  60 data Middle
  61   = MidComment FastString
  62
  63   | MidAssign CmmReg CmmExpr     -- Assign to register
  64
  65   | MidStore  CmmExpr CmmExpr    -- Assign to memory location.  Size is
  66                                  -- given by cmmExprType of the rhs.
  67
  68   | MidForeignCall               -- A foreign call; see Note [Foreign calls]
  69      ForeignSafety               -- Is it a safe or unsafe call?
  70      MidCallTarget               -- call target and convention
  71      CmmFormals                  -- zero or more results
  72      CmmActuals                  -- zero or more arguments
  73   deriving Eq
  74
  75 data Last
  76   = LastBranch BlockId  -- Goto another block in the same procedure
  77
  78   | LastCondBranch {            -- conditional branch
  79         cml_pred :: CmmExpr,
  80         cml_true, cml_false :: BlockId
  81     }
  82   | LastSwitch CmmExpr [Maybe BlockId]   -- Table branch
  83         -- The scrutinee is zero-based;
  84         --      zero -> first block
  85         --      one  -> second block etc
  86         -- Undefined outside range, and when there's a Nothing
  87   | LastCall {                   -- A call (native or safe foreign)
  88         cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!
  89
  90         cml_cont :: Maybe BlockId,
  91             -- BlockId of continuation (Nothing for return or tail call)
  92
  93         cml_args :: ByteOff,
  94             -- Byte offset, from the *old* end of the Area associated with
  95             -- the BlockId (if cml_cont = Nothing, then Old area), of
  96             -- youngest outgoing arg.  Set the stack pointer to this before
  97             -- transferring control.
  98             -- (NB: an update frame might also have been stored in the Old
  99             --      area, but it'll be in an older part than the args.)
 100
 101         cml_ret_args :: ByteOff,
 102             -- For calls *only*, the byte offset for youngest returned value
 103             -- This is really needed at the *return* point rather than here
 104             -- at the call, but in practice it's convenient to record it here.
 105
 106         cml_ret_off :: Maybe ByteOff
 107           -- For calls *only*, the byte offset of the base of the frame that
 108           -- must be described by the info table for the return point.
 109           -- The older words are an update frames, which have their own
 110           -- info-table and layout information
 111
 112           -- From a liveness point of view, the stack words older than
 113           -- cml_ret_off are treated as live, even if the sequel of
 114           -- the call goes into a loop.
 115         }
 116
 117 data MidCallTarget        -- The target of a MidUnsafeCall
 118   = ForeignTarget         -- A foreign procedure
 119         CmmExpr                  -- Its address
 120         ForeignConvention        -- Its calling convention
 121
 122   | PrimTarget            -- A possibly-side-effecting machine operation
 123         CallishMachOp            -- Which one
 124   deriving Eq
 125
 126 data Convention
 127   = NativeDirectCall -- Native C-- call skipping the node (closure) argument
 128
 129   | NativeNodeCall   -- Native C-- call including the node argument
 130
 131   | NativeReturn     -- Native C-- return
 132
 133   | Slow             -- Slow entry points: all args pushed on the stack
 134
 135   | GC               -- Entry to the garbage collector: uses the node reg!
 136
 137   | PrimOpCall       -- Calling prim ops
 138
 139   | PrimOpReturn     -- Returning from prim ops
 140
 141   | Foreign          -- Foreign call/return
 142         ForeignConvention
 143
 144   | Private
 145         -- Used for control transfers within a (pre-CPS) procedure All
 146         -- jump sites known, never pushed on the stack (hence no SRT)
 147         -- You can choose whatever calling convention you please
 148         -- (provided you make sure all the call sites agree)!
 149         -- This data type eventually to be extended to record the convention.
 150   deriving( Eq )
 151
 152 data ForeignConvention
 153   = ForeignConvention
 154         CCallConv               -- Which foreign-call convention
 155         [ForeignHint]           -- Extra info about the args
 156         [ForeignHint]           -- Extra info about the result
 157   deriving Eq
 158
 159 data ForeignSafety
 160   = Unsafe              -- unsafe call
 161   | Safe BlockId        -- making infotable requires: 1. label
 162          UpdFrameOffset --                            2. where the upd frame is
 163   deriving Eq
 164
 165 data ValueDirection = Arguments | Results
 166   -- Arguments go with procedure definitions, jumps, and arguments to calls
 167   -- Results go with returns and with results of calls.
 168   deriving Eq
 169
 170 {- Note [Foreign calls]
 171 ~~~~~~~~~~~~~~~~~~~~~~~
 172 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
 173 Unsafe ones are easy: think of them as a "fat machine instruction".
 174
 175 Safe ones are trickier.  A safe foreign call
 176      r = f(x)
 177 ultimately expands to
 178      push "return address"      -- Never used to return to;
 179                                 -- just points an info table
 180      save registers into TSO
 181      call suspendThread
 182      r = f(x)                   -- Make the call
 183      call resumeThread
 184      restore registers
 185      pop "return address"
 186 We cannot "lower" a safe foreign call to this sequence of Cmms, because
 187 after we've saved Sp all the Cmm optimiser's assumptions are broken.
 188 Furthermore, currently the smart Cmm constructors know the calling
 189 conventions for Haskell, the garbage collector, etc, and "lower" them
 190 so that a LastCall passes no parameters or results.  But the smart
 191 constructors do *not* (currently) know the foreign call conventions.
 192
 193 For these reasons use MidForeignCall for all calls. The only annoying thing
 194 is that a safe foreign call needs an info table.
 195 -}
 196
 197 ----------------------------------------------------------------------
 198 ----- Splicing between blocks
 199 -- Given a middle node, a block, and a successor BlockId,
 200 -- we can insert the middle node between the block and the successor.
 201 -- We return the updated block and a list of new blocks that must be added
 202 -- to the graph.
 203 -- The semantics is a bit tricky. We consider cases on the last node:
 204 -- o For a branch, we can just insert before the branch,
 205 --   but sometimes the optimizer does better if we actually insert
 206 --   a fresh basic block, enabling some common blockification.
 207 -- o For a conditional branch, switch statement, or call, we must insert
 208 --   a new basic block.
 209 -- o For a jump or return, this operation is impossible.
 210
 211 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
 212 insertBetween b ms succId = insert $ goto_end $ unzip b
 213   where insert (h, LastOther (LastBranch bid)) =
 214           if bid == succId then
 215             do (bid', bs) <- newBlocks
 216                return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
 217           else panic "tried invalid block insertBetween"
 218         insert (h, LastOther (LastCondBranch c t f)) =
 219           do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
 220              (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
 221              return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
 222         insert (h, LastOther (LastSwitch e ks)) =
 223           do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
 224              return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
 225         insert (_, LastOther (LastCall {})) =
 226           panic "unimp: insertBetween after a call -- probably not a good idea"
 227         insert (_, LastExit) = panic "cannot insert after exit"
 228         newBlocks = do id <- liftM BlockId $ getUniqueM
 229                        return $ (id, [Block id $
 230                                    foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
 231         mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
 232                                else return (Just k, [])
 233         mbNewBlocks Nothing  = return (Nothing, [])
 234         lift (id, bs) = (Just id, bs)
 235
 236 ----------------------------------------------------------------------
 237 ----- Instance declarations for control flow
 238
 239 instance HavingSuccessors Last where
 240     succs = cmmSuccs
 241     fold_succs = fold_cmm_succs
 242
 243 instance LastNode Last where
 244     mkBranchNode id = LastBranch id
 245     isBranchNode (LastBranch _) = True
 246     isBranchNode _ = False
 247     branchNodeTarget (LastBranch id) = id
 248     branchNodeTarget _ = panic "asked for target of non-branch"
 249
 250 cmmSuccs :: Last -> [BlockId]
 251 cmmSuccs (LastBranch id)              = [id]
 252 cmmSuccs (LastCall _ Nothing   _ _ _) = []
 253 cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
 254 cmmSuccs (LastCondBranch _ t f)       = [f, t]  -- meets layout constraint
 255 cmmSuccs (LastSwitch _ edges)         = catMaybes edges
 256
 257 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
 258 fold_cmm_succs  f (LastBranch id)              z = f id z
 259 fold_cmm_succs  _ (LastCall _ Nothing _ _ _)   z = z
 260 fold_cmm_succs  f (LastCall _ (Just id) _ _ _) z = f id z
 261 fold_cmm_succs  f (LastCondBranch _ te fe)     z = f te (f fe z)
 262 fold_cmm_succs  f (LastSwitch _ edges)         z = foldl (flip f) z $ catMaybes edges
 263
 264 ----------------------------------------------------------------------
 265 ----- Instance declarations for register use
 266
 267 instance UserOfLocalRegs Middle where
 268     foldRegsUsed f z m = middle m
 269       where middle (MidComment {})               = z
 270             middle (MidAssign _lhs expr)         = fold f z expr
 271             middle (MidStore addr rval)          = fold f (fold f z addr) rval
 272             middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
 273             fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
 274
 275 instance UserOfLocalRegs MidCallTarget where
 276   foldRegsUsed _f z (PrimTarget _)      = z
 277   foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e
 278
 279 instance UserOfSlots MidCallTarget where
 280   foldSlotsUsed  f z (ForeignTarget e _) = foldSlotsUsed f z e
 281   foldSlotsUsed _f z (PrimTarget _)      = z
 282
 283 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
 284   foldRegsUsed f z (Just x) = foldRegsUsed f z x
 285   foldRegsUsed _ z Nothing  = z
 286
 287 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
 288   foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
 289   foldSlotsUsed _ z Nothing  = z
 290
 291 instance UserOfLocalRegs Last where
 292     foldRegsUsed f z l = last l
 293       where last (LastBranch _id)       = z
 294             last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
 295             last (LastCondBranch e _ _) = foldRegsUsed f z e
 296             last (LastSwitch e _tbl)    = foldRegsUsed f z e
 297
 298 instance DefinerOfLocalRegs Middle where
 299     foldRegsDefd f z m = middle m
 300       where middle (MidComment {})           = z
 301             middle (MidAssign lhs _)         = fold f z lhs
 302             middle (MidStore _ _)            = z
 303             middle (MidForeignCall _ _ fs _) = fold f z fs
 304             fold f z m = foldRegsDefd f z m  -- avoid monomorphism restriction
 305
 306 instance DefinerOfLocalRegs Last where
 307     foldRegsDefd _ z _ = z
 308
 309
 310 ----------------------------------------------------------------------
 311 ----- Instance declarations for stack slot use
 312
 313 instance UserOfSlots Middle where
 314     foldSlotsUsed f z m = middle m
 315       where middle (MidComment {})                   = z
 316             middle (MidAssign _lhs expr)             = fold f z expr
 317             middle (MidStore addr rval)              = fold f (fold f z addr) rval
 318             middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
 319             fold f z e = foldSlotsUsed f z e  -- avoid monomorphism restriction
 320
 321 instance UserOfSlots Last where
 322     foldSlotsUsed f z l = last l
 323       where last (LastBranch _id)       = z
 324             last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
 325             last (LastCondBranch e _ _) = foldSlotsUsed f z e
 326             last (LastSwitch e _tbl)    = foldSlotsUsed f z e
 327
 328 instance UserOfSlots l => UserOfSlots (ZLast l) where
 329     foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
 330     foldSlotsUsed _ z LastExit      = z
 331
 332 instance DefinerOfSlots Middle where
 333     foldSlotsDefd f z m = middle m
 334       where middle (MidComment {})    = z
 335             middle (MidAssign _ _)    = z
 336             middle (MidForeignCall {}) = z
 337             middle (MidStore (CmmStackSlot a i) e) =
 338               f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
 339             middle (MidStore _ _)     = z
 340
 341 instance DefinerOfSlots Last where
 342     foldSlotsDefd _ z _ = z
 343
 344 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
 345     foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
 346     foldSlotsDefd _ z LastExit      = z
 347
 348 ----------------------------------------------------------------------
 349 ----- Code for manipulating Middle and Last nodes
 350
 351 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
 352 mapExpMiddle _   m@(MidComment _)            = m
 353 mapExpMiddle exp   (MidAssign r e)           = MidAssign r (exp e)
 354 mapExpMiddle exp   (MidStore addr e)         = MidStore (exp addr) (exp e)
 355 mapExpMiddle exp   (MidForeignCall s tgt fs as) =
 356   MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
 357
 358 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
 359 foldExpMiddle _   (MidComment _)              z = z
 360 foldExpMiddle exp (MidAssign _ e)             z = exp e z
 361 foldExpMiddle exp (MidStore addr e)           z = exp addr $ exp e z
 362 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
 363
 364 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
 365 mapExpLast _   l@(LastBranch _)           = l
 366 mapExpLast exp (LastCondBranch e ti fi)   = LastCondBranch (exp e) ti fi
 367 mapExpLast exp (LastSwitch e tbl)         = LastSwitch (exp e) tbl
 368 mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
 369
 370 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
 371 foldExpLast _   (LastBranch _)         z = z
 372 foldExpLast exp (LastCondBranch e _ _) z = exp e z
 373 foldExpLast exp (LastSwitch e _)       z = exp e z
 374 foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
 375
 376 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
 377 mapExpMidcall exp   (ForeignTarget e c) = ForeignTarget (exp e) c
 378 mapExpMidcall _   m@(PrimTarget _)      = m
 379
 380 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
 381 foldExpMidcall exp (ForeignTarget e _) z = exp e z
 382 foldExpMidcall _   (PrimTarget _)      z = z
 383
 384 -- Take a transformer on expressions and apply it recursively.
 385 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
 386 wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
 387 wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
 388 wrapRecExp f e                    = f e
 389
 390 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
 391 mapExpDeepLast   :: (CmmExpr -> CmmExpr) -> Last   -> Last
 392 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
 393 mapExpDeepLast   f = mapExpLast   $ wrapRecExp f
 394
 395 -- Take a folder on expressions and apply it recursively.
 396 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
 397 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
 398 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
 399 wrapRecExpf f e                  z = f e z
 400
 401 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
 402 foldExpDeepLast   :: (CmmExpr -> z -> z) -> Last   -> z -> z
 403 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
 404 foldExpDeepLast   f = foldExpLast   $ wrapRecExpf f
 405
 406 ----------------------------------------------------------------------
 407 -- Compute the join of facts live out of a Last node. Useful for most backward
 408 -- analyses.
 409 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
 410 joinOuts lattice env l =
 411   let bot  = fact_bot lattice
 412       join x y = txVal $ fact_add_to lattice x y
 413   in case l of
 414        (LastBranch id)             -> env id
 415        (LastCall _ Nothing _ _ _)  -> bot
 416        (LastCall _ (Just k) _ _ _) -> env k
 417        (LastCondBranch _ t f)      -> join (env t) (env f)
 418        (LastSwitch _ tbl)          -> foldr join bot (map env $ catMaybes tbl)
 419
 420 ----------------------------------------------------------------------
 421 ----- Instance declarations for prettyprinting (avoids recursive imports)
 422
 423 instance Outputable Middle where
 424     ppr s = pprMiddle s
 425
 426 instance Outputable Last where
 427     ppr s = pprLast s
 428
 429 instance Outputable Convention where
 430     ppr = pprConvention
 431
 432 instance Outputable ForeignConvention where
 433     ppr = pprForeignConvention
 434
 435 instance Outputable ValueDirection where
 436     ppr Arguments = ptext $ sLit "args"
 437     ppr Results   = ptext $ sLit "results"
 438
 439 instance DF.DebugNodes Middle Last
 440
 441 debugPpr :: Bool
 442 debugPpr = debugIsOn
 443
 444 pprMiddle :: Middle -> SDoc
 445 pprMiddle stmt = pp_stmt <+> pp_debug
 446   where
 447     pp_stmt = case stmt of
 448         --  // text
 449         MidComment s -> text "//" <+> ftext s
 450
 451         -- reg = expr;
 452         MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 453
 454         -- rep[lv] = expr;
 455         MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 456             where
 457               rep = ppr ( cmmExprType expr )
 458
 459         -- call "ccall" foo(x, y)[r1, r2];
 460         -- ToDo ppr volatile
 461         MidForeignCall safety target results args ->
 462             hsep [ ppUnless (null results) $
 463                       parens (commafy $ map ppr results) <+> equals,
 464                    ppr_safety safety,
 465                    ptext $ sLit "call",
 466                    ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
 467
 468     pp_debug =
 469       if not debugPpr then empty
 470       else text " //" <+>
 471            case stmt of
 472              MidComment     {} -> text "MidComment"
 473              MidAssign      {} -> text "MidAssign"
 474              MidStore       {} -> text "MidStore"
 475              MidForeignCall {} -> text "MidForeignCall"
 476
 477 ppr_fc :: ForeignConvention -> SDoc
 478 ppr_fc (ForeignConvention c args res) =
 479   doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
 480
 481 ppr_safety :: ForeignSafety -> SDoc
 482 ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
 483 ppr_safety Unsafe         = text "unsafe"
 484
 485 ppr_call_target :: MidCallTarget -> SDoc
 486 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
 487 ppr_call_target (PrimTarget op)
 488  -- HACK: We're just using a ForeignLabel to get this printed, the label
 489  --       might not really be foreign.
 490  = ppr (CmmLabel (mkForeignLabel
 491                         (mkFastString (show op))
 492                         Nothing ForeignLabelInThisPackage IsFunction))
 493
 494 ppr_target :: CmmExpr -> SDoc
 495 ppr_target t@(CmmLit _) = ppr t
 496 ppr_target fn'          = parens (ppr fn')
 497
 498 pprHinted :: Outputable a => CmmHinted a -> SDoc
 499 pprHinted (CmmHinted a NoHint)     = ppr a
 500 pprHinted (CmmHinted a AddrHint)   = doubleQuotes (text "address") <+> ppr a
 501 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 502
 503 pprLast :: Last -> SDoc
 504 pprLast stmt = pp_stmt <+> pp_debug
 505   where
 506     pp_stmt = case stmt of
 507        LastBranch ident                -> ptext (sLit "goto") <+> ppr ident <> semi
 508        LastCondBranch expr t f         -> genFullCondBranch expr t f
 509        LastSwitch arg ids              -> ppr $ CmmSwitch arg ids
 510        LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
 511
 512     pp_debug = text " //" <+> case stmt of
 513            LastBranch {} -> text "LastBranch"
 514            LastCondBranch {} -> text "LastCondBranch"
 515            LastSwitch {} -> text "LastSwitch"
 516            LastCall {} -> text "LastCall"
 517
 518 genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
 519                           Maybe UpdFrameOffset -> SDoc
 520 genBareCall fn k out res updfr_off =
 521         hcat [ ptext (sLit "call"), space
 522              , pprFun fn, ptext (sLit "(...)"), space
 523              , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
 524                                                    <+> parens (ppr res)
 525              , ptext (sLit " with update frame") <+> ppr updfr_off
 526              , semi ]
 527
 528 pprFun :: CmmExpr -> SDoc
 529 pprFun f@(CmmLit _) = ppr f
 530 pprFun f = parens (ppr f)
 531
 532 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 533 genFullCondBranch expr t f =
 534     hsep [ ptext (sLit "if")
 535          , parens(ppr expr)
 536          , ptext (sLit "goto")
 537          , ppr t <> semi
 538          , ptext (sLit "else goto")
 539          , ppr f <> semi
 540          ]
 541
 542 pprConvention :: Convention -> SDoc
 543 pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"
 544 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
 545 pprConvention (NativeReturn {})     = text "<native-ret-convention>"
 546 pprConvention  Slow                 = text "<slow-convention>"
 547 pprConvention  GC                   = text "<gc-convention>"
 548 pprConvention  PrimOpCall           = text "<primop-call-convention>"
 549 pprConvention  PrimOpReturn         = text "<primop-ret-convention>"
 550 pprConvention (Foreign c)           = ppr c
 551 pprConvention (Private {})          = text "<private-convention>"
 552
 553 pprForeignConvention :: ForeignConvention -> SDoc
 554 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
 555
 556 commafy :: [SDoc] -> SDoc
 557 commafy xs = hsep $ punctuate comma xs