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          Bool           -- is the call interruptible?
 167   deriving Eq
 168
 169 data ValueDirection = Arguments | Results
 170   -- Arguments go with procedure definitions, jumps, and arguments to calls
 171   -- Results go with returns and with results of calls.
 172   deriving Eq
 173
 174 {- Note [Foreign calls]
 175 ~~~~~~~~~~~~~~~~~~~~~~~
 176 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
 177 Unsafe ones are easy: think of them as a "fat machine instruction".
 178
 179 Safe ones are trickier.  A safe foreign call
 180      r = f(x)
 181 ultimately expands to
 182      push "return address"      -- Never used to return to;
 183                                 -- just points an info table
 184      save registers into TSO
 185      call suspendThread
 186      r = f(x)                   -- Make the call
 187      call resumeThread
 188      restore registers
 189      pop "return address"
 190 We cannot "lower" a safe foreign call to this sequence of Cmms, because
 191 after we've saved Sp all the Cmm optimiser's assumptions are broken.
 192 Furthermore, currently the smart Cmm constructors know the calling
 193 conventions for Haskell, the garbage collector, etc, and "lower" them
 194 so that a LastCall passes no parameters or results.  But the smart
 195 constructors do *not* (currently) know the foreign call conventions.
 196
 197 For these reasons use MidForeignCall for all calls. The only annoying thing
 198 is that a safe foreign call needs an info table.
 199 -}
 200
 201 ----------------------------------------------------------------------
 202 ----- Splicing between blocks
 203 -- Given a middle node, a block, and a successor BlockId,
 204 -- we can insert the middle node between the block and the successor.
 205 -- We return the updated block and a list of new blocks that must be added
 206 -- to the graph.
 207 -- The semantics is a bit tricky. We consider cases on the last node:
 208 -- o For a branch, we can just insert before the branch,
 209 --   but sometimes the optimizer does better if we actually insert
 210 --   a fresh basic block, enabling some common blockification.
 211 -- o For a conditional branch, switch statement, or call, we must insert
 212 --   a new basic block.
 213 -- o For a jump or return, this operation is impossible.
 214
 215 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
 216 insertBetween b ms succId = insert $ goto_end $ unzip b
 217   where insert (h, LastOther (LastBranch bid)) =
 218           if bid == succId then
 219             do (bid', bs) <- newBlocks
 220                return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
 221           else panic "tried invalid block insertBetween"
 222         insert (h, LastOther (LastCondBranch c t f)) =
 223           do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
 224              (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
 225              return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
 226         insert (h, LastOther (LastSwitch e ks)) =
 227           do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
 228              return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
 229         insert (_, LastOther (LastCall {})) =
 230           panic "unimp: insertBetween after a call -- probably not a good idea"
 231         insert (_, LastExit) = panic "cannot insert after exit"
 232         newBlocks = do id <- liftM BlockId $ getUniqueM
 233                        return $ (id, [Block id $
 234                                    foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
 235         mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
 236                                else return (Just k, [])
 237         mbNewBlocks Nothing  = return (Nothing, [])
 238         lift (id, bs) = (Just id, bs)
 239
 240 ----------------------------------------------------------------------
 241 ----- Instance declarations for control flow
 242
 243 instance HavingSuccessors Last where
 244     succs = cmmSuccs
 245     fold_succs = fold_cmm_succs
 246
 247 instance LastNode Last where
 248     mkBranchNode id = LastBranch id
 249     isBranchNode (LastBranch _) = True
 250     isBranchNode _ = False
 251     branchNodeTarget (LastBranch id) = id
 252     branchNodeTarget _ = panic "asked for target of non-branch"
 253
 254 cmmSuccs :: Last -> [BlockId]
 255 cmmSuccs (LastBranch id)              = [id]
 256 cmmSuccs (LastCall _ Nothing   _ _ _) = []
 257 cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
 258 cmmSuccs (LastCondBranch _ t f)       = [f, t]  -- meets layout constraint
 259 cmmSuccs (LastSwitch _ edges)         = catMaybes edges
 260
 261 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
 262 fold_cmm_succs  f (LastBranch id)              z = f id z
 263 fold_cmm_succs  _ (LastCall _ Nothing _ _ _)   z = z
 264 fold_cmm_succs  f (LastCall _ (Just id) _ _ _) z = f id z
 265 fold_cmm_succs  f (LastCondBranch _ te fe)     z = f te (f fe z)
 266 fold_cmm_succs  f (LastSwitch _ edges)         z = foldl (flip f) z $ catMaybes edges
 267
 268 ----------------------------------------------------------------------
 269 ----- Instance declarations for register use
 270
 271 instance UserOfLocalRegs Middle where
 272     foldRegsUsed f z m = middle m
 273       where middle (MidComment {})               = z
 274             middle (MidAssign _lhs expr)         = fold f z expr
 275             middle (MidStore addr rval)          = fold f (fold f z addr) rval
 276             middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
 277             fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
 278
 279 instance UserOfLocalRegs MidCallTarget where
 280   foldRegsUsed _f z (PrimTarget _)      = z
 281   foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e
 282
 283 instance UserOfSlots MidCallTarget where
 284   foldSlotsUsed  f z (ForeignTarget e _) = foldSlotsUsed f z e
 285   foldSlotsUsed _f z (PrimTarget _)      = z
 286
 287 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
 288   foldRegsUsed f z (Just x) = foldRegsUsed f z x
 289   foldRegsUsed _ z Nothing  = z
 290
 291 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
 292   foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
 293   foldSlotsUsed _ z Nothing  = z
 294
 295 instance UserOfLocalRegs Last where
 296     foldRegsUsed f z l = last l
 297       where last (LastBranch _id)       = z
 298             last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
 299             last (LastCondBranch e _ _) = foldRegsUsed f z e
 300             last (LastSwitch e _tbl)    = foldRegsUsed f z e
 301
 302 instance DefinerOfLocalRegs Middle where
 303     foldRegsDefd f z m = middle m
 304       where middle (MidComment {})           = z
 305             middle (MidAssign lhs _)         = fold f z lhs
 306             middle (MidStore _ _)            = z
 307             middle (MidForeignCall _ _ fs _) = fold f z fs
 308             fold f z m = foldRegsDefd f z m  -- avoid monomorphism restriction
 309
 310 instance DefinerOfLocalRegs Last where
 311     foldRegsDefd _ z _ = z
 312
 313
 314 ----------------------------------------------------------------------
 315 ----- Instance declarations for stack slot use
 316
 317 instance UserOfSlots Middle where
 318     foldSlotsUsed f z m = middle m
 319       where middle (MidComment {})                   = z
 320             middle (MidAssign _lhs expr)             = fold f z expr
 321             middle (MidStore addr rval)              = fold f (fold f z addr) rval
 322             middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
 323             fold f z e = foldSlotsUsed f z e  -- avoid monomorphism restriction
 324
 325 instance UserOfSlots Last where
 326     foldSlotsUsed f z l = last l
 327       where last (LastBranch _id)       = z
 328             last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
 329             last (LastCondBranch e _ _) = foldSlotsUsed f z e
 330             last (LastSwitch e _tbl)    = foldSlotsUsed f z e
 331
 332 instance UserOfSlots l => UserOfSlots (ZLast l) where
 333     foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
 334     foldSlotsUsed _ z LastExit      = z
 335
 336 instance DefinerOfSlots Middle where
 337     foldSlotsDefd f z m = middle m
 338       where middle (MidComment {})    = z
 339             middle (MidAssign _ _)    = z
 340             middle (MidForeignCall {}) = z
 341             middle (MidStore (CmmStackSlot a i) e) =
 342               f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
 343             middle (MidStore _ _)     = z
 344
 345 instance DefinerOfSlots Last where
 346     foldSlotsDefd _ z _ = z
 347
 348 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
 349     foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
 350     foldSlotsDefd _ z LastExit      = z
 351
 352 ----------------------------------------------------------------------
 353 ----- Code for manipulating Middle and Last nodes
 354
 355 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
 356 mapExpMiddle _   m@(MidComment _)            = m
 357 mapExpMiddle exp   (MidAssign r e)           = MidAssign r (exp e)
 358 mapExpMiddle exp   (MidStore addr e)         = MidStore (exp addr) (exp e)
 359 mapExpMiddle exp   (MidForeignCall s tgt fs as) =
 360   MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
 361
 362 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
 363 foldExpMiddle _   (MidComment _)              z = z
 364 foldExpMiddle exp (MidAssign _ e)             z = exp e z
 365 foldExpMiddle exp (MidStore addr e)           z = exp addr $ exp e z
 366 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
 367
 368 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
 369 mapExpLast _   l@(LastBranch _)           = l
 370 mapExpLast exp (LastCondBranch e ti fi)   = LastCondBranch (exp e) ti fi
 371 mapExpLast exp (LastSwitch e tbl)         = LastSwitch (exp e) tbl
 372 mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
 373
 374 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
 375 foldExpLast _   (LastBranch _)         z = z
 376 foldExpLast exp (LastCondBranch e _ _) z = exp e z
 377 foldExpLast exp (LastSwitch e _)       z = exp e z
 378 foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
 379
 380 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
 381 mapExpMidcall exp   (ForeignTarget e c) = ForeignTarget (exp e) c
 382 mapExpMidcall _   m@(PrimTarget _)      = m
 383
 384 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
 385 foldExpMidcall exp (ForeignTarget e _) z = exp e z
 386 foldExpMidcall _   (PrimTarget _)      z = z
 387
 388 -- Take a transformer on expressions and apply it recursively.
 389 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
 390 wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
 391 wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
 392 wrapRecExp f e                    = f e
 393
 394 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
 395 mapExpDeepLast   :: (CmmExpr -> CmmExpr) -> Last   -> Last
 396 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
 397 mapExpDeepLast   f = mapExpLast   $ wrapRecExp f
 398
 399 -- Take a folder on expressions and apply it recursively.
 400 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
 401 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
 402 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
 403 wrapRecExpf f e                  z = f e z
 404
 405 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
 406 foldExpDeepLast   :: (CmmExpr -> z -> z) -> Last   -> z -> z
 407 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
 408 foldExpDeepLast   f = foldExpLast   $ wrapRecExpf f
 409
 410 ----------------------------------------------------------------------
 411 -- Compute the join of facts live out of a Last node. Useful for most backward
 412 -- analyses.
 413 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
 414 joinOuts lattice env l =
 415   let bot  = fact_bot lattice
 416       join x y = txVal $ fact_add_to lattice x y
 417   in case l of
 418        (LastBranch id)             -> env id
 419        (LastCall _ Nothing _ _ _)  -> bot
 420        (LastCall _ (Just k) _ _ _) -> env k
 421        (LastCondBranch _ t f)      -> join (env t) (env f)
 422        (LastSwitch _ tbl)          -> foldr join bot (map env $ catMaybes tbl)
 423
 424 ----------------------------------------------------------------------
 425 ----- Instance declarations for prettyprinting (avoids recursive imports)
 426
 427 instance Outputable Middle where
 428     ppr s = pprMiddle s
 429
 430 instance Outputable Last where
 431     ppr s = pprLast s
 432
 433 instance Outputable Convention where
 434     ppr = pprConvention
 435
 436 instance Outputable ForeignConvention where
 437     ppr = pprForeignConvention
 438
 439 instance Outputable ValueDirection where
 440     ppr Arguments = ptext $ sLit "args"
 441     ppr Results   = ptext $ sLit "results"
 442
 443 instance DF.DebugNodes Middle Last
 444
 445 debugPpr :: Bool
 446 debugPpr = debugIsOn
 447
 448 pprMiddle :: Middle -> SDoc
 449 pprMiddle stmt = pp_stmt <+> pp_debug
 450   where
 451     pp_stmt = case stmt of
 452         --  // text
 453         MidComment s -> text "//" <+> ftext s
 454
 455         -- reg = expr;
 456         MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 457
 458         -- rep[lv] = expr;
 459         MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 460             where
 461               rep = ppr ( cmmExprType expr )
 462
 463         -- call "ccall" foo(x, y)[r1, r2];
 464         -- ToDo ppr volatile
 465         MidForeignCall safety target results args ->
 466             hsep [ ppUnless (null results) $
 467                       parens (commafy $ map ppr results) <+> equals,
 468                    ppr_safety safety,
 469                    ptext $ sLit "call",
 470                    ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
 471
 472     pp_debug =
 473       if not debugPpr then empty
 474       else text " //" <+>
 475            case stmt of
 476              MidComment     {} -> text "MidComment"
 477              MidAssign      {} -> text "MidAssign"
 478              MidStore       {} -> text "MidStore"
 479              MidForeignCall {} -> text "MidForeignCall"
 480
 481 ppr_fc :: ForeignConvention -> SDoc
 482 ppr_fc (ForeignConvention c args res) =
 483   doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
 484
 485 ppr_safety :: ForeignSafety -> SDoc
 486 ppr_safety (Safe bid upd interruptible) =
 487     text (if interruptible then "interruptible" else "safe") <>
 488     text "<" <> ppr bid <> text ", " <> ppr upd <> text ">"
 489 ppr_safety Unsafe         = text "unsafe"
 490
 491 ppr_call_target :: MidCallTarget -> SDoc
 492 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
 493 ppr_call_target (PrimTarget op)
 494  -- HACK: We're just using a ForeignLabel to get this printed, the label
 495  --       might not really be foreign.
 496  = ppr (CmmLabel (mkForeignLabel
 497                         (mkFastString (show op))
 498                         Nothing ForeignLabelInThisPackage IsFunction))
 499
 500 ppr_target :: CmmExpr -> SDoc
 501 ppr_target t@(CmmLit _) = ppr t
 502 ppr_target fn'          = parens (ppr fn')
 503
 504 pprHinted :: Outputable a => CmmHinted a -> SDoc
 505 pprHinted (CmmHinted a NoHint)     = ppr a
 506 pprHinted (CmmHinted a AddrHint)   = doubleQuotes (text "address") <+> ppr a
 507 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 508
 509 pprLast :: Last -> SDoc
 510 pprLast stmt = pp_stmt <+> pp_debug
 511   where
 512     pp_stmt = case stmt of
 513        LastBranch ident                -> ptext (sLit "goto") <+> ppr ident <> semi
 514        LastCondBranch expr t f         -> genFullCondBranch expr t f
 515        LastSwitch arg ids              -> ppr $ CmmSwitch arg ids
 516        LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
 517
 518     pp_debug = text " //" <+> case stmt of
 519            LastBranch {} -> text "LastBranch"
 520            LastCondBranch {} -> text "LastCondBranch"
 521            LastSwitch {} -> text "LastSwitch"
 522            LastCall {} -> text "LastCall"
 523
 524 genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
 525                           Maybe UpdFrameOffset -> SDoc
 526 genBareCall fn k out res updfr_off =
 527         hcat [ ptext (sLit "call"), space
 528              , pprFun fn, ptext (sLit "(...)"), space
 529              , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
 530                                                    <+> parens (ppr res)
 531              , ptext (sLit " with update frame") <+> ppr updfr_off
 532              , semi ]
 533
 534 pprFun :: CmmExpr -> SDoc
 535 pprFun f@(CmmLit _) = ppr f
 536 pprFun f = parens (ppr f)
 537
 538 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 539 genFullCondBranch expr t f =
 540     hsep [ ptext (sLit "if")
 541          , parens(ppr expr)
 542          , ptext (sLit "goto")
 543          , ppr t <> semi
 544          , ptext (sLit "else goto")
 545          , ppr f <> semi
 546          ]
 547
 548 pprConvention :: Convention -> SDoc
 549 pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"
 550 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
 551 pprConvention (NativeReturn {})     = text "<native-ret-convention>"
 552 pprConvention  Slow                 = text "<slow-convention>"
 553 pprConvention  GC                   = text "<gc-convention>"
 554 pprConvention  PrimOpCall           = text "<primop-call-convention>"
 555 pprConvention  PrimOpReturn         = text "<primop-ret-convention>"
 556 pprConvention (Foreign c)           = ppr c
 557 pprConvention (Private {})          = text "<private-convention>"
 558
 559 pprForeignConvention :: ForeignConvention -> SDoc
 560 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
 561
 562 commafy :: [SDoc] -> SDoc
 563 commafy xs = hsep $ punctuate comma xs