Repository : ssh://[email protected]/ghc On branch : master Link : http://ghc.haskell.org/trac/ghc/changeset/1957fddb9c32e4de001374baad55d9ccf76428f9/ghc
>--------------------------------------------------------------- commit 1957fddb9c32e4de001374baad55d9ccf76428f9 Author: Jan Stolarek <[email protected]> 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 _______________________________________________ ghc-commits mailing list [email protected] http://www.haskell.org/mailman/listinfo/ghc-commits
