diff --git a/CHANGES.md b/CHANGES.md index c29ba1c47a6..40f9d1bb6b3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -15,6 +15,10 @@ Unreleased - Fix build with MSVC compiler (#6517, @nojb) +- `dune clean` should no longer fail under Windows due to the inability to + remove the `.lock` file. Also, bring the implementation of the global lock + under Windows closer to that of Unix. (#6523, @nojb) + 3.6.0 (2022-11-14) ------------------ diff --git a/src/dune_util/dune_flock.c b/src/dune_util/dune_flock.c index 13832f1d4cd..fefd342c84f 100644 --- a/src/dune_util/dune_flock.c +++ b/src/dune_util/dune_flock.c @@ -3,18 +3,52 @@ #include #include -#ifndef _WIN32 +#ifdef _WIN32 + +#define FD_val(value) Handle_val(value) + +CAMLprim value dune_flock_lock(value v_fd, value v_block, value v_exclusive) { + CAMLparam3(v_fd, v_block, v_exclusive); + OVERLAPPED overlapped = { 0 }; + DWORD ok, dwFlags = 0; + if (Bool_val(v_exclusive)) { + dwFlags |= LOCKFILE_EXCLUSIVE_LOCK; + } + if (!Bool_val(v_block)) { + dwFlags |= LOCKFILE_FAIL_IMMEDIATELY; + } + caml_release_runtime_system(); + ok = LockFileEx(FD_val(v_fd), dwFlags, 0, MAXDWORD, MAXDWORD, &overlapped); + caml_acquire_runtime_system(); + if (!ok) { + win32_maperr(GetLastError()); + uerror("LockFileEx", Nothing); + } + CAMLreturn(Val_unit); +} + +CAMLprim value dune_flock_unlock(value v_fd) { + CAMLparam1(v_fd); + OVERLAPPED overlapped = { 0 }; + DWORD ok; + caml_release_runtime_system(); + ok = UnlockFileEx(FD_val(v_fd), 0, MAXDWORD, MAXDWORD, &overlapped); + caml_acquire_runtime_system(); + if (!ok) { + win32_maperr(GetLastError()); + uerror("UnlockFileEx", Nothing); + } + CAMLreturn(Val_unit); +} + +#else /* _WIN32 */ + #include -#endif #define FD_val(value) Int_val(value) CAMLprim value dune_flock_lock(value v_fd, value v_block, value v_exclusive) { -#ifdef _WIN32 - caml_failwith("no flock on win32"); - return Val_unit; -#else - CAMLparam2(v_fd, v_block); + CAMLparam3(v_fd, v_block, v_exclusive); int flags = 0; if (Bool_val(v_exclusive)) { flags |= LOCK_EX; @@ -30,14 +64,9 @@ CAMLprim value dune_flock_lock(value v_fd, value v_block, value v_exclusive) { } else { uerror("flock", Nothing); } -#endif } CAMLprim value dune_flock_unlock(value v_fd) { -#ifdef _WIN32 - caml_failwith("no flock on win32"); - return Val_unit; -#else CAMLparam1(v_fd); caml_release_runtime_system(); int ret = flock(FD_val(v_fd), LOCK_UN); @@ -47,5 +76,6 @@ CAMLprim value dune_flock_unlock(value v_fd) { } else { uerror("flock", Nothing); } -#endif } + +#endif /* _WIN32 */ diff --git a/src/dune_util/flock.ml b/src/dune_util/flock.ml index 4d5248142e1..582ba1935eb 100644 --- a/src/dune_util/flock.ml +++ b/src/dune_util/flock.ml @@ -21,7 +21,8 @@ let lock_block t lock = let lock_non_block t lock = match gen_lock t ~block:false ~exclusive:(is_exclusive lock) with | () -> Ok `Success - | exception Unix.Unix_error ((EWOULDBLOCK | EAGAIN), _, _) -> Ok `Failure + | exception Unix.Unix_error ((EWOULDBLOCK | EAGAIN | EACCES), _, _) -> + Ok `Failure | exception Unix.Unix_error (err, _, _) -> Error err external unlock : t -> unit = "dune_flock_unlock" diff --git a/src/dune_util/global_lock.ml b/src/dune_util/global_lock.ml index 6ee31ee3647..29d6ceddfe8 100644 --- a/src/dune_util/global_lock.ml +++ b/src/dune_util/global_lock.ml @@ -14,76 +14,32 @@ let with_timeout ~timeout f = in loop () -module type S = sig - val lock : unit -> [ `Success | `Failure ] - - val unlock : unit -> unit -end - let write_pid fd = let pid = Int.to_string (Unix.getpid ()) in let len = String.length pid in let res = Unix.write fd (Bytes.of_string pid) 0 len in assert (res = len) -module Win () : S = struct - let t = ref None - - let create () = - Path.ensure_build_dir_exists (); - match - Unix.openfile - (Path.Build.to_string lock_file) - [ O_CREAT; O_EXCL; O_WRONLY ] - 0o600 - with - | exception _ -> None - | fd -> - Unix.set_close_on_exec fd; - write_pid fd; - Some fd - - let () = - at_exit (fun () -> - match !t with - | None -> () - | Some fd -> - Unix.close fd; - Path.rm_rf (Path.build lock_file)) - - let lock () = - match !t with - | Some _ -> `Success - | None -> ( - match create () with - | None -> `Failure - | Some fd -> - t := Some fd; - `Success) - - let unlock () = - match !t with - | None -> () - | Some fd -> - Unix.close fd; - Path.rm_rf (Path.build lock_file) -end - -module Unix () : S = struct +module Lock = struct let t = lazy (Path.ensure_build_dir_exists (); let fd = Unix.openfile (Path.Build.to_string lock_file) - [ Unix.O_CREAT; O_WRONLY ] 0o600 + [ Unix.O_CREAT; O_WRONLY; O_SHARE_DELETE ] + 0o600 in Unix.set_close_on_exec fd; Flock.create fd) let or_raise_unix ~name = function | Ok s -> s - | Error _unix -> Code_error.raise "lock" [ ("name", Dyn.string name) ] + | Error error -> + Code_error.raise "lock" + [ ("name", Dyn.string name) + ; ("error", Dyn.string (Unix.error_message error)) + ] let lock () = let t = Lazy.force t in @@ -98,8 +54,6 @@ module Unix () : S = struct let unlock () = Lazy.force t |> Flock.unlock |> or_raise_unix ~name:"unlock" end -module Lock = (val if Sys.win32 then (module Win ()) else (module Unix ()) : S) - let locked = ref false let lock_exn ~timeout =