diff --git a/bench/micro/copyfile.ml b/bench/micro/copyfile.ml new file mode 100644 index 00000000000..a43188c2e20 --- /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 345f896dfaa..71503f3bb53 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 00000000000..b8e3ae33358 --- /dev/null +++ b/otherlibs/stdune/src/copyfile_stubs.c @@ -0,0 +1,69 @@ +#include +#include +#include + +#if defined(__APPLE__) +#define _DARWIN_C_SOURCE + +#include +#include +#include + +#include +#include +#include +#include +#include + +CAMLprim value stdune_copyfile(value v_from, value v_to) { + CAMLparam2(v_from, v_to); + caml_unix_check_path(v_from, "copyfile"); + caml_unix_check_path(v_to, "copyfile"); + char from[PATH_MAX]; + char to[PATH_MAX]; + char real_from[PATH_MAX]; + int from_len = caml_string_length(v_from); + int to_len = caml_string_length(v_to); + memcpy(from, String_val(v_from), from_len); + memcpy(to, String_val(v_to), to_len); + from[from_len] = '\0'; + to[to_len] = '\0'; + + caml_release_runtime_system(); + /* clonefile doesn't follow symlinks automatically */ + char *realpath_result = realpath(from, real_from); + if (realpath_result == NULL) { + caml_acquire_runtime_system(); + uerror("realpath", v_from); + } + /* nor does it automatically overwrite the target */ + int ret = unlink(to); + if (ret < 0 && errno != ENOENT) { + caml_acquire_runtime_system(); + uerror("unlink", v_to); + } + ret = copyfile(real_from, to, NULL, COPYFILE_CLONE); + caml_acquire_runtime_system(); + if (ret < 0) { + uerror("copyfile", v_to); + } + 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 44006601972..00899f60b93 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 33846e94dd5..210deb7455b 100644 --- a/otherlibs/stdune/src/io.ml +++ b/otherlibs/stdune/src/io.ml @@ -248,10 +248,39 @@ 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 + (try Copyfile.copyfile src dst with + | Unix.Unix_error (Unix.EPERM, "unlink", _) -> + let message = Printf.sprintf "%s: Is a directory" dst in + raise (Sys_error message) + | Unix.Unix_error (Unix.ENOENT, "realpath", _) -> + let message = + Printf.sprintf "error: %s: No such file or directory" src + in + raise (Sys_error message)); + 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