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 pprMiddle :: Middle -> SDoc
 211 pprMiddle stmt = case stmt of
 212
 213     MidNop -> semi
 214
 215     CopyIn conv args _ ->
 216         if null args then ptext SLIT("empty CopyIn")
 217         else commafy (map pprHinted args) <+> equals <+>
 218              ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
 219
 220     CopyOut conv args ->
 221         if null args then PP.empty
 222         else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
 223              parens (commafy (map pprHinted args))
 224
 225     --  // text
 226     MidComment s -> text "//" <+> ftext s
 227
 228     -- reg = expr;
 229     MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 230
 231     -- rep[lv] = expr;
 232     MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 233         where
 234           rep = ppr ( cmmExprRep expr )
 235
 236     -- call "ccall" foo(x, y)[r1, r2];
 237     -- ToDo ppr volatile
 238     MidUnsafeCall (CmmCallee fn cconv) results args ->
 239         hcat [ if null results
 240                   then PP.empty
 241                   else parens (commafy $ map ppr results) <>
 242                        ptext SLIT(" = "),
 243                ptext SLIT("call"), space,
 244                doubleQuotes(ppr cconv), space,
 245                target fn, parens  ( commafy $ map ppr args ),
 246                semi ]
 247         where
 248             target t@(CmmLit _) = ppr t
 249             target fn'          = parens (ppr fn')
 250
 251     MidUnsafeCall (CmmPrim op) results args ->
 252         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
 253         where
 254           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 255
 256
 257 pprHinted :: Outputable a => (a, MachHint) -> SDoc
 258 pprHinted (a, NoHint)     = ppr a
 259 pprHinted (a, PtrHint)    = doubleQuotes (text "address") <+> ppr a
 260 pprHinted (a, SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 261 pprHinted (a, FloatHint)  = doubleQuotes (text "float")   <+> ppr a
 262
 263     LastBranch ident args     -> genBranchWithArgs ident args
 264     LastCondBranch expr t f   -> genFullCondBranch expr t f
 265     LastJump expr params      -> ppr $ CmmJump expr params
 266     LastReturn params         -> ppr $ CmmReturn params
 267     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
 268     LastCall tgt params k     -> genCall tgt params k
 269
 270 genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
 271 genCall (CmmCallee fn cconv) args k =
 272         hcat [ ptext SLIT("foreign"), space
 273              , doubleQuotes(ppr cconv), space
 274              , target fn, parens  ( commafy $ map pprHinted args ), space
 275              , case k of Nothing -> ptext SLIT("never returns")
 276                          Just k -> ptext SLIT("returns to") <+> ppr k
 277              , semi ]
 278         where
 279             target t@(CmmLit _) = ppr t
 280             target fn'          = parens (ppr fn')
 281
 282 genCall (CmmPrim op) args k =
 283     hcat [ text "%", text (show op), parens  ( commafy $ map pprHinted args ),
 284            ptext SLIT("returns to"), space, ppr k,
 285            semi ]
 286
 287 genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc
 288 genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi
 289 genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+>
 290                                parens (commafy (map ppr args)) <> semi
 291
 292 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 293 genFullCondBranch expr t f =
 294     hsep [ ptext SLIT("if")
 295          , parens(ppr expr)
 296          , ptext SLIT("goto")
 297          , ppr t <> semi
 298          , ptext SLIT("else goto")
 299          , ppr f <> semi
 300          ]
 301
 302 pprConvention :: Convention -> SDoc
 303 pprConvention (Argument c) = ppr c
 304 pprConvention (Result c) = ppr c
 305 pprConvention Local = text "<local>"
 306
 307 commafy :: [SDoc] -> SDoc
 308 commafy xs = hsep $ punctuate comma xs