Oh Windows, you're so special and different.

tmcgilchrist · tmcgilchrist · commit 4df0160faef3 · 2026-03-28T21:55:17.000+11:00
diff --git a/lib/olly_common/launch.ml b/lib/olly_common/launch.ml
@@ -14,6 +14,19 @@ type exec_config = Attach of string * int | Execute of string list
 (* Raised by exec_process to indicate various unrecoverable failures. *)
 exception Fail of string
 
+(* List .events files in a directory, returning the set of filenames. *)
+let list_events_files dir =
+  try
+    Sys.readdir dir
+    |> Array.to_list
+    |> List.filter (fun f -> Filename.check_suffix f ".events")
+  with Sys_error _ -> []
+
+(* Extract the PID from a ring buffer filename like "12345.events". *)
+let pid_of_events_file filename =
+  try Some (int_of_string (Filename.chop_suffix filename ".events"))
+  with _ -> None
+
 let exec_process (config : runtime_events_config) (argsl : string list) :
     subprocess =
   if not (List.length argsl > 0) then
@@ -48,7 +61,12 @@ let exec_process (config : runtime_events_config) (argsl : string list) :
       |]
       (Unix.environment ())
   in
-  let child_pid =
+  (* Record existing .events files so we can detect the child's new one.
+     On Windows, Unix.create_process_env returns a process handle, not a PID,
+     but the .events file is named with the real PID. We find the child's
+     real PID by detecting which new .events file appeared. *)
+  let existing_events = list_events_files dir in
+  let child_handle =
     try
       Unix.create_process_env executable_filename (Array.of_list argsl) env
         Unix.stdin Unix.stdout Unix.stderr
@@ -63,14 +81,29 @@ let exec_process (config : runtime_events_config) (argsl : string list) :
   let timeout = 5.0 in
   let poll_interval = 0.05 in
   let deadline = Unix.gettimeofday () +. timeout in
+  let child_pid = ref child_handle in
   let cursor =
     let last_exn = ref None in
     let result = ref None in
     while !result = None && Unix.gettimeofday () < deadline do
-      try result := Some (Runtime_events.create_cursor (Some (dir, child_pid)))
-      with Failure _ as exn ->
-        last_exn := Some exn;
-        Unix.sleepf poll_interval
+      (* Find the child's real PID by detecting the new .events file.
+         On Unix, child_handle IS the PID so this is a no-op. On Windows,
+         we need to discover the real PID from the filesystem. *)
+      if !child_pid = child_handle then begin
+        let current = list_events_files dir in
+        let new_files = List.filter (fun f -> not (List.mem f existing_events)) current in
+        match new_files with
+        | [f] -> (match pid_of_events_file f with
+                  | Some pid -> child_pid := pid
+                  | None -> ())
+        | _ -> ()
+      end;
+      (try
+         result :=
+           Some (Runtime_events.create_cursor (Some (dir, !child_pid)))
+       with Failure _ as exn ->
+         last_exn := Some exn;
+         Unix.sleepf poll_interval)
     done;
     match !result with
     | Some c -> c
@@ -82,19 +115,22 @@ let exec_process (config : runtime_events_config) (argsl : string list) :
         in
         failwith msg
   in
+  let real_pid = !child_pid in
   let alive () =
-    match Unix.waitpid [ Unix.WNOHANG ] child_pid with
+    match Unix.waitpid [ Unix.WNOHANG ] child_handle with
     | 0, _ -> true
-    | p, _ when p = child_pid -> false
+    | p, _ when p = child_handle -> false
     | _, _ -> assert false
   and close () =
     Runtime_events.free_cursor cursor;
     (* We need to remove the ring buffers ourselves because we told
        the child process not to remove them *)
-    let ring_file = Filename.concat dir (string_of_int child_pid ^ ".events") in
-    Unix.unlink ring_file
+    let ring_file =
+      Filename.concat dir (string_of_int real_pid ^ ".events")
+    in
+    (try Unix.unlink ring_file with Unix.Unix_error _ -> ())
   in
-  { alive; cursor; close; pid = child_pid }
+  { alive; cursor; close; pid = child_handle }
 
 let attach_process (dir : string) (pid : int) : subprocess =
   let cursor =
