ZipCfgCmmRep.hs 21.9 KB
Newer Older
1 2 3 4 5 6
-- This module is pure representation and should be imported only by
-- clients that need to manipulate representation and know what
-- they're doing.  Clients that need to create flow graphs should
-- instead import MkZipCfgCmm.

module ZipCfgCmmRep
7
  ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
8 9
  , Middle(..), Last(..), MidCallTarget(..), UpdFrameOffset
  , Convention(..), ForeignConvention(..), ForeignSafety(..)
10 11 12
  , ValueDirection(..), ForeignHint(..)
  , CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted
  , insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast
13
  , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast, joinOuts
14 15 16
  )
where

17
import BlockId
18 19
import CmmExpr
import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
20 21
           , CallishMachOp(..), ForeignHint(..)
           , CmmActuals, CmmFormals, CmmHinted(..)
22 23
           , CmmStmt(..) -- imported in order to call ppr on Switch and to
                         -- implement pprCmmGraphLikeCmm
24
           )
25
import DFMonad
26
import PprCmm()
27
import CmmTx
28 29 30 31

import CLabel
import FastString
import ForeignCall
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
32
import qualified ZipDataflow as DF
33 34
import ZipCfg 
import MkZipCfg
35
import Util
36

37
import BasicTypes
38
import Maybes
Ian Lynagh's avatar
Ian Lynagh committed
39
import Control.Monad
40
import Outputable
41
import Prelude hiding (zip, unzip, last)
42
import SMRep (ByteOff)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
43
import UniqSupply
44

45 46 47
----------------------------------------------------------------------
----- Type synonyms and definitions

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
48 49 50
type CmmGraph                = LGraph Middle Last
type CmmAGraph               = AGraph Middle Last
type CmmBlock                = Block  Middle Last
51 52 53 54
type CmmStackInfo            = (ByteOff, Maybe ByteOff)
  -- probably want a record; (SP offset on entry, update frame space)
type CmmZ                    = GenCmm    CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
55 56
type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
type CmmForwardFixedPoint  a = DF.ForwardFixedPoint  Middle Last a ()
57

58 59
type UpdFrameOffset = ByteOff

60
data Middle
nr@eecs.harvard.edu's avatar
nr@eecs.harvard.edu committed
61
  = MidComment FastString
62 63 64

  | MidAssign CmmReg CmmExpr     -- Assign to register

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
65
  | MidStore  CmmExpr CmmExpr    -- Assign to memory location.  Size is
66
                                 -- given by cmmExprType of the rhs.
67

68
  | MidForeignCall               -- A foreign call; see Note [Foreign calls]
69 70
     ForeignSafety               -- Is it a safe or unsafe call?
     MidCallTarget               -- call target and convention
71
     CmmFormals                  -- zero or more results
72
     CmmActuals                  -- zero or more arguments
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
73
  deriving Eq
74 75

data Last
76
  = LastBranch BlockId  -- Goto another block in the same procedure
77 78 79 80 81 82 83 84 85 86

  | LastCondBranch {            -- conditional branch
        cml_pred :: CmmExpr,
        cml_true, cml_false :: BlockId
    }
  | LastSwitch CmmExpr [Maybe BlockId]   -- Table branch
        -- The scrutinee is zero-based; 
        --      zero -> first block
        --      one  -> second block etc
        -- Undefined outside range, and when there's a Nothing
