diff --git a/doc/reference/actions/dynamic-run.rst b/doc/reference/actions/dynamic-run.rst index 6e83343c990..f972d36afcc 100644 --- a/doc/reference/actions/dynamic-run.rst +++ b/doc/reference/actions/dynamic-run.rst @@ -8,6 +8,9 @@ dynamic-run Execute a program that was linked against the ``dune-action-plugin`` library. ```` is resolved in the same way as in :doc:`run`. + The program remains running while Dune builds dependencies that it discovers, + so each ``dynamic-run`` invocation starts the program only once. + Example:: (dynamic-run ./plugin.exe) diff --git a/otherlibs/dune-action-plugin/src/dune b/otherlibs/dune-action-plugin/src/dune index 0d76b5c49fe..cf6b28c829e 100644 --- a/otherlibs/dune-action-plugin/src/dune +++ b/otherlibs/dune-action-plugin/src/dune @@ -1,6 +1,6 @@ (library (name dune_action_plugin) (public_name dune-action-plugin) - (libraries stdune csexp dune-glob unix dune-rpc) + (libraries stdune csexp dune-glob unix threads.posix dune-rpc) (synopsis "[Internal] Monadic interface for defining scripts with dynamic or complex sets of dependencies.")) diff --git a/otherlibs/dune-action-plugin/src/dune_action_plugin.ml b/otherlibs/dune-action-plugin/src/dune_action_plugin.ml index 0c754705648..c722ab94a77 100644 --- a/otherlibs/dune-action-plugin/src/dune_action_plugin.ml +++ b/otherlibs/dune-action-plugin/src/dune_action_plugin.ml @@ -134,11 +134,305 @@ module V1 = struct } ;; + module Dap_client = struct + module Rpc = Protocol.Rpc + module Dune_rpc = Dune_rpc.V1 + + module Error = struct + type t = + | Version_error of + { procedure : string + ; error : Dune_rpc.Version_error.t + } + | Response_error of Dune_rpc.Response.Error.t + | Build_error of string + + let message = function + | Version_error { procedure; error } -> + "unable to negotiate " ^ procedure ^ ": " ^ Dune_rpc.Version_error.message error + | Response_error error -> + "dune rpc error: " ^ Dune_rpc.Response.Error.message error + | Build_error message -> message + ;; + end + + module type Monad = sig + type 'a t + + val return : 'a -> 'a t + + module O : sig + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t + end + end + + module Make + (M : Monad) + (Chan : sig + type t + end) + (Client : Dune_rpc.Client.S with type 'a fiber := 'a M.t and type chan := Chan.t) = + struct + type t = + { client : Client.t + ; action_id : string + ; targets : String.Set.t + ; build_deps_request : (Rpc.Build_deps.t, string option) Client.Versioned.request + ; mutable prepared_dependencies : Dependency.Set.t + } + + let targets t = t.targets + let prepared_dependencies t = t.prepared_dependencies + let version_error procedure error = Error.Version_error { procedure; error } + let response_error error = Error.Response_error error + + let prepare_request client name request = + let open M.O in + let+ result = Client.Versioned.prepare_request client request in + Stdune.Result.map_error result ~f:(fun error -> version_error name error) + ;; + + let request client request payload = + let open M.O in + let+ result = Client.request client request payload in + Stdune.Result.map_error result ~f:response_error + ;; + + let create client ~action_id = + let open M.O in + let* initialize_request = + prepare_request client "dap/initialize" Rpc.initialize_request + in + match initialize_request with + | Error _ as error -> M.return error + | Ok initialize_request -> + let* build_deps_request = + prepare_request client "dap/build-deps" Rpc.build_deps_request + in + (match build_deps_request with + | Error _ as error -> M.return error + | Ok build_deps_request -> + let* run_arguments = request client initialize_request action_id in + (match run_arguments with + | Error _ as error -> M.return error + | Ok run_arguments -> + M.return + (Ok + { client + ; action_id + ; targets = run_arguments.targets + ; build_deps_request + ; prepared_dependencies = Dependency.Set.empty + }))) + ;; + + let connect chan ~action_id ~f = + let open M.O in + let id = Dune_rpc.Request.Id.make (List [ Atom "dap"; Atom action_id ]) in + let initialize = Dune_rpc.Request.Initialize.create ~id in + Client.connect chan initialize ~f:(fun client -> + let* t = create client ~action_id in + match t with + | Error _ as error -> M.return error + | Ok t -> f t) + ;; + + let build_deps t deps = + if Dependency.Set.is_empty deps + then M.return (Ok ()) + else + let open M.O in + let+ response = + request + t.client + t.build_deps_request + { Rpc.Build_deps.action_id = t.action_id; deps } + in + match response with + | Error _ as error -> error + | Ok (Some message) -> Error (Error.Build_error message) + | Ok None -> + t.prepared_dependencies <- Dependency.Set.union t.prepared_dependencies deps; + Ok () + ;; + end + end + + module Blocking_rpc = struct + module Fiber = struct + type 'a t = unit -> 'a + + let return x () = x + + module O = struct + let ( let* ) x f () = f (x ()) () + let ( let+ ) x f () = f (x ()) + end + + let collect_errors f () = + match f () () with + | result -> Ok result + | exception exn -> Error [ exn ] + ;; + + let finalize f ~finally () = + Exn.protect ~f:(fun () -> f () ()) ~finally:(fun () -> finally () ()) + ;; + + let parallel_iter next ~f () = + let rec loop () = + match next () () with + | None -> () + | Some x -> + f x (); + loop () + in + loop () + ;; + + module Ivar = struct + type 'a t = + { mutex : Mutex.t + ; condition : Condition.t + ; mutable value : 'a option + } + + let create () = + { mutex = Mutex.create (); condition = Condition.create (); value = None } + ;; + + let read t () = + Mutex.lock t.mutex; + let rec loop () = + match t.value with + | Some value -> + Mutex.unlock t.mutex; + value + | None -> + Condition.wait t.condition t.mutex; + loop () + in + loop () + ;; + + let fill t value () = + Mutex.lock t.mutex; + (match t.value with + | Some _ -> () + | None -> + t.value <- Some value; + Condition.broadcast t.condition); + Mutex.unlock t.mutex + ;; + end + + let thread_pool = + lazy + (Stdune.Thread_pool0.create + ~spawn:(fun f -> Thread.create f ()) + ~min_workers:0 + ~max_workers:50) + ;; + + let fork_and_join_unit f g () = + Stdune.Thread_pool0.task (Lazy.force thread_pool) ~f:(fun () -> + match f () () with + | () -> () + | exception exn -> + prerr_endline ("dune rpc reader failed: " ^ Printexc.to_string exn); + flush stderr; + exit 2); + g () () + ;; + end + + module Chan = struct + type t = + { socket : Unix.file_descr + ; ic : in_channel + ; oc : out_channel + } + + let read t () = + match Csexp.input_opt t.ic with + | Ok sexp -> sexp + | Error message -> failwith ("unable to read dune rpc packet: " ^ message) + | exception End_of_file -> None + | exception Sys_error _ -> None + | exception Unix.Unix_error _ -> None + ;; + + let write t packets () = + List.iter packets ~f:(Csexp.to_channel t.oc); + flush t.oc + ;; + + let close t () = + (match Unix.shutdown t.socket Unix.SHUTDOWN_ALL with + | () -> () + | exception Unix.Unix_error _ -> ()); + close_out_noerr t.oc; + close_in_noerr t.ic + ;; + + let create socket = + { socket + ; ic = Unix.in_channel_of_descr (Unix.dup socket) + ; oc = Unix.out_channel_of_descr socket + } + ;; + end + + module Client = Dune_rpc.V1.Client.Make (Fiber) (Chan) + + let connect where = + let connection_error exn = + let message = + match exn with + | Unix.Unix_error (error, syscall, arg) -> + Unix_error.Detailed.create error ~syscall ~arg + |> Unix_error.Detailed.to_string_hum + | _ -> raise exn + in + Execution_error.raise ("unable to connect to dune rpc server: " ^ message) + in + let socket_of_addr addr = + let domain = + match addr with + | Unix.ADDR_UNIX _ -> Unix.PF_UNIX + | Unix.ADDR_INET _ -> Unix.PF_INET + in + let socket = + match Unix.socket domain Unix.SOCK_STREAM 0 with + | socket -> socket + | exception exn -> connection_error exn + in + match Unix.connect socket addr with + | () -> Chan.create socket + | exception exn -> + Unix.close socket; + connection_error exn + in + match where with + | `Unix path -> socket_of_addr (Unix.ADDR_UNIX path) + | `Ip (`Host host, `Port port) -> + let service = Int.to_string port in + (match Unix.getaddrinfo host service [ Unix.AI_SOCKTYPE Unix.SOCK_STREAM ] with + | [] -> Execution_error.raise ("unable to resolve dune rpc host: " ^ host) + | addr :: _ -> socket_of_addr addr.Unix.ai_addr + | exception exn -> connection_error exn) + ;; + end + + module Blocking_dap_client = + Dap_client.Make (Blocking_rpc.Fiber) (Blocking_rpc.Chan) (Blocking_rpc.Client) + let rec run_by_dune t context = match t with - | Pure () -> Context.respond context Done + | Pure () -> Ok () | Stage at -> - let allowed_targets = Context.targets context in + let allowed_targets = Blocking_dap_client.targets context in let disallowed_targets = String.Set.diff at.targets allowed_targets in (match String.Set.to_list disallowed_targets with | [] -> () @@ -155,13 +449,14 @@ module V1 = struct dune file:\n\ %sTo fix, add them to target list in dune file." (ts |> String.concat ~sep:"\n"))); - let prepared_dependencies = Context.prepared_dependencies context in let required_dependencies = - Dependency.Set.diff at.dependencies prepared_dependencies + Dependency.Set.diff + at.dependencies + (Blocking_dap_client.prepared_dependencies context) in - if Dependency.Set.is_empty required_dependencies - then run_by_dune (at.action ()) context - else Context.respond context (Need_more_deps required_dependencies) + (match Blocking_dap_client.build_deps context required_dependencies () with + | Error _ as error -> error + | Ok () -> run_by_dune (at.action ()) context) ;; (* If executable is not run by dune, assume that all dependencies are already @@ -173,15 +468,33 @@ module V1 = struct ;; let do_run t = - match Protocol.Context.create () with - | Run_outside_of_dune -> run_outside_of_dune t - | Error message -> + match + ( Env.get Env.initial Protocol.Rpc.action_id_env_variable + , Env.get Env.initial Protocol.old_run_by_dune_env_variable ) + with + | None, None -> run_outside_of_dune t + | None, Some _ -> Execution_error.raise - (Printf.sprintf - "Error during communication with dune. %s Did you use different dune version \ - to compile the executable?" - message) - | Ok context -> run_by_dune t context + "this dune-action-plugin executable requires Dune's RPC dynamic-run protocol" + | Some action_id, _ -> + let where = + match Dune_rpc.Private.Where.of_env Env.initial with + | Ok where -> where + | Error `Missing -> Execution_error.raise "unable to find a dune rpc server" + | Error (`Exn exn) -> + Execution_error.raise + ("invalid dune rpc server address: " ^ Printexc.to_string exn) + in + let chan = Blocking_rpc.connect where in + (match + Blocking_dap_client.connect + chan + ~action_id + ~f:(fun context () -> run_by_dune t context) + () + with + | Ok () -> () + | Error error -> Execution_error.raise (Dap_client.Error.message error)) ;; let run t = @@ -201,6 +514,7 @@ module V1 = struct module Private = struct module Protocol = Protocol + module Dap_client = Dap_client let do_run = do_run diff --git a/otherlibs/dune-action-plugin/src/dune_action_plugin.mli b/otherlibs/dune-action-plugin/src/dune_action_plugin.mli index 097aff2844d..863346ba04d 100644 --- a/otherlibs/dune-action-plugin/src/dune_action_plugin.mli +++ b/otherlibs/dune-action-plugin/src/dune_action_plugin.mli @@ -8,15 +8,9 @@ module V1 : sig dependencies of a computation. Dependencies can be declared dynamically - the list of dependencies can depend on previous dependencies. - Note: Monadic "bind" is provided, but it can be very costly. It's called - [stage] to discourage people from overusing it. When dune decides that the - action needs to be re-run, it runs (nontrivial) stages one by one, and - starts a process from scratch for every stage. So a linear chain of binds - leads to a linear number of program re-runs, and therefore overall - quadratic time complexity. This also means that using non-deterministic - mutable state can lead to surprising results. (note that with the current - implementation, nontrivial stages are those that have some dependencies, - so a stage that merely writes out some targets is "free") *) + Monadic "bind" is called [stage] to make dynamic dependency boundaries + explicit. Dune builds the dependencies of each stage while keeping the + plugin process running, then resumes the computation in that process. *) module Path = Path @@ -40,8 +34,8 @@ module V1 : sig [stage a ~f] is a computation that is equivalent to staging computation [bt] after computation [at]. - Note: This is a monadic "bind" function. This function is costly so - different name was chosen to discourage excessive use. *) + This is a monadic "bind" function. The name highlights that dependencies + introduced by [f] are discovered in a later stage. *) val stage : 'a t -> f:('a -> 'b t) -> 'b t (** {1 Syntax sugar for applicative subset} *) @@ -113,6 +107,53 @@ end module Private : sig module Protocol = Protocol + module Dap_client : sig + module Error : sig + type t = + | Version_error of + { procedure : string + ; error : Dune_rpc.V1.Version_error.t + } + | Response_error of Dune_rpc.V1.Response.Error.t + | Build_error of string + + val message : t -> string + end + + module type Monad = sig + type 'a t + + val return : 'a -> 'a t + + module O : sig + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t + end + end + + module Make + (M : Monad) + (Chan : sig + type t + end) + (Client : + Dune_rpc.V1.Client.S with type 'a fiber := 'a M.t and type chan := Chan.t) : sig + type t + + val create : Client.t -> action_id:string -> (t, Error.t) result M.t + + val connect + : Chan.t + -> action_id:string + -> f:(t -> ('a, Error.t) result M.t) + -> ('a, Error.t) result M.t + + val targets : t -> Stdune.String.Set.t + val prepared_dependencies : t -> Protocol.Dependency.Set.t + val build_deps : t -> Protocol.Dependency.Set.t -> (unit, Error.t) result M.t + end + end + val do_run : unit V1.t -> unit module Execution_error : sig diff --git a/otherlibs/dune-action-plugin/src/import.ml b/otherlibs/dune-action-plugin/src/import.ml index 4c4904ce239..d9d1477a917 100644 --- a/otherlibs/dune-action-plugin/src/import.ml +++ b/otherlibs/dune-action-plugin/src/import.ml @@ -5,11 +5,10 @@ include struct module Set = Set module Exn = Exn module String = String + module Env = Env module Io = Io module Sexp = Sexp - module Option = Option module Comparable = Comparable - module Result = Result module Map = Map end diff --git a/otherlibs/dune-action-plugin/src/protocol.ml b/otherlibs/dune-action-plugin/src/protocol.ml index 0639a7a2dcb..6d1280b0160 100644 --- a/otherlibs/dune-action-plugin/src/protocol.ml +++ b/otherlibs/dune-action-plugin/src/protocol.ml @@ -1,194 +1,15 @@ -open Import +let old_run_by_dune_env_variable = Stdune.Env.Var.of_string "DUNE_DYNAMIC_RUN_CLIENT" -let run_by_dune_env_variable = "DUNE_DYNAMIC_RUN_CLIENT" +module Dependency = Dune_rpc.Private.Dap.Dependency +module Run_arguments = Dune_rpc.Private.Dap.Run_arguments -module Error = Sexpable_intf.Error +module Rpc = struct + let action_id_env_variable = Stdune.Env.Var.of_string "DUNE_DYNAMIC_RUN_ACTION_ID" -module Dependency = struct - module T = struct - type t = - | File of string - | Directory of string - | Glob of - { path : string - ; glob : string - } + module Build_deps = Dune_rpc.Private.Dap.Build_deps - let conv = - let open Conv in - let file = constr "File" string (fun s -> File s) in - let directory = constr "Directory" string (fun s -> Directory s) in - let glob_cstr = - constr "Glob" (pair string string) (fun (path, glob) -> Glob { path; glob }) - in - sum - [ econstr file; econstr directory; econstr glob_cstr ] - (function - | File s -> case s file - | Directory s -> case s directory - | Glob { path; glob } -> case (path, glob) glob_cstr) - ;; - - let compare x y = - match x, y with - | File x, File y -> String.compare x y - | File _, _ -> Lt - | _, File _ -> Gt - | Directory x, Directory y -> String.compare x y - | Directory _, _ -> Lt - | _, Directory _ -> Gt - | Glob { path; glob }, Glob t -> - let open Ordering.O in - let= () = String.compare path t.path in - String.compare glob t.glob - ;; - - let to_dyn = Dyn.opaque - end - - include T - module O = Comparable.Make (T) - module Map = O.Map - - module Set = struct - include O.Set - - let conv : t Conv.value = Conv.iso (Conv.list conv) of_list to_list - end -end - -module Greeting = struct - module T = struct - type t = - { run_arguments_fn : string - ; response_fn : string - } - - let conv = - let open Conv in - let to_ (run_arguments_fn, response_fn) = { run_arguments_fn; response_fn } in - let from { run_arguments_fn; response_fn } = run_arguments_fn, response_fn in - iso (pair string string) to_ from - ;; - - let version = 0 - end - - include T - include Sexpable_intf.Make (T) -end - -module Run_arguments = struct - module T = struct - type t = - { prepared_dependencies : Dependency.Set.t - ; targets : String.Set.t - } - - let conv = - let from { prepared_dependencies; targets } = prepared_dependencies, targets in - let to_ (prepared_dependencies, targets) = { prepared_dependencies; targets } in - let string_set = - Conv.iso Conv.(list string) String.Set.of_list String.Set.to_list - in - let conv = Conv.pair Dependency.Set.conv string_set in - Conv.iso conv to_ from - ;; - - let version = 0 - end - - include T - include Sexpable_intf.Make (T) -end - -module Response = struct - module T = struct - type t = - | Done - | Need_more_deps of Dependency.Set.t - - let conv = - let open Conv in - let done_ = constr "Done" unit (fun () -> Done) in - let need_more_deps = - constr "Need_more_deps" Dependency.Set.conv (fun deps -> Need_more_deps deps) - in - sum - [ econstr done_; econstr need_more_deps ] - (function - | Done -> case () done_ - | Need_more_deps deps -> case deps need_more_deps) - ;; - - let version = 0 - end - - include T - include Sexpable_intf.Make (T) -end - -module Context = struct - type t = - { response_fn : string - ; prepared_dependencies : Dependency.Set.t - ; targets : String.Set.t - } - - type create_result = - | Ok of t - | Run_outside_of_dune - | Error of string - - let cannot_parse_error = Error "Can not parse dune message." - - let version_mismatch_error = - Error - "Dune version is incompatible with dune-action-plugin library version that was \ - used to build this executable." - ;; - - let cannot_read_file = Error "Cannot read file containing dune message." - let file_not_found_error = Error "Cannot find file containing dune message." - - let create () = - match Sys.getenv_opt run_by_dune_env_variable with - | None -> Run_outside_of_dune - | Some value -> - (match Csexp.parse_string value with - | Error _ -> cannot_parse_error - | Ok sexp -> - (match Greeting.of_sexp sexp with - | Error (Version_mismatch _) -> version_mismatch_error - | Error Parse_error -> cannot_parse_error - | Ok greeting -> - (match - ( Result.try_with (fun () -> - Io.String_path.read_file greeting.run_arguments_fn) - , Sys.file_exists greeting.response_fn ) - with - | _, false -> file_not_found_error - | Error _, _ -> cannot_read_file - | Ok data, true -> - (match Csexp.parse_string data with - | Error _ -> cannot_parse_error - | Ok sexp -> - (match Run_arguments.of_sexp sexp with - | Error (Version_mismatch _) -> version_mismatch_error - | Error Parse_error -> cannot_parse_error - | Ok { prepared_dependencies; targets } -> - Ok - { response_fn = greeting.response_fn - ; prepared_dependencies - ; targets - }))))) - ;; - - let prepared_dependencies (t : t) = t.prepared_dependencies - let targets (t : t) = t.targets - - let respond (t : t) response = - let data = Response.to_sexp response |> Csexp.to_string in - Io.String_path.write_file t.response_fn data - ;; + let initialize = Dune_rpc.Private.Procedures.Public.Action_plugin.initialize + let build_deps = Dune_rpc.Private.Procedures.Public.Action_plugin.build_deps + let initialize_request = Dune_rpc.V1.Request.Action_plugin.initialize + let build_deps_request = Dune_rpc.V1.Request.Action_plugin.build_deps end diff --git a/otherlibs/dune-action-plugin/src/protocol.mli b/otherlibs/dune-action-plugin/src/protocol.mli index 4a343799cee..c9e35ee12e6 100644 --- a/otherlibs/dune-action-plugin/src/protocol.mli +++ b/otherlibs/dune-action-plugin/src/protocol.mli @@ -1,62 +1,16 @@ -open Import -open Sexpable_intf -module Error : module type of Error +module Dependency = Dune_rpc.Private.Dap.Dependency +module Run_arguments = Dune_rpc.Private.Dap.Run_arguments -module Dependency : sig - type t = - | File of string - | Directory of string - | Glob of - { path : string - ; glob : string - } +module Rpc : sig + val action_id_env_variable : Stdune.Env.Var.t - module Map : Map.S with type key = t + module Build_deps = Dune_rpc.Private.Dap.Build_deps - module Set : sig - include Set.S with type elt = t and type 'a map = 'a Map.t - end + val initialize : (string, Run_arguments.t) Dune_rpc.Private.Decl.Request.t + val build_deps : (Build_deps.t, string option) Dune_rpc.Private.Decl.Request.t + val initialize_request : (string, Run_arguments.t) Dune_rpc.V1.Request.t + val build_deps_request : (Build_deps.t, string option) Dune_rpc.V1.Request.t end -module Greeting : sig - type t = - { run_arguments_fn : string - ; response_fn : string - } - - include Sexpable with type t := t -end - -module Run_arguments : sig - type t = - { prepared_dependencies : Dependency.Set.t - ; targets : String.Set.t - } - - include Sexpable with type t := t -end - -module Response : sig - type t = - | Done - | Need_more_deps of Dependency.Set.t - - include Sexpable with type t := t -end - -(** Dune sets this environment variable to pass [Greeting.t] to client. *) -val run_by_dune_env_variable : string - -module Context : sig - type t - - type create_result = - | Ok of t - | Run_outside_of_dune - | Error of string - - val create : unit -> create_result - val prepared_dependencies : t -> Dependency.Set.t - val targets : t -> String.Set.t - val respond : t -> Response.t -> unit -end +(** Marker set by Dune versions that used the old temp-file dynamic-run protocol. *) +val old_run_by_dune_env_variable : Stdune.Env.Var.t diff --git a/otherlibs/dune-action-plugin/src/sexpable_intf.ml b/otherlibs/dune-action-plugin/src/sexpable_intf.ml deleted file mode 100644 index ddd0f4813cb..00000000000 --- a/otherlibs/dune-action-plugin/src/sexpable_intf.ml +++ /dev/null @@ -1,42 +0,0 @@ -open Import - -module Error = struct - type t = - | Version_mismatch of int - | Parse_error -end - -module type Sexpable = sig - type t - - val to_sexp : t -> Sexp.t - val of_sexp : Sexp.t -> (t, Error.t) result -end - -module type S = sig - type t - - val conv : t Conv.value - val version : int -end - -module Make (Type : S) = struct - let conv = - let open Conv in - pair int Type.conv - ;; - - let of_sexp sexp : (_, Error.t) result = - match Conv.of_sexp Conv.(pair int sexp) ~version:(0, 0) sexp with - | Error _ -> Error Parse_error - | Ok (version, sexp) -> - (match Int.equal version Type.version with - | false -> Error (Version_mismatch version) - | true -> - (match Conv.of_sexp Type.conv ~version:(0, 0) sexp with - | Error _ -> Error Parse_error - | Ok v -> Ok v)) - ;; - - let to_sexp t = Conv.to_sexp conv (Type.version, t) -end diff --git a/otherlibs/dune-action-plugin/test/dependency-rebuilt-but-not-changed/run.t b/otherlibs/dune-action-plugin/test/dependency-rebuilt-but-not-changed/run.t index 470b8acb41c..69d31d9816a 100644 --- a/otherlibs/dune-action-plugin/test/dependency-rebuilt-but-not-changed/run.t +++ b/otherlibs/dune-action-plugin/test/dependency-rebuilt-but-not-changed/run.t @@ -24,8 +24,8 @@ they were forced to rebuild. $ cp ./bin/foo.exe ./ $ dune runtest - Building some_file! Hello from some_file! + Building some_file! $ dune runtest Building some_file! diff --git a/otherlibs/dune-action-plugin/test/depends-on-directory-with-glob/run.t b/otherlibs/dune-action-plugin/test/depends-on-directory-with-glob/run.t index 3287a40534c..077a22ea76e 100644 --- a/otherlibs/dune-action-plugin/test/depends-on-directory-with-glob/run.t +++ b/otherlibs/dune-action-plugin/test/depends-on-directory-with-glob/run.t @@ -37,7 +37,7 @@ $ cp ./bin/foo.exe ./ $ dune runtest - Building some_file! - Building some_file_but_different! some_file some_file_but_different + Building some_file! + Building some_file_but_different! diff --git a/otherlibs/dune-action-plugin/test/depends-on-its-target-by-read-dir/run.t b/otherlibs/dune-action-plugin/test/depends-on-its-target-by-read-dir/run.t index f4991bc364b..58e79a346ca 100644 --- a/otherlibs/dune-action-plugin/test/depends-on-its-target-by-read-dir/run.t +++ b/otherlibs/dune-action-plugin/test/depends-on-its-target-by-read-dir/run.t @@ -12,13 +12,12 @@ $ cp ./bin/foo.exe ./ - $ dune build some_file 2>&1 | awk '/Internal error/,/unable to serialize/' - Internal error! Please report to https://github.com/ocaml/dune/issues, - providing the file _build/trace.csexp, if possible. This includes build - commands, message logs, and file paths. - Description: - ("unable to serialize exception", - -^ This is not great. There is no actual dependency cycle, dune is just -interpreting glob dependency too coarsely (it builds all files instead -of just bringing the directory listing up to date). + $ dune build some_file + File "dune", lines 1-4, characters 0-62: + 1 | (rule + 2 | (target some_file) + 3 | (action + 4 | (dynamic-run ./foo.exe))) + Dependency cycle between: + _build/default/some_file + [1] diff --git a/otherlibs/dune-action-plugin/test/depends-on-its-target/bin/foo1.ml b/otherlibs/dune-action-plugin/test/depends-on-its-target/bin/foo1.ml index 4dac0897737..68700759f7d 100644 --- a/otherlibs/dune-action-plugin/test/depends-on-its-target/bin/foo1.ml +++ b/otherlibs/dune-action-plugin/test/depends-on-its-target/bin/foo1.ml @@ -1,5 +1,15 @@ open Dune_action_plugin.V1 -let path = Path.of_string "some_file1" -let action = read_file ~path |> stage ~f:(fun data -> write_file ~path ~data) +let dependency, target = + match Sys.argv with + | [| _ |] -> "some_file1", "some_file1" + | [| _; dependency; target |] -> dependency, target + | _ -> invalid_arg "expected dependency and target arguments" +;; + +let action = + read_file ~path:(Path.of_string dependency) + |> stage ~f:(fun data -> write_file ~path:(Path.of_string target) ~data) +;; + let () = run action diff --git a/otherlibs/dune-action-plugin/test/depends-on-its-target/run.t b/otherlibs/dune-action-plugin/test/depends-on-its-target/run.t index 743378c9c42..8a1f64e887c 100644 --- a/otherlibs/dune-action-plugin/test/depends-on-its-target/run.t +++ b/otherlibs/dune-action-plugin/test/depends-on-its-target/run.t @@ -13,17 +13,52 @@ > (target some_file2) > (action > (dynamic-run ./foo2.exe))) + > \ + > (rule + > (target some_file3) + > (action + > (dynamic-run ./foo1.exe some_file4 some_file3))) + > \ + > (rule + > (target some_file4) + > (deps some_file3) + > (action + > (write-file some_file4 done))) > EOF $ cp ./bin/foo1.exe ./ $ cp ./bin/foo2.exe ./ $ dune build some_file1 - Error: Dependency cycle between: + File "dune", lines 1-4, characters 0-64: + 1 | (rule + 2 | (target some_file1) + 3 | (action + 4 | (dynamic-run ./foo1.exe))) + Dependency cycle between: _build/default/some_file1 [1] $ dune build some_file2 - Error: Dependency cycle between: + File "dune", lines 5-8, characters 0-64: + 5 | (rule + 6 | (target some_file2) + 7 | (action + 8 | (dynamic-run ./foo2.exe))) + Dependency cycle between: _build/default/some_file2 [1] + +An indirect dependency on the action's target is rejected too. + + $ timeout 3 dune build some_file3 + File "dune", lines 9-12, characters 0-86: + 9 | (rule + 10 | (target some_file3) + 11 | (action + 12 | (dynamic-run ./foo1.exe some_file4 some_file3))) + Dependency cycle between: + _build/default/some_file4 + -> _build/default/some_file3 + -> _build/default/some_file4 + [1] diff --git a/otherlibs/dune-action-plugin/test/do-not-rebuild-unneeded-dependency/run.t b/otherlibs/dune-action-plugin/test/do-not-rebuild-unneeded-dependency/run.t index 0f599b7dc67..72979d34514 100644 --- a/otherlibs/dune-action-plugin/test/do-not-rebuild-unneeded-dependency/run.t +++ b/otherlibs/dune-action-plugin/test/do-not-rebuild-unneeded-dependency/run.t @@ -43,9 +43,9 @@ only the dependencies up to this stage are rebuilt. $ printf "SHOULD NOT BE PRINTED!" > bar_source $ dune runtest + Hello from foo! Building foo_or_bar! Building foo! - Hello from foo! $ printf "bar" > foo_or_bar_source $ printf "SHOULD NOT BE PRINTED!" > foo_source @@ -53,5 +53,5 @@ only the dependencies up to this stage are rebuilt. $ dune runtest Building foo_or_bar! - Building bar! Hello from bar! + Building bar! diff --git a/otherlibs/dune-action-plugin/test/one-absent-dependency/run.t b/otherlibs/dune-action-plugin/test/one-absent-dependency/run.t index 83584ec8e2d..f7c2b15f218 100644 --- a/otherlibs/dune-action-plugin/test/one-absent-dependency/run.t +++ b/otherlibs/dune-action-plugin/test/one-absent-dependency/run.t @@ -14,9 +14,10 @@ and requires dependency that can not be build fails. $ cp ./bin/foo.exe ./ - $ dune runtest 2>&1 | awk '/Internal error/,/unable to serialize/' - Internal error! Please report to https://github.com/ocaml/dune/issues, - providing the file _build/trace.csexp, if possible. This includes build - commands, message logs, and file paths. - Description: - ("unable to serialize exception", + $ dune runtest + File "dune", lines 1-3, characters 0-57: + 1 | (rule + 2 | (alias runtest) + 3 | (action (dynamic-run ./foo.exe))) + No rule found for some_absent_dependency + [1] diff --git a/otherlibs/dune-action-plugin/test/one-dependency/bin/dune b/otherlibs/dune-action-plugin/test/one-dependency/bin/dune index 22b5f28f566..7f061343c84 100644 --- a/otherlibs/dune-action-plugin/test/one-dependency/bin/dune +++ b/otherlibs/dune-action-plugin/test/one-dependency/bin/dune @@ -1,3 +1,3 @@ (executables (names foo) - (libraries dune-action-plugin)) + (libraries dune-action-plugin unix)) diff --git a/otherlibs/dune-action-plugin/test/one-dependency/bin/foo.ml b/otherlibs/dune-action-plugin/test/one-dependency/bin/foo.ml index 53c80d9043c..98575d6dcea 100644 --- a/otherlibs/dune-action-plugin/test/one-dependency/bin/foo.ml +++ b/otherlibs/dune-action-plugin/test/one-dependency/bin/foo.ml @@ -1,9 +1,36 @@ open Dune_action_plugin.V1 -let action = +let ordinary_action = let open Dune_action_plugin.V1.O in let+ data = read_file ~path:(Path.of_string "some_dependency") in print_endline data ;; +let write_connection path = + let output = open_out path in + output_string output (Sys.getenv "DUNE_DYNAMIC_RUN_ACTION_ID"); + output_char output '\n'; + output_string output (Sys.getenv "DUNE_RPC"); + output_char output '\n'; + close_out output +;; + +let held_action ~connection ~release = + write_file ~path:(Path.of_string "held-target") ~data:"held" + |> stage ~f:(fun () -> + write_connection connection; + while not (Sys.file_exists release) do + Unix.sleepf 0.05 + done; + return ()) +;; + +let action = + match Sys.argv with + | [| _ |] -> ordinary_action + | [| _; "hold"; connection; release |] -> held_action ~connection ~release + | [| _; "steal" |] -> return () + | _ -> invalid_arg "invalid arguments" +;; + let () = run action diff --git a/otherlibs/dune-action-plugin/test/one-dependency/run.t b/otherlibs/dune-action-plugin/test/one-dependency/run.t index e5dc04f0fc2..eca25ea78b7 100644 --- a/otherlibs/dune-action-plugin/test/one-dependency/run.t +++ b/otherlibs/dune-action-plugin/test/one-dependency/run.t @@ -14,9 +14,38 @@ and requires one dependency can be successfully run. > (rule > (alias runtest) > (action (dynamic-run ./foo.exe))) + > \ + > (rule + > (target held-target) + > (action + > (dynamic-run ./foo.exe hold "$PWD/connection" "$PWD/release"))) > EOF $ cp ./bin/foo.exe ./ + $ env DUNE_DYNAMIC_RUN_ACTION_ID=1 DUNE_RPC='unix:path=/no-such-dune-rpc-socket' ./foo.exe + unable to connect to dune rpc server: connect(): No such file or directory + [1] + $ dune runtest Hello from some_dependency! + +A second client cannot reuse the active action's id from another RPC session. + + $ rm -f connection release + $ dune build held-target > build.output 2>&1 & + $ build_pid=$! + $ for _ in $(seq 1 100); do + > test -f connection && break + > sleep 0.05 + > done + $ test -f connection + $ action_id=$(sed -n 1p connection) + $ dune_rpc=$(sed -n 2p connection) + $ (cd _build/default && env DUNE_DYNAMIC_RUN_ACTION_ID="$action_id" DUNE_RPC="$dune_rpc" ./foo.exe steal) + dune rpc error: dynamic action is already initialized + [1] + $ touch release + $ wait "$build_pid" + $ cat _build/default/held-target + held diff --git a/otherlibs/dune-action-plugin/test/two-stages-dependency-choose/bin/client.ml b/otherlibs/dune-action-plugin/test/two-stages-dependency-choose/bin/client.ml index cd7851a7efb..6b32ebaa438 100644 --- a/otherlibs/dune-action-plugin/test/two-stages-dependency-choose/bin/client.ml +++ b/otherlibs/dune-action-plugin/test/two-stages-dependency-choose/bin/client.ml @@ -1,5 +1,10 @@ open Dune_action_plugin.V1 +let () = + print_endline "starting client"; + flush stdout +;; + let action = let open Dune_action_plugin.V1.O in let switch = read_file ~path:(Path.of_string "foo_or_bar") in diff --git a/otherlibs/dune-action-plugin/test/two-stages-dependency-choose/run.t b/otherlibs/dune-action-plugin/test/two-stages-dependency-choose/run.t index d325844f3ac..0e2e7784138 100644 --- a/otherlibs/dune-action-plugin/test/two-stages-dependency-choose/run.t +++ b/otherlibs/dune-action-plugin/test/two-stages-dependency-choose/run.t @@ -33,5 +33,6 @@ on based on dependency from the previous stage. $ cp ./bin/client.exe ./ $ dune runtest - Building bar! + starting client Hello from bar! + Building bar! diff --git a/otherlibs/dune-rpc/dap.ml b/otherlibs/dune-rpc/dap.ml new file mode 100644 index 00000000000..9674e3ecc6c --- /dev/null +++ b/otherlibs/dune-rpc/dap.ml @@ -0,0 +1,78 @@ +open Import + +module Dependency = struct + module T = struct + type t = + | File of string + | Directory of string + | Glob of + { path : string + ; glob : string + } + + let conv = + let open Conv in + let file = constr "File" string (fun s -> File s) in + let directory = constr "Directory" string (fun s -> Directory s) in + let glob_cstr = + constr "Glob" (pair string string) (fun (path, glob) -> Glob { path; glob }) + in + sum + [ econstr file; econstr directory; econstr glob_cstr ] + (function + | File s -> case s file + | Directory s -> case s directory + | Glob { path; glob } -> case (path, glob) glob_cstr) + ;; + + let compare x y = + match x, y with + | File x, File y -> String.compare x y + | File _, _ -> Lt + | _, File _ -> Gt + | Directory x, Directory y -> String.compare x y + | Directory _, _ -> Lt + | _, Directory _ -> Gt + | Glob { path; glob }, Glob t -> + let open Ordering.O in + let= () = String.compare path t.path in + String.compare glob t.glob + ;; + + let to_dyn = Dyn.opaque + end + + include T + module O = Comparable.Make (T) + + module Set = struct + include O.Set + + let conv : t Conv.value = Conv.iso (Conv.list conv) of_list to_list + end +end + +module Run_arguments = struct + type t = { targets : String.Set.t } + + let conv = + let from { targets } = targets in + let to_ targets = { targets } in + let string_set = Conv.iso Conv.(list string) String.Set.of_list String.Set.to_list in + Conv.iso string_set to_ from + ;; +end + +module Build_deps = struct + type t = + { action_id : string + ; deps : Dependency.Set.t + } + + let conv = + let open Conv in + let to_ (action_id, deps) = { action_id; deps } in + let from { action_id; deps } = action_id, deps in + iso (pair string Dependency.Set.conv) to_ from + ;; +end diff --git a/otherlibs/dune-rpc/dap.mli b/otherlibs/dune-rpc/dap.mli new file mode 100644 index 00000000000..3faf8a15bb9 --- /dev/null +++ b/otherlibs/dune-rpc/dap.mli @@ -0,0 +1,39 @@ +open Import + +module Dependency : sig + type t = + | File of string + | Directory of string + | Glob of + { path : string + ; glob : string + } + + module Set : sig + type elt = t + type t + + val empty : t + val singleton : elt -> t + val union : t -> t -> t + val diff : t -> t -> t + val is_empty : t -> bool + val to_list_map : t -> f:(elt -> 'a) -> 'a list + val conv : t Conv.value + end +end + +module Run_arguments : sig + type t = { targets : String.Set.t } + + val conv : t Conv.value +end + +module Build_deps : sig + type t = + { action_id : string + ; deps : Dependency.Set.t + } + + val conv : t Conv.value +end diff --git a/otherlibs/dune-rpc/private.ml b/otherlibs/dune-rpc/private.ml index d6f717df79b..6bc2c09df55 100644 --- a/otherlibs/dune-rpc/private.ml +++ b/otherlibs/dune-rpc/private.ml @@ -1,4 +1,5 @@ module Conv = Conv +module Dap = Dap module Versioned = Versioned module Menu = Menu module Procedures = Procedures diff --git a/otherlibs/dune-rpc/procedures.ml b/otherlibs/dune-rpc/procedures.ml index 658fc3697bb..7599a4e559c 100644 --- a/otherlibs/dune-rpc/procedures.ml +++ b/otherlibs/dune-rpc/procedures.ml @@ -159,6 +159,42 @@ module Public = struct ;; end + module Action_plugin = struct + module Dependency = Dap.Dependency + module Run_arguments = Dap.Run_arguments + module Build_deps = Dap.Build_deps + + module Initialize = struct + let v1 = + Decl.Request.make_current_gen ~req:Conv.string ~resp:Run_arguments.conv ~version:1 + ;; + + let decl = + Decl.Request.make + ~method_:(Method.Name.of_string "dap/initialize") + ~generations:[ v1 ] + ;; + end + + module Build_deps_request = struct + let v1 = + Decl.Request.make_current_gen + ~req:Build_deps.conv + ~resp:Conv.(option string) + ~version:1 + ;; + + let decl = + Decl.Request.make + ~method_:(Method.Name.of_string "dap/build-deps") + ~generations:[ v1 ] + ;; + end + + let initialize = Initialize.decl + let build_deps = Build_deps_request.decl + end + let ping = Ping.decl let diagnostics = Diagnostics.decl let shutdown = Shutdown.decl @@ -373,6 +409,8 @@ module Builtin = struct ; request Public.promote_many ; request Public.build_dir ; request Public.runtest + ; request Public.Action_plugin.initialize + ; request Public.Action_plugin.build_deps ; notification ~declare_with_client:false Server_side.abort ; notification ~declare_with_client:false Server_side.log ; request (Poll.poll Poll.running_jobs) diff --git a/otherlibs/dune-rpc/procedures.mli b/otherlibs/dune-rpc/procedures.mli index ad544c546e5..b0d4c9206ae 100644 --- a/otherlibs/dune-rpc/procedures.mli +++ b/otherlibs/dune-rpc/procedures.mli @@ -12,6 +12,15 @@ module Public : sig val promote_many : (Promote_targets.t, Build_outcome_with_diagnostics.t) Decl.Request.t val build_dir : (unit, Path.t) Decl.Request.t val runtest : (string list, Build_outcome_with_diagnostics.t) Decl.Request.t + + module Action_plugin : sig + module Dependency = Dap.Dependency + module Run_arguments = Dap.Run_arguments + module Build_deps = Dap.Build_deps + + val initialize : (string, Run_arguments.t) Decl.Request.t + val build_deps : (Build_deps.t, string option) Decl.Request.t + end end module Server_side : sig diff --git a/otherlibs/dune-rpc/public.ml b/otherlibs/dune-rpc/public.ml index f9d56aee4b6..1203624388e 100644 --- a/otherlibs/dune-rpc/public.ml +++ b/otherlibs/dune-rpc/public.ml @@ -15,6 +15,11 @@ module Request = struct let promote_many = Procedures.Public.promote_many.decl let build_dir = Procedures.Public.build_dir.decl let runtest = Procedures.Public.runtest.decl + + module Action_plugin = struct + let initialize = Procedures.Public.Action_plugin.initialize.decl + let build_deps = Procedures.Public.Action_plugin.build_deps.decl + end end module Notification = struct diff --git a/otherlibs/dune-rpc/v1.mli b/otherlibs/dune-rpc/v1.mli index 4816c35361a..fcfc7581414 100644 --- a/otherlibs/dune-rpc/v1.mli +++ b/otherlibs/dune-rpc/v1.mli @@ -316,6 +316,11 @@ module Request : sig (** Returns the location of the build directory for the current build. *) val build_dir : (unit, Path.t) t + module Action_plugin : sig + val initialize : (string, Dap.Run_arguments.t) t + val build_deps : (Dap.Build_deps.t, string option) t + end + module Id : sig (** Id's for requests. diff --git a/otherlibs/stdune/src/stdune.ml b/otherlibs/stdune/src/stdune.ml index 123403eff6d..ec4848cfa7d 100644 --- a/otherlibs/stdune/src/stdune.ml +++ b/otherlibs/stdune/src/stdune.ml @@ -76,6 +76,7 @@ module Applicative = Applicative module Json = Json module Log = Log module Stat = Stat +module Thread_pool0 = Thread_pool0 module Time = Time module Escape0 = Escape module Debug = Debug diff --git a/otherlibs/stdune/src/thread_pool0.ml b/otherlibs/stdune/src/thread_pool0.ml new file mode 100644 index 00000000000..37fc22e1ba7 --- /dev/null +++ b/otherlibs/stdune/src/thread_pool0.ml @@ -0,0 +1,127 @@ +(** The thread pool implementation allows callers to offload non-raising work + to background threads. + + The pool maintains a [min_workers, max_workers] number of threads active and + dispatches the work to them. + + There's no attempt to dispatch the work fairly. + + There's no way for callers to pick an underlying thread to use for some + specific task. *) + +type t = + { mutex : Mutex.t + ; cv : Condition.t + ; tasks : (unit -> unit) Queue.t + ; spawn : (unit -> unit) -> Thread.t + ; min_workers : int + ; max_workers : int + ; (* number of threads waiting for a task *) + mutable idle : int + ; (* total number of running threads *) + mutable running : int + ; (* dead threads are collected here to [Thread.join] them. This is to + cleanup the resources of dead threads. *) + mutable dead : Thread.t list + } + +let worker_finished_and_unlock t = + t.running <- t.running - 1; + t.dead <- Thread.self () :: t.dead; + Mutex.unlock t.mutex +;; + +let run_task t task = + Mutex.unlock t.mutex; + match task () with + | () -> Mutex.lock t.mutex + | exception exn -> + Mutex.lock t.mutex; + worker_finished_and_unlock t; + Code_error.raise "thread pool tasks must not raise" [ "exn", Exn.to_dyn exn ] +;; + +let spawn_worker t = + let rec loop () = + match Queue.pop t.tasks with + | Some task -> + run_task t task; + loop () + | None -> + if t.running > t.min_workers then worker_finished_and_unlock t else wait_for_task () + and wait_for_task () = + t.idle <- t.idle + 1; + while Queue.is_empty t.tasks do + (* TODO [pthread_cond_timedwait] to set a maximum time for idling *) + Condition.wait t.cv t.mutex + done; + t.idle <- t.idle - 1; + loop () + in + t.running <- t.running + 1; + match + t.spawn (fun () -> + Mutex.lock t.mutex; + loop ()) + with + | (_ : Thread.t) -> () + | exception exn -> + t.running <- t.running - 1; + raise exn +;; + +let needs_worker t = Queue.length t.tasks > t.idle && t.running < t.max_workers + +let create ~spawn ~min_workers ~max_workers = + if min_workers < 0 || max_workers <= 0 || min_workers > max_workers + then + Code_error.raise + "Thread_pool.create got invalid worker bounds" + [ "min_workers", Dyn.int min_workers; "max_workers", Dyn.int max_workers ]; + let t = + { min_workers + ; max_workers + ; spawn + ; cv = Condition.create () + ; mutex = Mutex.create () + ; tasks = Queue.create () + ; idle = 0 + ; running = 0 + ; dead = [] + } + in + Mutex.protect t.mutex (fun () -> + for _ = 0 to min_workers - 1 do + spawn_worker t + done); + t +;; + +let task t ~f = + Mutex.protect t.mutex (fun () -> + let dead = + match t.dead with + | [] -> [] + | dead -> + t.dead <- []; + dead + in + Queue.push t.tasks f; + if needs_worker t then spawn_worker t; + Condition.signal t.cv; + dead) + |> List.iter ~f:Thread.join +;; + +module For_tests = struct + let run_task = run_task + let needs_worker = needs_worker + let set_running t running = t.running <- running + let running t = t.running + let set_idle t idle = t.idle <- idle + let dead_count t = List.length t.dead + let lock t = Mutex.lock t.mutex + let unlock t = Mutex.unlock t.mutex + let try_lock t = Mutex.try_lock t.mutex + let push_task t task = Queue.push t.tasks task +end diff --git a/otherlibs/stdune/src/thread_pool0.mli b/otherlibs/stdune/src/thread_pool0.mli new file mode 100644 index 00000000000..129be80a73e --- /dev/null +++ b/otherlibs/stdune/src/thread_pool0.mli @@ -0,0 +1,25 @@ +(** Simple thread pool *) + +(** A thread pool. *) +type t + +(** [create ~spawn ~min_workers ~max_workers] requires + [0 <= min_workers <= max_workers] and [max_workers > 0]. [spawn] is used to + start worker threads. *) +val create : spawn:((unit -> unit) -> Thread.t) -> min_workers:int -> max_workers:int -> t + +(** [task t ~f] runs [f] inside the pool. [f] must not raise. *) +val task : t -> f:(unit -> unit) -> unit + +module For_tests : sig + val run_task : t -> (unit -> unit) -> unit + val needs_worker : t -> bool + val set_running : t -> int -> unit + val running : t -> int + val set_idle : t -> int -> unit + val dead_count : t -> int + val lock : t -> unit + val unlock : t -> unit + val try_lock : t -> bool + val push_task : t -> (unit -> unit) -> unit +end diff --git a/src/dune_engine/action_exec.ml b/src/dune_engine/action_exec.ml index 6c52000ac02..0cec2027bd5 100644 --- a/src/dune_engine/action_exec.ml +++ b/src/dune_engine/action_exec.ml @@ -1,8 +1,6 @@ open Import open Stdune.Action_types open Action_intf.Exec -open Done_or_more_deps -module Dependency = Dune_action_plugin.Private.Protocol.Dependency module Exec_result = struct module Error = struct @@ -95,16 +93,13 @@ let bash_exn = let zero = Predicate_lang.element 0 -let rec exec t ~ectx ~eenv : Done_or_more_deps.t Fiber.t = +let rec exec t ~ectx ~eenv : unit Fiber.t = match (t : Action.t) with | Run { prog = Error e; args = _; can_run_in_action_runner = _ } -> Action.Prog.Not_found.raise e | Run { prog = Ok prog; args; can_run_in_action_runner } -> - let+ () = - let args = Appendable_list.to_immutable_array args in - exec_run ~ectx ~eenv ~can_run_in_action_runner prog args - in - Done + let args = Appendable_list.to_immutable_array args in + exec_run ~ectx ~eenv ~can_run_in_action_runner prog args | With_accepted_exit_codes (exit_codes, t) -> let eenv = let exit_codes = @@ -122,7 +117,7 @@ let rec exec t ~ectx ~eenv : Done_or_more_deps.t Fiber.t = | Redirect_out (Stdout, fn, perm, Echo s) -> let perm = File_perm.to_unix_perm perm in Io.write_file ~perm (Path.build fn) (String.concat s ~sep:" "); - Fiber.return Done + Fiber.return () | Redirect_out (outputs, fn, perm, t) -> let fn = Path.build fn in redirect_out t ~ectx ~eenv outputs ~perm fn @@ -130,7 +125,7 @@ let rec exec t ~ectx ~eenv : Done_or_more_deps.t Fiber.t = | Ignore (outputs, t) -> redirect_out t ~ectx ~eenv ~perm:Normal outputs Dev_null.path | Progn ts -> exec_list ts ~ectx ~eenv | Concurrent ts -> - Fiber.parallel_map ts ~f:(fun t -> + Fiber.parallel_iter ts ~f:(fun t -> let eenv = { eenv with stdout_to = Process.Io.multi_use eenv.stdout_to @@ -139,17 +134,16 @@ let rec exec t ~ectx ~eenv : Done_or_more_deps.t Fiber.t = } in exec t ~ectx ~eenv) - >>| List.fold_left ~f:Done_or_more_deps.union ~init:Done | Echo strs -> let () = String.concat strs ~sep:" " |> output_string (Process.Io.out_channel eenv.stdout_to) in - Fiber.return Done + Fiber.return () | Cat xs -> List.iter xs ~f:(fun fn -> Io.with_file_in fn ~f:(fun ic -> Io.copy_channels ic (Process.Io.out_channel eenv.stdout_to))); - Fiber.return Done + Fiber.return () | Copy (src, dst) -> let dst = Path.build dst in let copy_file ~src ~dst = @@ -176,36 +170,30 @@ let rec exec t ~ectx ~eenv : Done_or_more_deps.t Fiber.t = Tree_copy.copy ~src ~dst ~copy_file ~mkdir ~on_unsupported () | _ -> copy_file ~src ~dst in - Fiber.return Done + Fiber.return () | Symlink (src, dst) -> Io.portable_symlink ~src ~dst:(Path.build dst); - Fiber.return Done + Fiber.return () | Hardlink (src, dst) -> Io.portable_hardlink ~src ~dst:(Path.build dst); - Fiber.return Done + Fiber.return () | System command -> - let+ () = - let prog, arg = - Env_path.system_shell_exn ~needed_to:"interpret (system ...) actions" - in - exec_run - ~ectx - ~eenv - ~can_run_in_action_runner:true - prog - (Array.Immutable.of_list [ arg; command ]) + let prog, arg = + Env_path.system_shell_exn ~needed_to:"interpret (system ...) actions" in - Done + exec_run + ~ectx + ~eenv + ~can_run_in_action_runner:true + prog + (Array.Immutable.of_list [ arg; command ]) | Bash { script; can_run_in_action_runner } -> - let+ () = - exec_run - ~ectx - ~eenv - ~can_run_in_action_runner - (bash_exn ~loc:ectx.rule_loc ~needed_to:"interpret (bash ...) actions") - (Array.Immutable.of_list [ "-e"; "-u"; "-o"; "pipefail"; "-c"; script ]) - in - Done + exec_run + ~ectx + ~eenv + ~can_run_in_action_runner + (bash_exn ~loc:ectx.rule_loc ~needed_to:"interpret (bash ...) actions") + (Array.Immutable.of_list [ "-e"; "-u"; "-o"; "pipefail"; "-c"; script ]) | Write_file (fn, perm, s) -> let start = Time.now () in let fn = Path.build fn in @@ -216,24 +204,21 @@ let rec exec t ~ectx ~eenv : Done_or_more_deps.t Fiber.t = let finish = Time.now () in Dune_trace.emit ~buffered:true Action (fun () -> Dune_trace.Event.Action.write_file ~start ~finish ~file:fn ~size:(String.length s)); - Fiber.return Done + Fiber.return () | Rename (src, dst) -> let src = Path.Build.to_string src in let dst = Path.Build.to_string dst in Unix.rename src dst; - Fiber.return Done + Fiber.return () | Remove_tree path -> Path.rm_rf (Path.build path); - Fiber.return Done + Fiber.return () | Mkdir path -> Path.mkdir_p (Path.build path); - Fiber.return Done + Fiber.return () | Pipe (outputs, l) -> exec_pipe ~ectx ~eenv outputs l | Diff diff -> - let+ () = - Diff_action.exec ~sandbox:ectx.sandbox ~patch_back:None ectx.rule_loc diff - in - Done + Diff_action.exec ~sandbox:ectx.sandbox ~patch_back:None ectx.rule_loc diff | Extension (module A) -> let metadata = { ectx.metadata with can_run_in_action_runner = A.Spec.can_run_in_action_runner } @@ -266,25 +251,22 @@ and redirect t ~ectx ~eenv ?in_ ?out () = in stdout_to, stderr_to, fun () -> Process.Io.release out in - let+ result = exec t ~ectx ~eenv:{ eenv with stdin_from; stdout_to; stderr_to } in + let+ () = exec t ~ectx ~eenv:{ eenv with stdin_from; stdout_to; stderr_to } in release_in (); - release_out (); - result + release_out () -and exec_list ts ~ectx ~eenv : Done_or_more_deps.t Fiber.t = +and exec_list ts ~ectx ~eenv : unit Fiber.t = match ts with - | [] -> Fiber.return Done + | [] -> Fiber.return () | [ t ] -> exec t ~ectx ~eenv | t :: rest -> - (let stdout_to = Process.Io.multi_use eenv.stdout_to in - let stderr_to = Process.Io.multi_use eenv.stderr_to in - let stdin_from = Process.Io.multi_use eenv.stdin_from in - exec t ~ectx ~eenv:{ eenv with stdout_to; stderr_to; stdin_from }) - >>= (function - | Need_more_deps _ as need -> Fiber.return need - | Done -> exec_list rest ~ectx ~eenv) + let stdout_to = Process.Io.multi_use eenv.stdout_to in + let stderr_to = Process.Io.multi_use eenv.stderr_to in + let stdin_from = Process.Io.multi_use eenv.stdin_from in + let* () = exec t ~ectx ~eenv:{ eenv with stdout_to; stderr_to; stdin_from } in + exec_list rest ~ectx ~eenv -and exec_pipe outputs ts ~ectx ~eenv : Done_or_more_deps.t Fiber.t = +and exec_pipe outputs ts ~ectx ~eenv : unit Fiber.t = let tmp_file () = Dtemp.file ~prefix:"dune-pipe-action-" ~suffix:("." ^ Outputs.to_string outputs) in @@ -292,26 +274,19 @@ and exec_pipe outputs ts ~ectx ~eenv : Done_or_more_deps.t Fiber.t = match ts with | [] -> assert false | [ last_t ] -> - let+ result = - let eenv = - match outputs with - | Stderr -> { eenv with stdout_to = Process.Io.multi_use eenv.stderr_to } - | _ -> eenv - in - redirect_in last_t ~ectx ~eenv Stdin in_ + let eenv = + match outputs with + | Stderr -> { eenv with stdout_to = Process.Io.multi_use eenv.stderr_to } + | _ -> eenv in - Dtemp.destroy File in_; - result + let+ () = redirect_in last_t ~ectx ~eenv Stdin in_ in + Dtemp.destroy File in_ | t :: ts -> let out = tmp_file () in - let* done_or_deps = - let eenv = { eenv with stderr_to = Process.Io.multi_use eenv.stderr_to } in - redirect t ~ectx ~eenv ~in_:(Stdin, in_) ~out:(Stdout, out, Normal) () - in + let eenv = { eenv with stderr_to = Process.Io.multi_use eenv.stderr_to } in + let* () = redirect t ~ectx ~eenv ~in_:(Stdin, in_) ~out:(Stdout, out, Normal) () in Dtemp.destroy File in_; - (match done_or_deps with - | Need_more_deps _ as need -> Fiber.return need - | Done -> loop ~in_:out ts) + loop ~in_:out ts in match ts with | [] -> assert false @@ -323,32 +298,8 @@ and exec_pipe outputs ts ~ectx ~eenv : Done_or_more_deps.t Fiber.t = | Stdout -> { eenv with stderr_to = Process.Io.multi_use eenv.stderr_to } | Stderr -> { eenv with stdout_to = Process.Io.multi_use eenv.stdout_to } in - redirect_out t1 ~ectx ~eenv ~perm:Normal outputs out - >>= (function - | Need_more_deps _ as need -> Fiber.return need - | Done -> loop ~in_:out ts) -;; - -let exec_until_all_deps_ready ~ectx ~eenv t = - let rec loop ~eenv stages = - let* result = exec ~ectx ~eenv t in - match result with - | Done -> Fiber.return stages - | Need_more_deps (relative_deps, deps_to_build) -> - let* stages = - let+ fact_map = ectx.build_deps deps_to_build in - (deps_to_build, fact_map) :: stages - in - let eenv = - { eenv with - prepared_dependencies = - Dependency.Set.union eenv.prepared_dependencies relative_deps - } - in - loop ~eenv stages - in - let+ stages = loop ~eenv [] in - { Exec_result.dynamic_deps_stages = List.rev stages } + let* () = redirect_out t1 ~ectx ~eenv ~perm:Normal outputs out in + loop ~in_:out ts ;; type input = @@ -366,11 +317,15 @@ let exec { targets; root; context; env; rule_loc; execution_parameters; sandbox; action = t } ~build_deps = + let dynamic_deps_stages = ref [] in let ectx = let metadata = Process_metadata.create ~purpose:(Process_metadata.Build_job targets) () in - { targets; metadata; context; sandbox; rule_loc; build_deps } + let record_dynamic_deps deps facts = + dynamic_deps_stages := (deps, facts) :: !dynamic_deps_stages + in + { targets; metadata; context; sandbox; rule_loc; build_deps; record_dynamic_deps } and eenv = let env = match @@ -408,14 +363,13 @@ let exec (Execution_parameters.action_stderr_on_success execution_parameters) ~output_limit:(Execution_parameters.action_stderr_limit execution_parameters) ; stdin_from = Process.Io.null In - ; prepared_dependencies = Dependency.Set.empty ; exit_codes = Predicate.create (Int.equal 0) } in let open Fiber.O in - Fiber.collect_errors (fun () -> exec_until_all_deps_ready t ~ectx ~eenv) + Fiber.collect_errors (fun () -> exec t ~ectx ~eenv) >>| function - | Ok res -> Ok res + | Ok () -> Ok { Exec_result.dynamic_deps_stages = List.rev !dynamic_deps_stages } | Error exns -> Error (List.map exns ~f:(fun (e : Exn_with_backtrace.t) -> Exec_result.Error.of_exn e.exn)) diff --git a/src/dune_engine/action_ext.ml b/src/dune_engine/action_ext.ml index 47e1fdb34bb..d7f5791302e 100644 --- a/src/dune_engine/action_ext.ml +++ b/src/dune_engine/action_ext.ml @@ -36,8 +36,7 @@ struct Dune_trace.Event.Action.start ~name ~start); let+ () = action a ~ectx ~eenv in Dune_trace.emit ~buffered:true Action (fun () -> - Dune_trace.Event.Action.finish ~name ~start); - Done_or_more_deps.Done + Dune_trace.Event.Action.finish ~name ~start) ;; end diff --git a/src/dune_engine/action_intf.ml b/src/dune_engine/action_intf.ml index 3544a8c337a..a8f6d32124c 100644 --- a/src/dune_engine/action_intf.ml +++ b/src/dune_engine/action_intf.ml @@ -112,6 +112,7 @@ module Exec = struct ; sandbox : Process.Sandbox.t option ; rule_loc : Loc.t ; build_deps : Dep.Set.t -> Dep.Facts.t Fiber.t + ; record_dynamic_deps : Dep.Set.t -> Dep.Facts.t -> unit } type env = @@ -120,7 +121,6 @@ module Exec = struct ; stdout_to : Process.Io.output Process.Io.t ; stderr_to : Process.Io.output Process.Io.t ; stdin_from : Process.Io.input Process.Io.t - ; prepared_dependencies : Dune_action_plugin.Private.Protocol.Dependency.Set.t ; exit_codes : int Predicate.t } end @@ -144,11 +144,7 @@ module Ext = struct : (Path.t, Path.Build.t) t -> ectx:Exec.context -> eenv:Exec.env - -> (* cwong: For now, I think we should only worry about extensions with - known dependencies. In the future, we may generalize this to return - an [Action_exec.done_or_more_deps], but that may be trickier to get - right, and is a bridge we can cross when we get there. *) - Done_or_more_deps.t Fiber.t + -> unit Fiber.t end module type Instance = sig diff --git a/src/dune_engine/action_plugin.ml b/src/dune_engine/action_plugin.ml index 4426ecccbf0..535e1d190db 100644 --- a/src/dune_engine/action_plugin.ml +++ b/src/dune_engine/action_plugin.ml @@ -22,97 +22,180 @@ let to_dune_dep_set = Dependency.Set.to_list_map set ~f:(of_DAP_dep ~loc ~working_dir) |> Dep.Set.of_list ;; -let exec ~(ectx : context) ~(eenv : env) prog args = - let open Fiber.O in - let run_arguments_fn = Dtemp.action File ~prefix:"dune" ~suffix:"run" in - let response_fn = Dtemp.action File ~prefix:"dune" ~suffix:"response" in - let run_arguments = - let targets = - match ectx.targets with - | None -> String.Set.empty - | Some targets -> - if not (Filename.Set.is_empty targets.dirs) - then - User_error.raise - ~loc:ectx.rule_loc - [ Pp.text "Directory targets are not compatible with dynamic actions" ]; - Filename.Set.to_list_map targets.files ~f:(fun target -> - Path.Build.relative_fname targets.root target - |> Path.build - |> Path.reach ~from:eenv.working_dir) - |> String.Set.of_list +module Server = struct + module Rpc = DAP.Rpc + module Handler = Root.Rpc.Server.Handler + module Session = Root.Rpc.Server.Session + + type active = + { run_arguments : DAP.Run_arguments.t + ; build_deps : Dep.Set.t -> Dep.Facts.t Fiber.t + ; record_dynamic_deps : Dep.Set.t -> Dep.Facts.t -> unit + ; rule_loc : Loc.t + ; working_dir : Path.t + ; mutable session_id : Session.Id.t option + } + + let active = Table.create (module String) 16 + let prng = lazy (Random.State.make_self_init ()) + + let rec fresh_id () = + let state = Lazy.force prng in + let id = + Printf.sprintf + "%08x%08x%08x%08x" + (Random.State.bits state) + (Random.State.bits state) + (Random.State.bits state) + (Random.State.bits state) in - { DAP.Run_arguments.prepared_dependencies = eenv.prepared_dependencies; targets } - in - DAP.Run_arguments.to_sexp run_arguments - |> Csexp.to_string - |> Io.write_file run_arguments_fn; - let env = - let value = - DAP.Greeting.( - to_sexp - { run_arguments_fn = Path.to_absolute_filename run_arguments_fn - ; response_fn = Path.to_absolute_filename response_fn - }) - |> Csexp.to_string + if Table.mem active id then fresh_id () else id + ;; + + let invalid_request message = + raise + (Dune_rpc.Response.Error.E + (Dune_rpc.Response.Error.create + ~kind:Dune_rpc.Response.Error.Invalid_request + ~message + ())) + ;; + + let find_active action_id = + match Table.find active action_id with + | Some active -> active + | None -> invalid_request (Printf.sprintf "unknown dynamic action %S" action_id) + ;; + + let with_active ~run_arguments ~(ectx : context) ~(eenv : env) f = + let action_id = fresh_id () in + let active_action = + { run_arguments + ; build_deps = ectx.build_deps + ; record_dynamic_deps = ectx.record_dynamic_deps + ; rule_loc = ectx.rule_loc + ; working_dir = eenv.working_dir + ; session_id = None + } in - Env.add eenv.env ~var:(Env.Var.of_string DAP.run_by_dune_env_variable) ~value - in - let+ () = - Process.run - ~display:!Clflags.display - Strict - ~dir:eenv.working_dir - ~env - ~stderr_to:eenv.stderr_to - ~stdin_from:eenv.stdin_from - ~metadata:ectx.metadata - ?sandbox:ectx.sandbox - prog - args - in - let response_raw = Io.read_file response_fn in - Temp.destroy File run_arguments_fn; - Temp.destroy File response_fn; - let response = - match Csexp.parse_string response_raw with - | Ok s -> DAP.Response.of_sexp s - | Error _ -> Error DAP.Error.Parse_error + Table.add_exn active action_id active_action; + Fiber.finalize + (fun () -> f action_id active_action) + ~finally:(fun () -> + Table.remove active action_id; + Fiber.return ()) + ;; + + let initialize session action_id = + let active = find_active action_id in + match active.session_id with + | Some _ -> invalid_request "dynamic action is already initialized" + | None -> + active.session_id <- Some (Session.id session); + Fiber.return active.run_arguments + ;; + + let rec exception_message = function + | User_error.E message -> User_message.to_string message + | Memo.Error.E error -> exception_message (Memo.Error.get error) + | Memo.Cycle_error.E _ as exn -> + Dune_util.Report_error.message_of_exception exn |> User_message.to_string + | exn -> Printexc.to_string exn + ;; + + let build_error_message = function + | [] -> "dependency build failed" + | { Exn_with_backtrace.exn; _ } :: _ -> exception_message exn + ;; + + let build_deps session { Rpc.Build_deps.action_id; deps } = + let active = find_active action_id in + (match active.session_id with + | None -> invalid_request "dynamic action is not initialized" + | Some session_id -> + if not (Session.Id.equal session_id (Session.id session)) + then invalid_request "dynamic action belongs to another RPC session"); + let deps_to_build = + to_dune_dep_set deps ~loc:active.rule_loc ~working_dir:active.working_dir + in + let open Fiber.O in + let+ result = Fiber.collect_errors (fun () -> active.build_deps deps_to_build) in + match result with + | Ok facts -> + active.record_dynamic_deps deps_to_build facts; + None + | Error errors -> Some (build_error_message errors) + ;; + + let implement_handler handler = + Handler.implement_request handler Rpc.initialize initialize; + Handler.implement_request handler Rpc.build_deps build_deps + ;; +end + +let run_arguments ~(ectx : context) ~(eenv : env) = + let targets = + match ectx.targets with + | None -> String.Set.empty + | Some targets -> + if not (Filename.Set.is_empty targets.dirs) + then + User_error.raise + ~loc:ectx.rule_loc + [ Pp.text "Directory targets are not compatible with dynamic actions" ]; + Filename.Set.to_list_map targets.files ~f:(fun target -> + Path.Build.relative_fname targets.root target + |> Path.build + |> Path.reach ~from:eenv.working_dir) + |> String.Set.of_list in + { DAP.Run_arguments.targets } +;; + +let exec ~(ectx : context) ~(eenv : env) prog args = + let open Fiber.O in + let run_arguments = run_arguments ~ectx ~eenv in let prog_name = Path.reach ~from:eenv.working_dir prog in - match response with - | Error _ when String.is_empty response_raw -> - User_error.raise - ~loc:ectx.rule_loc - [ Pp.textf - "Executable '%s' declared as using dune-action-plugin (declared with \ - 'dynamic-run' tag) failed to respond to dune." - prog_name - ; Pp.nop - ; Pp.text - "If you don't use dynamic dependency discovery in your executable you may \ - consider changing 'dynamic-run' to 'run' in your rule definition." - ] - | Error Parse_error -> - User_error.raise - ~loc:ectx.rule_loc - [ Pp.textf - "Executable '%s' declared as using dune-action-plugin (declared with \ - 'dynamic-run' tag) responded with invalid message." - prog_name - ] - | Error (Version_mismatch _) -> - User_error.raise - ~loc:ectx.rule_loc - [ Pp.textf - "Executable '%s' is linked against a version of dune-action-plugin library \ - that is incompatible with this version of dune." - prog_name - ] - | Ok Done -> Done_or_more_deps.Done - | Ok (Need_more_deps deps) -> - Need_more_deps - (deps, to_dune_dep_set deps ~loc:ectx.rule_loc ~working_dir:eenv.working_dir) + Server.with_active ~run_arguments ~ectx ~eenv (fun action_id active_action -> + let env = + let where = + match Root.Rpc.Where.default () with + | `Unix _ -> + `Unix + (Path.reach + (Path.build (Root.Rpc.Where.rpc_socket_file ())) + ~from:eenv.working_dir) + | where -> where + in + Dune_rpc.Where.add_to_env where eenv.env + |> Env.add ~var:DAP.Rpc.action_id_env_variable ~value:action_id + in + let+ () = + Process.run + ~display:!Clflags.display + Strict + ~dir:eenv.working_dir + ~env + ~stderr_to:eenv.stderr_to + ~stdin_from:eenv.stdin_from + ~metadata:ectx.metadata + prog + args + in + if Option.is_none active_action.session_id + then + User_error.raise + ~loc:ectx.rule_loc + [ Pp.textf + "Executable '%s' declared as using dune-action-plugin (declared with \ + 'dynamic-run' tag) failed to respond to dune." + prog_name + ; Pp.nop + ; Pp.text + "If you don't use dynamic dependency discovery in your executable you may \ + consider changing 'dynamic-run' to 'run' in your rule definition." + ]; + ()) ;; module Spec = struct diff --git a/src/dune_engine/action_plugin.mli b/src/dune_engine/action_plugin.mli index 9e4691903f9..c9d9af9f523 100644 --- a/src/dune_engine/action_plugin.mli +++ b/src/dune_engine/action_plugin.mli @@ -1 +1,5 @@ +module Server : sig + val implement_handler : 'a Root.Rpc.Server.Handler.t -> unit +end + val action : prog:Action.Prog.t -> args:string list -> Action.t diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 335bb8f124b..8b420835110 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -496,7 +496,10 @@ module Internal = struct ; action } in - let build_deps deps = Memo.run (build_deps deps) in + let* memo_context = Memo.Cycle_detection_context.current () in + let build_deps deps = + Memo.Cycle_detection_context.run memo_context (build_deps deps) + in Action_exec.exec input ~build_deps in let* action_exec_result, () = diff --git a/src/dune_engine/done_or_more_deps.ml b/src/dune_engine/done_or_more_deps.ml deleted file mode 100644 index 67a1b496b12..00000000000 --- a/src/dune_engine/done_or_more_deps.ml +++ /dev/null @@ -1,13 +0,0 @@ -module Dependency = Dune_action_plugin.Private.Protocol.Dependency - -type t = - | Done - | Need_more_deps of (Dependency.Set.t * Dep.Set.t) - -let union (x : t) (y : t) = - match x, y with - | Done, Done -> Done - | Done, Need_more_deps x | Need_more_deps x, Done -> Need_more_deps x - | Need_more_deps (deps1, dyn_deps1), Need_more_deps (deps2, dyn_deps2) -> - Need_more_deps (Dependency.Set.union deps1 deps2, Dep.Set.union dyn_deps1 dyn_deps2) -;; diff --git a/src/dune_engine/done_or_more_deps.mli b/src/dune_engine/done_or_more_deps.mli deleted file mode 100644 index 67e594c0bd9..00000000000 --- a/src/dune_engine/done_or_more_deps.mli +++ /dev/null @@ -1,11 +0,0 @@ -module Dependency := Dune_action_plugin.Private.Protocol.Dependency - -type t = - | Done - (* This code assumes that there can be at most one 'dynamic-run' within single - action. [DAP.Dependency.t] stores relative paths so name clash would be - possible if multiple 'dynamic-run' would be executed in different - subdirectories that contains targets having the same name. *) - | Need_more_deps of (Dependency.Set.t * Dep.Set.t) - -val union : t -> t -> t diff --git a/src/dune_engine/dune_engine.ml b/src/dune_engine/dune_engine.ml index fea90cf0597..ff5fea630b1 100644 --- a/src/dune_engine/dune_engine.ml +++ b/src/dune_engine/dune_engine.ml @@ -5,7 +5,6 @@ module Dep = Dep module Action = Action module Action_ext = Action_ext module Action_plugin = Action_plugin -module Done_or_more_deps = Done_or_more_deps module Utils = Utils module Dir_set = Dir_set module Subdir_set = Subdir_set diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index 912a3fc638d..f318a7c714d 100644 --- a/src/dune_rpc_impl/server.ml +++ b/src/dune_rpc_impl/server.ml @@ -15,6 +15,7 @@ include struct module Action_builder = Action_builder module Build_loop = Build_loop module Diff_promotion = Diff_promotion + module Action_plugin = Action_plugin module Action_runner = Action_runner end @@ -412,6 +413,7 @@ let handler (t : t Fdecl.t) : unit Handler.t = let f _ () = Fiber.return Path.Build.(to_string root) in Handler.implement_request rpc Procedures.Public.build_dir f in + Action_plugin.Server.implement_handler rpc; Dune_rules_rpc.register rpc; rpc ;; diff --git a/src/dune_scheduler/thread_pool.ml b/src/dune_scheduler/thread_pool.ml index e6540d5eeda..b045c10f15f 100644 --- a/src/dune_scheduler/thread_pool.ml +++ b/src/dune_scheduler/thread_pool.ml @@ -1,129 +1,32 @@ open Stdune -(** The thread pool implementation allows callers to offload (non raising) work - to background threads. +(** The scheduler thread pool uses [Thread0.spawn] so that worker threads inherit + Dune's signal masking and trace/error-reporting behavior. *) - The pool maintains a [min_workers, max_workers] number of threads active and - dispatches the work to them. - - There's no attempt to dispatch the work fairly. - - There's no ways to for callers to pick an underlying thread to use for some - specific task. *) - -type t = - { mutex : Mutex.t - ; cv : Condition.t - ; tasks : (unit -> unit) Queue.t - ; min_workers : int - ; max_workers : int - ; (* number of threads waiting for a task *) - mutable idle : int - ; (* total number of running threads *) - mutable running : int - ; (* dead threads are collected here to [Thread.join] them. This is to - cleanup the resources of dead threads. *) - mutable dead : Thread.t list - } - -let worker_finished_and_unlock t = - t.running <- t.running - 1; - t.dead <- Thread.self () :: t.dead; - Mutex.unlock t.mutex -;; - -let run_task t task = - Mutex.unlock t.mutex; - match task () with - | () -> Mutex.lock t.mutex - | exception exn -> - Mutex.lock t.mutex; - worker_finished_and_unlock t; - Code_error.raise "thread pool tasks must not raise" [ "exn", Exn.to_dyn exn ] -;; - -let spawn_worker t = - let rec loop () = - match Queue.pop t.tasks with - | Some task -> - run_task t task; - loop () - | None -> - if t.running > t.min_workers then worker_finished_and_unlock t else wait_for_task () - and wait_for_task () = - t.idle <- t.idle + 1; - while Queue.is_empty t.tasks do - (* TODO [pthread_cond_timedwait] to set a maximum time for idling *) - Condition.wait t.cv t.mutex - done; - t.idle <- t.idle - 1; - loop () - in - t.running <- t.running + 1; - match - Thread0.spawn ~name:"thread-pool" (fun () -> - Mutex.lock t.mutex; - loop ()) - with - | (_ : Thread.t) -> () - | exception exn -> - t.running <- t.running - 1; - raise exn -;; - -let needs_worker t = Queue.length t.tasks > t.idle && t.running < t.max_workers +type t = Stdune.Thread_pool0.t let create ~min_workers ~max_workers = - if min_workers < 0 || max_workers <= 0 || min_workers > max_workers - then - Code_error.raise - "Thread_pool.create got invalid worker bounds" - [ "min_workers", Dyn.int min_workers; "max_workers", Dyn.int max_workers ]; - let t = - { min_workers - ; max_workers - ; cv = Condition.create () - ; mutex = Mutex.create () - ; tasks = Queue.create () - ; idle = 0 - ; running = 0 - ; dead = [] - } - in - Mutex.protect t.mutex (fun () -> - for _ = 0 to min_workers - 1 do - spawn_worker t - done); - t + Stdune.Thread_pool0.create + ~spawn:(fun f -> Thread0.spawn ~name:"thread-pool" f) + ~min_workers + ~max_workers ;; -let task t ~f = - Mutex.protect t.mutex (fun () -> - let dead = - match t.dead with - | [] -> [] - | dead -> - t.dead <- []; - dead - in - Queue.push t.tasks f; - if needs_worker t then spawn_worker t; - Condition.signal t.cv; - dead) - |> List.iter ~f:Thread.join -;; +let task = Stdune.Thread_pool0.task +let test_spawn f = Thread.create f () let%expect_test "failed task updates worker accounting" = - let t = create ~min_workers:0 ~max_workers:1 in - t.running <- 1; - Mutex.lock t.mutex; + let open Stdune.Thread_pool0.For_tests in + let t = Stdune.Thread_pool0.create ~spawn:test_spawn ~min_workers:0 ~max_workers:1 in + set_running t 1; + lock t; (match run_task t (fun () -> raise Exit) with | () -> Code_error.raise "run_task unexpectedly returned" [] | exception Code_error.E _ -> ()); - Printf.printf "running: %d\n" t.running; - Printf.printf "dead: %d\n" (List.length t.dead); - Printf.printf "mutex unlocked: %b\n" (Mutex.try_lock t.mutex); - Mutex.unlock t.mutex; + Printf.printf "running: %d\n" (running t); + Printf.printf "dead: %d\n" (dead_count t); + Printf.printf "mutex unlocked: %b\n" (try_lock t); + unlock t; [%expect {| running: 0 @@ -132,12 +35,13 @@ let%expect_test "failed task updates worker accounting" = ;; let%expect_test "queued work beyond idle capacity needs a worker" = - let t = create ~min_workers:0 ~max_workers:2 in - t.idle <- 1; - t.running <- 1; - Queue.push t.tasks (fun () -> ()); + let open Stdune.Thread_pool0.For_tests in + let t = Stdune.Thread_pool0.create ~spawn:test_spawn ~min_workers:0 ~max_workers:2 in + set_idle t 1; + set_running t 1; + push_task t (fun () -> ()); Printf.printf "one task: %b\n" (needs_worker t); - Queue.push t.tasks (fun () -> ()); + push_task t (fun () -> ()); Printf.printf "two tasks: %b\n" (needs_worker t); [%expect {| diff --git a/src/dune_util/report_error.ml b/src/dune_util/report_error.ml index b239266c2f3..35735700499 100644 --- a/src/dune_util/report_error.ml +++ b/src/dune_util/report_error.ml @@ -112,6 +112,8 @@ let get_error_from_exn = function } ;; +let message_of_exception exn = (get_error_from_exn exn).msg + let i_must_not_crash = let reported = ref false in fun () -> diff --git a/src/dune_util/report_error.mli b/src/dune_util/report_error.mli index dbee4531a3e..dcd6fd0f56d 100644 --- a/src/dune_util/report_error.mli +++ b/src/dune_util/report_error.mli @@ -13,6 +13,7 @@ val report : Exn_with_backtrace.t -> unit val report_exception : exn -> unit val report_backtraces : bool -> unit +val message_of_exception : exn -> User_message.t (** Raised for errors that have already been reported to the user and shouldn't be reported again. This might happen when trying to build a dependency that diff --git a/src/memo/memo.ml b/src/memo/memo.ml index d6e49c8ff89..58603b4f971 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -249,6 +249,23 @@ let run t = | false -> t ;; +module Cycle_detection_context = struct + type t = Call_stack.t + + let current = Call_stack.get_call_stack + + let run context memo = + Fiber.Var.set_apply + Call_stack.call_stack_var + context + (fun memo -> + run_with_error_handler + (fun () -> memo) + ~handle_error_no_raise:(fun _exn -> Fiber.return ())) + memo + ;; +end + module With_implicit_output = struct type ('i, 'o) t = 'i -> 'o Fiber.t diff --git a/src/memo/memo.mli b/src/memo/memo.mli index 27f860e6e40..b7a5b7189b7 100644 --- a/src/memo/memo.mli +++ b/src/memo/memo.mli @@ -38,6 +38,18 @@ end (* CR-someday amokhov: Return the set of exceptions explicitly. *) val run : 'a t -> 'a Fiber.t +module Cycle_detection_context : sig + (** The cycle-detection context of a running memoized computation. *) + type t + + val current : unit -> t Fiber.t + + (** Run a memoized computation from another fiber while preserving the call + stack of the captured context. The context may only be used during the + memoization run in which it was captured. *) + val run : t -> 'a memo -> 'a Fiber.t +end + (** Every error gets reported twice: once early, in non-deterministic order, by calling [handler_error], and once later, in deterministic order, by raising a fiber exception. diff --git a/test/expect-tests/dune_rpc/digests.ml b/test/expect-tests/dune_rpc/digests.ml index 8db2127890a..8b71abf49b2 100644 --- a/test/expect-tests/dune_rpc/digests.ml +++ b/test/expect-tests/dune_rpc/digests.ml @@ -139,6 +139,14 @@ let%expect_test "print digests for all declared RPCs" = Version 1: Request: (List String) Response: 9b023f3c0fa25b79499054bca94d5498 + dap/initialize + Version 1: + Request: String + Response: (Iso (Iso (List String))) + dap/build-deps + Version 1: + Request: 042dc00d68ff9ee66979e82fefde258a + Response: (Sum (None Unit) (Some String)) notify/abort Version 1: Payload: 0e9dfd1099101769896cf0bb06f891c6