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 wherever needed
  51 and will have to be sunk by a later forward transformation.
  52 -}
  53
  54 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
  55
  56 dualUnion :: DualLive -> DualLive -> DualLive
  57 dualUnion (DualLive s r) (DualLive s' r') =
  58     DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
  59
  60 dualUnionList :: [DualLive] -> DualLive
  61 dualUnionList ls = DualLive ss rs
  62     where ss = unionManyUniqSets $ map on_stack ls
  63           rs = unionManyUniqSets $ map in_regs  ls
  64
  65 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
  66 changeStack f live = live { on_stack = f (on_stack live) }
  67 changeRegs  f live = live { in_regs  = f (in_regs  live) }
  68
  69
  70 dualLiveLattice :: DataflowLattice DualLive
  71 dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
  72     where empty = DualLive emptyRegSet emptyRegSet
  73           add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
  74             where (change1, stack) = add1 (on_stack old) (on_stack new)
  75                   (change2, regs)  = add1 (in_regs old)  (in_regs new)
  76           add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
  77             where join = unionUniqSets old new
  78
  79 dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
  80 dualLivenessWithInsertion procPoints g =
  81   liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
  82                                                 (dualLiveTransfers (g_entry g) procPoints)
  83                                                 (insertSpillAndReloadRewrites g procPoints)
  84
  85 dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
  86 dualLiveness procPoints g =
  87   liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
  88
  89 dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
  90 dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
  91     where first :: CmmNode C O -> DualLive -> DualLive
  92           first (CmmEntry id) live = check live id $  -- live at procPoint => spill
  93             if id /= entry && setMember id procPoints
  94                then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
  95                              , in_regs  = emptyRegSet }
  96                else live
  97             where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
  98
  99           middle :: CmmNode O O -> DualLive -> DualLive
 100           middle m = changeStack updSlots
 101                    . changeRegs  updRegs
 102             where -- Reuse middle of liveness analysis from CmmLive
 103                   updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m
 104
 105                   updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
 106                   spill  live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
 107                   spill  live _ = live
 108                   reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
 109                   reload live _ = live
 110                   check (RegSlot (LocalReg _ ty), o, w) x
 111                      | o == w && w == widthInBytes (typeWidth ty) = x
 112                   check _ _ = panic "middleDualLiveness unsupported: slices"
 113           last :: CmmNode O C -> FactBase DualLive -> DualLive
 114           last l fb = case l of
 115             CmmBranch id                   -> lkp id
 116             l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
 117             l@(CmmCall {cml_cont=Just k})  -> call l k
 118             l@(CmmForeignCall {succ=k})    -> call l k
 119             l@(CmmCondBranch _ t f)        -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
 120             l@(CmmSwitch _ tbl)            -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
 121             where empty = fact_bot dualLiveLattice
 122                   lkp id = empty `fromMaybe` lookupFact id fb
 123                   call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
 124
 125 gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
 126 gen  a live = foldRegsUsed extendRegSet     live a
 127 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
 128 kill a live = foldRegsDefd deleteFromRegSet live a
 129
 130 insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
 131 insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
 132   -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
 133   -- but GHC miscompiles it, see bug #4044.
 134     where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
 135           first e@(CmmEntry id) live = return $
 136             if id /= (g_entry graph) && setMember id procPoints then
 137               case map reload (uniqSetToList spill_regs) of
 138                 [] -> Nothing
 139                 is -> Just $ mkFirst e <*> mkMiddles is
 140             else Nothing
 141               where
 142                 -- If we are splitting procedures, we need the LastForeignCall
 143                 -- to spill its results to the stack because they will only
 144                 -- be used by a separate procedure (so they can't stay in LocalRegs).
 145                 splitting = True
 146                 spill_regs = if splitting then in_regs live
 147                              else in_regs live `minusRegSet` defs
 148                 defs = case mapLookup id firstDefs of
 149                            Just defs -> defs
 150                            Nothing   -> emptyRegSet
 151                 -- A LastForeignCall may contain some definitions, which take place
 152                 -- on return from the function call. Therefore, we build a map (firstDefs)
 153                 -- from BlockId to the set of variables defined on return to the BlockId.
 154                 firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
 155                 addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
 156                 addLive b env = case lastNode b of
 157                                   CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
 158                                   _                                 -> env
 159                 add bid defs env = mapInsert bid defs'' env
 160                   where defs'' = case mapLookup bid env of
 161                                    Just defs' -> timesRegSet defs defs'
 162                                    Nothing    -> defs
 163
 164           middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
 165           middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
 166           middle m@(CmmAssign (CmmLocal reg) _) live = return $
 167               if reg `elemRegSet` on_stack live then -- must spill
 168                    my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
 169                                                text "after"{-, ppr m-}]) $
 170                    Just $ mkMiddles $ [m, spill reg]
 171               else Nothing
 172           middle _ _ = return Nothing
 173
 174           nothing _ _ = return Nothing
 175
 176 regSlot :: LocalReg -> CmmExpr
 177 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
 178
 179 spill, reload :: LocalReg -> CmmNode O O
 180 spill  r = CmmStore  (regSlot r) (CmmReg $ CmmLocal r)
 181 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 182
 183 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
 184 removeDeadAssignmentsAndReloads procPoints g =
 185    liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
 186                                                  (dualLiveTransfers (g_entry g) procPoints)
 187                                                  rewrites
 188    where rewrites = deepBwdRw3 nothing middle nothing
 189          -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
 190          -- but GHC panics while compiling, see bug #4045.
 191          middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
 192          middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
 193          -- XXX maybe this should be somewhere else...
 194          middle (CmmAssign lhs (CmmReg rhs))   _ | lhs == rhs = return $ Just emptyGraph
 195          middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
 196          middle _ _ = return Nothing
 197
 198          nothing _ _ = return Nothing
 199
 200 ---------------------
 201 -- prettyprinting
 202
 203 ppr_regs :: String -> RegSet -> SDoc
 204 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 205   where commafy xs = hsep $ punctuate comma xs
 206
 207 instance Outputable DualLive where
 208   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 209       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 210           text "<nothing-live>"
 211       else
 212           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 213                          else (ppr_regs "live in regs =" regs),
 214                          if isEmptyUniqSet stack then PP.empty
 215                          else (ppr_regs "live on stack =" stack)]
 216
 217 my_trace :: String -> SDoc -> a -> a
 218 my_trace = if False then pprTrace else \_ _ a -> a
 219
 220 f4sep :: [SDoc] -> SDoc
 221 f4sep [] = fsep []
 222 f4sep (d:ds) = fsep (d : map (nest 4) ds)