From 3a8d150b04bcccd12d05af5a5613bac4452ca618 Mon Sep 17 00:00:00 2001
From: "jerome.vouillon" <jerome.vouillon@pps.jussieu.fr>
Date: Wed, 9 Nov 2011 10:41:17 +0000
Subject: [PATCH] Concurrent implementation

---
 .depend           |  108 +++--
 Makefile          |    8 +-
 bytearray.ml      |   97 ++++
 bytearray.mli     |   27 ++
 bytearray_stubs.c |   52 +++
 deb_lib.ml        |    7 +
 deb_lib.mli       |    1 +
 task.ml           |  225 +++++++++
 task.mli          |   39 ++
 task_stubs.c      |   12 +
 transition.ml     | 1125 ++++++++++++++++++++++++++++-----------------
 upgrade.ml        |    2 +
 upgrade_common.ml |    8 +-
 util.ml           |   20 +-
 util.mli          |    8 +
 15 files changed, 1250 insertions(+), 489 deletions(-)
 create mode 100644 bytearray.ml
 create mode 100644 bytearray.mli
 create mode 100644 bytearray_stubs.c
 create mode 100644 task.ml
 create mode 100644 task.mli
 create mode 100644 task_stubs.c

diff --git a/.depend b/.depend
index 1cc0c9b..6dffdb0 100644
--- a/.depend
+++ b/.depend
@@ -1,65 +1,71 @@
-./coinst_common.cmi: repository.cmi quotient.cmi api.cmi
-./conflicts.cmo: repository.cmi quotient.cmi
-./conflicts.cmx: repository.cmx quotient.cmx
+./upgrade.cmo: util.cmi upgrade_common.cmi quotient.cmi graph.cmi file.cmi \
+    deb_lib.cmi
+./upgrade.cmx: util.cmx upgrade_common.cmx quotient.cmx graph.cmx file.cmx \
+    deb_lib.cmx
+./quotient.cmi: repository.cmi
+./common.cmo: util.cmi ./common.cmi
+./common.cmx: util.cmx ./common.cmi
+./upgrade_common.cmi: repository.cmi deb_lib.cmi
 ./cudf_lib.cmi: api.cmi
-./rpm_lib.cmo: util.cmi solver.cmi common.cmi ./rpm_lib.cmi
-./rpm_lib.cmx: util.cmx solver.cmx common.cmx ./rpm_lib.cmi
-./task.cmo:
-./task.cmx:
+./bytearray.cmi:
 ./file.cmo: ./file.cmi
 ./file.cmx: ./file.cmi
-./debug.cmo: ./debug.cmi
-./debug.cmx: ./debug.cmi
-./comp.cmo: deb_lib.cmi
-./comp.cmx: deb_lib.cmx
-./upgrade_common.cmi: repository.cmi deb_lib.cmi
-./solver.cmi:
-./dgraph.cmo: ./dgraph.cmi
-./dgraph.cmx: ./dgraph.cmi
-./file.cmi:
-./util.cmo: ./util.cmi
-./util.cmx: ./util.cmi
-./debug.cmi:
-./graph.cmo: repository.cmi quotient.cmi conflicts.cmo ./graph.cmi
-./graph.cmx: repository.cmx quotient.cmx conflicts.cmx ./graph.cmi
-./api.cmi: solver.cmi
-./quotient.cmi: repository.cmi
-./rpm_lib.cmi: api.cmi
-./util.cmi:
+./coinst_common.cmi: repository.cmi quotient.cmi api.cmi
 ./main.cmo: util.cmi rpm_lib.cmi repository.cmi quotient.cmi graph.cmi \
     file.cmi deb_lib.cmi api.cmi
 ./main.cmx: util.cmx rpm_lib.cmx repository.cmx quotient.cmx graph.cmx \
     file.cmx deb_lib.cmx api.cmx
-./upgrade.cmo: util.cmi upgrade_common.cmi quotient.cmi graph.cmi file.cmi \
-    deb_lib.cmi
-./upgrade.cmx: util.cmx upgrade_common.cmx quotient.cmx graph.cmx file.cmx \
-    deb_lib.cmx
-./coinst_common.cmo: repository.cmi quotient.cmi api.cmi ./coinst_common.cmi
-./coinst_common.cmx: repository.cmx quotient.cmx api.cmx ./coinst_common.cmi
-./quotient.cmo: util.cmi repository.cmi ./quotient.cmi
-./quotient.cmx: util.cmx repository.cmx ./quotient.cmi
-./api.cmo: solver.cmi ./api.cmi
-./api.cmx: solver.cmx ./api.cmi
-./upgrade_common.cmo: util.cmi graph.cmi deb_lib.cmi coinst_common.cmi \
-    ./upgrade_common.cmi
-./upgrade_common.cmx: util.cmx graph.cmx deb_lib.cmx coinst_common.cmx \
-    ./upgrade_common.cmi
+./debug.cmo: ./debug.cmi
+./debug.cmx: ./debug.cmi
+./repository.cmi: util.cmi api.cmi
 ./deb_lib.cmo: util.cmi solver.cmi common.cmi ./deb_lib.cmi
 ./deb_lib.cmx: util.cmx solver.cmx common.cmx ./deb_lib.cmi
-./common.cmi:
-./repository.cmo: util.cmi api.cmi ./repository.cmi
-./repository.cmx: util.cmx api.cmx ./repository.cmi
+./rpm_lib.cmi: api.cmi
+./util.cmi:
+./dgraph.cmi:
 ./solver.cmo: ./solver.cmi
 ./solver.cmx: ./solver.cmi
+./rpm_lib.cmo: util.cmi solver.cmi common.cmi ./rpm_lib.cmi
+./rpm_lib.cmx: util.cmx solver.cmx common.cmx ./rpm_lib.cmi
+./quotient.cmo: util.cmi repository.cmi ./quotient.cmi
+./quotient.cmx: util.cmx repository.cmx ./quotient.cmi
+./debug.cmi:
+./bytearray.cmo: ./bytearray.cmi
+./bytearray.cmx: ./bytearray.cmi
+./parallel.cmo: task.cmi file.cmi deb_lib.cmi
+./parallel.cmx: task.cmx file.cmx deb_lib.cmx
+./file.cmi:
+./api.cmo: solver.cmi ./api.cmi
+./api.cmx: solver.cmx ./api.cmi
+./conflicts.cmo: repository.cmi quotient.cmi
+./conflicts.cmx: repository.cmx quotient.cmx
+./coinst_common.cmo: repository.cmi quotient.cmi debug.cmi api.cmi \
+    ./coinst_common.cmi
+./coinst_common.cmx: repository.cmx quotient.cmx debug.cmx api.cmx \
+    ./coinst_common.cmi
+./graph.cmi: repository.cmi quotient.cmi
 ./cudf_lib.cmo: solver.cmi common.cmi ./cudf_lib.cmi
 ./cudf_lib.cmx: solver.cmx common.cmx ./cudf_lib.cmi
-./common.cmo: util.cmi ./common.cmi
-./common.cmx: util.cmx ./common.cmi
-./transition.cmo: util.cmi upgrade_common.cmi repository.cmi file.cmi \
-    debug.cmi deb_lib.cmi
-./transition.cmx: util.cmx upgrade_common.cmx repository.cmx file.cmx \
-    debug.cmx deb_lib.cmx
+./task.cmi:
+./api.cmi: solver.cmi
+./upgrade_common.cmo: util.cmi graph.cmi debug.cmi deb_lib.cmi \
+    coinst_common.cmi ./upgrade_common.cmi
+./upgrade_common.cmx: util.cmx graph.cmx debug.cmx deb_lib.cmx \
+    coinst_common.cmx ./upgrade_common.cmi
+./task.cmo: util.cmi debug.cmi bytearray.cmi ./task.cmi
+./task.cmx: util.cmx debug.cmx bytearray.cmx ./task.cmi
 ./deb_lib.cmi: util.cmi solver.cmi api.cmi
-./graph.cmi: repository.cmi quotient.cmi
-./repository.cmi: util.cmi api.cmi
-./dgraph.cmi:
+./repository.cmo: util.cmi api.cmi ./repository.cmi
+./repository.cmx: util.cmx api.cmx ./repository.cmi
+./dgraph.cmo: ./dgraph.cmi
+./dgraph.cmx: ./dgraph.cmi
+./util.cmo: ./util.cmi
+./util.cmx: ./util.cmi
+./common.cmi:
+./graph.cmo: repository.cmi quotient.cmi conflicts.cmo ./graph.cmi
+./graph.cmx: repository.cmx quotient.cmx conflicts.cmx ./graph.cmi
+./solver.cmi:
+./transition.cmo: util.cmi upgrade_common.cmi task.cmi repository.cmi \
+    file.cmi debug.cmi deb_lib.cmi
+./transition.cmx: util.cmx upgrade_common.cmx task.cmx repository.cmx \
+    file.cmx debug.cmx deb_lib.cmx
diff --git a/Makefile b/Makefile
index 529f3b2..05b67d2 100644
--- a/Makefile
+++ b/Makefile
@@ -3,13 +3,13 @@ COINST=coinst
 UPGRADE=upgrade
 TRANS=transition
 
-
 OCAMLC=ocamlfind ocamlc
 OCAMLOPT=ocamlfind ocamlopt
 OCAMLDEP=ocamldep
 
-OBJS = util.cmx file.cmx debug.cmx common.cmx dgraph.cmx solver.cmx api.cmx deb_lib.cmx rpm_lib.cmx repository.cmx quotient.cmx conflicts.cmx graph.cmx coinst_common.cmx
-COMPFLAGS=-package unix,str
+TASK = bytearray_stubs.o bytearray.cmx task_stubs.o task.cmx
+OBJS = util.cmx file.cmx debug.cmx common.cmx solver.cmx api.cmx deb_lib.cmx rpm_lib.cmx repository.cmx quotient.cmx conflicts.cmx graph.cmx coinst_common.cmx
+COMPFLAGS=-package unix,str,bigarray -g
 OPTLINKFLAGS=$(COMPFLAGS) -linkpkg
 
 all: $(COINST) $(UPGRADE) $(TRANS)
@@ -23,7 +23,7 @@ $(COINST).byte: $(OBJS:.cmx=.cmo) main.cmo
 $(UPGRADE): $(OBJS) upgrade_common.cmx upgrade.cmx
 	$(OCAMLOPT) -o $@  $(OPTLINKFLAGS) $^ $(LINKFLAGS)
 
-$(TRANS): $(OBJS) upgrade_common.cmx transition.cmx
+$(TRANS): $(OBJS) $(TASK) upgrade_common.cmx transition.cmx
 	$(OCAMLOPT) -o $@  $(OPTLINKFLAGS) $^ $(LINKFLAGS)
 
 clean::
