From 0c9df5d952d107269c117bb78bc97f4b16cb54c0 Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <me@rgrinberg.com>
Date: Thu, 2 Mar 2023 17:39:28 -0600
Subject: [PATCH] feature: use clonefile on macos

Use mac's [clonefile] instead of manually copying. [clonefile] is like
hardlink but it will copy-on-write when edited.

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

<!-- ps-id: 7c730484-ecf9-4dae-9718-9bbd0bd480f5 -->
---
 bench/micro/copyfile.ml               | 14 +++++++
 bench/micro/dune                      |  5 +++
 otherlibs/stdune/src/copyfile_stubs.c | 60 +++++++++++++++++++++++++++
 otherlibs/stdune/src/dune             |  2 +-
 otherlibs/stdune/src/io.ml            | 21 ++++++++++
 5 files changed, 101 insertions(+), 1 deletion(-)
 create mode 100644 bench/micro/copyfile.ml
 create mode 100644 otherlibs/stdune/src/copyfile_stubs.c

diff --git a/bench/micro/copyfile.ml b/bench/micro/copyfile.ml
new file mode 100644
index 000000000000..a43188c2e203
--- /dev/null
+++ b/bench/micro/copyfile.ml
@@ -0,0 +1,14 @@
+open Stdune
+
+let dir = Temp.create Dir ~prefix:"copyfile" ~suffix:"bench"
+
+let contents = String.make 50_000 '0'
+
+let () =
+  let src = Path.relative dir "initial" in
+  Io.write_file (Path.relative dir "initial") contents;
+  let chmod _ = 444 in
+  for i = 1 to 10_000 do
+    let dst = Path.relative dir (sprintf "dst-%d" i) in
+    Io.copy_file ~chmod ~src ~dst ()
+  done
diff --git a/bench/micro/dune b/bench/micro/dune
index 345f896dfaa5..71503f3bb538 100644
--- a/bench/micro/dune
+++ b/bench/micro/dune
@@ -1,3 +1,8 @@
+(executable
+ (name copyfile)
+ (modules copyfile)
+ (libraries stdune))
+
 (executable
  (name main)
  (modules main)
diff --git a/otherlibs/stdune/src/copyfile_stubs.c b/otherlibs/stdune/src/copyfile_stubs.c
new file mode 100644
index 000000000000..88432fe9a081
--- /dev/null
+++ b/otherlibs/stdune/src/copyfile_stubs.c
@@ -0,0 +1,60 @@
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+
+#if defined(__APPLE__)
+#define _DARWIN_C_SOURCE
+#include <caml/threads.h>
+#include <caml/unixsupport.h>
+#include <copyfile.h>
+#include <errno.h>
+#include <stdlib.h>
+
+CAMLprim value stdune_copyfile(value v_from, value v_to) {
+  CAMLparam2(v_from, v_to);
+  char *from = caml_stat_strdup(String_val(v_from));
+  char *to = caml_stat_strdup(String_val(v_to));
+  caml_release_runtime_system();
+  /* clonefile doesn't follow symlinks automatically */
+  char *real_from = realpath(from, NULL);
+  caml_stat_free(from);
+  if (real_from == NULL) {
+    caml_stat_free(to);
+    caml_acquire_runtime_system();
+    uerror("realpath", Nothing);
+  }
+  /* nor does it automatically overwrite the target */
+  int ret = unlink(to);
+  if (ret < 0 && errno != ENOENT) {
+    caml_stat_free(to);
+    free(real_from);
+    caml_acquire_runtime_system();
+    uerror("unlink", Nothing);
+  }
+  ret = copyfile(real_from, to, NULL, COPYFILE_CLONE);
+  caml_stat_free(to);
+  free(real_from);
+  caml_acquire_runtime_system();
+  if (ret < 0) {
+    uerror("copyfile", Nothing);
+  }
+  CAMLreturn(Val_unit);
+}
+
+CAMLprim value stdune_is_darwin(value v_unit) {
+  CAMLparam1(v_unit);
+  CAMLreturn(Val_true);
+}
+
+#else
+
+CAMLprim value stdune_copyfile(value v_from, value v_to) {
+  caml_failwith("copyfile: only on macos");
+}
+
+CAMLprim value stdune_is_darwin(value v_unit) {
+  CAMLparam1(v_unit);
+  CAMLreturn(Val_false);
+}
+
+#endif
diff --git a/otherlibs/stdune/src/dune b/otherlibs/stdune/src/dune
index 44006601972b..00899f60b934 100644
--- a/otherlibs/stdune/src/dune
+++ b/otherlibs/stdune/src/dune
@@ -12,6 +12,6 @@
   (re_export dune_filesystem_stubs))
  (foreign_stubs
   (language c)
-  (names wait3_stubs))
+  (names wait3_stubs copyfile_stubs))
  (instrumentation
   (backend bisect_ppx)))
diff --git a/otherlibs/stdune/src/io.ml b/otherlibs/stdune/src/io.ml
index 33846e94dd59..f736ee10b055 100644
--- a/otherlibs/stdune/src/io.ml
+++ b/otherlibs/stdune/src/io.ml
@@ -248,10 +248,31 @@ struct
     in
     (ic, oc)
 
+  module Copyfile = struct
+    (* Bindings to mac's fast copy function. It's similar to a hardlink, except
+       it does COW when edited. It will also default back to regular copying if
+       it fails for w/e reason *)
+    external copyfile : string -> string -> unit = "stdune_copyfile"
+
+    external available : unit -> bool = "stdune_is_darwin"
+  end
+
   let copy_file ?chmod ~src ~dst () =
     Exn.protectx (setup_copy ?chmod ~src ~dst ()) ~finally:close_both
       ~f:(fun (ic, oc) -> copy_channels ic oc)
 
+  let copy_file =
+    match Copyfile.available () with
+    | false -> copy_file
+    | true -> (
+      fun ?chmod ~src ~dst () ->
+        let src = Path.to_string src in
+        let dst = Path.to_string dst in
+        Copyfile.copyfile src dst;
+        match chmod with
+        | None -> ()
+        | Some chmod -> (Unix.stat src).st_perm |> chmod |> Unix.chmod dst)
+
   let file_line path n =
     with_file_in ~binary:false path ~f:(fun ic ->
         for _ = 1 to n - 1 do