Source file Zig.ml

(* LLM 2026-05-04:
    All commits for this file prior to this (hint: git blame) were LLM
    generated. No edits; no formatting.
    
    Priors: I had already written a non-fancy progress reporter (called
    "Plain") in OCaml and put a [std.Progress]-like interface on top of
    it months before I ported the Zig implementation (this file). There was
    quite a lot of tests in the code base. An AGENTS.md was also available
    (in a parent monorepo, not directly in MlFront) that tells LLMs how to
    build and test the code.
    
    Harness: GitHub Copilot v1.0.40
    LLM: GPT 5.4

    Prompt:

      /plan Make a MlFront_ProgressZig library as an OCaml translation of zig's https://github.com/ziglang/zig/blob/master/lib/std/Progress.zig library. Any code that can't be translated into OCaml should use a C stub.
      MlFront_Cache, MlFront_Signify and MlFront_ZipFile have wrappers around pure C; use them as examples for planning.
      An old article https://andrewkelley.me/post/zig-new-cli-progress-bar-explained.html can also be consulted during planning (Windows _is_ working in zig Progress today).

      Make a MlFront_ProgressPeriod library for headless environments like CI and accessiblity environments that have screen readers. It's only dependencies may be the `thread` library for a background thread that can print
      progress no slower than every 30 seconds; no C stubs should be used.
      An example of reporting progress in headless environment is https://github.com/tradingstrategy-ai/tqdm-loggable.

      Make a MlFront_Progress library with MlFront_Progress.Progress.S being a module interface that is common to both MlFront_ProgressZig and MlFront_ProgressPeriod.
      There _is_ an existing first attempt with ThunkProgress. Everything in MlFront_Progress.Progress should be similar to ThunkProgress, even the Plain and Silent backends. Any use in the source code of ThunkProgress
      should be replaced by a first-class module of MlFront_Progress.Progress.S.

      Make a unified test for MlFront_ProgressZig and MlFront_ProgressPeriod.

      All libraries should have .mli files with odoc documentation. *)

external windows_api_clear : unit -> bool
  = "mlfront_progresszig_windows_api_clear"

let backend_id = "zig"

external windows_api_write_marker : unit -> bool
  = "mlfront_progresszig_windows_api_write_marker"

external windows_api_move_to_marker : int -> bool
  = "mlfront_progresszig_windows_api_move_to_marker"

external windows_ipc_create_pipe : unit -> int64 * int64
  = "mlfront_progresszig_windows_ipc_create_pipe"

external windows_ipc_close : int64 -> unit
  = "mlfront_progresszig_windows_ipc_close"

type node = int
type child_transport = Unix_fd of Unix.file_descr | Windows_handle of int64

type child_snapshot = {
  parent : node;
  label : string;
  mutable snapshot : ZigPacket.packet_slot array option;
  mutable writer : child_transport option;
  mutable reader_thread : Thread.t option;
}

(* Andrew Kelley's "Inter-Process Communication" design for Zig progress
   explicitly grafts each child process snapshot into the parent's own tree
   instead of rendering a disconnected footer. Each snapshot therefore carries
   the OCaml parent node that launched the child process. *)
type child_process = { id : int; writer : child_transport }

type display_node = {
  display_name : string;
  display_estimated_total : int;
  display_completed : int;
  display_children : display_node list;
}

type visible_root =
  | Hidden_root of display_node list
  | Named_root of display_node

type mode =
  | Disabled
  | Plain
  | Ansi
  | WindowsApi
  | IpcUnixFd of Unix.file_descr
  | IpcWindowsHandle of int64

type last_output = Rendered of string | Packet of ZigPacket.t

type render_config = {
  cols : int;
  max_lines : int option;
  tree_encoding : ZigDisplay.tree_encoding;
}

