compiler/cmm/CmmSpillReload.hs

   1 {-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts #-}
   2 -- Norman likes local bindings
   3 -- If this module lives on I'd like to get rid of this flag in due course
   4
   5 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
   6 #if __GLASGOW_HASKELL__ >= 701
   7 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
   8 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
   9 #endif
  10
  11 module CmmSpillReload
  12   ( DualLive(..)
  13   , dualLiveLattice, dualLiveTransfers, dualLiveness
  14   --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
  15   , dualLivenessWithInsertion
  16
  17   , removeDeadAssignmentsAndReloads
  18   )
  19 where
  20
  21 import BlockId
  22 import Cmm
  23 import CmmExpr
  24 import CmmLive
  25 import OptimizationFuel
  26
  27 import Control.Monad
  28 import Outputable hiding (empty)
  29 import qualified Outputable as PP
  30 import UniqSet
  31
  32 import Compiler.Hoopl hiding (Unique)
  33 import Data.Maybe
  34 import Prelude hiding (succ, zip)
  35
  36 {- Note [Overview of spill/reload]
  37 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  38 The point of this module is to insert spills and reloads to
  39 establish the invariant that at a call (or at any proc point with
  40 an established protocol) all live variables not expected in
  41 registers are sitting on the stack.  We use a backward analysis to
  42 insert spills and reloads.  It should be followed by a
  43 forward transformation to sink reloads as deeply as possible, so as
  44 to reduce register pressure.
  45
  46 A variable can be expected to be live in a register, live on the
  47 stack, or both.  This analysis ensures that spills and reloads are
  48 inserted as needed to make sure that every live variable needed
  49 after a call is available on the stack.  Spills are pushed back to
  50 their reaching definitions, but reloads are dropped immediately after
  51 we return from a call and will have to be sunk by a later forward
  52 transformation.
  53
  54 Note that we offer no guarantees about the consistency of the value
  55 in memory and the value in the register, except that they are
  56 equal across calls/procpoints.  If the variable is changed, this
  57 mapping breaks: but as the original value of the register may still
  58 be useful in a different context, the memory location is not updated.
  59 -}
  60
  61 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
  62
  63 dualUnion :: DualLive -> DualLive -> DualLive
  64 dualUnion (DualLive s r) (DualLive s' r') =
  65     DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
  66
  67 dualUnionList :: [DualLive] -> DualLive
  68 dualUnionList ls = DualLive ss rs
  69     where ss = unionManyUniqSets $ map on_stack ls
  70           rs = unionManyUniqSets $ map in_regs  ls
  71
  72 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
  73 changeStack f live = live { on_stack = f (on_stack live) }
  74 changeRegs  f live = live { in_regs  = f (in_regs  live) }
  75
  76
  77 dualLiveLattice :: DataflowLattice DualLive
  78 dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
  79     where empty = DualLive emptyRegSet emptyRegSet
  80           add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
  81             where (change1, stack) = add1 (on_stack old) (on_stack new)
  82                   (change2, regs)  = add1 (in_regs old)  (in_regs new)
  83           add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
  84             where join = unionUniqSets old new
  85
  86 dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
  87 dualLivenessWithInsertion procPoints g =
  88   liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
  89                                                 (dualLiveTransfers (g_entry g) procPoints)
  90                                                 (insertSpillAndReloadRewrites g procPoints)
  91
  92 dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
  93 dualLiveness procPoints g =
  94   liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
  95
  96 dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
  97 dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
  98     where first :: CmmNode C O -> DualLive -> DualLive
  99           first (CmmEntry id) live = check live id $  -- live at procPoint => spill
 100             if id /= entry && setMember id procPoints
 101                then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
 102                              , in_regs  = emptyRegSet }
 103                else live
 104             where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
 105
 106           middle :: CmmNode O O -> DualLive -> DualLive
 107           middle m = changeStack updSlots
 108                    . changeRegs  updRegs
 109             where -- Reuse middle of liveness analysis from CmmLive
 110                   updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m
 111
 112                   updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
 113                   spill  live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
 114                   spill  live _ = live
 115                   reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
 116                   reload live _ = live
 117                   check (RegSlot (LocalReg _ ty), o, w) x
 118                      | o == w && w == widthInBytes (typeWidth ty) = x
 119                   check _ _ = panic "middleDualLiveness unsupported: slices"
 120           last :: CmmNode O C -> FactBase DualLive -> DualLive
 121           last l fb = case l of
 122             CmmBranch id                   -> lkp id
 123             l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
 124             l@(CmmCall {cml_cont=Just k})  -> call l k
 125             l@(CmmForeignCall {succ=k})    -> call l k
 126             l@(CmmCondBranch _ t f)        -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
 127             l@(CmmSwitch _ tbl)            -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
 128             where empty = fact_bot dualLiveLattice
 129                   lkp id = empty `fromMaybe` lookupFact id fb
 130                   call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
 131
 132 gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
 133 gen  a live = foldRegsUsed extendRegSet     live a
 134 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
 135 kill a live = foldRegsDefd deleteFromRegSet live a
 136
 137 insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
 138 insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
 139   -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
 140   -- but GHC miscompiles it, see bug #4044.
 141     where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
 142           first e@(CmmEntry id) live = return $
 143             if id /= (g_entry graph) && setMember id procPoints then
 144               case map reload (uniqSetToList spill_regs) of
 145                 [] -> Nothing
 146                 is -> Just $ mkFirst e <*> mkMiddles is
 147             else Nothing
 148               where
 149                 -- If we are splitting procedures, we need the LastForeignCall
 150                 -- to spill its results to the stack because they will only
 151                 -- be used by a separate procedure (so they can't stay in LocalRegs).
 152                 splitting = True
 153                 spill_regs = if splitting then in_regs live
 154                              else in_regs live `minusRegSet` defs
 155                 defs = case mapLookup id firstDefs of
 156                            Just defs -> defs
 157                            Nothing   -> emptyRegSet
 158                 -- A LastForeignCall may contain some definitions, which take place
 159                 -- on return from the function call. Therefore, we build a map (firstDefs)
 160                 -- from BlockId to the set of variables defined on return to the BlockId.
 161                 firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
 162                 addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
 163                 addLive b env = case lastNode b of
 164                                   CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
 165                                   _                                 -> env
 166                 add bid defs env = mapInsert bid defs'' env
 167                   where defs'' = case mapLookup bid env of
 168                                    Just defs' -> timesRegSet defs defs'
 169                                    Nothing    -> defs
 170
 171           middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
 172           middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
 173           middle m@(CmmAssign (CmmLocal reg) _) live = return $
 174               if reg `elemRegSet` on_stack live then -- must spill
 175                    my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
 176                                                text "after"{-, ppr m-}]) $
 177                    Just $ mkMiddles $ [m, spill reg]
 178               else Nothing
 179           middle _ _ = return Nothing
 180
 181           nothing _ _ = return Nothing
 182
 183 spill, reload :: LocalReg -> CmmNode O O
 184 spill  r = CmmStore  (regSlot r) (CmmReg $ CmmLocal r)
 185 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 186
 187 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
 188 removeDeadAssignmentsAndReloads procPoints g =
 189    liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
 190                                                  (dualLiveTransfers (g_entry g) procPoints)
 191                                                  rewrites
 192    where rewrites = deepBwdRw3 nothing middle nothing
 193          -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
 194          -- but GHC panics while compiling, see bug #4045.
 195          middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
 196          middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
 197          -- XXX maybe this should be somewhere else...
 198          middle (CmmAssign lhs (CmmReg rhs))   _ | lhs == rhs = return $ Just emptyGraph
 199          middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
 200          middle _ _ = return Nothing
 201
 202          nothing _ _ = return Nothing
 203
 204 ---------------------
 205 -- prettyprinting
 206
 207 ppr_regs :: String -> RegSet -> SDoc
 208 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 209   where commafy xs = hsep $ punctuate comma xs
 210
 211 instance Outputable DualLive where
 212   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 213       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 214           text "<nothing-live>"
 215       else
 216           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 217                          else (ppr_regs "live in regs =" regs),
 218                          if isEmptyUniqSet stack then PP.empty
 219                          else (ppr_regs "live on stack =" stack)]
 220
 221 my_trace :: String -> SDoc -> a -> a
 222 my_trace = if False then pprTrace else \_ _ a -> a
 223
 224 f4sep :: [SDoc] -> SDoc
 225 f4sep [] = fsep []
 226 f4sep (d:ds) = fsep (d : map (nest 4) ds)