diff --git a/bytearray.ml b/bytearray.ml
new file mode 100644
index 0000000..3a01ead
--- /dev/null
+++ b/bytearray.ml
@@ -0,0 +1,97 @@
+(* Unison file synchronizer: src/bytearray.ml *)
+(* Copyright 1999-2010, Benjamin C. Pierce 
+
+    This program is free software: you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation, either version 3 of the License, or
+    (at your option) any later version.
+
+    This program 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 General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+*)
+
+open Bigarray
+
+type t = (char, int8_unsigned_elt, c_layout) Array1.t
+
+let length = Bigarray.Array1.dim
+
+let create l = Bigarray.Array1.create Bigarray.char Bigarray.c_layout l
+
+(*
+let unsafe_blit_from_string s i a j l =
+  for k = 0 to l - 1 do
+    a.{j + k} <- s.[i + k]
+  done
+
+let unsafe_blit_to_string a i s j l =
+  for k = 0 to l - 1 do
+    s.[j + k] <- a.{i + k}
+  done
+*)
+
+external unsafe_blit_from_string : string -> int -> t -> int -> int -> unit
+  = "ml_blit_string_to_bigarray" "noalloc"
+
+external unsafe_blit_to_string : t -> int -> string -> int -> int -> unit
+  = "ml_blit_bigarray_to_string" "noalloc"
+
+let to_string a =
+  let l = length a in
+  if l > Sys.max_string_length then invalid_arg "Bytearray.to_string" else
+  let s = String.create l in
+  unsafe_blit_to_string a 0 s 0 l;
+  s
+
+let of_string s =
+  let l = String.length s in
+  let a = create l in
+  unsafe_blit_from_string s 0 a 0 l;
+  a
+
+let sub a ofs len =
+  if
+    ofs < 0 || len < 0 || ofs > length a - len || len > Sys.max_string_length
+  then
+    invalid_arg "Bytearray.sub"
+  else begin
+    let s = String.create len in
+    unsafe_blit_to_string a ofs s 0 len;
+    s
+  end
+
+let rec prefix_rec a i a' i' l =
+  l = 0 ||
+  (a.{i} = a'.{i'} && prefix_rec a (i + 1) a' (i' + 1) (l - 1))
+
+let prefix a a' i =
+  let l = length a in
+  let l' = length a' in
+  i <= l' - l &&
+  prefix_rec a 0 a' i l
+
+let blit_from_string s i a j l =
+  if l < 0 || i < 0 || i > String.length s - l
+           || j < 0 || j > length a - l
+  then invalid_arg "Bytearray.blit_from_string"
+  else unsafe_blit_from_string s i a j l
+
+let blit_to_string a i s j l =
+  if l < 0 || i < 0 || i > length a - l
+           || j < 0 || j > String.length s - l
+  then invalid_arg "Bytearray.blit_to_string"
+  else unsafe_blit_to_string a i s j l
+
+external marshal : 'a -> Marshal.extern_flags list -> t
+  = "ml_marshal_to_bigarray"
+
+external marshal_to_buffer : t -> int -> 'a -> Marshal.extern_flags list -> int
+  = "ml_marshal_to_bigarray_buffer"
+
+external unmarshal : t -> int -> 'a
+  = "ml_unmarshal_from_bigarray"
diff --git a/bytearray.mli b/bytearray.mli
new file mode 100644
index 0000000..74532b2
--- /dev/null
+++ b/bytearray.mli
@@ -0,0 +1,27 @@
+(* Unison file synchronizer: src/bytearray.mli *)
+(* Copyright 1999-2010, Benjamin C. Pierce (see COPYING for details) *)
+
+type t =
+  (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
+
+val create : int -> t
+
+val length : t -> int
+
+val to_string : t -> string
+
+val of_string : string -> t
+
+val sub : t -> int -> int -> string
+
+val blit_from_string : string -> int -> t -> int -> int -> unit
+
+val blit_to_string : t -> int -> string -> int -> int -> unit
+
+val prefix : t -> t -> int -> bool
+
+val marshal : 'a -> Marshal.extern_flags list -> t
+
+val unmarshal : t -> int -> 'a
+
+val marshal_to_buffer : t -> int -> 'a -> Marshal.extern_flags list -> int
diff --git a/bytearray_stubs.c b/bytearray_stubs.c
new file mode 100644
index 0000000..5cb8930
--- /dev/null
+++ b/bytearray_stubs.c
@@ -0,0 +1,52 @@
+/* Unison file synchronizer: src/bytearray_stubs.c */
+/* Copyright 1999-2010 (see COPYING for details) */
+
+#include <string.h>
+
+#include "caml/intext.h"
+#include "caml/bigarray.h"
+
+#define Array_data(a, i) (((char *) a->data) + Long_val(i))
+
+CAMLprim value ml_marshal_to_bigarray(value v, value flags)
+{
+  char *buf;
+  long len;
+  output_value_to_malloc(v, flags, &buf, &len);
+  return alloc_bigarray(BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT | BIGARRAY_MANAGED,
+                        1, buf, &len);
+}
+
+CAMLprim value ml_marshal_to_bigarray_buffer(value b, value ofs,
+                                             value v, value flags)
+{
+  struct caml_bigarray *b_arr = Bigarray_val(b);
+  return Val_long(caml_output_value_to_block(v, flags, Array_data (b_arr, ofs),
+					     b_arr->dim[0] - Long_val(ofs)));
+}
+
+
+CAMLprim value ml_unmarshal_from_bigarray(value b, value ofs)
+{
+  struct caml_bigarray *b_arr = Bigarray_val(b);
+  return input_value_from_block (Array_data (b_arr, ofs),
+                                 b_arr->dim[0] - Long_val(ofs));
+}
+
+CAMLprim value ml_blit_string_to_bigarray
+(value s, value i, value a, value j, value l)
+{
+  char *src = String_val(s) + Int_val(i);
+  char *dest = Array_data(Bigarray_val(a), j);
+  memcpy(dest, src, Long_val(l));
+  return Val_unit;
+}
+
+CAMLprim value ml_blit_bigarray_to_string
+(value a, value i, value s, value j, value l)
+{
+  char *src = Array_data(Bigarray_val(a), i);
+  char *dest = String_val(s) + Long_val(j);
+  memcpy(dest, src, Long_val(l));
+  return Val_unit;
+}
diff --git a/deb_lib.ml b/deb_lib.ml
index a46dd9f..d30ea27 100644
--- a/deb_lib.ml
+++ b/deb_lib.ml
@@ -981,6 +981,13 @@ let only_latest pool' =
     pool'.packages_by_name;
   pool
 
+let copy pool =
+  { size = pool.size;
+    packages = Hashtbl.copy pool.packages;
+    packages_by_name = ListTbl.copy pool.packages_by_name;
+    packages_by_num = Hashtbl.copy pool.packages_by_num;
+    provided_packages = ListTbl.copy pool.provided_packages }
+
 let merge pool filter pool' =
   Hashtbl.iter
     (fun _ p ->
diff --git a/deb_lib.mli b/deb_lib.mli
index ae12b32..ed625fc 100644
--- a/deb_lib.mli
+++ b/deb_lib.mli
@@ -61,6 +61,7 @@ val resolve_package_dep_raw :
 
 val only_latest : pool -> pool
 
+val copy : pool -> pool
 val merge : pool -> (int -> bool) -> pool -> unit
 val merge2 : pool -> (p -> bool) -> pool -> unit
 val add_package : pool -> p -> int
diff --git a/task.ml b/task.ml
new file mode 100644
index 0000000..cddb6d8
--- /dev/null
+++ b/task.ml
@@ -0,0 +1,225 @@
+(* Co-installability tools
+ * http://coinst.irill.org/
+ * Copyright (C) 2011 Jérôme Vouillon
+ * Laboratoire PPS - CNRS Université Paris Diderot
+ *
+ * These programs are free software; you can redistribute them and/or
+ * modify them under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program 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
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program.  If not, see <http://www.gnu.org/licenses/>.
+ *)
+
+(*
+TODO:
+- error handling
+- clear marshalled when large
+*)
+
+let debug_task = Debug.make "tasks" "debug client/server communication" []
+
+module Utimer = Util.Utimer
+
+type stats =
+  { mutable marshal_time : float;
+    mutable unmarshal_time : float }
+
+let stats = { marshal_time = 0.; unmarshal_time = 0. }
+let side = ref "SRV"
+
+type indirect =
+  { pipe_in : Unix.file_descr;
+    pipe_out : Unix.file_descr;
+    mem : Bytearray.t;
+    pid : int }
+
+type 'a t = Local of 'a | Remote of indirect
+
+type 'a future_state = Running of indirect | Finished of 'a
+
+type 'a future = 'a future_state ref
+
+let mem_size = 1 lsl 24
+
+external processor_count : unit -> int = "task_processor_count"
+
+let proc_count = ref (processor_count ())
+
+let get_processor_count () = !proc_count
+let set_processor_count n = proc_count := if n < 1 then 1 else n
+
+let function_count = ref 0
+let functions = Hashtbl.create 17
+
+let send pipe i l =
+  let s = Printf.sprintf "%d %d\n" i l in
+  ignore (Unix.write pipe s 0 (String.length s))
+
+let receive pipe =
+  let s = String.create 50 in
+  let len = Unix.read pipe s 0 (String.length s) in
+  if len = 0 then exit 0;
+  Scanf.sscanf s "%d %d" (fun i l -> (i, l))
+
+let read mem l =
+  let t = Utimer.start () in
+  let res = Bytearray.unmarshal mem 0 in (*XXX Clear the data if large*)
+  let dt = Utimer.stop t in
+  stats.unmarshal_time <- stats.unmarshal_time +. dt;
+  if debug_task () then Format.eprintf "Unmarshal: %s %f (%d)@." !side dt l;
+  res
+
+let write mem v =
+  let t = Utimer.start () in
+  let res = Bytearray.marshal_to_buffer mem 0 v [] in
+  let dt = Utimer.stop t in
+  stats.marshal_time <- stats.marshal_time +. dt;
+  if debug_task () then Format.eprintf "Marshal:   %s %f (%d)@." !side dt res;
+  res
+
+let funct f =
+  let i = !function_count in
+  incr function_count;
+  Hashtbl.add functions i
+    (fun st mem l -> write mem (f (Obj.obj st) (read mem l)));
+  fun st x ->
+    match st with
+      Local st ->
+        ref (Finished (f st x))
+    | Remote st ->
+        send st.pipe_out i (write st.mem x);
+        ref (Running st)
+
+let _ =
+at_exit (fun _ ->
+if debug_task () then
+  Format.eprintf "===>> marshal: %f / unmarshal: %f@."
+    stats.marshal_time stats.unmarshal_time)
+
+let spawn f =
+  if !proc_count <= 1 then
+    Local (f ())
+  else begin
+    let (cr, sw) = Unix.pipe () in
+    let (sr, cw) = Unix.pipe () in
+    let fd = Unix.openfile "/dev/zero" [Unix.O_RDWR] 0 in
+    let mem =
+      Bigarray.Array1.map_file
+        fd Bigarray.char Bigarray.c_layout true mem_size
+    in
+    Unix.close fd;
+    match Unix.fork () with
+      0 ->
+        Unix.close sr; Unix.close sw;
+        stats.marshal_time <- 0.; stats.unmarshal_time <- 0.;
+        side := "CLI";
+        let st = Obj.repr (f ()) in
+        let rec loop () =
+          let (i, l) = receive cr in
+          if i < 0 then
+            exit 0
+          else begin
+            let f = Hashtbl.find functions i in
+            let l = f st mem l in
+            send cw 0 l;
+            loop ()
+          end
+        in
+        loop ()
+    | pid ->
+        Unix.close cr; Unix.close cw;
+        Remote { pipe_in = sr; pipe_out = sw; mem = mem; pid = pid }
+  end
+
+let kill st =
+  match st with
+    Local _   ->
+      ()
+  | Remote st ->
+      send st.pipe_out (-1) 0;
+      Unix.close st.pipe_in; Unix.close st.pipe_out;
+      (*XXX Clear mmapped memory *)
+      ignore (Unix.waitpid [] st.pid)
+
+let wait fut =
+  match !fut with
+    Finished v ->
+      v
+  | Running st ->
+      let t = Unix.gettimeofday () in
+      let (i, l) = receive st.pipe_in in
+      if debug_task () then
+        Format.eprintf "Wait:         %f@." (Unix.gettimeofday () -. t);
+      let v = read st.mem l in
+      fut := Finished v;
+      v
+
+type scheduler =
+  { mutable fds : Unix.file_descr list;
+    conts : (Unix.file_descr, int -> unit) Hashtbl.t }
+
+let scheduler () = { fds = []; conts = Hashtbl.create 11 }
+
+let async sched fut f =
+  match !fut with
+    Finished v ->
+      f v
+  | Running st ->
+      let g l =
+        let v = read st.mem l in
+        fut := Finished v;
+        f v
+      in
+      sched.fds <- st.pipe_in :: sched.fds;
+      Hashtbl.add sched.conts st.pipe_in g
+
+let run sched =
+  while sched.fds <> [] do
+    let t = Unix.gettimeofday () in
+    let (avail, _, _) = Unix.select sched.fds [] [] (-1.) in
+    if debug_task () then
+      Format.eprintf "Wait:         %f@." (Unix.gettimeofday () -. t);
+    sched.fds <- List.filter (fun fd -> not (List.mem fd avail)) sched.fds;
+    List.iter
+      (fun fd ->
+         let cont = Hashtbl.find sched.conts fd in
+         Hashtbl.remove sched.conts fd;
+         let (i, l) = receive fd in
+         cont l)
+      avail
+  done
+
+let map l pre post =
+  List.map (fun x -> post (wait x)) (List.map pre l)
+
+let iter l pre post =
+  List.iter (fun x -> post (wait x)) (List.map pre l)
+
+let iteri l pre post =
+  List.iter (fun (x, y) -> post x (wait y)) (List.map pre l)
+
+(*
+
+#ifdef MADV_REMOVE
+    if (madvise(ptr, size, MADV_REMOVE) >= 0)
+        return;
+#endif
+
+#ifdef MADV_FREE
+    if (madvise(ptr, size, MADV_FREE) >= 0)
+        return;
+#endif
+
+#ifdef MADV_DONTNEED
+    madvise(ptr, size, MADV_DONTNEED);
+#endif
+}
+
+*)
diff --git a/task.mli b/task.mli
new file mode 100644
index 0000000..2aa60d8
--- /dev/null
+++ b/task.mli
@@ -0,0 +1,39 @@
+(* Co-installability tools
+ * http://coinst.irill.org/
+ * Copyright (C) 2011 Jérôme Vouillon
+ * Laboratoire PPS - CNRS Université Paris Diderot
+ *
+ * These programs are free software; you can redistribute them and/or
+ * modify them under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program 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
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program.  If not, see <http://www.gnu.org/licenses/>.
+ *)
+
+type 'a t
+type 'a future
+
+val spawn : (unit -> 'a) -> 'a t
+val funct : ('a -> 'b -> 'c) -> 'a t -> 'b -> 'c future
+val wait : 'a future -> 'a
+val kill : 'a t -> unit
+
+val map : 'a list -> ('a -> 'b future) -> ('b -> 'c) -> 'c list
+val iter : 'a list -> ('a -> 'b future) -> ('b -> unit) -> unit
+val iteri : 'a list -> ('a -> ('b * 'c future)) -> ('b -> 'c -> unit) -> unit
+
+type scheduler
+
+val scheduler : unit -> scheduler
+val async : scheduler -> 'a future -> ('a -> unit) -> unit
+val run : scheduler -> unit
+
+val get_processor_count : unit -> int
+val set_processor_count : int -> unit
diff --git a/task_stubs.c b/task_stubs.c
new file mode 100644
index 0000000..65ba21b
--- /dev/null
+++ b/task_stubs.c
@@ -0,0 +1,12 @@
+#include <unistd.h>
+#include "caml/mlvalues.h"
+
+CAMLprim value task_processor_count (value unit) {
+  long v;
+  #ifdef _SC_NPROCESSORS_ONLN
+  v = sysconf (_SC_NPROCESSORS_ONLN);
+  #else
+  v = 1;
+  #endif
+  return Val_long ((v<=0)?1:v);
+}
diff --git a/transition.ml b/transition.ml
index 68658d1..504208f 100644
--- a/transition.ml
+++ b/transition.ml
@@ -18,36 +18,43 @@
  *)
 
 (*
+- option to disable caching
+- option to set the number of processors available
+- should start finding conflicts while reducing repositories
+  ==> if not yet available when finding conflucts, compute
+  ==> if threads available, use them to reduce the repository
+  
 PRIORITIES
-==> save learnt clauses
-==> graphs for reporting co-installability issues
-==> explain what it takes to migrate a package
-==> find a way to indicate what corresponds to each new
-    co-installability issue
-    ==> if I upgrade, these packages will be broken
-        if I don't, these other packages will be broken (?)
-==> how do we ignore co-installability issues?
-==> allow package removal
-==> indicate which packages would be propagated by britney but not by
-    this tool
-
-
-  Generate explanations
+  ==> graphs for reporting co-installability issues:
+      should include "problematic packages" in the graph,
+      and illustrate how the issue changes between testing and unstable
+      - packages may be in testing, sid, or both; in the latter case,
+        they may have different version between the two
+      - dependencies can be in testing, sid, or both
+      - dependency targets may be in testing, sid, or both
+      - same thing for each side of a conflict (!)
+      indicate which set of packages are made non-coinstallable
+
+  ==> option to indicate which packages would be propagated by britney
+      but not by this tool
+  ==> find what it takes to install a package:
+      iterative (relax the problem until we can install the package);
+      with clause learning
+  ==> add possibility to migrate packages with co-installability issues
+      (find out the right kind of hints)
+
+PERFORMANCE
+  ==> parallelise the program: one process per architecture
+
+EXPLANATIONS
   ==> link to build logs / merge packages
   ==> link to http://packages.qa.debian.org (for source files)
   ==> link to bugs
   ==> show source and binary versions
   ==> three step: no age/bug constraints, bugs added, all
-  ==> show packages that only wait for age, for bugs
-
-  Find what it takes to install a package
-  ==> iterative: relax the problem until we can install the package
-  ==> with clause learning
-  ==> we could save learnt rules...
-
-  - parallelise the program: one process per architecture
-
-  - associate a nice graph to each co-installability issue found
+  ==> summaries; in particular, show packages that only wait for age,
+      for bugs
+  ==> explanation of co-installability issues
 *)
 
 let dir = ref (Filename.concat (Sys.getenv "HOME") "debian-dists/britney")