type state = {
  mutex : Mutex.t;
  slots : ZigSlot.t array;
  mutable freelist : int list;
  mutable running : bool;
  refresh_seconds : float;
  initial_delay_seconds : float;
  started_at : float;
  mode : mode;
  render_config : render_config;
  mutable last_output : last_output option;
  mutable last_ansi_lines : int;
  children : (int, child_snapshot) Hashtbl.t;
  mutable next_child_id : int;
  mutable reporter_thread : Thread.t option;
}

let global_state : state option ref = ref None
let root_id = 0
let max_name_len = 40
let default_max_nodes = 83
let default_terminal_rows = 25
let default_terminal_cols = 80

let with_lock mutex f =
  Mutex.lock mutex;
  Fun.protect ~finally:(fun () -> Mutex.unlock mutex) f

let getenv_float name ~default =
  match Sys.getenv_opt name with
  | None -> default
  | Some value ->
  match float_of_string_opt value with Some x when x > 0.0 -> x | _ -> default

let getenv_int name ~default =
  match Sys.getenv_opt name with
  | None -> default
  | Some value ->
  match int_of_string_opt value with Some x when x > 0 -> x | _ -> default

let normalize_root = function
  | Some name when not (String.equal name "") ->
      let length = min (String.length name) max_name_len in
      String.sub name 0 length
  | Some _ | None -> ""

let normalize_name name = normalize_root (Some name)
let name_option name = if String.equal name "" then None else Some name
let normalize_count count = max 0 count
let ns_to_seconds ns = Int64.to_float ns /. 1_000_000_000.0

external file_descr_of_int : int -> Unix.file_descr = "%identity"
external int_of_file_descr : Unix.file_descr -> int = "%identity"

let int64_of_string_opt s =
  try Some (Int64.of_string s) with Failure _ -> None

let delay_elapsed state =
  Unix.gettimeofday () -. state.started_at >= state.initial_delay_seconds

let terminal_size_or_default console =
  match MlFront_Console.Console.terminal_size console with
  | Some { rows; cols } when rows > 0 && cols > 0 -> (rows, cols)
  | _ -> (default_terminal_rows, default_terminal_cols)

let make_render_config console mode =
  match mode with
  | Ansi | WindowsApi ->
      let rows, cols = terminal_size_or_default console in
      {
        cols;
        max_lines = Some (max 0 (rows - 2));
        tree_encoding = ZigDisplay.tree_encoding_for_ansi console;
      }
  | Plain ->
      {
        cols = max_int;
        max_lines = None;
        tree_encoding = ZigDisplay.tree_encoding_for_plain ();
      }
  | Disabled | IpcUnixFd _ | IpcWindowsHandle _ ->
      { cols = max_int; max_lines = None; tree_encoding = ZigDisplay.Utf8 }

let within_row_limit config line_count =
  match config.max_lines with
  | None -> true
  | Some max_lines -> line_count < max_lines

let truncate_name name =
  let length = min (String.length name) max_name_len in
  String.sub name 0 length

let with_state default f =
  match !global_state with None -> default | Some state -> f state

let with_locked_state default f =
  with_state default (fun state -> with_lock state.mutex (fun () -> f state))

let active_slot_opt state node =
  if node >= 0 && node < Array.length state.slots then
    let slot = state.slots.(node) in
    if slot.used then Some slot else None
  else None

let with_active_slot state node ~default f =
  match active_slot_opt state node with Some slot -> f slot | None -> default

let invalid_active_parent () =
  invalid_arg
    "MlFront_ProgressZig.Zig.prepare_child_process: parent must be an active \
     node"

let register_child_locked state ~parent ~label =
  if Option.is_none (active_slot_opt state parent) then invalid_active_parent ();
  let id = state.next_child_id in
  state.next_child_id <- state.next_child_id + 1;
  Hashtbl.replace state.children id
    { parent; label; snapshot = None; writer = None; reader_thread = None };
  id

