Skip to content

Commit

Permalink
Use ocaml inotify (#4747)
Browse files Browse the repository at this point in the history
This PR makes dune use inotify library directly instead of relying on an external process (inotifywait).
The reasons for this are:

This removes one opaque indirection in reasoning about inotify semantics, putting it under our control. (inotify is already complicated, inotifywait adds its own quirks to the mix).
It lets us express interest in a part of the workspace that we're working with. With inotifywait you have to subscribe to the entire workspace, which uses more inotify watches and requires a full workspace scan at startup to establish those watches.

Signed-off-by: Arseniy Alekseyev <aalekseyev@janestreet.com>
  • Loading branch information
aalekseyev authored Jun 23, 2021
1 parent 6997cbe commit 7d5f6cd
Show file tree
Hide file tree
Showing 26 changed files with 1,367 additions and 308 deletions.
4 changes: 2 additions & 2 deletions bin/common.ml
Original file line number Diff line number Diff line change
Expand Up @@ -892,10 +892,10 @@ let term =
value
& opt
(enum
[ ("automatic", Dune_engine.Scheduler.Run.Detect_external)
[ ("automatic", Dune_engine.Scheduler.Run.Automatic)
; ("manual", No_watcher)
])
Detect_external
Automatic
& info [ "file-watcher" ] ~doc)
and+ wait_for_filesystem_clock =
Arg.(
Expand Down
3 changes: 3 additions & 0 deletions boot/libs.ml
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,9 @@ let local_libraries =
; ("otherlibs/dune-rpc/private", Some "Dune_rpc_private", false, None)
; ("src/dune_rpc_server", Some "Dune_rpc_server", false, None)
; ("src/thread_worker", Some "Thread_worker", false, None)
; ("vendor/ocaml-inotify/src", Some "Ocaml_inotify", false, None)
; ("src/async_inotify_for_dune", Some "Async_inotify_for_dune", false,
None)
; ("src/dune_file_watcher", Some "Dune_file_watcher", false, None)
; ("src/dune_engine", Some "Dune_engine", false, None)
; ("src/dune_config", Some "Dune_config", false, None)
Expand Down
2 changes: 2 additions & 0 deletions otherlibs/stdune-unstable/monoid.ml
Original file line number Diff line number Diff line change
@@ -1,5 +1,7 @@
module type Basic = Monoid_intf.Basic

module type S = Monoid_intf.S

module Make (M : Basic) : Monoid_intf.S with type t = M.t = struct
include M

Expand Down
32 changes: 17 additions & 15 deletions otherlibs/stdune-unstable/monoid.mli
Original file line number Diff line number Diff line change
@@ -1,32 +1,34 @@
module type Basic = Monoid_intf.Basic

module type S = Monoid_intf.S

(** This functor extends the basic definition of a monoid by adding a convenient
operator synonym [( @ ) = combine], as well as derived functions [reduce]
and [map_reduce]. *)
module Make (M : Basic) : Monoid_intf.S with type t = M.t
module Make (M : Basic) : S with type t = M.t
[@@inlined always]

(** The monoid you get with [empty = false] and [combine = ( || )]. *)
module Exists : Monoid_intf.S with type t = bool
module Exists : S with type t = bool

(** The monoid you get with [empty = true] and [combine = ( && )]. *)
module Forall : Monoid_intf.S with type t = bool
module Forall : S with type t = bool

(** The string concatenation monoid with [empty = ""] and [combine = ( ^ )]. *)
module String : Monoid_intf.S with type t = string
module String : S with type t = string

(** The list monoid with [empty = \[\]] and [combine = ( @ )]. *)
module List (M : sig
type t
end) : Monoid_intf.S with type t = M.t list
end) : S with type t = M.t list

(** The list monoid with [empty = \[\]] and [combine = ( @ )]. *)
module Appendable_list (M : sig
type t
end) : Monoid_intf.S with type t = M.t Appendable_list.t
end) : S with type t = M.t Appendable_list.t

(** The trivial monoid with [empty = ()] and [combine () () = ()]. *)
module Unit : Monoid_intf.S with type t = Unit.t
module Unit : S with type t = Unit.t

