Add -dasm-lint

When -dasm-lint is turned on the register conflict graph is checked for
internal consistency after each build/color pass. Make sure that all
edges point to valid nodes, that nodes are colored differently to their
neighbours, and if the graph is supposed to be colored, that all nodes
actually have a color.

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index c6e7dcb..76fafb3 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -156,6 +156,7 @@ data DynFlag
    | Opt_DoCoreLinting
    | Opt_DoStgLinting
    | Opt_DoCmmLinting
+   | Opt_DoAsmLinting
 
    | Opt_WarnIsError                   -- -Werror; makes warnings fatal
    | Opt_WarnDuplicateExports
@@ -1089,6 +1090,7 @@ dynamic_flags = [
   ,  ( "dcore-lint",            NoArg (setDynFlag Opt_DoCoreLinting))
   ,  ( "dstg-lint",             NoArg (setDynFlag Opt_DoStgLinting))
   ,  ( "dcmm-lint",             NoArg (setDynFlag Opt_DoCmmLinting))
+  ,  ( "dasm-lint",              NoArg (setDynFlag Opt_DoAsmLinting))
   ,  ( "dshow-passes",           NoArg (do setDynFlag Opt_ForceRecomp
                                           setVerbosity (Just 2)) )
   ,  ( "dfaststring-stats",     NoArg (setDynFlag Opt_D_faststring_stats))

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index fc62157..0145cf7 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -139,8 +139,16 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
        -- see if we've found a coloring
        if isEmptyUniqSet rsSpill
         then do
+               -- if -fasm-lint is turned on then validate the graph
+               let graph_colored_lint  =
+                       if dopt Opt_DoAsmLinting dflags
+                               then Color.validateGraph (text "")
+                                       True    -- require all nodes to be colored
+                                       graph_colored
+                               else graph_colored
+
                -- patch the registers using the info in the graph
-               let code_patched        = map (patchRegsFromGraph graph_colored) code_coalesced2
+               let code_patched        = map (patchRegsFromGraph graph_colored_lint) code_coalesced2
 
                -- clean out unneeded SPILL/RELOADs
                let code_spillclean     = map cleanSpills code_patched
@@ -155,7 +163,7 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
                -- record what happened in this stage for debugging
                let stat                =
                        RegAllocStatsColored
-                       { raGraph       = graph_colored
+                       { raGraph       = graph_colored_lint
                        , raCoalesced   = rmCoalesce
                        , raPatched     = code_patched
                        , raSpillClean  = code_spillclean
@@ -172,10 +180,18 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 
                return  ( code_final
                        , statList
-                       , graph_colored)
+                       , graph_colored_lint)
 
         -- we couldn't find a coloring, time to spill something
         else do
+               -- if -fasm-lint is turned on then validate the graph
+               let graph_colored_lint  =
+                       if dopt Opt_DoAsmLinting dflags
+                               then Color.validateGraph (text "")
+                                       False   -- don't require nodes to be colored
+                                       graph_colored
+                               else graph_colored
+
                -- spill the uncolored regs
                (code_spilled, slotsFree', spillStats)
                        <- regSpill code_coalesced2 slotsFree rsSpill
@@ -187,7 +203,7 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
                -- record what happened in this stage for debugging
                let stat        =
                        RegAllocStatsSpill
-                       { raGraph       = graph_colored
+                       { raGraph       = graph_colored_lint
                        , raCoalesced   = rmCoalesce
                        , raSpillStats  = spillStats
                        , raSpillCosts  = spillCosts

diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs
index 414abe4..ad5e18f 100644 (file)
--- a/compiler/utils/GraphOps.hs
+++ b/compiler/utils/GraphOps.hs
@@ -499,30 +499,76 @@ scanGraph match graph
 
 -- | validate the internal structure of a graph
 --     all its edges should point to valid nodes
---     if they don't then throw an error
+--     If they don't then throw an error
 --
 validateGraph
-       :: (Uniquable k, Outputable k)
-       => SDoc
-       -> Graph k cls color
-       -> Graph k cls color
+       :: (Uniquable k, Outputable k, Eq color)
+       => SDoc                         -- ^ extra debugging info to display on error
+       -> Bool                         -- ^ whether this graph is supposed to be colored.
+       -> Graph k cls color            -- ^ graph to validate
+       -> Graph k cls color            -- ^ validated graph
+
+validateGraph doc isColored graph
+
+       -- Check that all edges point to valid nodes.
+       | edges         <- unionManyUniqSets
+                               (  (map nodeConflicts       $ eltsUFM $ graphMap graph)
+                               ++ (map nodeCoalesce        $ eltsUFM $ graphMap graph))
+
+       , nodes         <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
+       , badEdges      <- minusUniqSet edges nodes
+       , not $ isEmptyUniqSet badEdges
+       = pprPanic "GraphOps.validateGraph"
+               (  text "Graph has edges that point to non-existant nodes"
+               $$ text "  bad edges: " <> vcat (map ppr $ uniqSetToList badEdges)
+               $$ doc )
+
+       -- Check that no conflicting nodes have the same color
+       | badNodes      <- filter (not . (checkNode graph))
+                       $ eltsUFM $ graphMap graph
+       , not $ null badNodes
+       = pprPanic "GraphOps.validateGraph"
+               (  text "Node has same color as one of it's conflicts"
+               $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
+               $$ doc)
+
+       -- If this is supposed to be a colored graph,
+       --      check that all nodes have a color.
+       | isColored
+       , badNodes      <- filter (\n -> isNothing $ nodeColor n)
+                       $  eltsUFM $ graphMap graph
+       , not $ null badNodes
+       = pprPanic "GraphOps.validateGraph"
+               (  text "Supposably colored graph has uncolored nodes."
+               $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
+               $$ doc )
+
+
+       -- graph looks ok
+       | otherwise
+       = graph
 
-validateGraph doc graph
- = let edges   = unionManyUniqSets
-                       (  (map nodeConflicts       $ eltsUFM $ graphMap graph)
-                       ++ (map nodeCoalesce        $ eltsUFM $ graphMap graph))
 
-       nodes   = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
+-- | If this node is colored, check that all the nodes which
+--     conflict with it have different colors.
+checkNode
+       :: (Uniquable k, Eq color)
+       => Graph k cls color
+       -> Node  k cls color
+       -> Bool                 -- ^ True if this node is ok
        
-       badEdges = minusUniqSet edges nodes
+checkNode graph node
+       | Just color            <- nodeColor node
+       , Just neighbors        <- sequence $ map (lookupNode graph)
+                               $  uniqSetToList $ nodeConflicts node
+
+       , neighbourColors       <- catMaybes $ map nodeColor neighbors
+       , elem color neighbourColors
+       = False
        
-  in   if isEmptyUniqSet badEdges 
-        then   graph
-        else   pprPanic "GraphOps.validateGraph"
-               ( text  "-- bad edges"
-               $$ vcat (map ppr $ uniqSetToList badEdges)
-               $$ text "----------------------------"
-               $$ doc)
+       | otherwise
+       = True
+
 
 
 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours