unikernel/duniverse/dune_/bin/build.ml

@@ -0,0 +1,215 @@
+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
+;;