-- a single slot, on insertion.
slotLattice :: DataflowLattice SubAreaSet
-slotLattice = DataflowLattice "live slots" emptyFM add True
+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
a == a' && hi >= hi' && hi - w <= hi' - w'
liveKill :: SubArea -> [SubArea] -> [SubArea]
-liveKill (a, hi, w) set = pprTrace "killing slots in area" (ppr a) $ liveKill' set []
+liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $
+ liveKill' set []
where liveKill' [] z = z
liveKill' (s'@(a', hi', w') : rst) z =
if a /= a' || hi < lo' || lo > hi' then -- no overlap
-- Don't forget to keep the outgoing parameters in the CallArea live,
-- as well as the update frame.
+-- Note: We have to keep the update frame live at a call because of the
+-- case where the function doesn't return -- in that case, there won't
+-- be a return to keep the update frame live. We'd still better keep the
+-- info pointer in the update frame live at any call site;
+-- otherwise we could screw up the garbage collector.
liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
liveLastOut env l =
case l of
- LastCall _ Nothing n _ ->
+ LastCall _ Nothing n _ ->
add_area (CallArea Old) n out -- add outgoing args (includes upd frame)
- LastCall _ (Just k) n _ -> add_area (CallArea (Young k)) 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
-- 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 -> LGraph Middle Last -> AreaMap
-layout procPoints env g@(LGraph _ entrySp _) =
+layout procPoints env g =
let builder = areaBuilder
ig = (igraph builder env g, builder)
env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
start = case returnOff stackInfo of Just b -> max b young
Nothing -> young
z = allocSlotFrom ig areaSize start areaMap (CallArea (Young id))
- in pprTrace "allocCallSlot for" (ppr id <+> ppr young <+> ppr (live_in t) <+> ppr z) z
+ in -- pprTrace "allocCallSlot for" (ppr id <+> ppr young <+> ppr (live_in t) <+> ppr z)
+ z
allocCallSlot areaMap _ = areaMap
-- mid foreign calls need to have info tables placed on the stack
allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap =
where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t
layout areaMap (ZLast _) = allocCallSlot areaMap b
areaMap = foldl layoutAreas (addToFM emptyFM (CallArea Old) 0) (postorder_dfs g)
- in pprTrace "ProcPoints" (ppr procPoints) $
- pprTrace "Area SizeMap" (ppr areaSize) $
- pprTrace "Entry SP" (ppr entrySp) $
- pprTrace "Area Map" (ppr areaMap) $ areaMap
+ in -- pprTrace "ProcPoints" (ppr procPoints) $
+ -- pprTrace "Area SizeMap" (ppr areaSize) $
+ -- pprTrace "Entry SP" (ppr entrySp) $
+ -- pprTrace "Area Map" (ppr areaMap) $
+ areaMap
-- After determining the stack layout, we can:
-- 1. Replace references to stack Areas with addresses relative to the stack
manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
liftM (LGraph entry args) blocks'
where blocks' = foldl replB (return emptyBlockEnv) (postorder_dfs g)
- slot a = pprTrace "slot" (ppr a) $
+ slot a = -- pprTrace "slot" (ppr a) $
lookupFM areaMap a `orElse` panic "unallocated Area"
slot' (Just id) = slot $ CallArea (Young id)
slot' Nothing = slot $ CallArea Old
replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
replB blocks (Block id o t) =
do bs <- replTail (Block id o) spIn t
- pprTrace "spIn" (ppr id <+> ppr spIn)$
- liftM (flip (foldr insertBlock) bs) blocks
+ -- pprTrace "spIn" (ppr id <+> ppr spIn) $ do
+ liftM (flip (foldr insertBlock) bs) blocks
where spIn = sp_on_entry id
replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) ->
FuelMonad ([CmmBlock])
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 spOff (CmmLit CmmHighStackMark) = -- replacing the high water mark
+ replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
replSlot _ e = e
-- The block must establish the SP expected at each successsor.
fixSp h spOff l@(LastBranch k) =
let succSp = sp_on_entry k in
if succSp /= spOff then
- pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $
+ -- pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $
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, [])
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, w) = max z (slotOff a + i)
+ add z (a, i, _) = max z (slotOff a + i)
-----------------------------------------------------------------------------
-- | Sanity check: stub pointers immediately after they die
projects / ghc-hetmet.git / blobdiff