let attach_child_locked state id writer reader_thread =
  match Hashtbl.find_opt state.children id with
  | Some (child : child_snapshot) ->
      child.writer <- Some writer;
      child.reader_thread <- Some reader_thread
  | None -> ()

let console_mode ~disable_printing () =
  let open MlFront_Console in
  let force_local =
    match Sys.getenv_opt "MLFRONT_PROGRESS_ZIG_FORCE_LOCAL" with
    | Some "1" -> true
    | _ -> false
  in
  match (force_local, Sys.getenv_opt "ZIG_PROGRESS") with
  | true, _ -> (
      match Sys.getenv_opt "MLFRONT_PROGRESS_ZIG_MODE" with
      | Some "plain" -> (Console.create_plain_terminal (), Plain)
      | Some "ansi" -> (Console.create_virtual_terminal (), Ansi)
      | Some "windows-api" when Sys.win32 ->
          (Console.create_virtual_terminal (), WindowsApi)
      | Some "disabled" -> (Console.create_no_terminal (), Disabled)
      | _ ->
          let terminal = Console.create_virtual_terminal () in
          if disable_printing then (Console.create_no_terminal (), Disabled)
          else if Console.supports_virtual_terminal terminal then
            (terminal, Ansi)
          else if Console.has_terminal terminal then
            if Sys.win32 then (terminal, WindowsApi) else (terminal, Ansi)
          else (terminal, Disabled))
  | false, Some value when Sys.win32 -> (
      match int64_of_string_opt value with
      | Some handle -> (Console.create_no_terminal (), IpcWindowsHandle handle)
      | None -> (Console.create_no_terminal (), Disabled))
  | false, Some value -> (
      match int_of_string_opt value with
      | Some fd ->
          (Console.create_no_terminal (), IpcUnixFd (file_descr_of_int fd))
      | None -> (Console.create_no_terminal (), Disabled))
  | false, None when disable_printing ->
      (Console.create_no_terminal (), Disabled)
  | false, None ->
  match Sys.getenv_opt "MLFRONT_PROGRESS_ZIG_MODE" with
  | Some "plain" -> (Console.create_plain_terminal (), Plain)
  | Some "ansi" -> (Console.create_virtual_terminal (), Ansi)
  | Some "windows-api" when Sys.win32 ->
      (Console.create_virtual_terminal (), WindowsApi)
  | Some "disabled" -> (Console.create_no_terminal (), Disabled)
  | _ ->
      let terminal = Console.create_virtual_terminal () in
      if Console.supports_virtual_terminal terminal then (terminal, Ansi)
      else if Console.has_terminal terminal then
        if Sys.win32 then (terminal, WindowsApi) else (terminal, Ansi)
      else (terminal, Disabled)

let children_of state parent =
  let children = ref [] in
  for idx = Array.length state.slots - 1 downto 0 do
    let slot = state.slots.(idx) in
    if slot.used && slot.parent = parent then children := idx :: !children
  done;
  !children

let sorted_ipc_children_of state parent =
  Hashtbl.to_seq state.children
  |> List.of_seq
  |> List.filter (fun (_id, child) -> child.parent = parent)
  |> List.sort (fun (id_a, child_a) (id_b, child_b) ->
         match String.compare child_a.label child_b.label with
         | 0 -> Int.compare id_a id_b
         | x -> x)

let children_indices_of_packet_slots packet_slots =
  let nodes_len = Array.length packet_slots in
  let children = Array.make nodes_len [] in
  for idx = nodes_len - 1 downto 0 do
    match packet_slots.(idx).ZigPacket.packet_parent with
    | Some parent when parent >= 0 && parent < nodes_len ->
        children.(parent) <- idx :: children.(parent)
    | Some _ | None -> ()
  done;
  children

let display_line ~estimated_total ~completed ~name =
  ZigDisplay.progress_line ~estimated_total ~completed ~name