(** The addition monoid with [empty = zero] and [combine = ( + )]. *)
module Add (M : sig
Expand All @@ -35,7 +37,7 @@ module Add (M : sig
val zero : t

val ( + ) : t -> t -> t
end) : Monoid_intf.S with type t = M.t
end) : S with type t = M.t

(** The multiplication monoid with [empty = one] and [combine = ( * )]. *)
module Mul (M : sig
Expand All @@ -44,7 +46,7 @@ module Mul (M : sig
val one : t

val ( * ) : t -> t -> t
end) : Monoid_intf.S with type t = M.t
end) : S with type t = M.t

(** The union monoid with [empty = M.empty] and [combine = M.union]. *)
module Union (M : sig
Expand All @@ -53,17 +55,17 @@ module Union (M : sig
val empty : t

val union : t -> t -> t
end) : Monoid_intf.S with type t = M.t
end) : S with type t = M.t

(** The product of monoids where pairs are combined component-wise. *)
module Product (A : Monoid_intf.Basic) (B : Monoid_intf.Basic) :
Monoid_intf.S with type t = A.t * B.t
S with type t = A.t * B.t

(** Same as [Product] but for 3 monoids. *)
module Product3
(A : Monoid_intf.Basic)
(B : Monoid_intf.Basic)
(C : Monoid_intf.Basic) : Monoid_intf.S with type t = A.t * B.t * C.t
(C : Monoid_intf.Basic) : S with type t = A.t * B.t * C.t

(** Functions that return a monoid form the following monoid:
Expand All @@ -72,7 +74,7 @@ module Product3
module Function (A : sig
type t
end)
(M : Monoid_intf.Basic) : Monoid_intf.S with type t = A.t -> M.t
(M : Monoid_intf.Basic) : S with type t = A.t -> M.t

(** Endofunctions, i.e., functions of type [t -> t], form two monoids. *)
module Endofunction : sig
Expand All @@ -83,7 +85,7 @@ module Endofunction : sig
- combine f g = fun x -> g (f x) *)
module Left (A : sig
type t
end) : Monoid_intf.S with type t = A.t -> A.t
end) : S with type t = A.t -> A.t

(** The right-to-left function composition monoid, where the argument is first
passed to the rightmost function:
Expand All @@ -92,5 +94,5 @@ module Endofunction : sig
- combine f g = fun x -> f (g x) *)
module Right (A : sig
type t
end) : Monoid_intf.S with type t = A.t -> A.t
end) : S with type t = A.t -> A.t
end
202 changes: 202 additions & 0 deletions src/async_inotify_for_dune/async_inotify.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,202 @@
open Stdune
open Poly

(* We don't make calls to [Inotify] functions ([add_watch], [rm_watch]) in a
separate thread because:
- we don't think they can block for a while - Inotify doesn't release the
OCaml lock anyway - it avoids racing with the select loop below, by
preventing adding a watch and seeing an event about it before having filled
the hashtable (not that we have observed this particular race). *)

module External_deps = struct
module Unix = Unix
module String_table = String.Table
module Filename = Filename
end

open External_deps
module Inotify = Ocaml_inotify.Inotify

module Event = struct
type move =
| Away of string
| Into of string
| Move of string * string

type t =
| Created of string
| Unlinked of string
| Modified of string
| Moved of move
| Queue_overflow

let move_to_string m =
match m with
| Away s -> Printf.sprintf "%s -> Unknown" s
| Into s -> Printf.sprintf "Unknown -> %s" s
| Move (f, t) -> Printf.sprintf "%s -> %s" f t

let to_string t =
match t with
| Created s -> Printf.sprintf "created %s" s
| Unlinked s -> Printf.sprintf "unlinked %s" s
| Moved mv -> Printf.sprintf "moved %s" (move_to_string mv)
| Modified s -> Printf.sprintf "modified %s" s
| Queue_overflow -> "queue overflow"
end

open Event

module Inotify_watch = struct
type t = Inotify.watch

let hash t = Int.hash (Inotify.int_of_watch t)

let equal a b = Int.equal (Inotify.int_of_watch a) (Inotify.int_of_watch b)

let to_dyn t = Int.to_dyn (Inotify.int_of_watch t)
end

module Watch_table = Hashtbl.Make (Inotify_watch)

