X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FStackPlacements.hs;fp=compiler%2Fcmm%2FStackPlacements.hs;h=0000000000000000000000000000000000000000;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hp=5cac288573fa3e4299e9e9230b160db8bee4df1e;hpb=f1a90f54590e5a7a32a9c3ef2950740922b1f425;p=ghc-hetmet.git diff --git a/compiler/cmm/StackPlacements.hs b/compiler/cmm/StackPlacements.hs deleted file mode 100644 index 5cac288..0000000 --- a/compiler/cmm/StackPlacements.hs +++ /dev/null @@ -1,248 +0,0 @@ - -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 -