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