type t =
{ fd : Unix.file_descr
; log_error : string -> unit
; watch_table : string Watch_table.t
; path_table : Inotify.watch String_table.t
; send_emit_events_job_to_scheduler : (unit -> Event.t list) -> unit
; select_events : Inotify.selector list
}

type file_info = string * Unix.stats

type modify_event_selector =
[ `Any_change
| `Closed_writable_fd
]

let ( ^/ ) = Filename.concat

let add t path =
let watch = Inotify.add_watch t.fd path t.select_events in
Watch_table.set t.watch_table watch path;
String_table.set t.path_table path watch

let process_raw_events t events =
let watch_table = t.watch_table in
let ev_kinds =
List.filter_map events ~f:(fun (watch, ev_kinds, trans_id, fn) ->
if
Inotify.int_of_watch watch = -1
(* queue overflow event is always reported on watch -1 *)
then
let maybe_overflow =
List.filter_map ev_kinds ~f:(fun ev ->
match ev with
| Inotify.Q_overflow -> Some (ev, trans_id, "<overflow>")
| _ -> None)
in
match maybe_overflow with
| [] -> None
| _ :: _ -> Some maybe_overflow
else
match Watch_table.find watch_table watch with
| None ->
t.log_error
(Printf.sprintf "Events for an unknown watch (%d) [%s]\n"
(Inotify.int_of_watch watch)
(String.concat ~sep:", "
(List.map ev_kinds ~f:Inotify.string_of_event_kind)));
None
| Some path ->
let fn =
match fn with
| None -> path
| Some fn -> path ^/ fn
in
Some (List.map ev_kinds ~f:(fun ev -> (ev, trans_id, fn))))
|> List.concat
in
let pending_mv, actions =
List.fold_left ev_kinds ~init:(None, [])
~f:(fun (pending_mv, actions) (kind, trans_id, fn) ->
let add_pending lst =
match pending_mv with
| None -> lst
| Some (_, fn) -> Moved (Away fn) :: lst
in
match kind with
| Inotify.Moved_from -> (Some (trans_id, fn), add_pending actions)
| Inotify.Moved_to -> (
match pending_mv with
| None -> (None, Moved (Into fn) :: actions)
| Some (m_trans_id, m_fn) ->
if m_trans_id = trans_id then
(None, Moved (Move (m_fn, fn)) :: actions)
else
(None, Moved (Away m_fn) :: Moved (Into fn) :: actions))
| Inotify.Move_self -> (Some (trans_id, fn), add_pending actions)
| Inotify.Create -> (None, Created fn :: add_pending actions)
| Inotify.Delete -> (None, Unlinked fn :: add_pending actions)
| Inotify.Modify
| Inotify.Close_write ->
(None, Modified fn :: add_pending actions)
| Inotify.Q_overflow -> (None, Queue_overflow :: add_pending actions)
| Inotify.Delete_self -> (None, add_pending actions)
| Inotify.Access
| Inotify.Attrib
| Inotify.Open
| Inotify.Ignored
| Inotify.Isdir
| Inotify.Unmount
| Inotify.Close_nowrite ->
(None, add_pending actions))
in
List.rev
(match pending_mv with
| None -> actions
| Some (_, fn) -> Moved (Away fn) :: actions)

let pump_events t ~spawn_thread =
let fd = t.fd in
let () =
spawn_thread (fun () ->
while true do
let _, _, _ =
UnixLabels.select ~read:[ fd ] ~write:[] ~except:[] ~timeout:(-1.)
in
let events = Inotify.read fd in
t.send_emit_events_job_to_scheduler (fun () ->
process_raw_events t events)
done)
in
()

let create ~spawn_thread ~modify_event_selector ~log_error
~send_emit_events_job_to_scheduler =
let fd = Inotify.create () in
let watch_table = Watch_table.create 10 in
let modify_selector : Inotify.selector =
match modify_event_selector with
| `Any_change -> S_Modify
| `Closed_writable_fd -> S_Close_write
in
let t =
{ fd
; watch_table
; path_table = String_table.create 10
; select_events =
[ S_Create
; S_Delete
; modify_selector
; S_Move_self
; S_Moved_from
; S_Moved_to
]
; log_error
; send_emit_events_job_to_scheduler
}
in
pump_events t ~spawn_thread;
t
Loading

0 comments on commit 7d5f6cd

Please sign in to comment.