+++ /dev/null
-
-module StackPlacements
- ( SlotSet, allStackSlots -- the infinite set of stack slots
- , 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
-
-{-
-
-The goal here is to provide placements on the stack that will allow,
-for example, two 32-bit words to spill to a slot previously used by a
-64-bit floating-point value. I use a simple buddy-system allocator
-that splits large slots in half as needed; this will work fine until
-the day when somebody wants to spill an 80-bit Intel floating-point
-register into the Intel standard 96-bit stack slot.
-
--}
-
-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] }
- -- ^ Always used for slots that have been previously used
-
-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
-
-
-
-
--- | Get a slot no matter what
-get32, get64, get128 :: SlotSet -> (StackPlacement, SlotSet)
-
--- | Get a previously used slot if one exists
-getu32, getu64, getu128 :: SlotSet -> Maybe (StackPlacement, SlotSet)
-
--- | Only supported slot classes
-
-stackSlot32, stackSlot64, stackSlot128 :: SlotClass
-stackSlot32 = SlotClass32
-stackSlot64 = SlotClass64
-stackSlot128 = SlotClass128
-
-allSlotClasses :: [SlotClass]
-allSlotClasses = [stackSlot32, stackSlot64, stackSlot128]
-
--- | Get a fresh slot, never before used
-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
-
--- | When splitting, allocate the old half first in case it makes the
--- stack smaller at a call site.
-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
-
-{-
-instance ColorSet SlotSet SlotClass StackPlacement where
- emptyColorSet = panic "The set of stack slots is never empty"
- deleteFromColorSet = deleteFromSlotSet
- extendColorSet slots (cls, p@(FullSlot {})) =
- with_size (slotClassBits cls) add_full p (pi slots)
- extendColorSet slots (cls, p) = with_size (slotClassBits cls) add_frag p (pi slots)
- chooseColor = chooseSlot
--}
-
-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
-
projects / ghc-hetmet.git / blobdiff