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 ZipDataflow0 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
 186 ----------------------------------------------------------------------
 187 ----- Instance declarations for prettyprinting (avoids recursive imports)
 188
 189 instance Outputable Middle where
 190     ppr s = pprMiddle s
 191
 192 instance Outputable Last where
 193     ppr s = pprLast s
 194
 195 instance Outputable Convention where
 196     ppr = pprConvention
 197
 198 instance DF.DebugNodes Middle Last
 199
 200 instance Outputable CmmGraph where
 201     ppr = pprLgraph
 202
 203 debugPpr :: Bool
 204 debugPpr = debugIsOn
 205
 206 pprMiddle :: Middle -> SDoc
 207 pprMiddle stmt = (case stmt of
 208
 209     CopyIn conv args _ ->
 210         if null args then ptext SLIT("empty CopyIn")
 211         else commafy (map pprHinted args) <+> equals <+>
 212              ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
 213
 214     CopyOut conv args ->
 215         ptext SLIT("next, pass") <+> doubleQuotes(ppr conv) <+>
 216         parens (commafy (map pprHinted args))
 217
 218     --  // text
 219     MidComment s -> text "//" <+> ftext s
 220
 221     -- reg = expr;
 222     MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 223
 224     -- rep[lv] = expr;
 225     MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 226         where
 227           rep = ppr ( cmmExprRep expr )
 228
 229     -- call "ccall" foo(x, y)[r1, r2];
 230     -- ToDo ppr volatile
 231     MidUnsafeCall (CmmCallee fn cconv) results args ->
 232         hcat [ if null results
 233                   then empty
 234                   else parens (commafy $ map ppr results) <>
 235                        ptext SLIT(" = "),
 236                ptext SLIT("call"), space,
 237                doubleQuotes(ppr cconv), space,
 238                ppr_target fn, parens  ( commafy $ map ppr args ),
 239                semi ]
 240
 241     MidUnsafeCall (CmmPrim op) results args ->
 242         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
 243         where
 244           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 245
 246     MidAddToContext ra args ->
 247         hcat [ ptext SLIT("return via ")
 248              , ppr_target ra, parens (commafy $ map ppr args), semi ]
 249
 250   ) <>
 251   if debugPpr then empty
 252   else text " //" <+>
 253        case stmt of
 254          CopyIn {}     -> text "CopyIn"
 255          CopyOut {}    -> text "CopyOut"
 256          MidComment {} -> text "MidComment"
 257          MidAssign {}  -> text "MidAssign"
 258          MidStore {}   -> text "MidStore"
 259          MidUnsafeCall  {} -> text "MidUnsafeCall"
 260          MidAddToContext {} -> text "MidAddToContext"
 261
 262
 263 ppr_target :: CmmExpr -> SDoc
 264 ppr_target t@(CmmLit _) = ppr t
 265 ppr_target fn'          = parens (ppr fn')
 266
 267
 268 pprHinted :: Outputable a => (a, MachHint) -> SDoc
 269 pprHinted (a, NoHint)     = ppr a
 270 pprHinted (a, PtrHint)    = doubleQuotes (text "address") <+> ppr a
 271 pprHinted (a, SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 272 pprHinted (a, FloatHint)  = doubleQuotes (text "float")   <+> ppr a
 273
 274 pprLast :: Last -> SDoc
 275 pprLast stmt = (case stmt of
 276     LastBranch ident          -> ptext SLIT("goto") <+> ppr ident <> semi
 277     LastCondBranch expr t f   -> genFullCondBranch expr t f
 278     LastJump expr             -> hcat [ ptext SLIT("jump"), space, pprFun expr
 279                                       , ptext SLIT("(...)"), semi]
 280     LastReturn                -> hcat [ ptext SLIT("return"), space
 281                                       , ptext SLIT("(...)"), semi]
 282     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
 283     LastCall tgt k            -> genBareCall tgt k
 284   ) <>
 285   if debugPpr then empty
 286   else text " //" <+>
 287        case stmt of
 288          LastBranch {} -> text "LastBranch"
 289          LastCondBranch {} -> text "LastCondBranch"
 290          LastJump {} -> text "LastJump"
 291          LastReturn {} -> text "LastReturn"
 292          LastSwitch {} -> text "LastSwitch"
 293          LastCall {} -> text "LastCall"
 294
 295 genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
 296 genBareCall fn k =
 297         hcat [ ptext SLIT("call"), space
 298              , pprFun fn, ptext SLIT("(...)"), space
 299              , case k of Nothing -> ptext SLIT("never returns")
 300                          Just k -> ptext SLIT("returns to") <+> ppr k
 301              , semi ]
 302         where
 303
 304 pprFun :: CmmExpr -> SDoc
 305 pprFun f@(CmmLit _) = ppr f
 306 pprFun f = parens (ppr f)
 307
 308 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 309 genFullCondBranch expr t f =
 310     hsep [ ptext SLIT("if")
 311          , parens(ppr expr)
 312          , ptext SLIT("goto")
 313          , ppr t <> semi
 314          , ptext SLIT("else goto")
 315          , ppr f <> semi
 316          ]
 317
 318 pprConvention :: Convention -> SDoc
 319 pprConvention (ConventionStandard c _) = ppr c
 320 pprConvention (ConventionPrivate {}  ) = text "<private-convention>"
 321
 322 commafy :: [SDoc] -> SDoc
 323 commafy xs = hsep $ punctuate comma xs