summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/Cmm.hs2
-rw-r--r--compiler/cmm/CmmCommonBlockElim.hs4
-rw-r--r--compiler/cmm/CmmContFlowOpt.hs9
-rw-r--r--compiler/cmm/CmmExpr.hs1
-rw-r--r--compiler/cmm/CmmLayoutStack.hs2
-rw-r--r--compiler/cmm/CmmOpt.hs8
-rw-r--r--compiler/cmm/CmmProcPoint.hs14
-rw-r--r--compiler/cmm/CmmSink.hs57
-rw-r--r--compiler/cmm/CmmUtils.hs31
-rw-r--r--compiler/cmm/Hoopl/Collections.hs4
-rw-r--r--compiler/cmm/Hoopl/Dataflow.hs29
-rw-r--r--compiler/cmm/Hoopl/Graph.hs134
-rw-r--r--compiler/cmm/Hoopl/Label.hs1
-rw-r--r--compiler/cmm/MkGraph.hs19
-rw-r--r--compiler/cmm/PprCmm.hs4
-rw-r--r--compiler/cmm/PprCmmDecl.hs3
16 files changed, 148 insertions, 174 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 9f832731b1..50d48afb38 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -1,5 +1,5 @@
-- Cmm representations using Hoopl's Graph CmmNode e x.
-{-# LANGUAGE CPP, GADTs #-}
+{-# LANGUAGE GADTs #-}
module Cmm (
-- * Cmm top-level datatypes
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index fce8f7dae8..c91d553c47 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -64,7 +64,9 @@ elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g = replaceLabels env $ copyTicks env g
where
env = iterate mapEmpty blocks_with_key
- groups = groupByInt hash_block (postorderDfs g)
+ -- The order of blocks doesn't matter here, but revPostorder also drops any
+ -- unreachable blocks, which is useful.
+ groups = groupByInt hash_block (revPostorder g)
blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
-- Invariant: The blocks in the list are pairwise distinct
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index da365cfe7f..9f091da8c2 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -174,10 +174,9 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
| otherwise
= (entry_id, shortcut_map)
- -- blocks is a list of blocks in DFS postorder, while blockmap is
- -- a map of blocks. We process each element from blocks and update
- -- blockmap accordingly
- blocks = postorderDfs g
+ -- blocks are sorted in reverse postorder, but we want to go from the exit
+ -- towards beginning, so we use foldr below.
+ blocks = revPostorder g
blockmap = foldl' (flip addBlock) emptyBody blocks
-- Accumulator contains three components:
@@ -435,7 +434,7 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
| otherwise = env
used_blocks :: [CmmBlock]
- used_blocks = postorderDfs g
+ used_blocks = revPostorder g
used_lbls :: LabelSet
used_lbls = setFromList $ map entryLabel used_blocks
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index bae5a739ca..946e146f9e 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 3f1633404c..d2525d1ffd 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -244,7 +244,7 @@ cmmLayoutStack dflags procpoints entry_args
-- We need liveness info. Dead assignments are removed later
-- by the sinking pass.
let liveness = cmmLocalLiveness dflags graph
- blocks = postorderDfs graph
+ blocks = revPostorder graph
(final_stackmaps, _final_high_sp, new_blocks) <-
mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 6b4d792122..e837d29783 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -422,14 +422,6 @@ That's what the constant-folding operations on comparison operators do above.
-- -----------------------------------------------------------------------------
-- Utils
-isLit :: CmmExpr -> Bool
-isLit (CmmLit _) = True
-isLit _ = False
-
-isComparisonExpr :: CmmExpr -> Bool
-isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
-isComparisonExpr _ = False
-
isPicReg :: CmmExpr -> Bool
isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
isPicReg _ = False
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index eeae96083a..bef8f384b8 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -190,7 +190,7 @@ minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
-- Given the set of successors of calls (which must be proc-points)
-- figure out the minimal set of necessary proc-points
minimalProcPointSet platform callProcPoints g
- = extendPPSet platform g (postorderDfs g) callProcPoints
+ = extendPPSet platform g (revPostorder g) callProcPoints
extendPPSet
:: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
@@ -242,11 +242,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbls = info_tbls})
top_l _ g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach
- let addBlock
+ let add_block
:: LabelMap (LabelMap CmmBlock)
-> CmmBlock
-> LabelMap (LabelMap CmmBlock)
- addBlock graphEnv b =
+ add_block graphEnv b =
case mapLookup bid procMap of
Just ProcPoint -> add graphEnv bid bid b
Just (ReachedBy set) ->
@@ -265,7 +265,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
regSetToList $
expectJust "ppLiveness" $ mapLookup pp liveness
- graphEnv <- return $ foldlGraphBlocks addBlock mapEmpty g
+ graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g
-- Build a map from proc point BlockId to pairs of:
-- * Labels for their new procedures
@@ -330,7 +330,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-- replace branches to procpoints with branches to jumps
blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
-- add the jump blocks to the graph
- blockEnv''' = foldl' (flip insertBlock) blockEnv'' jumpBlocks
+ blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks
let g' = ofBlockMap ppId blockEnv'''
-- pprTrace "g' pre jumps" (ppr g') $ do
return (mapInsert ppId g' newGraphEnv)
@@ -374,8 +374,8 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-- reversed later.
let (_, block_order) =
foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)
- (postorderDfs g)
- add_block_num (!i, !map) block =
+ (revPostorder g)
+ add_block_num (i, map) block =
(i + 1, mapInsert (entryLabel block) i map)
sort_fn (bid, _) (bid', _) =
compare (expectJust "block_order" $ mapLookup bid block_order)
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 487f0bc244..43444639e1 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -173,7 +173,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
liveness = cmmLocalLiveness dflags graph
getLive l = mapFindWithDefault Set.empty l liveness
- blocks = postorderDfs graph
+ blocks = revPostorder graph
join_pts = findJoinPoints blocks
@@ -458,17 +458,7 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
occurs_once = not l_live && l_usages == Just 1
occurs_none = not l_live && l_usages == Nothing
- inl_node = case mapExpDeep inl_exp node of
- -- See Note [Improving conditionals]
- CmmCondBranch (CmmMachOp (MO_Ne w) args)
- ti fi l
- -> CmmCondBranch (cmmMachOpFold dflags (MO_Eq w) args)
- fi ti (inv_likeliness l)
- node' -> node'
-
- inv_likeliness :: Maybe Bool -> Maybe Bool
- inv_likeliness Nothing = Nothing
- inv_likeliness (Just l) = Just (not l)
+ inl_node = improveConditional (mapExpDeep inl_exp node)
inl_exp :: CmmExpr -> CmmExpr
-- inl_exp is where the inlining actually takes place!
@@ -479,22 +469,43 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args
inl_exp other = other
-{- Note [Improving conditionals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given
- CmmCondBranch ((a >## b) != 1) t f
-where a,b, are Floats, the constant folder /cannot/ turn it into
- CmmCondBranch (a <=## b) t f
-because comparison on floats are not invertible
-(see CmmMachOp.maybeInvertComparison).
-What we want instead is simply to reverse the true/false branches thus
+{- Note [improveConditional]
+
+cmmMachOpFold tries to simplify conditionals to turn things like
+ (a == b) != 1
+into
+ (a != b)
+but there's one case it can't handle: when the comparison is over
+floating-point values, we can't invert it, because floating-point
+comparisions aren't invertible (because NaN).
+
+But we *can* optimise this conditional by swapping the true and false
+branches. Given
CmmCondBranch ((a >## b) != 1) t f
--->
+we can turn it into
CmmCondBranch (a >## b) f t
-And we do that right here in tryToInline, just as we do cmmMachOpFold.
+So here we catch conditionals that weren't optimised by cmmMachOpFold,
+and apply above transformation to eliminate the comparison against 1.
+
+It's tempting to just turn every != into == and then let cmmMachOpFold
+do its thing, but that risks changing a nice fall-through conditional
+into one that requires two jumps. (see swapcond_last in
+CmmContFlowOpt), so instead we carefully look for just the cases where
+we can eliminate a comparison.
-}
+improveConditional :: CmmNode O x -> CmmNode O x
+improveConditional
+ (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l)
+ | neLike mop, isComparisonExpr x
+ = CmmCondBranch x f t (fmap not l)
+ where
+ neLike (MO_Ne _) = True
+ neLike (MO_U_Lt _) = True -- (x<y) < 1 behaves like (x<y) != 1
+ neLike (MO_S_Lt _) = True -- (x<y) < 1 behaves like (x<y) != 1
+ neLike _ = False
+improveConditional other = other
-- Note [dependent assignments]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 4a1d874d8f..53dbcddfbb 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GADTs, RankNTypes #-}
+{-# LANGUAGE GADTs, RankNTypes #-}
-----------------------------------------------------------------------------
--
@@ -35,7 +35,7 @@ module CmmUtils(
cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
cmmToWord,
- isTrivialCmmExpr, hasNoGlobalRegs,
+ isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,
baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
currentTSOExpr, currentNurseryExpr, cccsExpr,
@@ -56,17 +56,15 @@ module CmmUtils(
-- * Operations that probably don't belong here
modifyGraph,
- ofBlockMap, toBlockMap, insertBlock,
+ ofBlockMap, toBlockMap,
ofBlockList, toBlockList, bodyToBlockList,
toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
- foldlGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
+ foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,
-- * Ticks
blockTicks
) where
-#include "HsVersions.h"
-
import GhcPrelude
import TyCon ( PrimRep(..), PrimElemRep(..) )
@@ -78,11 +76,9 @@ import BlockId
import CLabel
import Outputable
import DynFlags
-import Util
import CodeGen.Platform
import Data.Word
-import Data.Maybe
import Data.Bits
import Hoopl.Graph
import Hoopl.Label
@@ -389,6 +385,14 @@ hasNoGlobalRegs (CmmReg (CmmLocal _)) = True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
hasNoGlobalRegs _ = False
+isLit :: CmmExpr -> Bool
+isLit (CmmLit _) = True
+isLit _ = False
+
+isComparisonExpr :: CmmExpr -> Bool
+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
+isComparisonExpr _ = False
+
---------------------------------------------------
--
-- Tagging
@@ -487,12 +491,6 @@ toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
-insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
-insertBlock block map =
- ASSERT(isNothing $ mapLookup id map)
- mapInsert id block map
- where id = entryLabel block
-
toBlockList :: CmmGraph -> [CmmBlock]
toBlockList g = mapElems $ toBlockMap g
@@ -558,8 +556,9 @@ mapGraphNodes1 f = modifyGraph (mapGraph f)
foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
-postorderDfs :: CmmGraph -> [CmmBlock]
-postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
+revPostorder :: CmmGraph -> [CmmBlock]
+revPostorder g = {-# SCC "revPostorder" #-}
+ revPostorderFrom (toBlockMap g) (g_entry g)
-------------------------------------------------
-- Tick utilities
diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs
index b8072b37a7..ef7de4a078 100644
--- a/compiler/cmm/Hoopl/Collections.hs
+++ b/compiler/cmm/Hoopl/Collections.hs
@@ -12,7 +12,7 @@ module Hoopl.Collections
import GhcPrelude
-import qualified Data.IntMap as M
+import qualified Data.IntMap.Strict as M
import qualified Data.IntSet as S
import Data.List (foldl', foldl1')
@@ -66,6 +66,7 @@ class IsMap map where
mapInsert :: KeyOf map -> a -> map a -> map a
mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapDelete :: KeyOf map -> map a -> map a
+ mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
mapUnion :: map a -> map a -> map a
mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
@@ -143,6 +144,7 @@ instance IsMap UniqueMap where
mapInsert k v (UM m) = UM (M.insert k v m)
mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
mapDelete k (UM m) = UM (M.delete k m)
+ mapAlter f k (UM m) = UM (M.alter f k m)
mapUnion (UM x) (UM y) = UM (M.union x y)
mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index 0b0434bb36..2538b70ee3 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -111,8 +111,7 @@ analyzeCmm dir lattice transfer cmmGraph initFact =
blockMap =
case hooplGraph of
GMany NothingO bm NothingO -> bm
- entries = if mapNull initFact then [entry] else mapKeys initFact
- in fixpointAnalysis dir lattice transfer entries blockMap initFact
+ in fixpointAnalysis dir lattice transfer entry blockMap initFact
-- Fixpoint algorithm.
fixpointAnalysis
@@ -120,16 +119,16 @@ fixpointAnalysis
Direction
-> DataflowLattice f
-> TransferFun f
- -> [Label]
+ -> Label
-> LabelMap CmmBlock
-> FactBase f
-> FactBase f
-fixpointAnalysis direction lattice do_block entries blockmap = loop start
+fixpointAnalysis direction lattice do_block entry blockmap = loop start
where
-- Sorting the blocks helps to minimize the number of times we need to
-- process blocks. For instance, for forward analysis we want to look at
-- blocks in reverse postorder. Also, see comments for sortBlocks.
- blocks = sortBlocks direction entries blockmap
+ blocks = sortBlocks direction entry blockmap
num_blocks = length blocks
block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
start = {-# SCC "start" #-} IntSet.fromDistinctAscList
@@ -174,9 +173,8 @@ rewriteCmm dir lattice rwFun cmmGraph initFact = do
blockMap1 =
case hooplGraph of
GMany NothingO bm NothingO -> bm
- entries = if mapNull initFact then [entry] else mapKeys initFact
(blockMap2, facts) <-
- fixpointRewrite dir lattice rwFun entries blockMap1 initFact
+ fixpointRewrite dir lattice rwFun entry blockMap1 initFact
return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)
fixpointRewrite
@@ -184,16 +182,16 @@ fixpointRewrite
Direction
-> DataflowLattice f
-> RewriteFun f
- -> [Label]
+ -> Label
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
-fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap
+fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
where
-- Sorting the blocks helps to minimize the number of times we need to
-- process blocks. For instance, for forward analysis we want to look at
-- blocks in reverse postorder. Also, see comments for sortBlocks.
- blocks = sortBlocks dir entries blockmap
+ blocks = sortBlocks dir entry blockmap
num_blocks = length blocks
block_arr = {-# SCC "block_arr_rewrite" #-}
listArray (0, num_blocks - 1) blocks
@@ -268,20 +266,15 @@ we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
-- | Sort the blocks into the right order for analysis. This means reverse
-- postorder for a forward analysis. For the backward one, we simply reverse
-- that (see Note [Backward vs forward analysis]).
---
--- Note: We're using Hoopl's confusingly named `postorder_dfs_from` but AFAICS
--- it returns the *reverse* postorder of the blocks (it visits blocks in the
--- postorder and uses (:) to collect them, which gives the reverse of the
--- visitation order).
sortBlocks
:: NonLocal n
- => Direction -> [Label] -> LabelMap (Block n C C) -> [Block n C C]
-sortBlocks direction entries blockmap =
+ => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
+sortBlocks direction entry blockmap =
case direction of
Fwd -> fwd
Bwd -> reverse fwd
where
- fwd = postorder_dfs_from blockmap entries
+ fwd = revPostorderFrom blockmap entry
-- Note [Backward vs forward analysis]
--
diff --git a/compiler/cmm/Hoopl/Graph.hs b/compiler/cmm/Hoopl/Graph.hs
index ca482ab4a8..0142f70c76 100644
--- a/compiler/cmm/Hoopl/Graph.hs
+++ b/compiler/cmm/Hoopl/Graph.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
@@ -14,11 +15,12 @@ module Hoopl.Graph
, labelsDefined
, mapGraph
, mapGraphBlocks
- , postorder_dfs_from
+ , revPostorderFrom
) where
import GhcPrelude
+import Util
import Hoopl.Label
import Hoopl.Block
@@ -51,13 +53,14 @@ emptyBody = mapEmpty
bodyList :: Body' block n -> [(Label,block n C C)]
bodyList body = mapToList body
-addBlock :: NonLocal thing
- => thing C C -> LabelMap (thing C C)
- -> LabelMap (thing C C)
-addBlock b body
- | mapMember lbl body = error $ "duplicate label " ++ show lbl ++ " in graph"
- | otherwise = mapInsert lbl b body
- where lbl = entryLabel b
+addBlock
+ :: (NonLocal block, HasDebugCallStack)
+ => block C C -> LabelMap (block C C) -> LabelMap (block C C)
+addBlock block body = mapAlter add lbl body
+ where
+ lbl = entryLabel block
+ add Nothing = Just block
+ add _ = error $ "duplicate label " ++ show lbl ++ " in graph"
-- ---------------------------------------------------------------------------
@@ -119,22 +122,10 @@ labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
----------------------------------------------------------------
-class LabelsPtr l where
- targetLabels :: l -> [Label]
-
-instance NonLocal n => LabelsPtr (n e C) where
- targetLabels n = successors n
-
-instance LabelsPtr Label where
- targetLabels l = [l]
-
-instance LabelsPtr LabelSet where
- targetLabels = setElems
-
-instance LabelsPtr l => LabelsPtr [l] where
- targetLabels = concatMap targetLabels
-
--- | This is the most important traversal over this data structure. It drops
+-- | Returns a list of blocks reachable from the provided Labels in the reverse
+-- postorder.
+--
+-- This is the most important traversal over this data structure. It drops
-- unreachable code and puts blocks in an order that is good for solving forward
-- dataflow problems quickly. The reverse order is good for solving backward
-- dataflow problems quickly. The forward order is also reasonably good for
@@ -143,59 +134,52 @@ instance LabelsPtr l => LabelsPtr [l] where
-- that you would need a more serious analysis, probably based on dominators, to
-- identify loop headers.
--
--- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
--- representation, when for most purposes the plain 'Graph' representation is
--- more mathematically elegant (but results in more complicated code).
---
--- Here's an easy way to go wrong! Consider
+-- For forward analyses we want reverse postorder visitation, consider:
-- @
-- A -> [B,C]
-- B -> D
-- C -> D
-- @
--- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
--- Better to get [A,B,C,D]
-
-
--- | Traversal: 'postorder_dfs' returns a list of blocks reachable
--- from the entry of enterable graph. The entry and exit are *not* included.
--- The list has the following property:
---
--- Say a "back reference" exists if one of a block's
--- control-flow successors precedes it in the output list
---
--- Then there are as few back references as possible
---
--- The output is suitable for use in
--- a forward dataflow problem. For a backward problem, simply reverse
--- the list. ('postorder_dfs' is sufficiently tricky to implement that
--- one doesn't want to try and maintain both forward and backward
--- versions.)
-
-postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)
- => LabelMap (block C C) -> e -> LabelSet -> [block C C]
-postorder_dfs_from_except blocks b visited =
- vchildren (get_children b) (\acc _visited -> acc) [] visited
- where
- vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
- vnode block cont acc visited =
- if setMember id visited then
- cont acc visited
- else
- let cont' acc visited = cont (block:acc) visited in
- vchildren (get_children block) cont' acc (setInsert id visited)
- where id = entryLabel block
- vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
- vchildren bs cont acc visited = next bs acc visited
- where next children acc visited =
- case children of [] -> cont acc visited
- (b:bs) -> vnode b (next bs) acc visited
- get_children :: forall l. LabelsPtr l => l -> [block C C]
- get_children block = foldr add_id [] $ targetLabels block
- add_id id rst = case lookupFact id blocks of
- Just b -> b : rst
- Nothing -> rst
-
-postorder_dfs_from
- :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]
-postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty
+-- Postorder: [D, C, B, A] (or [D, B, C, A])
+-- Reverse postorder: [A, B, C, D] (or [A, C, B, D])
+-- This matters for, e.g., forward analysis, because we want to analyze *both*
+-- B and C before we analyze D.
+revPostorderFrom
+ :: forall block. (NonLocal block)
+ => LabelMap (block C C) -> Label -> [block C C]
+revPostorderFrom graph start = go start_worklist setEmpty []
+ where
+ start_worklist = lookup_for_descend start Nil
+
+ -- To compute the postorder we need to "visit" a block (mark as done)
+ -- *after* visiting all its successors. So we need to know whether we
+ -- already processed all successors of each block (and @NonLocal@ allows
+ -- arbitrary many successors). So we use an explicit stack with an extra bit
+ -- of information:
+ -- * @ConsTodo@ means to explore the block if it wasn't visited before
+ -- * @ConsMark@ means that all successors were already done and we can add
+ -- the block to the result.
+ --
+ -- NOTE: We add blocks to the result list in postorder, but we *prepend*
+ -- them (i.e., we use @(:)@), which means that the final list is in reverse
+ -- postorder.
+ go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
+ go Nil !_ !result = result
+ go (ConsMark block rest) !wip_or_done !result =
+ go rest wip_or_done (block : result)
+ go (ConsTodo block rest) !wip_or_done !result
+ | entryLabel block `setMember` wip_or_done = go rest wip_or_done result
+ | otherwise =
+ let new_worklist =
+ foldr lookup_for_descend
+ (ConsMark block rest)
+ (successors block)
+ in go new_worklist (setInsert (entryLabel block) wip_or_done) result
+
+ lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)
+ lookup_for_descend label wl
+ | Just b <- mapLookup label graph = ConsTodo b wl
+ | otherwise =
+ error $ "Label that doesn't have a block?! " ++ show label
+
+data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil
diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs
index 8096fab073..6eae115779 100644
--- a/compiler/cmm/Hoopl/Label.hs
+++ b/compiler/cmm/Hoopl/Label.hs
@@ -87,6 +87,7 @@ instance IsMap LabelMap where
mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
mapDelete (Label k) (LM m) = LM (mapDelete k m)
+ mapAlter f (Label k) (LM m) = LM (mapAlter f k m)
mapUnion (LM x) (LM y) = LM (mapUnion x y)
mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index d9f140254c..70229d067d 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, CPP, GADTs #-}
+{-# LANGUAGE BangPatterns, GADTs #-}
module MkGraph
( CmmAGraph, CmmAGraphScoped, CgStmt(..)
@@ -21,7 +21,7 @@ module MkGraph
)
where
-import GhcPrelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>)
+import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>)
import BlockId
import Cmm
@@ -37,10 +37,7 @@ import ForeignCall
import OrdList
import SMRep (ByteOff)
import UniqSupply
-
-import Control.Monad
-import Data.List
-import Data.Maybe
+import Util
-----------------------------------------------------------------------------
@@ -184,12 +181,10 @@ mkNop :: CmmAGraph
mkNop = nilOL
mkComment :: FastString -> CmmAGraph
-#if defined(DEBUG)
--- SDM: generating all those comments takes time, this saved about 4% for me
-mkComment fs = mkMiddle $ CmmComment fs
-#else
-mkComment _ = nilOL
-#endif
+mkComment fs
+ -- SDM: generating all those comments takes time, this saved about 4% for me
+ | debugIsOn = mkMiddle $ CmmComment fs
+ | otherwise = nilOL
---------- Assignment and store
mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 6a93ea818e..c9a6003aaf 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -141,8 +141,8 @@ pprCmmGraph g
= text "{" <> text "offset"
$$ nest 2 (vcat $ map ppr blocks)
$$ text "}"
- where blocks = postorderDfs g
- -- postorderDfs has the side-effect of discarding unreachable code,
+ where blocks = revPostorder g
+ -- revPostorder has the side-effect of discarding unreachable code,
-- so pretty-printed Cmm will omit any unreachable blocks. This can
-- sometimes be confusing.
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
index 9b3cecc3b8..9dd2332b67 100644
--- a/compiler/cmm/PprCmmDecl.hs
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
----------------------------------------------------------------------------
--
-- Pretty-printing of common Cmm types
@@ -54,7 +52,6 @@ import System.IO
-- Temp Jan08
import SMRep
-#include "../includes/rts/storage/FunTypes.h"
pprCmms :: (Outputable info, Outputable g)
View Lorry Controller Status