Replace Digraph's Node type synonym with a data type

This refactoring makes it more obvious when we are constructing
a Node for the digraph rather than a less useful 3-tuple.

Reviewers: austin, goldfire, bgamari, simonmar, dfeuer

Reviewed By: dfeuer

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3414

3 files changed, 26 insertions, 28 deletions

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 ]