Commit d260d919 authored by Simon Marlow's avatar Simon Marlow

Add an experimental sinking pass

parent 2491856e
{-# LANGUAGE RecordWildCards, GADTs #-}
module CmmLayoutStack (
cmmLayoutStack, setInfoTableStackMap
cmmLayoutStack, setInfoTableStackMap, cmmSink
) where
import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX
......@@ -32,7 +32,7 @@ import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
import Data.Bits
import Data.List (nub)
import Data.List (nub, partition)
import Control.Monad (liftM)
#include "HsVersions.h"
......@@ -973,3 +973,73 @@ insertReloads stackmap =
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs sm = eltsUFM (sm_regs sm)
-- -----------------------------------------------------------------------------
-- If we do this *before* stack layout, we might be able to avoid
-- saving some things across calls/procpoints.
--
-- *but*, that will invalidate the liveness analysis, and we'll have
-- to re-do it.
cmmSink :: CmmGraph -> FuelUniqSM CmmGraph
cmmSink graph = do
let liveness = cmmLiveness graph
return $ cmmSink' liveness graph
cmmSink' :: BlockEnv CmmLive -> CmmGraph -> CmmGraph
cmmSink' liveness graph
= ofBlockList (g_entry graph) $ sink mapEmpty $ postorderDfs graph
where
sink :: BlockEnv [(LocalReg, CmmExpr)] -> [CmmBlock] -> [CmmBlock]
sink _ [] = []
sink sunk (b:bs) =
pprTrace "sink" (ppr l) $
blockJoin first final_middle last : sink sunk' bs
where
l = entryLabel b
(first, middle, last) = blockSplit b
(middle', assigs) = walk (blockToList middle) emptyBlock
(mapFindWithDefault [] l sunk)
(dropped_last, assigs') = partition (`conflictsWithLast` last) assigs
final_middle = foldl blockSnoc middle' (toNodes dropped_last)
sunk' = mapUnion sunk $
mapFromList [ (l, filt assigs' (getLive l))
| l <- successors last ]
where
getLive l = mapFindWithDefault Set.empty l liveness
filt as live = [ (r,e) | (r,e) <- as, r `Set.member` live ]
walk :: [CmmNode O O] -> Block CmmNode O O -> [(LocalReg, CmmExpr)]
-> (Block CmmNode O O, [(LocalReg, CmmExpr)])
walk [] acc as = (acc, as)
walk (n:ns) acc as
| Just a <- collect_it = walk ns acc (a:as)
| otherwise = walk ns (foldr (flip blockSnoc) acc (n:drop_nodes)) as'
where
collect_it = case n of
CmmAssign (CmmLocal r) e@(CmmReg (CmmGlobal _)) -> Just (r,e)
-- CmmAssign (CmmLocal r) e@(CmmLoad addr _) |
-- foldRegsUsed (\b r -> False) True addr -> Just (r,e)
_ -> Nothing
drop_nodes = toNodes dropped
(dropped, as') = partition should_drop as
where should_drop a = a `conflicts` n
toNodes as = [ CmmAssign (CmmLocal r) rhs | (r,rhs) <- as ]
-- We only sink "r = G" assignments right now, so conflicts is very simple:
(r, rhs) `conflicts` CmmAssign reg _ | reg `regUsedIn` rhs = True
--(r, CmmLoad _ _) `conflicts` CmmStore _ _ = True
(r, _) `conflicts` node
= foldRegsUsed (\b r' -> r == r' || b) False node
(r, _) `conflictsWithLast` node
= foldRegsUsed (\b r' -> r == r' || b) False node
......@@ -65,13 +65,13 @@ cmmPipeline hsc_env topSRT prog =
--
showPass dflags "CPSZ"
(cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) prog
(cafEnvs, tops) <- {-# SCC "tops" #-} liftM unzip $ mapM (cpsTop hsc_env) prog
-- tops :: [[(CmmDecl,CAFSet]] (one list per group)
let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
let topCAFEnv = {-# SCC "topCAFEnv" #-} mkTopCAFInfo (concat cafEnvs)
-- folding over the groups
(topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
(topSRT, tops) <- {-# SCC "toTops" #-} foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
let cmms :: CmmGroup
cmms = reverse (concat tops)
......@@ -116,6 +116,9 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
run $ cmmLayoutStack procPoints entry_off g
dump Opt_D_dump_cmmz_sp "Layout Stack" g
g <- {-# SCC "sink" #-} run $ cmmSink g
dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
-- ----------- Sink and inline assignments -------------------
-- g <- {-# SCC "rewriteAssignments" #-} runOptimization $
-- rewriteAssignments platform g
......@@ -131,7 +134,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
------------- More CAFs ------------------------------
let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform g
let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs
let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo platform cafEnv) gs
mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment