compiler/cmm/ZipCfgCmmRep.hs

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