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