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   , pprCmmGraphLikeCmm
  12   )
  13 where
  14
  15 import CmmExpr
  16 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
  17            , CmmCallTarget(..), CmmActuals, CmmFormals, CmmHinted(..)
  18            , CmmStmt(..) -- imported in order to call ppr on Switch and to
  19                          -- implement pprCmmGraphLikeCmm
  20            , CmmSafety(CmmSafe) -- for pprCmmGraphLikeCmm
  21            , CmmReturnInfo(CmmMayReturn) -- for pprCmmGraphLikeCmm
  22            )
  23 import PprCmm()
  24
  25 import CLabel
  26 import CmmZipUtil
  27 import ClosureInfo
  28 import FastString
  29 import ForeignCall
  30 import MachOp
  31 import qualified ZipCfg as Z
  32 import qualified ZipDataflow0 as DF
  33 import ZipCfg
  34 import MkZipCfg
  35 import Util
  36
  37 import UniqSet
  38 import Maybes
  39 import Outputable
  40 import Prelude hiding (zip, unzip, last)
  41
  42 ----------------------------------------------------------------------
  43 ----- Type synonyms and definitions
  44
  45 type CmmGraph  = LGraph Middle Last
  46 type CmmAGraph = AGraph Middle Last
  47 type CmmBlock  = Block  Middle Last
  48 type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
  49 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
  50
  51 data Middle
  52   = MidComment FastString
  53
  54   | MidAssign CmmReg CmmExpr     -- Assign to register
  55
  56   | MidStore CmmExpr CmmExpr     -- Assign to memory location.  Size is
  57                                  -- given by cmmExprRep of the rhs.
  58
  59   | MidUnsafeCall                -- An "unsafe" foreign call;
  60      CmmCallTarget               -- just a fat machine instructoin
  61      CmmFormals                  -- zero or more results
  62      CmmActuals                  -- zero or more arguments
  63
  64   | MidAddToContext              -- push a frame on the stack;
  65                                  -- I will return to this frame
  66      CmmExpr                     -- The frame's return address; it must be
  67                                  -- preceded by an info table that describes the
  68                                  -- live variables.
  69      [CmmExpr]                   -- The frame's live variables, to go on the
  70                                  -- stack with the first one at the young end
  71
  72   | CopyIn    -- Move incoming parameters or results from conventional
  73               -- locations to registers.  Note [CopyIn invariant]
  74         Convention
  75         CmmFormals      -- eventually [CmmKind] will be used only for foreign
  76                         -- calls and will migrate into 'Convention' (helping to
  77                         -- drain "the swamp"), leaving this as [LocalReg]
  78         C_SRT           -- Static things kept alive by this block
  79
  80   | CopyOut Convention CmmActuals
  81               -- Move outgoing parameters or results from registers to
  82               -- conventional locations.  Every 'LastReturn',
  83               -- 'LastJump', or 'LastCall' must be dominated by a
  84               -- matching 'CopyOut' in the same basic block.
  85               -- As above, '[CmmKind]' will migrate into the foreign calling
  86               -- convention, leaving the actuals as '[CmmExpr]'.
  87
  88 data Last
  89   = LastBranch BlockId  -- Goto another block in the same procedure
  90
  91   | LastCondBranch {            -- conditional branch
  92         cml_pred :: CmmExpr,
  93         cml_true, cml_false :: BlockId
  94     }
  95
  96   | LastReturn          -- Return from a function; values in a previous CopyOut node
  97
  98   | LastJump CmmExpr    -- Tail call to another procedure; args in a CopyOut node
  99
 100   | LastCall {                   -- A call (native or safe foreign); args in CopyOut node
 101         cml_target :: CmmExpr,   -- never a CmmPrim to a CallishMachOp!
 102         cml_cont   :: Maybe BlockId }  -- BlockId of continuation, if call returns
 103
 104   | LastSwitch CmmExpr [Maybe BlockId]   -- Table branch
 105         -- The scrutinee is zero-based;
 106         --      zero -> first block
 107         --      one  -> second block etc
 108         -- Undefined outside range, and when there's a Nothing
 109
 110 data Convention
 111   = ConventionStandard CCallConv ValueDirection
 112   | ConventionPrivate
 113                 -- Used for control transfers within a (pre-CPS) procedure All
 114                 -- jump sites known, never pushed on the stack (hence no SRT)
 115                 -- You can choose whatever calling convention you please
 116                 -- (provided you make sure all the call sites agree)!
 117                 -- This data type eventually to be extended to record the convention.
 118
 119   deriving Eq
 120
 121 data ValueDirection = Arguments | Results
 122   -- Arguments go with procedure definitions, jumps, and arguments to calls
 123   -- Results go with returns and with results of calls.
 124   deriving Eq
 125
 126 {-
 127 Note [CopyIn invariant]
 128 ~~~~~~~~~~~~~~~~~~~~~~~
 129 One might wish for CopyIn to be a First node, but in practice, the
 130 possibility raises all sorts of hairy issues with graph splicing,
 131 rewriting, and so on.  In the end, NR finds it better to make the
 132 placement of CopyIn a dynamic invariant; it should normally be the first
 133 Middle node in the basic block in which it occurs.
 134 -}
 135
 136 ----------------------------------------------------------------------
 137 ----- Instance declarations for control flow
 138
 139 instance HavingSuccessors Last where
 140     succs = cmmSuccs
 141     fold_succs = fold_cmm_succs
 142
 143 instance LastNode Last where
 144     mkBranchNode id = LastBranch id
 145     isBranchNode (LastBranch _) = True
 146     isBranchNode _ = False
 147     branchNodeTarget (LastBranch id) = id
 148     branchNodeTarget _ = panic "asked for target of non-branch"
 149
 150 cmmSuccs :: Last -> [BlockId]
 151 cmmSuccs (LastReturn {})        = []
 152 cmmSuccs (LastJump {})          = []
 153 cmmSuccs (LastBranch id)        = [id]
 154 cmmSuccs (LastCall _ (Just id)) = [id]
 155 cmmSuccs (LastCall _ Nothing)   = []
 156 cmmSuccs (LastCondBranch _ t f) = [f, t]  -- meets layout constraint
 157 cmmSuccs (LastSwitch _ edges)   = catMaybes edges
 158
 159 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
 160 fold_cmm_succs _f (LastReturn {})          z = z
 161 fold_cmm_succs _f (LastJump {})            z = z
 162 fold_cmm_succs  f (LastBranch id)          z = f id z
 163 fold_cmm_succs  f (LastCall _ (Just id))   z = f id z
 164 fold_cmm_succs _f (LastCall _ Nothing)     z = z
 165 fold_cmm_succs  f (LastCondBranch _ te fe) z = f te (f fe z)
 166 fold_cmm_succs  f (LastSwitch _ edges)     z = foldl (flip f) z $ catMaybes edges
 167
 168 ----------------------------------------------------------------------
 169 ----- Instance declarations for register use
 170
 171 instance UserOfLocalRegs Middle where
 172     foldRegsUsed f z m = middle m
 173       where middle (MidComment {})                = z
 174             middle (MidAssign _lhs expr)          = fold f z expr
 175             middle (MidStore addr rval)           = fold f (fold f z addr) rval
 176             middle (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args
 177             middle (MidAddToContext ra args)      = fold f (fold f z ra) args
 178             middle (CopyIn _ _formals _)          = z
 179             middle (CopyOut _ actuals)            = fold f z actuals
 180             fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
 181
 182 instance UserOfLocalRegs Last where
 183     foldRegsUsed f z m = last m
 184       where last (LastReturn)           = z
 185             last (LastJump e)           = foldRegsUsed f z e
 186             last (LastBranch _id)       = z
 187             last (LastCall tgt _)       = foldRegsUsed f z tgt
 188             last (LastCondBranch e _ _) = foldRegsUsed f z e
 189             last (LastSwitch e _tbl)    = foldRegsUsed f z e
 190
 191
 192 ----------------------------------------------------------------------
 193 ----- Instance declarations for prettyprinting (avoids recursive imports)
 194
 195 instance Outputable Middle where
 196     ppr s = pprMiddle s
 197
 198 instance Outputable Last where
 199     ppr s = pprLast s
 200
 201 instance Outputable Convention where
 202     ppr = pprConvention
 203
 204 instance DF.DebugNodes Middle Last
 205
 206 debugPpr :: Bool
 207 debugPpr = debugIsOn
 208
 209 pprMiddle :: Middle -> SDoc
 210 pprMiddle stmt = pp_stmt <+> pp_debug
 211  where
 212    pp_stmt = case stmt of
 213
 214     CopyIn conv args _ ->
 215         if null args then ptext (sLit "empty CopyIn")
 216         else commafy (map pprHinted args) <+> equals <+>
 217              ptext (sLit "foreign") <+> doubleQuotes(ppr conv) <+> ptext (sLit "...")
 218
 219     CopyOut conv args ->
 220         ptext (sLit "next, pass") <+> doubleQuotes(ppr conv) <+>
 221         parens (commafy (map pprHinted args))
 222
 223     --  // text
 224     MidComment s -> text "//" <+> ftext s
 225
 226     -- reg = expr;
 227     MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 228
 229     -- rep[lv] = expr;
 230     MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 231         where
 232           rep = ppr ( cmmExprRep expr )
 233
 234     -- call "ccall" foo(x, y)[r1, r2];
 235     -- ToDo ppr volatile
 236     MidUnsafeCall (CmmCallee fn cconv) results args ->
 237         hcat [ if null results
 238                   then empty
 239                   else parens (commafy $ map ppr results) <>
 240                        ptext (sLit " = "),
 241                ptext (sLit "call"), space,
 242                doubleQuotes(ppr cconv), space,
 243                ppr_target fn, parens  ( commafy $ map ppr args ),
 244                semi ]
 245
 246     MidUnsafeCall (CmmPrim op) results args ->
 247         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
 248         where
 249           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 250
 251     MidAddToContext ra args ->
 252         hcat [ ptext (sLit "return via ")
 253              , ppr_target ra, parens (commafy $ map ppr args), semi ]
 254
 255    pp_debug =
 256      if not debugPpr then empty
 257      else text " //" <+>
 258           case stmt of
 259             CopyIn {}     -> text "CopyIn"
 260             CopyOut {}    -> text "CopyOut"
 261             MidComment {} -> text "MidComment"
 262             MidAssign {}  -> text "MidAssign"
 263             MidStore {}   -> text "MidStore"
 264             MidUnsafeCall  {} -> text "MidUnsafeCall"
 265             MidAddToContext {} -> text "MidAddToContext"
 266
 267
 268 ppr_target :: CmmExpr -> SDoc
 269 ppr_target t@(CmmLit _) = ppr t
 270 ppr_target fn'          = parens (ppr fn')
 271
 272
 273 pprHinted :: Outputable a => CmmHinted a -> SDoc
 274 pprHinted (CmmHinted a NoHint)     = ppr a
 275 pprHinted (CmmHinted a PtrHint)    = doubleQuotes (text "address") <+> ppr a
 276 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 277 pprHinted (CmmHinted a FloatHint)  = doubleQuotes (text "float")   <+> ppr a
 278
 279 pprLast :: Last -> SDoc
 280 pprLast stmt = (case stmt of
 281     LastBranch ident          -> ptext (sLit "goto") <+> ppr ident <> semi
 282     LastCondBranch expr t f   -> genFullCondBranch expr t f
 283     LastJump expr             -> hcat [ ptext (sLit "jump"), space, pprFun expr
 284                                       , ptext (sLit "(...)"), semi]
 285     LastReturn                -> hcat [ ptext (sLit "return"), space
 286                                       , ptext (sLit "(...)"), semi]
 287     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
 288     LastCall tgt k            -> genBareCall tgt k
 289   ) <>
 290   if debugPpr then empty
 291   else text " //" <+>
 292        case stmt of
 293          LastBranch {} -> text "LastBranch"
 294          LastCondBranch {} -> text "LastCondBranch"
 295          LastJump {} -> text "LastJump"
 296          LastReturn {} -> text "LastReturn"
 297          LastSwitch {} -> text "LastSwitch"
 298          LastCall {} -> text "LastCall"
 299
 300 genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
 301 genBareCall fn k =
 302         hcat [ ptext (sLit "call"), space
 303              , pprFun fn, ptext (sLit "(...)"), space
 304              , case k of Nothing -> ptext (sLit "never returns")
 305                          Just k -> ptext (sLit "returns to") <+> ppr k
 306              , semi ]
 307         where
 308
 309 pprFun :: CmmExpr -> SDoc
 310 pprFun f@(CmmLit _) = ppr f
 311 pprFun f = parens (ppr f)
 312
 313 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 314 genFullCondBranch expr t f =
 315     hsep [ ptext (sLit "if")
 316          , parens(ppr expr)
 317          , ptext (sLit "goto")
 318          , ppr t <> semi
 319          , ptext (sLit "else goto")
 320          , ppr f <> semi
 321          ]
 322
 323 pprConvention :: Convention -> SDoc
 324 pprConvention (ConventionStandard c _) = ppr c
 325 pprConvention (ConventionPrivate {}  ) = text "<private-convention>"
 326
 327 commafy :: [SDoc] -> SDoc
 328 commafy xs = hsep $ punctuate comma xs
 329
 330
 331 ----------------------------------------------------------------
 332 -- | The purpose of this function is to print a Cmm zipper graph "as if it were"
 333 -- a Cmm program.  The objective is dodgy, so it's unsurprising parts of the
 334 -- code are dodgy as well.
 335
 336 pprCmmGraphLikeCmm :: CmmGraph -> SDoc
 337 pprCmmGraphLikeCmm g = vcat (swallow blocks)
 338     where blocks = Z.postorder_dfs g
 339           swallow :: [CmmBlock] -> [SDoc]
 340           swallow [] = []
 341           swallow (Z.Block id t : rest) = tail id [] Nothing t rest
 342           tail id prev' out (Z.ZTail (CopyOut conv args) t) rest =
 343               if isJust out then panic "multiple CopyOut nodes in one basic block"
 344               else
 345                   tail id (prev') (Just (conv, args)) t rest
 346           tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest
 347           tail id prev' out (Z.ZLast Z.LastExit)      rest = exit id prev' out rest
 348           tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest
 349           mid (CopyIn _ [] _) = text "// proc point (no parameters)"
 350           mid m@(CopyIn {}) = ppr m <+> text "(proc point)"
 351           mid m = ppr m
 352           block' id prev'
 353               | id == Z.lg_entry g, entry_has_no_pred =
 354                             vcat (text "<entry>" : reverse prev')
 355               | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
 356           last id prev' out l n =
 357               let endblock stmt = block' id (stmt : prev') : swallow n in
 358               case l of
 359                 LastBranch tgt ->
 360                     case n of
 361                       Z.Block id' t : bs
 362                           | tgt == id', unique_pred id'
 363                           -> tail id prev' out t bs  -- optimize out redundant labels
 364                       _ -> endblock (ppr $ CmmBranch tgt)
 365                 l@(LastCondBranch expr tid fid) ->
 366                   let ft id = text "// fall through to " <> ppr id in
 367                   case n of
 368                     Z.Block id' t : bs
 369                       | id' == fid, isNothing out ->
 370                           tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs
 371                       | id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
 372                           tail id (ft tid : ppr (CmmCondBranch e'   fid) : prev') Nothing t bs
 373                     _ -> endblock $ with_out out l
 374                 l@(LastJump   {}) -> endblock $ with_out out l
 375                 l@(LastReturn {}) -> endblock $ with_out out l
 376                 l@(LastSwitch {}) -> endblock $ with_out out l
 377                 l@(LastCall _ Nothing) -> endblock $ with_out out l
 378                 l@(LastCall tgt (Just k))
 379                    | Z.Block id' (Z.ZTail (CopyIn _ ress srt) t) : bs <- n,
 380                      Just (conv, args) <- out,
 381                      id' == k ->
 382                          let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
 383                              tgt' = CmmCallee tgt (cconv_of_conv conv)
 384                              ppcall = ppr call <+> parens (text "ret to" <+> ppr k)
 385                          in if unique_pred k then
 386                                 tail id (ppcall : prev') Nothing t bs
 387                             else
 388                                 endblock (ppcall)
 389                    | Z.Block id' t : bs <- n, id' == k, unique_pred k,
 390                      Just (conv, args) <- out,
 391                      Just (ress, srt) <- findCopyIn t ->
 392                          let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
 393                              tgt' = CmmCallee tgt (cconv_of_conv conv)
 394                              delayed =
 395                                  ptext (sLit "// delayed CopyIn follows previous call")
 396                          in  tail id (delayed : ppr call : prev') Nothing t bs
 397                    | otherwise -> endblock $ with_out out l
 398           findCopyIn (Z.ZTail (CopyIn _ ress srt) _) = Just (ress, srt)
 399           findCopyIn (Z.ZTail _ t) = findCopyIn t
 400           findCopyIn (Z.ZLast _) = Nothing
 401           exit id prev' out n = -- highly irregular (assertion violation?)
 402               let endblock stmt = block' id (stmt : prev') : swallow n in
 403               case out of Nothing -> endblock (text "// <exit>")
 404                           Just (conv, args) -> endblock (ppr (CopyOut conv args) $$
 405                                                          text "// <exit>")
 406           preds = zipPreds g
 407           entry_has_no_pred = case Z.lookupBlockEnv preds (Z.lg_entry g) of
 408                                 Nothing -> True
 409                                 Just s -> isEmptyUniqSet s
 410           single_preds =
 411               let add b single =
 412                     let id = Z.blockId b
 413                     in  case Z.lookupBlockEnv preds id of
 414                           Nothing -> single
 415                           Just s -> if sizeUniqSet s == 1 then
 416                                         Z.extendBlockSet single id
 417                                     else single
 418               in  Z.fold_blocks add Z.emptyBlockSet g
 419           unique_pred id = Z.elemBlockSet id single_preds
 420           cconv_of_conv (ConventionStandard conv _) = conv
 421           cconv_of_conv (ConventionPrivate {}) = CmmCallConv -- XXX totally bogus
 422
 423 with_out :: Maybe (Convention, CmmActuals) -> Last -> SDoc
 424 with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l
 425 with_out (Just (conv, args)) l = last l
 426     where last (LastCall e k) =
 427               hcat [ptext (sLit "... = foreign "),
 428                     doubleQuotes(ppr conv), space,
 429                     ppr_target e, parens ( commafy $ map ppr args ),
 430                     ptext (sLit " \"safe\""),
 431                     case k of Nothing -> ptext (sLit " never returns")
 432                               Just _ -> empty,
 433                     semi ]
 434           last (LastReturn) = ppr (CmmReturn args)
 435           last (LastJump e) = ppr (CmmJump e args)
 436           last l = ppr (CopyOut conv args) $$ ppr l
 437           ppr_target (CmmLit lit) = ppr lit
 438           ppr_target fn'          = parens (ppr fn')
 439           commafy xs = hsep $ punctuate comma xs