@@ -114,6 +121,8 @@ let make_uid () =
        (Int64.mul magic1 (Int64.of_float (1e6 *. Unix.gettimeofday ())))
        (Int64.mul magic2 (Int64.of_int (Unix.getpid ()))))
 
+let cache_disabled = ref false
+
 let cached ?(force=false) files cache magic f =
   let magic =
     Format.sprintf
@@ -122,7 +131,7 @@ let cached ?(force=false) files cache magic f =
   in
   let ch = try Some (open_in cache) with Sys_error _ -> None in
   let should_compute =
-    force ||
+    !cache_disabled || force ||
     match ch with
       None ->
         true
@@ -147,15 +156,17 @@ let cached ?(force=false) files cache magic f =
   if should_compute then begin
     begin match ch with Some ch -> close_in ch | None -> () end;
     let res = f () in
-    let tmp = cache ^ ".tmp" in
-    Util.make_directories tmp;
-    let ch = open_out tmp in
-    output_string ch magic;
     let uid = make_uid () in
-    output_string ch uid;
-    Marshal.to_channel ch res [];
-    close_out ch;
-    Sys.rename tmp cache;
+    if not !cache_disabled then begin
+      let tmp = cache ^ ".tmp" in
+      Util.make_directories tmp;
+      let ch = open_out tmp in
+      output_string ch magic;
+      output_string ch uid;
+      Marshal.to_channel ch res [];
+      close_out ch;
+      Sys.rename tmp cache
+    end;
     (res, uid)
   end else begin
     match ch with
@@ -175,7 +186,7 @@ let _ =
 Printexc.record_backtrace true;
 Gc.set { (Gc.get ())
          with Gc.space_overhead = 200; max_overhead = 1000000;
-              major_heap_increment = 20 * 1024 * 1024 }
+              major_heap_increment = 5 * 1024 * 1024 }
 
 module Timer = Util.Timer
 module ListTbl = Util.ListTbl
@@ -317,10 +328,13 @@ let read_hints dir =
 let read_extra_info () =
   let dates = read_dates (Filename.concat (testing ()) "Dates") in
   let urgencies = read_urgencies (Filename.concat (testing ()) "Urgency") in
+  let hints = read_hints  (Filename.concat (unstable ()) "Hints") in
+  (dates, urgencies, hints)
+
+let read_bugs () =
   let testing_bugs = read_bugs (Filename.concat (testing ()) "BugsV") in
   let unstable_bugs = read_bugs (Filename.concat (unstable ()) "BugsV") in
-  let hints = read_hints  (Filename.concat (unstable ()) "Hints") in
-  (dates, urgencies, testing_bugs, unstable_bugs, hints)
+  (testing_bugs, unstable_bugs)
 
 (****)
 
