compiler/cmm/CmmSpillReload.hs

   1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
   2
   3 module CmmSpillReload
   4   ( ExtendWithSpills(..)
   5   , DualLive(..)
   6   , dualLiveLattice, dualLiveness
   7   , insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
   8   , dualLivenessWithInsertion
   9   , spillAndReloadComments
  10   )
  11 where
  12 import CmmExpr
  13 import CmmTx()
  14 import CmmLiveZ
  15 import DFMonad
  16 import FastString
  17 import Maybe
  18 import MkZipCfg
  19 import Outputable hiding (empty)
  20 import qualified Outputable as PP
  21 import Panic
  22 import PprCmm()
  23 import UniqSet
  24 import ZipCfg
  25 import ZipCfgCmm
  26 import ZipDataflow
  27
  28 -- The point of this module is to insert spills and reloads to
  29 -- establish the invariant that at a call (or at any proc point with
  30 -- an established protocol) all live variables not expected in
  31 -- registers are sitting on the stack.  We use a backward analysis to
  32 -- insert spills and reloads.  It should some day be followed by a
  33 -- forward transformation to sink reloads as deeply as possible, so as
  34 -- to reduce register pressure.
  35
  36 data ExtendWithSpills m
  37     = NotSpillOrReload m
  38     | Spill  RegSet
  39     | Reload RegSet
  40
  41 type M = ExtendWithSpills Middle
  42
  43 -- A variable can be expected to be live in a register, live on the
  44 -- stack, or both.  This analysis ensures that spills and reloads are
  45 -- inserted as needed to make sure that every live variable needed
  46 -- after a call is available on the stack.  Spills are pushed back to
  47 -- their reaching definitions, but reloads are dropped wherever needed
  48 -- and will have to be sunk by a later forward transformation.
  49
  50 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
  51
  52 dualUnion :: DualLive -> DualLive -> DualLive
  53 dualUnion (DualLive s r) (DualLive s' r') =
  54     DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
  55
  56 dualUnionList :: [DualLive] -> DualLive
  57 dualUnionList ls = DualLive ss rs
  58     where ss = unionManyUniqSets $ map on_stack ls
  59           rs = unionManyUniqSets $ map in_regs  ls
  60
  61 _changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
  62 _changeStack f live = live { on_stack = f (on_stack live) }
  63 changeRegs   f live = live { in_regs  = f (in_regs  live) }
  64
  65
  66 dualLiveLattice :: DataflowLattice DualLive
  67 dualLiveLattice =
  68       DataflowLattice "variables live in registers and on stack" empty add False
  69     where empty = DualLive emptyRegSet emptyRegSet
  70           -- | compute in the Tx monad to track whether anything has changed
  71           add new old = do stack <- add1 (on_stack new) (on_stack old)
  72                            regs  <- add1 (in_regs new)  (in_regs old)
  73                            return $ DualLive stack regs
  74           add1 = fact_add_to liveLattice
  75
  76 dualLivenessWithInsertion :: BPass M Last DualLive
  77 dualLivenessWithInsertion = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
  78
  79
  80 dualLiveness :: BAnalysis M Last DualLive
  81 dualLiveness = BComp "dual liveness" exit last middle first
  82     where exit   = empty
  83           last   = lastDualLiveness
  84           middle = middleDualLiveness
  85           first live _id = live
  86           empty = fact_bot dualLiveLattice
  87
  88             -- ^ could take a proc-point set and choose to spill here,
  89             -- but it's probably better to run this pass, choose
  90             -- proc-point protocols, insert more CopyIn nodes, and run
  91             -- this pass again
  92
  93 middleDualLiveness :: DualLive -> M -> DualLive
  94 middleDualLiveness live m@(Spill regs) =
  95     -- live-in on-stack requirements are satisfied;
  96     -- live-out in-regs obligations are created
  97       my_trace "before" (f4sep [ppr m, text "liveness is", ppr live']) $
  98       live'
  99     where live' = DualLive { on_stack = on_stack live `minusRegSet` regs
 100                            , in_regs = in_regs live `plusRegSet` regs }
 101
 102 middleDualLiveness live m@(Reload regs) =
 103     -- live-in in-regs requirements are satisfied;
 104     -- live-out on-stack obligations are created
 105       my_trace "before" (f4sep [ppr m, text "liveness is", ppr live']) $
 106       live'
 107     where live' = DualLive { on_stack = on_stack live `plusRegSet` regs
 108                            , in_regs = in_regs live `minusRegSet` regs }
 109
 110 middleDualLiveness live (NotSpillOrReload m) = middle m live
 111   where middle (MidNop)                         = id
 112         middle (MidComment {})                  = id
 113         middle (MidAssign (CmmLocal reg') expr) = changeRegs (gen expr . kill reg')
 114         middle (MidAssign (CmmGlobal _) expr)   = changeRegs (gen expr)
 115         middle (MidStore addr rval)             = changeRegs (gen addr . gen rval)
 116         middle (MidUnsafeCall _ ress args)      = changeRegs (gen args . kill ress)
 117         middle (CopyIn  _ formals _)            = changeRegs (kill formals)
 118         middle (CopyOut _ formals)              = changeRegs (gen  formals)
 119
 120 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
 121 lastDualLiveness env l = last l
 122   where last (LastReturn ress)            = changeRegs (gen ress) empty
 123         last (LastJump e args)            = changeRegs (gen e . gen args) empty
 124         last (LastBranch id args)         = changeRegs (gen args) $ env id
 125         last (LastCall tgt args Nothing)  = changeRegs (gen tgt. gen args) empty
 126         last (LastCall tgt args (Just k)) =
 127             -- nothing can be live in registers at this point
 128             -- only 'formals' can be in regs at this point
 129             let live = env k in
 130             if  isEmptyUniqSet (in_regs live) then
 131                 DualLive (on_stack live) (gen tgt $ gen args emptyRegSet)
 132             else
 133                 panic "live values in registers at call continuation"
 134         last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f)
 135         last (LastSwitch e tbl)     = changeRegs (gen e) $ dualUnionList $
 136                                                              map env (catMaybes tbl)
 137         empty = fact_bot dualLiveLattice
 138
 139 gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
 140 gen  a live = foldRegsUsed extendRegSet      live a
 141 kill a live = foldRegsUsed delOneFromUniqSet live a
 142
 143 insertSpillsAndReloads :: BFunctionalTransformation M Last DualLive
 144 insertSpillsAndReloads = BComp "CPS spiller" exit last middle first
 145     where exit   = Nothing
 146           last   = \_ _ -> Nothing
 147           middle = middleInsertSpillsAndReloads
 148           first _ _ = Nothing
 149             -- ^ could take a proc-point set and choose to spill here,
 150             -- but it's probably better to run this pass, choose
 151             -- proc-point protocols, insert more CopyIn nodes, and run
 152             -- this pass again
 153
 154
 155 middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
 156 middleInsertSpillsAndReloads _ (Spill _)  = Nothing
 157 middleInsertSpillsAndReloads _ (Reload _) = Nothing
 158 middleInsertSpillsAndReloads live (NotSpillOrReload m) = middle m
 159   where middle (MidAssign (CmmLocal reg') _) =
 160             if reg' `elemRegSet` on_stack live then -- must spill
 161                 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg',
 162                                             text "after", ppr m]) $
 163                 Just $ graphOfMiddles [NotSpillOrReload m, Spill $ mkRegSet [reg']]
 164             else
 165                 Nothing
 166         middle (CopyIn _ formals _) =
 167             -- only 'formals' can be in regs at this point
 168             let regs' = kill formals (in_regs live) -- live in regs; must reload
 169                 is_stack_var r = elemRegSet r (on_stack live)
 170                 needs_spilling = -- a formal that is expected on the stack; must spill
 171                    foldRegsUsed (\rs r -> if is_stack_var r then extendRegSet rs r
 172                                           else rs) emptyRegSet formals
 173             in  if isEmptyUniqSet regs' && isEmptyUniqSet needs_spilling then
 174                     Nothing
 175                 else
 176                     let reload = if isEmptyUniqSet regs' then []
 177                                  else [Reload regs']
 178                         spill_reload = if isEmptyUniqSet needs_spilling then reload
 179                                        else Spill needs_spilling : reload
 180                         middles = NotSpillOrReload m : spill_reload
 181                     in
 182                     my_trace "At CopyIn" (f4sep [text "Triggered by ", ppr live,
 183                                                  ppr (Reload regs' :: M),
 184                                                  ppr (Spill needs_spilling :: M),
 185                                                  text "after", ppr m]) $
 186                     Just $ graphOfMiddles middles
 187         middle _ = Nothing
 188
 189 -- | For conversion back to vanilla C--
 190 spillAndReloadComments :: M -> Middle
 191 spillAndReloadComments (NotSpillOrReload m) = m
 192 spillAndReloadComments (Spill  regs) = show_regs "Spill" regs
 193 spillAndReloadComments (Reload regs) = show_regs "Reload" regs
 194
 195 show_regs :: String -> RegSet -> Middle
 196 show_regs s regs = MidComment $ mkFastString $ showSDoc $ ppr_regs s regs
 197
 198
 199 ---------------------
 200 -- prettyprinting
 201
 202 instance Outputable m => Outputable (ExtendWithSpills m) where
 203     ppr (Spill  regs) = ppr_regs "Spill"  regs
 204     ppr (Reload regs) = ppr_regs "Reload" regs
 205     ppr (NotSpillOrReload m) = ppr m
 206
 207 instance Outputable (LGraph M Last) where
 208     ppr = pprLgraph
 209
 210 instance DebugNodes M Last
 211
 212 ppr_regs :: String -> RegSet -> SDoc
 213 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 214   where commafy xs = hsep $ punctuate comma xs
 215
 216 instance Outputable DualLive where
 217   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 218       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 219           text "<nothing-live>"
 220       else
 221           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 222                          else (ppr_regs "live in regs =" regs),
 223                          if isEmptyUniqSet stack then PP.empty
 224                          else (ppr_regs "live on stack =" stack)]
 225
 226 my_trace :: String -> SDoc -> a -> a
 227 my_trace = if False then pprTrace else \_ _ a -> a
 228
 229 f4sep :: [SDoc] -> SDoc
 230 f4sep [] = fsep []
 231 f4sep (d:ds) = fsep (d : map (nest 4) ds)