module CmmStackLayout
( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
, layout, manifestSP, igraph, areaBuilder
, stubSlotsOnDeath )
where
import Constants
import Prelude hiding (zip, unzip, last)
import BlockId
import CmmExpr
import CmmProcPointZ
import CmmTx
import DFMonad
import FiniteMap
import Maybes
import MkZipCfg
import MkZipCfgCmm hiding (CmmBlock, CmmGraph)
import Control.Monad
import Outputable
import SMRep (ByteOff)
import ZipCfg
import ZipCfg as Z
import ZipCfgCmmRep
import ZipDataflow
slotLattice :: DataflowLattice SubAreaSet
slotLattice = DataflowLattice "live slots" emptyFM add False
where add new old = case foldFM 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)
type SlotEnv = BlockEnv SubAreaSet
type SlotFix a = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet a)
liveSlotAnal :: LGraph Middle Last -> FuelMonad SlotEnv
liveSlotAnal g = liftM zdfFpFacts (res :: SlotFix ())
where res = zdfSolveFromL emptyBlockEnv "live slot analysis" slotLattice
liveSlotTransfers (fact_bot slotLattice) g
liveGen :: SubArea -> [SubArea] -> (Bool, [SubArea])
liveGen s set = liveGen' s set []
where liveGen' s [] z = (True, s : z)
liveGen' s@(a, hi, w) (s'@(a', hi', w') : rst) z =
if a /= a' || hi < lo' || lo > hi' then
liveGen' s rst (s' : z)
else if s' `contains` s then
(False, set)
else
let new_hi = max hi hi'
new_lo = min lo lo'
in liveGen' (a, new_hi, new_hi new_lo) rst z
where lo = hi w
lo' = hi' w'
contains (a, hi, w) (a', hi', w') =
a == a' && hi >= hi' && hi w <= hi' w'
liveKill :: SubArea -> [SubArea] -> [SubArea]
liveKill (a, hi, w) set =
liveKill' set []
where liveKill' [] z = z
liveKill' (s'@(a', hi', w') : rst) z =
if a /= a' || hi < lo' || lo > hi' then
liveKill' rst (s' : z)
else
let z' = if hi' > hi then (a, hi', hi' hi) : z else z
z'' = if lo > lo' then (a, lo, lo lo') : z' else z'
in liveKill' rst z''
where lo = hi w
lo' = hi' w'
liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet
liveSlotTransfers =
BackwardTransfers first liveInSlots liveLastIn
where first id live = delFromFM live (CallArea (Young id))
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)
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)
removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
removeLiveSlotDefs = foldSlotsDefd removeSlot
liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => s -> SubAreaSet -> SubAreaSet
liveInSlots x live = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x
liveLastIn :: Last -> (BlockId -> SubAreaSet) -> SubAreaSet
liveLastIn l env = liveInSlots l (liveLastOut env l)
liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
liveLastOut env l =
case l of
LastCall _ Nothing n _ _ ->
add_area (CallArea Old) n out
LastCall _ (Just k) n _ (Just _) ->
add_area (CallArea Old) n (add_area (CallArea (Young k)) n out)
LastCall _ (Just k) n _ Nothing ->
add_area (CallArea (Young k)) n out
_ -> out
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
type Set x = FiniteMap x ()
data IGraphBuilder n =
Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z
, _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
}
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`
pprPanic "wordsOccupied: unknown area" (ppr a))]
Nothing -> []
type IGraph x = FiniteMap 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)
where foldN = foldNodes builder
interfere block igraph =
let (h, l) = goto_end (unzip block)
heads (ZFirst _) (igraph, _) = igraph
heads (ZHead h m) (igraph, liveOut) =
heads h (addEdges igraph m liveOut, liveInSlots m liveOut)
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)))
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
env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
in heads h $ case l of LastExit -> (igraph, emptyFM)
LastOther l -> (addEdges igraph l $ liveLastOut env' l,
liveLastIn l env')
getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap
getAreaSize entry_off g@(LGraph _ _) =
fold_blocks (fold_fwd_block first add_regslots last)
(unitFM (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)
where area = CallArea Old
last l@(LastOther (LastCall _ (Just k) args res _)) z =
add_regslots l (add (add z area args) area res)
where area = CallArea (Young k)
last l z = add_regslots l z
add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i
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))
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
conflict n' () set = liveInSlots areaMap n' set
liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
setAdd w s = addToFM s w ()
freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
freeSlotFrom ig areaSize offset areaMap area =
let size = lookupFM areaSize area `orElse` 0
conflicts = conflictSlots ig areaSize areaMap (area, size, size)
align = case area of CallArea _ -> align'
RegSlot r | isGcPtrType (localRegType r) -> align'
RegSlot _ -> id
align' n = (n + (wORD_SIZE 1)) `div` wORD_SIZE * wORD_SIZE
findSpace curr 0 = curr
findSpace curr cnt =
if elemFM curr conflicts then
findSpace (align (curr + size)) size
else findSpace (curr 1) (cnt 1)
in findSpace (align (offset + size)) size
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
layout :: ProcPointSet -> SlotEnv -> ByteOff -> LGraph Middle Last -> AreaMap
layout procPoints env entry_off g =
let ig = (igraph areaBuilder env g, areaBuilder)
env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
areaSize = getAreaSize entry_off g
live_in (ZTail m l) = liveInSlots m (live_in l)
live_in (ZLast (LastOther l)) = liveLastIn l env'
live_in (ZLast LastExit) = emptyFM
youngest_live :: AreaMap
-> SubAreaSet
-> ByteOff
youngest_live areaMap live = fold_subareas young_slot live 0
where young_slot (a, o, _) z = case lookupFM areaMap a of
Just top -> max z $ top + o
Nothing -> z
fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m
allocVarSlot = allocSlotFrom ig areaSize 0
setSuccSPs inSp bid areaMap =
case (lookupFM areaMap area, lookupBlockEnv (lg_blocks g) bid) of
(Just _, _) -> areaMap
(Nothing, Just (Block _ _)) ->
if elemBlockSet bid procPoints then
let young = youngest_live areaMap $ env' bid
start = young
in allocSlotFrom ig areaSize start areaMap area
else addToFM areaMap area inSp
(_, 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 =
let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
area = CallArea (Young bid)
areaSize' = addToFM areaSize area (widthInBytes (typeWidth gcWord))
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
areaMap = foldl layoutAreas initMap (postorder_dfs g)
in
areaMap
manifestSP :: AreaMap -> ByteOff -> LGraph Middle Last -> FuelMonad (LGraph Middle Last)
manifestSP areaMap entry_off g@(LGraph entry _blocks) =
liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g)
where slot a =
lookupFM areaMap a `orElse` panic "unallocated Area"
slot' (Just id) = slot $ CallArea (Young id)
slot' Nothing = slot $ CallArea Old
sp_high = maxSlot slot g
proc_entry_sp = slot (CallArea Old) + entry_off
add_sp_off b env =
case Z.last (unzip b) of
LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off}) ->
extendBlockEnv env succ off
_ -> env
spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, entry_off)]) g
spOffset id = lookupBlockEnv spEntryMap id `orElse` 0
sp_on_entry id | id == entry = proc_entry_sp
sp_on_entry id = slot' (Just id) + spOffset id
replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
replB blocks (Block id t) =
do bs <- replTail (Block id) spIn t
liftM (flip (foldr insertBlock) bs) 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 (\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
replTail h spOff (ZLast (LastOther l)) = fixSp h spOff l
replTail h _ l@(ZLast LastExit) = return [h l]
middle spOff m = mapExpDeepMiddle (replSlot spOff) m
last spOff l = mapExpDeepLast (replSlot spOff) l
replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff (slot a + i))
replSlot _ (CmmLit CmmHighStackMark) =
CmmLit (CmmInt (toInteger (max 0 (sp_high proc_entry_sp))) (typeWidth bWord))
replSlot _ e = e
fixSp :: (ZTail Middle Last -> CmmBlock) -> Int -> Last -> FuelMonad ([CmmBlock])
fixSp h spOff l@(LastCall _ k n _ _) = updSp h spOff (slot' k + n) l
fixSp h spOff l@(LastBranch k) =
let succSp = sp_on_entry k in
if succSp /= spOff then
updSp h spOff succSp l
else return $ [h (ZLast (LastOther (last spOff l)))]
fixSp h spOff l = liftM (uncurry (:)) $ fold_succs succ l $ return (b, [])
where b = h (ZLast (LastOther (last spOff l)))
succ succId z =
let succSp = sp_on_entry succId in
if succSp /= spOff then
do (b, bs) <- z
(b', bs') <- insertBetween b [setSpMid spOff succSp] succId
return (b', bs ++ bs')
else z
updSp h old new l = return [h $ setSp old new $ ZLast $ LastOther (last new l)]
setSpMid sp sp' = MidAssign (CmmGlobal Sp) e
where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off]
off = CmmLit $ CmmInt (toInteger $ sp sp') wordWidth
setSp sp sp' t = if sp == sp' then t else ZTail (setSpMid sp sp') t
maxSlot :: (Area -> Int) -> CmmGraph -> Int
maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ x -> x) highSlot highSlot) 0 g
where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i
add z (a, i, _) = max z (slotOff a + i)
type StubPtrFix = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet CmmGraph)
stubSlotsOnDeath :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
stubSlotsOnDeath g = liftM zdfFpContents $ (res :: StubPtrFix)
where res = zdfBRewriteFromL RewriteShallow emptyBlockEnv "stub ptrs" slotLattice
liveSlotTransfers rewrites (fact_bot slotLattice) g
rewrites = BackwardRewrites first middle last Nothing
first _ _ = Nothing
last _ _ = Nothing
middle m liveSlots = foldSlotsUsed (stub liveSlots m) Nothing m
stub liveSlots m rst subarea@(a, off, w) =
if elemSlot liveSlots subarea then rst
else let store = mkStore (CmmStackSlot a off)
(stackStubExpr (widthFromBytes w))
in case rst of Nothing -> Just (mkMiddle m <*> store)
Just g -> Just (g <*> store)