Fix stack overflow caused by very long conlicts chains

this patch fiddle with the edosSolver. The list of reasons are
now appended without considering the order to limit the depth of the
recursion stack when the two lists are too big.

Author: Pietro Abate

Makefile

@@ -10,7 +10,8 @@ DIST_TARBALL = $(DIST_DIR).tar.gz
 #VERBOSE := -classic-display
 OBFLAGS := $(VERBOSE) -j 10 -no-links -cflags -warn-error,FPSXY
 APPFLAGS := $(VERBOSE) -j 10
-#OBFLAGS := $(OBFLAGS) -tag profile -tag debug
+#OBFLAGS := $(OBFLAGS) -tag debug
+#OBFLAGS := $(OBFLAGS) -tag profile
 #OBFLAGS := $(OBFLAGS) -classic-display
 
 addnotrpm:

algo/depsolver.ml

@@ -19,6 +19,8 @@ let label =  __label ;;
 include Util.Logging(struct let label = label end) ;;
 
 type solver = Depsolver_int.solver
+let timer_solver = Util.Timer.create "Algo.Depsolver.solver" 
+let timer_init = Util.Timer.create "Algo.Depsolver.init" 
 
 let load ?(global_constraints=[]) universe =
   let global_constraints =
@@ -35,14 +37,15 @@ let load ?(global_constraints=[]) universe =
 *)
 let univcheck ?(global_constraints=[]) ?callback ?(explain=true) universe =
   let aux ?callback univ =
-    let timer = Util.Timer.create "Algo.Depsolver.univcheck" in
-    Util.Timer.start timer;
     let global_constraints =
       List.map (fun (vpkg,l) ->
         (vpkg,List.map (CudfAdd.pkgtoint universe) l)
       ) global_constraints
     in
+    Util.Timer.start timer_init;
     let solver = Depsolver_int.init_solver_univ ~global_constraints ~explain univ in
+    Util.Timer.stop timer_init ();
+    Util.Timer.start timer_solver;
     let failed = ref 0 in
     (* This is size + 1 because we encode the global constraint of the
      * universe as a package that must be tested like any other *)
@@ -53,7 +56,7 @@ let univcheck ?(global_constraints=[]) ?callback ?(explain=true) universe =
     (* we do not test the last package that encodes the global constraints
      * on the universe as it is tested all the time with all other packages. *)
     for id = 0 to size - 2 do if not(check id) then incr failed done;
-    Util.Timer.stop timer !failed
+    Util.Timer.stop timer_solver !failed
   in
   let map = new Common.Util.identity in
   match callback with
@@ -76,19 +79,21 @@ let listcheck ?(global_constraints=[]) ?callback ?(explain=true) universe pkglis
         (vpkg,List.map (CudfAdd.pkgtoint universe) l)
       ) global_constraints
     in
+    Util.Timer.start timer_init;
     let solver = Depsolver_int.init_solver_univ ~global_constraints ~explain univ in
-    let timer = Util.Timer.create "Algo.Depsolver.listcheck" in
-    Util.Timer.start timer;
+    Util.Timer.stop timer_init ();
+    Util.Timer.start timer_solver;
     let failed = ref 0 in
     let size = (Cudf.universe_size univ) + 1 in
     let tested = Array.make size false in
     Util.Progress.set_total Depsolver_int.progressbar_univcheck size ;
     let check = Depsolver_int.pkgcheck callback explain solver tested in
     List.iter (function
-      |id when id = solver.Depsolver_int.globalid -> ()
+      |id when solver.Depsolver_int.globalid = None ||
+              (Option.get solver.Depsolver_int.globalid) = id -> ()
       |id -> if not(check id) then incr failed
     ) idlist ;
-    Util.Timer.stop timer !failed
+    Util.Timer.stop timer_solver !failed
   in
   let idlist = List.map (CudfAdd.pkgtoint universe) pkglist in
   let map = new Common.Util.identity in

applications/distcheck.ml

@@ -240,19 +240,6 @@ let main () =
     let nbp =
       if (OptParse.Opt.is_set Options.checkonly) && (List.length checklist) = 0 then 0
       else if OptParse.Opt.is_set Options.checkonly || not(bg_pkglist = []) then 