87
  | LastCall {                   -- A call (native or safe foreign)
88 89 90
        cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!

        cml_cont :: Maybe BlockId,
91
            -- BlockId of continuation (Nothing for return or tail call)
92 93 94 95 96 97 98 99 100 101 102 103 104 105

        cml_args :: ByteOff, 
 	    -- Byte offset, from the *old* end of the Area associated with
            -- the BlockId (if cml_cont = Nothing, then Old area), of
            -- youngest outgoing arg.  Set the stack pointer to this before
	    -- transferring control.
  	    -- (NB: an update frame might also have been stored in the Old
	    --      area, but it'll be in an older part than the args.)

        cml_ret_args :: ByteOff,  
	    -- For calls *only*, the byte offset for youngest returned value
	    -- This is really needed at the *return* point rather than here
	    -- at the call, but in practice it's convenient to record it here.

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
106 107 108 109 110 111 112 113 114
        cml_ret_off :: Maybe ByteOff
          -- For calls *only*, the byte offset of the base of the frame that
	  -- must be described by the info table for the return point.  
 	  -- The older words are an update frames, which have their own
	  -- info-table and layout information

	  -- From a liveness point of view, the stack words older than
	  -- cml_ret_off are treated as live, even if the sequel of
	  -- the call goes into a loop.
115
	}
116

117 118 119 120
data MidCallTarget        -- The target of a MidUnsafeCall
  = ForeignTarget         -- A foreign procedure
        CmmExpr                  -- Its address
        ForeignConvention        -- Its calling convention
121

122 123
  | PrimTarget            -- A possibly-side-effecting machine operation
        CallishMachOp            -- Which one
124
  deriving Eq
125 126

data Convention
127 128 129
  = NativeDirectCall -- Native C-- call skipping the node (closure) argument
  
  | NativeNodeCall   -- Native C-- call including the node argument
130

131
  | NativeReturn     -- Native C-- return
132

133
  | Slow             -- Slow entry points: all args pushed on the stack
134

135
  | GC               -- Entry to the garbage collector: uses the node reg!
136

137
  | PrimOpCall       -- Calling prim ops
138

139
  | PrimOpReturn     -- Returning from prim ops
140

141
  | Foreign          -- Foreign call/return
142
        ForeignConvention
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157

  | Private
        -- Used for control transfers within a (pre-CPS) procedure All
        -- jump sites known, never pushed on the stack (hence no SRT)
        -- You can choose whatever calling convention you please
        -- (provided you make sure all the call sites agree)!
        -- This data type eventually to be extended to record the convention. 
  deriving( Eq )

data ForeignConvention
  = ForeignConvention
	CCallConv 		-- Which foreign-call convention
	[ForeignHint]		-- Extra info about the args
	[ForeignHint]		-- Extra info about the result
  deriving Eq 
158

159 160 161 162 163 164
data ForeignSafety
  = Unsafe              -- unsafe call
  | Safe BlockId        -- making infotable requires: 1. label 
         UpdFrameOffset --                            2. where the upd frame is
  deriving Eq

165 166 167 168
data ValueDirection = Arguments | Results
  -- Arguments go with procedure definitions, jumps, and arguments to calls
  -- Results go with returns and with results of calls.
  deriving Eq
169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195
 
{- Note [Foreign calls]
~~~~~~~~~~~~~~~~~~~~~~~
A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
Unsafe ones are easy: think of them as a "fat machine instruction".

Safe ones are trickier.  A safe foreign call 
     r = f(x)
ultimately expands to
     push "return address"	-- Never used to return to; 
     	  	  		-- just points an info table
     save registers into TSO
     call suspendThread
     r = f(x)			-- Make the call
     call resumeThread
     restore registers
     pop "return address"
We cannot "lower" a safe foreign call to this sequence of Cmms, because
after we've saved Sp all the Cmm optimiser's assumptions are broken.
Furthermore, currently the smart Cmm constructors know the calling
conventions for Haskell, the garbage collector, etc, and "lower" them
so that a LastCall passes no parameters or results.  But the smart 
constructors do *not* (currently) know the foreign call conventions.

For these reasons use MidForeignCall for all calls. The only annoying thing
is that a safe foreign call needs an info table.
-}
196

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
197 198 199 200 201 202 203 204 205 206 207 208
----------------------------------------------------------------------
----- Splicing between blocks
-- Given a middle node, a block, and a successor BlockId,
-- we can insert the middle node between the block and the successor.
-- We return the updated block and a list of new blocks that must be added
-- to the graph.
-- The semantics is a bit tricky. We consider cases on the last node:
-- o For a branch, we can just insert before the branch,
--   but sometimes the optimizer does better if we actually insert
--   a fresh basic block, enabling some common blockification.
-- o For a conditional branch, switch statement, or call, we must insert
--   a new basic block.
209
-- o For a jump or return, this operation is impossible.
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
210 211 212 213 214 215

insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
insertBetween b ms succId = insert $ goto_end $ unzip b
  where insert (h, LastOther (LastBranch bid)) =
          if bid == succId then
            do (bid', bs) <- newBlocks
216 217
               return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
          else panic "tried invalid block insertBetween"
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
218 219 220 221 222 223 224
        insert (h, LastOther (LastCondBranch c t f)) =
          do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
             (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
             return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
        insert (h, LastOther (LastSwitch e ks)) =
          do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
             return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
225
        insert (_, LastOther (LastCall {})) =
226
          panic "unimp: insertBetween after a call -- probably not a good idea"
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
227 228
        insert (_, LastExit) = panic "cannot insert after exit"
        newBlocks = do id <- liftM BlockId $ getUniqueM
229
                       return $ (id, [Block id $
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
230 231 232 233 234 235
                                   foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
        mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
                               else return (Just k, [])
        mbNewBlocks Nothing  = return (Nothing, [])
        lift (id, bs) = (Just id, bs)

236 237 238
----------------------------------------------------------------------
----- Instance declarations for control flow

239 240 241 242 243
instance HavingSuccessors Last where
    succs = cmmSuccs
    fold_succs = fold_cmm_succs

instance LastNode Last where
244 245
    mkBranchNode id = LastBranch id
    isBranchNode (LastBranch _) = True
246
    isBranchNode _ = False
247
    branchNodeTarget (LastBranch id) = id
248 249 250
    branchNodeTarget _ = panic "asked for target of non-branch"

cmmSuccs :: Last -> [BlockId]
251 252 253 254 255
cmmSuccs (LastBranch id)              = [id]
cmmSuccs (LastCall _ Nothing   _ _ _) = []
cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
cmmSuccs (LastCondBranch _ t f)       = [f, t]  -- meets layout constraint
cmmSuccs (LastSwitch _ edges)         = catMaybes edges
256 257

fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
258 259 260 261 262
fold_cmm_succs  f (LastBranch id)              z = f id z
fold_cmm_succs  _ (LastCall _ Nothing _ _ _)   z = z
fold_cmm_succs  f (LastCall _ (Just id) _ _ _) z = f id z
fold_cmm_succs  f (LastCondBranch _ te fe)     z = f te (f fe z)
fold_cmm_succs  f (LastSwitch _ edges)         z = foldl (flip f) z $ catMaybes edges
263

264 265 266 267 268
----------------------------------------------------------------------
----- Instance declarations for register use

instance UserOfLocalRegs Middle where
    foldRegsUsed f z m = middle m
269 270 271 272
      where middle (MidComment {})               = z
            middle (MidAssign _lhs expr)         = fold f z expr
            middle (MidStore addr rval)          = fold f (fold f z addr) rval
            middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
273
            fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
274

275 276 277 278 279
instance UserOfLocalRegs MidCallTarget where
  foldRegsUsed _f z (PrimTarget _)      = z
  foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e

instance UserOfSlots MidCallTarget where
280
  foldSlotsUsed  f z (ForeignTarget e _) = foldSlotsUsed f z e
281 282
  foldSlotsUsed _f z (PrimTarget _)      = z

283 284 285 286 287 288 289 290
instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
  foldRegsUsed f z (Just x) = foldRegsUsed f z x
  foldRegsUsed _ z Nothing  = z

instance (UserOfSlots a) => UserOfSlots (Maybe a) where
  foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
  foldSlotsUsed _ z Nothing  = z

291
instance UserOfLocalRegs Last where
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
292
    foldRegsUsed f z l = last l
293
      where last (LastBranch _id)       = z
294
            last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
295 296 297
            last (LastCondBranch e _ _) = foldRegsUsed f z e
            last (LastSwitch e _tbl)    = foldRegsUsed f z e

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
298 299
instance DefinerOfLocalRegs Middle where
    foldRegsDefd f z m = middle m
300 301 302 303
      where middle (MidComment {})           = z
            middle (MidAssign lhs _)         = fold f z lhs
            middle (MidStore _ _)            = z
            middle (MidForeignCall _ _ fs _) = fold f z fs
304 305 306 307 308 309 310 311 312 313 314
            fold f z m = foldRegsDefd f z m  -- avoid monomorphism restriction

instance DefinerOfLocalRegs Last where
    foldRegsDefd _ z _ = z


----------------------------------------------------------------------
----- Instance declarations for stack slot use

instance UserOfSlots Middle where
    foldSlotsUsed f z m = middle m
315 316 317 318
      where middle (MidComment {})                   = z
            middle (MidAssign _lhs expr)             = fold f z expr
            middle (MidStore addr rval)              = fold f (fold f z addr) rval
            middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
319 320 321 322
            fold f z e = foldSlotsUsed f z e  -- avoid monomorphism restriction

instance UserOfSlots Last where
    foldSlotsUsed f z l = last l
323
      where last (LastBranch _id)       = z
324
            last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
325 326 327 328 329 330 331 332 333
            last (LastCondBranch e _ _) = foldSlotsUsed f z e
            last (LastSwitch e _tbl)    = foldSlotsUsed f z e

instance UserOfSlots l => UserOfSlots (ZLast l) where
    foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
    foldSlotsUsed _ z LastExit      = z

instance DefinerOfSlots Middle where
    foldSlotsDefd f z m = middle m
334 335 336
      where middle (MidComment {})    = z
            middle (MidAssign _ _)    = z
            middle (MidForeignCall {}) = z
337 338
            middle (MidStore (CmmStackSlot a i) e) =
              f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
339
            middle (MidStore _ _)     = z
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
340

341 342 343 344 345 346 347 348 349 350 351 352 353 354
instance DefinerOfSlots Last where
    foldSlotsDefd _ z _ = z

instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
    foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
    foldSlotsDefd _ z LastExit      = z

----------------------------------------------------------------------
----- Code for manipulating Middle and Last nodes

mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
mapExpMiddle _   m@(MidComment _)            = m
mapExpMiddle exp   (MidAssign r e)           = MidAssign r (exp e)
mapExpMiddle exp   (MidStore addr e)         = MidStore (exp addr) (exp e)
355 356
mapExpMiddle exp   (MidForeignCall s tgt fs as) =
  MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
357 358

foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
359 360 361 362
foldExpMiddle _   (MidComment _)              z = z
foldExpMiddle exp (MidAssign _ e)             z = exp e z
foldExpMiddle exp (MidStore addr e)           z = exp addr $ exp e z
foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
363 364

mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
365 366 367
mapExpLast _   l@(LastBranch _)           = l
mapExpLast exp (LastCondBranch e ti fi)   = LastCondBranch (exp e) ti fi
mapExpLast exp (LastSwitch e tbl)         = LastSwitch (exp e) tbl
368
mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
369 370 371 372 373

foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
foldExpLast _   (LastBranch _)         z = z
foldExpLast exp (LastCondBranch e _ _) z = exp e z
foldExpLast exp (LastSwitch e _)       z = exp e z
374
foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
375 376 377 378 379 380 381 382 383 384 385

mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget 
mapExpMidcall exp   (ForeignTarget e c) = ForeignTarget (exp e) c
mapExpMidcall _   m@(PrimTarget _)      = m

foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z 
foldExpMidcall exp (ForeignTarget e _) z = exp e z
foldExpMidcall _   (PrimTarget _)      z = z

-- Take a transformer on expressions and apply it recursively.
wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
386 387
wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
388 389 390 391 392 393 394 395 396
wrapRecExp f e                    = f e

mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
mapExpDeepLast   :: (CmmExpr -> CmmExpr) -> Last   -> Last
mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
mapExpDeepLast   f = mapExpLast   $ wrapRecExp f

-- Take a folder on expressions and apply it recursively.
wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
397 398
wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
399 400 401 402 403 404 405 406 407 408 409 410 411 412 413
wrapRecExpf f e                  z = f e z

foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
foldExpDeepLast   :: (CmmExpr -> z -> z) -> Last   -> z -> z
foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
foldExpDeepLast   f = foldExpLast   $ wrapRecExpf f

----------------------------------------------------------------------
-- Compute the join of facts live out of a Last node. Useful for most backward
-- analyses.
joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
joinOuts lattice env l =
  let bot  = fact_bot lattice
      join x y = txVal $ fact_add_to lattice x y
  in case l of
414 415 416 417 418
       (LastBranch id)             -> env id
       (LastCall _ Nothing _ _ _)  -> bot
       (LastCall _ (Just k) _ _ _) -> env k
       (LastCondBranch _ t f)      -> join (env t) (env f)
       (LastSwitch _ tbl)          -> foldr join bot (map env $ catMaybes tbl)
419

420 421
----------------------------------------------------------------------
----- Instance declarations for prettyprinting (avoids recursive imports)
422 423 424 425 426 427 428 429 430 431

instance Outputable Middle where
    ppr s = pprMiddle s

instance Outputable Last where
    ppr s = pprLast s

instance Outputable Convention where
    ppr = pprConvention

432 433 434 435 436 437 438
instance Outputable ForeignConvention where
    ppr = pprForeignConvention

instance Outputable ValueDirection where
    ppr Arguments = ptext $ sLit "args"
    ppr Results   = ptext $ sLit "results"

439 440
instance DF.DebugNodes Middle Last

441
debugPpr :: Bool
442
debugPpr = debugIsOn
443

444
pprMiddle :: Middle -> SDoc    
445
pprMiddle stmt = pp_stmt <+> pp_debug
446 447 448 449 450 451 452 453 454 455 456 457 458 459 460
  where
    pp_stmt = case stmt of
    	--  // text
    	MidComment s -> text "//" <+> ftext s

    	-- reg = expr;
    	MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi

    	-- rep[lv] = expr;
    	MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
    	    where
    	      rep = ppr ( cmmExprType expr )

    	-- call "ccall" foo(x, y)[r1, r2];
    	-- ToDo ppr volatile
461
    	MidForeignCall safety target results args ->
462 463 464
    	    hsep [ ppUnless (null results) $
    	              parens (commafy $ map ppr results) <+> equals,
                   ppr_safety safety,
465 466 467 468 469 470 471
    	           ptext $ sLit "call", 
    	           ppr_call_target target <> parens (commafy $ map ppr args) <> semi]

    pp_debug =
      if not debugPpr then empty
      else text " //" <+>
           case stmt of
472 473 474 475
             MidComment     {} -> text "MidComment"
             MidAssign      {} -> text "MidAssign"
             MidStore       {} -> text "MidStore"
             MidForeignCall {} -> text "MidForeignCall"
476 477

ppr_fc :: ForeignConvention -> SDoc
478 479
ppr_fc (ForeignConvention c args res) =
  doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
480

481 482 483 484
ppr_safety :: ForeignSafety -> SDoc
ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
ppr_safety Unsafe         = text "unsafe"

485 486
ppr_call_target :: MidCallTarget -> SDoc
ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
487 488
ppr_call_target (PrimTarget op) =
  ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction))
489 490 491 492

ppr_target :: CmmExpr -> SDoc
ppr_target t@(CmmLit _) = ppr t
ppr_target fn'          = parens (ppr fn')
493

494 495 496 497
pprHinted :: Outputable a => CmmHinted a -> SDoc
pprHinted (CmmHinted a NoHint)     = ppr a
pprHinted (CmmHinted a AddrHint)   = doubleQuotes (text "address") <+> ppr a
pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed")  <+> ppr a
498

499
pprLast :: Last -> SDoc    
500 501 502
pprLast stmt = pp_stmt <+> pp_debug
  where
    pp_stmt = case stmt of
503 504 505 506
       LastBranch ident                -> ptext (sLit "goto") <+> ppr ident <> semi
       LastCondBranch expr t f         -> genFullCondBranch expr t f
       LastSwitch arg ids              -> ppr $ CmmSwitch arg ids
       LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
507 508 509 510 511 512

    pp_debug = text " //" <+> case stmt of
           LastBranch {} -> text "LastBranch"
           LastCondBranch {} -> text "LastCondBranch"
           LastSwitch {} -> text "LastSwitch"
           LastCall {} -> text "LastCall"
513

514 515 516
genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
                          Maybe UpdFrameOffset -> SDoc
genBareCall fn k out res updfr_off =
517 518
        hcat [ ptext (sLit "call"), space
             , pprFun fn, ptext (sLit "(...)"), space
519 520
             , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
                                                   <+> parens (ppr res)
521
             , ptext (sLit " with update frame") <+> ppr updfr_off
522
             , semi ]
523

524 525 526
pprFun :: CmmExpr -> SDoc
pprFun f@(CmmLit _) = ppr f
pprFun f = parens (ppr f)
527 528 529

genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
genFullCondBranch expr t f =
530
    hsep [ ptext (sLit "if")
531
         , parens(ppr expr)
532
         , ptext (sLit "goto")
533
         , ppr t <> semi
534
         , ptext (sLit "else goto")
535 536 537 538
         , ppr f <> semi
         ]

pprConvention :: Convention -> SDoc
539 540 541 542 543 544 545 546 547
pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"
pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
pprConvention (NativeReturn {})     = text "<native-ret-convention>"
pprConvention  Slow                 = text "<slow-convention>"
pprConvention  GC                   = text "<gc-convention>"
pprConvention  PrimOpCall           = text "<primop-call-convention>"
pprConvention  PrimOpReturn         = text "<primop-ret-convention>"
pprConvention (Foreign c)           = ppr c
pprConvention (Private {})          = text "<private-convention>"
548 549 550

pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
551 552 553

commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs