compiler/cmm/ZipCfgCmmRep.hs

   1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
   2
   3 -- This module is pure representation and should be imported only by
   4 -- clients that need to manipulate representation and know what
   5 -- they're doing.  Clients that need to create flow graphs should
   6 -- instead import MkZipCfgCmm.
   7
   8 module ZipCfgCmmRep
   9   ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
  10   )
  11 where
  12
  13 #include "HsVersions.h"
  14
  15 import CmmExpr
  16 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
  17            , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
  18            , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
  19            )
  20 import PprCmm()
  21
  22 import CLabel
  23 import ClosureInfo
  24 import FastString
  25 import ForeignCall
  26 import MachOp
  27 import qualified ZipDataflow as DF
  28 import ZipCfg
  29 import MkZipCfg
  30
  31 import Maybes
  32 import Outputable
  33 import Prelude hiding (zip, unzip, last)
  34
  35 type CmmGraph  = LGraph Middle Last
  36 type CmmAGraph = AGraph Middle Last
  37 type CmmBlock  = Block  Middle Last
  38 type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
  39 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
  40
  41 data Middle
  42   = MidNop
  43   | MidComment FastString
  44
  45   | MidAssign CmmReg CmmExpr     -- Assign to register
  46
  47   | MidStore CmmExpr CmmExpr     -- Assign to memory location.  Size is
  48                                  -- given by cmmExprRep of the rhs.
  49
  50   | MidUnsafeCall                -- An "unsafe" foreign call;
  51      CmmCallTarget               -- just a fat machine instructoin
  52      CmmFormals              -- zero or more results
  53      CmmActuals                  -- zero or more arguments
  54
  55   | CopyIn    -- Move parameters or results from conventional locations to registers
  56               -- Note [CopyIn invariant]
  57         Convention
  58         CmmFormals
  59         C_SRT           -- Static things kept alive by this block
  60   | CopyOut Convention CmmFormals
  61
  62 data Last
  63   = LastReturn CmmActuals          -- Return from a function,
  64                                   -- with these return values.
  65
  66   | LastJump   CmmExpr CmmActuals
  67         -- Tail call to another procedure
  68
  69   | LastBranch BlockId CmmFormalsWithoutKinds
  70         -- To another block in the same procedure
  71         -- The parameters are unused at present.
  72
  73   | LastCall {                   -- A call (native or safe foreign)
  74         cml_target :: CmmCallTarget,
  75         cml_actual :: CmmActuals,        -- Zero or more arguments
  76         cml_next   :: Maybe BlockId }  -- BlockId of continuation, if call returns
  77
  78   | LastCondBranch {            -- conditional branch
  79         cml_pred :: CmmExpr,
  80         cml_true, cml_false :: BlockId
  81     }
  82
  83   | LastSwitch CmmExpr [Maybe BlockId]   -- Table branch
  84         -- The scrutinee is zero-based;
  85         --      zero -> first block
  86         --      one  -> second block etc
  87         -- Undefined outside range, and when there's a Nothing
  88
  89 data Convention
  90   = Argument CCallConv  -- Used for function formal params
  91   | Result CCallConv    -- Used for function results
  92
  93   | Local       -- Used for control transfers within a (pre-CPS) procedure
  94                 -- All jump sites known, never pushed on the stack (hence no SRT)
  95                 -- You can choose whatever calling convention
  96                 -- you please (provided you make sure
  97                 -- all the call sites agree)!
  98   deriving Eq
  99
 100 -- ^ In a complete LGraph for a procedure, the [[Exit]] node should not
 101 -- appear, but it is useful in a subgraph (e.g., replacement for a node).
 102
 103 {-
 104 Note [CopyIn invariant]
 105 ~~~~~~~~~~~~~~~~~~~~~~~
 106 In principle, CopyIn ought to be a First node, but in practice, the
 107 possibility raises all sorts of hairy issues with graph splicing,
 108 rewriting, and so on.  In the end, NR finds it better to make the
 109 placement of CopyIn a dynamic invariant.  This change will complicate
 110 the dataflow fact for the proc-point calculation, but it should make
 111 things easier in many other respects.
 112 -}
 113
 114 instance HavingSuccessors Last where
 115     succs = cmmSuccs
 116     fold_succs = fold_cmm_succs
 117
 118 instance LastNode Last where
 119     mkBranchNode id = LastBranch id []
 120     isBranchNode (LastBranch _ []) = True
 121     isBranchNode _ = False
 122     branchNodeTarget (LastBranch id []) = id
 123     branchNodeTarget _ = panic "asked for target of non-branch"
 124
 125 cmmSuccs :: Last -> [BlockId]
 126 cmmSuccs (LastReturn {})          = []
 127 cmmSuccs (LastJump {})            = []
 128 cmmSuccs (LastBranch id _)        = [id]
 129 cmmSuccs (LastCall _ _ (Just id)) = [id]
 130 cmmSuccs (LastCall _ _ Nothing)   = []
 131 cmmSuccs (LastCondBranch _ t f)   = [f, t]  -- meets layout constraint
 132 cmmSuccs (LastSwitch _ edges)     = catMaybes edges
 133
 134 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
 135 fold_cmm_succs _f (LastReturn {})          z = z
 136 fold_cmm_succs _f (LastJump {})            z = z
 137 fold_cmm_succs  f (LastBranch id _)        z = f id z
 138 fold_cmm_succs  f (LastCall _ _ (Just id)) z = f id z
 139 fold_cmm_succs _f (LastCall _ _ Nothing)   z = z
 140 fold_cmm_succs  f (LastCondBranch _ te fe) z = f te (f fe z)
 141 fold_cmm_succs  f (LastSwitch _ edges)     z = foldl (flip f) z $ catMaybes edges
 142
 143
 144 ----------------------------------------------------------------
 145 -- prettyprinting (avoids recursive imports)
 146
 147 instance Outputable Middle where
 148     ppr s = pprMiddle s
 149
 150 instance Outputable Last where
 151     ppr s = pprLast s
 152
 153 instance Outputable Convention where
 154     ppr = pprConvention
 155
 156 instance DF.DebugNodes Middle Last
 157
 158 instance Outputable CmmGraph where
 159     ppr = pprLgraph
 160
 161 debugPpr :: Bool
 162 #ifdef DEBUG
 163 debugPpr = True
 164 #else
 165 debugPpr = False
 166 #endif
 167
 168 pprMiddle :: Middle -> SDoc
 169 pprMiddle stmt = (case stmt of
 170
 171     MidNop -> semi
 172
 173     CopyIn conv args _ ->
 174         if null args then ptext SLIT("empty CopyIn")
 175         else commafy (map pprHinted args) <+> equals <+>
 176              ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
 177
 178     CopyOut conv args ->
 179         if null args then empty
 180         else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
 181              parens (commafy (map pprHinted args))
 182
 183     --  // text
 184     MidComment s -> text "//" <+> ftext s
 185
 186     -- reg = expr;
 187     MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 188
 189     -- rep[lv] = expr;
 190     MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 191         where
 192           rep = ppr ( cmmExprRep expr )
 193
 194     -- call "ccall" foo(x, y)[r1, r2];
 195     -- ToDo ppr volatile
 196     MidUnsafeCall (CmmCallee fn cconv) results args ->
 197         hcat [ if null results
 198                   then empty
 199                   else parens (commafy $ map ppr results) <>
 200                        ptext SLIT(" = "),
 201                ptext SLIT("call"), space,
 202                doubleQuotes(ppr cconv), space,
 203                target fn, parens  ( commafy $ map ppr args ),
 204                semi ]
 205         where
 206             target t@(CmmLit _) = ppr t
 207             target fn'          = parens (ppr fn')
 208
 209     MidUnsafeCall (CmmPrim op) results args ->
 210         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
 211         where
 212           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 213   ) <>
 214   if debugPpr then empty
 215   else text " //" <+>
 216        case stmt of
 217          MidNop {}     -> text "MidNop"
 218          CopyIn {}     -> text "CopyIn"
 219          CopyOut {}    -> text "CopyOut"
 220          MidComment {} -> text "MidComment"
 221          MidAssign {}  -> text "MidAssign"
 222          MidStore {}   -> text "MidStore"
 223          MidUnsafeCall {} -> text "MidUnsafeCall"
 224
 225
 226 pprHinted :: Outputable a => (a, MachHint) -> SDoc
 227 pprHinted (a, NoHint)     = ppr a
 228 pprHinted (a, PtrHint)    = doubleQuotes (text "address") <+> ppr a
 229 pprHinted (a, SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 230 pprHinted (a, FloatHint)  = doubleQuotes (text "float")   <+> ppr a
 231
 232 pprLast :: Last -> SDoc
 233 pprLast stmt = (case stmt of
 234     LastBranch ident args     -> genBranchWithArgs ident args
 235     LastCondBranch expr t f   -> genFullCondBranch expr t f
 236     LastJump expr params      -> ppr $ CmmJump expr params
 237     LastReturn results        -> hcat [ ptext SLIT("return"), space
 238                                       , parens ( commafy $ map pprHinted results )
 239                                       , semi ]
 240     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
 241     LastCall tgt params k     -> genCall tgt params k
 242   ) <>
 243   if debugPpr then empty
 244   else text " //" <+>
 245        case stmt of
 246          LastBranch {} -> text "LastBranch"
 247          LastCondBranch {} -> text "LastCondBranch"
 248          LastJump {} -> text "LastJump"
 249          LastReturn {} -> text "LastReturn"
 250          LastSwitch {} -> text "LastSwitch"
 251          LastCall {} -> text "LastCall"
 252
 253 genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
 254 genCall (CmmCallee fn cconv) args k =
 255         hcat [ ptext SLIT("foreign"), space
 256              , doubleQuotes(ppr cconv), space
 257              , target fn, parens  ( commafy $ map pprHinted args ), space
 258              , case k of Nothing -> ptext SLIT("never returns")
 259                          Just k -> ptext SLIT("returns to") <+> ppr k
 260              , semi ]
 261         where
 262             target t@(CmmLit _) = ppr t
 263             target fn'          = parens (ppr fn')
 264
 265 genCall (CmmPrim op) args k =
 266     hcat [ text "%", text (show op), parens  ( commafy $ map pprHinted args ),
 267            ptext SLIT("returns to"), space, ppr k,
 268            semi ]
 269
 270 genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc
 271 genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi
 272 genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+>
 273                                parens (commafy (map ppr args)) <> semi
 274
 275 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 276 genFullCondBranch expr t f =
 277     hsep [ ptext SLIT("if")
 278          , parens(ppr expr)
 279          , ptext SLIT("goto")
 280          , ppr t <> semi
 281          , ptext SLIT("else goto")
 282          , ppr f <> semi
 283          ]
 284
 285 pprConvention :: Convention -> SDoc
 286 pprConvention (Argument c) = ppr c
 287 pprConvention (Result c) = ppr c
 288 pprConvention Local = text "<local>"
 289
 290 commafy :: [SDoc] -> SDoc
 291 commafy xs = hsep $ punctuate comma xs