compiler/cmm/StackColor.hs

   1
   2 module StackColor where
   3
   4 import BlockId
   5 import StackPlacements
   6 import qualified GraphColor as Color
   7 import CmmExpr
   8 import CmmSpillReload
   9 import DFMonad
  10 import qualified GraphOps
  11 import ZipCfg
  12 import ZipCfgCmmRep
  13 import ZipDataflow
  14
  15 import Maybes
  16 import Panic
  17 import UniqSet
  18
  19 import Data.List
  20
  21 fold_edge_facts_b ::
  22   LastNode l => (DualLive -> a -> a) -> BackwardTransfers m l DualLive -> LGraph m l
  23                                      -> (BlockId -> DualLive) -> a -> a
  24 fold_edge_facts_b f comp graph env z =
  25     foldl fold_block_facts z (postorder_dfs graph)
  26   where
  27     fold_block_facts z b =
  28       let (h, l) = goto_end (ZipCfg.unzip b)
  29           last_in _ LastExit = fact_bot dualLiveLattice
  30           last_in env (LastOther l) = bt_last_in comp env l
  31       in head_fold h (last_in env l) z
  32     head_fold (ZHead h m)   out z = head_fold h (bt_middle_in comp out m) (f out z)
  33     head_fold (ZFirst id _) out z = f (bt_first_in comp out id) (f out z)
  34
  35 foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a
  36 foldConflicts f z g@(LGraph entry _ _) =
  37   do env <- dualLiveness emptyBlockSet g
  38      let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
  39          f' dual z = f (on_stack dual) z
  40      return $ fold_edge_facts_b f' (dualLiveTransfers entry emptyBlockSet) g lookup z
  41   --let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts)
  42   --    lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
  43   --    f' dual z = f (on_stack dual) z
  44   --in  fold_edge_facts_b f' dualLiveness g lookup z
  45
  46
  47 type IGraph = Color.Graph LocalReg SlotClass StackPlacement
  48 type ClassCount = [(SlotClass, Int)]
  49
  50 buildIGraphAndCounts :: LGraph Middle Last -> FuelMonad (IGraph, ClassCount)
  51 buildIGraphAndCounts g = igraph_and_counts
  52     where igraph_and_counts = foldConflicts add (Color.initGraph, zero) g
  53           zero = map (\c -> (c, 0)) allSlotClasses
  54           add live (igraph, counts) = (graphAddConflictSet live igraph,
  55                                        addSimulCounts (classCounts live) counts)
  56           addSimulCounts =
  57             zipWith (\(c, n) (c', n') -> if c == c' then (c, max n n')
  58                                          else panic "slot classes out of order")
  59           classCounts regs = foldUniqSet addReg zero regs
  60           addReg reg counts =
  61               let cls = slotClass reg in
  62               map (\(c, n) -> (c, if c == cls then n + 1 else n)) counts
  63
  64
  65 -- | Add some conflict edges to the graph.
  66 --      Conflicts between virtual and real regs are recorded as exclusions.
  67 --
  68
  69 graphAddConflictSet :: RegSet -> IGraph -> IGraph
  70 graphAddConflictSet set graph = GraphOps.addConflicts set slotClass graph
  71
  72 slotClass :: LocalReg -> SlotClass
  73 slotClass (LocalReg _ ty) =
  74     case typeWidth ty of -- the horror, the horror
  75       W8   -> SlotClass32
  76       W16  -> SlotClass32
  77       W32  -> SlotClass32
  78       W64  -> SlotClass64
  79       W128 -> SlotClass128
  80       W80  -> SlotClass64
  81
  82 {-
  83 colorMe :: (IGraph, ClassCount) -> (IGraph, UniqSet LocalReg)
  84 colorMe (igraph, counts) = Color.colorGraph starter_colors triv spill_max_degree igraph
  85     where starter_colors = allocate [] counts allStackSlots
  86           allocate prev [] colors = insert prev colors
  87           allocate prev ((c, n) : counts) colors =
  88               let go prev 0 colors = allocate prev counts colors
  89                   go prev n colors = let (p, colors') = getStackSlot c colors in
  90                                      go (p:prev) (n-1) colors'
  91               in  go prev n colors
  92           insert :: [StackPlacement] -> SlotSet -> SlotSet
  93           insert [] colors = colors
  94           insert (p:ps) colors = insert ps (extendSlotSet colors p)
  95           triv :: Color.Triv LocalReg SlotClass StackPlacement
  96           triv = trivColorable (mkSizeOf counts)
  97
  98 spill_max_degree :: IGraph -> LocalReg
  99 spill_max_degree igraph = Color.nodeId node
 100     where node  = maximumBy (\n1 n2 -> compare
 101                                 (sizeUniqSet $ Color.nodeConflicts n1)
 102                                 (sizeUniqSet $ Color.nodeConflicts n2)) $
 103                   eltsUFM $ Color.graphMap igraph
 104
 105
 106 type Worst = SlotClass -> (Int, Int, Int) -> Int
 107
 108 trivColorable :: (SlotClass -> Int) ->
 109                  SlotClass -> UniqSet LocalReg -> UniqSet StackPlacement -> Bool
 110 trivColorable sizeOf classN conflicts exclusions = squeeze < sizeOf classN
 111   where squeeze = worst classN counts
 112         counts   = if isEmptyUniqSet exclusions then foldUniqSet acc zero conflicts
 113                    else panic "exclusions in stack slots?!"
 114         zero = (0, 0, 0)
 115         acc r (word, dbl, quad) =
 116             case slotClass r of
 117               SlotClass32  -> (word+1, dbl, quad)
 118               SlotClass64  -> (word, dbl+1, quad)
 119               SlotClass128 -> (word, dbl, quad+1)
 120         worst SlotClass128 (_, _, q) = q
 121         worst SlotClass64  (_, d, q) = d + 2 * q
 122         worst SlotClass32  (w, d, q) = w + 2 * d + 4 * q
 123 -}
 124
 125 -- | number of placements available is from class and all larger classes
 126 mkSizeOf :: ClassCount -> (SlotClass -> Int)
 127 mkSizeOf counts = sizeOf
 128     where sizeOf SlotClass32  = n32
 129           sizeOf SlotClass64  = n64
 130           sizeOf SlotClass128 = n128
 131           n128 = (lookup SlotClass128 counts `orElse` 0)
 132           n64  = (lookup SlotClass64  counts `orElse` 0) + 2 * n128
 133           n32  = (lookup SlotClass32  counts `orElse` 0) + 2 * n32