X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmStackLayout.hs;h=df1b89c9ba54d32423381f84f029a7663eb9647f;hp=be16f19c06246a73c75906f9c79e2c37964e2e8b;hb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2 diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs index be16f19..df1b89c 100644 --- a/compiler/cmm/CmmStackLayout.hs +++ b/compiler/cmm/CmmStackLayout.hs @@ -1,3 +1,7 @@ +{-# OPTIONS_GHC -XNoMonoLocalBinds #-} +-- Norman likes local bindings +-- If this module lives on I'd like to get rid of this flag in due course + module CmmStackLayout ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs , layout, manifestSP, igraph, areaBuilder @@ -12,11 +16,10 @@ import CmmExpr import CmmProcPointZ import CmmTx import DFMonad -import FiniteMap import Maybes import MkZipCfg import MkZipCfgCmm hiding (CmmBlock, CmmGraph) -import Monad +import Control.Monad import Outputable import SMRep (ByteOff) import ZipCfg @@ -24,6 +27,10 @@ import ZipCfg as Z import ZipCfgCmmRep import ZipDataflow +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map + ------------------------------------------------------------------------ -- Stack Layout -- ------------------------------------------------------------------------ @@ -57,16 +64,18 @@ import ZipDataflow -- a single slot, on insertion. slotLattice :: DataflowLattice SubAreaSet -slotLattice = DataflowLattice "live slots" emptyFM add False - where add new old = case foldFM addArea (False, old) new of +slotLattice = DataflowLattice "live slots" Map.empty add False + where add new old = case Map.foldRightWithKey addArea (False, old) new of (True, x) -> aTx x (False, x) -> noTx x addArea a newSlots z = foldr (addSlot a) z newSlots addSlot a slot (changed, map) = - let (c, live) = liveGen slot $ lookupWithDefaultFM map [] a - in (c || changed, addToFM map a live) + let (c, live) = liveGen slot $ Map.findWithDefault [] a map + in (c || changed, Map.insert a live map) type SlotEnv = BlockEnv SubAreaSet + -- The sub-areas live on entry to the block + type SlotFix a = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet a) liveSlotAnal :: LGraph Middle Last -> FuelMonad SlotEnv @@ -114,17 +123,17 @@ liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $ liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet liveSlotTransfers = BackwardTransfers first liveInSlots liveLastIn - where first id live = delFromFM live (CallArea (Young id)) + where first id live = Map.delete (CallArea (Young id)) live -- Slot sets: adding slots, removing slots, and checking for membership. liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet addSlot, removeSlot :: SubAreaSet -> SubArea -> SubAreaSet elemSlot :: SubAreaSet -> SubArea -> Bool -liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a) +liftToArea a f map = Map.insert a (f (Map.findWithDefault [] a map)) map addSlot live (a, i, w) = liftToArea a (snd . liveGen (a, i, w)) live removeSlot live (a, i, w) = liftToArea a (liveKill (a, i, w)) live elemSlot live (a, i, w) = - not $ fst $ liveGen (a, i, w) (lookupWithDefaultFM live [] a) + not $ fst $ liveGen (a, i, w) (Map.findWithDefault [] a live) removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet removeLiveSlotDefs = foldSlotsDefd removeSlot @@ -155,7 +164,7 @@ liveLastOut env l = where out = joinOuts slotLattice env l add_area _ n live | n == 0 = live add_area a n live = - addToFM live a $ snd $ liveGen (a, n, n) $ lookupWithDefaultFM live [] a + Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live -- The liveness analysis must be precise: otherwise, we won't know if a definition -- should really kill a live-out stack slot. @@ -166,7 +175,7 @@ liveLastOut env l = -- every time, I provide a function to fold over the nodes, which should be a -- reasonably efficient approach for the implementations we envision. -- Of course, it will probably be much easier to program if we just return a list... -type Set x = FiniteMap x () +type Set x = Map x () data IGraphBuilder n = Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int] @@ -176,8 +185,8 @@ areaBuilder :: IGraphBuilder Area areaBuilder = Builder fold words where fold (a, _, _) f z = f a z words areaSize areaMap a = - case lookupFM areaMap a of - Just addr -> [addr .. addr + (lookupFM areaSize a `orElse` + case Map.lookup a areaMap of + Just addr -> [addr .. addr + (Map.lookup a areaSize `orElse` pprPanic "wordsOccupied: unknown area" (ppr a))] Nothing -> [] @@ -187,10 +196,10 @@ areaBuilder = Builder fold words -- Now, we can build the interference graph. -- The usual story: a definition interferes with all live outs and all other -- definitions. -type IGraph x = FiniteMap x (Set x) +type IGraph x = Map x (Set x) type IGPair x = (IGraph x, IGraphBuilder x) igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> LGraph Middle Last -> IGraph x -igraph builder env g = foldr interfere emptyFM (postorder_dfs g) +igraph builder env g = foldr interfere Map.empty (postorder_dfs g) where foldN = foldNodes builder interfere block igraph = let (h, l) = goto_end (unzip block) @@ -202,15 +211,15 @@ igraph builder env g = foldr interfere emptyFM (postorder_dfs g) addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i addDef (igraph, out) def@(a, _, _) = (foldN def (addDefN out) igraph, - addToFM out a (snd $ liveGen def (lookupWithDefaultFM out [] a))) + Map.insert a (snd $ liveGen def (Map.findWithDefault [] a out)) out) addDefN out n igraph = let addEdgeNO o igraph = foldN o addEdgeNN igraph addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph - addEdgeNN' n n' igraph = addToFM igraph n (addToFM set n' ()) - where set = lookupWithDefaultFM igraph emptyFM n - in foldFM (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out + addEdgeNN' n n' igraph = Map.insert n (Map.insert n' () set) igraph + where set = Map.findWithDefault Map.empty n igraph + in Map.foldRightWithKey (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph" - in heads h $ case l of LastExit -> (igraph, emptyFM) + in heads h $ case l of LastExit -> (igraph, Map.empty) LastOther l -> (addEdges igraph l $ liveLastOut env' l, liveLastIn l env') @@ -218,9 +227,11 @@ igraph builder env g = foldr interfere emptyFM (postorder_dfs g) -- what's the highest offset (in bytes) used in each Area? -- We'll need to allocate that much space for each Area. getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap + -- The domain of the returned mapping consists only of Areas + -- used for (a) variable spill slots, and (b) parameter passing ares for calls getAreaSize entry_off g@(LGraph _ _) = fold_blocks (fold_fwd_block first add_regslots last) - (unitFM (CallArea Old) entry_off) g + (Map.singleton (CallArea Old) entry_off) g where first _ z = z last l@(LastOther (LastCall _ Nothing args res _)) z = add_regslots l (add (add z area args) area res) @@ -233,25 +244,28 @@ getAreaSize entry_off g@(LGraph _ _) = addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) = add z a $ widthInBytes $ typeWidth ty addSlot z _ = z - add z a off = addToFM z a (max off (lookupWithDefaultFM z 0 a)) + add z a off = Map.insert a (max off (Map.findWithDefault 0 a z)) z + -- The 'max' is important. Two calls, to f and g, might share a common + -- continuation (and hence a common CallArea), but their number of overflow + -- parameters might differ. -- Find the Stack slots occupied by the subarea's conflicts conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea = - foldNodes subarea foldNode emptyFM - where foldNode n set = foldFM conflict set $ lookupWithDefaultFM ig emptyFM n + foldNodes subarea foldNode Map.empty + where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig conflict n' () set = liveInSlots areaMap n' set -- Add stack slots occupied by igraph node n liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n) - setAdd w s = addToFM s w () + setAdd w s = Map.insert w () s -- Find any open space on the stack, starting from the offset. -- If the area is a CallArea or a spill slot for a pointer, then it must -- be word-aligned. freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int freeSlotFrom ig areaSize offset areaMap area = - let size = lookupFM areaSize area `orElse` 0 + let size = Map.lookup area areaSize `orElse` 0 conflicts = conflictSlots ig areaSize areaMap (area, size, size) -- CallAreas and Ptrs need to be word-aligned (round up!) align = case area of CallArea _ -> align' @@ -261,7 +275,7 @@ freeSlotFrom ig areaSize offset areaMap area = -- Find a space big enough to hold the area findSpace curr 0 = curr findSpace curr cnt = -- part of target slot, # of bytes left to check - if elemFM curr conflicts then + if Map.member curr conflicts then findSpace (align (curr + size)) size -- try the next (possibly) open space else findSpace (curr - 1) (cnt - 1) in findSpace (align (offset + size)) size @@ -269,25 +283,36 @@ freeSlotFrom ig areaSize offset areaMap area = -- Find an open space on the stack, and assign it to the area. allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap allocSlotFrom ig areaSize from areaMap area = - if elemFM area areaMap then areaMap - else addToFM areaMap area $ freeSlotFrom ig areaSize from areaMap area + if Map.member area areaMap then areaMap + else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap -- | Greedy stack layout. -- Compute liveness, build the interference graph, and allocate slots for the areas. -- We visit each basic block in a (generally) forward order. + -- At each instruction that names a register subarea r, we immediately allocate -- any available slot on the stack by the following procedure: --- 1. Find the nodes N' that conflict with r --- 2. Find the stack slots used for N' --- 3. Choose a contiguous stack space s not in N' (s must be large enough to hold r) +-- 1. Find the sub-areas S that conflict with r +-- 2. Find the stack slots used for S +-- 3. Choose a contiguous stack space s not in S (s must be large enough to hold r) + -- For a CallArea, we allocate the stack space only when we reach a function -- call that returns to the CallArea's blockId. --- We use a similar procedure, with one exception: the stack space --- must be allocated below the youngest stack slot that is live out. +-- Then, we allocate the Area subject to the following constraints: +-- a) It must be younger than all the sub-areas that are live on entry to the block +-- This constraint is only necessary for the successor of a call +-- b) It must not overlap with any already-allocated Area with which it conflicts +-- (ie at some point, not necessarily now, is live at the same time) +-- Part (b) is just the 1,2,3 part above -- Note: The stack pointer only has to be younger than the youngest live stack slot -- at proc points. Otherwise, the stack pointer can point anywhere. + layout :: ProcPointSet -> SlotEnv -> ByteOff -> LGraph Middle Last -> AreaMap +-- The domain of the returned map includes an Area for EVERY block +-- including each block that is not the successor of a call (ie is not a proc-point) +-- That's how we return the info of what the SP should be at the entry of every block + layout procPoints env entry_off g = let ig = (igraph areaBuilder env g, areaBuilder) env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph" @@ -295,18 +320,25 @@ layout procPoints env entry_off g = -- Find the slots that are live-in to a block tail live_in (ZTail m l) = liveInSlots m (live_in l) live_in (ZLast (LastOther l)) = liveLastIn l env' - live_in (ZLast LastExit) = emptyFM - -- Find the youngest live stack slot + live_in (ZLast LastExit) = Map.empty + + -- Find the youngest live stack slot that has already been allocated + youngest_live :: AreaMap -- Already allocated + -> SubAreaSet -- Sub-areas live here + -> ByteOff -- Offset of the youngest byte of any + -- already-allocated, live sub-area youngest_live areaMap live = fold_subareas young_slot live 0 - where young_slot (a, o, _) z = case lookupFM areaMap a of + where young_slot (a, o, _) z = case Map.lookup a areaMap of Just top -> max z $ top + o Nothing -> z - fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m + fold_subareas f m z = Map.foldRightWithKey (\_ s z -> foldr f z s) z m + -- Allocate space for spill slots and call areas allocVarSlot = allocSlotFrom ig areaSize 0 + -- Update the successor's incoming SP. setSuccSPs inSp bid areaMap = - case (lookupFM areaMap area, lookupBlockEnv (lg_blocks g) bid) of + case (Map.lookup area areaMap, lookupBlockEnv (lg_blocks g) bid) of (Just _, _) -> areaMap -- succ already knows incoming SP (Nothing, Just (Block _ _)) -> if elemBlockSet bid procPoints then @@ -316,27 +348,31 @@ layout procPoints env entry_off g = start = young -- maybe wrong, but I don't understand -- why the preceding is necessary... in allocSlotFrom ig areaSize start areaMap area - else addToFM areaMap area inSp + else Map.insert area inSp areaMap (_, Nothing) -> panic "Block not found in cfg" where area = CallArea (Young bid) + allocLast (Block id _) areaMap l = fold_succs (setSuccSPs inSp) l areaMap - where inSp = expectJust "sp in" $ lookupFM areaMap (CallArea (Young id)) - allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap = + where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap + + allocMidCall m@(MidForeignCall (Safe bid _ _) _ _ _) t areaMap = let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m area = CallArea (Young bid) - areaSize' = addToFM areaSize area (widthInBytes (typeWidth gcWord)) + areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize in allocSlotFrom ig areaSize' young areaMap area allocMidCall _ _ areaMap = areaMap + alloc m t areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' (allocMidCall m t areaMap) m) m where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a alloc' areaMap _ = areaMap + layoutAreas areaMap b@(Block _ t) = layout areaMap t where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t layout areaMap (ZLast l) = allocLast b areaMap l - initMap = addToFM (addToFM emptyFM (CallArea Old) 0) - (CallArea (Young (lg_entry g))) 0 + initMap = Map.insert (CallArea (Young (lg_entry g))) 0 + (Map.insert (CallArea Old) 0 Map.empty) areaMap = foldl layoutAreas initMap (postorder_dfs g) in -- pprTrace "ProcPoints" (ppr procPoints) $ -- pprTrace "Area SizeMap" (ppr areaSize) $ @@ -357,7 +393,7 @@ manifestSP :: AreaMap -> ByteOff -> LGraph Middle Last -> FuelMonad (LGraph Midd manifestSP areaMap entry_off g@(LGraph entry _blocks) = liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g) where slot a = -- pprTrace "slot" (ppr a) $ - lookupFM areaMap a `orElse` panic "unallocated Area" + Map.lookup a areaMap `orElse` panic "unallocated Area" slot' (Just id) = slot $ CallArea (Young id) slot' Nothing = slot $ CallArea Old sp_high = maxSlot slot g @@ -384,7 +420,7 @@ manifestSP areaMap entry_off g@(LGraph entry _blocks) = where spIn = sp_on_entry id replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) -> FuelMonad ([CmmBlock]) - replTail h spOff (ZTail m@(MidForeignCall (Safe bid _) _ _ _) t) = + replTail h spOff (ZTail m@(MidForeignCall (Safe bid _ _) _ _ _) t) = replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord) replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t