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