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