compiler/cmm/CmmSpillReload.hs

   1 {-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts, ViewPatterns #-}
   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 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
   7 #if __GLASGOW_HASKELL__ >= 701
   8 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
   9 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
  10 #endif
  11
  12 module CmmSpillReload
  13   ( DualLive(..)
  14   , dualLiveLattice, dualLiveTransfers, dualLiveness
  15   --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
  16   , dualLivenessWithInsertion
  17
  18   , rewriteAssignments
  19   , removeDeadAssignmentsAndReloads
  20   )
  21 where
  22
  23 import BlockId
  24 import Cmm
  25 import CmmExpr
  26 import CmmLive
  27 import OptimizationFuel
  28
  29 import Control.Monad
  30 import Outputable hiding (empty)
  31 import qualified Outputable as PP
  32 import UniqSet
  33 import UniqFM
  34 import Unique
  35
  36 import Compiler.Hoopl hiding (Unique)
  37 import Data.Maybe
  38 import Prelude hiding (succ, zip)
  39
  40 {- Note [Overview of spill/reload]
  41 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  42 The point of this module is to insert spills and reloads to
  43 establish the invariant that at a call (or at any proc point with
  44 an established protocol) all live variables not expected in
  45 registers are sitting on the stack.  We use a backward analysis to
  46 insert spills and reloads.  It should be followed by a
  47 forward transformation to sink reloads as deeply as possible, so as
  48 to reduce register pressure.
  49
  50 A variable can be expected to be live in a register, live on the
  51 stack, or both.  This analysis ensures that spills and reloads are
  52 inserted as needed to make sure that every live variable needed
  53 after a call is available on the stack.  Spills are pushed back to
  54 their reaching definitions, but reloads are dropped wherever needed
  55 and will have to be sunk by a later forward transformation.
  56 -}
  57
  58 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
  59
  60 dualUnion :: DualLive -> DualLive -> DualLive
  61 dualUnion (DualLive s r) (DualLive s' r') =
  62     DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
  63
  64 dualUnionList :: [DualLive] -> DualLive
  65 dualUnionList ls = DualLive ss rs
  66     where ss = unionManyUniqSets $ map on_stack ls
  67           rs = unionManyUniqSets $ map in_regs  ls
  68
  69 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
  70 changeStack f live = live { on_stack = f (on_stack live) }
  71 changeRegs  f live = live { in_regs  = f (in_regs  live) }
  72
  73
  74 dualLiveLattice :: DataflowLattice DualLive
  75 dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
  76     where empty = DualLive emptyRegSet emptyRegSet
  77           add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
  78             where (change1, stack) = add1 (on_stack old) (on_stack new)
  79                   (change2, regs)  = add1 (in_regs old)  (in_regs new)
  80           add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
  81             where join = unionUniqSets old new
  82
  83 dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
  84 dualLivenessWithInsertion procPoints g =
  85   liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
  86                                                 (dualLiveTransfers (g_entry g) procPoints)
  87                                                 (insertSpillAndReloadRewrites g procPoints)
  88
  89 dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
  90 dualLiveness procPoints g =
  91   liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
  92
  93 dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
  94 dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
  95     where first :: CmmNode C O -> DualLive -> DualLive
  96           first (CmmEntry id) live = check live id $  -- live at procPoint => spill
  97             if id /= entry && setMember id procPoints
  98                then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
  99                              , in_regs  = emptyRegSet }
 100                else live
 101             where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
 102
 103           middle :: CmmNode O O -> DualLive -> DualLive
 104           middle m = changeStack updSlots
 105                    . changeRegs  updRegs
 106             where -- Reuse middle of liveness analysis from CmmLive
 107                   updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m
 108
 109                   updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
 110                   spill  live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
 111                   spill  live _ = live
 112                   reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
 113                   reload live _ = live
 114                   check (RegSlot (LocalReg _ ty), o, w) x
 115                      | o == w && w == widthInBytes (typeWidth ty) = x
 116                   check _ _ = panic "middleDualLiveness unsupported: slices"
 117           last :: CmmNode O C -> FactBase DualLive -> DualLive
 118           last l fb = case l of
 119             CmmBranch id                   -> lkp id
 120             l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
 121             l@(CmmCall {cml_cont=Just k})  -> call l k
 122             l@(CmmForeignCall {succ=k})    -> call l k
 123             l@(CmmCondBranch _ t f)        -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
 124             l@(CmmSwitch _ tbl)            -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
 125             where empty = fact_bot dualLiveLattice
 126                   lkp id = empty `fromMaybe` lookupFact id fb
 127                   call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
 128
 129 gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
 130 gen  a live = foldRegsUsed extendRegSet     live a
 131 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
 132 kill a live = foldRegsDefd deleteFromRegSet live a
 133
 134 insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
 135 insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
 136   -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
 137   -- but GHC miscompiles it, see bug #4044.
 138     where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
 139           first e@(CmmEntry id) live = return $
 140             if id /= (g_entry graph) && setMember id procPoints then
 141               case map reload (uniqSetToList spill_regs) of
 142                 [] -> Nothing
 143                 is -> Just $ mkFirst e <*> mkMiddles is
 144             else Nothing
 145               where
 146                 -- If we are splitting procedures, we need the LastForeignCall
 147                 -- to spill its results to the stack because they will only
 148                 -- be used by a separate procedure (so they can't stay in LocalRegs).
 149                 splitting = True
 150                 spill_regs = if splitting then in_regs live
 151                              else in_regs live `minusRegSet` defs
 152                 defs = case mapLookup id firstDefs of
 153                            Just defs -> defs
 154                            Nothing   -> emptyRegSet
 155                 -- A LastForeignCall may contain some definitions, which take place
 156                 -- on return from the function call. Therefore, we build a map (firstDefs)
 157                 -- from BlockId to the set of variables defined on return to the BlockId.
 158                 firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
 159                 addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
 160                 addLive b env = case lastNode b of
 161                                   CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
 162                                   _                                 -> env
 163                 add bid defs env = mapInsert bid defs'' env
 164                   where defs'' = case mapLookup bid env of
 165                                    Just defs' -> timesRegSet defs defs'
 166                                    Nothing    -> defs
 167
 168           middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
 169           middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
 170           middle m@(CmmAssign (CmmLocal reg) _) live = return $
 171               if reg `elemRegSet` on_stack live then -- must spill
 172                    my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
 173                                                text "after"{-, ppr m-}]) $
 174                    Just $ mkMiddles $ [m, spill reg]
 175               else Nothing
 176           middle _ _ = return Nothing
 177
 178           nothing _ _ = return Nothing
 179
 180 regSlot :: LocalReg -> CmmExpr
 181 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
 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 --- Usage information
 206
 207 -- We decorate all register assignments with usage information,
 208 -- that is, the maximum number of times the register is referenced
 209 -- while it is live along all outgoing control paths.  There are a few
 210 -- subtleties here:
 211 --
 212 --  - If a register goes dead, and then becomes live again, the usages
 213 --    of the disjoint live range don't count towards the original range.
 214 --
 215 --          a = 1; // used once
 216 --          b = a;
 217 --          a = 2; // used once
 218 --          c = a;
 219 --
 220 --  - A register may be used multiple times, but these all reside in
 221 --    different control paths, such that any given execution only uses
 222 --    it once. In that case, the usage count may still be 1.
 223 --
 224 --          a = 1; // used once
 225 --          if (b) {
 226 --              c = a + 3;
 227 --          } else {
 228 --              c = a + 1;
 229 --          }
 230 --
 231 --    This policy corresponds to an inlining strategy that does not
 232 --    duplicate computation but may increase binary size.
 233 --
 234 --  - If we naively implement a usage count, we have a counting to
 235 --    infinity problem across joins.  Furthermore, knowing that
 236 --    something is used 2 or more times in one runtime execution isn't
 237 --    particularly useful for optimizations (inlining may be beneficial,
 238 --    but there's no way of knowing that without register pressure
 239 --    information.)
 240 --
 241 --          while (...) {
 242 --              // first iteration, b used once
 243 --              // second iteration, b used twice
 244 --              // third iteration ...
 245 --              a = b;
 246 --          }
 247 --          // b used zero times
 248 --
 249 --    There is an orthogonal question, which is that for every runtime
 250 --    execution, the register may be used only once, but if we inline it
 251 --    in every conditional path, the binary size might increase a lot.
 252 --    But tracking this information would be tricky, because it violates
 253 --    the finite lattice restriction Hoopl requires for termination;
 254 --    we'd thus need to supply an alternate proof, which is probably
 255 --    something we should defer until we actually have an optimization
 256 --    that would take advantage of this.  (This might also interact
 257 --    strangely with liveness information.)
 258 --
 259 --          a = ...;
 260 --          // a is used one time, but in X different paths
 261 --          case (b) of
 262 --              1 -> ... a ...
 263 --              2 -> ... a ...
 264 --              3 -> ... a ...
 265 --              ...
 266 --
 267 --  This analysis is very similar to liveness analysis; we just keep a
 268 --  little extra info. (Maybe we should move it to CmmLive, and subsume
 269 --  the old liveness analysis.)
 270
 271 data RegUsage = SingleUse | ManyUse
 272     deriving (Ord, Eq, Show)
 273 -- Absence in map = ZeroUse
 274
 275 {-
 276 -- minBound is bottom, maxBound is top, least-upper-bound is max
 277 -- ToDo: Put this in Hoopl.  Note that this isn't as useful as I
 278 -- originally hoped, because you usually want to leave out the bottom
 279 -- element when you have things like this put in maps.  Maybe f is
 280 -- useful on its own as a combining function.
 281 boundedOrdLattice :: (Bounded a, Ord a) => String -> DataflowLattice a
 282 boundedOrdLattice n = DataflowLattice n minBound f
 283     where f _ (OldFact x) (NewFact y)
 284             | x >= y    = (NoChange,   x)
 285             | otherwise = (SomeChange, y)
 286 -}
 287
 288 -- Custom node type we'll rewrite to.  CmmAssign nodes to local
 289 -- registers are replaced with AssignLocal nodes.
 290 data WithRegUsage n e x where
 291     Plain       :: n e x -> WithRegUsage n e x
 292     AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O
 293
 294 instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where
 295     foldRegsUsed f z (Plain n) = foldRegsUsed f z n
 296     foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e
 297
 298 instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where
 299     foldRegsDefd f z (Plain n) = foldRegsDefd f z n
 300     foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r
 301
 302 instance NonLocal n => NonLocal (WithRegUsage n) where
 303     entryLabel (Plain n) = entryLabel n
 304     successors (Plain n) = successors n
 305
 306 liftRegUsage :: Graph n e x -> Graph (WithRegUsage n) e x
 307 liftRegUsage = mapGraph Plain
 308
 309 eraseRegUsage :: Graph (WithRegUsage CmmNode) e x -> Graph CmmNode e x
 310 eraseRegUsage = mapGraph f
 311     where f :: WithRegUsage CmmNode e x -> CmmNode e x
 312           f (AssignLocal l e _) = CmmAssign (CmmLocal l) e
 313           f (Plain n) = n
 314
 315 type UsageMap = UniqFM RegUsage
 316
 317 usageLattice :: DataflowLattice UsageMap
 318 usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f)
 319     where f _ (OldFact x) (NewFact y)
 320             | x >= y    = (NoChange,   x)
 321             | otherwise = (SomeChange, y)
 322
 323 -- We reuse the names 'gen' and 'kill', although we're doing something
 324 -- slightly different from the Dragon Book
 325 usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap
 326 usageTransfer = mkBTransfer3 first middle last
 327     where first _ f = f
 328           middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap
 329           middle n f = gen_kill n f
 330           last :: WithRegUsage CmmNode O C -> FactBase UsageMap -> UsageMap
 331           -- Checking for CmmCall/CmmForeignCall is unnecessary, because
 332           -- spills/reloads have already occurred by the time we do this
 333           -- analysis.
 334           -- XXX Deprecated warning is puzzling: what label are we
 335           -- supposed to use?
 336           -- ToDo: With a bit more cleverness here, we can avoid
 337           -- disappointment and heartbreak associated with the inability
 338           -- to inline into CmmCall and CmmForeignCall by
 339           -- over-estimating the usage to be ManyUse.
 340           last n f = gen_kill n (joinOutFacts usageLattice n f)
 341           gen_kill a = gen a . kill a
 342           gen  a f = foldRegsUsed increaseUsage f a
 343           kill a f = foldRegsDefd delFromUFM f a
 344           increaseUsage f r = addToUFM_C combine f r SingleUse
 345             where combine _ _ = ManyUse
 346
 347 usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap
 348 usageRewrite = mkBRewrite3 first middle last
 349     where first  _ _ = return Nothing
 350           middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O))
 351           middle (Plain (CmmAssign (CmmLocal l) e)) f
 352                      = return . Just
 353                      $ case lookupUFM f l of
 354                             Nothing    -> emptyGraph
 355                             Just usage -> mkMiddle (AssignLocal l e usage)
 356           middle _ _ = return Nothing
 357           last   _ _ = return Nothing
 358
 359 type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode)
 360 annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage)
 361 annotateUsage vanilla_g =
 362     let g = modifyGraph liftRegUsage vanilla_g
 363     in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $
 364                                    analRewBwd usageLattice usageTransfer usageRewrite
 365
 366 ----------------------------------------------------------------
 367 --- Assignment tracking
 368
 369 -- The idea is to maintain a map of local registers do expressions,
 370 -- such that the value of that register is the same as the value of that
 371 -- expression at any given time.  We can then do several things,
 372 -- as described by Assignment.
 373
 374 -- Assignment describes the various optimizations that are valid
 375 -- at a given point in the program.
 376 data Assignment =
 377 -- This assignment can always be inlined.  It is cheap or single-use.
 378                   AlwaysInline CmmExpr
 379 -- This assignment should be sunk down to its first use.  (This will
 380 -- increase code size if the register is used in multiple control flow
 381 -- paths, but won't increase execution time, and the reduction of
 382 -- register pressure is worth it.)
 383                 | AlwaysSink CmmExpr
 384 -- We cannot safely optimize occurrences of this local register. (This
 385 -- corresponds to top in the lattice structure.)
 386                 | NeverOptimize
 387
 388 -- Extract the expression that is being assigned to
 389 xassign :: Assignment -> Maybe CmmExpr
 390 xassign (AlwaysInline e) = Just e
 391 xassign (AlwaysSink e)   = Just e
 392 xassign NeverOptimize    = Nothing
 393
 394 -- Extracts the expression, but only if they're the same constructor
 395 xassign2 :: (Assignment, Assignment) -> Maybe (CmmExpr, CmmExpr)
 396 xassign2 (AlwaysInline e, AlwaysInline e') = Just (e, e')
 397 xassign2 (AlwaysSink e, AlwaysSink e')     = Just (e, e')
 398 xassign2 _ = Nothing
 399
 400 -- Note: We'd like to make decisions about "not optimizing" as soon as
 401 -- possible, because this will make running the transfer function more
 402 -- efficient.
 403 type AssignmentMap = UniqFM Assignment
 404
 405 assignmentLattice :: DataflowLattice AssignmentMap
 406 assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUFM add)
 407     where add _ (OldFact old) (NewFact new)
 408             = case (old, new) of
 409                 (NeverOptimize, _) -> (NoChange,   NeverOptimize)
 410                 (_, NeverOptimize) -> (SomeChange, NeverOptimize)
 411                 (xassign2 -> Just (e, e'))
 412                     | e == e'   -> (NoChange, old)
 413                     | otherwise -> (SomeChange, NeverOptimize)
 414                 _ -> (SomeChange, NeverOptimize)
 415
 416 -- Deletes sinks from assignment map, because /this/ is the place
 417 -- where it will be sunk to.
 418 deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap
 419 deleteSinks n m = foldRegsUsed (adjustUFM f) m n
 420   where f (AlwaysSink _) = NeverOptimize
 421         f old = old
 422
 423 -- Invalidates any expressions that use a register.
 424 invalidateUsersOf :: CmmReg -> AssignmentMap -> AssignmentMap
 425 -- foldUFM_Directly :: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
 426 invalidateUsersOf reg m = foldUFM_Directly f m m -- [foldUFM performance]
 427     where f u (xassign -> Just e) m | reg `regUsedIn` e = addToUFM_Directly m u NeverOptimize
 428           f _ _ m = m
 429 {- This requires the entire spine of the map to be continually rebuilt,
 430  - which causes crazy memory usage!
 431 invalidateUsersOf reg = mapUFM (invalidateUsers' reg)
 432   where invalidateUsers' reg (xassign -> Just e) | reg `regUsedIn` e = NeverOptimize
 433         invalidateUsers' _ old = old
 434 -}
 435
 436 -- Note [foldUFM performance]
 437 -- These calls to fold UFM no longer leak memory, but they do cause
 438 -- pretty killer amounts of allocation.  So they'll be something to
 439 -- optimize; we need an algorithmic change to prevent us from having to
 440 -- traverse the /entire/ map continually.
 441
 442 middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap
 443
 444 -- Algorithm for annotated assignments:
 445 --  1. Delete any sinking assignments that were used by this instruction
 446 --  2. Add the assignment to our list of valid local assignments with
 447 --     the correct optimization policy.
 448 --  3. Look for all assignments that reference that register and
 449 --     invalidate them.
 450 middleAssignment n@(AssignLocal r e usage) assign
 451     = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign
 452       where add m = addToUFM m r
 453                   $ case usage of
 454                         SingleUse -> AlwaysInline e
 455                         ManyUse   -> decide e
 456             decide CmmLit{}       = AlwaysInline e
 457             decide CmmReg{}       = AlwaysInline e
 458             decide CmmLoad{}      = AlwaysSink e
 459             decide CmmStackSlot{} = AlwaysSink e
 460             decide CmmMachOp{}    = AlwaysSink e
 461             -- We'll always inline simple operations on the global
 462             -- registers, to reduce register pressure: Sp - 4 or Hp - 8
 463             -- EZY: Justify this optimization more carefully.
 464             decide CmmRegOff{}    = AlwaysInline e
 465
 466 -- Algorithm for unannotated assignments of global registers:
 467 -- 1. Delete any sinking assignments that were used by this instruction
 468 -- 2. Look for all assignments that reference this register and
 469 --    invalidate them.
 470 middleAssignment (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign
 471     = invalidateUsersOf reg . deleteSinks n $ assign
 472
 473 -- Algorithm for unannotated assignments of *local* registers: do
 474 -- nothing (it's a reload, so no state should have changed)
 475 middleAssignment (Plain (CmmAssign (CmmLocal _) _)) assign = assign
 476
 477 -- Algorithm for stores:
 478 --  1. Delete any sinking assignments that were used by this instruction
 479 --  2. Look for all assignments that load from memory locations that
 480 --     were clobbered by this store and invalidate them.
 481 middleAssignment (Plain n@(CmmStore lhs rhs)) assign
 482     = let m = deleteSinks n assign
 483       in foldUFM_Directly f m m -- [foldUFM performance]
 484       where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize
 485             f _ _ m = m
 486 {- Also leaky
 487     = mapUFM_Directly p . deleteSinks n $ assign
 488       -- ToDo: There's a missed opportunity here: even if a memory
 489       -- access we're attempting to sink gets clobbered at some
 490       -- location, it's still /better/ to sink it to right before the
 491       -- point where it gets clobbered.  How might we do this?
 492       -- Unfortunately, it's too late to change the assignment...
 493       where p r (xassign -> Just x) | (lhs, rhs) `clobbers` (r, x) = NeverOptimize
 494             p _ old = old
 495 -}
 496
 497 -- Assumption: Unsafe foreign calls don't clobber memory
 498 middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign
 499     = foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n
 500
 501 middleAssignment (Plain (CmmComment {})) assign
 502     = assign
 503
 504 -- Assumptions:
 505 --  * Writes using Hp do not overlap with any other memory locations
 506 --    (An important invariant being relied on here is that we only ever
 507 --    use Hp to allocate values on the heap, which appears to be the
 508 --    case given hpReg usage, and that our heap writing code doesn't
 509 --    do anything stupid like overlapping writes.)
 510 --  * Stack slots do not overlap with any other memory locations
 511 --  * Stack slots for different areas do not overlap
 512 --  * Stack slots within the same area and different offsets may
 513 --    overlap; we need to do a size check (see 'overlaps').
 514 --  * Register slots only overlap with themselves.  (But this shouldn't
 515 --    happen in practice, because we'll fail to inline a reload across
 516 --    the next spill.)
 517 --  * Non stack-slot stores always conflict with each other.  (This is
 518 --    not always the case; we could probably do something special for Hp)
 519 clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore
 520          -> (Unique,  CmmExpr) -- (register, expression) that may be clobbered
 521          -> Bool
 522 clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False
 523 clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False
 524 -- ToDo: Also catch MachOp case
 525 clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _)
 526     | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?)
 527 clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
 528     where f (CmmLoad (CmmStackSlot (CallArea a') o') t)
 529             = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t))
 530           f (CmmLoad e _)    = containsStackSlot e
 531           f (CmmMachOp _ es) = or (map f es)
 532           f _                = False
 533           -- Maybe there's an invariant broken if this actually ever
 534           -- returns True
 535           containsStackSlot (CmmLoad{})      = True -- load of a load, all bets off
 536           containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es)
 537           containsStackSlot (CmmStackSlot{}) = True
 538           containsStackSlot _ = False
 539 clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr
 540     where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l'
 541           f _ = False
 542 clobbers _ (_, e) = f e
 543     where f (CmmLoad (CmmStackSlot _ _) _) = False
 544           f (CmmLoad{}) = True -- conservative
 545           f (CmmMachOp _ es) = or (map f es)
 546           f _ = False
 547
 548 -- Check for memory overlapping.
 549 -- Diagram:
 550 --      4      8     12
 551 --      s -w-  o
 552 --      [ I32  ]
 553 --      [    F64     ]
 554 --      s'   -w'-    o'
 555 type CallSubArea = (AreaId, Int, Int) -- area, offset, width
 556 overlaps :: CallSubArea -> CallSubArea -> Bool
 557 overlaps (a, _, _) (a', _, _) | a /= a' = False
 558 overlaps (_, o, w) (_, o', w') =
 559     let s  = o  - w
 560         s' = o' - w'
 561     in (s' < o) && (s < o) -- Not LTE, because [ I32  ][ I32  ] is OK
 562
 563 lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)]
 564 -- Variables are dead across calls, so invalidating all mappings is justified
 565 lastAssignment (Plain (CmmCall _ (Just k) _ _ _)) assign = [(k, mapUFM (const NeverOptimize) assign)]
 566 lastAssignment (Plain (CmmForeignCall {succ=k}))  assign = [(k, mapUFM (const NeverOptimize) assign)]
 567 lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l
 568
 569 assignmentTransfer :: FwdTransfer (WithRegUsage CmmNode) AssignmentMap
 570 assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase assignmentLattice .) . lastAssignment)
 571
 572 assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap
 573 assignmentRewrite = mkFRewrite3 first middle last
 574     where
 575         first _ _ = return Nothing
 576         middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O
 577         middle (Plain m) assign = return $ rewrite assign (precompute assign m) mkMiddle m
 578         middle (AssignLocal l e u) assign = return $ rewriteLocal assign (precompute assign (CmmAssign (CmmLocal l) e)) mkMiddle l e u
 579         last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l
 580         -- Tuple is (inline?, reloads)
 581         precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless
 582             where f (i, l) r = case lookupUFM assign r of
 583                                 Just (AlwaysSink e)   -> (i, (Plain (CmmAssign (CmmLocal r) e)):l)
 584                                 Just (AlwaysInline _) -> (True, l)
 585                                 Just NeverOptimize    -> (i, l)
 586                                 -- This case can show up when we have
 587                                 -- limited optimization fuel.
 588                                 Nothing -> (i, l)
 589         rewrite _ (False, []) _ _ = Nothing
 590         -- Note [CmmCall Inline Hack]
 591         -- ToDo: Conservative hack: don't do any inlining on CmmCalls, since
 592         -- the code produced here tends to be unproblematic and I need
 593         -- to write lint passes to ensure that we don't put anything in
 594         -- the arguments that could be construed as a global register by
 595         -- some later translation pass.  (For example, slots will turn
 596         -- into dereferences of Sp).  This is the same hack in spirit as
 597         -- was in cmm/CmmOpt.hs.  Fix this up to only bug out if certain
 598         -- CmmExprs are involved.
 599         -- ToDo: We miss an opportunity here, where all possible
 600         -- inlinings should instead be sunk.
 601         rewrite _ (True, []) _ n | not (inlinable n) = Nothing -- see [CmmCall Inline Hack]
 602         rewrite assign (i, xs) mk n = Just $ mkMiddles xs <*> mk (Plain (inline i assign n))
 603
 604         rewriteLocal _ (False, []) _ _ _ _ = Nothing
 605         rewriteLocal assign (i, xs) mk l e u = Just $ mkMiddles xs <*> mk n'
 606             where n' = AssignLocal l e' u
 607                   e' = if i then wrapRecExp (inlineExp assign) e else e
 608             -- inlinable check omitted, since we can always inline into
 609             -- assignments.
 610
 611         inline :: Bool -> AssignmentMap -> CmmNode e x -> CmmNode e x
 612         inline False _ n = n
 613         inline True  _ n | not (inlinable n) = n -- see [CmmCall Inline Hack]
 614         inline True assign n = mapExpDeep (inlineExp assign) n
 615
 616         inlineExp assign old@(CmmReg (CmmLocal r))
 617           = case lookupUFM assign r of
 618               Just (AlwaysInline x) -> x
 619               _ -> old
 620         inlineExp assign old@(CmmRegOff (CmmLocal r) i)
 621           = case lookupUFM assign r of
 622               Just (AlwaysInline x) ->
 623                 case x of
 624                     (CmmRegOff r' i') -> CmmRegOff r' (i + i')
 625                     _ -> CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
 626                           where rep = typeWidth (localRegType r)
 627               _ -> old
 628         inlineExp _ old = old
 629
 630         inlinable :: CmmNode e x -> Bool
 631         inlinable (CmmCall{}) = False
 632         inlinable (CmmForeignCall{}) = False
 633         inlinable _ = True
 634
 635 rewriteAssignments :: CmmGraph -> FuelUniqSM CmmGraph
 636 rewriteAssignments g = do
 637   g'  <- annotateUsage g
 638   g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
 639                                      analRewFwd assignmentLattice assignmentTransfer assignmentRewrite
 640   return (modifyGraph eraseRegUsage g'')
 641
 642 ---------------------
 643 -- prettyprinting
 644
 645 ppr_regs :: String -> RegSet -> SDoc
 646 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 647   where commafy xs = hsep $ punctuate comma xs
 648
 649 instance Outputable DualLive where
 650   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 651       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 652           text "<nothing-live>"
 653       else
 654           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 655                          else (ppr_regs "live in regs =" regs),
 656                          if isEmptyUniqSet stack then PP.empty
 657                          else (ppr_regs "live on stack =" stack)]
 658
 659 -- ToDo: Outputable instance for UsageMap and AssignmentMap
 660
 661 my_trace :: String -> SDoc -> a -> a
 662 my_trace = if False then pprTrace else \_ _ a -> a
 663
 664 f4sep :: [SDoc] -> SDoc
 665 f4sep [] = fsep []
 666 f4sep (d:ds) = fsep (d : map (nest 4) ds)