compiler/cmm/ZipCfgCmmRep.hs

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