Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 149 lines (133 sloc) 5.688 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 @author Rudy Sicard
20 @author Maxime Audouin
21 **)
22
23 (* TODO remove *)
24 open Base
25
26 let (|>) = InfixOperator.(|>)
27
28 (**)
29
30 module V = GraphUtils.Int.V
31 module G = GraphUtils.Int.G
32 module SCC = GraphUtils.Int.SCC
33
34 module Debug_int =
35 struct
36 let r = ref IntMap.empty
37 let clear() = r:= IntMap.empty
38 let add i s = r:= IntMap.add i s !r
39 let get i = try IntMap.find i !r with Not_found -> "UNKNOWN FOR DEBUG_INT"
40 end
41
42 let get_reachable_graph_from roots addon_roots graph =
43 GraphUtils.Int.get_reachable_graph_from ~addon_roots roots graph
44
45
46 let debug_deps depsmap =
47 let () = prerr_endline "digraph g {"
48 in let () = IntMap.fold
49 (fun k v () ->
50 IntSet.fold
51 (fun v () -> prerr_endline (Printf.sprintf "%d -> %d;" k v))
52 v
53 ()
54 ) depsmap ()
55 in prerr_endline "}"
56
57 let depsToGraph = GraphUtils.Int.graph_of_deps
58
59 let create_group_list roots (addon_roots:(int list IntMap.t)) deps_set =
60 let fold1(set,init)(f) =IntMap.fold f set init in
61 let fold2(set,init)(f) =IntSet.fold f set init in
62 let depsMap = IntMap.from_list deps_set in
63 let graph = depsToGraph deps_set in
64 let graph = if roots <> [] then get_reachable_graph_from roots addon_roots graph else graph in
65 (* decomposition en composante fortement connexe *)
66 let _groups = SCC.scc_array graph in
67 let _groups = Array.to_list (Array.map (fun list ->
68 let id_group = List.hd list in
69 id_group, IntSet.from_list list) _groups
70 )
71 in
72 (* assign an integer to all top-level value
73 assign an integer to all groups (the minimum of all top value)
74 generate the topological order using this integer
75 *)
76 (* group priority = min decl priority *)
77 let group_prio =
78 (* ordre des declarations *)
79 let prior = List.mapi (fun i (n,_)-> (n,i)) deps_set |> IntMap.from_list in
80 let map = List.map (fun (i,l) ->
81 let prio = fold2(l,max_int)(fun n int-> min int (IntMap.find n prior))
82 in (i,prio)
83 ) _groups |> IntMap.from_list in
84 fun n -> IntMap.find n map
85 in
86 let group_sort l = List.sort (fun g1 g2 -> (compare (group_prio g1) (group_prio g2))) l in
87 let group_revsort l = List.sort (fun g1 g2 -> -(compare (group_prio g1) (group_prio g2))) l in
88 let groups_source_order = group_sort (List.map fst _groups) in
89 (* nom de decl -> group *)
90 let group_of =
91 let map =
92 List.fold_left
93 (fun map (g,set) -> IntSet.fold (fun n map -> IntMap.add n g map) set map)
94 IntMap.empty _groups
95 in
96 fun d -> (IntMap.find d map) in
97 let group_deps =
98 let map =
99 fold1(depsMap,IntMap.empty)
100 (fun decl decldeps map->
101 if G.mem_vertex graph decl then (
102 (* normal case *)
103 (*OpaEnv.EnvLib.debug_do "cleaning" (fun ()->warning ("Kept : " ^(Debug_int.get decl)));*)
104 let deps =
105 fold2(decldeps,IntSet.empty)
106 (fun d set -> IntSet.add (group_of d) set) in
107 let g_of_decl = group_of decl in
108 let update =
109 try
110 IntSet.union deps (IntMap.find g_of_decl map)
111 with
112 | Not_found -> deps
113 in
114 IntMap.add g_of_decl update map
115 ) else (
116 (* case where the declaration is not reachable from the roots *)
117 (*OpaEnv.EnvLib.debug_do "cleaning" (fun ()->warning ("Cleaned : " ^(Debug_int.get decl)));*)
118 map
119 )
120 )
121 in IntMap.map (fun set-> group_revsort (IntSet.elements set) ) map
122 in
123
124 (* take group in source order, adding its non fullfilled dependencies in source order *)
125 (* a group cannot be recursiv (if not will loop)!!! *)
126 let rec order_group alltodo dones_set dones_list =
127 let already_done x = IntSet.mem x dones_set in
128 let deps x = IntMap.find x group_deps in
129 match alltodo with
130 | [] -> List.rev dones_list
131 | todo :: remtodo when already_done todo -> order_group remtodo dones_set dones_list
132 | todo :: remtodo ->
133 let newalltodo = List.fold_left (fun alltodo n-> if already_done n || n=todo then alltodo else (
134 n::alltodo)
135 ) alltodo (deps todo)
136 in
137 if alltodo=newalltodo then order_group remtodo (IntSet.add todo dones_set) (todo::dones_list)
138 else order_group newalltodo dones_set dones_list
139 in
140 let _groups_ordered = order_group groups_source_order IntSet.empty [] in
141 let _groups_map = IntMap.from_list _groups in
142 List.map (fun n->
143 let group = IntMap.find n _groups_map in
144 let is_rec =
145 IntSet.cardinal group > 1 ||
146 (let n = IntSet.choose group in
147 G.mem_edge graph n n) in
148 n,is_rec,group) _groups_ordered , depsMap
Something went wrong with that request. Please try again.