ZipCfgCmmRep.hs 22.2 KB
Newer Older
Ian Lynagh's avatar
Ian Lynagh committed
1
#if __GLASGOW_HASKELL__ >= 611
2
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
Ian Lynagh's avatar
Ian Lynagh committed
3
#endif
4
5
-- Norman likes local bindings

6
7
8
9
10
11
-- 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
12
  ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
13
14
  , Middle(..), Last(..), MidCallTarget(..), UpdFrameOffset
  , Convention(..), ForeignConvention(..), ForeignSafety(..)
15
16
17
  , ValueDirection(..), ForeignHint(..)
  , CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted
  , insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast
18
  , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast, joinOuts
19
20
21
  )
where

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

import CLabel
import FastString
import ForeignCall
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
37
import qualified ZipDataflow as DF
38
39
import ZipCfg 
import MkZipCfg
40
import Util
41

42
import BasicTypes
43
import Maybes
Ian Lynagh's avatar
Ian Lynagh committed
44
import Control.Monad
45
import Outputable
46
import Prelude hiding (zip, unzip, last)
47
import SMRep (ByteOff)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
48
import UniqSupply
49

50
51
52
----------------------------------------------------------------------
----- Type synonyms and definitions

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
53
54
55
type CmmGraph                = LGraph Middle Last
type CmmAGraph               = AGraph Middle Last
type CmmBlock                = Block  Middle Last
56
57
58
59
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
60
61
type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
type CmmForwardFixedPoint  a = DF.ForwardFixedPoint  Middle Last a ()
62

63
64
type UpdFrameOffset = ByteOff

65
data Middle
nr@eecs.harvard.edu's avatar
nr@eecs.harvard.edu committed
66
  = MidComment FastString
67
68
69

  | MidAssign CmmReg CmmExpr     -- Assign to register

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
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
75
     ForeignSafety               -- Is it a safe or unsafe call?
     MidCallTarget               -- call target and convention
76
     CmmFormals                  -- zero or more results
77
     CmmActuals                  -- zero or more arguments
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
78
  deriving Eq
79
80

data Last
81
  = LastBranch BlockId  -- Goto another block in the same procedure
82
83
84
85
86
87
88
89
90
91

  | 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
92
  | LastCall {                   -- A call (native or safe foreign)
93
94
95
        cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!

        cml_cont :: Maybe BlockId,
96
            -- BlockId of continuation (Nothing for return or tail call)
97
98
99
100
101
102
103
104
105
106
107
108
109
110

        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
111
112
113
114
115
116
117
118
119
        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.
120
	}
121

122
123
124
125
data MidCallTarget        -- The target of a MidUnsafeCall
  = ForeignTarget         -- A foreign procedure
        CmmExpr                  -- Its address
        ForeignConvention        -- Its calling convention
126

127
128
  | PrimTarget            -- A possibly-side-effecting machine operation
        CallishMachOp            -- Which one
129
  deriving Eq
130
131

data Convention
132
133
134
  = NativeDirectCall -- Native C-- call skipping the node (closure) argument
  
  | 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
150
151
152
153
154
155
156
157
158
159
160
161
162

  | 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 
163

164
165
166
167
168
169
data ForeignSafety
  = Unsafe              -- unsafe call
  | Safe BlockId        -- making infotable requires: 1. label 
         UpdFrameOffset --                            2. where the upd frame is
  deriving Eq

170
171
172
173
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
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
 
{- 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.
-}
201

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
202
203
204
205
206
207
208
209
210
211
212
213
----------------------------------------------------------------------
----- 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.
214
-- o For a jump or return, this operation is impossible.
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
215
216
217
218
219
220

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
221
222
               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
223
224
225
226
227
228
229
        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)
230
        insert (_, LastOther (LastCall {})) =
231
          panic "unimp: insertBetween after a call -- probably not a good idea"
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
232
233
        insert (_, LastExit) = panic "cannot insert after exit"
        newBlocks = do id <- liftM BlockId $ getUniqueM
234
                       return $ (id, [Block id $
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
235
236
237
238
239
240
                                   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)

241
242
243
----------------------------------------------------------------------
----- Instance declarations for control flow

244
245
246
247
248
instance HavingSuccessors Last where
    succs = cmmSuccs
    fold_succs = fold_cmm_succs

instance LastNode Last where
249
250
    mkBranchNode id = LastBranch id
    isBranchNode (LastBranch _) = True
251
    isBranchNode _ = False
252
    branchNodeTarget (LastBranch id) = id
253
254
255
    branchNodeTarget _ = panic "asked for target of non-branch"

cmmSuccs :: Last -> [BlockId]
256
257
258
259
260
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
261
262

fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
263
264
265
266
267
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
268

269
270
271
272
273
----------------------------------------------------------------------
----- Instance declarations for register use

instance UserOfLocalRegs Middle where
    foldRegsUsed f z m = middle m
274
275
276
277
      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
278
            fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
279

280
281
282
283
284
instance UserOfLocalRegs MidCallTarget where
  foldRegsUsed _f z (PrimTarget _)      = z
  foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e

instance UserOfSlots MidCallTarget where
285
  foldSlotsUsed  f z (ForeignTarget e _) = foldSlotsUsed f z e
286
287
  foldSlotsUsed _f z (PrimTarget _)      = z

288
289
290
291
292
293
294
295
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

296
instance UserOfLocalRegs Last where
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
297
    foldRegsUsed f z l = last l
298
      where last (LastBranch _id)       = z
299
            last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
300
301
302
            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
303
304
instance DefinerOfLocalRegs Middle where
    foldRegsDefd f z m = middle m
305
306
307
308
      where middle (MidComment {})           = z
            middle (MidAssign lhs _)         = fold f z lhs
            middle (MidStore _ _)            = z
            middle (MidForeignCall _ _ fs _) = fold f z fs
309
310
311
312
313
314
315
316
317
318
319
            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
320
321
322
323
      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
324
325
326
327
            fold f z e = foldSlotsUsed f z e  -- avoid monomorphism restriction

instance UserOfSlots Last where
    foldSlotsUsed f z l = last l
328
      where last (LastBranch _id)       = z
329
            last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
330
331
332
333
334
335
336
337
338
            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
339
340
341
      where middle (MidComment {})    = z
            middle (MidAssign _ _)    = z
            middle (MidForeignCall {}) = z
342
343
            middle (MidStore (CmmStackSlot a i) e) =
              f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
344
            middle (MidStore _ _)     = z
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
345

346
347
348
349
350
351
352
353
354
355
356
357
358
359
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)
360
361
mapExpMiddle exp   (MidForeignCall s tgt fs as) =
  MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
362
363

foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
364
365
366
367
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
368
369

mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
370
371
372
mapExpLast _   l@(LastBranch _)           = l
mapExpLast exp (LastCondBranch e ti fi)   = LastCondBranch (exp e) ti fi
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
376
377
378

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
379
foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
380
381
382
383
384
385
386
387
388
389
390

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
391
392
wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
393
394
395
396
397
398
399
400
401
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
402
403
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)
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
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
419
420
421
422
423
       (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)
424

425
426
----------------------------------------------------------------------
----- Instance declarations for prettyprinting (avoids recursive imports)
427
428
429
430
431
432
433
434
435
436

instance Outputable Middle where
    ppr s = pprMiddle s

instance Outputable Last where
    ppr s = pprLast s

instance Outputable Convention where
    ppr = pprConvention

437
438
439
440
441
442
443
instance Outputable ForeignConvention where
    ppr = pprForeignConvention

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

444
445
instance DF.DebugNodes Middle Last

446
debugPpr :: Bool
447
debugPpr = debugIsOn
448

449
pprMiddle :: Middle -> SDoc    
450
pprMiddle stmt = pp_stmt <+> pp_debug
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
  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
466
    	MidForeignCall safety target results args ->
467
468
469
    	    hsep [ ppUnless (null results) $
    	              parens (commafy $ map ppr results) <+> equals,
                   ppr_safety safety,
470
471
472
473
474
475
476
    	           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
477
478
479
480
             MidComment     {} -> text "MidComment"
             MidAssign      {} -> text "MidAssign"
             MidStore       {} -> text "MidStore"
             MidForeignCall {} -> text "MidForeignCall"
481
482

ppr_fc :: ForeignConvention -> SDoc
483
484
ppr_fc (ForeignConvention c args res) =
  doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
485

486
487
488
489
ppr_safety :: ForeignSafety -> SDoc
ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
ppr_safety Unsafe         = text "unsafe"

490
491
ppr_call_target :: MidCallTarget -> SDoc
ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
492
493
494
495
496
497
ppr_call_target (PrimTarget op) 
 -- HACK: We're just using a ForeignLabel to get this printed, the label
 --	  might not really be foreign.
 = ppr (CmmLabel (mkForeignLabel
 			(mkFastString (show op)) 
			Nothing ForeignLabelInThisPackage IsFunction))
498
499
500
501

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

503
504
505
506
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
507

508
pprLast :: Last -> SDoc    
509
510
511
pprLast stmt = pp_stmt <+> pp_debug
  where
    pp_stmt = case stmt of
512
513
514
515
       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
516
517
518
519
520
521

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

523
524
525
genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
                          Maybe UpdFrameOffset -> SDoc
genBareCall fn k out res updfr_off =
526
527
        hcat [ ptext (sLit "call"), space
             , pprFun fn, ptext (sLit "(...)"), space
528
529
             , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
                                                   <+> parens (ppr res)
530
             , ptext (sLit " with update frame") <+> ppr updfr_off
531
             , semi ]
532

533
534
535
pprFun :: CmmExpr -> SDoc
pprFun f@(CmmLit _) = ppr f
pprFun f = parens (ppr f)
536
537
538

genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
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
545
546
547
         , ppr f <> semi
         ]

pprConvention :: Convention -> SDoc
548
549
550
551
552
553
554
555
556
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>"
557
558
559

pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
560
561
562

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