compiler/cmm/ZipCfgCmm.hs

   1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
   2 module ZipCfgCmm
   3   ( mkNop, mkAssign, mkStore, mkCall, mkUnsafeCall, mkFinalCall
   4          , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse
   5          , mkCmmWhileDo
   6   , mkCopyIn, mkCopyOut
   7   , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
   8   )
   9 where
  10
  11 #include "HsVersions.h"
  12
  13 import CmmExpr
  14 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
  15            , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
  16            , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
  17            )
  18 import PprCmm()
  19
  20 import CLabel
  21 import ClosureInfo
  22 import FastString
  23 import ForeignCall
  24 import MachOp
  25 import qualified ZipDataflow as DF
  26 import ZipCfg
  27 import MkZipCfg
  28
  29 import Maybes
  30 import Outputable hiding (empty)
  31 import qualified Outputable as PP
  32 import Prelude hiding (zip, unzip, last)
  33
  34 type CmmGraph  = LGraph Middle Last
  35 type CmmAGraph = AGraph Middle Last
  36 type CmmBlock  = Block  Middle Last
  37 type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
  38 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
  39
  40 mkNop        :: CmmAGraph
  41 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
  42 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
  43 mkCall       :: CmmCallTarget -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
  44 mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
  45 mkFinalCall  :: CmmCallTarget -> CmmActuals -> CmmAGraph -- never returns
  46 mkJump       :: CmmExpr -> CmmActuals -> CmmAGraph
  47 mkCbranch    :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
  48 mkSwitch     :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
  49 mkReturn     :: CmmActuals -> CmmAGraph
  50 mkComment    :: FastString -> CmmAGraph
  51
  52 -- Not to be forgotten, but exported by MkZipCfg:
  53 --mkBranch      :: BlockId -> CmmAGraph
  54 --mkLabel       :: BlockId -> CmmAGraph
  55 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
  56 mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
  57
  58 --------------------------------------------------------------------------
  59
  60 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
  61 mkCmmWhileDo    e = mkWhileDo    (mkCbranch e)
  62
  63 mkCopyIn     :: Convention -> CmmFormals -> C_SRT -> CmmAGraph
  64 mkCopyOut    :: Convention -> CmmFormals -> CmmAGraph
  65
  66   -- ^ XXX: Simon or Simon thinks maybe the hints are being abused and
  67   -- we should have CmmFormalsWithoutKinds here, but for now it is CmmFormals
  68   -- for consistency with the rest of the back end ---NR
  69
  70 mkComment fs = mkMiddle (MidComment fs)
  71
  72 data Middle
  73   = MidNop
  74   | MidComment FastString
  75
  76   | MidAssign CmmReg CmmExpr     -- Assign to register
  77
  78   | MidStore CmmExpr CmmExpr     -- Assign to memory location.  Size is
  79                                  -- given by cmmExprRep of the rhs.
  80
  81   | MidUnsafeCall                -- An "unsafe" foreign call;
  82      CmmCallTarget               -- just a fat machine instructoin
  83      CmmFormals              -- zero or more results
  84      CmmActuals                  -- zero or more arguments
  85
  86   | CopyIn    -- Move parameters or results from conventional locations to registers
  87               -- Note [CopyIn invariant]
  88         Convention
  89         CmmFormals
  90         C_SRT           -- Static things kept alive by this block
  91   | CopyOut Convention CmmFormals
  92
  93 data Last
  94   = LastReturn CmmActuals          -- Return from a function,
  95                                   -- with these return values.
  96
  97   | LastJump   CmmExpr CmmActuals
  98         -- Tail call to another procedure
  99
 100   | LastBranch BlockId CmmFormalsWithoutKinds
 101         -- To another block in the same procedure
 102         -- The parameters are unused at present.
 103
 104   | LastCall {                   -- A call (native or safe foreign)
 105         cml_target :: CmmCallTarget,
 106         cml_actual :: CmmActuals,        -- Zero or more arguments
 107         cml_next   :: Maybe BlockId }  -- BlockId of continuation, if call returns
 108
 109   | LastCondBranch {            -- conditional branch
 110         cml_pred :: CmmExpr,
 111         cml_true, cml_false :: BlockId
 112     }
 113
 114   | LastSwitch CmmExpr [Maybe BlockId]   -- Table branch
 115         -- The scrutinee is zero-based;
 116         --      zero -> first block
 117         --      one  -> second block etc
 118         -- Undefined outside range, and when there's a Nothing
 119
 120 data Convention
 121   = Argument CCallConv  -- Used for function formal params
 122   | Result CCallConv    -- Used for function results
 123
 124   | Local       -- Used for control transfers within a (pre-CPS) procedure
 125                 -- All jump sites known, never pushed on the stack (hence no SRT)
 126                 -- You can choose whatever calling convention
 127                 -- you please (provided you make sure
 128                 -- all the call sites agree)!
 129   deriving Eq
 130
 131 -- ^ In a complete LGraph for a procedure, the [[Exit]] node should not
 132 -- appear, but it is useful in a subgraph (e.g., replacement for a node).
 133
 134 {-
 135 Note [CopyIn invariant]
 136 ~~~~~~~~~~~~~~~~~~~~~~~
 137 In principle, CopyIn ought to be a First node, but in practice, the
 138 possibility raises all sorts of hairy issues with graph splicing,
 139 rewriting, and so on.  In the end, NR finds it better to make the
 140 placement of CopyIn a dynamic invariant.  This change will complicate
 141 the dataflow fact for the proc-point calculation, but it should make
 142 things easier in many other respects.
 143 -}
 144
 145
 146 -- ================ IMPLEMENTATION ================--
 147
 148 mkNop                     = mkMiddle $ MidNop
 149 mkAssign l r              = mkMiddle $ MidAssign l r
 150 mkStore  l r              = mkMiddle $ MidStore  l r
 151 mkCopyIn  conv args srt   = mkMiddle $ CopyIn  conv args srt
 152 mkCopyOut conv args       = mkMiddle $ CopyOut conv args
 153
 154 mkJump e args             = mkLast   $ LastJump e args
 155 mkCbranch pred ifso ifnot = mkLast   $ LastCondBranch pred ifso ifnot
 156 mkReturn actuals          = mkLast   $ LastReturn actuals
 157 mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
 158
 159 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
 160 mkFinalCall  tgt actuals         = mkLast   $ LastCall      tgt actuals Nothing
 161
 162 mkCall tgt results actuals srt =
 163   withFreshLabel "call successor" $ \k ->
 164     mkLast (LastCall tgt actuals (Just k)) <*>
 165     mkLabel k <*>
 166     mkCopyIn (Result CmmCallConv) results srt
 167
 168 instance HavingSuccessors Last where
 169     succs = cmmSuccs
 170     fold_succs = fold_cmm_succs
 171
 172 instance LastNode Last where
 173     mkBranchNode id = LastBranch id []
 174     isBranchNode (LastBranch _ []) = True
 175     isBranchNode _ = False
 176     branchNodeTarget (LastBranch id []) = id
 177     branchNodeTarget _ = panic "asked for target of non-branch"
 178
 179 cmmSuccs :: Last -> [BlockId]
 180 cmmSuccs (LastReturn {})          = []
 181 cmmSuccs (LastJump {})            = []
 182 cmmSuccs (LastBranch id _)        = [id]
 183 cmmSuccs (LastCall _ _ (Just id)) = [id]
 184 cmmSuccs (LastCall _ _ Nothing)   = []
 185 cmmSuccs (LastCondBranch _ t f)   = [f, t]  -- meets layout constraint
 186 cmmSuccs (LastSwitch _ edges)     = catMaybes edges
 187
 188 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
 189 fold_cmm_succs _f (LastReturn {})          z = z
 190 fold_cmm_succs _f (LastJump {})            z = z
 191 fold_cmm_succs  f (LastBranch id _)        z = f id z
 192 fold_cmm_succs  f (LastCall _ _ (Just id)) z = f id z
 193 fold_cmm_succs _f (LastCall _ _ Nothing)   z = z
 194 fold_cmm_succs  f (LastCondBranch _ te fe) z = f te (f fe z)
 195 fold_cmm_succs  f (LastSwitch _ edges)     z = foldl (flip f) z $ catMaybes edges
 196
 197
 198 ----------------------------------------------------------------
 199 -- prettyprinting (avoids recursive imports)
 200
 201 instance Outputable Middle where
 202     ppr s = pprMiddle s
 203
 204 instance Outputable Last where
 205     ppr s = pprLast s
 206
 207 instance Outputable Convention where
 208     ppr = pprConvention
 209
 210 instance DF.DebugNodes Middle Last
 211
 212 instance Outputable CmmGraph where
 213     ppr = pprCmmGraphAsRep
 214
 215 pprCmmGraphAsRep :: CmmGraph -> SDoc
 216 pprCmmGraphAsRep g = vcat (map ppr_block blocks)
 217     where blocks = postorder_dfs g
 218           ppr_block (Block id tail) = hang (ppr id <> colon) 4 (ppr tail)
 219
 220 pprMiddle :: Middle -> SDoc
 221 pprMiddle stmt = (case stmt of
 222
 223     MidNop -> semi
 224
 225     CopyIn conv args _ ->
 226         if null args then ptext SLIT("empty CopyIn")
 227         else commafy (map pprHinted args) <+> equals <+>
 228              ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
 229
 230     CopyOut conv args ->
 231         if null args then PP.empty
 232         else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
 233              parens (commafy (map pprHinted args))
 234
 235     --  // text
 236     MidComment s -> text "//" <+> ftext s
 237
 238     -- reg = expr;
 239     MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 240
 241     -- rep[lv] = expr;
 242     MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 243         where
 244           rep = ppr ( cmmExprRep expr )
 245
 246     -- call "ccall" foo(x, y)[r1, r2];
 247     -- ToDo ppr volatile
 248     MidUnsafeCall (CmmCallee fn cconv) results args ->
 249         hcat [ if null results
 250                   then PP.empty
 251                   else parens (commafy $ map ppr results) <>
 252                        ptext SLIT(" = "),
 253                ptext SLIT("call"), space,
 254                doubleQuotes(ppr cconv), space,
 255                target fn, parens  ( commafy $ map ppr args ),
 256                semi ]
 257         where
 258             target t@(CmmLit _) = ppr t
 259             target fn'          = parens (ppr fn')
 260
 261     MidUnsafeCall (CmmPrim op) results args ->
 262         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
 263         where
 264           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 265   ) <+> text "//" <+>
 266   case stmt of
 267     MidNop {} -> text "MidNop"
 268     CopyIn {} -> text "CopyIn"
 269     CopyOut {} -> text "CopyOut"
 270     MidComment {} -> text "MidComment"
 271     MidAssign {} -> text "MidAssign"
 272     MidStore {} -> text "MidStore"
 273     MidUnsafeCall {} -> text "MidUnsafeCall"
 274
 275
 276 pprHinted :: Outputable a => (a, MachHint) -> SDoc
 277 pprHinted (a, NoHint)     = ppr a
 278 pprHinted (a, PtrHint)    = doubleQuotes (text "address") <+> ppr a
 279 pprHinted (a, SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 280 pprHinted (a, FloatHint)  = doubleQuotes (text "float")   <+> ppr a
 281
 282 pprLast :: Last -> SDoc
 283 pprLast stmt = (case stmt of
 284     LastBranch ident args     -> genBranchWithArgs ident args
 285     LastCondBranch expr t f   -> genFullCondBranch expr t f
 286     LastJump expr params      -> ppr $ CmmJump expr params
 287     LastReturn results        -> hcat [ ptext SLIT("return"), space
 288                                       , parens ( commafy $ map pprHinted results )
 289                                       , semi ]
 290     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
 291     LastCall tgt params k     -> genCall tgt params k
 292   ) <+> text "//" <+>
 293   case stmt of
 294     LastBranch {} -> text "LastBranch"
 295     LastCondBranch {} -> text "LastCondBranch"
 296     LastJump {} -> text "LastJump"
 297     LastReturn {} -> text "LastReturn"
 298     LastSwitch {} -> text "LastSwitch"
 299     LastCall {} -> text "LastCall"
 300
 301
 302 genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
 303 genCall (CmmCallee fn cconv) args k =
 304         hcat [ ptext SLIT("foreign"), space
 305              , doubleQuotes(ppr cconv), space
 306              , target fn, parens  ( commafy $ map pprHinted args ), space
 307              , case k of Nothing -> ptext SLIT("never returns")
 308                          Just k -> ptext SLIT("returns to") <+> ppr k
 309              , semi ]
 310         where
 311             target t@(CmmLit _) = ppr t
 312             target fn'          = parens (ppr fn')
 313
 314 genCall (CmmPrim op) args k =
 315     hcat [ text "%", text (show op), parens  ( commafy $ map pprHinted args ),
 316            ptext SLIT("returns to"), space, ppr k,
 317            semi ]
 318
 319 genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc
 320 genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi
 321 genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+>
 322                                parens (commafy (map ppr args)) <> semi
 323
 324 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 325 genFullCondBranch expr t f =
 326     hsep [ ptext SLIT("if")
 327          , parens(ppr expr)
 328          , ptext SLIT("goto")
 329          , ppr t <> semi
 330          , ptext SLIT("else goto")
 331          , ppr f <> semi
 332          ]
 333
 334 pprConvention :: Convention -> SDoc
 335 pprConvention (Argument c) = ppr c
 336 pprConvention (Result c) = ppr c
 337 pprConvention Local = text "<local>"
 338
 339 commafy :: [SDoc] -> SDoc
 340 commafy xs = hsep $ punctuate comma xs