-        (*
-        let subuniverse =
-          let l =
-            Cudf.fold_packages (fun acc pkg ->
-                match pkg.Cudf.keep with
-                |`Keep_package |`Keep_version | `Keep_feature 
-                  when pkg.Cudf.installed -> pkg::acc
-                |_ -> acc
-            ) checklist universe
-          in
-          Cudf.load_universe (CudfAdd.cone universe l)
-        in
-        *)
         Depsolver.listcheck ~global_constraints ~callback ~explain universe checklist
       else
         univcheck ~global_constraints ~callback ~explain universe 

applications/outdated.ml

@@ -92,8 +92,6 @@ let version_of_target getv = function
   |`Lo v |`In (_,v) -> (getv v) - 1
 ;;
 
-let timer = Util.Timer.create "Solver"
-
 (* the repository should contain only the most recent version of each
    package *)
 let future ~options ?(checklist=[]) repository =
@@ -273,17 +271,16 @@ let outdated
   let results = Diagnostic.default_result universe_size in
   let callback d = 
     if summary then Diagnostic.collect results d ;
-    Diagnostic.fprintf ~pp ~failure ~explain fmt d 
+    if failure then
+      Diagnostic.fprintf ~pp ~failure ~explain fmt d 
   in
 
-  Util.Timer.start timer;
   let broken =
     if checklist <> [] then
-      Depsolver.listcheck ~callback universe checklist
+      Depsolver.listcheck ~callback ~explain universe checklist
     else
-      Depsolver.univcheck ~callback universe
+      Depsolver.univcheck ~callback ~explain universe
   in
-  ignore(Util.Timer.stop timer ());
 
   if failure then Format.fprintf fmt "@]@.";
 
@@ -306,8 +303,9 @@ let main () =
 
   StdDebug.enable_debug (OptParse.Opt.get Options.verbose);
   StdDebug.enable_bars (OptParse.Opt.get Options.progress)
-    ["Depsolver_int.univcheck";"Depsolver_int.init_solver"] ;
-  StdDebug.enable_timers (OptParse.Opt.get Options.timers) ["Solver"];
+  ["Depsolver_int.univcheck";"Depsolver_int.init_solver"];
+  StdDebug.enable_timers (OptParse.Opt.get Options.timers)
+    ["Algo.Depsolver.solver"; "Algo.Depsolver.init" ] ;
   StdDebug.all_quiet (OptParse.Opt.get Options.quiet);
 
   let checklist = OptParse.Opt.opt Options.checkonly in

common/edosSolver.ml

@@ -12,6 +12,7 @@
 (*  library, see the COPYING file for more information.                                *)
 (***************************************************************************************)
 
+
 module type S = sig
   type reason
 end
@@ -55,6 +56,27 @@ module IntHash =
     let hash i = i
   end)
 
+open ExtLib
+(*
+let (@) l1 l2 =
+  let rec geq = function
+    |[],[] -> true
+    |_::_,[] -> true
+    |[],_::_ -> false
+    |_::r1,_::r2 -> geq (r1,r2)
+  in 
+  if geq (l1,l2) then List.append l2 l1 else List.append l1 l2
+*)
+
+(* join two lists ignoring the order *)
+let (@) l1 l2 =
+  let rec aux l1 l2 acc =
+    match (l1,l2) with
+    |x::r1,y::r2 -> aux r1 r2 (x::y::acc)
+    |l1,[] -> List.fold_left (fun accu x -> x::accu) l1 acc
+    |[],l2 -> List.fold_left (fun accu x -> x::accu) l2 acc
+  in aux l1 l2 []
+
 module M (X : S) = struct
 
   module X = X
@@ -442,10 +464,6 @@ module M (X : S) = struct
       reasons := !r.reasons @ !reasons;
       for i = 0 to Array.length !r.all_lits - 1 do
         let p = !r.all_lits.(i) in
-(*
-      for i = 0 to Array.length !r.lits - 1 do
-        let p = !r.lits.(i) in
-*)
         let x = var_of_lit p in
         if  st.st_seen_var.(x) <> st.st_seen then begin
           assert (val_of_lit st p = False);