compiler/cmm/StackColor.hs

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