--- /dev/null
+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+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