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 ----- Instance declarations for register use
 156
 157 instance UserOfLocalRegs Middle where
 158     foldRegsUsed f z m = middle m
 159       where middle (MidComment {})                = z
 160             middle (MidAssign _lhs expr)          = foldRegsUsed f z expr
 161             middle (MidStore addr rval)           = foldRegsUsed f (foldRegsUsed f z addr) rval
 162             middle (MidUnsafeCall tgt _ress args) = foldRegsUsed f (foldRegsUsed f z tgt) args
 163             middle (CopyIn _ _formals _)          = z
 164             middle (CopyOut _ actuals)            = foldRegsUsed f z actuals
 165 --            fold = foldRegsUsed
 166
 167 instance UserOfLocalRegs Last where
 168     foldRegsUsed f z m = last m
 169       where last (LastReturn)           = z
 170             last (LastJump e)           = foldRegsUsed f z e
 171             last (LastBranch _id)       = z
 172             last (LastCall tgt _)       = foldRegsUsed f z tgt
 173             last (LastCondBranch e _ _) = foldRegsUsed f z e
 174             last (LastSwitch e _tbl)    = foldRegsUsed f z e
 175
 176 instance UserOfLocalRegs (ZLast Last) where
 177     foldRegsUsed  f z (LastOther l) = foldRegsUsed f z l
 178     foldRegsUsed _f z LastExit      = z
 179
 180
 181 ----------------------------------------------------------------------
 182 ----- Instance declarations for prettyprinting (avoids recursive imports)
 183
 184 instance Outputable Middle where
 185     ppr s = pprMiddle s
 186
 187 instance Outputable Last where
 188     ppr s = pprLast s
 189
 190 instance Outputable Convention where
 191     ppr = pprConvention
 192
 193 instance DF.DebugNodes Middle Last
 194
 195 instance Outputable CmmGraph where
 196     ppr = pprLgraph
 197
 198 debugPpr :: Bool
 199 debugPpr = debugIsOn
 200
 201 pprMiddle :: Middle -> SDoc
 202 pprMiddle stmt = (case stmt of
 203
 204     CopyIn conv args _ ->
 205         if null args then ptext SLIT("empty CopyIn")
 206         else commafy (map pprHinted args) <+> equals <+>
 207              ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
 208
 209     CopyOut conv args ->
 210         ptext SLIT("next, pass") <+> doubleQuotes(ppr conv) <+>
 211         parens (commafy (map pprHinted args))
 212
 213     --  // text
 214     MidComment s -> text "//" <+> ftext s
 215
 216     -- reg = expr;
 217     MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 218
 219     -- rep[lv] = expr;
 220     MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 221         where
 222           rep = ppr ( cmmExprRep expr )
 223
 224     -- call "ccall" foo(x, y)[r1, r2];
 225     -- ToDo ppr volatile
 226     MidUnsafeCall (CmmCallee fn cconv) results args ->
 227         hcat [ if null results
 228                   then empty
 229                   else parens (commafy $ map ppr results) <>
 230                        ptext SLIT(" = "),
 231                ptext SLIT("call"), space,
 232                doubleQuotes(ppr cconv), space,
 233                target fn, parens  ( commafy $ map ppr args ),
 234                semi ]
 235         where
 236             target t@(CmmLit _) = ppr t
 237             target fn'          = parens (ppr fn')
 238
 239     MidUnsafeCall (CmmPrim op) results args ->
 240         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
 241         where
 242           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 243   ) <>
 244   if debugPpr then empty
 245   else text " //" <+>
 246        case stmt of
 247          CopyIn {}     -> text "CopyIn"
 248          CopyOut {}    -> text "CopyOut"
 249          MidComment {} -> text "MidComment"
 250          MidAssign {}  -> text "MidAssign"
 251          MidStore {}   -> text "MidStore"
 252          MidUnsafeCall {} -> text "MidUnsafeCall"
 253
 254
 255 pprHinted :: Outputable a => (a, MachHint) -> SDoc
 256 pprHinted (a, NoHint)     = ppr a
 257 pprHinted (a, PtrHint)    = doubleQuotes (text "address") <+> ppr a
 258 pprHinted (a, SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 259 pprHinted (a, FloatHint)  = doubleQuotes (text "float")   <+> ppr a
 260
 261 pprLast :: Last -> SDoc
 262 pprLast stmt = (case stmt of
 263     LastBranch ident          -> ptext SLIT("goto") <+> ppr ident <> semi
 264     LastCondBranch expr t f   -> genFullCondBranch expr t f
 265     LastJump expr             -> hcat [ ptext SLIT("jump"), space, pprFun expr
 266                                       , ptext SLIT("(...)"), semi]
 267     LastReturn                -> hcat [ ptext SLIT("return"), space
 268                                       , ptext SLIT("(...)"), semi]
 269     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
 270     LastCall tgt k            -> genBareCall tgt k
 271   ) <>
 272   if debugPpr then empty
 273   else text " //" <+>
 274        case stmt of
 275          LastBranch {} -> text "LastBranch"
 276          LastCondBranch {} -> text "LastCondBranch"
 277          LastJump {} -> text "LastJump"
 278          LastReturn {} -> text "LastReturn"
 279          LastSwitch {} -> text "LastSwitch"
 280          LastCall {} -> text "LastCall"
 281
 282 genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
 283 genBareCall fn k =
 284         hcat [ ptext SLIT("call"), space
 285              , pprFun fn, ptext SLIT("(...)"), space
 286              , case k of Nothing -> ptext SLIT("never returns")
 287                          Just k -> ptext SLIT("returns to") <+> ppr k
 288              , semi ]
 289         where
 290
 291 pprFun :: CmmExpr -> SDoc
 292 pprFun f@(CmmLit _) = ppr f
 293 pprFun f = parens (ppr f)
 294
 295 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 296 genFullCondBranch expr t f =
 297     hsep [ ptext SLIT("if")
 298          , parens(ppr expr)
 299          , ptext SLIT("goto")
 300          , ppr t <> semi
 301          , ptext SLIT("else goto")
 302          , ppr f <> semi
 303          ]
 304
 305 pprConvention :: Convention -> SDoc
 306 pprConvention (ConventionStandard c _) = ppr c
 307 pprConvention (ConventionPrivate {}  ) = text "<private-convention>"
 308
 309 commafy :: [SDoc] -> SDoc
 310 commafy xs = hsep $ punctuate comma xs