Commit 89900ff3 authored by ian@well-typed.com's avatar ian@well-typed.com

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 6f346d4d 7974afb3
......@@ -24,12 +24,12 @@ import Prelude hiding (succ, unzip, zip)
--
-----------------------------------------------------------------------------
cmmCfgOpts :: CmmGraph -> CmmGraph
cmmCfgOpts g = fst (blockConcat g)
cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts split g = fst (blockConcat split g)
cmmCfgOptsProc :: CmmDecl -> CmmDecl
cmmCfgOptsProc (CmmProc info lbl g) = CmmProc info' lbl g'
where (g', env) = blockConcat g
cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc split (CmmProc info lbl g) = CmmProc info' lbl g'
where (g', env) = blockConcat split g
info' = info{ info_tbls = new_info_tbls }
new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
......@@ -44,7 +44,7 @@ cmmCfgOptsProc (CmmProc info lbl g) = CmmProc info' lbl g'
| otherwise
= (k,info)
cmmCfgOptsProc top = top
cmmCfgOptsProc _ top = top
-----------------------------------------------------------------------------
......@@ -54,6 +54,7 @@ cmmCfgOptsProc top = top
-----------------------------------------------------------------------------
-- This optimisation does three things:
--
-- - If a block finishes with an unconditional branch, then we may
-- be able to concatenate the block it points to and remove the
-- branch. We do this either if the destination block is small
......@@ -63,6 +64,7 @@ cmmCfgOptsProc top = top
-- - If a block finishes in a call whose continuation block is a
-- goto, then we can shortcut the destination, making the
-- continuation block the destination of the goto.
-- (but see Note [shortcut call returns])
--
-- - removes any unreachable blocks from the graph. This is a side
-- effect of starting with a postorder DFS traversal of the graph
......@@ -93,8 +95,8 @@ cmmCfgOptsProc top = top
-- which labels we have renamed and apply the mapping at the end
-- with replaceLabels.
blockConcat :: CmmGraph -> (CmmGraph, BlockEnv BlockId)
blockConcat g@CmmGraph { g_entry = entry_id }
blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId)
blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
= (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map)
where
-- we might be able to shortcut the entry BlockId itself
......@@ -125,7 +127,8 @@ blockConcat g@CmmGraph { g_entry = entry_id }
-- calls: if we can shortcut the continuation label, then
-- we must *also* remember to substitute for the label in the
-- code, because we will push it somewhere.
| Just b' <- callContinuation_maybe last
| splitting_procs -- Note [shortcut call returns]
, Just b' <- callContinuation_maybe last
, Just blk' <- mapLookup b' blocks
, Just dest <- canShortcut blk'
= (blocks, mapInsert b' dest shortcut_map)
......@@ -184,6 +187,39 @@ okToDuplicate block
-- has a CmmExpr inside it.
_otherwise -> False
{- Note [shortcut call returns]
Consider this code that you might get from a recursive let-no-escape:
goto L1
L1:
if (Hp > HpLim) then L2 else L3
L2:
call stg_gc_noregs returns to L4
L4:
goto L1
L3:
...
goto L1
Then the control-flow optimiser shortcuts L4. But that turns L1
into the call-return proc point, and every iteration of the loop
has to shuffle variables to and from the stack. So we must *not*
shortcut L4.
Moreover not shortcutting call returns is probably fine. If L4 can
concat with its branch target then it will still do so. And we
save some compile time because we don't have to traverse all the
code in replaceLabels.
However, we probably do want to do this if we are splitting proc
points, because L1 will be a proc-point anyway, so merging it with L4
reduces the number of proc points. Unfortunately recursive
let-no-escapes won't generate very good code with proc-point
splitting on - we should probably
-}
------------------------------------------------------------------------
-- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied BlockEnv.
......
......@@ -110,7 +110,13 @@ cmmLayoutStack dflags procpoints entry_args
graph0@(CmmGraph { g_entry = entry })
= do
-- pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
(graph, liveness) <- removeDeadAssignments graph0
-- We need liveness info. We could do removeDeadAssignments at
-- the same time, but it buys nothing over doing cmmSink later,
-- and costs a lot more than just cmmLiveness.
-- (graph, liveness) <- removeDeadAssignments graph0
let (graph, liveness) = (graph0, cmmLiveness graph0)
-- pprTrace "liveness" (ppr liveness) $ return ()
let blocks = postorderDfs graph
......
......@@ -55,17 +55,20 @@ cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
do
----------- Control-flow optimisations ---------------
g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOpts g
----------- Control-flow optimisations ----------------------------------
g <- {-# SCC "cmmCfgOpts(1)" #-}
return $ cmmCfgOpts splitting_proc_points g
dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
----------- Eliminate common blocks -------------------
g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
----------- Eliminate common blocks -------------------------------------
g <- {-# SCC "elimCommonBlocks" #-}
condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
Opt_D_dump_cmmz_cbe "Post common block elimination"
-- Any work storing block Labels must be performed _after_
-- elimCommonBlocks
----------- Proc points -------------------
----------- Proc points -------------------------------------------------
let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
proc_points <-
if splitting_proc_points
......@@ -78,25 +81,30 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
when (not (setNull noncall_pps)) $
pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
----------- Layout the stack and manifest Sp ---------------
-- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
(g, stackmaps) <- {-# SCC "layoutStack" #-}
runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
----------- Sink and inline assignments *before* stack layout -----------
{- Maybe enable this later
g <- {-# SCC "sink1" #-}
condPass Opt_CmmSink cmmSink g
Opt_D_dump_cmmz_rewrite "Sink assignments (1)"
-}
----------- Layout the stack and manifest Sp ----------------------------
(g, stackmaps) <-
{-# SCC "layoutStack" #-}
runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
dump Opt_D_dump_cmmz_sp "Layout Stack" g
----------- Sink and inline assignments -------------------
g <- if dopt Opt_CmmSink dflags
then do g <- {-# SCC "sink" #-} return (cmmSink g)
dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
return g
else return g
----------- Sink and inline assignments *after* stack layout ------------
g <- {-# SCC "sink2" #-}
condPass Opt_CmmSink cmmSink g
Opt_D_dump_cmmz_rewrite "Sink assignments (2)"
------------- CAF analysis ------------------------------
------------- CAF analysis ----------------------------------------------
let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
if splitting_proc_points
then do
------------- Split into separate procedures ------------
------------- Split into separate procedures -----------------------
pp_map <- {-# SCC "procPointAnalysis" #-} runUniqSM $
procPointAnalysis proc_points g
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
......@@ -104,13 +112,14 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
splitAtProcPoints l call_pps proc_points pp_map (CmmProc h l g)
dumps Opt_D_dump_cmmz_split "Post splitting" gs
------------- Populate info tables with stack info ------
------------- Populate info tables with stack info -----------------
gs <- {-# SCC "setInfoTableStackMap" #-}
return $ map (setInfoTableStackMap stackmaps) gs
dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
----------- Control-flow optimisations ---------------
gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
----------- Control-flow optimisations -----------------------------
gs <- {-# SCC "cmmCfgOpts(2)" #-}
return $ map (cmmCfgOptsProc splitting_proc_points) gs
dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
return (cafEnv, gs)
......@@ -119,13 +128,14 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- attach info tables to return points
g <- return $ attachContInfoTables call_pps (CmmProc h l g)
------------- Populate info tables with stack info ------
------------- Populate info tables with stack info -----------------
g <- {-# SCC "setInfoTableStackMap" #-}
return $ setInfoTableStackMap stackmaps g
dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
----------- Control-flow optimisations ---------------
g <- {-# SCC "cmmCfgOpts(2)" #-} return $ cmmCfgOptsProc g
----------- Control-flow optimisations -----------------------------
g <- {-# SCC "cmmCfgOpts(2)" #-}
return $ cmmCfgOptsProc splitting_proc_points g
dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
return (cafEnv, [g])
......@@ -137,6 +147,15 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
dumps flag name
= mapM_ (dumpWith dflags flag name)
condPass flag pass g dumpflag dumpname =
if dopt flag dflags
then do
g <- return $ pass g
dump dumpflag dumpname g
return g
else return g
-- we don't need to split proc points for the NCG, unless
-- tablesNextToCode is off. The latter is because we have no
-- label to put on info tables for basic blocks that are not
......
......@@ -10,21 +10,24 @@ import CmmUtils
import Hoopl
import UniqFM
-- import PprCmm ()
-- import Outputable
import Data.List (partition)
import qualified Data.Set as Set
-- -----------------------------------------------------------------------------
-- Sinking
-- Sinking and inlining
-- This is an optimisation pass that
-- (a) moves assignments closer to their uses, to reduce register pressure
-- (b) pushes assignments into a single branch of a conditional if possible
-- It is particularly helpful in the Cmm generated by the Stg->Cmm
-- code generator, in which every function starts with a copyIn
-- sequence like:
-- (c) inlines assignments to registers that are mentioned only once
-- (d) discards dead assignments
--
-- This tightens up lots of register-heavy code. It is particularly
-- helpful in the Cmm generated by the Stg->Cmm code generator, in
-- which every function starts with a copyIn sequence like:
--
-- x1 = R1
-- x2 = Sp[8]
......@@ -36,22 +39,33 @@ import qualified Data.Set as Set
-- Algorithm:
--
-- * Start by doing liveness analysis.
-- * Keep a list of assignments; earlier ones may refer to later ones
-- * Walk forwards through the graph;
-- * At an assignment:
-- * pick up the assignment and add it to the list
-- * At a store:
-- * drop any assignments that the store refers to
-- * drop any assignments that refer to memory that may be written
-- by the store
--
-- * Keep a list of assignments A; earlier ones may refer to later ones
--
-- * Walk forwards through the graph, look at each node N:
-- * If any assignments in A (1) occur only once in N, and (2) are
-- not live after N, inline the assignment and remove it
-- from A.
-- * If N is an assignment:
-- * If the register is not live after N, discard it
-- * otherwise pick up the assignment and add it to A
-- * If N is a non-assignment node:
-- * remove any assignments from A that conflict with N, and
-- place them before N in the current block. (we call this
-- "dropping" the assignments).
-- * An assignment conflicts with N if it:
-- - assigns to a register mentioned in N
-- - mentions a register assigned by N
-- - reads from memory written by N
-- * do this recursively, dropping dependent assignments
-- * At a multi-way branch:
-- * drop any assignments that are live on more than one branch
-- * if any successor has more than one predecessor, drop everything
-- live in that successor
-- * if any successor has more than one predecessor (a
-- join-point), drop everything live in that successor
--
-- As a side-effect we'll delete some dead assignments (transitively,
-- even). Maybe we could do without removeDeadAssignments?
-- even). This isn't as good as removeDeadAssignments, but it's much
-- cheaper.
-- If we do this *before* stack layout, we might be able to avoid
-- saving some things across calls/procpoints.
......@@ -59,33 +73,28 @@ import qualified Data.Set as Set
-- *but*, that will invalidate the liveness analysis, and we'll have
-- to re-do it.
type Assignment = (LocalReg, CmmExpr, AbsAddr)
type Assignment = (LocalReg, CmmExpr, AbsMem)
-- Assignment caches AbsMem, an abstraction of the memory read by
-- the RHS of the assignment.
cmmSink :: CmmGraph -> CmmGraph
cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
where
liveness = cmmLiveness graph
getLive l = mapFindWithDefault Set.empty l liveness
blocks = postorderDfs graph
all_succs = concatMap successors blocks
succ_counts :: BlockEnv Int
succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs
join_pts = mapFilter (>1) succ_counts
join_pts = findJoinPoints blocks
sink :: BlockEnv [Assignment] -> [CmmBlock] -> [CmmBlock]
sink _ [] = []
sink sunk (b:bs) =
-- pprTrace "sink" (ppr lbl) $
blockJoin first final_middle last : sink sunk' bs
blockJoin first final_middle final_last : sink sunk' bs
where
lbl = entryLabel b
(first, middle, last) = blockSplit b
(middle', assigs) = walk ann_middles emptyBlock
(mapFindWithDefault [] lbl sunk)
succs = successors last
......@@ -96,6 +105,10 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
live_middle = gen_kill last live
ann_middles = annotate live_middle (blockToList middle)
-- Now sink and inline in this block
(middle', assigs) = walk ann_middles (mapFindWithDefault [] lbl sunk)
(final_last, assigs') = tryToInline live last assigs
-- We cannot sink into join points (successors with more than
-- one predecessor), so identify the join points and the set
-- of registers live in them.
......@@ -114,11 +127,11 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
_ -> False
-- Now, drop any assignments that we will not sink any further.
(dropped_last, assigs') = dropAssignments drop_if init_live_sets assigs
(dropped_last, assigs'') = dropAssignments drop_if init_live_sets assigs'
drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
where
should_drop = a `conflicts` last
should_drop = a `conflicts` final_last
|| {- not (isTiny rhs) && -} live_in_multi live_sets r
|| r `Set.member` live_in_joins
......@@ -133,7 +146,7 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
final_middle = foldl blockSnoc middle' dropped_last
sunk' = mapUnion sunk $
mapFromList [ (l, filterAssignments (getLive l) assigs')
mapFromList [ (l, filterAssignments (getLive l) assigs'')
| l <- succs ]
{-
......@@ -144,78 +157,109 @@ isTiny (CmmLit _) = True
isTiny _other = False
-}
--
-- annotate each node with the set of registers live *after* the node
--
annotate :: RegSet -> [CmmNode O O] -> [(RegSet, CmmNode O O)]
annotate live nodes = snd $ foldr (\n (live,nodes) -> (gen_kill n live, (live,n) : nodes)) (live,[]) nodes
annotate live nodes = snd $ foldr ann (live,[]) nodes
where ann n (live,nodes) = (gen_kill n live, (live,n) : nodes)
--
-- Find the blocks that have multiple successors (join points)
--
findJoinPoints :: [CmmBlock] -> BlockEnv Int
findJoinPoints blocks = mapFilter (>1) succ_counts
where
all_succs = concatMap successors blocks
succ_counts :: BlockEnv Int
succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs
--
-- filter the list of assignments to remove any assignments that
-- are not live in a continuation.
--
filterAssignments :: RegSet -> [Assignment] -> [Assignment]
filterAssignments live assigs = reverse (go assigs [])
where go [] kept = kept
where go [] kept = kept
go (a@(r,_,_):as) kept | needed = go as (a:kept)
| otherwise = go as kept
where
needed = r `Set.member` live || any (a `conflicts`) (map toNode kept)
needed = r `Set.member` live
|| any (a `conflicts`) (map toNode kept)
-- Note that we must keep assignments that are
-- referred to by other assignments we have
-- already kept.
-- -----------------------------------------------------------------------------
-- Walk through the nodes of a block, sinking and inlining assignments
-- as we go.
walk :: [(RegSet, CmmNode O O)] -> Block CmmNode O O -> [Assignment]
-> (Block CmmNode O O, [Assignment])
walk :: [(RegSet, CmmNode O O)] -- nodes of the block, annotated with
-- the set of registers live *after*
-- this node.
walk [] block as = (block, as)
walk ((live,node):ns) block as
| Just a <- shouldSink node1 = walk ns block (a : as1)
| otherwise = walk ns block' as'
where
(node1, as1) = tryToInline live usages node as
where usages :: UniqFM Int
usages = foldRegsUsed addUsage emptyUFM node
(dropped, as') = dropAssignmentsSimple (`conflicts` node1) as1
block' = foldl blockSnoc block dropped `blockSnoc` node1
tryToInline :: RegSet -> UniqFM Int -> CmmNode O x -> [Assignment]
-> (CmmNode O x, [Assignment])
tryToInline _live _usages node []
= (node, [])
tryToInline live usages node (a@(l,rhs,_) : rest)
| occurs_once_in_this_node = inline_and_discard
| False {- isTiny rhs -} = inline_and_keep
-- ^^ seems to make things slightly worse
where
inline_and_discard = tryToInline live' usages' node' rest
-> [Assignment] -- The current list of
-- assignments we are sinking.
-- Later assignments may refer
-- to earlier ones.
inline_and_keep = (node'', a : rest')
where (node'',rest') = inline_and_discard
-> ( Block CmmNode O O -- The new block
, [Assignment] -- Assignments to sink further
)
occurs_once_in_this_node =
not (l `elemRegSet` live) && lookupUFM usages l == Just 1
live' = foldRegsUsed extendRegSet live rhs
usages' = foldRegsUsed addUsage usages rhs
node' = mapExpDeep inline node
where inline (CmmReg (CmmLocal l')) | l == l' = rhs
inline (CmmRegOff (CmmLocal l') off) | l == l' = cmmOffset rhs off
inline other = other
tryToInline live usages node (assig@(_,rhs,_) : rest)
= (node', assig : rest')
where (node', rest') = tryToInline live usages' node rest
usages' = foldRegsUsed addUsage usages rhs
walk nodes assigs = go nodes emptyBlock assigs
where
go [] block as = (block, as)
go ((live,node):ns) block as
| shouldDiscard node live = go ns block as
| Just a <- shouldSink node1 = go ns block (a : as1)
| otherwise = go ns block' as'
where
(node1, as1) = tryToInline live node as
addUsage :: UniqFM Int -> LocalReg -> UniqFM Int
addUsage m r = addToUFM_C (+) m r 1
(dropped, as') = dropAssignmentsSimple (`conflicts` node1) as1
block' = foldl blockSnoc block dropped `blockSnoc` node1
--
-- Heuristic to decide whether to pick up and sink an assignment
-- Currently we pick up all assignments to local registers. It might
-- be profitable to sink assignments to global regs too, but the
-- liveness analysis doesn't track those (yet) so we can't.
--
shouldSink :: CmmNode e x -> Maybe Assignment
shouldSink (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprAddr e)
shouldSink (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem e)
where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e
shouldSink _other = Nothing
--
-- discard dead assignments. This doesn't do as good a job as
-- removeDeadAsssignments, because it would need multiple passes
-- to get all the dead code, but it catches the common case of
-- superfluous reloads from the stack that the stack allocator
-- leaves behind.
--
-- Also we catch "r = r" here. You might think it would fall
-- out of inlining, but the inliner will see that r is live
-- after the instruction and choose not to inline r in the rhs.
--
shouldDiscard :: CmmNode e x -> RegSet -> Bool
shouldDiscard node live
= case node of
CmmAssign r (CmmReg r') | r == r' -> True
CmmAssign (CmmLocal r) _ -> not (r `Set.member` live)
_otherwise -> False
toNode :: Assignment -> CmmNode O O
toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs
dropAssignmentsSimple :: (Assignment -> Bool) -> [Assignment] -> ([CmmNode O O], [Assignment])
dropAssignmentsSimple :: (Assignment -> Bool) -> [Assignment]
-> ([CmmNode O O], [Assignment])
dropAssignmentsSimple f = dropAssignments (\a _ -> (f a, ())) ()
dropAssignments :: (Assignment -> s -> (Bool, s)) -> s -> [Assignment] -> ([CmmNode O O], [Assignment])
dropAssignments :: (Assignment -> s -> (Bool, s)) -> s -> [Assignment]
-> ([CmmNode O O], [Assignment])
dropAssignments should_drop state assigs
= (dropped, reverse kept)
where
......@@ -229,6 +273,62 @@ dropAssignments should_drop state assigs
(dropit, state') = should_drop assig state
conflict = dropit || any (assig `conflicts`) dropped
-- -----------------------------------------------------------------------------
-- Try to inline assignments into a node.
tryToInline
:: RegSet -- set of registers live after this
-- node. We cannot inline anything
-- that is live after the node, unless
-- it is small enough to duplicate.
-> CmmNode O x -- The node to inline into
-> [Assignment] -- Assignments to inline
-> (
CmmNode O x -- New node
, [Assignment] -- Remaining assignments
)
tryToInline live node assigs = go usages node assigs
where
usages :: UniqFM Int
usages = foldRegsUsed addUsage emptyUFM node
go _usages node [] = (node, [])
go usages node (a@(l,rhs,_) : rest)
| occurs_once_in_this_node = inline_and_discard
| False {- isTiny rhs -} = inline_and_keep
-- ^^ seems to make things slightly worse
where
inline_and_discard = go usages' node' rest
inline_and_keep = (node'', a : rest')
where (node'',rest') = inline_and_discard
occurs_once_in_this_node =
not (l `elemRegSet` live) && lookupUFM usages l == Just 1
usages' = foldRegsUsed addUsage usages rhs
node' = mapExpDeep inline node
where inline (CmmReg (CmmLocal l')) | l == l' = rhs
inline (CmmRegOff (CmmLocal l') off) | l == l'
= cmmOffset rhs off
inline other = other
go usages node (assig@(_,rhs,_) : rest)
= (node', assig : rest')
where (node', rest') = go usages' node rest
usages' = foldRegsUsed (\m r -> addToUFM m r 2) usages rhs
-- we must not inline anything that is mentioned in the RHS
-- of a binding that we have already skipped, so we set the
-- usages of the regs on the RHS to 2.
addUsage :: UniqFM Int -> LocalReg -> UniqFM Int
addUsage m r = addToUFM_C (+) m r 1
-- -----------------------------------------------------------------------------
-- | @conflicts (r,e) stmt@ is @False@ if and only if the assignment
......@@ -237,51 +337,85 @@ dropAssignments should_drop state assigs
-- We only sink "r = G" assignments right now, so conflicts is very simple:
--
conflicts :: Assignment -> CmmNode O x -> Bool
(_, rhs, _ ) `conflicts` CmmAssign reg _ | reg `regUsedIn` rhs = True
(_, _, addr) `conflicts` CmmStore addr' _ | addrConflicts addr (loadAddr addr') = True
(r, _, _) `conflicts` node
= foldRegsUsed (\b r' -> r == r' || b) False node
-- An abstraction of the addresses read or written.
data AbsAddr = NoAddr | HeapAddr | StackAddr | AnyAddr
bothAddrs :: AbsAddr -> AbsAddr -> AbsAddr
bothAddrs NoAddr x = x
bothAddrs x NoAddr = x
bothAddrs HeapAddr HeapAddr = HeapAddr
bothAddrs StackAddr StackAddr = StackAddr
bothAddrs _ _ = AnyAddr
addrConflicts :: AbsAddr -> AbsAddr -> Bool
addrConflicts NoAddr _ = False
addrConflicts _ NoAddr = False
addrConflicts HeapAddr StackAddr = False
addrConflicts StackAddr HeapAddr = False
addrConflicts _ _ = True
exprAddr :: CmmExpr -> AbsAddr -- here NoAddr means "no reads"
exprAddr (CmmLoad addr _) = loadAddr addr
exprAddr (CmmMachOp _ es) = foldr bothAddrs NoAddr (map exprAddr es)
exprAddr _ = NoAddr
absAddr :: CmmExpr -> AbsAddr -- here NoAddr means "don't know"