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 = pprLgraph
 161
 162 pprMiddle :: Middle -> SDoc
 163 pprMiddle stmt = (case stmt of
 164
 165     MidNop -> semi
 166
 167     CopyIn conv args _ ->
 168         if null args then ptext SLIT("empty CopyIn")
 169         else commafy (map pprHinted args) <+> equals <+>
 170              ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
 171
 172     CopyOut conv args ->
 173         if null args then PP.empty
 174         else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
 175              parens (commafy (map pprHinted args))
 176
 177     --  // text
 178     MidComment s -> text "//" <+> ftext s
 179
 180     -- reg = expr;
 181     MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 182
 183     -- rep[lv] = expr;
 184     MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 185         where
 186           rep = ppr ( cmmExprRep expr )
 187
 188     -- call "ccall" foo(x, y)[r1, r2];
 189     -- ToDo ppr volatile
 190     MidUnsafeCall (CmmCallee fn cconv) results args ->
 191         hcat [ if null results
 192                   then PP.empty
 193                   else parens (commafy $ map ppr results) <>
 194                        ptext SLIT(" = "),
 195                ptext SLIT("call"), space,
 196                doubleQuotes(ppr cconv), space,
 197                target fn, parens  ( commafy $ map ppr args ),
 198                semi ]
 199         where
 200             target t@(CmmLit _) = ppr t
 201             target fn'          = parens (ppr fn')
 202
 203     MidUnsafeCall (CmmPrim op) results args ->
 204         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
 205         where
 206           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 207   ) <+> text "//" <+>
 208   case stmt of
 209     MidNop {} -> text "MidNop"
 210     CopyIn {} -> text "CopyIn"
 211     CopyOut {} -> text "CopyOut"
 212     MidComment {} -> text "MidComment"
 213     MidAssign {} -> text "MidAssign"
 214     MidStore {} -> text "MidStore"
 215     MidUnsafeCall {} -> text "MidUnsafeCall"
 216
 217
 218 pprHinted :: Outputable a => (a, MachHint) -> SDoc
 219 pprHinted (a, NoHint)     = ppr a
 220 pprHinted (a, PtrHint)    = doubleQuotes (text "address") <+> ppr a
 221 pprHinted (a, SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 222 pprHinted (a, FloatHint)  = doubleQuotes (text "float")   <+> ppr a
 223
 224 pprLast :: Last -> SDoc
 225 pprLast stmt = (case stmt of
 226     LastBranch ident args     -> genBranchWithArgs ident args
 227     LastCondBranch expr t f   -> genFullCondBranch expr t f
 228     LastJump expr params      -> ppr $ CmmJump expr params
 229     LastReturn results        -> hcat [ ptext SLIT("return"), space
 230                                       , parens ( commafy $ map pprHinted results )
 231                                       , semi ]
 232     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
 233     LastCall tgt params k     -> genCall tgt params k
 234   ) <+> text "//" <+>
 235   case stmt of
 236     LastBranch {} -> text "LastBranch"
 237     LastCondBranch {} -> text "LastCondBranch"
 238     LastJump {} -> text "LastJump"
 239     LastReturn {} -> text "LastReturn"
 240     LastSwitch {} -> text "LastSwitch"
 241     LastCall {} -> text "LastCall"
 242
 243
 244 genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
 245 genCall (CmmCallee fn cconv) args k =
 246         hcat [ ptext SLIT("foreign"), space
 247              , doubleQuotes(ppr cconv), space
 248              , target fn, parens  ( commafy $ map pprHinted args ), space
 249              , case k of Nothing -> ptext SLIT("never returns")
 250                          Just k -> ptext SLIT("returns to") <+> ppr k
 251              , semi ]
 252         where
 253             target t@(CmmLit _) = ppr t
 254             target fn'          = parens (ppr fn')
 255
 256 genCall (CmmPrim op) args k =
 257     hcat [ text "%", text (show op), parens  ( commafy $ map pprHinted args ),
 258            ptext SLIT("returns to"), space, ppr k,
 259            semi ]
 260
 261 genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc
 262 genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi
 263 genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+>
 264                                parens (commafy (map ppr args)) <> semi
 265
 266 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 267 genFullCondBranch expr t f =
 268     hsep [ ptext SLIT("if")
 269          , parens(ppr expr)
 270          , ptext SLIT("goto")
 271          , ppr t <> semi
 272          , ptext SLIT("else goto")
 273          , ppr f <> semi
 274          ]
 275
 276 pprConvention :: Convention -> SDoc
 277 pprConvention (Argument c) = ppr c
 278 pprConvention (Result c) = ppr c
 279 pprConvention Local = text "<local>"
 280
 281 commafy :: [SDoc] -> SDoc
 282 commafy xs = hsep $ punctuate comma xs