@@ -406,26 +420,32 @@ let print_reason f reason =
         l;
       Format.fprintf f " cannot be propagated all at once"
 
-let unchanged = ListTbl.create 101
+let unchanged_reasons = ListTbl.create 101
+let unchanged = Hashtbl.create 17
 
 let propagation_rules = Hashtbl.create 101
 
+let init_changes () =
+  List.iter (fun arch -> Hashtbl.add unchanged arch (Hashtbl.create 1001))
+    ("source" :: !archs)
+
 let rec no_change pkg reason =
+  ListTbl.add unchanged_reasons pkg reason;
   let (nm, arch) = pkg in
-  let already = ListTbl.mem unchanged (nm, arch) in
-  ListTbl.add unchanged (nm, arch) reason;
-  if not already then begin
-    if reason <> Unchanged && verbose () then
-      Format.eprintf "Skipping %s (%s): %a@."
-        nm arch print_reason reason;
-    let l = Hashtbl.find_all propagation_rules (nm, arch) in
+  let unchanged' = Hashtbl.find unchanged arch in
+  if not (Hashtbl.mem unchanged' nm) then begin
+    Hashtbl.add unchanged' nm ();
+    if reason <> Unchanged && verbose () then begin
+      Format.eprintf "Skipping %s (%s): %a@." nm arch print_reason reason
+    end;
+    let l = Hashtbl.find_all propagation_rules pkg in
     List.iter (fun (pkg', reason') -> no_change pkg' reason') l
   end
 
 (* if pkg2 is unchanged, then pkg1 should be unchanged as well. *)
 let associates pkg1 pkg2 reason =
   let (nm, arch) = pkg2 in
-  if ListTbl.mem unchanged (nm, arch) then
+  if Hashtbl.mem (Hashtbl.find unchanged arch) nm then
     no_change pkg1 reason
   else
     Hashtbl.add propagation_rules (nm, arch) (pkg1, reason)
@@ -443,14 +463,15 @@ let all_or_none pkgs reason =
 
 let learnt_rules = ref []
 
-let learn_rule nm version arch neg s =
-  learnt_rules := (nm, version, arch, neg, s) :: !learnt_rules
+let learn_rule nm arch neg s =
+  learnt_rules := (nm, arch, neg, s) :: !learnt_rules
 
-let load_rules uid =
+let load_rules uids =
   let cache = Filename.concat cache_dir "Rules" in
-  let (rules, _) = cached [] cache ("version 1\n" ^ uid) (fun () -> []) in
+  let uids = String.concat "\n" uids in
+  let (rules, _) = cached [] cache ("version 2\n" ^ uids) (fun () -> []) in
   List.iter
-    (fun (nm, version, arch, neg, s) ->
+    (fun (nm, arch, neg, s) ->
        if StringSet.is_empty neg then
          no_change (nm, arch) (Conflict (neg, s))
        else if StringSet.cardinal neg = 1 then
@@ -459,9 +480,10 @@ let load_rules uid =
     rules;
   learnt_rules := rules
 
-let save_rules uid =
+let save_rules uids =
   let cache = Filename.concat cache_dir "Rules" in
-  ignore (cached ~force:true [] cache ("version 1\n" ^ uid)
+  let uids = String.concat "\n" uids in
+  ignore (cached ~force:true [] cache ("version 2\n" ^ uids)
             (fun () -> List.rev !learnt_rules))
 
 (****)
@@ -499,12 +521,27 @@ let group compare l =
 
 (****)
 
+type st =
+  { arch : string;
+    testing : M.pool;
+    unstable : M.pool;
+    testing_srcs : (string, M.s) Hashtbl.t;
+    unstable_srcs : (string, M.s) Hashtbl.t;
+    unstable_bugs : (string, StringSet.t) Hashtbl.t;
+    testing_bugs : (string, StringSet.t) Hashtbl.t;
+    mutable upgrade_state :
+      (Upgrade_common.state * Upgrade_common.state) option;
+    uid : string }
+
+(****)
+
 let rec interesting_reason r =
   match r with
     Unchanged ->
       false
   | Binary_not_propagated (bin, arch) ->
-      List.exists interesting_reason (ListTbl.find unchanged (bin, arch))
+      List.exists interesting_reason
+        (ListTbl.find unchanged_reasons (bin, arch))
   | Source_not_propagated _ ->
       false
   | Atomic _ ->
@@ -512,29 +549,55 @@ let rec interesting_reason r =
   | _ ->
       true
 
+let binary_sources st l =
+  List.map
+    (fun nm ->
+       let source =
+         match ListTbl.find st.unstable.M.packages_by_name nm with
+           p :: _ -> fst p.M.source
+         | []     -> match ListTbl.find st.testing.M.packages_by_name nm with
+                       p :: _ -> fst p.M.source
+                     | []     -> assert false
+       in
+       (nm, source))
+    l
+
+let binary_sources = Task.funct binary_sources
+
 let output_reasons l filename =
+  let t = Timer.start () in
   let ch = open_out filename in
   let f = Format.formatter_of_out_channel ch in
 
+  let blocked_source = Hashtbl.create 1024 in
   let sources = ref [] in
+  let binaries = ListTbl.create 17 in
+  let add_binaries arch s =
+    StringSet.iter (fun p -> ListTbl.add binaries arch p) s in
   ListTbl.iter
     (fun (nm, arch) reasons ->
-       if arch = "source" && List.exists interesting_reason reasons then
-         sources := (nm, reasons) :: !sources)
-    unchanged;
-
-  let print_binary f (nm, (arch : string)) =
-    let (t, u) = List.assoc arch l in
-    let source =
-      match ListTbl.find u.M.packages_by_name nm with
-        p :: _ ->
-          fst p.M.source
-      | [] ->
-          match ListTbl.find t.M.packages_by_name nm with
-            p :: _ -> fst p.M.source
-          | []     -> assert false
-    in
-    if not (List.mem_assoc source !sources) then begin
+       if arch = "source" && List.exists interesting_reason reasons then begin
+         sources := (nm, reasons) :: !sources;
+         Hashtbl.add blocked_source nm ()
+       end;
+       List.iter
+         (fun r ->
+            match r with
+              Conflict (s, s') -> add_binaries arch s; add_binaries arch s'
+            | _                -> ())
+         reasons)
+    unchanged_reasons;
+
+  let source_of_binary = Hashtbl.create 101 in
+  Task.iteri l
+    (fun (arch, st) -> (arch, binary_sources st (ListTbl.find binaries arch)))
+    (fun arch l ->
+       List.iter
+         (fun (nm, src) -> Hashtbl.add source_of_binary (nm, arch) src) l);
+
+  let print_binary f (nm, arch) =
+    let source = Hashtbl.find source_of_binary (nm, arch) in
+    if not (Hashtbl.mem blocked_source source) then begin
       if source = nm then
         Format.fprintf f "%s" nm
       else
@@ -581,7 +644,7 @@ let output_reasons l filename =
                 (fun bin ->
                   List.exists
                     (fun r -> match r with Not_yet_built _ -> true | _ -> false)
-                    (ListTbl.find unchanged bin))
+                    (ListTbl.find unchanged_reasons bin))
                 binaries)
          in
          List.iter
@@ -598,7 +661,7 @@ let output_reasons l filename =
                 (fun bin ->
                   List.exists
                     (fun r -> match r with More_bugs -> true | _ -> false)
-                    (ListTbl.find unchanged bin))
+                    (ListTbl.find unchanged_reasons bin))
                 binaries)
          in
          List.iter
@@ -615,7 +678,7 @@ let output_reasons l filename =
                      match r with
                        Not_yet_built _ | More_bugs -> false
                      | _                           -> true)
-                  (ListTbl.find unchanged bin))
+                  (ListTbl.find unchanged_reasons bin))
                 binaries
          in
          List.iter
