compiler/cmm/ZipCfgCmmRep.hs

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