summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/NameEnv.hs3
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs3
-rw-r--r--compiler/codeGen/StgCmmUtils.hs4
-rw-r--r--compiler/iface/MkIface.hs4
-rw-r--r--compiler/main/GhcMake.hs15
-rw-r--r--compiler/nativeGen/AsmCodeGen.hs14
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs20
-rw-r--r--compiler/nativeGen/RegAlloc/Liveness.hs20
-rw-r--r--compiler/rename/RnSource.hs5
-rw-r--r--compiler/simplCore/OccurAnal.hs21
-rw-r--r--compiler/typecheck/TcBinds.hs4
-rw-r--r--compiler/typecheck/TcEvidence.hs6
-rw-r--r--compiler/typecheck/TcSMonad.hs4
-rw-r--r--compiler/types/Type.hs12
-rw-r--r--compiler/utils/Digraph.hs30
-rw-r--r--compiler/vectorise/Vectorise/Type/Classify.hs3
-rw-r--r--testsuite/tests/determinism/determ001/determinism001.hs4
17 files changed, 92 insertions, 80 deletions
diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs
index a0eb933469..cca771a33e 100644
--- a/compiler/basicTypes/NameEnv.hs
+++ b/compiler/basicTypes/NameEnv.hs
@@ -69,7 +69,8 @@ depAnal get_defs get_uses nodes
= stronglyConnCompFromEdgedVerticesUniq (map mk_node keyed_nodes)
where
keyed_nodes = nodes `zip` [(1::Int)..]
- mk_node (node, key) = (node, key, mapMaybe (lookupNameEnv key_map) (get_uses node))
+ mk_node (node, key) =
+ DigraphNode node key (mapMaybe (lookupNameEnv key_map) (get_uses node))
key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it
key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node]
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index af3a092a93..78c604e067 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -278,7 +278,8 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
g = stronglyConnCompFromEdgedVerticesOrd
- [ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ]
+ [ DigraphNode (l,cafs) l (Set.elems cafs)
+ | (cafs, Just l) <- localCAFs ]
flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet
flatten env cafset = foldSet (lookup env) Set.empty cafset
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 2a00379ee5..237520877f 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -399,8 +399,8 @@ emitMultiAssign regs rhss = do
unscramble :: DynFlags -> [Vrtx] -> FCode ()
unscramble dflags vertices = mapM_ do_component components
where
- edges :: [ (Vrtx, Key, [Key]) ]
- edges = [ (vertex, key1, edges_from stmt1)
+ edges :: [ Node Key Vrtx ]
+ edges = [ DigraphNode vertex key1 (edges_from stmt1)
| vertex@(key1, stmt1) <- vertices ]
edges_from :: Stmt -> [Key]
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 435d06c5db..d157a5ac99 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -445,8 +445,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
non_orph_fis decl
- edges :: [(IfaceDeclABI, Unique, [Unique])]
- edges = [ (abi, getUnique (getOccName decl), out)
+ edges :: [ Node Unique IfaceDeclABI ]
+ edges = [ DigraphNode abi (getUnique (getOccName decl)) out
| decl <- new_decls
, let abi = declABI decl
, let out = localOccs $ freeNamesDeclABI abi
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 3912ac577e..25b6467f7a 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1570,7 +1570,7 @@ typecheckLoop dflags hsc_env mods = do
reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards mod summaries
- = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
+ = [ node_payload node | node <- reachableG (transposeG graph) root ]
where -- the rest just sets up the graph:
(graph, lookup_node) = moduleGraphNodes False summaries
root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
@@ -1618,13 +1618,13 @@ topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
| otherwise = throwGhcException (ProgramError "module does not exist")
in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
-type SummaryNode = (ModSummary, Int, [Int])
+type SummaryNode = Node Int ModSummary
summaryNodeKey :: SummaryNode -> Int
-summaryNodeKey (_, k, _) = k
+summaryNodeKey = node_key
summaryNodeSummary :: SummaryNode -> ModSummary
-summaryNodeSummary (s, _, _) = s
+summaryNodeSummary = node_payload
moduleGraphNodes :: Bool -> [ModSummary]
-> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
@@ -1642,11 +1642,12 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
node_map :: NodeMap SummaryNode
node_map = Map.fromList [ ((moduleName (ms_mod s),
hscSourceToIsBoot (ms_hsc_src s)), node)
- | node@(s, _, _) <- nodes ]
+ | node <- nodes
+ , let s = summaryNodeSummary node ]
-- We use integers as the keys for the SCC algorithm
nodes :: [SummaryNode]
- nodes = [ (s, key, out_keys)
+ nodes = [ DigraphNode s key out_keys
| (s, key) <- numbered_summaries
-- Drop the hi-boot ones if told to do so
, not (isBootSummary s && drop_hs_boot_nodes)
@@ -2212,7 +2213,7 @@ cyclicModuleErr mss
, nest 2 (show_path path) ]
where
graph :: [Node NodeKey ModSummary]
- graph = [(ms, msKey ms, get_deps ms) | ms <- mss]
+ graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss]
get_deps :: ModSummary -> [NodeKey]
get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index b4752cce0c..b4cfd8e310 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -848,9 +848,7 @@ sequenceBlocks infos (entry:blocks) =
sccBlocks
:: Instruction instr
=> [NatBasicBlock instr]
- -> [SCC ( NatBasicBlock instr
- , BlockId
- , [BlockId])]
+ -> [SCC (Node BlockId (NatBasicBlock instr))]
sccBlocks blocks = stronglyConnCompFromEdgedVerticesUniqR (map mkNode blocks)
@@ -867,10 +865,10 @@ getOutEdges instrs
mkNode :: (Instruction t)
=> GenBasicBlock t
- -> (GenBasicBlock t, BlockId, [BlockId])
-mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)
+ -> Node BlockId (GenBasicBlock t)
+mkNode block@(BasicBlock id instrs) = DigraphNode block id (getOutEdges instrs)
-seqBlocks :: LabelMap i -> [(GenBasicBlock t1, BlockId, [BlockId])]
+seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
-> [GenBasicBlock t1]
seqBlocks infos blocks = placeNext pullable0 todo0
where
@@ -879,8 +877,8 @@ seqBlocks infos blocks = placeNext pullable0 todo0
-- reason not to;
-- may include blocks that have already been placed, but then
-- these are not in pullable
- pullable0 = listToUFM [ (i,(b,n)) | (b,i,n) <- blocks ]
- todo0 = [i | (_,i,_) <- blocks ]
+ pullable0 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ]
+ todo0 = map node_key blocks
placeNext _ [] = []
placeNext pullable (i:rest)
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index 186ff3f622..1b639c9757 100644
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -229,7 +229,7 @@ joinToTargets_again
-- We cut some corners by not handling memory-to-memory moves.
-- This shouldn't happen because every temporary gets its own stack slot.
--
-makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])]
+makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique]
makeRegMovementGraph adjusted_assig dest_assig
= [ node | (vreg, src) <- nonDetUFMToList adjusted_assig
-- This is non-deterministic but we do not
@@ -255,15 +255,15 @@ expandNode
:: a
-> Loc -- ^ source of move
-> Loc -- ^ destination of move
- -> [(a, Loc, [Loc])]
+ -> [Node Loc a ]
expandNode vreg loc@(InReg src) (InBoth dst mem)
- | src == dst = [(vreg, loc, [InMem mem])]
- | otherwise = [(vreg, loc, [InReg dst, InMem mem])]
+ | src == dst = [DigraphNode vreg loc [InMem mem]]
+ | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]]
expandNode vreg loc@(InMem src) (InBoth dst mem)
- | src == mem = [(vreg, loc, [InReg dst])]
- | otherwise = [(vreg, loc, [InReg dst, InMem mem])]
+ | src == mem = [DigraphNode vreg loc [InReg dst]]
+ | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]]
expandNode _ (InBoth _ src) (InMem dst)
| src == dst = [] -- guaranteed to be true
@@ -276,7 +276,7 @@ expandNode vreg (InBoth src _) dst
expandNode vreg src dst
| src == dst = []
- | otherwise = [(vreg, src, [dst])]
+ | otherwise = [DigraphNode vreg src [dst]]
-- | Generate fixup code for a particular component in the move graph
@@ -286,14 +286,14 @@ expandNode vreg src dst
--
handleComponent
:: Instruction instr
- => Int -> instr -> SCC (Unique, Loc, [Loc])
+ => Int -> instr -> SCC (Node Loc Unique)
-> RegM freeRegs [instr]
-- If the graph is acyclic then we won't get the swapping problem below.
-- In this case we can just do the moves directly, and avoid having to
-- go via a spill slot.
--
-handleComponent delta _ (AcyclicSCC (vreg, src, dsts))
+handleComponent delta _ (AcyclicSCC (DigraphNode vreg src dsts))
= mapM (makeMove delta vreg src) dsts
@@ -313,7 +313,7 @@ handleComponent delta _ (AcyclicSCC (vreg, src, dsts))
-- require a fixup.
--
handleComponent delta instr
- (CyclicSCC ((vreg, InReg sreg, (InReg dreg: _)) : rest))
+ (CyclicSCC ((DigraphNode vreg (InReg sreg) ((InReg dreg: _))) : rest))
-- dest list may have more than one element, if the reg is also InMem.
= do
-- spill the source into its slot
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index e387f82420..53e09285c4 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -677,29 +677,28 @@ natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
-- exactly what we do. (#7574)
--
sccBlocks
- :: Instruction instr
+ :: forall instr . Instruction instr
=> [NatBasicBlock instr]
-> [BlockId]
-> [SCC (NatBasicBlock instr)]
-sccBlocks blocks entries = map (fmap get_node) sccs
+sccBlocks blocks entries = map (fmap node_payload) sccs
where
- -- nodes :: [(NatBasicBlock instr, Unique, [Unique])]
- nodes = [ (block, id, getOutEdges instrs)
+ nodes :: [ Node BlockId (NatBasicBlock instr) ]
+ nodes = [ DigraphNode block id (getOutEdges instrs)
| block@(BasicBlock id instrs) <- blocks ]
g1 = graphFromEdgedVerticesUniq nodes
reachable :: LabelSet
- reachable = setFromList [ id | (_,id,_) <- reachablesG g1 roots ]
+ reachable = setFromList [ node_key node | node <- reachablesG g1 roots ]
- g2 = graphFromEdgedVerticesUniq [ node | node@(_,id,_) <- nodes
- , id `setMember` reachable ]
+ g2 = graphFromEdgedVerticesUniq [ node | node <- nodes
+ , node_key node
+ `setMember` reachable ]
sccs = stronglyConnCompG g2
- get_node (n, _, _) = n
-
getOutEdges :: Instruction instr => [instr] -> [BlockId]
getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
@@ -709,7 +708,8 @@ sccBlocks blocks entries = map (fmap get_node) sccs
-- node: (NatBasicBlock, BlockId, [BlockId]). This takes
-- advantage of the fact that Digraph only looks at the key,
-- even though it asks for the whole triple.
- roots = [(panic "sccBlocks",b,panic "sccBlocks") | b <- entries ]
+ roots = [DigraphNode (panic "sccBlocks") b (panic "sccBlocks")
+ | b <- entries ]
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 30915d58b7..af145e815f 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -49,7 +49,7 @@ import DynFlags
import Util ( debugIsOn, lengthExceeds, partitionWith )
import HscTypes ( HscEnv, hsc_dflags )
import ListSetOps ( findDupsEq, removeDups, equivClasses )
-import Digraph ( SCC, flattenSCC, flattenSCCs
+import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..)
, stronglyConnCompFromEdgedVerticesUniq )
import UniqSet
import qualified GHC.LanguageExtensions as LangExt
@@ -1349,7 +1349,8 @@ depAnalTyClDecls :: GlobalRdrEnv
depAnalTyClDecls rdr_env ds_w_fvs
= stronglyConnCompFromEdgedVerticesUniq edges
where
- edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nonDetEltsUniqSet fvs))
+ edges :: [ Node Name (LTyClDecl Name) ]
+ edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))
| (d, fvs) <- ds_w_fvs ]
-- It's OK to use nonDetEltsUFM here as
-- stronglyConnCompFromEdgedVertices is still deterministic
diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
index b14dbd9724..98c81ce026 100644
--- a/compiler/simplCore/OccurAnal.hs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -11,7 +11,7 @@ The occurrence analyser re-typechecks a core expression, returning a new
core expression with (hopefully) improved usage information.
-}
-{-# LANGUAGE CPP, BangPatterns, MultiWayIf #-}
+{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-}
module OccurAnal (
occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap
@@ -35,7 +35,7 @@ import VarSet
import VarEnv
import Var
import Demand ( argOneShots, argsOneShots )
-import Digraph ( SCC(..), Node
+import Digraph ( SCC(..), Node(..)
, stronglyConnCompFromEdgedVerticesUniq
, stronglyConnCompFromEdgedVerticesUniqR )
import Unique
@@ -978,7 +978,7 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
(map mk_loop_breaker chosen_nodes ++ binds)
where
(chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb
- (nd_score (fstOf3 node))
+ (nd_score (node_payload node))
[node] [] nodes
approximate_lb = depth >= 2
@@ -988,14 +988,15 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
-- and approximate, returning to d=0
mk_loop_breaker :: LetrecNode -> Binding
-mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)
+mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs})
= (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs)
where
tail_info = tailCallInfo (idOccInfo bndr)
mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding
-- See Note [Weak loop breakers]
-mk_non_loop_breaker weak_fvs (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)
+mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr
+ , nd_rhs = rhs})
| bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs)
| otherwise = (bndr, rhs)
where
@@ -1029,7 +1030,7 @@ chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)
| otherwise -- Worse score so don't pick it
= chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes
where
- sc = nd_score (fstOf3 node)
+ sc = nd_score (node_payload node)
{-
Note [Complexity of loop breaking]
@@ -1223,7 +1224,7 @@ makeNode :: OccEnv -> ImpRuleEdges -> VarSet
-> (Var, CoreExpr) -> LetrecNode
-- See Note [Recursive bindings: the grand plan]
makeNode env imp_rule_edges bndr_set (bndr, rhs)
- = (details, varUnique bndr, nonDetKeysUniqSet node_fvs)
+ = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs)
-- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR
-- is still deterministic with edges in nondeterministic order as
-- explained in Note [Deterministic SCC] in Digraph.
@@ -1296,10 +1297,12 @@ mkLoopBreakerNodes lvl bndr_set body_uds details_s
= (final_uds, zipWith mk_lb_node details_s bndrs')
where
(final_uds, bndrs') = tagRecBinders lvl body_uds
- [ (nd_bndr nd, nd_uds nd, nd_rhs_bndrs nd)
+ [ ((nd_bndr nd)
+ ,(nd_uds nd)
+ ,(nd_rhs_bndrs nd))
| nd <- details_s ]
mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr'
- = (nd', varUnique bndr, nonDetKeysUniqSet lb_deps)
+ = DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps)
-- It's OK to use nonDetKeysUniqSet here as
-- stronglyConnCompFromEdgedVerticesR is still deterministic with edges
-- in nondeterministic order as explained in
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 0f381c4cfc..1133e81dad 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -552,8 +552,8 @@ type BKey = Int -- Just number off the bindings
mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
-- See Note [Polymorphic recursion] in HsBinds.
mkEdges sig_fn binds
- = [ (bind, key, [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
- Just key <- [lookupNameEnv key_map n], no_sig n ])
+ = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
+ Just key <- [lookupNameEnv key_map n], no_sig n ]
| (bind, key) <- keyd_binds
]
-- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 006b01ca92..eb809ab013 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -803,12 +803,12 @@ evVarsOfTerms = mapUnionVarSet evVarsOfTerm
sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges
where
- edges :: [(EvBind, EvVar, [EvVar])]
+ edges :: [ Node EvVar EvBind ]
edges = foldrBag ((:) . mk_node) [] bs
- mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
+ mk_node :: EvBind -> Node EvVar EvBind
mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
- = (b, var, nonDetEltsUniqSet (evVarsOfTerm term `unionVarSet`
+ = DigraphNode b var (nonDetEltsUniqSet (evVarsOfTerm term `unionVarSet`
coVarsOfType (varType var)))
-- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
-- is still deterministic even if the edges are in nondeterministic order
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 2502c6e865..adb8666f98 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -2422,8 +2422,8 @@ checkForCyclicBinds ev_binds_map
coercion_cycles = [c | c <- cycles, any is_co_bind c]
is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b)
- edges :: [(EvBind, EvVar, [EvVar])]
- edges = [ (bind, bndr, nonDetEltsUniqSet (evVarsOfTerm rhs))
+ edges :: [ Node EvVar EvBind ]
+ edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))
| bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]
-- It's OK to use nonDetEltsUFM here as
-- stronglyConnCompFromEdgedVertices is still deterministic even
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 37916f4741..56fa938257 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -1891,16 +1891,18 @@ predTypeEqRel ty
-- (that is, doesn't depend on Uniques).
toposortTyVars :: [TyVar] -> [TyVar]
toposortTyVars tvs = reverse $
- [ tv | (tv, _, _) <- topologicalSortG $
+ [ node_payload node | node <- topologicalSortG $
graphFromEdgedVerticesOrd nodes ]
where
var_ids :: VarEnv Int
var_ids = mkVarEnv (zip tvs [1..])
- nodes = [ ( tv
- , lookupVarEnv_NF var_ids tv
- , mapMaybe (lookupVarEnv var_ids)
- (tyCoVarsOfTypeList (tyVarKind tv)) )
+ nodes :: [ Node Int TyVar ]
+ nodes = [ DigraphNode
+ tv
+ (lookupVarEnv_NF var_ids tv)
+ (mapMaybe (lookupVarEnv var_ids)
+ (tyCoVarsOfTypeList (tyVarKind tv)))
| tv <- tvs ]
-- | Extract a well-scoped list of variables from a deterministic set of
diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs
index 48e39f761f..fe325e6a06 100644
--- a/compiler/utils/Digraph.hs
+++ b/compiler/utils/Digraph.hs
@@ -1,11 +1,11 @@
-- (c) The University of Glasgow 2006
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-}
module Digraph(
Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
- SCC(..), Node, flattenSCC, flattenSCCs,
+ SCC(..), Node(..), flattenSCC, flattenSCCs,
stronglyConnCompG,
topologicalSortG, dfsTopSortG,
verticesG, edgesG, hasVertexG,
@@ -89,7 +89,10 @@ data Graph node = Graph {
data Edge node = Edge node node
-type Node key payload = (payload, key, [key])
+data Node key payload = DigraphNode {
+ node_payload :: payload,
+ node_key :: key,
+ node_dependencies :: [key] }
-- The payload is user data, just carried around in this module
-- The keys are ordered
-- The [key] are the dependencies of the node;
@@ -109,11 +112,11 @@ graphFromEdgedVertices
graphFromEdgedVertices _reduceFn [] = emptyGraph
graphFromEdgedVertices reduceFn edged_vertices =
Graph graph vertex_fn (key_vertex . key_extractor)
- where key_extractor (_, k, _) = k
+ where key_extractor = node_key
(bounds, vertex_fn, key_vertex, numbered_nodes) =
reduceFn edged_vertices key_extractor
graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)
- | (v, (_, _, ks)) <- numbered_nodes]
+ | (v, (node_dependencies -> ks)) <- numbered_nodes]
-- We normalize outgoing edges by sorting on node order, so
-- that the result doesn't depend on the order of the edges
@@ -212,14 +215,15 @@ findCycle graph
= go Set.empty (new_work root_deps []) []
where
env :: Map.Map key (Node key payload)
- env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ]
+ env = Map.fromList [ (node_key node, node) | node <- graph ]
-- Find the node with fewest dependencies among the SCC modules
-- This is just a heuristic to find some plausible root module
root :: Node key payload
- root = fst (minWith snd [ (node, count (`Map.member` env) deps)
- | node@(_,_,deps) <- graph ])
- (root_payload,root_key,root_deps) = root
+ root = fst (minWith snd [ (node, count (`Map.member` env)
+ (node_dependencies node))
+ | node <- graph ])
+ DigraphNode root_payload root_key root_deps = root
-- 'go' implements Dijkstra's algorithm, more or less
@@ -232,7 +236,7 @@ findCycle graph
go _ [] [] = Nothing -- No cycles
go visited [] qs = go visited qs []
- go visited (((payload,key,deps), path) : ps) qs
+ go visited (((DigraphNode payload key deps), path) : ps) qs
| key == root_key = Just (root_payload : reverse path)
| key `Set.member` visited = go visited ps qs
| key `Map.notMember` env = go visited ps qs
@@ -294,8 +298,7 @@ stronglyConnCompFromEdgedVerticesOrd
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd
- = map (fmap get_node) . stronglyConnCompFromEdgedVerticesOrdR
- where get_node (n, _, _) = n
+ = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR
-- The following two versions are provided for backwards compatibility:
-- See Note [Deterministic SCC]
@@ -305,8 +308,7 @@ stronglyConnCompFromEdgedVerticesUniq
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq
- = map (fmap get_node) . stronglyConnCompFromEdgedVerticesUniqR
- where get_node (n, _, _) = n
+ = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR
-- The "R" interface is used when you expect to apply SCC to
-- (some of) the result of SCC, so you dont want to lose the dependency info
diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs
index a1215fd8c0..ffe95f3cc4 100644
--- a/compiler/vectorise/Vectorise/Type/Classify.hs
+++ b/compiler/vectorise/Vectorise/Type/Classify.hs
@@ -98,7 +98,8 @@ type TyConGroup = ([TyCon], UniqSet TyCon)
tyConGroups :: [TyCon] -> [TyConGroup]
tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVerticesUniq edges)
where
- edges = [((tc, ds), tc, nonDetEltsUniqSet ds) | tc <- tcs
+ edges :: [ Node TyCon (TyCon, UniqSet TyCon) ]
+ edges = [DigraphNode (tc, ds) tc (nonDetEltsUniqSet ds) | tc <- tcs
, let ds = tyConsOfTyCon tc]
-- It's OK to use nonDetEltsUniqSet here as
-- stronglyConnCompFromEdgedVertices is still deterministic even
diff --git a/testsuite/tests/determinism/determ001/determinism001.hs b/testsuite/tests/determinism/determ001/determinism001.hs
index 9ba9b7f09e..6de1e673d0 100644
--- a/testsuite/tests/determinism/determ001/determinism001.hs
+++ b/testsuite/tests/determinism/determ001/determinism001.hs
@@ -20,4 +20,6 @@ test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])]
test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])]
-testSCC = flattenSCCs . stronglyConnCompFromEdgedVerticesOrd
+testSCC = flattenSCCs . stronglyConnCompFromEdgedVerticesOrd . map toNode
+ where
+ toNode (a, b, c) = DigraphNode a b c
View Lorry Controller Status