diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index b11507e..9e12037 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -13,7 +13,8 @@ jobs: strategy: matrix: ocaml-compiler: - - ocaml-base-compiler.5.1.1 + - 5.1.1 + - 5.2.0 os: - ubuntu-latest - macos-14 diff --git a/lib/olly_common/cli.ml b/lib/olly_common/cli.ml index 10e0e64..66ace74 100644 --- a/lib/olly_common/cli.ml +++ b/lib/olly_common/cli.ml @@ -34,13 +34,63 @@ let help man_format cmds topic = `Ok (Manpage.print man_format Format.std_formatter page)) let exec_args p = - let doc = - "Executable (and its arguments) to trace. If the executable takes\n\ - \ arguments, wrap quotes around the executable and its \ - arguments.\n\ - \ For example, olly ' ... '." + let exec_and_args, ea_docv = + let doc = "Executable and arguments to trace." in + let docv = "EXECUTABLE" in + (Arg.(value & pos_right (p - 1) string [] & info [] ~docv ~doc), docv) in - Arg.(required & pos p (some string) None & info [] ~docv:"EXECUTABLE" ~doc) + let attach_opt, ao_docv = + let doc = + "Attach to the process with the given PID. The directory containing the \ + PID.events file may be specified. This option cannot be combined with \ + EXECUTABLE." + in + let docv = "[directory:]pid" in + let parser str = + let exception Fail of string in + try + let dir, pid_str = + match String.rindex_opt str ':' with + | None -> (".", str) + | Some idx -> + ( String.sub str 0 idx, + String.sub str (idx + 1) (String.length str - idx - 1) ) + in + let pid = + try int_of_string pid_str + with _ -> + raise (Fail (Printf.sprintf "expected integer pid, got %s" pid_str)) + in + if not @@ Sys.file_exists dir then + raise (Fail (Printf.sprintf "directory %s does not exist" dir)); + if not @@ Sys.is_directory dir then + raise (Fail (Printf.sprintf "file %s is not a directory" dir)); + Ok (dir, pid) + with Fail msg -> Error msg + in + let printer fmt (dir, pid) = + match dir with + | "." -> Format.fprintf fmt "%d" pid + | _ -> Format.fprintf fmt "%s:%d" dir pid + in + let dir_and_pid_conv = Arg.conv' ~docv (parser, printer) in + ( Arg.( + value + & opt (some dir_and_pid_conv) None + & info [ "a"; "attach" ] ~docv ~doc), + docv ) + in + let cat_docvs sep = Printf.sprintf "%s %s --attach=%s" ea_docv sep ao_docv in + let combine dir_and_pid args = + match (args, dir_and_pid) with + | [], Some (dir, pid) -> Ok (Launch.Attach (dir, pid)) + | _ :: _, None -> Ok (Launch.Execute args) + | [], None -> + Error (Printf.sprintf "required %s is missing" (cat_docvs "or")) + | _ -> + Error (Printf.sprintf "more than one of %s specified" (cat_docvs "and")) + in + Term.(term_result' ~usage:true (const combine $ attach_opt $ exec_and_args)) let main name commands = let help_cmd = diff --git a/lib/olly_common/launch.ml b/lib/olly_common/launch.ml index 242dec0..d86c59a 100644 --- a/lib/olly_common/launch.ml +++ b/lib/olly_common/launch.ml @@ -7,8 +7,9 @@ type subprocess = { close : unit -> unit; } -let exec_process exec_args = - let argsl = String.split_on_char ' ' exec_args in +type exec_config = Attach of string * int | Execute of string list + +let exec_process argsl = let executable_filename = List.hd argsl in (* TODO Set the temp directory. We should make this configurable. *) @@ -44,6 +45,21 @@ let exec_process exec_args = in { alive; cursor; close } +let attach_process dir pid = + let cursor = Runtime_events.create_cursor (Some (dir, pid)) in + let alive () = + try + Unix.kill pid 0; + true + with Unix.Unix_error (Unix.ESRCH, _, _) -> false + and close () = Runtime_events.free_cursor cursor in + { alive; cursor; close } + +let launch_process exec_args = + match exec_args with + | Execute argsl -> exec_process argsl + | Attach (dir, pid) -> attach_process dir pid + let collect_events child callbacks = (* Read from the child process *) while child.alive () do @@ -76,10 +92,10 @@ let empty_config = cleanup = (fun () -> ()); } -let olly config exec_args = +let olly config (exec_args : exec_config) = config.init (); Fun.protect ~finally:config.cleanup (fun () -> - let child = exec_process exec_args in + let child = launch_process exec_args in Fun.protect ~finally:child.close (fun () -> let callbacks = let { diff --git a/test/dune b/test/dune index 100c055..1eff51e 100644 --- a/test/dune +++ b/test/dune @@ -23,7 +23,7 @@ (package runtime_events_tools) (deps %{bin:olly} test_gc_stats.exe) (action - (run olly gc-stats "./test_gc_stats.exe 19"))) + (run olly gc-stats ./test_gc_stats.exe 19))) (rule (alias runtest)