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 l env
  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 m out) (f out z)
  33     head_fold (ZFirst id) out z = f (bt_first_in comp id out) (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