let rec display_tree_of_slot state node_id =
  let slot = state.slots.(node_id) in
  {
    display_name = slot.name;
    display_estimated_total = slot.estimated_total;
    display_completed = slot.completed;
    display_children = visible_children_for_parent state node_id;
  }

and display_tree_of_packet_slot packet_slots children idx =
  let slot = packet_slots.(idx) in
  {
    display_name = slot.ZigPacket.packet_name;
    display_estimated_total = slot.packet_estimated_total;
    display_completed = slot.packet_completed;
    display_children =
      List.map
        (display_tree_of_packet_slot packet_slots children)
        children.(idx);
  }

and visible_forest_of_packet_slots packet_slots =
  if Array.length packet_slots = 0 then []
  else
    let children = children_indices_of_packet_slots packet_slots in
    let root = display_tree_of_packet_slot packet_slots children 0 in
    if String.equal root.display_name "" then root.display_children
    else [ root ]

and visible_forest_of_child_snapshot child =
  let label_only () =
    [
      {
        display_name = truncate_name child.label;
        display_estimated_total = 0;
        display_completed = 0;
        display_children = [];
      };
    ]
  in
  match child.snapshot with
  | None -> label_only ()
  | Some packet_slots ->
  match visible_forest_of_packet_slots packet_slots with
  | [] -> label_only ()
  | first :: rest ->
      let labeled_first =
        {
          first with
          display_name =
            truncate_name child.label ^ ": "
            ^ display_line ~estimated_total:first.display_estimated_total
                ~completed:first.display_completed ~name:first.display_name;
          display_estimated_total = 0;
          display_completed = 0;
        }
      in
      labeled_first :: rest

and visible_children_for_parent state parent =
  List.map (display_tree_of_slot state) (children_of state parent)
  @ (sorted_ipc_children_of state parent
    |> List.map (fun (_id, child) -> visible_forest_of_child_snapshot child)
    |> List.flatten)

and visible_root_locked ~hide_idle_named_root state =
  let root_slot = state.slots.(root_id) in
  let root_children = visible_children_for_parent state root_id in
  if String.equal root_slot.name "" then Hidden_root root_children
  else if hide_idle_named_root && root_children = [] then Hidden_root []
  else
    Named_root
      {
        display_name = root_slot.name;
        display_estimated_total = root_slot.estimated_total;
        display_completed = root_slot.completed;
        display_children = root_children;
      }

let serialize_visible_root_locked state =
  let slots =
    Array.init ZigPacket.max_nodes (fun _ -> { ZigSlot.zero with used = false })
  in
  let ordered = ref [] in
  let next_idx = ref 0 in
  let rec add_node parent node =
    if !next_idx < ZigPacket.max_nodes then (
      let idx = !next_idx in
      incr next_idx;
      slots.(idx) <-
        {
          used = true;
          parent =
            (match parent with
            | Some parent_idx -> parent_idx
            | None -> ZigSlot.noop_node);
          name = node.display_name;
          no_rollup = false;
          estimated_total = node.display_estimated_total;
          completed = node.display_completed;
        };
      ordered := (idx, parent) :: !ordered;
      List.iter (add_node (Some idx)) node.display_children)
  in
  (match visible_root_locked ~hide_idle_named_root:false state with
  | Hidden_root children ->
      slots.(0) <- ZigSlot.root ~name:"" ~no_rollup:false ~estimated_total:0 ();
      ordered := [ (0, None) ];
      next_idx := 1;
      List.iter (add_node (Some 0)) children
  | Named_root root -> add_node None root);
  ZigPacket.serialize_slots ~nodes_len:!next_idx ~ordered:(List.rev !ordered)
    slots

let rec render_children_list config prefix line_count children =
  let child_count = List.length children in
  let rec loop idx used acc = function
    | [] -> (List.rev acc, used)
    | _ :: _ when not (within_row_limit config used) -> (List.rev acc, used)
    | child :: rest ->
        let child_lines, used =
          render_display_node config prefix (idx = child_count - 1) child used
        in
        loop (idx + 1) used (List.rev_append child_lines acc) rest
  in
  loop 0 line_count [] children

