216 lines
8.6 KiB
OCaml
216 lines
8.6 KiB
OCaml
|
open Import
|
||
|
|
|
||
|
|
let with_metrics ~common f =
|
||
|
|
let start_time = Unix.gettimeofday () in
|
||
|
|
Fiber.finalize f ~finally:(fun () ->
|
||
|
|
let duration = Unix.gettimeofday () -. start_time in
|
||
|
|
if Common.print_metrics common
|
||
|
|
then (
|
||
|
|
let gc_stat = Gc.quick_stat () in
|
||
|
|
(* We reset Memo counters below, unconditionally. *)
|
||
|
|
let memo_counters_report = Memo.Metrics.report ~reset_after_reporting:false in
|
||
|
|
Console.print_user_message
|
||
|
|
(User_message.make
|
||
|
|
([ Pp.textf "%s" memo_counters_report
|
||
|
|
; Pp.textf
|
||
|
|
"(%.2fs total, %.1fM heap words)"
|
||
|
|
duration
|
||
|
|
(float_of_int gc_stat.heap_words /. 1_000_000.)
|
||
|
|
; Pp.text "Timers:"
|
||
|
|
]
|
||
|
|
@ List.map
|
||
|
|
~f:(fun (timer, { Metrics.Timer.Measure.cumulative_time; count }) ->
|
||
|
|
Pp.textf
|
||
|
|
"%s - time spent = %.2fs, count = %d"
|
||
|
|
timer
|
||
|
|
cumulative_time
|
||
|
|
count)
|
||
|
|
(String.Map.to_list (Metrics.Timer.aggregated_timers ())))));
|
||
|
|
Memo.Metrics.reset ();
|
||
|
|
Fiber.return ())
|
||
|
|
;;
|
||
|
|
|
||
|
|
let run_build_system ~common ~request =
|
||
|
|
let run ~(toplevel : unit Memo.Lazy.t) =
|
||
|
|
with_metrics ~common (fun () -> build (fun () -> Memo.Lazy.force toplevel))
|
||
|
|
in
|
||
|
|
let open Fiber.O in
|
||
|
|
Fiber.finalize
|
||
|
|
(fun () ->
|
||
|
|
(* CR-someday amokhov: Currently we invalidate cached timestamps on every
|
||
|
|
incremental rebuild. This conservative approach helps us to work around
|
||
|
|
some [mtime] resolution problems (e.g. on Mac OS). It would be nice to
|
||
|
|
find a way to avoid doing this. In fact, this may be unnecessary even
|
||
|
|
for the initial build if we assume that the user does not modify files
|
||
|
|
in the [_build] directory. For now, it's unclear if optimising this is
|
||
|
|
worth the effort. *)
|
||
|
|
Cached_digest.invalidate_cached_timestamps ();
|
||
|
|
let* setup = Import.Main.setup () in
|
||
|
|
let request =
|
||
|
|
Action_builder.bind (Action_builder.of_memo setup) ~f:(fun setup ->
|
||
|
|
request setup)
|
||
|
|
in
|
||
|
|
(* CR-someday cmoseley: Can we avoid creating a new lazy memo node every
|
||
|
|
time the build system is rerun? *)
|
||
|
|
(* This top-level node is used for traversing the whole Memo graph. *)
|
||
|
|
let toplevel_cell, toplevel =
|
||
|
|
Memo.Lazy.Expert.create ~name:"toplevel" (fun () ->
|
||
|
|
let open Memo.O in
|
||
|
|
let+ (), (_ : Dep.Fact.t Dep.Map.t) =
|
||
|
|
Action_builder.evaluate_and_collect_facts request
|
||
|
|
in
|
||
|
|
())
|
||
|
|
in
|
||
|
|
let* res = run ~toplevel in
|
||
|
|
let+ () =
|
||
|
|
match Common.dump_memo_graph_file common with
|
||
|
|
| None -> Fiber.return ()
|
||
|
|
| Some file ->
|
||
|
|
let path = Path.external_ file in
|
||
|
|
let+ graph =
|
||
|
|
Memo.dump_cached_graph
|
||
|
|
~time_nodes:(Common.dump_memo_graph_with_timing common)
|
||
|
|
toplevel_cell
|
||
|
|
in
|
||
|
|
Graph.serialize graph ~path ~format:(Common.dump_memo_graph_format common)
|
||
|
|
(* CR-someday cmoseley: It would be nice to use Persistent to dump a
|
||
|
|
copy of the graph's internal representation here, so it could be used
|
||
|
|
without needing to re-run the build*)
|
||
|
|
in
|
||
|
|
res)
|
||
|
|
~finally:(fun () ->
|
||
|
|
Hooks.End_of_build.run ();
|
||
|
|
Fiber.return ())
|
||
|
|
;;
|
||
|
|
|
||
|
|
let poll_handling_rpc_build_requests ~(common : Common.t) ~config =
|
||
|
|
let open Fiber.O in
|
||
|
|
let rpc =
|
||
|
|
match Common.rpc common with
|
||
|
|
| `Allow server -> server
|
||
|
|
| `Forbid_builds -> Code_error.raise "rpc server must be allowed in passive mode" []
|
||
|
|
in
|
||
|
|
Scheduler.Run.poll_passive
|
||
|
|
~get_build_request:
|
||
|
|
(let+ (Build (targets, ivar)) = Dune_rpc_impl.Server.pending_build_action rpc in
|
||
|
|
let request setup =
|
||
|
|
Target.interpret_targets (Common.root common) config setup targets
|
||
|
|
in
|
||
|
|
run_build_system ~common ~request, ivar)
|
||
|
|
;;
|
||
|
|
|
||
|
|
let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit =
|
||
|
|
Scheduler.go_with_rpc_server_and_console_status_reporting ~common ~config (fun () ->
|
||
|
|
let open Fiber.O in
|
||
|
|
(* Run two fibers concurrently. One is responible for rebuilding targets
|
||
|
|
named on the command line in reaction to file system changes. The other
|
||
|
|
is responsible for building targets named in RPC build requests. *)
|
||
|
|
let+ () = Scheduler.Run.poll (run_build_system ~common ~request)
|
||
|
|
and+ () = poll_handling_rpc_build_requests ~common ~config in
|
||
|
|
())
|
||
|
|
;;
|
||
|
|
|
||
|
|
let run_build_command_poll_passive ~common ~config ~request:_ : unit =
|
||
|
|
(* CR-someday aalekseyev: It would've been better to complain if [request] is
|
||
|
|
non-empty, but we can't check that here because [request] is a function.*)
|
||
|
|
Scheduler.go_with_rpc_server_and_console_status_reporting ~common ~config (fun () ->
|
||
|
|
poll_handling_rpc_build_requests ~common ~config)
|
||
|
|
;;
|
||
|
|
|
||
|
|
let run_build_command_once ~(common : Common.t) ~config ~request =
|
||
|
|
let open Fiber.O in
|
||
|
|
let once () =
|
||
|
|
let+ res = run_build_system ~common ~request in
|
||
|
|
match res with
|
||
|
|
| Error `Already_reported -> raise Dune_util.Report_error.Already_reported
|
||
|
|
| Ok () -> ()
|
||
|
|
in
|
||
|
|
Scheduler.go_with_rpc_server ~common ~config once
|
||
|
|
;;
|
||
|
|
|
||
|
|
let run_build_command ~(common : Common.t) ~config ~request =
|
||
|
|
(match Common.watch common with
|
||
|
|
| Yes Eager -> run_build_command_poll_eager
|
||
|
|
| Yes Passive -> run_build_command_poll_passive
|
||
|
|
| No -> run_build_command_once)
|
||
|
|
~common
|
||
|
|
~config
|
||
|
|
~request
|
||
|
|
;;
|
||
|
|
|
||
|
|
let build_via_rpc_server ~print_on_success ~targets =
|
||
|
|
Rpc_common.wrap_build_outcome_exn
|
||
|
|
~print_on_success
|
||
|
|
(Rpc.Build.build ~wait:true)
|
||
|
|
targets
|
||
|
|
()
|
||
|
|
;;
|
||
|
|
|
||
|
|
let build =
|
||
|
|
let doc = "Build the given targets, or the default ones if none are given." in
|
||
|
|
let man =
|
||
|
|
[ `S "DESCRIPTION"
|
||
|
|
; `P {|Targets starting with a $(b,@) are interpreted as aliases.|}
|
||
|
|
; `Blocks Common.help_secs
|
||
|
|
; Common.examples
|
||
|
|
[ "Build all targets in the current source tree", "dune build"
|
||
|
|
; "Build targets in the `./foo/bar' directory", "dune build ./foo/bar"
|
||
|
|
; ( "Build the minimal set of targets required for tooling such as Merlin \
|
||
|
|
(useful for quickly detecting errors)"
|
||
|
|
, "dune build @check" )
|
||
|
|
; "Run all code formatting tools in-place", "dune build --auto-promote @fmt"
|
||
|
|
]
|
||
|
|
]
|
||
|
|
in
|
||
|
|
let name_ = Arg.info [] ~docv:"TARGET" in
|
||
|
|
let term =
|
||
|
|
let+ builder = Common.Builder.term
|
||
|
|
and+ targets = Arg.(value & pos_all dep [] name_)
|
||
|
|
and+ aliases_rec = Arg.(value & opt_all Dep.alias_rec_arg [] & info [ "alias-rec" ])
|
||
|
|
and+ aliases = Arg.(value & opt_all Dep.alias_arg [] & info [ "alias" ]) in
|
||
|
|
let targets = List.concat [ targets; aliases; aliases_rec ] in
|
||
|
|
let targets =
|
||
|
|
match targets with
|
||
|
|
| [] -> [ Common.Builder.default_target builder ]
|
||
|
|
| _ :: _ -> targets
|
||
|
|
in
|
||
|
|
let common, config = Common.init builder in
|
||
|
|
(* Here we need to find out whether another instance of dune already holds
|
||
|
|
the global build lock, as this will determine whether the current
|
||
|
|
instance of dune will perform the build itself or send a build request
|
||
|
|
to the RPC server in an already-running dune process. The method of
|
||
|
|
checking whether another dune instance holds the lock is to simply try
|
||
|
|
to take the lock. If taking the lock succeeds then the current process
|
||
|
|
will perform the build itself, and future attempts by this process to
|
||
|
|
take the lock are guaranteed to succeed. If taking the lock fails then
|
||
|
|
we know that another instance of dune must have it, and the current
|
||
|
|
process will send a build RPC request to that dune instance. Checking
|
||
|
|
the status of the lock by taking prevents a race condition where the
|
||
|
|
state of the lock could otherwise change between checking it and taking
|
||
|
|
it. *)
|
||
|
|
match Dune_util.Global_lock.lock ~timeout:None with
|
||
|
|
| Error lock_held_by ->
|
||
|
|
(* This case is reached if dune detects that another instance of dune
|
||
|
|
is already running. Rather than performing the build itself, the
|
||
|
|
current instance of dune will instruct the already-running instance to
|
||
|
|
perform the build by sending an RPC message. As only one RPC server
|
||
|
|
can run at a time we need to use a fiber scheduler which does not run
|
||
|
|
an RPC server in the background to schedule the fiber which will
|
||
|
|
perform the RPC call.
|
||
|
|
*)
|
||
|
|
Rpc_common.run_via_rpc
|
||
|
|
~builder
|
||
|
|
~common
|
||
|
|
~config
|
||
|
|
lock_held_by
|
||
|
|
(Rpc.Build.build ~wait:true)
|
||
|
|
targets
|
||
|
|
| Ok () ->
|
||
|
|
let request setup =
|
||
|
|
Target.interpret_targets (Common.root common) config setup targets
|
||
|
|
in
|
||
|
|
run_build_command ~common ~config ~request
|
||
|
|
in
|
||
|
|
Cmd.v (Cmd.info "build" ~doc ~man ~envs:Common.envs) term
|
||
|
|
;;
|