[commit: ghc] master: Comments and type synonym in CmmSink (1957fdd)
git at git.haskell.org
git at git.haskell.org
Tue Sep 3 14:48:12 CEST 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/1957fddb9c32e4de001374baad55d9ccf76428f9/ghc
>---------------------------------------------------------------
commit 1957fddb9c32e4de001374baad55d9ccf76428f9
Author: Jan Stolarek <jan.stolarek at p.lodz.pl>
Date: Tue Sep 3 11:51:51 2013 +0100
Comments and type synonym in CmmSink
>---------------------------------------------------------------
1957fddb9c32e4de001374baad55d9ccf76428f9
compiler/cmm/CmmNode.hs | 2 ++
compiler/cmm/CmmSink.hs | 55 ++++++++++++++++++++++++++++-------------------
2 files changed, 35 insertions(+), 22 deletions(-)
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 47811bc..e6b1a5a 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -429,6 +429,8 @@ foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
foldExpForeignTarget _ (PrimTarget _) z = z
-- Take a folder on expressions and apply it recursively.
+-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
+-- itself, delegating all the other CmmExpr forms to 'f'.
wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index fc9164f..12e1f66 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -90,12 +90,6 @@ import qualified Data.Set as Set
-- (transitively, 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.
---
--- *but*, that will invalidate the liveness analysis, and we'll have
--- to re-do it.
-
-- -----------------------------------------------------------------------------
-- things that we aren't optimising very well yet.
--
@@ -142,6 +136,12 @@ type Assignment = (LocalReg, CmmExpr, AbsMem)
-- Assignment caches AbsMem, an abstraction of the memory read by
-- the RHS of the assignment.
+type Assignments = [Assignment]
+ -- A sequence of assignements; kept in *reverse* order
+ -- So the list [ x=e1, y=e2 ] means the sequence of assignments
+ -- y = e2
+ -- x = e1
+
cmmSink :: DynFlags -> CmmGraph -> CmmGraph
cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
where
@@ -152,7 +152,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
join_pts = findJoinPoints blocks
- sink :: BlockEnv [Assignment] -> [CmmBlock] -> [CmmBlock]
+ sink :: BlockEnv Assignments -> [CmmBlock] -> [CmmBlock]
sink _ [] = []
sink sunk (b:bs) =
-- pprTrace "sink" (ppr lbl) $
@@ -229,7 +229,8 @@ isSmall _ = False
isTrivial :: CmmExpr -> Bool
isTrivial (CmmReg (CmmLocal _)) = True
--- isTrivial (CmmLit _) = True
+-- isTrivial (CmmLit _) = True -- Disabled because it used to make thing worse.
+ -- Needs further investigation
isTrivial _ = False
--
@@ -254,7 +255,7 @@ findJoinPoints blocks = mapFilter (>1) succ_counts
-- filter the list of assignments to remove any assignments that
-- are not live in a continuation.
--
-filterAssignments :: DynFlags -> LocalRegSet -> [Assignment] -> [Assignment]
+filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments
filterAssignments dflags live assigs = reverse (go assigs [])
where go [] kept = kept
go (a@(r,_,_):as) kept | needed = go as (a:kept)
@@ -269,19 +270,29 @@ filterAssignments dflags live assigs = reverse (go assigs [])
-- -----------------------------------------------------------------------------
-- Walk through the nodes of a block, sinking and inlining assignments
-- as we go.
+--
+-- On input we pass in a:
+-- * list of nodes in the block
+-- * a list of assignments that appeared *before* this block and
+-- that are being sunk.
+--
+-- On output we get:
+-- * a new block
+-- * a list of assignments that will be placed *after* that block.
+--
walk :: DynFlags
-> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with
-- the set of registers live *after*
-- this node.
- -> [Assignment] -- The current list of
+ -> Assignments -- The current list of
-- assignments we are sinking.
-- Later assignments may refer
-- to earlier ones.
-> ( Block CmmNode O O -- The new block
- , [Assignment] -- Assignments to sink further
+ , Assignments -- Assignments to sink further
)
walk dflags nodes assigs = go nodes emptyBlock assigs
@@ -341,12 +352,12 @@ shouldDiscard node live
toNode :: Assignment -> CmmNode O O
toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs
-dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> [Assignment]
- -> ([CmmNode O O], [Assignment])
+dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments
+ -> ([CmmNode O O], Assignments)
dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()
-dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> [Assignment]
- -> ([CmmNode O O], [Assignment])
+dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments
+ -> ([CmmNode O O], Assignments)
dropAssignments dflags should_drop state assigs
= (dropped, reverse kept)
where
@@ -371,16 +382,16 @@ tryToInline
-- 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
+ -> Assignments -- Assignments to inline
-> (
CmmNode O x -- New node
- , [Assignment] -- Remaining assignments
+ , Assignments -- Remaining assignments
)
tryToInline dflags live node assigs = go usages node [] assigs
where
- usages :: UniqFM Int
- usages = foldRegsUsed dflags addUsage emptyUFM node
+ usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used
+ usages = foldLocalRegsUsed dflags addUsage emptyUFM node
go _usages node _skipped [] = (node, [])
@@ -391,10 +402,10 @@ tryToInline dflags live node assigs = go usages node [] assigs
| otherwise = dont_inline
where
inline_and_discard = go usages' inl_node skipped rest
- where usages' = foldRegsUsed dflags addUsage usages rhs
+ where usages' = foldLocalRegsUsed dflags addUsage usages rhs
- dont_inline = keep node -- don't inline the assignment, keep it
- inline_and_keep = keep inl_node -- inline the assignment, keep it
+ dont_inline = keep node -- don't inline the assignment, keep it
+ inline_and_keep = keep inl_node -- inline the assignment, keep it
keep node' = (final_node, a : rest')
where (final_node, rest') = go usages' node' (l:skipped) rest
More information about the ghc-commits
mailing list