diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-07-22 08:56:42 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-07-22 08:56:42 +0100 |
commit | e85902183d290b3ee8bdd242d10bf60b963f3f28 (patch) | |
tree | 42f6a746b2cca7614554364976c8c0dadc38b904 | |
parent | 9500b166d07e5a6ef7717f30ab89bb3e36eb77ea (diff) | |
download | haskell-e85902183d290b3ee8bdd242d10bf60b963f3f28.tar.gz |
Implement a findCycle function in Digraph,
and use it to report module loops nicely
This fixes Trac #5307. Now we get
Module imports form a cycle:
module `M8' (.\M8.hs)
imports `M1' (M1.hs)
which imports `M9' (.\M9.hs-boot)
which imports `M8' (.\M8.hs)
And the algorithm is linear time.
-rw-r--r-- | compiler/main/GhcMake.hs | 67 | ||||
-rw-r--r-- | compiler/utils/Digraph.lhs | 85 | ||||
-rw-r--r-- | compiler/utils/Util.lhs | 6 |
3 files changed, 107 insertions, 51 deletions
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index afa8a1ca74..dece548043 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2011 @@ -1459,51 +1461,32 @@ multiRootsErr summs@(summ1:_) cyclicModuleErr :: [ModSummary] -> SDoc -- From a strongly connected component we find -- a single cycle to report -cyclicModuleErr ms - = ASSERT( not (null ms) ) - hang (ptext (sLit "Module imports form a cycle:")) - 2 (show_path (shortest [] root_mod)) +cyclicModuleErr mss + = ASSERT( not (null mss) ) + case findCycle graph of + Nothing -> ptext (sLit "Unexpected non-cycle") <+> ppr mss + Just path -> vcat [ ptext (sLit "Module imports form a cycle:") + , nest 2 (show_path path) ] where - deps :: [(ModuleName, [ModuleName])] - deps = [ (moduleName (ms_mod m), get_deps m) | m <- ms ] - - get_deps :: ModSummary -> [ModuleName] - get_deps m = filter (\k -> Map.member k dep_env) (map unLoc (ms_home_imps m)) - - dep_env :: Map.Map ModuleName [ModuleName] - dep_env = Map.fromList deps - - -- Find the module with fewest imports among the SCC modules - -- This is just a heuristic to find some plausible root module - root_mod :: ModuleName - root_mod = fst (minWith (length . snd) deps) - - shortest :: [ModuleName] -> ModuleName -> [ModuleName] - -- (shortest [v1,v2,..,vn] m) assumes that - -- m is imported by v1 - -- which is imported by v2 - -- ... - -- which is imported by vn - -- It retuns an import chain [w1, w2, ..wm] - -- where w1 imports w2 imports .... imports wm imports w1 - shortest visited m - | m `elem` visited - = m : reverse (takeWhile (/= m) visited) - | otherwise - = minWith length (map (shortest (m:visited)) deps) - where - Just deps = Map.lookup m dep_env + graph :: [Node NodeKey ModSummary] + graph = [(ms, msKey ms, get_deps ms) | ms <- mss] + + get_deps :: ModSummary -> [NodeKey] + get_deps ms = ([ (unLoc m, HsBootFile) | m <- ms_home_srcimps ms ] ++ + [ (unLoc m, HsSrcFile) | m <- ms_home_imps ms ]) show_path [] = panic "show_path" - show_path [m] = ptext (sLit "module") <+> quotes (ppr m) + show_path [m] = ptext (sLit "module") <+> ppr_ms m <+> ptext (sLit "imports itself") - show_path (m1:m2:ms) = ptext (sLit "module") <+> quotes (ppr m1) - <+> sep ( nest 6 (ptext (sLit "imports") <+> quotes (ppr m2)) - : go ms) + show_path (m1:m2:ms) = vcat ( nest 7 (ptext (sLit "module") <+> ppr_ms m1) + : nest 6 (ptext (sLit "imports") <+> ppr_ms m2) + : go ms ) where - go [] = [ptext (sLit "which imports") <+> quotes (ppr m1)] - go (m:ms) = (ptext (sLit "which imports") <+> quotes (ppr m)) : go ms + go [] = [ptext (sLit "which imports") <+> ppr_ms m1] + go (m:ms) = (ptext (sLit "which imports") <+> ppr_ms m) : go ms -minWith :: Ord b => (a -> b) -> [a] -> a -minWith get_key xs = ASSERT( not (null xs) ) - head (sortWith get_key xs) + + ppr_ms :: ModSummary -> SDoc + ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> + (parens (text (msHsFilePath ms))) + diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index ec65cded94..b9d2da37d2 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -3,10 +3,11 @@ % \begin{code} +{-# LANGUAGE ScopedTypeVariables #-} module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, - SCC(..), flattenSCC, flattenSCCs, + SCC(..), Node, flattenSCC, flattenSCCs, stronglyConnCompG, topologicalSortG, verticesG, edgesG, hasVertexG, reachableG, transposeG, @@ -14,6 +15,8 @@ module Digraph( vertexGroupsG, emptyG, componentsG, + findCycle, + -- For backwards compatability with the simpler version of Digraph stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR, @@ -37,7 +40,7 @@ module Digraph( ------------------------------------------------------------------------------ -import Util ( sortLe ) +import Util ( sortLe, minWith, count ) import Outputable import Maybes ( expectJust ) import MonadUtils ( allM ) @@ -51,6 +54,8 @@ import Data.Maybe import Data.Array import Data.List ( (\\) ) import Data.Array.ST +import qualified Data.Map as Map +import qualified Data.Set as Set \end{code} %************************************************************************ @@ -78,6 +83,13 @@ data Graph node = Graph { data Edge node = Edge node node +type Node key payload = (payload, key, [key]) + -- The payload is user data, just carried around in this module + -- The keys are ordered + -- The [key] are the dependencies of the node; + -- it's ok to have extra keys in the dependencies that + -- are not the key of any Node in the graph + emptyGraph :: Graph a emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) @@ -101,10 +113,10 @@ graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vert graphFromEdgedVertices :: Ord key - => [(node, key, [key])] -- The graph; its ok for the + => [Node key payload] -- The graph; its ok for the -- out-list to contain keys which arent -- a vertex key, they are ignored - -> Graph (node, key, [key]) + -> Graph (Node key payload) graphFromEdgedVertices [] = emptyGraph graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor) where key_extractor (_, k, _) = k @@ -147,6 +159,63 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte %************************************************************************ \begin{code} +type WorkItem key payload + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a + +-- | Find a reasonably short cycle a->b->c->a, in a strongly +-- connected component. The input nodes are presumed to be +-- a SCC, so you can start anywhere. +findCycle :: forall payload key. Ord key + => [Node key payload] -- The nodes. The dependencies can + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next +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 ] + + -- 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 + + + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((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 + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) + + new_work :: [key] -> [payload] -> [WorkItem key payload] + new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] +\end{code} + +%************************************************************************ +%* * +%* SCC +%* * +%************************************************************************ + +\begin{code} data SCC vertex = AcyclicSCC vertex | CyclicSCC [vertex] @@ -194,8 +263,8 @@ stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } -- The following two versions are provided for backwards compatability: stronglyConnCompFromEdgedVertices :: Ord key - => [(node, key, [key])] - -> [SCC node] + => [Node key payload] + -> [SCC payload] stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR where get_node (n, _, _) = n @@ -203,8 +272,8 @@ stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEd -- the (some of) the result of SCC, so you dont want to lose the dependency info stronglyConnCompFromEdgedVerticesR :: Ord key - => [(node, key, [key])] - -> [SCC (node, key, [key])] + => [Node key payload] + -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices \end{code} diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index dc4f32ec5e..ea46b28334 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -41,7 +41,7 @@ module Util ( nTimes, -- * Sorting - sortLe, sortWith, on, + sortLe, sortWith, minWith, on, -- * Comparisons isEqual, eqListBy, @@ -543,6 +543,10 @@ sortWith get_key xs = sortLe le xs where x `le` y = get_key x < get_key y +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = ASSERT( not (null xs) ) + head (sortWith get_key xs) + on :: (a -> a -> c) -> (b -> a) -> b -> b -> c on cmp sel = \x y -> sel x `cmp` sel y |