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