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