compiler/cmm/CmmCommonBlockElim.hs

   1 {-# LANGUAGE GADTs #-}
   2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
   3 -- ToDo: remove
   4 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
   5
   6 module CmmCommonBlockElim
   7   ( elimCommonBlocks
   8   )
   9 where
  10
  11
  12 import BlockId
  13 import Cmm
  14 import CmmExpr
  15 import Prelude hiding (iterate, succ, unzip, zip)
  16
  17 import Compiler.Hoopl
  18 import Data.Bits
  19 import qualified Data.List as List
  20 import Data.Word
  21 import FastString
  22 import Control.Monad
  23 import Outputable
  24 import UniqFM
  25 import Unique
  26
  27 my_trace :: String -> SDoc -> a -> a
  28 my_trace = if False then pprTrace else \_ _ a -> a
  29
  30 -- Eliminate common blocks:
  31 -- If two blocks are identical except for the label on the first node,
  32 -- then we can eliminate one of the blocks. To ensure that the semantics
  33 -- of the program are preserved, we have to rewrite each predecessor of the
  34 -- eliminated block to proceed with the block we keep.
  35
  36 -- The algorithm iterates over the blocks in the graph,
  37 -- checking whether it has seen another block that is equal modulo labels.
  38 -- If so, then it adds an entry in a map indicating that the new block
  39 -- is made redundant by the old block.
  40 -- Otherwise, it is added to the useful blocks.
  41
  42 -- TODO: Use optimization fuel
  43 elimCommonBlocks :: CmmGraph -> CmmGraph
  44 elimCommonBlocks g =
  45     upd_graph g . snd $ iterate common_block reset hashed_blocks
  46                                 (emptyUFM, mapEmpty)
  47       where hashed_blocks    = map (\b -> (hash_block b, b)) (reverse (postorderDfs g))
  48             reset (_, subst) = (emptyUFM, subst)
  49
  50 -- Iterate over the blocks until convergence
  51 iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t
  52 iterate upd reset blocks state =
  53   case foldl upd' (False, state) blocks of
  54     (True,  state') -> iterate upd reset blocks (reset state')
  55     (False, state') -> state'
  56   where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes
  57
  58 -- Try to find a block that is equal (or ``common'') to b.
  59 type BidMap = BlockEnv BlockId
  60 type State  = (UniqFM [CmmBlock], BidMap)
  61 common_block :: (Outputable h, Uniquable h) =>  State -> (h, CmmBlock) -> (Bool, State)
  62 common_block (bmap, subst) (hash, b) =
  63   case lookupUFM bmap hash of
  64     Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
  65                      mapLookup bid subst) of
  66                  (Just b', Nothing)                         -> addSubst b'
  67                  (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
  68                  _ -> (False, (addToUFM bmap hash (b : bs), subst))
  69     Nothing -> (False, (addToUFM bmap hash [b], subst))
  70   where bid = entryLabel b
  71         addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
  72                       (True, (bmap, mapInsert bid (entryLabel b') subst))
  73
  74 -- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
  75 upd_graph :: CmmGraph -> BidMap -> CmmGraph
  76 upd_graph g subst = mapGraphNodes (id, middle, last) g
  77   where middle = mapExpDeep exp
  78         last l = last' (mapExpDeep exp l)
  79         last' :: CmmNode O C -> CmmNode O C
  80         last' (CmmBranch bid)              = CmmBranch $ sub bid
  81         last' (CmmCondBranch p t f)        = cond p (sub t) (sub f)
  82         last' (CmmCall t (Just bid) a r o) = CmmCall t (Just $ sub bid) a r o
  83         last' l@(CmmCall _ Nothing _ _ _)  = l
  84         last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (sub bid) u i
  85         last' (CmmSwitch e bs)             = CmmSwitch e $ map (liftM sub) bs
  86         cond p t f = if t == f then CmmBranch t else CmmCondBranch p t f
  87         exp (CmmStackSlot (CallArea (Young id))       off) =
  88              CmmStackSlot (CallArea (Young (sub id))) off
  89         exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id))
  90         exp e = e
  91         sub = lookupBid subst
  92
  93 -- To speed up comparisons, we hash each basic block modulo labels.
  94 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
  95 -- but it should be fast and good enough.
  96 hash_block :: CmmBlock -> Int
  97 hash_block block =
  98   fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
  99   -- UniqFM doesn't like negative Ints
 100   where hash_fst _ h = h
 101         hash_mid m h = hash_node m + h `shiftL` 1
 102         hash_lst m h = hash_node m + h `shiftL` 1
 103
 104         hash_node :: CmmNode O x -> Word32
 105         hash_node (CmmComment (FastString u _ _ _ _)) = cvt u
 106         hash_node (CmmAssign r e) = hash_reg r + hash_e e
 107         hash_node (CmmStore e e') = hash_e e + hash_e e'
 108         hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
 109         hash_node (CmmBranch _) = 23 -- would be great to hash these properly
 110         hash_node (CmmCondBranch p _ _) = hash_e p
 111         hash_node (CmmCall e _ _ _ _) = hash_e e
 112         hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
 113         hash_node (CmmSwitch e _) = hash_e e
 114
 115         hash_reg :: CmmReg -> Word32
 116         hash_reg   (CmmLocal _) = 117
 117         hash_reg   (CmmGlobal _)    = 19
 118
 119         hash_e :: CmmExpr -> Word32
 120         hash_e (CmmLit l) = hash_lit l
 121         hash_e (CmmLoad e _) = 67 + hash_e e
 122         hash_e (CmmReg r) = hash_reg r
 123         hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
 124         hash_e (CmmRegOff r i) = hash_reg r + cvt i
 125         hash_e (CmmStackSlot _ _) = 13
 126
 127         hash_lit :: CmmLit -> Word32
 128         hash_lit (CmmInt i _) = fromInteger i
 129         hash_lit (CmmFloat r _) = truncate r
 130         hash_lit (CmmLabel _) = 119 -- ugh
 131         hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
 132         hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
 133         hash_lit (CmmBlock _) = 191 -- ugh
 134         hash_lit (CmmHighStackMark) = cvt 313
 135
 136         hash_tgt (ForeignTarget e _) = hash_e e
 137         hash_tgt (PrimTarget _) = 31 -- lots of these
 138
 139         hash_list f = foldl (\z x -> f x + z) (0::Word32)
 140
 141         cvt = fromInteger . toInteger
 142 -- Utilities: equality and substitution on the graph.
 143
 144 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
 145 eqBid :: BidMap -> BlockId -> BlockId -> Bool
 146 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
 147 lookupBid :: BidMap -> BlockId -> BlockId
 148 lookupBid subst bid = case mapLookup bid subst of
 149                         Just bid  -> lookupBid subst bid
 150                         Nothing -> bid
 151
 152 -- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
 153 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
 154 eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
 155   where (_, middles , JustC last  :: MaybeC C (CmmNode O C)) = blockToNodeList block
 156         (_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'
 157
 158 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
 159 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
 160 eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
 161   c1 == c2 && eqBid t1 t2 && eqBid f1 f2
 162 eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) =
 163   t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
 164 eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
 165   e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
 166 eqLastWith _ _ _ = False
 167
 168 eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 169 eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
 170
 171 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
 172 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
 173 eqMaybeWith _ Nothing Nothing = True
 174 eqMaybeWith _ _ _ = False