and render_display_node config prefix is_last node line_count =
  if not (within_row_limit config line_count) then ([], line_count)
  else
    let raw_line =
      if String.equal prefix "" then
        display_line ~estimated_total:node.display_estimated_total
          ~completed:node.display_completed ~name:node.display_name
      else
        Printf.sprintf "%s%s%s" prefix
          (ZigDisplay.tree_symbol config.tree_encoding
             (if is_last then `Langle else `Tee))
          (display_line ~estimated_total:node.display_estimated_total
             ~completed:node.display_completed ~name:node.display_name)
    in
    let line =
      ZigDisplay.truncate_display_width ~encoding:config.tree_encoding
        ~cols:config.cols raw_line
    in
    let child_prefix =
      if String.equal prefix "" then "   "
      else
        prefix
        ^
        if is_last then "   "
        else ZigDisplay.tree_symbol config.tree_encoding `Line
    in
    let rendered_children, line_count =
      render_children_list config child_prefix (line_count + 1)
        node.display_children
    in
    (line :: rendered_children, line_count)

let render_locked state =
  let config = state.render_config in
  match visible_root_locked ~hide_idle_named_root:true state with
  | Hidden_root children -> fst (render_children_list config "" 0 children)
  | Named_root root ->
      if not (within_row_limit config 0) then []
      else
        let root_line =
          display_line ~estimated_total:root.display_estimated_total
            ~completed:root.display_completed ~name:root.display_name
          |> ZigDisplay.truncate_display_width ~encoding:config.tree_encoding
               ~cols:config.cols
        in
        let child_lines =
          fst (render_children_list config "   " 1 root.display_children)
        in
        root_line :: child_lines

let same_last_output left right =
  match (left, right) with
  | None, None -> true
  | Some (Rendered left_text), Some (Rendered right_text) ->
      String.equal left_text right_text
  | Some (Packet left_packet), Some (Packet right_packet) ->
      ZigPacket.compare left_packet right_packet = 0
  | _ -> false

let output_plain state lines =
  let rendered = String.concat "\n" lines in
  let next_output = Some (Rendered rendered) in
  if not (same_last_output next_output state.last_output) then (
    state.last_output <- next_output;
    List.iter (fun line -> Printf.eprintf "%s\n%!" line) lines)

let move_ansi_cursor_to_start buffer line_count =
  if line_count > 0 then (
    Buffer.add_char buffer '\r';
    if line_count > 1 then
      Buffer.add_string buffer (Printf.sprintf "\027[%dA" (line_count - 1)))

let output_ansi state lines =
  let rendered = String.concat "\n" lines in
  let line_count = List.length lines in
  if line_count > 0 || state.last_ansi_lines > 0 then (
    let buffer = Buffer.create 256 in
    Buffer.add_string buffer "\027[J";
    List.iteri
      (fun idx line ->
        Buffer.add_string buffer line;
        if idx < List.length lines - 1 then Buffer.add_char buffer '\n')
      lines;
    move_ansi_cursor_to_start buffer line_count;
    output_string stderr (Buffer.contents buffer);
    Stdlib.flush stderr;
    state.last_output <- Some (Rendered rendered);
    state.last_ansi_lines <- line_count)

let output_windows_api state lines =
  let rendered = String.concat "\n" lines in
  let line_count = List.length lines in
  if line_count > 0 || state.last_ansi_lines > 0 then (
    (if state.last_ansi_lines > 0 then
       let (_ : bool) = windows_api_clear () in
       ());
    if line_count > 0 then (
      let (_ : bool) = windows_api_write_marker () in
      List.iter (fun line -> Printf.eprintf "%s\n%!" line) lines;
      let (_ : bool) = windows_api_move_to_marker line_count in
      ());
    state.last_output <- Some (Rendered rendered);
    state.last_ansi_lines <- line_count)

let clear_ansi state =
  if state.last_ansi_lines > 0 then (
    output_string stderr "\027[J";
    Stdlib.flush stderr;
    state.last_output <- Some (Rendered "");
    state.last_ansi_lines <- 0)

let clear_windows_api state =
  if state.last_ansi_lines > 0 then (
    let (_ : bool) = windows_api_clear () in
    Stdlib.flush stderr;
    state.last_output <- Some (Rendered "");
    state.last_ansi_lines <- 0)

let output_ipc state mode =
  match serialize_visible_root_locked state with
  | None -> ()
  | Some packet ->
      let next_output = Some (Packet packet) in
      if not (same_last_output next_output state.last_output) then (
        state.last_output <- next_output;
        match mode with
        | IpcUnixFd fd -> ZigPacket.write_packet_unix fd packet
        | IpcWindowsHandle handle ->
            let (_ : bool) = ZigPacket.windows_ipc_write_frame handle packet in
            ()
        | Disabled | Plain | Ansi | WindowsApi -> ())

let output_rendered_lines state mode =
  let lines = render_locked state in
  match mode with
  | Plain -> output_plain state lines
  | Ansi -> output_ansi state lines
  | WindowsApi -> output_windows_api state lines
  | Disabled | IpcUnixFd _ | IpcWindowsHandle _ -> ()

let flush_locked state =
  if state.mode <> Disabled && delay_elapsed state then
    match state.mode with
    | Disabled -> ()
    | (Plain | Ansi | WindowsApi) as mode -> output_rendered_lines state mode
    | IpcUnixFd _ as mode -> output_ipc state mode
    | IpcWindowsHandle _ as mode -> output_ipc state mode

let flush () =
  match !global_state with
  | None -> ()
  | Some state -> with_lock state.mutex (fun () -> flush_locked state)

let close_child_transport = function
  | Unix_fd fd -> ( try Unix.close fd with _ -> ())
  | Windows_handle handle -> windows_ipc_close handle

let detach_child_locked (child : child_snapshot) =
  Option.iter close_child_transport child.writer;
  child.writer <- None;
  let reader_thread = child.reader_thread in
  child.reader_thread <- None;
  reader_thread

let safe_join thread =
  if Thread.id thread <> Thread.id (Thread.self ()) then
    try Thread.join thread with _ -> ()

let shutdown_state state =
  let reporter_thread, child_threads =
    with_lock state.mutex (fun () ->
        if state.running then (
          state.running <- false;
          match state.mode with
          | Ansi -> clear_ansi state
          | WindowsApi -> clear_windows_api state
          | Disabled -> ()
          | Plain | IpcUnixFd _ | IpcWindowsHandle _ -> flush_locked state);
        let child_threads =
          Hashtbl.to_seq_values state.children
          |> List.of_seq
          |> List.filter_map detach_child_locked
        in
        Hashtbl.clear state.children;
        let reporter_thread = state.reporter_thread in
        state.reporter_thread <- None;
        (reporter_thread, child_threads))
  in
  global_state := None;
  List.iter safe_join child_threads;
  Option.iter safe_join reporter_thread

let shutdown () =
  match !global_state with None -> () | Some state -> shutdown_state state

let () = at_exit shutdown

let start_reporter state =
  let loop () =
    if state.running then (
      let first_delay =
        if state.initial_delay_seconds > 0.0 then state.initial_delay_seconds
        else state.refresh_seconds
      in
      if first_delay > 0.0 then Thread.delay first_delay;
      if state.running then flush ();
      while state.running do
        Thread.delay state.refresh_seconds;
        if state.running then flush ()
      done)
  in
  Thread.create loop ()

let init_mode mode =
  match mode with
  | Disabled -> ()
  | Plain -> ()
  | Ansi -> ()
  | WindowsApi -> ()
  | IpcUnixFd _fd -> ()
  | IpcWindowsHandle _handle -> ()

let init ?refresh_rate_ns ?initial_delay_ns ?estimated_total_items ?root_name
    ?disable_printing () =
  match !global_state with
  | Some _ -> Error "Zig progress backend already initialized"
  | None ->
      let disable_printing = Option.value disable_printing ~default:false in
      let max_nodes =
        max 2
          (getenv_int "MLFRONT_PROGRESS_ZIG_MAX_NODES"
             ~default:default_max_nodes)
      in
      let slots = Array.init max_nodes (fun _ -> ZigSlot.zero) in
      slots.(root_id) <-
        ZigSlot.root ~name:(normalize_root root_name) ~no_rollup:false
          ~estimated_total:
            (normalize_count (Option.value estimated_total_items ~default:0))
          ();
      let refresh_seconds =
        match refresh_rate_ns with
        | Some ns -> ns_to_seconds ns
        | None ->
            getenv_float "MLFRONT_PROGRESS_ZIG_REFRESH_SECONDS" ~default:0.1
      in
      let initial_delay_seconds =
        match initial_delay_ns with Some ns -> ns_to_seconds ns | None -> 0.2
      in
      let console, mode = console_mode ~disable_printing () in
      init_mode mode;
      let state =
        {
          mutex = Mutex.create ();
          slots;
          freelist =
            (let rec build acc idx =
               if idx <= root_id then acc else build (idx :: acc) (idx - 1)
             in
             build [] (max_nodes - 1));
          running = true;
          refresh_seconds = max 0.0 refresh_seconds;
          initial_delay_seconds = max 0.0 initial_delay_seconds;
          started_at = Unix.gettimeofday ();
          mode;
          render_config = make_render_config console mode;
          last_output = None;
          last_ansi_lines = 0;
          children = Hashtbl.create 8;
          next_child_id = 0;
          reporter_thread = None;
        }
      in
      global_state := Some state;
      state.reporter_thread <- Some (start_reporter state);
      Ok root_id

let start ?estimated_total ?(no_rollup = false) parent name =
  match !global_state with
  | None ->
      (* since [node] type is abstract, impossible for [start] to occur before the [node]
       constructor function [init] *)
      assert false
  | Some state ->
      with_lock state.mutex (fun () ->
          if parent = ZigSlot.noop_node then ZigSlot.noop_node
          else
            match state.freelist with
            | [] -> ZigSlot.noop_node
            | id :: rest ->
                with_active_slot state parent ~default:ZigSlot.noop_node
                  (fun _parent_slot ->
                    state.freelist <- rest;
                    state.slots.(id) <-
                      {
                        used = true;
                        parent;
                        name = truncate_name name;
                        no_rollup;
                        estimated_total =
                          normalize_count
                            (Option.value estimated_total ~default:0);
                        completed = 0;
                      };
                    id))

let end_ node =
  match !global_state with
  | None -> ()
  | Some state ->
      if node = root_id then shutdown_state state
      else
        with_lock state.mutex (fun () ->
            with_active_slot state node ~default:() (fun slot ->
                with_active_slot state slot.parent ~default:()
                  (fun parent_slot ->
                    if not parent_slot.no_rollup then
                      parent_slot.completed <- parent_slot.completed + 1);
                slot.used <- false;
                slot.parent <- ZigSlot.noop_node;
                state.freelist <- node :: state.freelist))

let complete_one node =
  with_locked_state () (fun state ->
      with_active_slot state node ~default:() (fun slot ->
          slot.completed <- slot.completed + 1))

let set_name node new_name =
  with_locked_state () (fun state ->
      with_active_slot state node ~default:() (fun slot ->
          slot.name <- normalize_name new_name))

let name node =
  with_locked_state None (fun state ->
      with_active_slot state node ~default:None (fun slot ->
          name_option slot.name))

let set_completed_items node count =
  with_locked_state () (fun state ->
      with_active_slot state node ~default:() (fun slot ->
          slot.completed <- normalize_count count))

let completed_items node =
  with_locked_state 0 (fun state ->
      with_active_slot state node ~default:0 (fun slot -> slot.completed))

let unset_estimated_total_items node =
  with_locked_state () (fun state ->
      with_active_slot state node ~default:() (fun slot ->
          slot.estimated_total <- 0))

let set_estimated_total_items node count =
  with_locked_state () (fun state ->
      with_active_slot state node ~default:() (fun slot ->
          slot.estimated_total <- normalize_count count))

let increase_estimated_total_items node count =
  with_locked_state () (fun state ->
      with_active_slot state node ~default:() (fun slot ->
          slot.estimated_total <- slot.estimated_total + normalize_count count))

let start_child_reader state id ~close_reader read_packet =
  Thread.create
    (fun () ->
      Fun.protect ~finally:close_reader (fun () ->
          let rec loop () =
            match read_packet () with
            | None -> ()
            | Some packet ->
                with_lock state.mutex (fun () ->
                    match Hashtbl.find_opt state.children id with
                    | Some (child : child_snapshot) ->
                        child.snapshot <- ZigPacket.parse_packet_slots packet;
                        flush_locked state
                    | None -> ());
                loop ()
          in
          loop ()))
    ()

let prepare_child_process ?(parent = root_id) ~label envmods =
  match !global_state with
  | None -> (envmods, None)
  | Some state ->
  match state.mode with
  | Disabled -> (envmods, None)
  | Plain | Ansi | WindowsApi | IpcUnixFd _ | IpcWindowsHandle _ ->
      let envmods =
        MlFront_Core.EnvMods.remove_names
          [ "MLFRONT_PROGRESS_ZIG_FORCE_LOCAL" ]
          envmods
      in
      if Sys.win32 then (
        let read_handle, write_handle = windows_ipc_create_pipe () in
        let id =
          with_lock state.mutex (fun () ->
              register_child_locked state ~parent ~label)
        in
        let writer = Windows_handle write_handle in
        let reader_thread =
          start_child_reader state id
            ~close_reader:(fun () -> windows_ipc_close read_handle)
            (fun () -> ZigPacket.windows_ipc_read_frame read_handle)
        in
        with_lock state.mutex (fun () ->
            attach_child_locked state id writer reader_thread);
        let envmods =
          MlFront_Core.EnvMods.add "ZIG_PROGRESS"
            (Int64.to_string write_handle)
            envmods
        in
        (envmods, Some { id; writer }))
      else
        let read_fd, write_fd = Unix.pipe ~cloexec:false () in
        Unix.set_close_on_exec read_fd;
        let id =
          with_lock state.mutex (fun () ->
              register_child_locked state ~parent ~label)
        in
        let writer = Unix_fd write_fd in
        let reader_thread =
          start_child_reader state id
            ~close_reader:(fun () -> Unix.close read_fd)
            (fun () -> ZigPacket.read_packet_unix read_fd)
        in
        with_lock state.mutex (fun () ->
            attach_child_locked state id writer reader_thread);
        let envmods =
          MlFront_Core.EnvMods.add "ZIG_PROGRESS"
            (string_of_int (int_of_file_descr write_fd))
            envmods
        in
        (envmods, Some { id; writer })

let finish_child_process { id; writer } =
  match !global_state with
  | None -> close_child_transport writer
  | Some state ->
      let reader_thread =
        with_lock state.mutex (fun () ->
            match Hashtbl.find_opt state.children id with
            | Some (child : child_snapshot) -> detach_child_locked child
            | None -> None)
      in
      Option.iter safe_join reader_thread;
      with_lock state.mutex (fun () ->
          Hashtbl.remove state.children id;
          flush_locked state)