X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmStackLayout.hs;h=d9cd41186231aeb6fff117ce7e0e722989b3d573;hb=c6206fd81612e51e257a650390646421c7c1d1cb;hp=60f4b5c99a56dcbde84d7f7ae8ecbfb25a66ee2e;hpb=dc6a72b94f1c2de24cf51a2ca8f44ada6db17ab9;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs index 60f4b5c..d9cd411 100644 --- a/compiler/cmm/CmmStackLayout.hs +++ b/compiler/cmm/CmmStackLayout.hs @@ -5,7 +5,6 @@ module CmmStackLayout where import Constants -import qualified Prelude as P import Prelude hiding (zip, unzip, last) import BlockId @@ -17,10 +16,11 @@ 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 @@ -57,7 +57,7 @@ import ZipDataflow -- 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 @@ -67,6 +67,8 @@ slotLattice = DataflowLattice "live slots" emptyFM add True in (c || changed, addToFM map a live) 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 @@ -94,7 +96,8 @@ liveGen s set = liveGen' s set [] 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 @@ -113,7 +116,7 @@ liveKill (a, hi, w) set = pprTrace "killing slots in area" (ppr a) $ liveKill' s liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet liveSlotTransfers = BackwardTransfers first liveInSlots liveLastIn - where first live id = delFromFM live (CallArea (Young id)) + where first id live = delFromFM live (CallArea (Young id)) -- Slot sets: adding slots, removing slots, and checking for membership. liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet @@ -128,20 +131,28 @@ elemSlot live (a, i, w) = removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet removeLiveSlotDefs = foldSlotsDefd removeSlot -liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet -liveInSlots live x = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x +liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => s -> SubAreaSet -> SubAreaSet +liveInSlots x live = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x -liveLastIn :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet -liveLastIn env l = liveInSlots (liveLastOut env l) l +liveLastIn :: Last -> (BlockId -> SubAreaSet) -> SubAreaSet +liveLastIn l env = liveInSlots l (liveLastOut env l) -- 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 @@ -186,9 +197,9 @@ igraph builder env g = foldr interfere emptyFM (postorder_dfs g) interfere block igraph = let (h, l) = goto_end (unzip block) --heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x - heads (ZFirst _ _) (igraph, _) = igraph + heads (ZFirst _) (igraph, _) = igraph heads (ZHead h m) (igraph, liveOut) = - heads h (addEdges igraph m liveOut, liveInSlots liveOut m) + heads h (addEdges igraph m liveOut, liveInSlots m liveOut) -- add edges between a def and the other defs and liveouts addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i addDef (igraph, out) def@(a, _, _) = @@ -203,26 +214,33 @@ igraph builder env g = foldr interfere emptyFM (postorder_dfs g) 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 env' l) + liveLastIn l env') -- Before allocating stack slots, we need to collect one more piece of information: -- what's the highest offset (in bytes) used in each Area? -- We'll need to allocate that much space for each Area. -getAreaSize :: LGraph Middle Last -> AreaMap -getAreaSize g@(LGraph _ off _) = +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) off) g - where first id (StackInfo {argBytes = Just off}) z = add z (CallArea (Young id)) off - first _ _ z = z - add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i - last l@(LastOther (LastCall _ Nothing off _)) z = - add_regslots l (add z (CallArea Old) off) - last l@(LastOther (LastCall _ (Just k) off _)) z = - add_regslots l (add z (CallArea (Young k)) off) + (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 - addSlot z (a@(RegSlot _), off, _) = add z a off + 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)) + -- 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 @@ -264,64 +282,96 @@ allocSlotFrom ig areaSize from areaMap area = -- | 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 -> LGraph Middle Last -> AreaMap -layout procPoints env g@(LGraph _ entrySp _) = - let builder = areaBuilder - ig = (igraph builder env g, builder) + +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" - areaSize = getAreaSize g - -- Find the slots that are live-in to the block - live_in (ZTail m l) = liveInSlots (live_in l) m - live_in (ZLast (LastOther l)) = liveLastIn env' l + areaSize = getAreaSize 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 + + -- 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 Just top -> max z $ top + o Nothing -> z - fold_subareas :: (SubArea -> z -> z) -> SubAreaSet -> z -> z - fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m + fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m + -- Allocate space for spill slots and call areas allocVarSlot = allocSlotFrom ig areaSize 0 - allocCallSlot areaMap (Block id stackInfo t) - | elemBlockSet id procPoints = - let young = youngest_live areaMap $ live_in t - 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 - allocCallSlot areaMap _ = areaMap - -- mid foreign calls need to have info tables placed on the stack + + -- Update the successor's incoming SP. + setSuccSPs inSp bid areaMap = + case (lookupFM areaMap area, lookupBlockEnv (lg_blocks g) bid) of + (Just _, _) -> areaMap -- succ already knows incoming SP + (Nothing, Just (Block _ _)) -> + if elemBlockSet bid procPoints then + let young = youngest_live areaMap $ env' bid + -- start = case returnOff stackInfo of Just b -> max b young + -- Nothing -> young + 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 + (_, 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 + + layoutAreas areaMap b@(Block _ t) = layout areaMap t 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 + 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 -- 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 @@ -332,37 +382,34 @@ layout procPoints env g@(LGraph _ entrySp _) = -- stack pointer to be younger than the live values on the stack at proc points. -- 3. Compute the maximum stack offset used in the procedure and replace -- the stack high-water mark with that offset. -manifestSP :: ProcPointSet -> BlockEnv Status -> AreaMap -> - LGraph Middle Last -> FuelMonad (LGraph Middle Last) -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) $ +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 = -- pprTrace "slot" (ppr 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) + args + 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 = - case lookupBlockEnv blocks id of - Just (Block _ (StackInfo {argBytes = Just o}) _) -> slot' (Just id) + o - _ -> - case expectJust "sp_on_entry" (lookupBlockEnv procMap id) of - ReachedBy pp -> - case blockSetToList pp of - [id] -> sp_on_entry id - _ -> panic "block not reached by one proc point" - ProcPoint -> pprPanic "procpoint doesn't take any arguments?" - (ppr id <+> ppr g <+> ppr procPoints <+> ppr procMap) + sp_on_entry id = slot' (Just id) + spOffset id -- On entry to procpoints, the stack pointer is conventional; -- otherwise, we check the SP set by predecessors. 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 + replB blocks (Block id t) = + do bs <- replTail (Block id) spIn t + -- 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]) @@ -375,16 +422,16 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) = 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 :: (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@(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 - 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, []) @@ -406,9 +453,9 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) = -- To compute the stack high-water mark, we fold over the graph and -- compute the highest slot offset. maxSlot :: (Area -> Int) -> CmmGraph -> Int -maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ _ x -> x) highSlot highSlot) 0 g +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 @@ -425,7 +472,7 @@ stubSlotsOnDeath g = liftM zdfFpContents $ (res :: StubPtrFix) rewrites = BackwardRewrites first middle last Nothing first _ _ = Nothing last _ _ = Nothing - middle liveSlots m = foldSlotsUsed (stub liveSlots m) Nothing m + 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)