forked from ocaml/ocaml
-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Flambda-specific copy of Strongly_connected_components (#516)
- Loading branch information
Showing
6 changed files
with
277 additions
and
7 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
214 changes: 214 additions & 0 deletions
214
middle_end/flambda/compilenv_deps/strongly_connected_components_flambda2.ml
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,214 @@ | ||
| (**************************************************************************) | ||
| (* *) | ||
| (* OCaml *) | ||
| (* *) | ||
| (* Pierre Chambart, OCamlPro *) | ||
| (* Mark Shinwell and Leo White, Jane Street Europe *) | ||
| (* *) | ||
| (* Copyright 2013--2016 OCamlPro SAS *) | ||
| (* Copyright 2014--2016 Jane Street Group LLC *) | ||
| (* *) | ||
| (* All rights reserved. This file is distributed under the terms of *) | ||
| (* the GNU Lesser General Public License version 2.1, with the *) | ||
| (* special exception on linking described in the file LICENSE. *) | ||
| (* *) | ||
| (**************************************************************************) | ||
|
|
||
| module Int = Numbers.Int | ||
|
|
||
| module Kosaraju : sig | ||
| type component_graph = | ||
| { sorted_connected_components : int list array; | ||
| component_edges : int list array; | ||
| } | ||
|
|
||
| val component_graph : int list array -> component_graph | ||
| end = struct | ||
| let transpose graph = | ||
| let size = Array.length graph in | ||
| let transposed = Array.make size [] in | ||
| let add src dst = transposed.(src) <- dst :: transposed.(src) in | ||
| Array.iteri (fun src dsts -> List.iter (fun dst -> add dst src) dsts) | ||
| graph; | ||
| transposed | ||
|
|
||
| let depth_first_order (graph : int list array) : int array = | ||
| let size = Array.length graph in | ||
| let marked = Array.make size false in | ||
| let stack = Array.make size ~-1 in | ||
| let pos = ref 0 in | ||
| let push i = | ||
| stack.(!pos) <- i; | ||
| incr pos | ||
| in | ||
| let rec aux node = | ||
| if not marked.(node) | ||
| then begin | ||
| marked.(node) <- true; | ||
| List.iter aux graph.(node); | ||
| push node | ||
| end | ||
| in | ||
| for i = 0 to size - 1 do | ||
| aux i | ||
| done; | ||
| stack | ||
|
|
||
| let mark order graph = | ||
| let size = Array.length graph in | ||
| let graph = transpose graph in | ||
| let marked = Array.make size false in | ||
| let id = Array.make size ~-1 in | ||
| let count = ref 0 in | ||
| let rec aux node = | ||
| if not marked.(node) | ||
| then begin | ||
| marked.(node) <- true; | ||
| id.(node) <- !count; | ||
| List.iter aux graph.(node) | ||
| end | ||
| in | ||
| for i = size - 1 downto 0 do | ||
| let node = order.(i) in | ||
| if not marked.(node) | ||
| then begin | ||
| aux order.(i); | ||
| incr count | ||
| end | ||
| done; | ||
| id, !count | ||
|
|
||
| let kosaraju graph = | ||
| let dfo = depth_first_order graph in | ||
| let components, ncomponents = mark dfo graph in | ||
| ncomponents, components | ||
|
|
||
| type component_graph = | ||
| { sorted_connected_components : int list array; | ||
| component_edges : int list array; | ||
| } | ||
|
|
||
| let component_graph graph = | ||
| let ncomponents, components = kosaraju graph in | ||
| let id_scc = Array.make ncomponents [] in | ||
| let component_graph = Array.make ncomponents Int.Set.empty in | ||
| let add_component_dep node set = | ||
| let node_deps = graph.(node) in | ||
| List.fold_left (fun set dep -> Int.Set.add components.(dep) set) | ||
| set node_deps | ||
| in | ||
| Array.iteri (fun node component -> | ||
| id_scc.(component) <- node :: id_scc.(component); | ||
| component_graph.(component) <- | ||
| add_component_dep node (component_graph.(component))) | ||
| components; | ||
| { sorted_connected_components = id_scc; | ||
| component_edges = Array.map Int.Set.elements component_graph; | ||
| } | ||
| end | ||
|
|
||
| module type S = sig | ||
| module Id : Identifiable.S | ||
|
|
||
| type directed_graph = Id.Set.t Id.Map.t | ||
|
|
||
| type component = | ||
| | Has_loop of Id.t list | ||
| | No_loop of Id.t | ||
|
|
||
| val connected_components_sorted_from_roots_to_leaf | ||
| : directed_graph | ||
| -> component array | ||
|
|
||
| val component_graph : directed_graph -> (component * int list) array | ||
| end | ||
|
|
||
| module Make (Id : Identifiable.S) = struct | ||
| type directed_graph = Id.Set.t Id.Map.t | ||
|
|
||
| type component = | ||
| | Has_loop of Id.t list | ||
| | No_loop of Id.t | ||
|
|
||
| (* Ensure that the dependency graph does not have external dependencies. *) | ||
| (* Note: this function is currently not used. *) | ||
| let _check dependencies = | ||
| Id.Map.iter (fun id set -> | ||
| Id.Set.iter (fun v -> | ||
| if not (Id.Map.mem v dependencies) | ||
| then | ||
| Misc.fatal_errorf "Strongly_connected_components.check: the \ | ||
| graph has external dependencies (%a -> %a)" | ||
| Id.print id Id.print v) | ||
| set) | ||
| dependencies | ||
|
|
||
| type numbering = { | ||
| back : int Id.Map.t; | ||
| forth : Id.t array; | ||
| } | ||
|
|
||
| let number graph = | ||
| let size = Id.Map.cardinal graph in | ||
| let bindings = Id.Map.bindings graph in | ||
| let a = Array.of_list bindings in | ||
| let forth = Array.map fst a in | ||
| let back = | ||
| let back = ref Id.Map.empty in | ||
| for i = 0 to size - 1 do | ||
| back := Id.Map.add forth.(i) i !back; | ||
| done; | ||
| !back | ||
| in | ||
| let integer_graph = | ||
| Array.init size (fun i -> | ||
| let _, dests = a.(i) in | ||
| Id.Set.fold (fun dest acc -> | ||
| (* CR mshinwell: work out what to do about this *) | ||
| try | ||
| let v = Id.Map.find dest back in | ||
| v :: acc | ||
| with Not_found -> acc) | ||
| (* Old code: | ||
| let v = | ||
| try Id.Map.find dest back | ||
| with Not_found -> | ||
| Misc.fatal_errorf | ||
| "Strongly_connected_components: missing dependency %a" | ||
| Id.print dest | ||
| in | ||
| v :: acc) | ||
| *) | ||
| dests []) | ||
| in | ||
| { back; forth }, integer_graph | ||
|
|
||
| let rec int_list_mem x xs = | ||
| match xs with | ||
| | [] -> false | ||
| | x':: xs -> | ||
| if Int.equal x x' then true | ||
| else int_list_mem x xs | ||
|
|
||
| let component_graph graph = | ||
| let numbering, integer_graph = number graph in | ||
| let { Kosaraju. sorted_connected_components; | ||
| component_edges } = | ||
| Kosaraju.component_graph integer_graph | ||
| in | ||
| Array.mapi (fun component nodes -> | ||
| match nodes with | ||
| | [] -> assert false | ||
| | [node] -> | ||
| (if int_list_mem node integer_graph.(node) | ||
| then Has_loop [numbering.forth.(node)] | ||
| else No_loop numbering.forth.(node)), | ||
| component_edges.(component) | ||
| | _::_ -> | ||
| (Has_loop (List.map (fun node -> numbering.forth.(node)) nodes)), | ||
| component_edges.(component)) | ||
| sorted_connected_components | ||
|
|
||
| let connected_components_sorted_from_roots_to_leaf graph = | ||
| Array.map fst (component_graph graph) | ||
| end |
43 changes: 43 additions & 0 deletions
43
middle_end/flambda/compilenv_deps/strongly_connected_components_flambda2.mli
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,43 @@ | ||
| (**************************************************************************) | ||
| (* *) | ||
| (* OCaml *) | ||
| (* *) | ||
| (* Pierre Chambart, OCamlPro *) | ||
| (* Mark Shinwell and Leo White, Jane Street Europe *) | ||
| (* *) | ||
| (* Copyright 2013--2016 OCamlPro SAS *) | ||
| (* Copyright 2014--2016 Jane Street Group LLC *) | ||
| (* *) | ||
| (* All rights reserved. This file is distributed under the terms of *) | ||
| (* the GNU Lesser General Public License version 2.1, with the *) | ||
| (* special exception on linking described in the file LICENSE. *) | ||
| (* *) | ||
| (**************************************************************************) | ||
|
|
||
| (** Kosaraju's algorithm for strongly connected components. | ||
| {b Warning:} this module is unstable and part of | ||
| {{!Compiler_libs}compiler-libs}. | ||
| *) | ||
|
|
||
| module type S = sig | ||
| module Id : Identifiable.S | ||
|
|
||
| type directed_graph = Id.Set.t Id.Map.t | ||
| (** If (a -> set) belongs to the map, it means that there are edges | ||
| from [a] to every element of [set]. It is assumed that no edge | ||
| points to a vertex not represented in the map. *) | ||
|
|
||
| type component = | ||
| | Has_loop of Id.t list | ||
| | No_loop of Id.t | ||
|
|
||
| val connected_components_sorted_from_roots_to_leaf | ||
| : directed_graph | ||
| -> component array | ||
|
|
||
| val component_graph : directed_graph -> (component * int list) array | ||
| end | ||
|
|
||
| module Make (Id : Identifiable.S) : S with module Id := Id |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters