#if __GLASGOW_HASKELL__ >= 611
#endif
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 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
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
slotLattice :: DataflowLattice SubAreaSet
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 $ Map.findWithDefault [] a map
in (c || changed, Map.insert a live map)
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 = Map.delete (CallArea (Young id)) live
liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet
addSlot, removeSlot :: SubAreaSet -> SubArea -> SubAreaSet
elemSlot :: SubAreaSet -> SubArea -> Bool
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) (Map.findWithDefault [] a live)
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 =
Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live
type Set x = Map 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 Map.lookup a areaMap of
Just addr -> [addr .. addr + (Map.lookup a areaSize `orElse`
pprPanic "wordsOccupied: unknown area" (ppr a))]
Nothing -> []
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 Map.empty (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,
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 = 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, Map.empty)
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)
(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)
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 = Map.insert a (max off (Map.findWithDefault 0 a z)) z
conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
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
liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
setAdd w s = Map.insert w () s
freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
freeSlotFrom ig areaSize offset areaMap area =
let size = Map.lookup area areaSize `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 Map.member 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 Map.member area areaMap then areaMap
else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap
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) = Map.empty
youngest_live :: AreaMap
-> SubAreaSet
-> ByteOff
youngest_live areaMap live = fold_subareas young_slot live 0
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 = Map.foldRightWithKey (\_ s z -> foldr f z s) z m
allocVarSlot = allocSlotFrom ig areaSize 0
setSuccSPs inSp bid areaMap =
case (Map.lookup area areaMap, 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 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" $ 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' = 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 = Map.insert (CallArea (Young (lg_entry g))) 0
(Map.insert (CallArea Old) 0 Map.empty)
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 =
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
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)