-- (c) The University of Glasgow 2006{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-}{-# LANGUAGE GeneralizedNewtypeDeriving #-}moduleDigraph(Graph ,graphFromEdgedVerticesOrd ,graphFromEdgedVerticesUniq ,SCC(..),Node (..),flattenSCC,flattenSCCs,stronglyConnCompG ,topologicalSortG ,verticesG ,edgesG ,hasVertexG ,reachableG ,reachablesG ,transposeG ,emptyG ,findCycle ,-- For backwards compatibility with the simpler version of DigraphstronglyConnCompFromEdgedVerticesOrd ,stronglyConnCompFromEdgedVerticesOrdR ,stronglyConnCompFromEdgedVerticesUniq ,stronglyConnCompFromEdgedVerticesUniqR ,-- Simple way to classify edgesEdgeType (..),classifyEdges )where#include "HsVersions.h"
-------------------------------------------------------------------------------- A version of the graph algorithms described in:---- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''-- by David King and John Launchbury---- Also included is some additional code for printing tree structures ...---- If you ever find yourself in need of algorithms for classifying edges,-- or finding connected/biconnected components, consult the history; Sigbjorn-- Finne contributed some implementations in 1997, although we've since-- removed them since they were not used anywhere in GHC.------------------------------------------------------------------------------importGhcPrelude importUtil (minWith ,count )importOutputable importMaybes (expectJust )-- std interfacesimportData.MaybeimportData.ArrayimportData.Listhiding(transpose)importqualifiedData.MapasMapimportqualifiedData.SetasSetimportqualifiedData.GraphasGimportData.Graphhiding(Graph,Edge,transposeG,reachable)importData.TreeimportUnique importUniqFM {-
************************************************************************
* *
* Graphs and Graph Construction
* *
************************************************************************
Note [Nodes, keys, vertices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * A 'node' is a big blob of client-stuff
 * Each 'node' has a unique (client) 'key', but the latter
 is in Ord and has fast comparison
 * Digraph then maps each 'key' to a Vertex (Int) which is
 arranged densely in 0.n
-}dataGraph node =Graph {gr_int_graph ::IntGraph ,gr_vertex_to_node ::Vertex->node ,gr_node_to_vertex ::node ->MaybeVertex}dataEdge node =Edge node node {-| Representation for nodes of the Graph.
 * The @payload@ is user data, just carried around in this module
 * The @key@ is the node identifier.
 Key has an Ord instance for performance reasons.
 * 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
-}dataNode key payload =DigraphNode {node_payload ::payload ,-- ^ User datanode_key ::key ,-- ^ User defined node idnode_dependencies ::[key ]-- ^ Dependencies/successors of the node}instance(Outputable a ,Outputable b )=>Outputable (Node a b )whereppr (DigraphNode a b c )=ppr (a ,b ,c )emptyGraph::Graph a emptyGraph =Graph (array(1,0)[])(error"emptyGraph")(constNothing)-- See Note [Deterministic SCC]graphFromEdgedVertices::ReduceFn key payload ->[Node key payload ]-- The graph; its ok for the-- out-list to contain keys which aren't-- a vertex key, they are ignored->Graph (Node key payload )graphFromEdgedVertices _reduceFn []=emptyGraph graphFromEdgedVerticesreduceFn edged_vertices =Graph graph vertex_fn (key_vertex .key_extractor )wherekey_extractor =node_key(bounds ,vertex_fn ,key_vertex ,numbered_nodes )=reduceFn edged_vertices key_extractor graph =arraybounds [(v ,sort$mapMaybekey_vertex ks )|(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-- See Note [Deterministic SCC]-- See Note [reduceNodesIntoVertices implementations]graphFromEdgedVerticesOrd::Ordkey =>[Node key payload ]-- The graph; its ok for the-- out-list to contain keys which aren't-- a vertex key, they are ignored->Graph (Node key payload )graphFromEdgedVerticesOrd =graphFromEdgedVertices reduceNodesIntoVerticesOrd -- See Note [Deterministic SCC]-- See Note [reduceNodesIntoVertices implementations]graphFromEdgedVerticesUniq::Uniquable key =>[Node key payload ]-- The graph; its ok for the-- out-list to contain keys which aren't-- a vertex key, they are ignored->Graph (Node key payload )graphFromEdgedVerticesUniq =graphFromEdgedVertices reduceNodesIntoVerticesUniq typeReduceFn key payload =[Node key payload ]->(Node key payload ->key )->(Bounds,Vertex->Node key payload ,key ->MaybeVertex,[(Vertex,Node key payload )]){-
Note [reduceNodesIntoVertices implementations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
reduceNodesIntoVertices is parameterized by the container type.
This is to accomodate key types that don't have an Ord instance
and hence preclude the use of Data.Map. An example of such type
would be Unique, there's no way to implement Ord Unique
deterministically.
For such types, there's a version with a Uniquable constraint.
This leaves us with two versions of every function that depends on
reduceNodesIntoVertices, one with Ord constraint and the other with
Uniquable constraint.
For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq.
The Uniq version should be a tiny bit more efficient since it uses
Data.IntMap internally.
-}reduceNodesIntoVertices::([(key ,Vertex)]->m )->(key ->m ->MaybeVertex)->ReduceFn key payload reduceNodesIntoVertices fromList lookup nodes key_extractor =(bounds ,(!)vertex_map ,key_vertex ,numbered_nodes )wheremax_v =lengthnodes -1bounds =(0,max_v )::(Vertex,Vertex)-- Keep the order intact to make the result depend on input order-- instead of key ordernumbered_nodes =zip[0..]nodes vertex_map =arraybounds numbered_nodes key_map =fromList [(key_extractor node ,v )|(v ,node )<-numbered_nodes ]key_vertex k =lookup k key_map -- See Note [reduceNodesIntoVertices implementations]reduceNodesIntoVerticesOrd::Ordkey =>ReduceFn key payload reduceNodesIntoVerticesOrd =reduceNodesIntoVertices Map.fromListMap.lookup-- See Note [reduceNodesIntoVertices implementations]reduceNodesIntoVerticesUniq::Uniquable key =>ReduceFn key payload reduceNodesIntoVerticesUniq =reduceNodesIntoVertices listToUFM (fliplookupUFM ){-
************************************************************************
* *
* SCC
* *
************************************************************************
-}typeWorkItem 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::forallpayload key .Ordkey =>[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 nextfindCycle graph =go Set.empty(new_work root_deps [])[]whereenv::Map.Mapkey (Node key payload )env =Map.fromList[(node_keynode ,node )|node <-graph ]-- Find the node with fewest dependencies among the SCC modules-- This is just a heuristic to find some plausible root moduleroot::Node key payload root =fst(minWith snd[(node ,count (`Map.member`env )(node_dependenciesnode ))|node <-graph ])DigraphNode root_payload root_key root_deps =root -- 'go' implements Dijkstra's algorithm, more or lessgo::Set.Setkey -- 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 cyclesgovisited []qs =go visited qs []govisited (((DigraphNode payload key deps ),path ):ps )qs |key ==root_key =Just(root_payload :reversepath )|key `Set.member`visited =go visited ps qs |key `Map.notMember`env =go visited ps qs |otherwise=go (Set.insertkey visited )ps (new_qs ++qs )wherenew_qs =new_work deps (payload :path )new_work::[key ]->[payload ]->[WorkItem key payload ]new_work deps path =[(n ,path )|Justn <-map(`Map.lookup`env )deps ]{-
************************************************************************
* *
* Strongly Connected Component wrappers for Graph
* *
************************************************************************
Note: the components are returned topologically sorted: later components
depend on earlier ones, but not vice versa i.e. later components only have
edges going from them to earlier ones.
-}{-
Note [Deterministic SCC]
~~~~~~~~~~~~~~~~~~~~~~~~
stronglyConnCompFromEdgedVerticesUniq,
stronglyConnCompFromEdgedVerticesUniqR,
stronglyConnCompFromEdgedVerticesOrd and
stronglyConnCompFromEdgedVerticesOrdR
provide a following guarantee:
Given a deterministically ordered list of nodes it returns a deterministically
ordered list of strongly connected components, where the list of vertices
in an SCC is also deterministically ordered.
Note that the order of edges doesn't need to be deterministic for this to work.
We use the order of nodes to normalize the order of edges.
-}stronglyConnCompG::Graph node ->[SCCnode ]stronglyConnCompG graph =decodeSccs graph forest whereforest ={-# SCC"Digraph.scc"#-}scc(gr_int_graphgraph )decodeSccs::Graph node ->ForestVertex->[SCCnode ]decodeSccs Graph {gr_int_graph=graph ,gr_vertex_to_node=vertex_fn }forest =mapdecode forest wheredecode (Nodev [])|mentions_itself v =CyclicSCC[vertex_fn v ]|otherwise=AcyclicSCC(vertex_fn v )decodeother =CyclicSCC(dec other [])wheredec (Nodev ts )vs =vertex_fn v :foldrdec vs ts mentions_itself v =v `elem`(graph !v )-- The following two versions are provided for backwards compatibility:-- See Note [Deterministic SCC]-- See Note [reduceNodesIntoVertices implementations]stronglyConnCompFromEdgedVerticesOrd::Ordkey =>[Node key payload ]->[SCCpayload ]stronglyConnCompFromEdgedVerticesOrd =map(fmapnode_payload).stronglyConnCompFromEdgedVerticesOrdR -- The following two versions are provided for backwards compatibility:-- See Note [Deterministic SCC]-- See Note [reduceNodesIntoVertices implementations]stronglyConnCompFromEdgedVerticesUniq::Uniquable key =>[Node key payload ]->[SCCpayload ]stronglyConnCompFromEdgedVerticesUniq =map(fmapnode_payload).stronglyConnCompFromEdgedVerticesUniqR -- The "R" interface is used when you expect to apply SCC to-- (some of) the result of SCC, so you don't want to lose the dependency info-- See Note [Deterministic SCC]-- See Note [reduceNodesIntoVertices implementations]stronglyConnCompFromEdgedVerticesOrdR::Ordkey =>[Node key payload ]->[SCC(Node key payload )]stronglyConnCompFromEdgedVerticesOrdR =stronglyConnCompG .graphFromEdgedVertices reduceNodesIntoVerticesOrd -- The "R" interface is used when you expect to apply SCC to-- (some of) the result of SCC, so you don't want to lose the dependency info-- See Note [Deterministic SCC]-- See Note [reduceNodesIntoVertices implementations]stronglyConnCompFromEdgedVerticesUniqR::Uniquable key =>[Node key payload ]->[SCC(Node key payload )]stronglyConnCompFromEdgedVerticesUniqR =stronglyConnCompG .graphFromEdgedVertices reduceNodesIntoVerticesUniq {-
************************************************************************
* *
* Misc wrappers for Graph
* *
************************************************************************
-}topologicalSortG::Graph node ->[node ]topologicalSortG graph =map(gr_vertex_to_nodegraph )result whereresult ={-# SCC"Digraph.topSort"#-}topSort(gr_int_graphgraph )reachableG::Graph node ->node ->[node ]reachableG graph from =map(gr_vertex_to_nodegraph )result wherefrom_vertex =expectJust "reachableG"(gr_node_to_vertexgraph from )result ={-# SCC"Digraph.reachable"#-}reachable (gr_int_graphgraph )[from_vertex ]-- | Given a list of roots return all reachable nodes.reachablesG::Graph node ->[node ]->[node ]reachablesG graph froms =map(gr_vertex_to_nodegraph )result whereresult ={-# SCC"Digraph.reachable"#-}reachable (gr_int_graphgraph )vs vs =[v |Justv <-map(gr_node_to_vertexgraph )froms ]hasVertexG::Graph node ->node ->BoolhasVertexG graph node =isJust$gr_node_to_vertexgraph node verticesG::Graph node ->[node ]verticesG graph =map(gr_vertex_to_nodegraph )$vertices(gr_int_graphgraph )edgesG::Graph node ->[Edge node ]edgesG graph =map(\(v1 ,v2 )->Edge (v2n v1 )(v2n v2 ))$edges(gr_int_graphgraph )wherev2n =gr_vertex_to_nodegraph transposeG::Graph node ->Graph node transposeG graph =Graph (G.transposeG(gr_int_graphgraph ))(gr_vertex_to_nodegraph )(gr_node_to_vertexgraph )emptyG::Graph node ->BoolemptyG g =graphEmpty (gr_int_graphg ){-
************************************************************************
* *
* Showing Graphs
* *
************************************************************************
-}instanceOutputable node =>Outputable (Graph node )whereppr graph =vcat [hang (text "Vertices:")2(vcat (mapppr $verticesG graph )),hang (text "Edges:")2(vcat (mapppr $edgesG graph ))]instanceOutputable node =>Outputable (Edge node )whereppr (Edge from to )=ppr from <+> text "->"<+> ppr to graphEmpty::G.Graph->BoolgraphEmpty g =lo >hi where(lo ,hi )=boundsg {-
************************************************************************
* *
* IntGraphs
* *
************************************************************************
-}typeIntGraph =G.Graph{-
------------------------------------------------------------
-- Depth first search numbering
------------------------------------------------------------
-}-- Data.Tree has flatten for Tree, but nothing for ForestpreorderF::Foresta ->[a ]preorderF ts =concat(mapflattents ){-
------------------------------------------------------------
-- Finding reachable vertices
------------------------------------------------------------
-}-- This generalizes reachable which was found in Data.Graphreachable::IntGraph ->[Vertex]->[Vertex]reachable g vs =preorderF (dfsg vs ){-
************************************************************************
* *
* Classify Edge Types
* *
************************************************************************
-}-- Remark: While we could generalize this algorithm this comes at a runtime-- cost and with no advantages. If you find yourself using this with graphs-- not easily represented using Int nodes please consider rewriting this-- using the more general Graph type.-- | Edge direction based on DFS ClassificationdataEdgeType =Forward |Cross |Backward -- ^ Loop back towards the root node.-- Eg backjumps in loops|SelfLoop -- ^ v -> vderiving(Eq,Ord)instanceOutputable EdgeType whereppr Forward =text "Forward"pprCross =text "Cross"pprBackward =text "Backward"pprSelfLoop =text "SelfLoop"newtypeTime =Time Intderiving(Eq,Ord,Num,Outputable )--Allow for specialzation{-# INLINEABLEclassifyEdges#-}-- | Given a start vertex, a way to get successors from a node-- and a list of (directed) edges classify the types of edges.classifyEdges::forallkey .Uniquable key =>key ->(key ->[key ])->[(key ,key )]->[((key ,key ),EdgeType )]classifyEdges root getSucc edges =--let uqe (from,to) = (getUnique from, getUnique to)--in pprTrace "Edges:" (ppr $ map uqe edges) $zipedges $mapclassify edges where(_time ,starts ,ends )=addTimes (0,emptyUFM ,emptyUFM )root classify::(key ,key )->EdgeType classify (from ,to )|startFrom <startTo ,endFrom >endTo =Forward |startFrom >startTo ,endFrom <endTo =Backward |startFrom >startTo ,endFrom >endTo =Cross |getUnique from ==getUnique to =SelfLoop |otherwise=pprPanic "Failed to classify edge of Graph"(ppr (getUnique from ,getUnique to ))wheregetTime event node |Justtime <-lookupUFM event node =time |otherwise=pprPanic "Failed to classify edge of CFG - not not timed"(text "edges"<> ppr (getUnique from ,getUnique to )<+> ppr starts <+> ppr ends )startFrom =getTime starts from startTo =getTime starts to endFrom =getTime ends from endTo =getTime ends to addTimes::(Time ,UniqFM Time ,UniqFM Time )->key ->(Time ,UniqFM Time ,UniqFM Time )addTimes (time ,starts ,ends )n --Dont reenter nodes|elemUFM n starts =(time ,starts ,ends )|otherwise=letstarts' =addToUFM starts n time time' =time +1succs =getSucc n ::[key ](time'' ,starts'' ,ends' )=foldl'addTimes (time' ,starts' ,ends )succs ends'' =addToUFM ends' n time'' in(time'' +1,starts'' ,ends'' )