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 (C) 2012 Johannes 'josch' Schauer <j.schauer@email.de> *)
(* Copyright (C) 2012 Pietro Abate <pietro.abate@pps.jussieu.fr> *)
(* *)
(* This library is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Lesser General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version. A special linking *)
(* exception to the GNU Lesser General Public License applies to this *)
(* library, see the COPYING file for more information. *)
(**************************************************************************)
open! ExtLib
open Dose_common
module IntSet = BootstrapCommon.IntSet
module Make (U : sig val univ : Cudf.universe end) = struct
module G = SrcGraph.G
let string_of_intsetscc s =
let minpkg = CudfAdd.inttopkg U.univ (IntSet.min_elt s) in
let pkgname = BootstrapCommon.string_of_package minpkg in
let card = IntSet.cardinal s in
Printf.sprintf "%s, ... and %d more" pkgname (card-1)
let package_of_vertex = function
| SrcGraph.SrcPkg id ->
CudfAdd.inttopkg U.univ id
| SrcGraph.SCC s ->
CudfAdd.inttopkg U.univ (IntSet.min_elt s)
let string_of_vertex ?(fvs=IntSet.empty) = function
| SrcGraph.SrcPkg id ->
let pkg = CudfAdd.inttopkg U.univ id in
let name = BootstrapCommon.string_of_package pkg in
if IntSet.mem id fvs then name^"(*)" else name
| SrcGraph.SCC s ->
Printf.sprintf "SCC#%d (%s)" (IntSet.min_elt s) (string_of_intsetscc s)
let annotate is_strong g =
let ag = G.create () in
G.iter_edges_e (fun (v1,label,v2) ->
match v1 with
| SrcGraph.SrcPkg sid ->
let srcpkg = CudfAdd.inttopkg U.univ sid in
let binaries = !(label.SrcGraph.binaries) in
let strong = IntSet.filter (fun pid -> is_strong srcpkg (CudfAdd.inttopkg U.univ pid)) binaries in
if IntSet.is_empty strong then
G.add_edge_e ag (v1,label,v2)
else begin
(* these binary packages in the installation set are strong
* dependencies of the source package
* now figure out the set of binary packages from the source
* package's dependencies of which those binary packages are also
* strong dependencies *)
let s = List.fold_left (fun acc vpkglist ->
let pkgs = CudfAdd.resolve_deps U.univ vpkglist in
(* calculate the strong dependencies for each package in the
* disjunction
* intersect those strong dependencies with the strong
* dependencies found above *)
let inters = List.fold_left (fun acc pkg ->
let strong2 = try
IntSet.fold (fun pid acc ->
if is_strong pkg (CudfAdd.inttopkg U.univ pid) then IntSet.add pid acc else acc
) strong IntSet.empty
with _ ->
Printf.printf "not found: %s\n" (BootstrapCommon.string_of_package pkg);
IntSet.empty
in
IntSet.inter strong2 acc
) strong pkgs in
let pkgs = List.map (CudfAdd.pkgtoint U.univ) pkgs in
(* if the intersection of those sets is not empty, add the
* packages of the disjuction *)
if IntSet.is_empty inters then acc
else List.fold_right IntSet.add pkgs acc
) IntSet.empty (srcpkg.Cudf.depends) in
G.add_edge_e ag (v1,{SrcGraph.binaries=ref binaries; strong=strong; strong_direct=s; annotation=[]},v2)
end
| SrcGraph.SCC _ ->
failwith "not implemented"
) g;
ag
let collapse_scc g =
(* non degenerate strongly connected components *)
let sccs = (List.filter (function [] | [_] -> false | _ -> true) (SrcGraph.Comp.scc_list g)) in
List.iter (fun scc ->
(* for each scc, create a new SCC vertex, remove the old vertices and
* reconnect their edges to the new SCC vertex *)
let scc_set = List.fold_left (fun acc vert ->
match vert with
| SrcGraph.SrcPkg id -> IntSet.add id acc
| _ -> failwith "not implemented"
) IntSet.empty scc in
let scc_vert = SrcGraph.SCC scc_set in
List.iter (fun vert ->
G.iter_succ_e (fun (_,label,v) ->
match v with
| SrcGraph.SCC s ->
if IntSet.compare s scc_set <> 0 then begin
try match G.find_edge g scc_vert v with
| _,{ SrcGraph.binaries = s },_ -> s := IntSet.union !s !(label.SrcGraph.binaries)
with Not_found -> G.add_edge_e g (scc_vert,label,v)
end
| SrcGraph.SrcPkg id ->
if not (IntSet.mem id scc_set) then begin
try match G.find_edge g scc_vert v with
| _,{ SrcGraph.binaries = s },_ -> s := IntSet.union !s !(label.SrcGraph.binaries)
with Not_found -> G.add_edge_e g (scc_vert,label,v)
end
) g vert;
G.iter_pred_e (fun (v,label,_) ->
match v with
| SrcGraph.SCC s ->
if IntSet.compare s scc_set <> 0 then begin
try match G.find_edge g v scc_vert with
| _,{ SrcGraph.binaries = s },_ -> s := IntSet.union !s !(label.SrcGraph.binaries)
with Not_found -> G.add_edge_e g (v,label,scc_vert)
end
| SrcGraph.SrcPkg id ->
if not (IntSet.mem id scc_set) then begin
try match G.find_edge g v scc_vert with
| _,{ SrcGraph.binaries = s },_ -> s := IntSet.union !s !(label.SrcGraph.binaries)
with Not_found -> G.add_edge_e g (v,label,scc_vert)
end
) g vert;
G.remove_vertex g vert;
) scc;
) sccs;
(* pass over the vertices in the resulting graph and replace all self cycles
* with an SCC node *)
G.iter_edges (fun v1 v2 ->
match v1,v2 with
| SrcGraph.SrcPkg sid1, SrcGraph.SrcPkg sid2 ->
if sid1 = sid2 then begin
G.remove_edge g v1 v2;
let newvert = SrcGraph.SCC (IntSet.singleton sid1) in
G.iter_succ_e (fun (_,label,v2) -> G.add_edge_e g (newvert,label,v2)) g v1;
G.iter_pred_e (fun (v2,label,_) -> G.add_edge_e g (v2,label,newvert)) g v1;
G.remove_vertex g v1;
end
| _ -> ()
) g;
end
|
