module StackPlacements
( SlotSet, allStackSlots
, SlotClass(..), slotClassBits, stackSlot32, stackSlot64, stackSlot128
, allSlotClasses
, getStackSlot, extendSlotSet, deleteFromSlotSet, elemSlotSet, chooseSlot
, StackPlacement(..)
)
where
import Maybes
import Outputable
import Unique
import Prelude hiding (pi)
import Data.List
data SlotClass = SlotClass32 | SlotClass64 | SlotClass128
deriving (Eq)
instance Uniquable SlotClass where
getUnique = getUnique . slotClassBits
instance Outputable SlotClass where
ppr cls = text "class of" <+> int (slotClassBits cls) <> text "-bit stack slots"
slotClassBits :: SlotClass -> Int
slotClassBits SlotClass32 = 32
slotClassBits SlotClass64 = 64
slotClassBits SlotClass128 = 128
data StackPlacement = FullSlot SlotClass Int
| YoungHalf StackPlacement
| OldHalf StackPlacement
deriving (Eq)
data OneSize = OneSize { full_slots :: [StackPlacement], fragments :: [StackPlacement] }
data SlotSet = SlotSet { s32, s64, s128 :: OneSize, next_unused :: Int }
allStackSlots :: SlotSet
allStackSlots = SlotSet empty empty empty 0
where empty = OneSize [] []
psize :: StackPlacement -> Int
psize (FullSlot cls _) = slotClassBits cls
psize (YoungHalf p) = psize p `div` 2
psize (OldHalf p) = psize p `div` 2
get32, get64, get128 :: SlotSet -> (StackPlacement, SlotSet)
getu32, getu64, getu128 :: SlotSet -> Maybe (StackPlacement, SlotSet)
stackSlot32, stackSlot64, stackSlot128 :: SlotClass
stackSlot32 = SlotClass32
stackSlot64 = SlotClass64
stackSlot128 = SlotClass128
allSlotClasses :: [SlotClass]
allSlotClasses = [stackSlot32, stackSlot64, stackSlot128]
getFull :: SlotClass -> SlotSet -> (StackPlacement, SlotSet)
infixr 4 |||
(|||) :: (SlotSet -> Maybe (StackPlacement, SlotSet)) ->
(SlotSet -> (StackPlacement, SlotSet)) ->
(SlotSet -> (StackPlacement, SlotSet))
f1 ||| f2 = \slots -> f1 slots `orElse` f2 slots
getFull cls slots = (FullSlot cls n, slots { next_unused = n + 1 })
where n = next_unused slots
get32 = getu32 ||| (fmap split64 . getu64) ||| getFull stackSlot32
get64 = getu64 ||| (fmap split128 . getu128) ||| getFull stackSlot64
get128 = getu128 ||| getFull stackSlot128
type SizeGetter = SlotSet -> OneSize
type SizeSetter = OneSize -> SlotSet -> SlotSet
upd32, upd64, upd128 :: SizeSetter
upd32 this_size slots = slots { s32 = this_size }
upd64 this_size slots = slots { s64 = this_size }
upd128 this_size slots = slots { s128 = this_size }
with_size :: Int -> (SizeGetter -> SizeSetter -> a) -> a
with_size 32 = with_32
with_size 64 = with_64
with_size 128 = with_128
with_size _ = panic "non-standard slot size -- error in size computation?"
with_32, with_64, with_128 :: (SizeGetter -> SizeSetter -> a) -> a
with_32 f = f s32 upd32
with_64 f = f s64 upd64
with_128 f = f s128 upd128
getu32 = with_32 getUsed
getu64 = with_64 getUsed
getu128 = with_128 getUsed
getUsed :: SizeGetter -> SizeSetter -> SlotSet -> Maybe (StackPlacement, SlotSet)
getUsed get set slots =
let this_size = get slots in
case full_slots this_size of
p : ps -> Just (p, set (this_size { full_slots = ps }) slots)
[] -> case fragments this_size of
p : ps -> Just (p, set (this_size { fragments = ps }) slots)
[] -> Nothing
split64, split128 :: (StackPlacement, SlotSet) -> (StackPlacement, SlotSet)
split64 (p, slots) = (OldHalf p, slots { s32 = cons_frag (YoungHalf p) (s32 slots) })
split128 (p, slots) = (OldHalf p, slots { s64 = cons_frag (YoungHalf p) (s64 slots) })
cons_frag :: StackPlacement -> OneSize -> OneSize
cons_frag p this_size = this_size { fragments = p : fragments this_size }
instance Outputable StackPlacement where
ppr (FullSlot cls n) = int (slotClassBits cls) <> text "-bit slot " <> int n
ppr (YoungHalf p) = text "young half of" <+> ppr p
ppr (OldHalf p) = text "old half of" <+> ppr p
instance Outputable SlotSet where
ppr slots = fsep $ punctuate comma
(pprSlots (s32 slots) ++ pprSlots (s64 slots) ++ pprSlots (s128 slots) ++
[text "and slots numbered" <+> int (next_unused slots)
<+> text "and up"])
where pprSlots (OneSize w fs) = map ppr w ++ map ppr fs
deleteFromSlotSet :: StackPlacement -> SlotSet -> SlotSet
deleteFromSlotSet p@(FullSlot {}) slots = with_size (psize p) remove_full p (pi slots)
deleteFromSlotSet p slots = with_size (psize p) remove_frag p (pi slots)
extendSlotSet :: SlotSet -> StackPlacement -> SlotSet
extendSlotSet slots p@(FullSlot {}) = with_size (psize p) add_full p (pi slots)
extendSlotSet slots p = with_size (psize p) add_frag p (pi slots)
elemSlotSet :: StackPlacement -> SlotSet -> Bool
elemSlotSet p@(FullSlot {}) slots = with_size (psize p) elem_full p slots
elemSlotSet p slots = with_size (psize p) elem_frag p slots
remove_full, remove_frag, add_full, add_frag
:: SizeGetter -> SizeSetter -> StackPlacement -> SlotSet -> SlotSet
remove_full get set p slots = set p' slots
where this_size = get slots
p' = this_size { full_slots = delete p $ full_slots this_size }
remove_frag get set p slots = set p' slots
where this_size = get slots
p' = this_size { full_slots = delete p $ full_slots this_size }
add_full get set p slots = set p' slots
where this_size = get slots
p' = this_size { full_slots = add p $ full_slots this_size }
add_frag get set p slots = set p' slots
where this_size = get slots
p' = this_size { full_slots = add p $ full_slots this_size }
add :: Eq a => a -> [a] -> [a]
add x xs = if notElem x xs then x : xs else xs
elem_full, elem_frag :: SizeGetter -> SizeSetter -> StackPlacement -> SlotSet -> Bool
elem_full get _set p slots = elem p (full_slots $ get slots)
elem_frag get _set p slots = elem p (fragments $ get slots)
getStackSlot :: SlotClass -> SlotSet -> (StackPlacement, SlotSet)
getStackSlot cls slots =
case cls of
SlotClass32 -> get32 (pi slots)
SlotClass64 -> get64 (pi slots)
SlotClass128 -> get128 (pi slots)
chooseSlot :: SlotClass -> [StackPlacement] -> SlotSet -> Maybe (StackPlacement, SlotSet)
chooseSlot cls prefs slots =
case filter (flip elemSlotSet slots) prefs of
placement : _ -> Just (placement, deleteFromSlotSet placement (pi slots))
[] -> Just (getStackSlot cls slots)
check_invariant :: Bool
check_invariant = True
pi :: SlotSet -> SlotSet
pi = if check_invariant then panic_on_invariant_violation else id
panic_on_invariant_violation :: SlotSet -> SlotSet
panic_on_invariant_violation slots =
check 32 (s32 slots) $ check 64 (s64 slots) $ check 128 (s128 slots) $ slots
where n = next_unused slots
check bits this_size = (check_full bits $ full_slots this_size) .
(check_frag bits $ fragments this_size)
check_full _ [] = id
check_full bits (FullSlot cls k : ps) =
if slotClassBits cls /= bits then panic "slot in bin of wrong size"
else if k >= n then panic "slot number is unreasonably fresh"
else check_full bits ps
check_full _ _ = panic "a fragment is in a bin reserved for full slots"
check_frag _ [] = id
check_frag _ (FullSlot {} : _) =
panic "a full slot is in a bin reserved for fragments"
check_frag bits (p : ps) =
if bits /= psize p then panic "slot in bin of wrong size"
else if pnumber p >= n then panic "slot number is unreasonably fresh"
else check_frag bits ps
pnumber (FullSlot _ k) = k
pnumber (YoungHalf p) = pnumber p
pnumber (OldHalf p) = pnumber p