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