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