+#if __GLASGOW_HASKELL__ >= 611
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+#endif
+-- 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
where
import Constants
-import qualified Prelude as P
import Prelude hiding (zip, unzip, last)
import BlockId
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 Panic
import SMRep (ByteOff)
import ZipCfg
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 --
------------------------------------------------------------------------
-- 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
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
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.
-- 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]
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 -> []
-- 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)
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')
-- 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)
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'
-- 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
-- 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"
-- 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
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) $
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
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