@@ -649,7 +712,7 @@ let output_reasons l filename =
                             ": would break binary package %a.@."
                             print_binary (StringSet.choose s', arch)
                         end
-                     end else begin
+                      end else begin
                         Format.fprintf f ": would break binary packages";
                         StringSet.iter
                           (fun nm ->
@@ -663,14 +726,16 @@ let output_reasons l filename =
                       ()
                   | _ ->
                       assert false)
-               (ListTbl.find unchanged (nm', arch));
+               (ListTbl.find unchanged_reasons (nm', arch));
              Format.fprintf f "</ul>@.")
            binaries;
          Format.fprintf f "</ul>@.")
       (List.sort (fun (nm1, _) (nm2, _) -> compare nm1 nm2) !sources);
     Format.fprintf f "</ul>@."
   end;
-  close_out ch
+  close_out ch;
+  if debug_time () then
+    Format.eprintf "Writing excuse file: %f@." (Timer.stop t)
 
 (****)
 
@@ -733,13 +798,15 @@ let compute_conflicts t u =
   compute_package_conflicts u t; compute_package_conflicts u u;
   conflicts
 
-let reduce_repository_pair (arch, (t, u)) =
+let prepare_repository st unchanged =
+  let t = st.testing in
+  let u = st.unstable in
   let conflicts = compute_conflicts t u in
 
   let changed_packages = Hashtbl.create 101 in
   let consider_package _ p =
     let nm = p.M.package in
-    if not (ListTbl.mem unchanged (nm, arch)) then
+    if not (Hashtbl.mem unchanged nm) then
       Hashtbl.replace changed_packages nm ()
   in
   Hashtbl.iter consider_package t.M.packages_by_num;
@@ -751,7 +818,7 @@ let reduce_repository_pair (arch, (t, u)) =
       Hashtbl.add pkgs p ();
       List.iter add_package (ListTbl.find conflicts p);
       List.iter follow_deps (ListTbl.find t.M.packages_by_name p);
-      if Hashtbl.mem changed_packages p then
+      if not (Hashtbl.mem unchanged p) then
         List.iter follow_deps (ListTbl.find u.M.packages_by_name p)
     end
   and follow_deps p =
@@ -820,21 +887,326 @@ let reduce_repository_pair (arch, (t, u)) =
   let u' = M.new_pool () in
   M.merge2 u' filter u;
   if debug_reduction () then Format.eprintf "==> %d/%d@." !n !m;
-  (arch, (t', u'))
+  st.upgrade_state <-
+    Some (Upgrade_common.prepare_analyze t',
+          Upgrade_common.prepare_analyze u')
+
+let reduce_repository_pair = Task.funct prepare_repository
 
 let reduce_repositories l =
   let t = Timer.start () in
-  let l = List.map reduce_repository_pair l in
+  Task.iter l
+    (fun (arch, st) -> reduce_repository_pair st (Hashtbl.find unchanged arch))
+    (fun () -> ());
   if debug_time () then
-    Format.eprintf "Reducing repositories: %f@." (Timer.stop t);
-  l
+    Format.eprintf "Reducing repositories: %f@." (Timer.stop t)
+
+let rec get_upgrade_state st unchanged =
+  match st.upgrade_state with
+    Some st ->
+      st
+  | None ->
+      prepare_repository st unchanged;
+      get_upgrade_state st unchanged
 
 (****)
 
-type 'a easy_hint =
-  { mutable h_names : 'a list;
-    mutable h_pkgs : (string * string) list;
-    mutable h_live : bool }
+let share_packages (t, u) =
+  let unchanged dist p =
+    match ListTbl.find dist.M.packages_by_name p.M.package with
+      []  -> false
+    | [q] -> M.compare_version p.M.version q.M.version = 0
+    | _   -> assert false
+  in
+  let common = M.new_pool () in
+  M.merge2 common (fun p -> unchanged u p) t;
+  let t' = M.copy common in
+  M.merge2 t' (fun p -> not (unchanged u p)) t;
+  let u' = common in
+  M.merge2 u' (fun p -> not (unchanged t p)) u;
+  assert (t'.M.size = t.M.size && u'.M.size = u.M.size);
+  (t', u')
+ 
+let init_arch arch testing_srcs testing_bugs unstable_srcs unstable_bugs () =
+  let files =
+    [bin_package_file (testing ()) arch;
+     bin_package_file (unstable ()) arch]
+  in
+  let cache = bin_package_file cache_dir arch in
+  let ((t, u), uid) =
+    cached files cache "version 1"
+      (fun () ->
+        share_packages
+         (load_bin_packages (testing ()) arch,
+          load_bin_packages (unstable ()) arch))
+  in
+(*
+let n1 = ref 0 in
+let n2 = ref 0 in
+Hashtbl.iter (fun _ p ->
+  incr n1;
+if ListTbl.mem t.M.packages_by_name p.M.package then begin
+  let q = List.hd (ListTbl.find t.M.packages_by_name p.M.package) in
+  if M.compare_version p.M.version q.M.version = 0 then incr n2
+end
+) u.M.packages_by_num;
+Format.eprintf "====> %d/%d" !n2 !n1;
+*)
+  { arch = arch;
+    testing = t;
+    testing_srcs = testing_srcs; testing_bugs = testing_bugs;
+    unstable = u;
+    unstable_srcs = unstable_srcs; unstable_bugs = unstable_bugs;
+    upgrade_state = None;
+    uid = uid }
+
+type cstr =
+    No_change of int * (string * string) * reason
+  | Associates of (string * string) * (string * string) * reason
+  | All_or_none of (string * string) list * reason
+
+let arch_constraints st (produce_excuses, compute_hints) =
+  let t = st.testing_srcs in
+  let u = st.unstable_srcs in
+  let t' = st.testing in
+  let u' = st.unstable in
+  let fake_srcs = ref [] in
+  let is_fake = Hashtbl.create 17 in
+  let sources_with_binaries = ref [] in
+  let source_has_binaries = Hashtbl.create 8192 in
+  let l = ref [] in
+  let no_change pkg reason = l := No_change (0, pkg, reason) :: !l in
+  let no_change_deferred pkg reason = l := No_change (1, pkg, reason) :: !l in
+  let associates pkg1 pkg2 reason =
+    l := Associates (pkg1, pkg2, reason):: !l
+  in
+  let all_or_none pkgl reason = l := All_or_none (pkgl, reason) :: !l in
+  let get_bugs src bugs p =
+    try Hashtbl.find bugs p with Not_found -> StringSet.empty
+  in
+  let no_new_bugs is_new p =
+    if is_new then
+      StringSet.is_empty (get_bugs u st.unstable_bugs p)
+    else
+      StringSet.subset
+        (get_bugs u st.unstable_bugs p)
+        (get_bugs t st.testing_bugs p)
+  in
+  let arch = st.arch in
+  let bin_nmus = ListTbl.create 101 in
+  Hashtbl.iter
+    (fun _ p ->
+       let pkg = (p.M.package, arch) in
+       let (nm, v) = p.M.source in
+       (* Faux packages *)
+       if not (Hashtbl.mem u nm) then begin
+         Hashtbl.add u nm
+           { M.s_name = nm; s_version = v; s_section = "" };
+         fake_srcs := (nm, v) :: !fake_srcs;
+         Hashtbl.add is_fake nm ();
+         no_change (nm, "source") Unchanged
+       end;
+       let v' = (Hashtbl.find u nm).M.s_version in
+       (* Do not add a binary package if its source is not
+          the most up to date source file. *)
+       if M.compare_version v v' <> 0 then
+         no_change pkg (Not_yet_built (nm, v, v'))
+       else if not (Hashtbl.mem source_has_binaries nm) then begin
+         sources_with_binaries := nm :: !sources_with_binaries;
+         Hashtbl.add source_has_binaries nm ()
+       end;
+       let source_changed =
+         not (same_source_version t u (fst p.M.source)) in
+       (* We only propagate binary packages with a larger version.
+          Faux packages are not propagated. *)
+       if no_new_bin t' u' p.M.package || Hashtbl.mem is_fake nm then
+         no_change pkg Unchanged
+       else begin
+         (* Do not upgrade a package if it has new bugs *)
+         let is_new = bin_version t' p.M.package = None in
+         if not (no_new_bugs is_new p.M.package) then
+           no_change_deferred pkg More_bugs;
+         if source_changed then
+           (* We cannot add a binary package without also adding
+              its source. *)
+           associates pkg (fst p.M.source, "source")
+             (Source_not_propagated p.M.source)
+         else
+           ListTbl.add bin_nmus p.M.source pkg;
+
+       end;
+       (* If a source is propagated, all its binaries should
+          be propagated as well *)
+       if source_changed || produce_excuses then
+         associates (fst p.M.source, "source") pkg
+           (Binary_not_propagated pkg))
+    u'.M.packages_by_num;
+  (* All binaries packages from a same source are propagated
+     atomically on any given architecture. *)
+  ListTbl.iter
+    (fun _ pkgs -> all_or_none pkgs (Atomic pkgs)) bin_nmus;
+  Hashtbl.iter
+    (fun _ p ->
+       let pkg = (p.M.package, arch) in
+       let (nm, v) = p.M.source in
+       (* Faux packages *)
+       if not (Hashtbl.mem t nm) then begin
+         (* The source should be fake in unstable as well. *)
+         assert (not (Hashtbl.mem u nm) || Hashtbl.mem is_fake nm);
+         Hashtbl.add t nm
+           { M.s_name = nm; s_version = v; s_section = "" };
+         fake_srcs := (nm, v) :: !fake_srcs;
+         Hashtbl.add is_fake nm ();
+         no_change (nm, "source") Unchanged
+       end;
+       let v' = (Hashtbl.find t nm).M.s_version in
+       let source_changed =
+         not (same_source_version t u (fst p.M.source)) in
+       (* We only propagate binary packages with a larger version.
+          Faux packages are not propagated. *)
+       if no_new_bin t' u' p.M.package || Hashtbl.mem is_fake nm then
+         no_change pkg Unchanged
+       else begin
+         (* Binary packages without source of the same version can
+            be removed freely when not needed anymore (these are
+            binaries left for smooth update).
+            However, when producing hints, we do not allow this, as
+            we have no way to communicate the change to britney... *)
+         if not compute_hints && M.compare_version v v' <> 0 then
+           ()
+         (* We cannot remove a binary without removing its source. *)
+         else if source_changed then
+           associates pkg (fst p.M.source, "source")
+             (Source_not_propagated p.M.source)
+         else
+           ListTbl.add bin_nmus p.M.source pkg
+       end;
+       (* We cannot remove or upgrade a source package if a
+          corresponding binary package still exists.
+          We relax this constraint for libraries when upgrading
+          a source package. *)
+       if
+         (source_changed || produce_excuses)
+           &&
+         not (allow_smooth_updates p && Hashtbl.mem u nm)
+       then
+         associates (fst p.M.source, "source") pkg
+           (Binary_not_propagated pkg))
+    t'.M.packages_by_num;
+  (List.rev !l, st.uid, !sources_with_binaries, !fake_srcs)
+
+let arch_constraints = Task.funct arch_constraints
+
+(****)
+
+let find_coinst_constraints st unchanged =
+  let arch = st.arch in
+  let (t', u') = get_upgrade_state st unchanged in
+  let changes = ref [] in
+  if debug_coinst () then
+    Format.eprintf "==================== %s@." arch;
+  let step_t = Timer.start () in
+  let problems =
+    Upgrade_common.find_problematic_packages
+      ~check_new_packages:true t' u'
+      (fun nm -> Hashtbl.mem unchanged nm)
+  in
+  let t = Timer.start () in
+  let has_singletons =
+    List.exists
+      (fun (cl, _) -> StringSet.cardinal cl.Upgrade_common.pos = 1)
+      problems
+  in
+  List.iter
+    (fun ({Upgrade_common.pos = pos;  neg = neg}, s) ->
+       let n = StringSet.cardinal pos in
+       if not (has_singletons && n > 1) then begin
+         let nm = StringSet.choose pos in
+         let can_learn = n = 1 && StringSet.cardinal neg <= 1 in
+         changes := (nm, arch, neg, s, can_learn) :: !changes
+       end)
+    problems;
+  if debug_time () then begin
+    Format.eprintf "  New constraints: %f@." (Timer.stop t);
+    Format.eprintf "Step duration: %f@." (Timer.stop step_t)
+  end;
+  List.rev !changes
+
+let find_coinst_constraints = Task.funct find_coinst_constraints
+
+let find_all_coinst_constraints a =
+  let t = Timer.start () in
+  let c = Array.length a in
+  let running = Array.make c false in
+  let changed = Array.make c true in
+  let n = ref 0 in
+  let max_proc = Task.get_processor_count () in
+  let scheduler = Task.scheduler () in
+  let rec start c i0 i =
+    if running.(i) || not changed.(i) then begin
+      let i = (i + 1) mod c in
+      if i <> i0 then start c i0 i
+    end else begin
+      changed.(i) <- false;
+      running.(i) <- true;
+      let (arch, st) = a.(i) in
+      Task.async scheduler
+        (find_coinst_constraints st (Hashtbl.find unchanged arch))
+        (fun changes -> stop c i changes);
+      if !n < max_proc then begin
+        start c 0 0
+      end
+    end
+  and stop c i changes =
+    if changes <> [] then begin
+      Array.fill changed 0 c true;
+      List.iter
+        (fun (nm, arch, neg, s, can_learn) ->
+           if can_learn then learn_rule nm arch neg s;
+           no_change (nm, arch) (Conflict (neg, s)))
+        changes
+    end;
+    running.(i) <- false;
+    decr n;
+    start c i i
+  in
+  start 1 0 0;
+  Task.run scheduler;
+  start c 0 0;
+  Task.run scheduler;
+  if debug_time () then
+    Format.eprintf "Solving constraints: %f@." (Timer.stop t)
+
+(****)
+
+let arch_change st unchanged =
+  let arch = st.arch in
+  let t' = st.testing in
+  let u' = st.unstable in
+  Hashtbl.iter
+    (fun _ p ->
+       let nm = p.M.package in
+       let v = p.M.version in
+       if not (Hashtbl.mem unchanged nm) then
+         match bin_version u' nm with
+           Some v' ->
+             Format.eprintf
+               "Upgrade binary package %s/%s from %a to %a@."
+               nm arch M.print_version v M.print_version v'
+         | None ->
+             Format.eprintf "Remove binary package %s/%s@." nm arch)
+    t'.M.packages_by_num;
+  Hashtbl.iter
+    (fun _ p ->
+       let nm = p.M.package in
+       if not (Hashtbl.mem unchanged nm) then
+         if not (ListTbl.mem t'.M.packages_by_name nm) then
+           Format.eprintf "Adding binary package %s/%s@." nm arch)
+    u'.M.packages_by_num
+
+let arch_change = Task.funct arch_change
+
+(****)
 
 module Union_find = struct
 
@@ -859,49 +1231,81 @@ let rec get t =
     Link _  -> assert false
   | Value v -> v
 
-let merge t t' =
+let merge t t' f =
   let t = repr t in
   let t' = repr t' in
-  t'.state <- Link t
+  if t != t' then begin
+    t.state <- Value (f (get t) (get t'));
+    t'.state <- Link t
+  end
 
 let elt v = { state = Value v }
 
 end
 
+let cluster_packages st (unchanged, clusters) =
+  let clusters =
+    List.map (fun (lst, id) -> (lst, (id, Union_find.elt id))) clusters
+  in
+  let merge (_, e1) (_, e2) = Union_find.merge e1 e2 min in
+  let (t, u) =
+    match st.upgrade_state with Some st -> st | None -> assert false in
+  Upgrade_common.find_clusters t u
+    (fun nm -> Hashtbl.mem unchanged nm) clusters merge;
+  List.map (fun (_, (id, elt)) -> (id, Union_find.get elt)) clusters
+
+let cluster_packages = Task.funct cluster_packages
+
+type 'a easy_hint =
+  { mutable h_names : 'a list;
+    mutable h_pkgs : (string * string) list;
+    mutable h_live : bool;
+    h_id : int }
+
 let generate_small_hints l buckets =
   let to_consider = ref [] in
+  let buckets_by_id = Hashtbl.create 17 in
+  let n = ref 0 in
   ListTbl.iter
     (fun (src, arch) lst ->
-       let info = { h_names = [(src, arch)]; h_pkgs = lst; h_live = true } in
+       let info =
+         { h_names = [(src, arch)]; h_pkgs = lst; h_live = true; h_id = !n } in
        let elt = Union_find.elt info in
+       Hashtbl.add buckets_by_id !n elt;
+       incr n;
        to_consider := (info, elt) :: !to_consider)
     buckets;
 
   let merge elt elt' =
-    if Union_find.repr elt != Union_find.repr elt' then begin
-      let info = Union_find.get elt in
-      let info' = Union_find.get elt' in
-      assert (info.h_live);
-      assert (info'.h_live);
-      Union_find.merge elt elt';
-      info.h_names <- info'.h_names @ info.h_names;
-      info.h_pkgs <- info'.h_pkgs @ info.h_pkgs;
-      info'.h_live <- false
-    end
+    Union_find.merge elt elt'
+      (fun info info' ->
+         assert (info.h_live);
+         assert (info'.h_live);
+         info.h_names <- info'.h_names @ info.h_names;
+         info.h_pkgs <- info'.h_pkgs @ info.h_pkgs;
+         info'.h_live <- false;
+         info)
   in
 
-  List.iter
-    (fun (arch, t, u) ->
+  Task.iter l
+    (fun (arch, st) ->
+       let unchanged' = Hashtbl.find unchanged arch in
        let clusters = ref [] in
        List.iter
          (fun (info, elt) ->
-            let l = List.filter (fun (_, arch') -> arch = arch') info.h_pkgs in
+            let l =
+              List.filter (fun (_, arch') -> arch = arch') info.h_pkgs in
             if l <> [] then
-              clusters := (List.map fst l, elt) :: !clusters)
+              clusters :=
+                (List.map fst l, (Union_find.get elt).h_id) :: !clusters)
          !to_consider;
-       Upgrade_common.find_clusters t u
-         (fun nm -> ListTbl.mem unchanged (nm, arch)) !clusters merge)
-    l;
+       cluster_packages st (unchanged', !clusters))
+    (fun lst ->
+       List.iter
+         (fun (id, id') ->
+            merge (Hashtbl.find buckets_by_id id)
+                  (Hashtbl.find buckets_by_id id'))
+         lst);
 
   let lst =
     List.filter (fun info -> info.h_live) (List.map fst !to_consider) in
@@ -920,42 +1324,49 @@ let generate_small_hints l buckets =
   in
   let lst = List.map (fun names -> List.sort compare_elt names) lst in
   let lst = List.sort compare_lst lst in
-  let lst =
-    List.stable_sort
-      (fun l l' -> compare (List.length l) (List.length l')) lst
-  in
-  lst
+  List.stable_sort (fun l l' -> compare (List.length l) (List.length l')) lst
 
-let generate_hints t u l l' =
+let collect_changes st unchanged =
+  let changes = ref [] in
+  let u' = st.unstable in
+  let t' = st.testing in
+  Hashtbl.iter
+    (fun _ p ->
+       let nm = p.M.package in
+       if not (Hashtbl.mem unchanged nm) then begin
+         let (src, v) = p.M.source in
+         changes := (src, nm) :: !changes
+       end)
+    u'.M.packages_by_num;
+  Hashtbl.iter
+    (fun _ p ->
+       let nm = p.M.package in
+       if
+         not (Hashtbl.mem unchanged nm)
+           &&
+         not (ListTbl.mem u'.M.packages_by_name nm)
+       then begin
+         let (src, v) = p.M.source in
+         changes := (src, nm) :: !changes
+       end)
+    t'.M.packages_by_num;
+  List.rev !changes
+
+let collect_changes = Task.funct collect_changes
+
+let generate_hints t u l =
   let hint_t = Timer.start () in
   let changes = ListTbl.create 101 in
-  List.iter
-    (fun (arch, (t', u')) ->
-       Hashtbl.iter
-         (fun _ p ->
-            let nm = p.M.package in
-            if not (ListTbl.mem unchanged (nm, arch)) then begin
-              let (src, v) = p.M.source in
-              ListTbl.add changes src (nm, arch)
-            end)
-         u'.M.packages_by_num;
-       Hashtbl.iter
-         (fun _ p ->
-            let nm = p.M.package in
-            if
-              not (ListTbl.mem unchanged (nm, arch))
-                &&
-              not (ListTbl.mem u'.M.packages_by_name nm)
-            then begin
-              let (src, v) = p.M.source in
-              ListTbl.add changes src (nm, arch)
-            end)
-         t'.M.packages_by_num)
-    l;
+  Task.iteri l
+    (fun (arch, st) ->
+       (arch, collect_changes st (Hashtbl.find unchanged arch)))
+    (fun arch lst ->
+       List.iter (fun (src, nm) -> ListTbl.add changes src (nm, arch)) lst);
   let buckets = ListTbl.create 101 in
+  let unchanged' = Hashtbl.find unchanged "source" in
   ListTbl.iter
     (fun src l ->
-       if not (ListTbl.mem unchanged (src, "source")) then
+       if not (Hashtbl.mem unchanged' src) then
          List.iter
            (fun info -> ListTbl.add buckets (src, "source") info)
            l
@@ -965,7 +1376,7 @@ let generate_hints t u l l' =
               ListTbl.add buckets (src, arch) info)
            l)
     changes;
-  let hints = generate_small_hints l' buckets in
+  let hints = generate_small_hints l buckets in
   if debug_time () then
     Format.eprintf "Generating hints: %f@." (Timer.stop hint_t);
   let print_pkg f src arch =
@@ -1001,28 +1412,70 @@ let generate_hints t u l l' =
 
 (****)
 
+let heidi_buffer = Buffer.create 80
+
+let heidi_line lines nm vers arch sect =
+  Format.bprintf heidi_buffer "%s %a %s %s@."
+    nm M.print_version vers arch sect;
+  lines := Buffer.contents heidi_buffer :: !lines;
+  Buffer.clear heidi_buffer
+
+let heidi_arch st unchanged =
+  let lines = ref [] in
+  let arch = st.arch in
+  let t = st.testing in
+  let u = st.unstable in
+  let is_preserved nm = Hashtbl.mem unchanged nm in
+  Hashtbl.iter
+    (fun _ p ->
+       let nm = p.M.package in
+       let sect = if p.M.section = "" then "faux" else p.M.section in
+       if is_preserved nm then heidi_line lines nm p.M.version arch sect)
+    t.M.packages_by_num;
+  Hashtbl.iter
+    (fun _ p ->
+       let nm = p.M.package in
+       let sect = if p.M.section = "" then "faux" else p.M.section in
+       if not (is_preserved nm) then
+         heidi_line lines nm p.M.version arch sect)
+    u.M.packages_by_num;
+  String.concat "" (List.sort compare !lines)
+
+let heidi_arch = Task.funct heidi_arch
+
+let print_heidi ch fake_src l t u =
+  let heidi_t = Timer.start () in
+  let lines = ref [] in
+  Task.iter (List.sort (fun (arch, _) (arch', _) -> compare arch arch') l)
+    (fun (arch, st) -> heidi_arch st (Hashtbl.find unchanged arch))
+    (fun lines -> output_string ch lines);
+  let unchanged' = Hashtbl.find unchanged "source" in
+  let is_preserved nm = Hashtbl.mem unchanged' nm in
+  let source_sect nm s =
+    if Hashtbl.mem fake_src nm then "faux"
+    else if s.M.s_section = "" then "unknown"
+    else s.M.s_section
+  in
+  Hashtbl.iter
+    (fun nm s ->
+       let sect = source_sect nm s in
+       if is_preserved nm then
+         heidi_line lines nm s.M.s_version "source" sect)
+    t;
+  Hashtbl.iter
+    (fun nm s ->
+       let sect = source_sect nm s in
+       if not (is_preserved nm) then
+         heidi_line lines nm s.M.s_version "source" sect)
+    u;
+  List.iter (output_string ch) (List.sort compare !lines);
+  if debug_time () then
+    Format.eprintf "Writing Heidi file: %f@." (Timer.stop heidi_t)
+
 let f () =
+  Util.enable_messages false;
   let load_t = Timer.start () in
-  let (dates, urgencies, testing_bugs, unstable_bugs, hints) =
-    read_extra_info () in
-  let files =
-    List.flatten
-      (List.map
-         (fun arch ->
-            [bin_package_file (testing ()) arch;
-             bin_package_file (unstable ()) arch])
-         !archs)
-  in
-  let cache = Filename.concat cache_dir "Packages" in
-  let (l, uid) =
-    cached files cache "version 2" (fun () ->
-    List.map
-      (fun arch ->
-         (arch,
-          (load_bin_packages (testing ()) arch,
-           load_bin_packages (unstable ()) arch)))
-      !archs)
-  in
+  let (testing_bugs, unstable_bugs) = read_bugs () in
   let files =
     [src_package_file (testing ()); src_package_file (unstable ())] in
   let cache = Filename.concat cache_dir "Sources" in
@@ -1030,11 +1483,20 @@ let f () =
     cached files cache "version 2" (fun () ->
       (load_src_packages (testing ()), load_src_packages (unstable ())))
   in
-  if debug_time () then Format.eprintf "Loading: %f@." (Timer.stop load_t);
+  if debug_time () then
+    Format.eprintf "  Loading shared data: %f@." (Timer.stop load_t);
+  let l =
+    List.map
+      (fun arch ->
+         (arch, Task.spawn (init_arch arch t testing_bugs u unstable_bugs)))
+      !archs
+  in
+  let (dates, urgencies, hints) = read_extra_info () in
 
-  load_rules uid;
+  if debug_time () then Format.eprintf "Loading: %f@." (Timer.stop load_t);
 
   let init_t = Timer.start () in
+  init_changes ();
   let compute_hints = debug_hints () || !hint_file <> "" in
   let compute_ages nm uv tv =
     let d =
@@ -1103,6 +1565,10 @@ let f () =
       (fun (pkg, reason) -> no_change pkg reason) !deferred_constraints;
     deferred_constraints := []
   in
+  let arch_results =
+    List.map
+      (fun (_, t) -> arch_constraints t (produce_excuses, compute_hints)) l
+  in
   Hashtbl.iter
     (fun nm s ->
        let v = s.M.s_version in
@@ -1125,207 +1591,64 @@ let f () =
            no_change_deferred (nm, "source") More_bugs
        end)
     u;
-  let fake_src = Hashtbl.create 17 in
-  let sources_with_binaries = Hashtbl.create 16384 in
-  List.iter
-    (fun (arch, (t', u')) ->
-       let bin_nmus = ListTbl.create 101 in
-       Hashtbl.iter
-         (fun _ p ->
-            let pkg = (p.M.package, arch) in
-            let (nm, v) = p.M.source in
-            (* Faux packages *)
-            if not (Hashtbl.mem u nm) then begin
-              Hashtbl.add u nm
-                { M.s_name = nm; s_version = v; s_section = "" };
-              Hashtbl.add fake_src nm ();
-              no_change (nm, "source") Unchanged
-            end;
-            let v' = (Hashtbl.find u nm).M.s_version in
-            (* Do not add a binary package if its source is not
-               the most up to date source file. *)
-            if M.compare_version v v' <> 0 then
-              no_change pkg (Not_yet_built (nm, v, v'))
-            else
-              Hashtbl.replace sources_with_binaries nm ();
-            let source_changed =
-              not (same_source_version t u (fst p.M.source)) in
-            (* We only propagate binary packages with a larger version.
-               Faux packages are not propagated. *)
-            if no_new_bin t' u' p.M.package || Hashtbl.mem fake_src nm then
-              no_change pkg Unchanged
-            else begin
-              (* Do not upgrade a package if it has new bugs *)
-              let is_new = bin_version t' p.M.package = None in
-              if not (no_new_bugs is_new p.M.package) then
-                no_change_deferred pkg More_bugs;
-              if source_changed then
-                (* We cannot add a binary package without also adding
-                   its source. *)
-                associates pkg (fst p.M.source, "source")
-                  (Source_not_propagated p.M.source)
-              else
-                ListTbl.add bin_nmus p.M.source pkg;
-
-            end;
-            (* If a source is propagated, all its binaries should
-               be propagated as well *)
-            if source_changed || produce_excuses then
-              associates (fst p.M.source, "source") pkg
-                (Binary_not_propagated pkg))
-         u'.M.packages_by_num;
-       (* All binaries packages from a same source are propagated
-          atomically on any given architecture. *)
-       ListTbl.iter
-         (fun _ pkgs -> all_or_none pkgs (Atomic pkgs)) bin_nmus;
-       Hashtbl.iter
-         (fun _ p ->
-            let pkg = (p.M.package, arch) in
-            let (nm, v) = p.M.source in
-            (* Faux packages *)
-            if not (Hashtbl.mem t nm) then begin
-              (* The source should be fake in unstable as well. *)
-              assert (not (Hashtbl.mem u nm) || Hashtbl.mem fake_src nm);
-              Hashtbl.add t nm
-                { M.s_name = nm; s_version = v; s_section = "" };
-              Hashtbl.add fake_src nm ();
-              no_change (nm, "source") Unchanged
-            end;
-            let v' = (Hashtbl.find t nm).M.s_version in
-            let source_changed =
-              not (same_source_version t u (fst p.M.source)) in
-            (* We only propagate binary packages with a larger version.
-               Faux packages are not propagated. *)
-            if no_new_bin t' u' p.M.package || Hashtbl.mem fake_src nm then
-              no_change pkg Unchanged
-            else begin
-              (* Binary packages without source of the same version can
-                 be removed freely when not needed anymore (these are
-                 binaries left for smooth update).
-                 However, when producing hints, we do not allow this, as
-                 we have no way to communicate the change to britney... *)
-              if not compute_hints && M.compare_version v v' <> 0 then
-                ()
-              (* We cannot remove a binary without removing its source. *)
-              else if source_changed then
-                associates pkg (fst p.M.source, "source")
-                  (Source_not_propagated p.M.source)
-              else
-                ListTbl.add bin_nmus p.M.source pkg
-            end;
-            (* We cannot remove or upgrade a source package if a
-               corresponding binary package still exists.
-               We relax this constraint for libraries when upgrading
-               a source package. *)
-            if
-              (source_changed || produce_excuses)
-                &&
-              not (allow_smooth_updates p && Hashtbl.mem u nm)
-            then
-              associates (fst p.M.source, "source") pkg
-                (Binary_not_propagated pkg))
-         t'.M.packages_by_num)
-    l;
-
+  let source_has_binaries = Hashtbl.create 8192 in
+  let is_fake = Hashtbl.create 17 in
+  let uids =
+    List.map
+      (fun r ->
+         let (l, uid, sources_with_binaries, fake_srcs) = Task.wait r in
+         List.iter
+           (fun nm ->
+              if not (Hashtbl.mem source_has_binaries nm) then
+                Hashtbl.add source_has_binaries nm ())
+           sources_with_binaries;
+         List.iter
+           (fun (nm, v) ->
+              if not (Hashtbl.mem is_fake nm) then begin
+                Hashtbl.add is_fake nm ();
+                Hashtbl.add t nm
+                  { M.s_name = nm; s_version = v; s_section = "" };
+              end)
+           fake_srcs;
+         List.iter
+           (fun c ->
+              match c with
+                No_change (0, pkg, reason) ->
+                  no_change pkg reason
+              | No_change (_, pkg, reason) ->
+                  no_change_deferred pkg reason
+              | Associates (pkg1, pkg2, reason) ->
+                  associates pkg1 pkg2 reason
+              | All_or_none (pkgl, reason) ->
+                  all_or_none pkgl reason)
+           l;
+         uid)
+      arch_results
+  in
   Hashtbl.iter
     (fun nm s ->
-       if not (Hashtbl.mem sources_with_binaries nm) then
+       if not (Hashtbl.mem source_has_binaries nm) then
          no_change (nm, "source") No_binary)
     u;
-
+  load_rules uids;
   if debug_time () then
     Format.eprintf "Initial constraints: %f@." (Timer.stop init_t);
 
-  let l0 = l in
-  let l = reduce_repositories l in
-
-  let flatten_t = Timer.start () in
-  let l' =
-    List.map
-      (fun (arch, (t', u')) ->
-         (arch,
-          Upgrade_common.prepare_analyze t',
-          Upgrade_common.prepare_analyze u'))
-      l
-  in
-  if debug_time () then
-    Format.eprintf "Preparing analyze: %f@." (Timer.stop flatten_t);
+  reduce_repositories l;
 
-  let find_coinst_constraints () =
-    while
-      let first = ref true in
-      let changed = ref false in
-      List.iter
-        (fun (arch, t', u') ->
-           if debug_coinst () then
-             Format.eprintf "==================== %s@." arch;
-           while
-             let step_t = Timer.start () in
-             let problems =
-               Upgrade_common.find_problematic_packages
-                 ~check_new_packages:true t' u'
-                 (fun nm -> ListTbl.mem unchanged (nm, arch))
-             in
-             let t = Timer.start () in
-             let has_singletons =
-               List.exists
-                 (fun (cl, _) -> StringSet.cardinal cl.Upgrade_common.pos = 1)
-                 problems
-             in
-             let arch_changed = ref false in
-             List.iter
-               (fun ({Upgrade_common.pos = pos;  neg = neg}, s) ->
-                  let n = StringSet.cardinal pos in
-                  if not (has_singletons && n > 1) then begin
-                    let nm = StringSet.choose pos in
-                    let p =
-                      match
-                        ListTbl.find
-                          u'.Upgrade_common.dist.M.packages_by_name nm
-                      with
-                        p :: _ ->
-                          p
-                      | [] ->
-                          match
-                            ListTbl.find
-                              t'.Upgrade_common.dist.M.packages_by_name nm
-                          with
-                            p :: _ ->
-                              p
-                          | [] ->
-                              assert false
-                    in
-                    arch_changed := true;
-                    if n = 1 && StringSet.cardinal neg <= 1 then
-                      learn_rule nm p.M.version arch neg s;
-                    no_change (nm, arch) (Conflict (neg, s))
-                  end)
-               problems;
-             if debug_time () then begin
-               Format.eprintf "  New constraints: %f@." (Timer.stop t);
-               Format.eprintf "Step duration: %f@." (Timer.stop step_t)
-             end;
-             if !arch_changed && not !first then changed := true;
-             first := false;
-             !arch_changed
-           do () done)
-        l';
-      !changed
-    do () done
-  in
-
-  find_coinst_constraints ();
+  find_all_coinst_constraints (Array.of_list l);
   if !deferred_constraints <> [] then begin
     perform_deferred ();
-    find_coinst_constraints ()
+    find_all_coinst_constraints (Array.of_list l)
   end;
 
-  save_rules uid;
+  save_rules uids;
 
   if debug_outcome () then begin
+    let unchanged_src = Hashtbl.find unchanged "source" in
     Hashtbl.iter
       (fun nm s ->
-         if not (ListTbl.mem unchanged (nm, "source")) then
+         if not (Hashtbl.mem unchanged_src nm) then
            try
              let s' = Hashtbl.find u nm in
              Format.eprintf "Upgrade source package %s from %a to %a@." nm
@@ -1335,89 +1658,27 @@ let f () =
       t;
     Hashtbl.iter
       (fun nm v ->
-         if not (Hashtbl.mem t nm || ListTbl.mem unchanged (nm, "source")) then
+         if not (Hashtbl.mem t nm || Hashtbl.mem unchanged_src nm) then
            Format.eprintf "Adding source package %s@." nm)
       u;
+
     List.iter
-      (fun (arch, (t', u')) ->
-         Hashtbl.iter
-           (fun _ p ->
-              let nm = p.M.package in
-              let v = p.M.version in
-              if not (ListTbl.mem unchanged (nm, arch)) then
-                match bin_version u' nm with
-                  Some v' ->
-                    Format.eprintf
-                      "Upgrade binary package %s/%s from %a to %a@."
-                      nm arch M.print_version v M.print_version v'
-                | None ->
-                    Format.eprintf "Remove binary package %s/%s@." nm arch)
-           t'.M.packages_by_num;
-         Hashtbl.iter
-           (fun _ p ->
-              let nm = p.M.package in
-              if not (ListTbl.mem unchanged (nm, arch)) then
-                if not (ListTbl.mem t'.M.packages_by_name nm) then
-                  Format.eprintf "Adding binary package %s/%s@." nm arch)
-           u'.M.packages_by_num)
+      (fun (arch, st) ->
+         Task.wait (arch_change st (Hashtbl.find unchanged arch)))
       l
   end;
 
-  if compute_hints then generate_hints t u l l';
+  if compute_hints then generate_hints t u l;
 
-  let print_heidi ch =
-    let lines = ref [] in
-    let add_line nm vers arch sect =
-      let b = Buffer.create 80 in
-      Format.bprintf b "%s %a %s %s@." nm M.print_version vers arch sect;
-      lines := Buffer.contents b :: !lines
-    in
-    let output_lines ch =
-      List.iter (output_string ch) (List.sort compare !lines); lines := []
-    in
-    List.iter
-      (fun (arch, (t, u)) ->
-         let is_preserved nm = ListTbl.mem unchanged (nm, arch) in
-         Hashtbl.iter
-           (fun _ p ->
-              let nm = p.M.package in
-              let sect = if p.M.section = "" then "faux" else p.M.section in
-              if is_preserved nm then add_line nm p.M.version arch sect)
-           t.M.packages_by_num;
-         Hashtbl.iter
-           (fun _ p ->
-              let nm = p.M.package in
-              let sect = if p.M.section = "" then "faux" else p.M.section in
-              if not (is_preserved nm) then
-                add_line nm p.M.version arch sect)
-           u.M.packages_by_num;
-         output_lines ch)
-      (List.sort (fun (arch, _) (arch', _) -> compare arch arch') l0);
-    let is_preserved nm = ListTbl.mem unchanged (nm, "source") in
-    let source_sect nm s =
-      if Hashtbl.mem fake_src nm then "faux"
-      else if s.M.s_section = "" then "unknown"
-      else s.M.s_section
-    in
-    Hashtbl.iter
-      (fun nm s ->
-         let sect = source_sect nm s in
-         if is_preserved nm then add_line nm s.M.s_version "source" sect)
-      t;
-    Hashtbl.iter
-      (fun nm s ->
-         let sect = source_sect nm s in
-         if not (is_preserved nm) then add_line nm s.M.s_version "source" sect)
-      u;
-    output_lines ch; flush ch
-  in
   if !heidi_file <> "" then begin
     let ch = open_out !heidi_file in
-    print_heidi ch;
+    print_heidi ch is_fake l t u;
     close_out ch
   end;
 
-  if !excuse_file <> "" then output_reasons l0 !excuse_file
+  if !excuse_file <> "" then output_reasons l !excuse_file;
+
+  List.iter (fun (_, t) -> Task.kill t) l
 
 (****)
 
@@ -1452,40 +1713,46 @@ let spec =
   Arg.align
   ["--input",
    Arg.String (fun d -> dir := d),
-   "DIR       Select directory containing britney data";
+   "DIR Select directory containing britney data";
    "-c",
    Arg.String read_conf,
-   "FILE      Read britney config FILE";
+   "FILE Read britney config FILE";
    "--hints",
    Arg.String (fun f -> hint_file := f),
-   "FILE      Output hints to FILE";
+   "FILE Output hints to FILE";
    "--all-hints",
    Arg.Unit (fun () -> all_hints := true),
-   "          Show all hints (including those for single packages)";
+   " Show all hints (including single package ones)";
    "--heidi",
    Arg.String (fun f -> heidi_file := f),
-   "FILE      Output Heidi results to FILE";
+   "FILE Output Heidi results to FILE";
    "--excuses",
    Arg.String (fun f -> excuse_file := f),
-   "FILE      Output excuses to FILE";
+   "FILE Output excuses to FILE";
    "--offset",
    Arg.Int (fun n -> offset := n),
-   "N         Move N days into the future";
+   "N Move N days into the future";
+   "--no-cache",
+   Arg.Unit (fun () -> cache_disabled := true),
+   " Disable on-disk caching";
+   "--proc",
+   Arg.Int Task.set_processor_count,
+   "N Provide number of processors (use 1 to disable concurrency)";
    "--debug",
    Arg.String Debug.set,
-   "NAME      Activate debug option NAME";
+   "NAME Activate debug option NAME";
    "--control-files",
    Arg.Unit (fun () -> ()),
-   "          Currently ignored";
+   " Currently ignored";
    "--auto-hinter",
    Arg.Unit (fun () -> ()),
-   "          Currently ignored";
+   " Currently ignored";
    "-v",
    Arg.Unit (fun () -> ()),
-   "          Currently ignored";
+   " Currently ignored";
    "--compatible",
    Arg.Unit (fun () -> ()),
-   "          Currently ignored"]
+   " Currently ignored"]
 in
 Arg.parse spec (fun p -> ())
   ("Usage: " ^ Sys.argv.(0) ^ " OPTIONS\n\
@@ -1495,3 +1762,7 @@ Arg.parse spec (fun p -> ())
     \n\
     Options:");
   f ()
+
+(*
+let _ = Format.eprintf ">>>> %f@." (Unix.times ()).Unix.tms_utime
+*)
diff --git a/upgrade.ml b/upgrade.ml
index f3c3549..dc75020 100644
--- a/upgrade.ml
+++ b/upgrade.ml
@@ -20,6 +20,8 @@
 (*
 XXXX List broken new packages!
 
+- Show how important each issue is (use strong dependencies?)
+
 - Does it make sense to consider new packages as previously
   installable, and report issues for them in a uniform way?
 
diff --git a/upgrade_common.ml b/upgrade_common.ml
index bd0c6ea..01875b0 100644
--- a/upgrade_common.ml
+++ b/upgrade_common.ml
@@ -524,10 +524,10 @@ let analyze ?(check_new_packages = false) ?reference dist1_state dist2 =
       if
         PSet.exists (fun p -> not (now_installable (PSet.remove p s))) s
       then begin
-  if true (*debug*) then begin
-  Format.printf "Not minimal:";
-  List.iter (fun p -> Format.printf " %a" (Package.print_name dist2) p) l;
-  Format.printf "@.";
+  if debug_coinst () then begin
+  Format.eprintf "Not minimal:";
+  List.iter (fun p -> Format.eprintf " %a" (Package.print_name dist2) p) l;
+  Format.eprintf "@.";
   end;
       end else begin
         add_result s
diff --git a/util.ml b/util.ml
index 7f7ee70..8a776a1 100644
--- a/util.ml
+++ b/util.ml
@@ -17,8 +17,11 @@
  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  *)
 
-let enable_msgs = (* isatty is not available...*)
-  (Unix.fstat Unix.stderr).Unix.st_kind = Unix.S_CHR
+let can_enable_msgs = Unix.isatty Unix.stderr
+
+let enable_msgs = ref can_enable_msgs
+
+let enable_messages b = if can_enable_msgs then enable_msgs := b
 
 let cur_msg = ref ""
 
@@ -34,7 +37,7 @@ let show_msg () =
   if !cur_msg <> "" then begin prerr_string !cur_msg; flush stderr end
 
 let set_msg s =
-  if enable_msgs && s <> !cur_msg then begin
+  if !enable_msgs && s <> !cur_msg then begin
     hide_msg (); cur_msg := s; show_msg ()
   end
 
@@ -70,6 +73,12 @@ module Timer = struct
   let stop t = Unix.gettimeofday () -. t
 end
 
+module Utimer = struct
+  type t = float
+  let start () = (Unix.times ()).Unix.tms_utime
+  let stop t = start () -. t
+end
+
 module IntSet =
   Set.Make (struct type t = int let compare x (y : int) = compare x y end)
 
@@ -92,6 +101,11 @@ module ListTbl = struct
   let mem = Hashtbl.mem
 
   let iter f h = Hashtbl.iter (fun k l -> f k !l) h
+
+  let copy h =
+    let h' = Hashtbl.create (2 * Hashtbl.length h) in
+    Hashtbl.iter (fun k l -> Hashtbl.add h' k (ref !l)) h;
+    h'
 end
 
 (****)
diff --git a/util.mli b/util.mli
index a120baf..8a49bc2 100644
--- a/util.mli
+++ b/util.mli
@@ -20,6 +20,7 @@
 val set_msg : string -> unit
 val hide_msg : unit -> unit
 val show_msg : unit -> unit
+val enable_messages : bool -> unit
 
 val set_warning_location : string -> unit
 val reset_warning_location : unit -> unit
@@ -35,6 +36,12 @@ module Timer : sig
   val stop : t -> float
 end
 
+module Utimer : sig
+  type t
+  val start : unit -> t
+  val stop : t -> float
+end
+
 module IntSet : Set.S with type elt = int
 
 module ListTbl : sig
@@ -44,6 +51,7 @@ module ListTbl : sig
   val find : ('a, 'b) t -> 'a -> 'b list
   val mem : ('a, 'b) t -> 'a -> bool
   val iter : ('a -> 'b list -> unit) -> ('a, 'b) t -> unit
+  val copy : ('a, 'b) t -> ('a, 'b) t
 end
 
 val print_list :