compiler/cmm/StackPlacements.hs

   1
   2 module StackPlacements
   3   ( SlotSet, allStackSlots  -- the infinite set of stack slots
   4   , SlotClass(..), slotClassBits, stackSlot32, stackSlot64, stackSlot128
   5   , allSlotClasses
   6   , getStackSlot, extendSlotSet, deleteFromSlotSet, elemSlotSet, chooseSlot
   7   , StackPlacement(..)
   8   )
   9 where
  10
  11 import Maybes
  12 import Outputable
  13 import Unique
  14
  15 import Prelude hiding (pi)
  16 import Data.List
  17
  18 {-
  19
  20 The goal here is to provide placements on the stack that will allow,
  21 for example, two 32-bit words to spill to a slot previously used by a
  22 64-bit floating-point value.  I use a simple buddy-system allocator
  23 that splits large slots in half as needed; this will work fine until
  24 the day when somebody wants to spill an 80-bit Intel floating-point
  25 register into the Intel standard 96-bit stack slot.
  26
  27 -}
  28
  29 data SlotClass = SlotClass32 | SlotClass64 | SlotClass128
  30   deriving (Eq)
  31
  32 instance Uniquable SlotClass where
  33     getUnique = getUnique . slotClassBits
  34
  35 instance Outputable SlotClass where
  36     ppr cls = text "class of" <+> int (slotClassBits cls) <> text "-bit stack slots"
  37
  38 slotClassBits :: SlotClass -> Int
  39 slotClassBits SlotClass32 = 32
  40 slotClassBits SlotClass64 = 64
  41 slotClassBits SlotClass128 = 128
  42
  43 data StackPlacement = FullSlot SlotClass Int
  44                | YoungHalf StackPlacement
  45                | OldHalf StackPlacement
  46   deriving (Eq)
  47
  48 data OneSize = OneSize { full_slots :: [StackPlacement], fragments :: [StackPlacement] }
  49   -- ^ Always used for slots that have been previously used
  50
  51 data SlotSet = SlotSet { s32, s64, s128 :: OneSize, next_unused :: Int }
  52
  53 allStackSlots :: SlotSet
  54 allStackSlots = SlotSet empty empty empty 0
  55     where empty = OneSize [] []
  56
  57
  58 psize :: StackPlacement -> Int
  59 psize (FullSlot cls _) = slotClassBits cls
  60 psize (YoungHalf p) = psize p `div` 2
  61 psize (OldHalf   p) = psize p `div` 2
  62
  63
  64
  65
  66 -- | Get a slot no matter what
  67 get32, get64, get128 :: SlotSet -> (StackPlacement, SlotSet)
  68
  69 -- | Get a previously used slot if one exists
  70 getu32, getu64, getu128 :: SlotSet -> Maybe (StackPlacement, SlotSet)
  71
  72 -- | Only supported slot classes
  73
  74 stackSlot32, stackSlot64, stackSlot128 :: SlotClass
  75 stackSlot32  = SlotClass32
  76 stackSlot64  = SlotClass64
  77 stackSlot128 = SlotClass128
  78
  79 allSlotClasses :: [SlotClass]
  80 allSlotClasses = [stackSlot32, stackSlot64, stackSlot128]
  81
  82 -- | Get a fresh slot, never before used
  83 getFull :: SlotClass -> SlotSet -> (StackPlacement, SlotSet)
  84
  85 infixr 4 |||
  86
  87 (|||) :: (SlotSet -> Maybe (StackPlacement, SlotSet)) ->
  88          (SlotSet ->       (StackPlacement, SlotSet)) ->
  89          (SlotSet ->       (StackPlacement, SlotSet))
  90
  91 f1 ||| f2 = \slots -> f1 slots `orElse`   f2 slots
  92
  93 getFull cls slots = (FullSlot cls n, slots { next_unused = n + 1 })
  94     where n = next_unused slots
  95
  96 get32  = getu32  ||| (fmap split64  . getu64)  ||| getFull stackSlot32
  97 get64  = getu64  ||| (fmap split128 . getu128) ||| getFull stackSlot64
  98 get128 = getu128 ||| getFull stackSlot128
  99
 100 type SizeGetter = SlotSet -> OneSize
 101 type SizeSetter = OneSize -> SlotSet -> SlotSet
 102
 103 upd32, upd64, upd128 :: SizeSetter
 104 upd32  this_size slots = slots { s32  = this_size }
 105 upd64  this_size slots = slots { s64  = this_size }
 106 upd128 this_size slots = slots { s128 = this_size }
 107
 108 with_size :: Int -> (SizeGetter -> SizeSetter -> a) -> a
 109 with_size  32 = with_32
 110 with_size  64 = with_64
 111 with_size 128 = with_128
 112 with_size _   = panic "non-standard slot size -- error in size computation?"
 113
 114 with_32, with_64, with_128 :: (SizeGetter -> SizeSetter -> a) -> a
 115 with_32  f = f s32  upd32
 116 with_64  f = f s64  upd64
 117 with_128 f = f s128 upd128
 118
 119 getu32  = with_32  getUsed
 120 getu64  = with_64  getUsed
 121 getu128 = with_128 getUsed
 122
 123 getUsed :: SizeGetter -> SizeSetter -> SlotSet -> Maybe (StackPlacement, SlotSet)
 124 getUsed get set slots =
 125     let this_size = get slots in
 126     case full_slots this_size of
 127       p : ps -> Just (p, set (this_size { full_slots = ps }) slots)
 128       [] -> case fragments this_size of
 129               p : ps -> Just (p, set (this_size { fragments = ps }) slots)
 130               [] -> Nothing
 131
 132 -- | When splitting, allocate the old half first in case it makes the
 133 -- stack smaller at a call site.
 134 split64, split128 :: (StackPlacement, SlotSet) -> (StackPlacement, SlotSet)
 135 split64  (p, slots) = (OldHalf p, slots { s32 = cons_frag (YoungHalf p) (s32 slots) })
 136 split128 (p, slots) = (OldHalf p, slots { s64 = cons_frag (YoungHalf p) (s64 slots) })
 137
 138 cons_frag :: StackPlacement -> OneSize -> OneSize
 139 cons_frag p this_size = this_size { fragments = p : fragments this_size }
 140
 141
 142 ----------------------------
 143 instance Outputable StackPlacement where
 144   ppr (FullSlot cls n) = int (slotClassBits cls) <> text "-bit slot " <> int n
 145   ppr (YoungHalf p) = text "young half of" <+> ppr p
 146   ppr (OldHalf   p) = text "old half of"   <+> ppr p
 147
 148 instance Outputable SlotSet where
 149   ppr slots = fsep $ punctuate comma
 150               (pprSlots (s32 slots) ++ pprSlots (s64 slots) ++ pprSlots (s128 slots) ++
 151                [text "and slots numbered" <+> int (next_unused slots)
 152                          <+> text "and up"])
 153    where pprSlots (OneSize w fs) = map ppr w ++ map ppr fs
 154
 155 {-
 156 instance ColorSet SlotSet SlotClass StackPlacement where
 157   emptyColorSet = panic "The set of stack slots is never empty"
 158   deleteFromColorSet = deleteFromSlotSet
 159   extendColorSet slots (cls, p@(FullSlot {})) =
 160       with_size (slotClassBits cls) add_full p (pi slots)
 161   extendColorSet slots (cls, p) = with_size (slotClassBits cls) add_frag p (pi slots)
 162   chooseColor        = chooseSlot
 163 -}
 164
 165 deleteFromSlotSet :: StackPlacement -> SlotSet -> SlotSet
 166 deleteFromSlotSet p@(FullSlot {}) slots = with_size (psize p) remove_full p (pi slots)
 167 deleteFromSlotSet p               slots = with_size (psize p) remove_frag p (pi slots)
 168
 169 extendSlotSet :: SlotSet -> StackPlacement -> SlotSet
 170 extendSlotSet slots p@(FullSlot {}) = with_size (psize p) add_full p (pi slots)
 171 extendSlotSet slots p               = with_size (psize p) add_frag p (pi slots)
 172
 173 elemSlotSet :: StackPlacement -> SlotSet -> Bool
 174 elemSlotSet p@(FullSlot {}) slots = with_size (psize p) elem_full p slots
 175 elemSlotSet p               slots = with_size (psize p) elem_frag p slots
 176
 177 remove_full, remove_frag, add_full, add_frag
 178     :: SizeGetter -> SizeSetter -> StackPlacement -> SlotSet -> SlotSet
 179
 180 remove_full get set p slots = set p' slots
 181     where this_size = get slots
 182           p' = this_size { full_slots = delete p $ full_slots this_size }
 183
 184 remove_frag get set p slots = set p' slots
 185     where this_size = get slots
 186           p' = this_size { full_slots = delete p $ full_slots this_size }
 187
 188 add_full get set p slots = set p' slots
 189     where this_size = get slots
 190           p' = this_size { full_slots = add p $ full_slots this_size }
 191
 192 add_frag get set p slots = set p' slots
 193     where this_size = get slots
 194           p' = this_size { full_slots = add p $ full_slots this_size }
 195
 196 add :: Eq a => a -> [a] -> [a]
 197 add x xs = if notElem x xs then x : xs else xs
 198
 199 elem_full, elem_frag :: SizeGetter -> SizeSetter -> StackPlacement -> SlotSet -> Bool
 200 elem_full get _set p slots = elem p (full_slots $ get slots)
 201 elem_frag get _set p slots = elem p (fragments  $ get slots)
 202
 203
 204
 205
 206 getStackSlot :: SlotClass -> SlotSet -> (StackPlacement, SlotSet)
 207 getStackSlot cls slots =
 208   case cls of
 209     SlotClass32  -> get32  (pi slots)
 210     SlotClass64  -> get64  (pi slots)
 211     SlotClass128 -> get128 (pi slots)
 212
 213
 214 chooseSlot :: SlotClass -> [StackPlacement] -> SlotSet -> Maybe (StackPlacement, SlotSet)
 215 chooseSlot cls prefs slots =
 216   case filter (flip elemSlotSet slots) prefs of
 217     placement : _ -> Just (placement, deleteFromSlotSet placement (pi slots))
 218     [] -> Just (getStackSlot cls slots)
 219
 220 check_invariant :: Bool
 221 check_invariant = True
 222
 223 pi :: SlotSet -> SlotSet
 224 pi = if check_invariant then panic_on_invariant_violation else id
 225
 226 panic_on_invariant_violation :: SlotSet -> SlotSet
 227 panic_on_invariant_violation slots =
 228     check 32 (s32 slots) $ check 64 (s64 slots) $ check 128 (s128 slots) $ slots
 229   where n = next_unused slots
 230         check bits this_size = (check_full bits $ full_slots this_size) .
 231                                (check_frag bits $ fragments  this_size)
 232         check_full _ [] = id
 233         check_full bits (FullSlot cls k : ps) =
 234             if slotClassBits cls /= bits then panic "slot in bin of wrong size"
 235             else if k >= n then panic "slot number is unreasonably fresh"
 236                  else check_full bits ps
 237         check_full _ _ = panic "a fragment is in a bin reserved for full slots"
 238         check_frag _ [] = id
 239         check_frag _ (FullSlot {} : _) =
 240             panic "a full slot is in a bin reserved for fragments"
 241         check_frag bits (p : ps) =
 242             if bits /= psize p then panic "slot in bin of wrong size"
 243             else if pnumber p >= n then panic "slot number is unreasonably fresh"
 244                  else check_frag bits ps
 245         pnumber (FullSlot _ k) = k
 246         pnumber (YoungHalf p) = pnumber p
 247         pnumber (OldHalf p)   = pnumber p
 248