From 8a0ede3292b4968b1e3261ad97b96d5ea0ad16fd Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 20 Jan 2020 14:12:22 +0000 Subject: [PATCH] Implement keep-going (-k) option. --- docs/goals.pod | 11 +++++++- src/cmdline.ml | 6 +++++ src/cmdline.mli | 3 +++ src/deps.ml | 55 ++++++++++++++++++++++++++++++---------- src/deps.mli | 1 + src/jobs.ml | 9 ++++--- src/jobs.mli | 13 +++++++--- src/main.ml | 3 ++- tests/20-option-keep-going.gl | 59 +++++++++++++++++++++++++++++++++++++++++++ tests/20-option-keep-going.sh | 50 ++++++++++++++++++++++++++++++++++++ 10 files changed, 187 insertions(+), 23 deletions(-) create mode 100644 tests/20-option-keep-going.gl create mode 100755 tests/20-option-keep-going.sh diff --git a/docs/goals.pod b/docs/goals.pod index cf67a45..ffea303 100644 --- a/docs/goals.pod +++ b/docs/goals.pod @@ -9,7 +9,7 @@ goals - an experimental tool that generalizes “make” goals ['TARGET'] ['VAR=VALUE'] [-C|--directory DIRECTORY] [-d] [-f|--file Goalfile] [-I|--include DIRECTORY] [-j|--jobs JOBS] [--no-prelude] - [-s|--silent|--quiet] + [-k|--keep-going] [-s|--silent|--quiet] goals --help @@ -90,6 +90,15 @@ prelude is always loaded automatically before any initial goal file (but you can redefine prelude definitions in your goal file if you want). +=item B<-k> + +=item B<--keep-going> + +Continue as much as possible after an error. The target that failed +and anything that depends on that target (recursively) will fail and +the program as a whole will still exit with an error, but as many +targets as can be built will be built. + =item B<-s> =item B<--silent> diff --git a/src/cmdline.ml b/src/cmdline.ml index 927dfdf..86e9dbf 100644 --- a/src/cmdline.ml +++ b/src/cmdline.ml @@ -53,6 +53,7 @@ let input_file = ref "Goalfile" let includes = ref [stdlibdir] let add_include dir = includes := dir :: !includes let nr_jobs = ref (nprocs ()) +let keep_going = ref false let silent = ref false let use_prelude = ref true @@ -84,6 +85,10 @@ let parse () = jobshelp; "--no-prelude",Arg.Clear use_prelude, " Do not automatically use prelude.gl from stdlib"; + "-k", Arg.Set keep_going, + " Keep going after an error"; + "--keep-going",Arg.Set keep_going, + " Keep going after an error"; "-s", Arg.Set silent, " Silent operation"; "--silent", Arg.Set silent, @@ -136,5 +141,6 @@ let input_file () = !input_file let includes () = !includes let nr_jobs () = !nr_jobs +let keep_going () = !keep_going let silent () = !silent let use_prelude () = !use_prelude diff --git a/src/cmdline.mli b/src/cmdline.mli index 9bc8ff9..5080993 100644 --- a/src/cmdline.mli +++ b/src/cmdline.mli @@ -51,6 +51,9 @@ val includes : unit -> string list val nr_jobs : unit -> int (** Number of jobs (-j option). *) +val keep_going : unit -> bool +(** Keep-going mode (-k option). *) + val silent : unit -> bool (** Silent operation (-s option). *) diff --git a/src/deps.ml b/src/deps.ml index 6656e87..8acf658 100644 --- a/src/deps.ml +++ b/src/deps.ml @@ -481,10 +481,14 @@ type state = { * access we store a map node -> true. *) mutable complete : bool G.t; + + (* List of nodes which failed. *) + mutable failed : bool G.t; } let new_state (dag, sorted_nodes) goal_runner exists_runner = - { dag; goal_runner; exists_runner; sorted_nodes; complete = G.empty } + { dag; goal_runner; exists_runner; sorted_nodes; + complete = G.empty; failed = G.empty } (* Called by [Jobs] when a node completes successfully. We mark * it as done. @@ -492,6 +496,13 @@ let new_state (dag, sorted_nodes) goal_runner exists_runner = let retire_job state node = state.complete <- G.add node true state.complete +(* Called by [Jobs] when a node fails. We mark the node as + * failed and ensure that anything that depends on it will + * also be marked as failed (and never returned by next_job). + *) +let fail_job state node = + state.failed <- G.add node true state.failed + let rec next_job state = (* Find the earliest node in the list which has all its * dependencies done. @@ -499,25 +510,41 @@ let rec next_job state = let rec loop acc = function | [] -> if state.sorted_nodes = [] then Jobs.Complete else Jobs.Not_ready - | node :: nodes -> - if node_is_ready_to_run state node then ( - state.sorted_nodes <- List.rev acc @ nodes; - match node with - | Goal (env, loc, name, args, goal, extra_deps, debug_goal) -> - Jobs.Job (node, fun () -> - state.goal_runner env loc name args goal - extra_deps debug_goal) - | Exists (env, loc, p, debug_tactic) -> - Jobs.Job (node, fun () -> - state.exists_runner env loc p debug_tactic) + | node :: nodes when node_is_ready_to_run state node -> + (* Drop the node from the list of jobs and run it. *) + state.sorted_nodes <- List.rev acc @ nodes; + (match node with + | Goal (env, loc, name, args, goal, extra_deps, debug_goal) -> + Jobs.Job (node, fun () -> + state.goal_runner env loc name args goal + extra_deps debug_goal) + | Exists (env, loc, p, debug_tactic) -> + Jobs.Job (node, fun () -> + state.exists_runner env loc p debug_tactic) ) - else - loop (node :: acc) nodes + | node :: nodes when node_failed state node -> + (* Mark it as failed also, and drop it from the list of jobs. *) + fail_job state node; + state.sorted_nodes <- List.rev acc @ nodes; + loop acc nodes + | node :: nodes -> + (* All dependencies of this node are neither complete nor failed, + * continue down the list. + *) + loop (node :: acc) nodes in loop [] state.sorted_nodes +(* All dependencies of this node are complete. *) and node_is_ready_to_run { dag; complete } node = let parents = try G.find node dag.edges with Not_found -> [] in List.for_all (fun p -> G.mem p complete) parents +(* This node or any dependency of this node failed. *) +and node_failed { dag; failed } node = + G.mem node failed || ( + let parents = try G.find node dag.edges with Not_found -> [] in + List.exists (fun p -> G.mem p failed) parents + ) + let string_of_job = string_of_node diff --git a/src/deps.mli b/src/deps.mli index 7cdcdab..759447e 100644 --- a/src/deps.mli +++ b/src/deps.mli @@ -46,6 +46,7 @@ val new_state : t -> goal_runner -> exists_runner -> state type node val retire_job : state -> node -> unit +val fail_job : state -> node -> unit (** See {!Jobs.run}. *) val next_job : state -> node Jobs.next diff --git a/src/jobs.ml b/src/jobs.ml index f5aefa9..0a698ef 100644 --- a/src/jobs.ml +++ b/src/jobs.ml @@ -21,7 +21,7 @@ open Utils type 'a next = Job of 'a * (unit -> unit) | Complete | Not_ready -let run next_job retire_job string_of_job = +let run next_job retire_job fail_job string_of_job = (* Number of running threads <= Cmdline.nr_jobs. *) let running = ref 0 in @@ -38,7 +38,9 @@ let run next_job retire_job string_of_job = Mutex.lock lock; (match exn with | None -> retire_job job - | Some exn -> last_exn := exn :: !last_exn + | Some exn -> + last_exn := exn :: !last_exn; + fail_job job ); decr running; Condition.signal cond; @@ -46,7 +48,8 @@ let run next_job retire_job string_of_job = in let rec loop () = - if !last_exn = [] then ( + let continue = !last_exn = [] || Cmdline.keep_going () in + if continue then ( match next_job () with | Complete -> () | Not_ready -> diff --git a/src/jobs.mli b/src/jobs.mli index a5b79bb..9be4186 100644 --- a/src/jobs.mli +++ b/src/jobs.mli @@ -21,18 +21,22 @@ type 'a next = Job of 'a * (unit -> unit) | Complete | Not_ready -val run : (unit -> 'a next) -> ('a -> unit) -> ('a -> string) -> unit -(** [run next_job retire_job to_string] runs jobs in parallel. +val run : (unit -> 'a next) -> ('a -> unit) -> ('a -> unit) -> + ('a -> string) -> unit +(** [run next_job retire_job fail_job to_string] runs jobs in parallel. [next_job] is called to pick the next available job. [retire_job] is called when a job finishes successfully. + [fail_job] is called when a job fails (only in keep-going + -k mode). All jobs that depend on this one must be marked + failed by the caller. [to_string] is called if we need to print the job name. If [next_job] returns [Job f] then that function is started (usually in a thread if -j N > 1). If [next_job] returns [Complete] then [run] waits until - all parallel jobs are then returns. + all parallel jobs are finished then returns. If [next_job] returns [Not_ready] then [next_job] will be called again after a little while. @@ -40,4 +44,5 @@ val run : (unit -> 'a next) -> ('a -> unit) -> ('a -> string) -> unit If any job throws an exception then the exception will be reraised by [run], usually causing goals to exit with an error. The exception is delayed until all currently running jobs - finish, but no new jobs will be started during this time. *) + finish. In normal mode no new jobs will be started during + this time. In keep-going -k mode new jobs may be started. *) diff --git a/src/main.ml b/src/main.ml index ba4a195..cee1dcf 100644 --- a/src/main.ml +++ b/src/main.ml @@ -84,8 +84,9 @@ let main () = let state = Deps.new_state dag Run.goal_runner Run.exists_runner in let next_job () = Deps.next_job state in let retire_job job = Deps.retire_job state job in + let fail_job job = Deps.fail_job state job in let string_of_job job = Deps.string_of_job job in - Jobs.run next_job retire_job string_of_job + Jobs.run next_job retire_job fail_job string_of_job let () = try main () diff --git a/tests/20-option-keep-going.gl b/tests/20-option-keep-going.gl new file mode 100644 index 0000000..ef1c4c7 --- /dev/null +++ b/tests/20-option-keep-going.gl @@ -0,0 +1,59 @@ +# Goals test. +# Copyright (C) 2020 Richard W.M. Jones +# Copyright (C) 2020 Red Hat Inc. +# +# 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 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 General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +# This tests the behaviour of the keep-going (-k) option. This +# should build as many targets as possible. The tree of goals +# looks like this: +# +# fail3 +# / +# fail1 good3 good6 +# / / / +# all --- good1 --- good2 --- fail2 +# \ \ +# good4 --- good5 good7 -- good8..20 +# +# The following goals should run: +# fail2, fail3, good3, good4, good5, good6, good7, good8..20 +# The following goals should NOT run: +# all, fail1, good1, good2 + +goal all = : fail1, good1, good4 { echo ALL } +goal fail1 = : fail3 { echo FAIL1; exit 1 } +goal fail2 = : good6, good7 { echo FAIL2; exit 1 } +goal fail3 = { echo FAIL3; exit 1 } +goal good1 = : good2 { echo GOOD1 } +goal good2 = : good3, fail2 { echo GOOD2 } +goal good3 = { echo GOOD3 } +goal good4 = : good5 { echo GOOD4 } +goal good5 = { echo GOOD5 } +goal good6 = { echo GOOD6 } +goal good7 = : good8 { echo GOOD7 } +goal good8 = : good9 { echo GOOD8 } +goal good9 = : good10 { echo GOOD9 } +goal good10 = : good11 { echo GOOD10 } +goal good11 = : good12 { echo GOOD11 } +goal good12 = : good13 { echo GOOD12 } +goal good13 = : good14 { echo GOOD13 } +goal good14 = : good15 { echo GOOD14 } +goal good15 = : good16 { echo GOOD15 } +goal good16 = : good17 { echo GOOD16 } +goal good17 = : good18 { echo GOOD17 } +goal good18 = : good19 { echo GOOD18 } +goal good19 = : good20 { echo GOOD19 } +goal good20 = { echo GOOD20 } diff --git a/tests/20-option-keep-going.sh b/tests/20-option-keep-going.sh new file mode 100755 index 0000000..f684368 --- /dev/null +++ b/tests/20-option-keep-going.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +# Goals test. +# Copyright (C) 2020 Richard W.M. Jones +# Copyright (C) 2020 Red Hat Inc. +# +# 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 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 General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +set -e + +if goals -k -f 20-option-keep-going.gl > 20-option-keep-going.out 2>&1; then + echo "$0: expected goals to exit with an error" + exit 1 +fi +fgrep FAIL2 20-option-keep-going.out +fgrep FAIL3 20-option-keep-going.out +fgrep GOOD3 20-option-keep-going.out +fgrep GOOD4 20-option-keep-going.out +fgrep GOOD5 20-option-keep-going.out +fgrep GOOD6 20-option-keep-going.out +fgrep GOOD7 20-option-keep-going.out +fgrep GOOD8 20-option-keep-going.out +fgrep GOOD9 20-option-keep-going.out +fgrep GOOD10 20-option-keep-going.out +fgrep GOOD11 20-option-keep-going.out +fgrep GOOD12 20-option-keep-going.out +fgrep GOOD13 20-option-keep-going.out +fgrep GOOD14 20-option-keep-going.out +fgrep GOOD15 20-option-keep-going.out +fgrep GOOD16 20-option-keep-going.out +fgrep GOOD17 20-option-keep-going.out +fgrep GOOD18 20-option-keep-going.out +fgrep GOOD19 20-option-keep-going.out +fgrep GOOD20 20-option-keep-going.out +! fgrep ALL 20-option-keep-going.out +! fgrep FAIL1 20-option-keep-going.out +! fgrep GOOD1 20-option-keep-going.out +! fgrep GOOD2 20-option-keep-going.out +rm 20-option-keep-going.out -- 1.8.3.1