compiler/cmm/ZipCfgCmmRep.hs

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