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   | MidAddToContext              -- push a frame on the stack;
  59                                  -- I will return to this frame
  60      CmmExpr                     -- The frame's return address; it must be
  61                                  -- preceded by an info table that describes the
  62                                  -- live variables.
  63      [CmmExpr]                   -- The frame's live variables, to go on the
  64                                  -- stack with the first one at the young end
  65
  66   | CopyIn    -- Move incoming parameters or results from conventional
  67               -- locations to registers.  Note [CopyIn invariant]
  68         Convention
  69         CmmFormals      -- eventually [CmmKind] will be used only for foreign
  70                         -- calls and will migrate into 'Convention' (helping to
  71                         -- drain "the swamp"), leaving this as [LocalReg]
  72         C_SRT           -- Static things kept alive by this block
  73
  74   | CopyOut Convention CmmActuals
  75               -- Move outgoing parameters or results from registers to
  76               -- conventional locations.  Every 'LastReturn',
  77               -- 'LastJump', or 'LastCall' must be dominated by a
  78               -- matching 'CopyOut' in the same basic block.
  79               -- As above, '[CmmKind]' will migrate into the foreign calling
  80               -- convention, leaving the actuals as '[CmmExpr]'.
  81
  82 data Last
  83   = LastBranch BlockId  -- Goto another block in the same procedure
  84
  85   | LastCondBranch {            -- conditional branch
  86         cml_pred :: CmmExpr,
  87         cml_true, cml_false :: BlockId
  88     }
  89
  90   | LastReturn          -- Return from a function; values in a previous CopyOut node
  91
  92   | LastJump CmmExpr    -- Tail call to another procedure; args in a CopyOut node
  93
  94   | LastCall {                   -- A call (native or safe foreign); args in CopyOut node
  95         cml_target :: CmmExpr,   -- never a CmmPrim to a CallishMachOp!
  96         cml_cont   :: Maybe BlockId }  -- BlockId of continuation, if call returns
  97
  98   | LastSwitch CmmExpr [Maybe BlockId]   -- Table branch
  99         -- The scrutinee is zero-based;
 100         --      zero -> first block
 101         --      one  -> second block etc
 102         -- Undefined outside range, and when there's a Nothing
 103
 104 data Convention
 105   = ConventionStandard CCallConv ValueDirection
 106   | ConventionPrivate
 107                 -- Used for control transfers within a (pre-CPS) procedure All
 108                 -- jump sites known, never pushed on the stack (hence no SRT)
 109                 -- You can choose whatever calling convention you please
 110                 -- (provided you make sure all the call sites agree)!
 111                 -- This data type eventually to be extended to record the convention.
 112
 113   deriving Eq
 114
 115 data ValueDirection = Arguments | Results
 116   -- Arguments go with procedure definitions, jumps, and arguments to calls
 117   -- Results go with returns and with results of calls.
 118   deriving Eq
 119
 120 {-
 121 Note [CopyIn invariant]
 122 ~~~~~~~~~~~~~~~~~~~~~~~
 123 One might wish for CopyIn to be a First node, but in practice, the
 124 possibility raises all sorts of hairy issues with graph splicing,
 125 rewriting, and so on.  In the end, NR finds it better to make the
 126 placement of CopyIn a dynamic invariant; it should normally be the first
 127 Middle node in the basic block in which it occurs.
 128 -}
 129
 130 ----------------------------------------------------------------------
 131 ----- Instance declarations for control flow
 132
 133 instance HavingSuccessors Last where
 134     succs = cmmSuccs
 135     fold_succs = fold_cmm_succs
 136
 137 instance LastNode Last where
 138     mkBranchNode id = LastBranch id
 139     isBranchNode (LastBranch _) = True
 140     isBranchNode _ = False
 141     branchNodeTarget (LastBranch id) = id
 142     branchNodeTarget _ = panic "asked for target of non-branch"
 143
 144 cmmSuccs :: Last -> [BlockId]
 145 cmmSuccs (LastReturn {})        = []
 146 cmmSuccs (LastJump {})          = []
 147 cmmSuccs (LastBranch id)        = [id]
 148 cmmSuccs (LastCall _ (Just id)) = [id]
 149 cmmSuccs (LastCall _ Nothing)   = []
 150 cmmSuccs (LastCondBranch _ t f) = [f, t]  -- meets layout constraint
 151 cmmSuccs (LastSwitch _ edges)   = catMaybes edges
 152
 153 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
 154 fold_cmm_succs _f (LastReturn {})          z = z
 155 fold_cmm_succs _f (LastJump {})            z = z
 156 fold_cmm_succs  f (LastBranch id)          z = f id z
 157 fold_cmm_succs  f (LastCall _ (Just id))   z = f id z
 158 fold_cmm_succs _f (LastCall _ Nothing)     z = z
 159 fold_cmm_succs  f (LastCondBranch _ te fe) z = f te (f fe z)
 160 fold_cmm_succs  f (LastSwitch _ edges)     z = foldl (flip f) z $ catMaybes edges
 161
 162 ----------------------------------------------------------------------
 163 ----- Instance declarations for register use
 164
 165 instance UserOfLocalRegs Middle where
 166     foldRegsUsed f z m = middle m
 167       where middle (MidComment {})                = z
 168             middle (MidAssign _lhs expr)          = fold f z expr
 169             middle (MidStore addr rval)           = fold f (fold f z addr) rval
 170             middle (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args
 171             middle (MidAddToContext ra args)      = fold f (fold f z ra) args
 172             middle (CopyIn _ _formals _)          = z
 173             middle (CopyOut _ actuals)            = fold f z actuals
 174             fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
 175
 176 instance UserOfLocalRegs Last where
 177     foldRegsUsed f z m = last m
 178       where last (LastReturn)           = z
 179             last (LastJump e)           = foldRegsUsed f z e
 180             last (LastBranch _id)       = z
 181             last (LastCall tgt _)       = foldRegsUsed f z tgt
 182             last (LastCondBranch e _ _) = foldRegsUsed f z e
 183             last (LastSwitch e _tbl)    = foldRegsUsed f z e
 184
 185 instance UserOfLocalRegs (ZLast Last) where
 186     foldRegsUsed  f z (LastOther l) = foldRegsUsed f z l
 187     foldRegsUsed _f z LastExit      = z
 188
 189
 190 ----------------------------------------------------------------------
 191 ----- Instance declarations for prettyprinting (avoids recursive imports)
 192
 193 instance Outputable Middle where
 194     ppr s = pprMiddle s
 195
 196 instance Outputable Last where
 197     ppr s = pprLast s
 198
 199 instance Outputable Convention where
 200     ppr = pprConvention
 201
 202 instance DF.DebugNodes Middle Last
 203
 204 instance Outputable CmmGraph where
 205     ppr = pprLgraph
 206
 207 debugPpr :: Bool
 208 debugPpr = debugIsOn
 209
 210 pprMiddle :: Middle -> SDoc
 211 pprMiddle stmt = (case stmt of
 212
 213     CopyIn conv args _ ->
 214         if null args then ptext SLIT("empty CopyIn")
 215         else commafy (map pprHinted args) <+> equals <+>
 216              ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
 217
 218     CopyOut conv args ->
 219         ptext SLIT("next, pass") <+> doubleQuotes(ppr conv) <+>
 220         parens (commafy (map pprHinted args))
 221
 222     --  // text
 223     MidComment s -> text "//" <+> ftext s
 224
 225     -- reg = expr;
 226     MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 227
 228     -- rep[lv] = expr;
 229     MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 230         where
 231           rep = ppr ( cmmExprRep expr )
 232
 233     -- call "ccall" foo(x, y)[r1, r2];
 234     -- ToDo ppr volatile
 235     MidUnsafeCall (CmmCallee fn cconv) results args ->
 236         hcat [ if null results
 237                   then empty
 238                   else parens (commafy $ map ppr results) <>
 239                        ptext SLIT(" = "),
 240                ptext SLIT("call"), space,
 241                doubleQuotes(ppr cconv), space,
 242                ppr_target fn, parens  ( commafy $ map ppr args ),
 243                semi ]
 244
 245     MidUnsafeCall (CmmPrim op) results args ->
 246         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
 247         where
 248           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 249
 250     MidAddToContext ra args ->
 251         hcat [ ptext SLIT("return via ")
 252              , ppr_target ra, parens (commafy $ map ppr args), semi ]
 253
 254   ) <>
 255   if debugPpr then empty
 256   else text " //" <+>
 257        case stmt of
 258          CopyIn {}     -> text "CopyIn"
 259          CopyOut {}    -> text "CopyOut"
 260          MidComment {} -> text "MidComment"
 261          MidAssign {}  -> text "MidAssign"
 262          MidStore {}   -> text "MidStore"
 263          MidUnsafeCall  {} -> text "MidUnsafeCall"
 264          MidAddToContext {} -> text "MidAddToContext"
 265
 266
 267 ppr_target :: CmmExpr -> SDoc
 268 ppr_target t@(CmmLit _) = ppr t
 269 ppr_target fn'          = parens (ppr fn')
 270
 271
 272 pprHinted :: Outputable a => (a, MachHint) -> SDoc
 273 pprHinted (a, NoHint)     = ppr a
 274 pprHinted (a, PtrHint)    = doubleQuotes (text "address") <+> ppr a
 275 pprHinted (a, SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 276 pprHinted (a, FloatHint)  = doubleQuotes (text "float")   <+> ppr a
 277
 278 pprLast :: Last -> SDoc
 279 pprLast stmt = (case stmt of
 280     LastBranch ident          -> ptext SLIT("goto") <+> ppr ident <> semi
 281     LastCondBranch expr t f   -> genFullCondBranch expr t f
 282     LastJump expr             -> hcat [ ptext SLIT("jump"), space, pprFun expr
 283                                       , ptext SLIT("(...)"), semi]
 284     LastReturn                -> hcat [ ptext SLIT("return"), space
 285                                       , ptext SLIT("(...)"), semi]
 286     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
 287     LastCall tgt k            -> genBareCall tgt k
 288   ) <>
 289   if debugPpr then empty
 290   else text " //" <+>
 291        case stmt of
 292          LastBranch {} -> text "LastBranch"
 293          LastCondBranch {} -> text "LastCondBranch"
 294          LastJump {} -> text "LastJump"
 295          LastReturn {} -> text "LastReturn"
 296          LastSwitch {} -> text "LastSwitch"
 297          LastCall {} -> text "LastCall"
 298
 299 genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
 300 genBareCall fn k =
 301         hcat [ ptext SLIT("call"), space
 302              , pprFun fn, ptext SLIT("(...)"), space
 303              , case k of Nothing -> ptext SLIT("never returns")
 304                          Just k -> ptext SLIT("returns to") <+> ppr k
 305              , semi ]
 306         where
 307
 308 pprFun :: CmmExpr -> SDoc
 309 pprFun f@(CmmLit _) = ppr f
 310 pprFun f = parens (ppr f)
 311
 312 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 313 genFullCondBranch expr t f =
 314     hsep [ ptext SLIT("if")
 315          , parens(ppr expr)
 316          , ptext SLIT("goto")
 317          , ppr t <> semi
 318          , ptext SLIT("else goto")
 319          , ppr f <> semi
 320          ]
 321
 322 pprConvention :: Convention -> SDoc
 323 pprConvention (ConventionStandard c _) = ppr c
 324 pprConvention (ConventionPrivate {}  ) = text "<private-convention>"
 325
 326 commafy :: [SDoc] -> SDoc
 327 commafy xs = hsep $ punctuate comma xs