diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 86082330092..4093cff331f 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -284,14 +284,14 @@ npm link rescript #### Use Local BSC with Existing ReScript Installation -Alternatively, you can set the `RESCRIPT_BSC_EXE` environment variable to point to your locally compiled `bsc.exe`. +The `rescript` build system has the compiler built in, so to test a local compiler change, link the local package as shown above. + +The Rust build system, `rescript-rust`, still runs `bsc.exe` and accepts the `RESCRIPT_BSC_EXE` environment variable pointing to your locally compiled `bsc.exe`: ```sh -RESCRIPT_BSC_EXE=your-rescript-repo/packages/@rescript/darwin-arm64/bin/bsc.exe npx rescript +RESCRIPT_BSC_EXE=your-rescript-repo/packages/@rescript/darwin-arm64/bin/bsc.exe npx rescript-rust ``` -This will test the local compiler while still using the build system from the installed Node module. - ### Running Automatic Tests We provide different test suites for different levels of the compiler and build system infrastructure. Always make sure to locally build your compiler before running any tests. diff --git a/changes/in-process-compilation.polish.md b/changes/in-process-compilation.polish.md new file mode 100644 index 00000000000..431ec8657cd --- /dev/null +++ b/changes/in-process-compilation.polish.md @@ -0,0 +1 @@ +- Speed up `rescript` builds by compiling modules inside the build system on several CPU cores, instead of starting `bsc` for every file. https://github.com/rescript-lang/rescript/pull/8781 diff --git a/changes/rescript-bsc-exe.breaking.md b/changes/rescript-bsc-exe.breaking.md new file mode 100644 index 00000000000..d3468efe3a7 --- /dev/null +++ b/changes/rescript-bsc-exe.breaking.md @@ -0,0 +1 @@ +- `rescript` compiles with its embedded compiler and ignores `RESCRIPT_BSC_EXE`, which now only affects `rescript-rust`. https://github.com/rescript-lang/rescript/pull/8781 diff --git a/compiler/bsc/build_identity_gen.ml b/compiler/bsc/build_identity_gen.ml new file mode 100644 index 00000000000..41b7debf315 --- /dev/null +++ b/compiler/bsc/build_identity_gen.ml @@ -0,0 +1,38 @@ +let () = + let relevant file = + Filename.basename file = "dune" + || List.exists (Filename.check_suffix file) [".ml"; ".mli"; ".c"; ".h"] + in + let files = + Array.to_list Sys.argv |> List.tl |> List.filter relevant + |> List.sort String.compare + in + let normalize path = + String.map + (function + | '\\' -> '/' + | character -> character) + path + in + let has_suffix suffix = + List.exists + (fun file -> Filename.check_suffix (normalize file) suffix) + files + in + [ + "/flow_parser/parser/expression_parser.ml"; + "/ext/ext_platform_primitives_stubs.c"; + "/ext/platform/native/ext_platform_primitives.ml"; + "/core/platform/native/js_name_of_module_id.ml"; + "/syntax/src/res_driver.ml"; + "/syntax/src/dune"; + ] + |> List.iter (fun suffix -> + if not (has_suffix suffix) then + failwith ("compiler identity is missing required input " ^ suffix)); + let digest = + files + |> List.map (fun file -> file ^ "\000" ^ Digest.file file) + |> String.concat "\000" |> Digest.string + in + Printf.printf "let value = %S\n" (Digest.to_hex digest) diff --git a/compiler/bsc/dune b/compiler/bsc/dune index 0700fd697b6..293ca8709ae 100644 --- a/compiler/bsc/dune +++ b/compiler/bsc/dune @@ -3,10 +3,25 @@ (flags (:standard -ccopt -static)))) +(executable + (name build_identity_gen) + (modules build_identity_gen)) + +(rule + (target rescript_compiler_build_identity.ml) + ; Every compiler source, so code in a new directory is covered. Sources that + ; are not linked into bsc only cause an extra clean rebuild after they change. + (deps + (source_tree ..)) + (action + (with-stdout-to + %{target} + (run ./build_identity_gen.exe %{deps})))) + (library (name rescript_compiler_driver) (wrapped false) - (modules rescript_compiler_driver) + (modules rescript_compiler_driver rescript_compiler_build_identity) (instrumentation (backend bisect_ppx)) (libraries common core depends flow_parser gentype syntax unix)) diff --git a/compiler/bsc/rescript_compiler_driver.ml b/compiler/bsc/rescript_compiler_driver.ml index 49880e5aa79..95b681469c6 100644 --- a/compiler/bsc/rescript_compiler_driver.ml +++ b/compiler/bsc/rescript_compiler_driver.ml @@ -554,6 +554,8 @@ let () = type result = {exit_code: int; stdout: string; stderr: string} +let build_identity = Rescript_compiler_build_identity.value + (* Request_local gives every request the state of a new compiler process. On top of that, a request needs bsc's own defaults, and allocates the shared predefined type graphs in a fixed order: lazy first use on different worker diff --git a/compiler/bsc/rescript_compiler_driver.mli b/compiler/bsc/rescript_compiler_driver.mli index 7b4b189cbf5..c1d611188ef 100644 --- a/compiler/bsc/rescript_compiler_driver.mli +++ b/compiler/bsc/rescript_compiler_driver.mli @@ -1,5 +1,10 @@ type result = {exit_code: int; stdout: string; stderr: string} +val build_identity : string +(** A digest of the compiler implementation linked into this driver. The + standalone compiler and embedded callers therefore use the same identity + without fingerprinting a separately installed executable. *) + val run_request : run_external:(string -> int * string * string) option -> cwd:string -> diff --git a/rewatch-ocaml/README.md b/rewatch-ocaml/README.md index 2230ddb2d25..af62cd8677c 100644 --- a/rewatch-ocaml/README.md +++ b/rewatch-ocaml/README.md @@ -7,8 +7,10 @@ implementation in [`../rewatch`](../rewatch) ships next to it as `rescript-rust`, and both are tested with the shared integration suite in [`../rewatch/tests`](../rewatch/tests). -The port follows Rust rewatch's architecture and algorithms. Every parse and -compile runs `bsc` as a separate process. +The port follows Rust rewatch's architecture and algorithms, but it links the +compiler in: parses and compiles run in-process on a pool of OCaml domains +rather than as `bsc` subprocesses (see +[In-process compilation](#in-process-compilation)). ## Building and running @@ -20,16 +22,20 @@ make # builds bsc and packages/@rescript/ close_in_noerr channel) (fun () -> - (try ignore (input_line channel) with End_of_file -> ()); - let rec loop dependencies = - match input_line channel with - | line -> - let line = String.trim line in - if line = "" then loop dependencies - else if Filename.is_relative line then loop (line :: dependencies) - else {dependencies = List.rev dependencies; source = Some line} - | exception End_of_file -> - {dependencies = List.rev dependencies; source = None} + (* The first four bytes give the exact length of the newline-delimited + dependency block. The following source path can itself be relative; + scanning until an absolute path would read the marshalled AST. *) + let read_header () = + let dependency_length = input_binary_int channel in + (* Checked before allocating: a damaged length can claim gigabytes. *) + if + dependency_length < 0 + || dependency_length > in_channel_length channel - pos_in channel + then raise End_of_file; + let dependencies = + really_input_string channel dependency_length + |> String.split_on_char '\n' + |> List.filter (fun name -> name <> "") + in + let source = try Some (input_line channel) with End_of_file -> None in + {dependencies; source} in - loop []) + (* A damaged AST, such as one cut short by a killed build, has no usable + header: it ends early or gives an impossible length. Like a missing + AST, it makes the module parse again. *) + try read_header () + with End_of_file | Invalid_argument _ -> + {dependencies = []; source = None}) diff --git a/rewatch-ocaml/ast_header.mli b/rewatch-ocaml/ast_header.mli index 3c41db44d24..8a39f988ff8 100644 --- a/rewatch-ocaml/ast_header.mli +++ b/rewatch-ocaml/ast_header.mli @@ -1,7 +1,7 @@ type t = {dependencies: string list; source: string option} (** Published AST headers are read without deserializing the compiler's full AST. Cleanup needs the original source path, while graph construction needs only - dependency names; keeping one reader prevents those wire-format rules from - drifting. *) + dependency names. The encoded dependency byte length separates those names + from either an absolute or a relative source path and the marshalled AST. *) val read : string -> t diff --git a/rewatch-ocaml/bench/README.md b/rewatch-ocaml/bench/README.md index 747a1a42977..b0ae7945a25 100644 --- a/rewatch-ocaml/bench/README.md +++ b/rewatch-ocaml/bench/README.md @@ -82,6 +82,14 @@ that a differently-cased recreated CMI exists to `stat` and then return `ENOENT` from the immediately following `open`; that host-filesystem artifact is not valid scheduler or benchmark evidence. The harness's default `mktemp` workspace normally stays on the container filesystem. + +The OCaml implementation compiles in-process, so it has no compiler `execve` +to trace. The gate counts its compiler requests from the log it writes when +`REWATCH_COMPILER_CALL_LOG` is set, and still traces PPXs as processes. +`RESCRIPT_BSC_EXE` only selects Rust's compiler; the OCaml executable uses the +compiler linked into it, so build both from the same checkout. Set +`REWATCH_COMPILER_DOMAINS` to measure a specific number of compiler workers. + Set `REWATCH_PERFORMANCE_THRESHOLD_PERCENT` to change the 125% threshold. Set `KEEP_REWATCH_BENCHMARK_WORKDIR=1` to retain traces and raw stdout/stderr for investigation. For a quick correctness-only check, an odd run count below five is accepted only with `REWATCH_ALLOW_SMOKE_RUN=1`; its timing @@ -100,8 +108,11 @@ rewatch-ocaml/bench/watch_performance_gate.sh \ ``` It warms both implementations, interleaves an odd number of timed edits, -requires byte-identical generated JavaScript and normalized parser/compiler -argument logs, and samples file descriptors, tasks, and RSS after every build. +requires byte-identical generated JavaScript and equal parser/compiler work +counts (Rust's through the counting `bsc` proxy, OCaml's through +`REWATCH_COMPILER_CALL_LOG`), and samples file descriptors, tasks, and RSS after +every build. Set `REWATCH_WATCH_COMPILER_DOMAINS` to run the OCaml watcher with +a specific number of compiler workers. This catches retained-state implementations that appear fast by skipping work, as well as resource growth that a single build cannot show. The default median-latency limit is 150% of Rust because individual watch events diff --git a/rewatch-ocaml/bench/performance_gate.sh b/rewatch-ocaml/bench/performance_gate.sh index 4118d7fc651..b9aa48e9421 100755 --- a/rewatch-ocaml/bench/performance_gate.sh +++ b/rewatch-ocaml/bench/performance_gate.sh @@ -89,10 +89,11 @@ tree_resources() { for (pass = 0; pass < NR; pass++) for (i = 1; i <= NR; i++) if (live[parent[pids[i]]]) live[pids[i]] = 1 - for (pid in live) { - total_memory += memory[pid] - total_tasks += tasks[pid] - } + for (pid in live) + if (live[pid]) { + total_memory += memory[pid] + total_tasks += tasks[pid] + } print total_memory + 0, total_tasks + 0 }' } @@ -171,20 +172,35 @@ trace_and_classify() { local implementation=$1 scenario=$2 executable=$3 fixture=$4 manifest=$5 local clean_first=$6 local trace_prefix="$work_root/${implementation}-${scenario}.execve" + local call_log="$work_root/${implementation}-${scenario}.compiler" if [[ "$clean_first" == 1 ]]; then "$executable" clean "$fixture" >/dev/null 2>&1 fi - strace -f -ff -qq -s 4096 -e trace=execve,chdir -o "$trace_prefix" \ - "$executable" build "$fixture" \ - >"$work_root/${implementation}-${scenario}-trace.out" \ - 2>"$work_root/${implementation}-${scenario}-trace.stderr" + if [[ $implementation == ocaml ]]; then + # Embedded requests have no compiler execve. Record them at their shared + # logical boundary while tracing PPXs as external processes. + strace -f -ff -qq -s 4096 -e trace=execve,chdir -o "$trace_prefix" \ + env REWATCH_COMPILER_CALL_LOG="$call_log" \ + "$executable" build "$fixture" \ + >"$work_root/${implementation}-${scenario}-trace.out" \ + 2>"$work_root/${implementation}-${scenario}-trace.stderr" + else + strace -f -ff -qq -s 4096 -e trace=execve,chdir -o "$trace_prefix" \ + "$executable" build "$fixture" \ + >"$work_root/${implementation}-${scenario}-trace.out" \ + 2>"$work_root/${implementation}-${scenario}-trace.stderr" + fi local trace_files=("$trace_prefix".*) local implementation_root=${fixture%/rewatch/testrepo} local trace_file exec_line argv cwd_line cwd phase input identity : >"$manifest.unsorted" for trace_file in "${trace_files[@]}"; do - exec_line=$(grep -m1 -F "execve(\"$RESCRIPT_BSC_EXE\"" "$trace_file" \ - || grep -m1 -E 'execve\("[^"]*sury-ppx' "$trace_file" || true) + if [[ $implementation == ocaml ]]; then + exec_line=$(grep -m1 -E 'execve\("[^"]*sury-ppx' "$trace_file" || true) + else + exec_line=$(grep -m1 -F "execve(\"$RESCRIPT_BSC_EXE\"" "$trace_file" \ + || grep -m1 -E 'execve\("[^"]*sury-ppx' "$trace_file" || true) + fi if [[ -z "$exec_line" ]]; then continue fi @@ -193,7 +209,7 @@ trace_and_classify() { cwd_line=$(grep -m1 '^chdir("' "$trace_file" || true) cwd=${cwd_line#chdir(\"} cwd=${cwd%%\"*} - if [[ "$exec_line" == *"execve(\"$RESCRIPT_BSC_EXE\""* ]]; then + if [[ $implementation == rust && "$exec_line" == *"execve(\"$RESCRIPT_BSC_EXE\""* ]]; then if [[ "$argv" == *'"-bs-ast"'* ]]; then phase=parse elif [[ "$argv" == *'.mlmap"'* ]]; then @@ -205,24 +221,35 @@ trace_and_classify() { input=${input%]} identity="$cwd"$'\t'"$phase"$'\t'"$input" else - # PPX temporary input/output names are deliberately randomized. Its - # executable identity and count are the stable unit of work. + # PPX temporary input/output names are deliberately randomized. identity=ppx$'\t'"${argv%%,*}" fi printf '%s\n' "$identity" \ | sed "s#$implementation_root##g" >>"$manifest.unsorted" done - sort "$manifest.unsorted" >"$manifest" local invocations parse namespace compile interface ppx - invocations=$(grep -hF -c "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ - | awk '{ total += $1 } END { print total + 0 }') - parse=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ - | grep -F -c '"-bs-ast"' || true) - namespace=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ - | grep -E -c '\.mlmap"' || true) - interface=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ - | grep -vF '"-bs-ast"' | grep -vE '\.mlmap"' \ - | grep -E -c '\.iast"' || true) + if [[ $implementation == ocaml ]]; then + while IFS=$'\t' read -r phase cwd input; do + if [[ $phase != parse && $phase != namespace ]]; then phase=compile; fi + printf '%s\t%s\t"%s"\n' "$cwd" "$phase" "$input" \ + | sed "s#$implementation_root##g" >>"$manifest.unsorted" + done <"$call_log" + invocations=$(wc -l <"$call_log") + parse=$(awk -F '\t' '$1 == "parse" { n++ } END { print n+0 }' "$call_log") + namespace=$(awk -F '\t' '$1 == "namespace" { n++ } END { print n+0 }' "$call_log") + interface=$(awk -F '\t' '$1 == "interface" { n++ } END { print n+0 }' "$call_log") + else + invocations=$(grep -hF -c "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ + | awk '{ total += $1 } END { print total + 0 }') + parse=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ + | grep -F -c '"-bs-ast"' || true) + namespace=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ + | grep -E -c '\.mlmap"' || true) + interface=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ + | grep -vF '"-bs-ast"' | grep -vE '\.mlmap"' \ + | grep -E -c '\.iast"' || true) + fi + sort "$manifest.unsorted" >"$manifest" compile=$((invocations - parse - namespace)) ppx=$(grep -hE -c 'execve\("[^"]*sury-ppx' "${trace_files[@]}" \ | awk '{ total += $1 } END { print total + 0 }') diff --git a/rewatch-ocaml/bench/watch_performance_gate.sh b/rewatch-ocaml/bench/watch_performance_gate.sh index b21f38c5307..3643b0d0e6e 100755 --- a/rewatch-ocaml/bench/watch_performance_gate.sh +++ b/rewatch-ocaml/bench/watch_performance_gate.sh @@ -139,16 +139,31 @@ start_watcher() { fixture="$work_root/$implementation" cp -R "$repo_root/rewatch-ocaml/tests/basic" "$fixture" : >"$work_root/$implementation.bsc" - setsid env \ - RESCRIPT_BSC_EXE="$counting_bsc" \ - REWATCH_BSC_PROXY_MODE=counting \ - RESCRIPT_RUNTIME="$runtime" \ - REWATCH_REAL_BSC="$real_bsc" \ - REWATCH_BSC_CALL_LOG="$work_root/$implementation.bsc" \ - REWATCH_WATCH_MARKER="$work_root/$implementation.marker" \ - "$executable" watch --after-build "node $marker_script" "$fixture" \ - >"$work_root/$implementation.stdout" \ - 2>"$work_root/$implementation.stderr" & + : >"$work_root/$implementation.compiler" + if [[ $implementation == ocaml ]]; then + local -a domain_count_env=() + if [[ ${REWATCH_WATCH_COMPILER_DOMAINS+x} ]]; then + domain_count_env=(REWATCH_COMPILER_DOMAINS="$REWATCH_WATCH_COMPILER_DOMAINS") + fi + setsid env \ + RESCRIPT_RUNTIME="$runtime" \ + "${domain_count_env[@]}" \ + REWATCH_COMPILER_CALL_LOG="$work_root/$implementation.compiler" \ + REWATCH_WATCH_MARKER="$work_root/$implementation.marker" \ + "$executable" watch --after-build "node $marker_script" "$fixture" \ + >"$work_root/$implementation.stdout" \ + 2>"$work_root/$implementation.stderr" & + else + setsid env \ + RESCRIPT_BSC_EXE="$counting_bsc" \ + RESCRIPT_RUNTIME="$runtime" \ + REWATCH_REAL_BSC="$real_bsc" \ + REWATCH_BSC_CALL_LOG="$work_root/$implementation.bsc" \ + REWATCH_WATCH_MARKER="$work_root/$implementation.marker" \ + "$executable" watch --after-build "node $marker_script" "$fixture" \ + >"$work_root/$implementation.stdout" \ + 2>"$work_root/$implementation.stderr" & + fi pids[$implementation]=$! wait_for_lines "$work_root/$implementation.marker" 1 wait_for_text_count "$work_root/$implementation.stdout" \ @@ -169,6 +184,7 @@ for implementation in rust ocaml; do "Finished incremental compilation" 1 wait_for_idle "${pids[$implementation]}" : >"$work_root/$implementation.bsc" + : >"$work_root/$implementation.compiler" done declare -A baseline_fd baseline_tasks baseline_rss max_fd max_tasks max_rss @@ -227,27 +243,20 @@ median() { rust_median=$(median "$work_root/rust.latencies") ocaml_median=$(median "$work_root/ocaml.latencies") -normalize_calls() { - local implementation=$1 - sed "s#$work_root/$implementation##g" \ - "$work_root/$implementation.bsc" >"$work_root/$implementation.bsc.normalized" -} -normalize_calls rust -normalize_calls ocaml -if ! cmp -s "$work_root/rust.bsc.normalized" \ - "$work_root/ocaml.bsc.normalized"; then - echo "Rust and OCaml retained edits performed different compiler work." >&2 +rust_parse_count=$(grep -cF -- '-bs-ast' "$work_root/rust.bsc" || true) +rust_total_count=$(wc -l <"$work_root/rust.bsc") +ocaml_parse_count=$(grep -c '^parse' "$work_root/ocaml.compiler" || true) +ocaml_compile_count=$(grep -c '^implementation' \ + "$work_root/ocaml.compiler" || true) +ocaml_total_count=$(wc -l <"$work_root/ocaml.compiler") +if ((rust_parse_count != runs || rust_total_count != runs * 2 || + ocaml_parse_count != runs || ocaml_compile_count != runs || + ocaml_total_count != runs * 2)); then + printf 'retained work mismatch: Rust %d parser / %d total; embedded OCaml %d parser / %d compiler / %d total; expected %d / %d.\n' \ + "$rust_parse_count" "$rust_total_count" "$ocaml_parse_count" \ + "$ocaml_compile_count" "$ocaml_total_count" "$runs" "$((runs * 2))" >&2 exit 1 fi -for implementation in rust ocaml; do - parse_count=$(grep -cF -- '-bs-ast' "$work_root/$implementation.bsc" || true) - total_count=$(wc -l <"$work_root/$implementation.bsc") - if ((parse_count != runs || total_count != runs * 2)); then - printf '%s retained work was %d parser / %d total calls; expected %d / %d.\n' \ - "$implementation" "$parse_count" "$total_count" "$runs" "$((runs * 2))" >&2 - exit 1 - fi -done for implementation in rust ocaml; do pid=${pids[$implementation]} diff --git a/rewatch-ocaml/build.ml b/rewatch-ocaml/build.ml index 824f0472361..e2bad1f4e40 100644 --- a/rewatch-ocaml/build.ml +++ b/rewatch-ocaml/build.ml @@ -78,8 +78,10 @@ let run_namespace_jobs (attempt : Build_attempt.t) = attempt.parse_seconds +. (Unix.gettimeofday () -. started_at)) (fun () -> let results = - Process.run_parallel ?poll:attempt.process_poll - (List.map (fun job -> job.Build_attempt.job) jobs) + Process.run_tasks + ~max_jobs:(Compiler_execution_mode.configured_count ()) + ?poll:attempt.process_poll + (List.map (fun job -> job.Build_attempt.task) jobs) in List.iter2 (fun job result -> job.Build_attempt.finish result) @@ -138,7 +140,6 @@ let prepare_incremental previous changes (attempt : Build_attempt.t) affected modules' dependency edges in memory. This keeps the long-lived graph coherent without rediscovering the package tree. *) let sources = incremental_sources previous changes in - let bsc = prepared.compiler_context.bsc_path in let started_at = Unix.gettimeofday () in List.iter (fun source -> @@ -162,10 +163,12 @@ let prepare_incremental previous changes (attempt : Build_attempt.t) sources) in let results = - Process.run_parallel_map ?poll:attempt.process_poll - ~on_complete:parse_completed sources ~job:(fun source -> - Compiler_process.parse_job ~bsc ~build_dir:source.package.build_dir + sources + |> List.map (fun source -> + Compiler_process.parse_request ~build_dir:source.package.build_dir ~config:source.package.compile_config source.source.relative_path) + |> Compiler_process.run_requests ?poll:attempt.process_poll + ~on_complete:parse_completed in let affected_modules = Hashtbl.create (List.length sources) in let dependency_updates = ref [] in diff --git a/rewatch-ocaml/build_attempt.ml b/rewatch-ocaml/build_attempt.ml index 61bdbd19a8a..9fcc0890ffc 100644 --- a/rewatch-ocaml/build_attempt.ml +++ b/rewatch-ocaml/build_attempt.ml @@ -18,7 +18,7 @@ let preliminary_parse result = if Process.succeeded result then Parsed_successfully {stderr = result.stderr} else Parse_failed {stdout = result.stdout; stderr = result.stderr} -type namespace_job = {job: Process.job; finish: Process.result -> unit} +type namespace_job = {task: Process.task; finish: Process.result -> unit} type pending_work = { mutable namespace_jobs: namespace_job list; diff --git a/rewatch-ocaml/build_attempt.mli b/rewatch-ocaml/build_attempt.mli index 11fcfe99607..db40bf19f1a 100644 --- a/rewatch-ocaml/build_attempt.mli +++ b/rewatch-ocaml/build_attempt.mli @@ -17,7 +17,7 @@ type preliminary_parse = val preliminary_parse : Process.result -> preliminary_parse -type namespace_job = {job: Process.job; finish: Process.result -> unit} +type namespace_job = {task: Process.task; finish: Process.result -> unit} type pending_work type finalization_state diff --git a/rewatch-ocaml/build_lock.mli b/rewatch-ocaml/build_lock.mli index 593aee79e40..28d4095673d 100644 --- a/rewatch-ocaml/build_lock.mli +++ b/rewatch-ocaml/build_lock.mli @@ -13,6 +13,7 @@ val with_build : ([attempts] times 50 ms). *) val with_watch : string -> (watch -> 'a) -> 'a + val is_owned : watch -> bool module For_test : sig diff --git a/rewatch-ocaml/build_preparation.ml b/rewatch-ocaml/build_preparation.ml index cdae985d7c8..ea098117693 100644 --- a/rewatch-ocaml/build_preparation.ml +++ b/rewatch-ocaml/build_preparation.ml @@ -5,8 +5,11 @@ type result = { cycle: Module_graph.cycle_info option; } -let bsc_path () = - try Toolchain.bsc () with Toolchain.Error message -> raise (Error message) +let bundled_bsc_path root = + try + Toolchain.bundled_bsc ~cwd:(Sys.getcwd ()) ~executable:Sys.executable_name + ~root ~find_package:Project_context.dependency_path + with Toolchain.Error message -> raise (Error message) let runtime_path root = try Toolchain.runtime ~find_package:(Project_context.dependency_path root) @@ -14,7 +17,6 @@ let runtime_path root = let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch ~(attempt : Build_attempt.t) ~parse_step ~on_cleanup = - let bsc = bsc_path () in let workspace_config = Project_context.workspace_config_for root_config in let package_plans = Package_graph.discover ~root_config ~workspace_config ~prod ~features @@ -24,7 +26,9 @@ let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch let runtime = runtime_path root_config.root in let source_map_args = Compiler_args.source_map_args workspace_config ~watch in let compiler_context = - Compiler_info.make_context ~bsc_path:bsc ~runtime_path:runtime + Compiler_info.make_context + ~compiler_path:(bundled_bsc_path root_config.root) + ~compiler_identity:Compiler_process.build_identity ~runtime_path:runtime ~source_map_args ~inherited_compiler_args: (workspace_config.jsx_args @ workspace_config.experimental_args) @@ -182,11 +186,12 @@ let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch (List.map (fun (_, _, group) -> group) parse_entries) in let parse_results = - Process.run_parallel_map ?poll:attempt.process_poll - ~on_complete:parse_completed parse_entries - ~job:(fun ((package : Package_plan.t), path, _) -> - Compiler_process.parse_job ~bsc ~build_dir:package.build_dir + parse_entries + |> List.map (fun ((package : Package_plan.t), path, _) -> + Compiler_process.parse_request ~build_dir:package.build_dir ~config:package.compile_config path) + |> Compiler_process.run_requests ?poll:attempt.process_poll + ~on_complete:parse_completed in let failed_parse_paths = Hashtbl.create 8 in List.iter2 diff --git a/rewatch-ocaml/compiler_execution_mode.ml b/rewatch-ocaml/compiler_execution_mode.ml new file mode 100644 index 00000000000..2c9d4a40295 --- /dev/null +++ b/rewatch-ocaml/compiler_execution_mode.ml @@ -0,0 +1,19 @@ +let max_domain_count = max 12 Process.default_max_jobs + +(* Leave a CPU for dependency scheduling and artifact publication. The cap is + provisional: gains flattened around eight workers on the Linux fixture. *) +let recommended_domain_count available_cpus = min 8 (max 1 (available_cpus - 1)) + +(* A count above the machine's limit is lowered to it, so one setting works on + machines with different CPU counts. *) +let configured_count () = + match Sys.getenv_opt "REWATCH_COMPILER_DOMAINS" with + | None -> recommended_domain_count (Domain.recommended_domain_count ()) + | Some value -> ( + match int_of_string_opt (String.trim value) with + | Some count when count >= 1 -> min count max_domain_count + | _ -> + raise + (Process.Error + ("REWATCH_COMPILER_DOMAINS must be a positive integer, got " ^ value)) + ) diff --git a/rewatch-ocaml/compiler_execution_mode.mli b/rewatch-ocaml/compiler_execution_mode.mli new file mode 100644 index 00000000000..b59f000d2b8 --- /dev/null +++ b/rewatch-ocaml/compiler_execution_mode.mli @@ -0,0 +1,3 @@ +val max_domain_count : int +val recommended_domain_count : int -> int +val configured_count : unit -> int diff --git a/rewatch-ocaml/compiler_info.ml b/rewatch-ocaml/compiler_info.ml index 859f37ea1c8..46374dca79b 100644 --- a/rewatch-ocaml/compiler_info.ml +++ b/rewatch-ocaml/compiler_info.ml @@ -25,11 +25,11 @@ let package_output_specs (config : Config.t) = }) config.package_specs -let make_context ~bsc_path ~runtime_path ~source_map_args - ~inherited_compiler_args ~package_output_specs = +let make_context ~compiler_path ~compiler_identity ~runtime_path + ~source_map_args ~inherited_compiler_args ~package_output_specs = { - bsc_path; - bsc_hash = Digest.file bsc_path |> Digest.to_hex; + bsc_path = compiler_path; + bsc_hash = compiler_identity; runtime_path; source_map_args; inherited_compiler_args; diff --git a/rewatch-ocaml/compiler_info.mli b/rewatch-ocaml/compiler_info.mli index a638f1059b5..09a81a45540 100644 --- a/rewatch-ocaml/compiler_info.mli +++ b/rewatch-ocaml/compiler_info.mli @@ -20,7 +20,8 @@ and package_output_spec = { val package_output_specs : Config.t -> package_output_spec list val make_context : - bsc_path:string -> + compiler_path:string -> + compiler_identity:string -> runtime_path:string -> source_map_args:string list -> inherited_compiler_args:string list -> diff --git a/rewatch-ocaml/compiler_process.ml b/rewatch-ocaml/compiler_process.ml index 82b07ec1050..fb4117fd7da 100644 --- a/rewatch-ocaml/compiler_process.ml +++ b/rewatch-ocaml/compiler_process.ml @@ -8,7 +8,103 @@ let retain_critical_external_warnings stderr = |> List.filter (fun block -> String_util.contains block marker) |> String.concat "\n\n\n" -let parse_job ~bsc ~build_dir ~(config : Config.t) path = +let build_identity = Rescript_compiler_driver.build_identity + +type request = {args: string list; cwd: string} + +let compiler_phase args = + let input = + match List.rev args with + | input :: _ -> input + | [] -> "" + in + let phase = + if List.mem "-bs-ast" args then "parse" + else if Filename.check_suffix input ".mlmap" then "namespace" + else if Filename.check_suffix input ".iast" then "interface" + else "implementation" + in + (phase, input) + +let log_compiler_request (request : request) = + match Sys.getenv_opt "REWATCH_COMPILER_CALL_LOG" with + | None -> () + | Some path -> + let phase, input = compiler_phase request.args in + let channel = + open_out_gen [Open_creat; Open_append; Open_text] 0o644 path + in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> Printf.fprintf channel "%s\t%s\t%s\n" phase request.cwd input) + +let exit_code = function + | Unix.WEXITED code -> code + | Unix.WSIGNALED signal | Unix.WSTOPPED signal -> 128 + signal + +let run_in_process ?poll (request : request) = + log_compiler_request request; + match List.rev request.args with + | [] -> + { + Process.status = Unix.WEXITED 2; + stdout = ""; + stderr = "missing compiler input"; + } + | input :: reversed_argv -> ( + match + Rescript_compiler_driver.run_request ~cwd:request.cwd + ~argv:(List.rev reversed_argv) ~input + ~run_external: + (Some + (fun command -> + let command = Platform.shell_command command in + let result = + Process.run ?poll ~cwd:request.cwd command.program command.args + in + (exit_code result.status, result.stdout, result.stderr))) + with + | result -> + { + Process.status = Unix.WEXITED result.exit_code; + stdout = result.stdout; + stderr = result.stderr; + } + | exception + Compiler_request_output.Failed {error = Process.Interrupted _ as error} + -> + raise error + | exception Compiler_request_output.Failed {error; stdout; stderr} -> + (* Keep the warnings written before the failure. *) + { + Process.status = Unix.WEXITED 2; + stdout; + stderr = stderr ^ Printexc.to_string error ^ "\n"; + }) + +let run ?poll request = + Option.iter (fun poll -> poll ()) poll; + let result = run_in_process ?poll request in + Option.iter (fun poll -> poll ()) poll; + result + +let task request = + let cancelled = Atomic.make false in + Process.concurrent_task + ~cancel:(fun () -> Atomic.set cancelled true) + (fun () -> + run_in_process + ~poll:(fun () -> + if Atomic.get cancelled then raise (Process.Interrupted 15)) + request) + +let run_requests ?poll ?on_complete requests = + requests |> List.map task + |> Process.run_tasks + ~max_jobs:(Compiler_execution_mode.configured_count ()) + ?poll ?on_complete + +let parse_request ~build_dir ~(config : Config.t) path = let ast = Source.ast_path path in File_util.ensure_dir (Filename.concat build_dir (Filename.dirname ast)); let contents = @@ -16,7 +112,7 @@ let parse_job ~bsc ~build_dir ~(config : Config.t) path = else File_util.read_file (Filename.concat config.root path) in let args = Compiler_args.parser_arguments ~config ~contents ~path in - Process.{program = bsc; args; cwd = build_dir} + {args; cwd = build_dir} let ast_dependencies ~build_dir ast = (Ast_header.read (Filename.concat build_dir ast)).dependencies @@ -52,8 +148,8 @@ let publish_compiler_artifacts ~artifact_dir ~ocaml_dir ~basename artifacts = with error -> raise (Compiler_scheduler.Publication_failure (error, !cmi_change)) -let namespace_task ~bsc ~runtime ~build_dir ~ocaml_dir ~entry ~package_dirty - ~force namespace modules = +let namespace_task ~runtime ~build_dir ~ocaml_dir ~entry ~package_dirty ~force + namespace modules = let mlmap = Filename.concat build_dir (namespace ^ ".mlmap") in let contents = let buffer = Buffer.create 128 in @@ -95,10 +191,9 @@ let namespace_task ~bsc ~runtime ~build_dir ~ocaml_dir ~entry ~package_dirty Some Compiler_scheduler. { - job = - Process. + task = + task { - program = bsc; args = [ "-runtime-path"; @@ -148,7 +243,7 @@ let post_build_tasks (config : Config.t) path = }) config.package_specs -let compile_job ~bsc ~build_dir ~(config : Config.t) ~common_args +let compile_request ~build_dir ~(config : Config.t) ~common_args (module_ : Source.module_) ~source_kind path = let args = Compiler_args.compiler_arguments_with_common ~config ~common_args @@ -156,7 +251,7 @@ let compile_job ~bsc ~build_dir ~(config : Config.t) ~common_args ~has_interface:(Option.is_some module_.interface) ~path in - Process.{program = bsc; args; cwd = build_dir} + {args; cwd = build_dir} let publish ~build_dir ~ocaml_dir ~is_local ~(config : Config.t) ~has_interface ~source_kind path result = diff --git a/rewatch-ocaml/compiler_process.mli b/rewatch-ocaml/compiler_process.mli index 38844006632..3a55794eaac 100644 --- a/rewatch-ocaml/compiler_process.mli +++ b/rewatch-ocaml/compiler_process.mli @@ -1,10 +1,21 @@ val retain_critical_external_warnings : string -> string -val parse_job : - bsc:string -> build_dir:string -> config:Config.t -> string -> Process.job +val build_identity : string + +type request = {args: string list; cwd: string} +(** A request for the embedded compiler: [bsc]'s arguments, ending with the + input file, and the directory it runs in. *) + +val parse_request : build_dir:string -> config:Config.t -> string -> request val ast_dependencies : build_dir:string -> string -> string list +val run : ?poll:(unit -> unit) -> request -> Process.result +val run_requests : + ?poll:(unit -> unit) -> + ?on_complete:(int -> unit) -> + request list -> + Process.result list +val task : request -> Process.task val namespace_task : - bsc:string -> runtime:string -> build_dir:string -> ocaml_dir:string -> @@ -15,15 +26,14 @@ val namespace_task : Source.module_ list -> Compiler_scheduler.namespace_task option -val compile_job : - bsc:string -> +val compile_request : build_dir:string -> config:Config.t -> common_args:string list -> Source.module_ -> source_kind:Source.source_kind -> string -> - Process.job + request val post_build_tasks : Config.t -> string -> Compiler_scheduler.post_build_task list diff --git a/rewatch-ocaml/compiler_scheduler.ml b/rewatch-ocaml/compiler_scheduler.ml index 18cc1523de1..7d2e1a9dbdb 100644 --- a/rewatch-ocaml/compiler_scheduler.ml +++ b/rewatch-ocaml/compiler_scheduler.ml @@ -8,7 +8,7 @@ exception Publication_failure of exn * cmi_change type publish_result = {stderr: string; cmi_change: cmi_change} type namespace_task = { - job: Process.job; + task: Process.task; publish: Process.result -> publish_result; } type post_build_task = {output: string; task: Process.task} @@ -44,7 +44,7 @@ type scheduled_module = { cmi_path: string; publication: publication option Atomic.t; prepare: unit -> unit; - compile: source_kind:Source.source_kind -> string -> Process.job; + compile: source_kind:Source.source_kind -> string -> Process.task; publish: source_kind:Source.source_kind -> string -> Process.result -> publish_result; record_published_outputs: source_kind:Source.source_kind -> string -> unit; @@ -202,6 +202,16 @@ let run ~poll ~warning_state ~compile_assets ~build_state ~candidates Publication_failed (Printexc.to_string error) | None -> No_publication in + let publish_compilation (scheduled : scheduled_module) ~source_kind path + result = + (if Process.succeeded result then + let publication = + capture_publication (fun () -> + scheduled.publish ~source_kind path result) + in + Atomic.set scheduled.publication (Some publication)); + result + in let record_result (scheduled : scheduled_module) ~source_kind path result = let result, publication_error = match record_publication scheduled ~source_kind path with @@ -238,17 +248,14 @@ let run ~poll ~warning_state ~compile_assets ~build_state ~candidates message; Option.is_none message in + (* The worker that compiled a module also publishes its artifacts, which + only touches that module's files: dependents are scheduled after its result + is recorded. Build-state updates stay on this scheduler domain. A stop + cancels a compile before publication starts, never during it. *) let compilation_task (scheduled : scheduled_module) ~source_kind path = - let job = scheduled.compile ~source_kind path in + let task = scheduled.compile ~source_kind path in Atomic.set scheduled.publication None; - Process.task job ~on_result:(fun result -> - (if Process.succeeded result then - let publication = - capture_publication (fun () -> - scheduled.publish ~source_kind path result) - in - Atomic.set scheduled.publication (Some publication)); - result) + Process.map_result task (publish_compilation scheduled ~source_kind path) in let record_post_build_result (scheduled : scheduled_module) output result = if Process.succeeded result then ( @@ -320,12 +327,11 @@ let run ~poll ~warning_state ~compile_assets ~build_state ~candidates in let () = try - Process.run_dependency_graph ?poll + let max_jobs = Compiler_execution_mode.configured_count () in + Process.run_dependency_graph ~max_jobs ?poll works - (* Rust's parallel scheduler may already have independent work in - flight when a module fails. Finish all ready, independent work here - so the same diagnostics do not depend on the host's worker count; - dependents of the failed module remain blocked. *) + (* Finish ready independent work after a module failure; dependents of + the failed module remain blocked. Interruptions still abort. *) ~on_failure:(function | Module_failed -> Process.Continue_independent_work | _ -> Process.Abort_immediately) diff --git a/rewatch-ocaml/compiler_scheduler.mli b/rewatch-ocaml/compiler_scheduler.mli index 2d3c31858fe..3038a5b2b21 100644 --- a/rewatch-ocaml/compiler_scheduler.mli +++ b/rewatch-ocaml/compiler_scheduler.mli @@ -12,7 +12,7 @@ exception Publication_failure of exn * cmi_change type publish_result = {stderr: string; cmi_change: cmi_change} type namespace_task = { - job: Process.job; + task: Process.task; publish: Process.result -> publish_result; } type post_build_task = {output: string; task: Process.task} @@ -36,7 +36,7 @@ val create : state:Build_state.module_ -> cmi_path:string -> prepare:(unit -> unit) -> - compile:(source_kind:Source.source_kind -> string -> Process.job) -> + compile:(source_kind:Source.source_kind -> string -> Process.task) -> publish: (source_kind:Source.source_kind -> string -> diff --git a/rewatch-ocaml/dune b/rewatch-ocaml/dune index a2faebbeaf8..d0d3cc15251 100644 --- a/rewatch-ocaml/dune +++ b/rewatch-ocaml/dune @@ -17,9 +17,18 @@ (action (copy platform_unix.ml platform.ml))) +(rule + (target build_platform.ml) + (action + (with-stdout-to + %{target} + (progn + (echo "let system = \"%{system}\"\n") + (echo "let architecture = \"%{architecture}\"\n"))))) + (library (name rewatch_ocaml_lib) - (wrapped false) + (wrapped true) (modules rewatch_version string_util @@ -48,6 +57,7 @@ compiler_args_command compiler_log ast_header + compiler_execution_mode compiler_process compiler_scheduler after_build @@ -69,6 +79,7 @@ watch_scope watch_snapshot watcher + build_platform toolchain compiler_info source_dirs @@ -76,7 +87,16 @@ output build format) - (libraries unix threads yojson str spawn cmdliner luv re.perl) + (libraries + unix + threads + yojson + str + spawn + cmdliner + luv + re.perl + rescript_compiler_driver) (foreign_stubs (language c) (names windows_job_stubs))) @@ -84,4 +104,6 @@ (executable (name rescript_ocaml) (modules rescript_ocaml) + (flags + (:standard -open Rewatch_ocaml_lib)) (libraries rewatch_ocaml_lib)) diff --git a/rewatch-ocaml/format.ml b/rewatch-ocaml/format.ml index f63f9291bbd..a79bfb5740c 100644 --- a/rewatch-ocaml/format.ml +++ b/rewatch-ocaml/format.ml @@ -23,9 +23,6 @@ let write_file path contents = extended attributes that replacing the directory entry could lose. *) File_util.write_file path contents) -let bsc () = - try Toolchain.bsc () with Toolchain.Error message -> raise (Error message) - type discovered_package = {config: Config.t; files: string list} let package_sources (package : discovered_package) = @@ -118,8 +115,11 @@ let files_in_scope ~verbosity = let formatting_error target stderr = Printf.sprintf "Error formatting %s: %s" target stderr -let formatted ?poll ~bsc ~target path = - let result = Process.run ?poll ~cwd:(Sys.getcwd ()) bsc ["-format"; path] in +let format_request path = + Compiler_process.{args = ["-format"; path]; cwd = Sys.getcwd ()} + +let formatted ?poll ~target path = + let result = Compiler_process.run ?poll (format_request path) in if not (Process.succeeded result) then raise (Error (formatting_error target result.stderr)); result.stdout @@ -128,8 +128,7 @@ let format_check_summary = function | 1 -> "The file listed above needs formatting" | count -> Printf.sprintf "The %d files listed above need formatting" count -let format_files_with_bsc ?max_jobs ?poll ~bsc ~check files = - let cwd = Sys.getcwd () in +let format_files ?poll ~check files = let incorrect = ref 0 in let works = files @@ -138,8 +137,7 @@ let format_files_with_bsc ?max_jobs ?poll ~bsc ~check files = {key = Printf.sprintf "%08d" index; dependencies = []; value = path}) in let next path = function - | None -> - Some (Process.task Process.{program = bsc; args = ["-format"; path]; cwd}) + | None -> Some (Compiler_process.task (format_request path)) | Some result -> if not (Process.succeeded result) then raise (Error (formatting_error path result.stderr)); @@ -151,7 +149,9 @@ let format_files_with_bsc ?max_jobs ?poll ~bsc ~check files = else write_file path result.stdout; None in - Process.run_dependency_graph ?max_jobs ?poll works ~next; + Process.run_dependency_graph + ~max_jobs:(Compiler_execution_mode.configured_count ()) + ?poll works ~next; if !incorrect > 0 then ( prerr_endline (format_check_summary !incorrect); raise (Error "Formatting check failed")) @@ -197,19 +197,17 @@ let read_stdin_interruptibly ?poll () = let format_stdin ?poll extension = if extension <> ".res" && extension <> ".resi" then raise (Error "--stdin must be .res or .resi"); - let bsc = bsc () in let path = Filename.temp_file "rescript-format-" extension in Fun.protect ~finally:(fun () -> try Sys.remove path with Sys_error _ -> ()) (fun () -> let contents = read_stdin_interruptibly ?poll () in File_util.write_file path contents; - print_string (formatted ?poll ~bsc ~target:"stdin" path)) + print_string (formatted ?poll ~target:"stdin" path)) let run_files ?poll ~verbosity ~check paths = - let bsc = bsc () in let files = if paths = [] then files_in_scope ~verbosity else paths in List.iter (fun file -> Output.trace ~channel:stderr ~verbosity ("Formatting " ^ file)) files; - format_files_with_bsc ?poll ~bsc ~check files + format_files ?poll ~check files diff --git a/rewatch-ocaml/format.mli b/rewatch-ocaml/format.mli index 95624e0c3f4..3cb8845e0ac 100644 --- a/rewatch-ocaml/format.mli +++ b/rewatch-ocaml/format.mli @@ -4,13 +4,7 @@ val write_file : string -> string -> unit val formatting_error : string -> string -> string val format_check_summary : int -> string -val format_files_with_bsc : - ?max_jobs:int -> - ?poll:(unit -> unit) -> - bsc:string -> - check:bool -> - string list -> - unit +val format_files : ?poll:(unit -> unit) -> check:bool -> string list -> unit val format_stdin : ?poll:(unit -> unit) -> string -> unit val run_files : diff --git a/rewatch-ocaml/package_compilation.ml b/rewatch-ocaml/package_compilation.ml index 9ac565e481b..68219535e34 100644 --- a/rewatch-ocaml/package_compilation.ml +++ b/rewatch-ocaml/package_compilation.ml @@ -75,13 +75,13 @@ let prepare ~(package : Package_plan.t) ~(prepared : Build_session.prepared) config.package_specs in let compile_process module_ ~source_kind path = - Compiler_process.compile_job ~bsc:prepared.compiler_context.bsc_path - ~build_dir ~config + Compiler_process.compile_request ~build_dir ~config ~common_args: (if module_.Source.is_dev then prepared_package.development_common_args else prepared_package.regular_common_args) module_ ~source_kind path + |> Compiler_process.task in let record_published_outputs ~source_kind path = match source_kind with @@ -156,7 +156,6 @@ let prepare ~(package : Package_plan.t) ~(prepared : Build_session.prepared) || attempt.freshness_mode = Build_attempt.Initialize_freshness then Compiler_process.namespace_task - ~bsc:prepared.compiler_context.bsc_path ~runtime:prepared.compiler_context.runtime_path ~build_dir ~ocaml_dir ~entry:(Config.namespace_entry config.namespace) @@ -190,7 +189,7 @@ let prepare ~(package : Package_plan.t) ~(prepared : Build_session.prepared) raise error in Build_attempt.add_namespace_job attempt - Build_attempt.{job = namespace_task.job; finish})); + Build_attempt.{task = namespace_task.task; finish})); Build_attempt.add_compile_candidates attempt candidates; Build_attempt.register_cleanup attempt (fun () -> if not watch then diff --git a/rewatch-ocaml/package_parse.ml b/rewatch-ocaml/package_parse.ml index 424b1fed46d..ecc1d96c8df 100644 --- a/rewatch-ocaml/package_parse.ml +++ b/rewatch-ocaml/package_parse.ml @@ -52,10 +52,10 @@ let run ~(package : Package_plan.t) ~(prepared : Build_session.prepared) List.map2 (fun path result -> (path, Build_attempt.preliminary_parse result)) parse_paths_to_run - (Process.run_parallel_map ?poll:attempt.process_poll parse_paths_to_run - ~job: - (Compiler_process.parse_job ~bsc:prepared.compiler_context.bsc_path - ~build_dir ~config)) + (List.map + (fun path -> Compiler_process.parse_request ~build_dir ~config path) + parse_paths_to_run + |> Compiler_process.run_requests ?poll:attempt.process_poll) @ (dirty_parse_paths |> List.filter_map (fun path -> Hashtbl.find_opt attempt.preliminary_parses diff --git a/rewatch-ocaml/platform.mli b/rewatch-ocaml/platform.mli index 18c66de50df..96ccf00e8d3 100644 --- a/rewatch-ocaml/platform.mli +++ b/rewatch-ocaml/platform.mli @@ -20,6 +20,7 @@ val error_symbol : string type command = {env: Spawn.Env.t option; program: string; args: string list} val post_build_command : command:string -> output:string -> command +val shell_command : string -> command type process diff --git a/rewatch-ocaml/platform_unix.ml b/rewatch-ocaml/platform_unix.ml index b0fca3df641..da737c7e382 100644 --- a/rewatch-ocaml/platform_unix.ml +++ b/rewatch-ocaml/platform_unix.ml @@ -38,6 +38,9 @@ let post_build_command ~command ~output = args = ["-c"; command ^ " " ^ Filename.quote output]; } +let shell_command command = + {env = None; program = "/bin/sh"; args = ["-c"; command]} + type process = int let spawn ~env ~cwd ~program ~args ~stdin ~stdout ~stderr = diff --git a/rewatch-ocaml/platform_windows.ml b/rewatch-ocaml/platform_windows.ml index f9f4f45b834..b5afa01763e 100644 --- a/rewatch-ocaml/platform_windows.ml +++ b/rewatch-ocaml/platform_windows.ml @@ -76,6 +76,13 @@ let post_build_command ~command ~output = args = ["/D"; "/V:OFF"; "/S"; "/C"; command ^ " \"%" ^ variable ^ "%\""]; } +let shell_command command = + { + env = None; + program = "cmd.exe"; + args = ["/D"; "/V:OFF"; "/S"; "/C"; command]; + } + let is_batch_file program = List.mem (Filename.extension program |> String.lowercase_ascii) diff --git a/rewatch-ocaml/process.ml b/rewatch-ocaml/process.ml index 0559efea75d..d4e3068b742 100644 --- a/rewatch-ocaml/process.ml +++ b/rewatch-ocaml/process.ml @@ -7,7 +7,11 @@ type result = Child.result = { } type job = Child.job = {program: string; args: string list; cwd: string} -type task = {job: job; env: Spawn.Env.t option; on_result: result -> result} +type task_kind = + | External of {job: job; env: Spawn.Env.t option} + | Concurrent of {run: unit -> result; cancel: unit -> unit} + +type task = {kind: task_kind; on_result: result -> result} exception Error = Child.Error exception Interrupted of int @@ -29,56 +33,14 @@ let with_completion_notifier ~poll action = Child.with_completion_notifier ~ticker_enabled:false (action ~poll:(fun () -> ())) -let task ?env ?(on_result = fun result -> result) job = {job; env; on_result} +let task ?env ?(on_result = fun result -> result) job = + {kind = External {job; env}; on_result} -let run_parallel_map_with_notifier ~max_jobs ~poll ~on_complete notifier values - ~job = - let indexed = List.mapi (fun index value -> (index, value)) values in - let results = Array.make (List.length values) None in - let active = ref [] in - let launch_indexed (index, value) = - active := Child.launch ~notifier index (job value) :: !active - in - let rec fill slots queued = - if slots = 0 then queued - else - match queued with - | [] -> [] - | job :: rest -> - launch_indexed job; - fill (slots - 1) rest - in - let rec schedule queued = - let queued = fill (max_jobs - List.length !active) queued in - match !active with - | [] -> () - | _ -> - let child, result = Child.wait_for_running ~poll notifier !active in - active := List.filter (fun running -> running != child) !active; - Child.release_running child; - results.(Child.payload child) <- Some result; - on_complete (Child.payload child); - schedule queued - in - try - schedule indexed; - Array.to_list results |> List.map Option.get - with exn -> - Child.terminate_running !active; - raise exn - -let run_parallel_map ?(max_jobs = default_max_jobs) ?poll - ?(on_complete = fun _ -> ()) values ~job = - if max_jobs < 1 then raise (Error "max_jobs must be at least one"); - match values with - | [] -> [] - | _ -> - with_completion_notifier ~poll (fun ~poll notifier -> - run_parallel_map_with_notifier ~max_jobs ~poll ~on_complete notifier - values ~job) +let concurrent_task ~cancel ?(on_result = fun result -> result) run = + {kind = Concurrent {run; cancel}; on_result} -let run_parallel ?max_jobs ?poll ?on_complete jobs = - run_parallel_map ?max_jobs ?poll ?on_complete jobs ~job:Fun.id +let map_result task map = + {task with on_result = (fun result -> map (task.on_result result))} type 'a work = {key: string; dependencies: string list; value: 'a} type failure_action = @@ -106,10 +68,12 @@ type termination_state = type pool_active = { id: int; - child: unit Child.running; + child: Child.running; mutable cancellation: cancellation_state; } +type pool_action = {id: int; cancel: unit -> unit} + let cancellation_was_requested = function | Cancellation_not_requested -> false | Cancellation_requested | Cancellation_failed _ -> true @@ -126,13 +90,15 @@ type 'a worker_pool = { queued: ('a * task) Queue.t; completed_tasks: 'a pool_completion Queue.t; mutable active_children: pool_active list; + mutable active_actions: pool_action list; mutable next_active_id: int; mutable stopping: bool; mutable signalling_cancellation: bool; mutable workers: unit Domain.t list; + mutable worker_error: exn option; } -let remove_active pool active = +let remove_active pool (active : pool_active) = Child.with_lock pool.mutex (fun () -> while pool.signalling_cancellation @@ -142,7 +108,7 @@ let remove_active pool active = done; pool.active_children <- List.filter - (fun current -> current.id <> active.id) + (fun (current : pool_active) -> current.id <> active.id) pool.active_children) let complete_pool_task pool completion = @@ -150,70 +116,92 @@ let complete_pool_task pool completion = Queue.add completion pool.completed_tasks); Child.notify_completion pool.notifier +let run_concurrent_task pool payload task run cancel = + let active, cancel_now = + Child.with_lock pool.mutex (fun () -> + let active = {id = pool.next_active_id; cancel} in + pool.next_active_id <- pool.next_active_id + 1; + pool.active_actions <- active :: pool.active_actions; + (active, pool.stopping)) + in + let completion = + try + if cancel_now then cancel (); + Task_completed (payload, task.on_result (run ())) + with exn -> Task_failed (payload, exn) + in + Child.with_lock pool.mutex (fun () -> + pool.active_actions <- + List.filter (fun current -> current.id <> active.id) pool.active_actions); + complete_pool_task pool completion + let run_pool_task pool payload task = - match - try Ok (Child.launch ?env:task.env ~notifier:pool.notifier () task.job) - with exn -> Error exn - with - | Error exn -> complete_pool_task pool (Task_failed (payload, exn)) - | Ok child -> - let active, cancel_after_launch = - Child.with_lock pool.mutex (fun () -> - let active = - { - id = pool.next_active_id; - child; - cancellation = - (if pool.stopping then Cancellation_requested - else Cancellation_not_requested); - } - in - pool.next_active_id <- pool.next_active_id + 1; - pool.active_children <- active :: pool.active_children; - (active, cancellation_was_requested active.cancellation)) - in - let wait_result = - try - if cancel_after_launch then Child.signal_running [child]; - Ok - (Child.wait_for_running - ~poll:(fun () -> - match - Child.with_lock pool.mutex (fun () -> active.cancellation) - with - | Cancellation_failed exn -> raise exn - | Cancellation_not_requested | Cancellation_requested -> ()) - pool.notifier [child]) + match task.kind with + | Concurrent {run; cancel} -> run_concurrent_task pool payload task run cancel + | External {job; env} -> ( + match + try Ok (Child.launch ?env ~notifier:pool.notifier job) with exn -> Error exn - in - let completion = - match wait_result with - | Ok (_, result) -> ( - remove_active pool active; + with + | Error exn -> complete_pool_task pool (Task_failed (payload, exn)) + | Ok child -> + let active, cancel_after_launch = + Child.with_lock pool.mutex (fun () -> + let active = + { + id = pool.next_active_id; + child; + cancellation = + (if pool.stopping then Cancellation_requested + else Cancellation_not_requested); + } + in + pool.next_active_id <- pool.next_active_id + 1; + pool.active_children <- active :: pool.active_children; + (active, cancellation_was_requested active.cancellation)) + in + let wait_result = try - Child.release_running child; - Task_completed (payload, task.on_result result) - with exn -> Task_failed (payload, exn)) - | Error exn -> ( - let termination = - try - Child.signal_running [child]; - Termination_confirmed - with cancellation_exn -> Termination_unconfirmed cancellation_exn - in - match termination with - | Termination_confirmed -> ( + if cancel_after_launch then Child.signal_running [child]; + Ok + (Child.wait_for_running + ~poll:(fun () -> + match + Child.with_lock pool.mutex (fun () -> active.cancellation) + with + | Cancellation_failed exn -> raise exn + | Cancellation_not_requested | Cancellation_requested -> ()) + pool.notifier [child]) + with exn -> Error exn + in + let completion = + match wait_result with + | Ok (_, result) -> ( remove_active pool active; try Child.release_running child; - Task_failed (payload, exn) - with release_exn -> Task_failed (payload, release_exn)) - | Termination_unconfirmed cancellation_exn -> - remove_active pool active; - Child.release_after_completion child; - Task_failed (payload, cancellation_exn)) - in - complete_pool_task pool completion + Task_completed (payload, task.on_result result) + with exn -> Task_failed (payload, exn)) + | Error exn -> ( + let termination = + try + Child.signal_running [child]; + Termination_confirmed + with cancellation_exn -> Termination_unconfirmed cancellation_exn + in + match termination with + | Termination_confirmed -> ( + remove_active pool active; + try + Child.release_running child; + Task_failed (payload, exn) + with release_exn -> Task_failed (payload, release_exn)) + | Termination_unconfirmed cancellation_exn -> + remove_active pool active; + Child.release_after_completion child; + Task_failed (payload, cancellation_exn)) + in + complete_pool_task pool completion) let rec worker_loop pool = let queued = @@ -240,15 +228,33 @@ let create_worker_pool ~max_jobs notifier = queued = Queue.create (); completed_tasks = Queue.create (); active_children = []; + active_actions = []; next_active_id = 0; stopping = false; signalling_cancellation = false; workers = []; + worker_error = None; } in + (* Workers run in-process compiler requests, which are OCaml computations, so + they must be domains to compile in parallel: threads would serialize them + on the runtime lock. A worker records an escaped exception instead of + letting it escape [Domain.join], so [stop_worker_pool] joins every worker + before re-raising the first error. *) + let run_worker () = + (* Every minor collection stops all domains, so the default 256k-word minor + heap makes busy compiler workers stall each other. 2M words (16 MB per + worker) cut clean-build time by about 15%; larger heaps added memory + without speed. *) + Gc.set {(Gc.get ()) with minor_heap_size = 2 * 1024 * 1024}; + try worker_loop pool + with exn -> + Child.with_lock pool.mutex (fun () -> + if Option.is_none pool.worker_error then pool.worker_error <- Some exn) + in let rec start_workers remaining = if remaining > 0 then ( - let worker = Domain.spawn (fun () -> worker_loop pool) in + let worker = Domain.spawn run_worker in pool.workers <- worker :: pool.workers; start_workers (remaining - 1)) in @@ -282,21 +288,24 @@ let await_pool_completion ~poll pool = Child.notifier_generation pool.notifier |> wait let stop_worker_pool ~cancel pool = - let active = + let active, actions = Child.with_lock pool.mutex (fun () -> pool.stopping <- true; Queue.clear pool.queued; Condition.broadcast pool.work_available; if cancel then ( pool.signalling_cancellation <- true; - pool.active_children - |> List.filter_map (fun active -> - match active.cancellation with - | Cancellation_requested | Cancellation_failed _ -> None - | Cancellation_not_requested -> - active.cancellation <- Cancellation_requested; - Some active.child)) - else []) + let children = + pool.active_children + |> List.filter_map (fun active -> + match active.cancellation with + | Cancellation_requested | Cancellation_failed _ -> None + | Cancellation_not_requested -> + active.cancellation <- Cancellation_requested; + Some active.child) + in + (children, List.map (fun active -> active.cancel) pool.active_actions)) + else ([], [])) in let signal_error = try @@ -304,6 +313,23 @@ let stop_worker_pool ~cancel pool = None with exn -> Some exn in + let action_error = + List.fold_left + (fun first_error cancel -> + try + cancel (); + first_error + with exn -> ( + match first_error with + | Some _ -> first_error + | None -> Some exn)) + None actions + in + let cancellation_error = + match signal_error with + | Some _ -> signal_error + | None -> action_error + in Child.with_lock pool.mutex (fun () -> Option.iter (fun exn -> @@ -314,12 +340,18 @@ let stop_worker_pool ~cancel pool = active.cancellation <- Cancellation_failed exn | Cancellation_not_requested | Cancellation_failed _ -> ()) pool.active_children) - signal_error; + cancellation_error; pool.signalling_cancellation <- false; Condition.broadcast pool.cancellation_finished); - Option.iter (fun _ -> Child.notify_completion pool.notifier) signal_error; + Option.iter + (fun _ -> Child.notify_completion pool.notifier) + cancellation_error; List.iter Domain.join pool.workers; - Option.iter raise signal_error + (* A worker that crashed is the root cause; a failure to cancel the other + work is at most a consequence of it. *) + match (pool.worker_error, cancellation_error) with + | Some exn, _ | None, Some exn -> raise exn + | None, None -> () let with_worker_pool ~max_jobs notifier action = let pool = create_worker_pool ~max_jobs notifier in @@ -413,6 +445,10 @@ let run_dependency_graph_with_notifier ~max_jobs ~on_failure ~poll notifier if remaining = 0 then add_ready (Graph.find_node graph dependent_key)) in let rec fill pool = + (* Synchronous tasks and queued domain completions can keep the scheduler + from reaching the wait path's poll. Check before admitting more work so + an interrupt stops the next compiler request. *) + poll (); if (not !stopped) && !in_flight < max_jobs then match Work_ready.min_elt_opt !ready with | None -> () @@ -474,10 +510,34 @@ let run_dependency_graph ?(max_jobs = default_max_jobs) run_dependency_graph_with_notifier ~max_jobs ~on_failure ~poll notifier works ~next) -let run_one ?poll ?stdout_chunk ?stderr_chunk ?stdin ~cwd program args = +let run_tasks ?(max_jobs = default_max_jobs) ?poll ?(on_complete = fun _ -> ()) + tasks = + let tasks = Array.of_list tasks in + let results = Array.make (Array.length tasks) None in + let works = + Array.to_list + (Array.mapi + (fun index _ -> + { + key = Printf.sprintf "%010d" index; + dependencies = []; + value = index; + }) + tasks) + in + run_dependency_graph ~max_jobs ?poll works ~next:(fun index result -> + match result with + | None -> Some tasks.(index) + | Some result -> + results.(index) <- Some result; + on_complete index; + None); + Array.to_list results |> List.map Option.get + +let run_one ?poll ?stdout_chunk ?stderr_chunk ?stdin ?env ~cwd program args = with_completion_notifier ~poll (fun ~poll notifier -> let child = - Child.launch ?stdout_chunk ?stderr_chunk ?stdin ~notifier () + Child.launch ?stdout_chunk ?stderr_chunk ?stdin ?env ~notifier {program; args; cwd} in let completion_received = ref false in diff --git a/rewatch-ocaml/process.mli b/rewatch-ocaml/process.mli index a611081869b..4ba7c22b5c0 100644 --- a/rewatch-ocaml/process.mli +++ b/rewatch-ocaml/process.mli @@ -15,21 +15,12 @@ val status_string : Unix.process_status -> string val default_max_jobs : int val task : ?env:Spawn.Env.t -> ?on_result:(result -> result) -> job -> task - -val run_parallel : - ?max_jobs:int -> - ?poll:(unit -> unit) -> - ?on_complete:(int -> unit) -> - job list -> - result list - -val run_parallel_map : - ?max_jobs:int -> - ?poll:(unit -> unit) -> - ?on_complete:(int -> unit) -> - 'a list -> - job:('a -> job) -> - result list +val concurrent_task : + cancel:(unit -> unit) -> + ?on_result:(result -> result) -> + (unit -> result) -> + task +val map_result : task -> (result -> result) -> task type 'a work = {key: string; dependencies: string list; value: 'a} @@ -50,6 +41,13 @@ val run_dependency_graph : next:('a -> result option -> task option) -> unit +val run_tasks : + ?max_jobs:int -> + ?poll:(unit -> unit) -> + ?on_complete:(int -> unit) -> + task list -> + result list + val run : ?poll:(unit -> unit) -> cwd:string -> string -> string list -> result val run_streaming : diff --git a/rewatch-ocaml/process_child.ml b/rewatch-ocaml/process_child.ml index 8eda49a2ab0..cc37576a233 100644 --- a/rewatch-ocaml/process_child.ml +++ b/rewatch-ocaml/process_child.ml @@ -38,11 +38,7 @@ type child_wait = { outcome: (result, exn) Stdlib.result option Atomic.t; } -type 'a running = { - payload: 'a; - process: Platform.process; - child_wait: child_wait; -} +type running = {process: Platform.process; child_wait: child_wait} type launch_ownership = { mutable stdin: Unix.file_descr option; @@ -252,8 +248,8 @@ let fail_launch ownership launch_error = in raise error -let launch ?env ?stdout_chunk ?stderr_chunk ?(stdin = Null_stdin) ~notifier - payload job = +let launch ?env ?stdout_chunk ?stderr_chunk ?(stdin = Null_stdin) ~notifier job + = let ownership = empty_launch_ownership () in try let pipes = Platform_common.create_capture_pipes () in @@ -291,13 +287,13 @@ let launch ?env ?stdout_chunk ?stderr_chunk ?(stdin = Null_stdin) ~notifier ownership.stderr_write <- None; close_noerr stderr_write; let child_wait = start_child_wait pid notifier stdout stderr in - {payload; process; child_wait} + {process; child_wait} with exn -> fail_launch ownership exn let wait_for_running ~poll notifier active = let rec find_completed = function | [] -> None - | (child : _ running) :: rest -> ( + | (child : running) :: rest -> ( match Atomic.get child.child_wait.outcome with | Some outcome -> Some (child, outcome) | None -> find_completed rest) @@ -312,12 +308,12 @@ let wait_for_running ~poll notifier active = in notifier_generation notifier |> wait -let signal_running (children : _ running list) = +let signal_running (children : running list) = if children <> [] then ( - let completion_ready (child : _ running) = + let completion_ready (child : running) = Option.is_some (Atomic.get child.child_wait.outcome) in - let root_identity_lost (child : _ running) = + let root_identity_lost (child : running) = Option.is_some (Atomic.get child.child_wait.direct_outcome) in let signal_all signal = @@ -375,16 +371,14 @@ let signal_running (children : _ running list) = ("Could not terminate a subprocess tree: " ^ String.concat "; " (List.map snd errors)))) -let payload (child : _ running) = child.payload - -let release_running (child : _ running) = +let release_running (child : running) = Thread.join child.child_wait.thread; Platform.release_process child.process let release_after_completion child = ignore (Thread.create release_running child) -let terminate_running (children : _ running list) = +let terminate_running (children : running list) = if children <> [] then ( try signal_running children; diff --git a/rewatch-ocaml/process_child.mli b/rewatch-ocaml/process_child.mli index 8ddd8964589..488dc28cb8d 100644 --- a/rewatch-ocaml/process_child.mli +++ b/rewatch-ocaml/process_child.mli @@ -12,7 +12,7 @@ val succeeded : result -> bool val status_string : Unix.process_status -> string type completion_notifier -type 'a running +type running val with_lock : Mutex.t -> (unit -> 'a) -> 'a (** Runs the action holding the mutex and releases it on exceptions too. *) @@ -30,18 +30,13 @@ val launch : ?stderr_chunk:(bytes -> int -> unit) -> ?stdin:stdin_policy -> notifier:completion_notifier -> - 'a -> job -> - 'a running + running val wait_for_running : - poll:(unit -> unit) -> - completion_notifier -> - 'a running list -> - 'a running * result - -val payload : 'a running -> 'a -val signal_running : 'a running list -> unit -val release_after_completion : 'a running -> unit -val terminate_running : 'a running list -> unit -val release_running : 'a running -> unit + poll:(unit -> unit) -> completion_notifier -> running list -> running * result + +val signal_running : running list -> unit +val release_after_completion : running -> unit +val terminate_running : running list -> unit +val release_running : running -> unit diff --git a/rewatch-ocaml/rescript_ocaml.ml b/rewatch-ocaml/rescript_ocaml.ml index 5814ffdfb40..0c7b37f3f5f 100644 --- a/rewatch-ocaml/rescript_ocaml.ml +++ b/rewatch-ocaml/rescript_ocaml.ml @@ -5,15 +5,9 @@ let with_termination_handlers action = let requested_exit = Atomic.make 0 in let interrupt signal = - (* Shells report a process killed by signal n as exit status 128 + n. *) - let exit_code = - if signal = Sys.sigint then 130 - else if signal = Sys.sigterm then 143 - else if signal = Sys.sighup then 129 - else if signal = Sys.sigquit then 131 - else 1 - in - ignore (Atomic.compare_and_set requested_exit 0 exit_code) + ignore + (Atomic.compare_and_set requested_exit 0 + (Termination_signals.exit_code signal)) in let poll () = let exit_code = Atomic.get requested_exit in @@ -70,7 +64,7 @@ let run = function | command -> with_termination_handlers (fun ~poll -> run_command ~poll command) -let () = +let main () = Platform.configure_standard_streams (); try match Cli.eval Sys.argv with @@ -92,3 +86,5 @@ let () = | (Sys_error _ as exn) | (Unix.Unix_error _ as exn) -> prerr_endline (Printexc.to_string exn); exit 1 + +let () = main () diff --git a/rewatch-ocaml/termination_signals.ml b/rewatch-ocaml/termination_signals.ml index ae69a1940e9..c7a458d8d62 100644 --- a/rewatch-ocaml/termination_signals.ml +++ b/rewatch-ocaml/termination_signals.ml @@ -1,3 +1,11 @@ +(* Shells report a process killed by signal n as exit status 128 + n. *) +let exit_code signal = + if signal = Sys.sigint then 130 + else if signal = Sys.sigterm then 143 + else if signal = Sys.sighup then 129 + else if signal = Sys.sigquit then 131 + else 1 + let with_handlers handler action = let rec install = function | [] -> action () diff --git a/rewatch-ocaml/termination_signals.mli b/rewatch-ocaml/termination_signals.mli index 77cfe608acb..781f37806c0 100644 --- a/rewatch-ocaml/termination_signals.mli +++ b/rewatch-ocaml/termination_signals.mli @@ -1,4 +1,9 @@ +val exit_code : int -> int +(** The shell's exit status for a process stopped by the signal. *) + val with_handlers : (int -> unit) -> (unit -> 'a) -> 'a (** Runs the action with the handler installed for every {!Platform.termination_signals} entry, restoring the previous handlers - afterwards. *) + afterwards. The handler only records the request: work stops at the next + poll point, after the modules compiling in-process finish, so a stop never + leaves a half-written artifact. Callers ignore repeated signals. *) diff --git a/rewatch-ocaml/tests/check_command_validation.sh b/rewatch-ocaml/tests/check_command_validation.sh index 89929a186b9..d4a0b5a7eb2 100755 --- a/rewatch-ocaml/tests/check_command_validation.sh +++ b/rewatch-ocaml/tests/check_command_validation.sh @@ -7,7 +7,6 @@ rust=${1:-$root/rewatch/target/debug/rescript} ocaml=${2:-$root/_build/default/rewatch-ocaml/rescript_ocaml.exe} rust=$(realpath "$rust") ocaml=$(realpath "$ocaml") -bsc_test_proxy="$root/_build/default/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.exe" work=$(mktemp -d "${TMPDIR:-/tmp}/rewatch-command-validation-XXXXXX") # Compiler diagnostics contain canonical paths. Resolve platform aliases such # as macOS's /var -> /private/var before deriving paths used for comparison. @@ -19,12 +18,7 @@ if $windows_posix_shell; then native_user=$(cygpath -w "$USERPROFILE" | tr '\\' '/') native_short_user=$(cygpath -w -s "$USERPROFILE" | tr '\\' '/') native_short_work=${native_work/"$native_user"/"$native_short_user"} - bsc_test_proxy=$(cygpath -aw \ - "$root/_build/default/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.exe") fi -delete_source_bsc=$bsc_test_proxy -delete_parse_sources_bsc=$bsc_test_proxy -delete_ast_bsc=$bsc_test_proxy lock_owner_pid() { local shell_pid=$1 if $windows_posix_shell; then @@ -120,11 +114,6 @@ mkdir -p "$work/duplicate-dependency/src" \ "$work/duplicate-dependency/node_modules/a/src" \ "$work/duplicate-dependency/node_modules/shared/src" \ "$work/duplicate-dependency/node_modules/a/node_modules/shared/src" -mkdir -p "$work/publication-race-rust/src" \ - "$work/publication-race-ocaml/src" -mkdir -p "$work/ast-race-rust/src" "$work/ast-race-ocaml/src" -mkdir -p "$work/parse-source-race-rust/src" \ - "$work/parse-source-race-ocaml/src" mkdir -p "$work/watch-config-rust/src" "$work/watch-config-ocaml/src" mkdir -p "$work/watch-retained-graph/src" mkdir -p "$work/watch-dependency-recovery/src" \ @@ -137,7 +126,6 @@ mkdir -p "$work/watch-dependency-fallback/src" \ "$work/watch-dependency-fallback/packages/dep/src" \ "$work/node_modules" mkdir -p "$work/watch-symlink-target/src" "$work/watch-symlink-external/sub" -mkdir -p "$work/watch-feature-scope/src" "$work/watch-feature-scope/inactive" mkdir -p "$work/watch-filter-rust/src" "$work/watch-filter-rust/inactive" \ "$work/watch-filter-ocaml/src" "$work/watch-filter-ocaml/inactive" mkdir -p "$work/quiet-watch-rust/src" "$work/quiet-watch-ocaml/src" @@ -326,28 +314,6 @@ printf '{"name":"shared","sources":["src"]}\n' \ >"$work/duplicate-dependency/node_modules/a/node_modules/shared/rescript.json" printf 'let value = 2\n' \ >"$work/duplicate-dependency/node_modules/a/node_modules/shared/src/Shared.res" -printf '{"name":"publication-race","sources":["src"]}\n' \ - >"$work/publication-race-rust/rescript.json" -cp "$work/publication-race-rust/rescript.json" \ - "$work/publication-race-ocaml/rescript.json" -printf 'let value = 1\n' >"$work/publication-race-rust/src/A.res" -cp "$work/publication-race-rust/src/A.res" \ - "$work/publication-race-ocaml/src/A.res" -printf '{"name":"ast-race","sources":["src"]}\n' \ - >"$work/ast-race-rust/rescript.json" -cp "$work/ast-race-rust/rescript.json" "$work/ast-race-ocaml/rescript.json" -printf 'let value = 1\n' >"$work/ast-race-rust/src/A.res" -cp "$work/ast-race-rust/src/A.res" "$work/ast-race-ocaml/src/A.res" -printf '{"name":"parse-source-race","sources":["src"]}\n' \ - >"$work/parse-source-race-rust/rescript.json" -cp "$work/parse-source-race-rust/rescript.json" \ - "$work/parse-source-race-ocaml/rescript.json" -for implementation in rust ocaml; do - printf 'let value = 1\n' \ - >"$work/parse-source-race-$implementation/src/A.res" - printf 'let value = 2\n' \ - >"$work/parse-source-race-$implementation/src/B.res" -done printf '{"name":"watch-config","sources":["src"]}\n' \ >"$work/watch-config-rust/rescript.json" cp "$work/watch-config-rust/rescript.json" \ @@ -371,10 +337,6 @@ directory_link "$work/watch-dependency-recovery/packages/dep" \ printf '{"name":"watch-dependency-install","sources":["src"],"dependencies":["@scope/dep"]}\n' \ >"$work/watch-dependency-install/rescript.json" printf 'let value = 1\n' >"$work/watch-dependency-install/src/A.res" -printf '{"name":"watch-feature-scope","sources":["src",{"dir":"inactive","feature":"inactive"}]}\n' \ - >"$work/watch-feature-scope/rescript.json" -printf 'let value = 1\n' >"$work/watch-feature-scope/src/A.res" -printf 'let inactive = 1\n' >"$work/watch-feature-scope/inactive/Inactive.res" printf '{"name":"watch-dependency-fallback","sources":["src"],"dependencies":["dep"]}\n' \ >"$work/watch-dependency-fallback/rescript.json" printf 'let value = 1\n' >"$work/watch-dependency-fallback/src/A.res" @@ -406,24 +368,6 @@ for implementation in rust ocaml; do done printf 'require("fs").appendFileSync(process.env.REWATCH_WATCH_FILTER_MARKER, "done\\n")\n' \ >"$work/watch-filter-marker.js" -printf '%s\n' \ - '#!/bin/sh' \ - 'if [ -f "$REWATCH_SCOPE_BLOCK_REQUEST" ] && [ ! -f "$REWATCH_SCOPE_BLOCK_STARTED" ]; then' \ - ' : >"$REWATCH_SCOPE_BLOCK_STARTED"' \ - ' attempts=0' \ - ' while [ ! -f "$REWATCH_SCOPE_BLOCK_RELEASE" ] && [ "$attempts" -lt 200 ]; do' \ - ' attempts=$((attempts + 1))' \ - ' sleep 0.05' \ - ' done' \ - 'fi' \ - 'exec "$REWATCH_SCOPE_REAL_BSC" "$@"' \ - >"$work/watch-scope-bsc.sh" -chmod +x "$work/watch-scope-bsc.sh" -watch_scope_bsc="$work/watch-scope-bsc.sh" -if $windows_posix_shell; then - watch_scope_bsc=$bsc_test_proxy -fi - default_bsc=$root/_build/default/compiler/bsc/rescript_compiler_main.exe default_runtime=$root/packages/@rescript/runtime case $(uname -s) in @@ -469,6 +413,10 @@ normalize_project_path() { text = text.split(spelling).join(""); } } + // The Windows compiler can emit CRLF through the Rust process while the + // OCaml process converts captured compiler output to LF. Preserve bare CR + // characters used by terminal control sequences. + text = text.replaceAll("\r\n", "\n"); text = text.replaceAll("\\", "/"); text = text.replaceAll(".//", "./"); fs.writeFileSync(process.argv[2], text); @@ -585,23 +533,19 @@ require_both_errors_contain() { fi } +# Rust needs RESCRIPT_BSC_EXE to exist; OCaml builds and formats with the +# embedded compiler and ignores it. run_missing_bsc_case() { name=$1 shift RESCRIPT_BSC_EXE="$work/missing-bsc" run_both "$@" if [ "$(classify "$rust_status")" != panic ] || \ - [ "$(classify "$ocaml_status")" != reject ]; then - printf '%s: expected Rust=panic/OCaml=reject, got Rust=%s/OCaml=%s\n' \ + [ "$(classify "$ocaml_status")" != accept ]; then + printf '%s: expected Rust=panic/OCaml=accept, got Rust=%s/OCaml=%s\n' \ "$name" "$rust_status" "$ocaml_status" >&2 dump_both exit 1 fi - if ! grep -F 'RESCRIPT_BSC_EXE points to missing path' \ - "$work/ocaml.err" >/dev/null; then - echo "$name: OCaml did not report the stale compiler path" >&2 - cat "$work/ocaml.out" "$work/ocaml.err" >&2 - exit 1 - fi checked=$((checked + 1)) } @@ -1280,108 +1224,6 @@ if ! grep -F "$duplicate_warning" "$work/rust.err.norm" >/dev/null || \ exit 1 fi -set +e -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-source \ -REWATCH_SOURCE_TO_DELETE="$(command_path "$work/publication-race-rust/src/A.res")" \ -REWATCH_SOURCE_DELETED="$(command_path "$work/publication-race-rust/source-deleted")" \ -RESCRIPT_BSC_EXE="$delete_source_bsc" \ - "$rust" build "$work/publication-race-rust" \ - >"$work/rust.out" 2>"$work/rust.err" & -rust_pid=$! -attempts=0 -while kill -0 "$rust_pid" 2>/dev/null && [ "$attempts" -lt 150 ]; do - attempts=$((attempts + 1)) - sleep 0.1 -done -if kill -0 "$rust_pid" 2>/dev/null; then - kill -TERM "$rust_pid" 2>/dev/null - wait "$rust_pid" 2>/dev/null - rust_status=124 -else - wait "$rust_pid" - rust_status=$? -fi -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-source \ -REWATCH_SOURCE_TO_DELETE="$(command_path "$work/publication-race-ocaml/src/A.res")" \ -REWATCH_SOURCE_DELETED="$(command_path "$work/publication-race-ocaml/source-deleted")" \ -RESCRIPT_BSC_EXE="$delete_source_bsc" \ - "$ocaml" build "$work/publication-race-ocaml" \ - >"$work/ocaml.out" 2>"$work/ocaml.err" -ocaml_status=$? -set -e -if [ "$rust_status" -ne 124 ] || \ - ! grep -F "copying source file failed" "$work/rust.err" >/dev/null || \ - [ "$(classify "$ocaml_status")" != reject ] || \ - ! grep -F "A.res" "$work/ocaml.err" >/dev/null; then - printf 'build-source-disappears-during-publication: expected Rust=worker-panic/timeout and OCaml=path-bearing rejection, got Rust=%s/OCaml=%s\n' \ - "$rust_status" "$ocaml_status" >&2 - dump_both - exit 1 -fi -checked=$((checked + 1)) - -set +e -RAYON_NUM_THREADS=1 \ -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-parse-sources \ -REWATCH_SOURCE_A="$(command_path "$work/parse-source-race-rust/src/A.res")" \ -REWATCH_SOURCE_B="$(command_path "$work/parse-source-race-rust/src/B.res")" \ -REWATCH_SOURCES_DELETED="$(command_path "$work/parse-source-race-rust/sources-deleted")" \ -RESCRIPT_BSC_EXE="$delete_parse_sources_bsc" \ - "$rust" build "$work/parse-source-race-rust" \ - >"$work/rust.out" 2>"$work/rust.err" -rust_status=$? -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-parse-sources \ -REWATCH_SOURCE_A="$(command_path "$work/parse-source-race-ocaml/src/A.res")" \ -REWATCH_SOURCE_B="$(command_path "$work/parse-source-race-ocaml/src/B.res")" \ -REWATCH_SOURCES_DELETED="$(command_path "$work/parse-source-race-ocaml/sources-deleted")" \ -RESCRIPT_BSC_EXE="$delete_parse_sources_bsc" \ - "$ocaml" build "$work/parse-source-race-ocaml" \ - >"$work/ocaml.out" 2>"$work/ocaml.err" -ocaml_status=$? -set -e -if [ "$rust_status" -ne 101 ] || \ - ! grep -F "file not found" "$work/rust.err" >/dev/null || \ - [ "$(classify "$ocaml_status")" != reject ] || \ - ! grep -F "parse-source-race" "$work/ocaml.err" >/dev/null || \ - ! grep -E 'A\.(res|ast)' "$work/ocaml.err" >/dev/null; then - printf 'build-source-disappears-before-parse-read: expected Rust=panic and OCaml=path-bearing rejection, got Rust=%s/OCaml=%s\n' \ - "$rust_status" "$ocaml_status" >&2 - dump_both - exit 1 -fi -checked=$((checked + 1)) - -set +e -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-ast \ -REWATCH_AST_DELETED="$(command_path "$work/ast-race-rust/ast-deleted")" \ -RESCRIPT_BSC_EXE="$delete_ast_bsc" \ - "$rust" build "$work/ast-race-rust" \ - >"$work/rust.out" 2>"$work/rust.err" -rust_status=$? -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-ast \ -REWATCH_AST_DELETED="$(command_path "$work/ast-race-ocaml/ast-deleted")" \ -RESCRIPT_BSC_EXE="$delete_ast_bsc" \ - "$ocaml" build "$work/ast-race-ocaml" \ - >"$work/ocaml.out" 2>"$work/ocaml.err" -ocaml_status=$? -set -e -if [ "$rust_status" -ne 101 ] || \ - ! grep -F "Could not read file" "$work/rust.err" >/dev/null || \ - [ "$(classify "$ocaml_status")" != reject ] || \ - ! grep -F "A.ast" "$work/ocaml.err" >/dev/null; then - printf 'build-ast-disappears-before-dependency-read: expected Rust=panic and OCaml=path-bearing rejection, got Rust=%s/OCaml=%s\n' \ - "$rust_status" "$ocaml_status" >&2 - dump_both - exit 1 -fi -checked=$((checked + 1)) - "$rust" watch "$work/watch-config-rust" \ >"$work/watch-rust.out" 2>"$work/watch-rust.err" & rust_watch_pid=$! @@ -1565,47 +1407,6 @@ if $file_symlinks_supported; then checked=$((checked + 1)) fi -feature_scope_marker="$work/watch-feature-scope/after-build.log" -scope_block_request="$work/watch-feature-scope/block-request" -scope_block_started="$work/watch-feature-scope/block-started" -scope_block_release="$work/watch-feature-scope/block-release" -REWATCH_SCOPE_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=scope-block \ -REWATCH_SCOPE_BLOCK_REQUEST="$(command_path "$scope_block_request")" \ -REWATCH_SCOPE_BLOCK_STARTED="$(command_path "$scope_block_started")" \ -REWATCH_SCOPE_BLOCK_RELEASE="$(command_path "$scope_block_release")" \ -RESCRIPT_BSC_EXE="$watch_scope_bsc" \ -REWATCH_WATCH_FILTER_MARKER="$feature_scope_marker" \ - "$ocaml" watch --features other \ - --after-build "node $command_work/watch-filter-marker.js" \ - "$work/watch-feature-scope" \ - >"$work/watch-feature-scope.out" 2>"$work/watch-feature-scope.err" & -feature_scope_pid=$! -background_pids="$background_pids $feature_scope_pid" -if ! wait_for_line_count "$feature_scope_marker" 1; then - echo "OCaml feature-scope watcher did not finish its initial build" >&2 - cat "$work/watch-feature-scope.out" "$work/watch-feature-scope.err" >&2 - exit 1 -fi -: >"$scope_block_request" -printf '{"name":"watch-feature-scope","sources":["src",{"dir":"inactive","feature":"inactive"}],"features":{"other":["inactive"]}}\n' \ - >"$work/watch-feature-scope/rescript.json" -wait_for_file "$scope_block_started" -printf 'let createdDuringBuild = 2\n' \ - >"$work/watch-feature-scope/inactive/CreatedDuringBuild.res" -: >"$scope_block_release" -wait_for_file "$work/watch-feature-scope/inactive/Inactive.js" -wait_for_file "$work/watch-feature-scope/inactive/CreatedDuringBuild.js" -wait_for_line_count "$feature_scope_marker" 3 -if ! line_count_stays "$feature_scope_marker" 3; then - echo "OCaml watcher lost or duplicated an edit during a source-scope transition" >&2 - cat "$work/watch-feature-scope.out" "$work/watch-feature-scope.err" >&2 - exit 1 -fi -terminate_and_wait "$feature_scope_pid" "feature-scope watcher" -checked=$((checked + 1)) - rust_filter_marker="$work/watch-filter-rust/after-build.log" REWATCH_WATCH_FILTER_MARKER="$rust_filter_marker" \ "$rust" watch --features other --filter 'Include\.res$' \ diff --git a/rewatch-ocaml/tests/check_interactive_output.sh b/rewatch-ocaml/tests/check_interactive_output.sh index eadb345e263..46287bb3109 100755 --- a/rewatch-ocaml/tests/check_interactive_output.sh +++ b/rewatch-ocaml/tests/check_interactive_output.sh @@ -71,7 +71,6 @@ for implementation in rust ocaml; do printf 'let value = 1\n' >"$work/$implementation/src/A.res" printf 'let value: int\n' >"$work/$implementation/src/A.resi" cp -R "$work/$implementation" "$work/$implementation-after-build" - cp -R "$work/$implementation" "$work/$implementation-parse-warning" cp -R "$work/$implementation" "$work/$implementation-watch" cp -R "$work/$implementation" "$work/$implementation-initial-failure-watch" printf 'let value = (\n' \ @@ -101,12 +100,10 @@ EOF export RESCRIPT_BSC_EXE=${RESCRIPT_BSC_EXE:-$root/_build/default/compiler/bsc/rescript_compiler_main.exe} export RESCRIPT_RUNTIME=${RESCRIPT_RUNTIME:-$root/packages/@rescript/runtime} -parse_warning_bsc="$root/_build/default/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.exe" after_build_command="$work/after-build-marker.sh" if $windows_posix_shell; then RESCRIPT_BSC_EXE=$(command_path "$RESCRIPT_BSC_EXE") RESCRIPT_RUNTIME=$(command_path "$RESCRIPT_RUNTIME") - parse_warning_bsc=$(command_path "$parse_warning_bsc") after_build_command="node $(command_path "$work/after-build-marker.js")" fi @@ -185,55 +182,6 @@ if ! cmp -s "$work/expected" "$work/ocaml.phases"; then exit 1 fi -capture_parse_warning_order() { - implementation=$1 - executable=$2 - transcript="$work/$implementation-parse-warning.tty" - project="$work/$implementation-parse-warning" - command_executable=$(command_path "$executable") - command_project=$(command_path "$project") - if [ "$(uname -s)" = Darwin ]; then - script -qF "$transcript" env -u NO_COLOR \ - "TERM=xterm" \ - "CLICOLOR=1" \ - "CLICOLOR_FORCE=0" \ - "REWATCH_REAL_BSC=$RESCRIPT_BSC_EXE" \ - "REWATCH_BSC_PROXY_MODE=parse-warning" \ - "RESCRIPT_BSC_EXE=$parse_warning_bsc" \ - "RESCRIPT_RUNTIME=$RESCRIPT_RUNTIME" \ - "$executable" build "$project" --no-timing >/dev/null - else - script -qefc \ - "env -u NO_COLOR TERM=xterm CLICOLOR=1 CLICOLOR_FORCE=0 REAL_BSC_EXE=$RESCRIPT_BSC_EXE REWATCH_REAL_BSC=$RESCRIPT_BSC_EXE REWATCH_BSC_PROXY_MODE=parse-warning RESCRIPT_BSC_EXE=$parse_warning_bsc RESCRIPT_RUNTIME=$RESCRIPT_RUNTIME $command_executable build $command_project --no-timing" \ - "$transcript" >/dev/null - fi - tr '\r' '\n' <"$transcript" \ - | normalize_output \ - | grep -E '(^\[[123]/3\] .* Parsed |PARSE_WARNING_MARKER)' \ - >"$work/$implementation-parse-warning.order" -} - -echo "Checking interactive parser warnings..." -capture_parse_warning_order rust "$rust" -capture_parse_warning_order ocaml "$ocaml" - -if ! cmp -s "$work/rust-parse-warning.order" \ - "$work/ocaml-parse-warning.order"; then - echo "Parser warning phase order differs" >&2 - printf '%s\n' '--- Rust order ---' >&2 - cat "$work/rust-parse-warning.order" >&2 - printf '%s\n' '--- OCaml order ---' >&2 - cat "$work/ocaml-parse-warning.order" >&2 - exit 1 -fi - -if ! sed -n '1p' "$work/ocaml-parse-warning.order" \ - | grep -E '^\[2/3\] .* Parsed 1 source files in 0.00s$' >/dev/null; then - echo "Parser warnings were emitted before the completed parse phase" >&2 - cat "$work/ocaml-parse-warning.order" >&2 - exit 1 -fi - capture_after_build_order() { implementation=$1 executable=$2 diff --git a/rewatch-ocaml/tests/ppx-filter/rescript.json b/rewatch-ocaml/tests/ppx-filter/rescript.json index b1d194899bf..91de1018199 100644 --- a/rewatch-ocaml/tests/ppx-filter/rescript.json +++ b/rewatch-ocaml/tests/ppx-filter/rescript.json @@ -1,5 +1,9 @@ { "name": "rewatch-ocaml-ppx-filter", "sources": "src", - "ppx-flags": ["missing-graphql-ppx"] + "ppx-flags": [ + "missing-graphql-ppx", + "missing-rescript-schema-ppx", + "missing-sury-ppx" + ] } diff --git a/rewatch-ocaml/tests/run.sh b/rewatch-ocaml/tests/run.sh index 1e3a0e9825b..64eaecfd5d8 100644 --- a/rewatch-ocaml/tests/run.sh +++ b/rewatch-ocaml/tests/run.sh @@ -11,34 +11,14 @@ port="$1" port_directory=$(CDPATH= cd -- "$(dirname "$port")" && pwd) port="$port_directory/$(basename "$port")" root=$(CDPATH= cd -- "$(dirname "$0")/../.." && pwd) -: "${RESCRIPT_BSC_EXE:=$root/_build/default/compiler/bsc/rescript_compiler_main.exe}" : "${RESCRIPT_RUNTIME:=$root/packages/@rescript/runtime}" -test_proxy="$root/_build/default/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.exe" native_path() { if $windows_posix_shell; then cygpath -am "$1"; else printf '%s\n' "$1"; fi } -assert_no_test_proxy_processes() { - if $windows_posix_shell; then - if ! powershell.exe -NoProfile -NonInteractive -Command \ - 'if (Get-Process -Name rewatch_bsc_test_proxy -ErrorAction SilentlyContinue) { exit 1 }'; then - echo "rewatch compiler test proxy was left running" >&2 - powershell.exe -NoProfile -NonInteractive -Command \ - 'Get-Process -Name rewatch_bsc_test_proxy -ErrorAction SilentlyContinue | Format-Table -AutoSize' >&2 - exit 1 - fi - # Match only this checkout's proxy: other worktrees may run tests concurrently. - elif test -n "$(pgrep -f -- "$test_proxy_pattern" || true)"; then - echo "rewatch compiler test proxy was left running" >&2 - exit 1 - fi -} if $windows_posix_shell; then - RESCRIPT_BSC_EXE=$(native_path "$RESCRIPT_BSC_EXE") RESCRIPT_RUNTIME=$(native_path "$RESCRIPT_RUNTIME") - test_proxy=$(native_path "$test_proxy") fi -test_proxy_pattern=$(printf '%s\n' "$test_proxy" | sed 's/[][\.*^$+?(){}|]/\\&/g') -export RESCRIPT_BSC_EXE RESCRIPT_RUNTIME +export RESCRIPT_RUNTIME work="$root/tmp/rewatch-ocaml/test-$$" mkdir -p "$work" cp -R "$root/rewatch-ocaml/tests/basic" "$work/basic" @@ -125,7 +105,6 @@ for dependency in namespace-one namespace-two; do "$work/namespace-collision/node_modules/$dependency" done cp -R "$root/rewatch-ocaml/tests/source-map" "$work/source-map" -cp -R "$root/rewatch-ocaml/tests/warning-replay" "$work/warning-replay" cp -R "$root/rewatch-ocaml/tests/monorepo" "$work/monorepo" basic="$work/basic" cleanup_lifecycle="$work/cleanup-lifecycle" @@ -152,7 +131,6 @@ namespace_entry="$work/namespace-entry" qualified_namespace="$work/qualified-namespace" namespace_collision="$work/namespace-collision" source_map="$work/source-map" -warning_replay="$work/warning-replay" monorepo="$work/monorepo" package_name_mismatch="$work/package-name-mismatch" @@ -245,13 +223,6 @@ printf 'let dependent = A.value + 1\n' \ printf 'let valid = true\n' \ >"$interface_failure_recovery/src/Broken.res" -atomic_save="$work/atomic-save" -mkdir -p "$atomic_save/src" -printf '%s\n' \ - '{"name":"atomic-save","sources":"src/","package-specs":{"module":"esmodule","in-source":true,"suffix":".mjs"}}' \ - >"$atomic_save/rescript.json" -printf 'let value = 1\n' >"$atomic_save/src/Main.res" - missing_nested_source="$work/missing-nested-source" mkdir -p "$missing_nested_source" printf '%s\n' \ @@ -394,14 +365,6 @@ printf '%s\n' \ >"$moved_source/rescript.json" printf 'let value = 1\n' >"$moved_source/src/A.res" -publication_cmi="$work/publication-cmi" -mkdir -p "$publication_cmi/src" -printf '%s\n' \ - '{"name":"publication-cmi","sources":"src","package-specs":{"module":"esmodule","in-source":true,"suffix":".mjs"}}' \ - >"$publication_cmi/rescript.json" -printf 'let value = 1\n' >"$publication_cmi/src/A.res" -printf 'let dependent = A.value + 1\n' >"$publication_cmi/src/B.res" - retained_cycle="$work/retained-cycle" mkdir -p "$retained_cycle/src" printf '%s\n' \ @@ -410,14 +373,6 @@ printf '%s\n' \ printf 'let value = 1\n' >"$retained_cycle/src/A.res" printf 'let dependent = A.value\n' >"$retained_cycle/src/B.res" -retained_parse="$work/retained-parse" -mkdir -p "$retained_parse/src" -printf '%s\n' \ - '{"name":"retained-parse","sources":"src","package-specs":{"module":"esmodule","in-source":true,"suffix":".mjs"}}' \ - >"$retained_parse/rescript.json" -printf 'let value = 1\n' >"$retained_parse/src/A.res" -printf 'let other = 1\n' >"$retained_parse/src/B.res" - initial_failure_freshness="$work/initial-failure-freshness" mkdir -p "$initial_failure_freshness/src" printf '%s\n' \ @@ -516,29 +471,25 @@ for namespace_dependency_name in ns-one ns-two; do "$external_namespace/node_modules/$namespace_dependency_name" done -dev_include_order="$work/dev-include-order" -mkdir -p "$dev_include_order/src" "$dev_include_order/dev" \ - "$dev_include_order/node_modules/regular/src" \ - "$dev_include_order/node_modules/development/src" -printf '%s\n' \ - '{"name":"dev-include-root","sources":["src",{"dir":"dev","type":"dev"}],"dependencies":["regular"],"dev-dependencies":["development"]}' \ - >"$dev_include_order/rescript.json" -printf 'let value = 1\n' >"$dev_include_order/src/Main.res" -printf 'let value = 2\n' >"$dev_include_order/dev/Test.res" -printf '%s\n' '{"name":"regular","sources":"src"}' \ - >"$dev_include_order/node_modules/regular/rescript.json" -printf 'let value = 1\n' \ - >"$dev_include_order/node_modules/regular/src/Regular.res" -printf '%s\n' '{"name":"development","sources":"src"}' \ - >"$dev_include_order/node_modules/development/rescript.json" -printf 'let value = 1\n' \ - >"$dev_include_order/node_modules/development/src/Development.res" - -if [ -x "$port_directory/bsc.exe" ]; then - env -u RESCRIPT_BSC_EXE "$port" build "$packaged_basic" \ - >"$packaged_basic/build.log" - test -f "$packaged_basic/src/A.mjs" -fi +# Builds use the embedded compiler, but editor tooling finds bsc.exe and the +# other platform binaries through compiler-info.json, so it must record the +# bsc.exe shipped next to the executable. +"$port" build "$packaged_basic" >"$packaged_basic/build.log" +test -f "$packaged_basic/src/A.mjs" +COMPILER_INFO=$(native_path "$packaged_basic/lib/bs/compiler-info.json") \ + EXPECTED_BSC=$(native_path "$port_directory/bsc.exe") node -e ' + const fs = require("node:fs"); + const path = require("node:path"); + const info = JSON.parse(fs.readFileSync(process.env.COMPILER_INFO, "utf8")); + const expected = path.join( + fs.realpathSync(path.dirname(process.env.EXPECTED_BSC)), + "bsc.exe", + ); + if (path.relative(info.bsc_path, expected) !== "") { + console.error(`compiler-info.json bsc_path ${info.bsc_path}, expected ${expected}`); + process.exit(1); + } +' mkdir -p "$runtime_discovery/node_modules/@rescript/runtime" runtime_path=$(CDPATH= cd -- \ @@ -1200,42 +1151,6 @@ grep 'does not match the interface' \ grep 'Parsed 0 source files' "$directory_symlink/unchanged.log" >/dev/null grep 'Compiled 0 modules' "$directory_symlink/unchanged.log" >/dev/null -# Record the content that triggered a direct event before building it. An -# atomic replacement made while that build is compiling must cause a second -# build rather than becoming the post-build snapshot baseline. -atomic_release="$atomic_save/release" -atomic_started="$atomic_save/compile-started" -touch "$atomic_release" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=block-compile \ - REWATCH_OCAML_RELEASE_FILE="$(native_path "$atomic_release")" \ - REWATCH_OCAML_COMPILE_STARTED="$(native_path "$atomic_started")" \ - "$port" watch "$atomic_save" >"$atomic_save/watch.log" 2>&1 & -atomic_save_pid=$! -background_pids="$background_pids $atomic_save_pid" -if ! wait_for_file "$atomic_save/src/Main.mjs"; then - cat "$atomic_save/watch.log" >&2 - exit 1 -fi -wait_for_initial_build "$atomic_save/watch.log" -rm "$atomic_release" "$atomic_started" -printf 'let value = 2\n' >"$atomic_save/src/Main.res" -if ! wait_for_file "$atomic_started"; then - cat "$atomic_save/watch.log" >&2 - exit 1 -fi -printf 'let value = 3\n' >"$atomic_save/src/Main.next" -mv "$atomic_save/src/Main.next" "$atomic_save/src/Main.res" -touch "$atomic_release" -if ! wait_for_text "$atomic_save/src/Main.mjs" 'value = 3'; then - cat "$atomic_save/watch.log" >&2 - cat "$atomic_save/src/Main.mjs" >&2 - exit 1 -fi -kill -TERM "$atomic_save_pid" -wait "$atomic_save_pid" 2>/dev/null || true - "$port" watch "$recursive_lib" >"$recursive_lib/watch.log" 2>&1 & recursive_lib_pid=$! background_pids="$background_pids $recursive_lib_pid" @@ -1519,38 +1434,6 @@ fi kill -TERM "$namespace_repair_pid" wait "$namespace_repair_pid" 2>/dev/null || true -publication_destination="$publication_cmi/lib/bs/src/A.res" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=fail-late-publication \ - REWATCH_FAIL_PUBLICATION="$(native_path "$publication_cmi/fail-publication")" \ - REWATCH_PUBLICATION_FAILED="$(native_path "$publication_cmi/publication-failed")" \ - REWATCH_PUBLICATION_DESTINATION="$(native_path "$publication_destination")" \ - "$port" watch "$publication_cmi" >"$publication_cmi/watch.log" 2>&1 & -publication_cmi_pid=$! -background_pids="$background_pids $publication_cmi_pid" -if ! wait_for_file "$publication_cmi/src/B.mjs"; then - cat "$publication_cmi/watch.log" >&2 - exit 1 -fi -wait_for_initial_build "$publication_cmi/watch.log" -touch "$publication_cmi/fail-publication" -printf 'let value = "changed"\n' >"$publication_cmi/src/A.res" -if ! wait_for_file "$publication_cmi/publication-failed" || \ - ! wait_for_text "$publication_cmi/watch.log" 'A.res'; then - cat "$publication_cmi/watch.log" >&2 - exit 1 -fi -remove_obstruction_directory "$publication_destination" -rm "$publication_cmi/fail-publication" -printf 'let value = "changed"\n\n' >"$publication_cmi/src/A.res" -if ! wait_for_text "$publication_cmi/watch.log" 'This has type:'; then - cat "$publication_cmi/watch.log" >&2 - exit 1 -fi -kill -TERM "$publication_cmi_pid" -wait "$publication_cmi_pid" 2>/dev/null || true - "$port" watch "$retained_cycle" >"$retained_cycle/watch.log" 2>&1 & retained_cycle_pid=$! background_pids="$background_pids $retained_cycle_pid" @@ -1608,61 +1491,6 @@ fi kill -TERM "$initial_failure_freshness_pid" wait "$initial_failure_freshness_pid" 2>/dev/null || true -# Failed parses and parser warnings remain pending until the same source parses -# cleanly. An unrelated edit must not compile an older AST or forget diagnostics. -retained_parse_log="$retained_parse/watch.log" -retained_parse_calls="$retained_parse/bsc-calls.log" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=parse-warning-log \ - REWATCH_BSC_CALL_LOG="$(native_path "$retained_parse_calls")" \ - REWATCH_PARSE_WARNING_SOURCE=A.res \ - "$port" watch "$retained_parse" >"$retained_parse_log" 2>&1 & -retained_parse_pid=$! -background_pids="$background_pids $retained_parse_pid" -if ! wait_for_count "$retained_parse_log" REWATCH_PARSE_WARNING 1 || \ - ! wait_for_file "$retained_parse/src/A.mjs"; then - cat "$retained_parse_log" >&2 - exit 1 -fi -wait_for_initial_build "$retained_parse_log" -initial_a_parse_count=$(grep -c -- '-bs-ast.*A.res' "$retained_parse_calls") -printf 'let other = 2\n' >"$retained_parse/src/B.res" -if ! wait_for_count "$retained_parse_log" REWATCH_PARSE_WARNING 2; then - cat "$retained_parse_log" >&2 - exit 1 -fi -if ! wait_for_count "$retained_parse_calls" '-bs-ast.*A.res' \ - "$((initial_a_parse_count + 1))"; then - cat "$retained_parse_calls" >&2 - exit 1 -fi -warning_a_parse_count=$(grep -c -- '-bs-ast.*A.res' "$retained_parse_calls") -test "$warning_a_parse_count" -gt "$initial_a_parse_count" -printf 'let value =\n' >"$retained_parse/src/A.res" -if ! wait_for_count "$retained_parse_log" \ - 'This let-binding misses an expression' 1; then - cat "$retained_parse_log" >&2 - exit 1 -fi -failed_a_parse_count=$(grep -c -- '-bs-ast.*A.res' "$retained_parse_calls") -printf 'let other = 3\n' >"$retained_parse/src/B.res" -if ! wait_for_count "$retained_parse_log" \ - 'This let-binding misses an expression' 2; then - cat "$retained_parse_log" >&2 - exit 1 -fi -retried_a_parse_count=$(grep -c -- '-bs-ast.*A.res' "$retained_parse_calls") -test "$retried_a_parse_count" -gt "$failed_a_parse_count" -grep 'value = 1' "$retained_parse/src/A.mjs" >/dev/null -printf 'let value = 2\n' >"$retained_parse/src/A.res" -if ! wait_for_text "$retained_parse/src/A.mjs" 'value = 2'; then - cat "$retained_parse_log" >&2 - exit 1 -fi -kill -TERM "$retained_parse_pid" -wait "$retained_parse_pid" 2>/dev/null || true - "$port" build "$duplicate_selection" >/dev/null "$port" build "$external_duplicate" >"$external_duplicate/build.log" 2>&1 tr '\\' '/' <"$external_duplicate/build.log" | \ @@ -1733,34 +1561,13 @@ fi kill -TERM "$transitive_local_watch_pid" wait "$transitive_local_watch_pid" 2>/dev/null || true -dev_include_call_log="$dev_include_order/bsc-calls.log" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=counting \ - REWATCH_BSC_CALL_LOG="$(native_path "$dev_include_call_log")" \ - "$port" build "$dev_include_order" >/dev/null -node - "$dev_include_call_log" \ - "$dev_include_order/node_modules/development/lib/ocaml" \ - "$dev_include_order/node_modules/regular/lib/ocaml" <<'EOF' -const fs = require("fs"); -const [log, development, regular] = process.argv.slice(2); -const normalize = value => value.replaceAll("\\", "/"); -const command = fs.readFileSync(log, "utf8").split("\n") - .find(line => line.includes("Test.ast") && !line.includes("-bs-ast")); -const normalizedCommand = command === undefined ? "" : normalize(command); -if (!command || normalizedCommand.indexOf(normalize(development)) < 0 || - normalizedCommand.indexOf(normalize(development)) > - normalizedCommand.indexOf(normalize(regular))) { - process.exit(1); -} -EOF - -warning_call_log="$warning_replay/bsc-calls.log" +# A watch rebuild after an unrelated edit replays warnings from modules it +# doesn't recompile. Compiler requests are counted at the logical request log. +cp -R "$root/rewatch-ocaml/tests/warning-replay" "$work/warning-replay" +warning_replay="$work/warning-replay" +warning_call_log="$warning_replay/compiler-calls.log" warning_watch_log="$warning_replay/watch.log" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=counting \ - REWATCH_BSC_CALL_LOG="$(native_path "$warning_call_log")" \ +env REWATCH_COMPILER_CALL_LOG="$(native_path "$warning_call_log")" \ "$port" watch "$warning_replay" >"$warning_watch_log" 2>&1 & warning_watch_pid=$! background_pids="$background_pids $warning_watch_pid" @@ -1832,62 +1639,13 @@ stop_watch "$watch_basic" "$watch_restart_pid" test ! -f "$watch_basic/lib/watch.lock" if ! $windows_posix_shell; then -interrupt_basic="$work/interrupt-basic" -cp -R "$root/rewatch-ocaml/tests/basic" "$interrupt_basic" -child_marker="$interrupt_basic/child-started" -REWATCH_OCAML_CHILD_STARTED="$(native_path "$child_marker")" \ -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=slow \ -RESCRIPT_BSC_EXE="$test_proxy" \ -"$port" watch "$interrupt_basic" >"$interrupt_basic/watch.log" 2>&1 & -interrupt_pid=$! -background_pids="$background_pids $interrupt_pid" -attempts=0 -while [ "$attempts" -lt 100 ] && [ ! -f "$child_marker" ]; do - attempts=$((attempts + 1)) - sleep 0.1 -done -test -f "$child_marker" -kill -TERM "$interrupt_pid" -wait "$interrupt_pid" -test ! -f "$interrupt_basic/lib/watch.lock" -assert_no_test_proxy_processes -test -z "$(find "$interrupt_basic" -name '.rewatch-ocaml-*.log' -print)" - -# One-shot commands must unwind through the same process and lock owners when -# the shell terminates them during compiler work. Compiler children run in -# their own process groups, so a closing terminal's SIGHUP and a SIGQUIT reach -# only rescript and must be handled like SIGTERM, or the children outlive the -# build and its lock is left behind. -for interrupt_signal in TERM:143 HUP:129 QUIT:131; do - signal_name=${interrupt_signal%%:*} - expected_status=${interrupt_signal#*:} - interrupt_build="$work/interrupt-build-$signal_name" - cp -R "$root/rewatch-ocaml/tests/basic" "$interrupt_build" - build_child_marker="$interrupt_build/child-started" - REWATCH_OCAML_CHILD_STARTED="$(native_path "$build_child_marker")" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=slow \ - RESCRIPT_BSC_EXE="$test_proxy" \ - "$port" build "$interrupt_build" >"$interrupt_build/build.log" 2>&1 & - interrupt_build_pid=$! - background_pids="$background_pids $interrupt_build_pid" - wait_for_file "$build_child_marker" - kill "-$signal_name" "$interrupt_build_pid" - set +e - wait "$interrupt_build_pid" - interrupt_build_status=$? - set -e - test "$interrupt_build_status" -eq "$expected_status" - test ! -f "$interrupt_build/lib/build.lock" - assert_no_test_proxy_processes - test -z "$(find "$interrupt_build" -name '.rewatch-ocaml-*.log' -print)" -done - -# The same signals must also stop a build while it waits for an external -# js-post-build hook, which runs in its own process group too. The hook records -# its pid and then sleeps, so the build is still running when it is signalled; -# the hook must be gone afterwards and the build lock released. +# One-shot builds must unwind through the same process and lock owners when +# the shell terminates them. Compilation runs in process, but a js-post-build +# hook is still an external child in its own process group, so a closing +# terminal's SIGHUP and a SIGQUIT reach only rescript and must be handled like +# SIGTERM, or the hook outlives the build and its lock is left behind. The hook +# records its pid and then sleeps, so the build is still running when it is +# signalled. for hook_signal in TERM:143 HUP:129 QUIT:131; do signal_name=${hook_signal%%:*} expected_status=${hook_signal#*:} @@ -1930,66 +1688,268 @@ for hook_signal in TERM:143 HUP:129 QUIT:131; do done fi -# Removing watch.lock is the shell-suite shutdown protocol. It must interrupt -# an in-progress compiler batch just as SIGTERM does, rather than waiting for -# every queued module to finish. -lock_interrupt_basic="$work/lock-interrupt-basic" -cp -R "$root/rewatch-ocaml/tests/basic" "$lock_interrupt_basic" -lock_child_marker="$lock_interrupt_basic/child-started" -REWATCH_OCAML_CHILD_STARTED="$(native_path "$lock_child_marker")" \ -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=slow \ -RESCRIPT_BSC_EXE="$test_proxy" \ -"$port" watch "$lock_interrupt_basic" \ - >"$lock_interrupt_basic/watch.log" 2>&1 & +# One large module keeps an in-process compile running for seconds. +second_interrupt="$work/second-interrupt" +mkdir -p "$second_interrupt/src" +printf '%s\n' '{"name":"second-interrupt","sources":"src","package-specs":{"module":"esmodule","in-source":true}}' \ + >"$second_interrupt/rescript.json" +awk 'BEGIN { for (i = 1; i <= 200000; i++) printf "let v%d = (%d, \"%d\")\n", i, i, i }' \ + >"$second_interrupt/src/Slow.res" + +# A second build waits for the first one's build lock and then runs. +"$port" -vv build "$second_interrupt" >"$second_interrupt/first.log" 2>&1 & +lock_first_pid=$! +background_pids="$background_pids $lock_first_pid" +# Logged when the parsed module is handed to the compiler. +if ! wait_for_text "$second_interrupt/first.log" 'compile dirty: Slow'; then + cat "$second_interrupt/first.log" >&2 + echo "large module did not reach the compiler" >&2 + exit 1 +fi +"$port" build "$second_interrupt" >"$second_interrupt/second.log" 2>&1 & +lock_second_pid=$! +background_pids="$background_pids $lock_second_pid" +wait_for_text "$second_interrupt/second.log" "Waiting for other build to finish" +test ! -f "$second_interrupt/src/Slow.js" +if ! wait "$lock_first_pid"; then + cat "$second_interrupt/first.log" >&2 + exit 1 +fi +if ! wait "$lock_second_pid"; then + cat "$second_interrupt/second.log" >&2 + exit 1 +fi +test -f "$second_interrupt/src/Slow.js" +test ! -f "$second_interrupt/lib/build.lock" + +# A stop waits for the modules compiling in-process, and a repeated signal +# does not cut it short: the npm launcher forwards the Ctrl-C the terminal +# already delivered. The stop leaves no lock or temporary files, and the next +# build completes the module. +if ! $windows_posix_shell; then + printf 'let dirty = 1\n' >>"$second_interrupt/src/Slow.res" + rm "$second_interrupt/src/Slow.js" + mkdir -p "$second_interrupt/tmp" + TMPDIR="$second_interrupt/tmp" \ + "$port" -vv build "$second_interrupt" >"$second_interrupt/build.log" 2>&1 & + second_interrupt_pid=$! + background_pids="$background_pids $second_interrupt_pid" + # Logged when the parsed module is handed to the compiler. + if ! wait_for_text "$second_interrupt/build.log" 'compile dirty: Slow'; then + echo "large module did not reach the compiler" >&2 + exit 1 + fi + kill -INT "$second_interrupt_pid" + # The forwarded copy arrives a little later, as a separate signal. + sleep 0.2 + kill -INT "$second_interrupt_pid" + if ! wait_for_pid_gone "$second_interrupt_pid" 600; then + echo "an interrupted in-process compile did not stop" >&2 + exit 1 + fi + set +e + wait "$second_interrupt_pid" + second_interrupt_status=$? + set -e + if [ "$second_interrupt_status" -ne 130 ] || \ + [ -e "$second_interrupt/lib/build.lock" ] || \ + [ -n "$(ls "$second_interrupt/tmp")" ]; then + cat "$second_interrupt/build.log" >&2 + ls "$second_interrupt/tmp" >&2 + echo "repeated signal: status $second_interrupt_status, expected 130 without a lock or temporary files" >&2 + exit 1 + fi + "$port" build "$second_interrupt" >"$second_interrupt/after.log" 2>&1 + test -f "$second_interrupt/src/Slow.js" +fi + +# Namespace maps compile on the worker domains, and a stop is noticed between +# them instead of after the last one. +if ! $windows_posix_shell; then + namespace_stop="$work/namespace-stop" + namespace_stop_count=100 + mkdir -p "$namespace_stop/node_modules" + namespace_stop_deps="" + for i in $(seq 1 "$namespace_stop_count"); do + mkdir -p "$namespace_stop/packages/p$i/src" + printf '{"name":"p%d","sources":"src","namespace":true}\n' "$i" \ + >"$namespace_stop/packages/p$i/rescript.json" + printf '{"name":"p%d","version":"1.0.0"}\n' "$i" \ + >"$namespace_stop/packages/p$i/package.json" + printf 'let value = %d\n' "$i" >"$namespace_stop/packages/p$i/src/M.res" + directory_link "$namespace_stop/packages/p$i" "$namespace_stop/node_modules/p$i" + namespace_stop_deps="$namespace_stop_deps\"p$i\"," + done + printf '{"name":"root","sources":[],"dependencies":[%s]}\n' \ + "${namespace_stop_deps%,}" >"$namespace_stop/rescript.json" + printf '{"name":"root","private":true,"workspaces":["packages/*"]}\n' \ + >"$namespace_stop/package.json" + REWATCH_COMPILER_CALL_LOG="$namespace_stop/calls.log" \ + "$port" build "$namespace_stop" >"$namespace_stop/build.log" 2>&1 & + namespace_stop_pid=$! + background_pids="$background_pids $namespace_stop_pid" + until grep -q '^namespace' "$namespace_stop/calls.log" 2>/dev/null || \ + ! kill -0 "$namespace_stop_pid" 2>/dev/null; do + : + done + kill -TERM "$namespace_stop_pid" + set +e + wait "$namespace_stop_pid" + namespace_stop_status=$? + set -e + namespace_stop_compiled=$(grep -c '^namespace' "$namespace_stop/calls.log") + if [ "$namespace_stop_status" -ne 143 ] || \ + [ "$namespace_stop_compiled" -ge "$namespace_stop_count" ]; then + echo "a stop during namespace maps: status $namespace_stop_status after $namespace_stop_compiled of $namespace_stop_count maps" >&2 + exit 1 + fi +fi + +# write_slow_module PATH VALUE: a module whose in-process compile takes a few +# seconds, so a test can act while it runs. VALUE marks the version. +write_slow_module() { + awk -v value="$2" 'BEGIN { + printf "let value = %s\n", value + for (i = 1; i <= 60000; i++) printf "let v%d = (%d, \"%d\")\n", i, i, i + }' >"$1" +} +slow_project() { + mkdir -p "$1/src" + printf '%s\n' '{"name":"slow","sources":"src","package-specs":{"module":"esmodule","in-source":true}}' \ + >"$1/rescript.json" + write_slow_module "$1/src/Slow.res" 1 + printf 'let dependent = Slow.value\n' >"$1/src/Dependent.res" +} + +# A signal during compiler work stops the build after the module compiling +# in-process: its dependent is not compiled, the exit status is the signal's +# and the lock is released. A closing terminal's SIGHUP and SIGQUIT are handled +# like SIGTERM. +if ! $windows_posix_shell; then + for interrupt_signal in TERM:143 HUP:129 QUIT:131; do + signal_name=${interrupt_signal%%:*} + expected_status=${interrupt_signal#*:} + interrupt_build="$work/interrupt-build-$signal_name" + slow_project "$interrupt_build" + "$port" -vv build "$interrupt_build" >"$interrupt_build/build.log" 2>&1 & + interrupt_build_pid=$! + background_pids="$background_pids $interrupt_build_pid" + if ! wait_for_text "$interrupt_build/build.log" 'compile dirty: Slow'; then + echo "large module did not reach the compiler before $signal_name" >&2 + exit 1 + fi + kill "-$signal_name" "$interrupt_build_pid" + set +e + wait "$interrupt_build_pid" + interrupt_build_status=$? + set -e + if [ "$interrupt_build_status" -ne "$expected_status" ] || \ + [ -e "$interrupt_build/lib/build.lock" ] || \ + [ -e "$interrupt_build/src/Dependent.js" ]; then + cat "$interrupt_build/build.log" >&2 + echo "$signal_name during compiler work: status $interrupt_build_status, expected $expected_status without a lock or further compiles" >&2 + exit 1 + fi + done +fi + +# Removing watch.lock is the shell suite's shutdown protocol. It stops a +# watcher's compiler work like a signal, before the queued dependent. +lock_interrupt="$work/lock-interrupt" +slow_project "$lock_interrupt" +"$port" -vv watch "$lock_interrupt" >"$lock_interrupt/watch.log" 2>&1 & lock_interrupt_pid=$! background_pids="$background_pids $lock_interrupt_pid" -if ! wait_for_file "$lock_child_marker"; then - cat "$lock_interrupt_basic/watch.log" >&2 +if ! wait_for_text "$lock_interrupt/watch.log" 'compile dirty: Slow'; then + echo "large module did not reach the compiler" >&2 exit 1 fi -remove_file_with_retry "$lock_interrupt_basic/lib/watch.lock" -if ! wait_for_pid_gone "$lock_interrupt_pid"; then +remove_file_with_retry "$lock_interrupt/lib/watch.lock" +if ! wait_for_pid_gone "$lock_interrupt_pid" 600; then echo "watcher did not stop during compiler work after watch.lock removal" >&2 exit 1 fi -wait "$lock_interrupt_pid" -assert_no_test_proxy_processes - -lock_basic="$work/lock-basic" -cp -R "$root/rewatch-ocaml/tests/basic" "$lock_basic" -rm -rf "$lock_basic/lib" -rm -f "$lock_basic/src/A.mjs" "$lock_basic/src/B.mjs" \ - "$lock_basic/src/WithInterface.mjs" -first_marker="$lock_basic/first-child-started" -release_marker="$lock_basic/release-first-build" -REWATCH_OCAML_CHILD_STARTED="$(native_path "$first_marker")" \ -REWATCH_OCAML_RELEASE_FILE="$(native_path "$release_marker")" \ -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=slow \ -RESCRIPT_BSC_EXE="$test_proxy" \ - "$port" build "$lock_basic" >"$lock_basic/first.log" 2>&1 & -first_build_pid=$! -background_pids="$background_pids $first_build_pid" -wait_for_file "$first_marker" -workspace_build_lock="$lock_basic/lib/build.lock" -test -f "$workspace_build_lock" -"$port" build "$lock_basic" >"$lock_basic/second.log" 2>&1 & -second_build_pid=$! -background_pids="$background_pids $second_build_pid" -wait_for_text "$lock_basic/second.log" "Waiting for other build to finish" -test ! -f "$lock_basic/src/A.mjs" -touch "$release_marker" -if ! wait "$first_build_pid"; then - cat "$lock_basic/first.log" >&2 - exit 1 -fi -if ! wait "$second_build_pid"; then - cat "$lock_basic/second.log" >&2 - exit 1 -fi -test -f "$lock_basic/src/A.mjs" -test ! -f "$workspace_build_lock" +wait "$lock_interrupt_pid" 2>/dev/null || true +if [ -e "$lock_interrupt/src/Dependent.js" ]; then + cat "$lock_interrupt/watch.log" >&2 + echo "watcher compiled queued modules after watch.lock removal" >&2 + exit 1 +fi + +# An atomic save made while a rebuild compiles causes another build instead of +# becoming the baseline of the next one. +atomic_save="$work/atomic-save-rebuild" +slow_project "$atomic_save" +"$port" -vv watch "$atomic_save" >"$atomic_save/watch.log" 2>&1 & +atomic_save_pid=$! +background_pids="$background_pids $atomic_save_pid" +if ! wait_for_text "$atomic_save/watch.log" 'Finished initial compilation' 1 1200; then + echo "watcher did not finish its initial build" >&2 + exit 1 +fi +write_slow_module "$atomic_save/src/Slow.res" 2 +if ! wait_for_text "$atomic_save/watch.log" 'compile dirty: Slow' 2 600; then + echo "the edited large module did not reach the compiler" >&2 + exit 1 +fi +write_slow_module "$atomic_save/src/Slow.next" 3 +mv "$atomic_save/src/Slow.next" "$atomic_save/src/Slow.res" +if ! wait_for_text "$atomic_save/src/Slow.js" 'value = 3' 1 1200; then + cat "$atomic_save/watch.log" >&2 + echo "an atomic save during a rebuild was not built" >&2 + exit 1 +fi +remove_file_with_retry "$atomic_save/lib/watch.lock" +wait "$atomic_save_pid" 2>/dev/null || true + +# A failed parse stays pending until the source parses: an unrelated edit +# parses it again and reports the error again, and its old AST is never +# compiled. +retained_parse="$work/retained-parse" +mkdir -p "$retained_parse/src" +printf '%s\n' '{"name":"retained-parse","sources":"src","package-specs":{"module":"esmodule","in-source":true}}' \ + >"$retained_parse/rescript.json" +printf 'let value = 1\n' >"$retained_parse/src/A.res" +printf 'let other = 1\n' >"$retained_parse/src/B.res" +REWATCH_COMPILER_CALL_LOG="$retained_parse/calls.log" \ + "$port" watch "$retained_parse" >"$retained_parse/watch.log" 2>&1 & +retained_parse_pid=$! +background_pids="$background_pids $retained_parse_pid" +wait_for_initial_build "$retained_parse/watch.log" +printf 'let value =\n' >"$retained_parse/src/A.res" +wait_for_text "$retained_parse/watch.log" 'This let-binding misses an expression' +failed_parses=$(grep -c '^parse.*A\.res' "$retained_parse/calls.log") +printf 'let other = 2\n' >"$retained_parse/src/B.res" +wait_for_text "$retained_parse/watch.log" 'This let-binding misses an expression' 2 +test "$(grep -c '^parse.*A\.res' "$retained_parse/calls.log")" -gt "$failed_parses" +grep 'value = 1' "$retained_parse/src/A.js" >/dev/null +printf 'let value = 2\n' >"$retained_parse/src/A.res" +wait_for_text "$retained_parse/src/A.js" 'value = 2' +remove_file_with_retry "$retained_parse/lib/watch.lock" +wait "$retained_parse_pid" 2>/dev/null || true + +# A damaged published AST, such as one cut short by a killed build, makes its +# module parse again instead of failing every later build. +damaged_ast="$work/damaged-ast" +mkdir -p "$damaged_ast/src" +printf '%s\n' '{"name":"damaged-ast","sources":"src","package-specs":{"module":"esmodule","in-source":true}}' \ + >"$damaged_ast/rescript.json" +printf 'let value = 1\n' >"$damaged_ast/src/A.res" +printf 'let value = A.value + 1\n' >"$damaged_ast/src/B.res" +"$port" build "$damaged_ast" >/dev/null +for damage in empty garbled; do + case $damage in + empty) : >"$damaged_ast/lib/ocaml/A.ast" ;; + garbled) printf '\377\377\377\377' >"$damaged_ast/lib/ocaml/A.ast" ;; + esac + if ! "$port" build "$damaged_ast" >"$damaged_ast/$damage.log" 2>&1; then + cat "$damaged_ast/$damage.log" >&2 + echo "a build failed after an $damage published AST" >&2 + exit 1 + fi + test -s "$damaged_ast/lib/ocaml/A.ast" + test -f "$damaged_ast/src/B.js" +done # dep-union is requested with [web] by consumer, then with all features by # consumer's dev-dependency, then with [native] by the root. All features win @@ -2139,35 +2099,111 @@ fi "$port" build "$ppx_filter" test -f "$ppx_filter/src/Main.js" +# A failing PPX leaves no temporary AST files behind. +ppx_cleanup="$work/ppx-temp-cleanup" +mkdir -p "$ppx_cleanup/src" "$ppx_cleanup/tmp" +printf '{"name":"ppx-temp-cleanup","sources":"src","ppx-flags":["%s/missing-ppx"]}\n' \ + "$ppx_cleanup" >"$ppx_cleanup/rescript.json" +printf 'let value = 1\n' >"$ppx_cleanup/src/A.res" +if TMPDIR="$ppx_cleanup/tmp" TEMP="$ppx_cleanup/tmp" TMP="$ppx_cleanup/tmp" \ + "$port" build "$ppx_cleanup" >"$ppx_cleanup/build.log" 2>&1; then + echo "a build with a missing PPX succeeded" >&2 + exit 1 +fi +if ls "$ppx_cleanup/tmp" | grep -q '^ppx'; then + ls "$ppx_cleanup/tmp" >&2 + echo "a failing PPX left temporary files" >&2 + exit 1 +fi +# Compiler output is captured in memory: a build needs no temporary directory. +no_temp="$work/no-temp-dir" +mkdir -p "$no_temp/src" +printf '{"name":"no-temp-dir","sources":"src"}\n' >"$no_temp/rescript.json" +printf 'let value = 1\n' >"$no_temp/src/A.res" +if ! TMPDIR="$work/missing-temp" TEMP="$work/missing-temp" TMP="$work/missing-temp" \ + "$port" build "$no_temp" >"$no_temp/build.log" 2>&1; then + cat "$no_temp/build.log" >&2 + echo "a build failed without a temporary directory" >&2 + exit 1 +fi +test -f "$no_temp/src/A.js" + +if ! $windows_posix_shell; then + # A failing PPX's error is reported with its usual indentation, whatever the + # PPX wrote to stderr. + ppx_stderr="$work/ppx-stderr" + mkdir -p "$ppx_stderr/src" + printf '#!/bin/sh\necho "bad ppx: something went wrong" >&2\nexit 1\n' \ + >"$ppx_stderr/bad-ppx.sh" + chmod +x "$ppx_stderr/bad-ppx.sh" + printf '{"name":"ppx-stderr","sources":"src","ppx-flags":["%s/bad-ppx.sh"]}\n' \ + "$ppx_stderr" >"$ppx_stderr/rescript.json" + printf 'let value = 1\n' >"$ppx_stderr/src/A.res" + if "$port" build "$ppx_stderr" >"$ppx_stderr/build.log" 2>&1 || \ + ! grep '^ Error while running external preprocessor' \ + "$ppx_stderr/build.log" >/dev/null; then + cat "$ppx_stderr/build.log" >&2 + echo "a PPX's stderr shifted the following error" >&2 + exit 1 + fi + + # A relative temporary directory names one below the build's working + # directory; PPX files there are found and removed. + relative_temp="$work/relative-temp" + mkdir -p "$relative_temp/src" "$relative_temp/tmp" + printf '#!/bin/sh\ncp "$1" "$2"\n' >"$relative_temp/copy-ppx.sh" + chmod +x "$relative_temp/copy-ppx.sh" + printf '{"name":"relative-temp","sources":"src","ppx-flags":["%s/copy-ppx.sh"]}\n' \ + "$relative_temp" >"$relative_temp/rescript.json" + printf 'let value = 1\n' >"$relative_temp/src/A.res" + if ! (cd "$relative_temp" && TMPDIR=tmp "$port" build . >build.log 2>&1); then + cat "$relative_temp/build.log" >&2 + echo "a PPX failed with a relative temporary directory" >&2 + exit 1 + fi + test -f "$relative_temp/src/A.js" + if [ -n "$(ls "$relative_temp/tmp")" ] || ls "$relative_temp" | grep -q '^ppx'; then + ls "$relative_temp" "$relative_temp/tmp" >&2 + echo "a relative temporary directory kept PPX files" >&2 + exit 1 + fi + + # Standalone bsc -verbose prints each command before running it, so the + # command precedes the PPX's own output. + verbose_ppx="$work/verbose-ppx" + mkdir -p "$verbose_ppx" + printf '#!/bin/sh\necho PPX-RAN >&2\ncp "$1" "$2"\n' >"$verbose_ppx/ppx.sh" + chmod +x "$verbose_ppx/ppx.sh" + printf 'let value = 1\n' >"$verbose_ppx/A.res" + (cd "$verbose_ppx" && "$port_directory/bsc.exe" -verbose -ppx "$verbose_ppx/ppx.sh" \ + -bs-ast -o A A.res >out.log 2>err.log) + if [ "$(grep -n '^+ \|PPX-RAN' "$verbose_ppx/err.log" | head -1 | cut -d: -f2 | cut -c1-2)" != "+ " ]; then + cat "$verbose_ppx/err.log" >&2 + echo "bsc -verbose printed a PPX command after the PPX's output" >&2 + exit 1 + fi +fi + "$port" build "$out_of_source" test -f "$out_of_source/lib/es6/src/Main.js" rm -f "$out_of_source/src/Main.res" "$port" build "$out_of_source" test ! -f "$out_of_source/lib/es6/src/Main.js" -namespace_call_log="$namespace/bsc-calls.log" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=counting \ - REWATCH_BSC_CALL_LOG="$(native_path "$namespace_call_log")" \ -"$port" build "$namespace" +namespace_call_log="$namespace/compiler-calls.log" +REWATCH_COMPILER_CALL_LOG="$(native_path "$namespace_call_log")" \ + "$port" build "$namespace" test -f "$namespace/lib/ocaml/A-Widget.cmi" test -f "$namespace/src/B.js" : > "$namespace_call_log" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=counting \ - REWATCH_BSC_CALL_LOG="$(native_path "$namespace_call_log")" \ +REWATCH_COMPILER_CALL_LOG="$(native_path "$namespace_call_log")" \ "$port" build "$namespace" if grep -F 'Widget.mlmap' "$namespace_call_log" >/dev/null; then echo "unchanged build unexpectedly recompiled its namespace" >&2 exit 1 fi printf '\nlet changed = 1\n' >> "$namespace/src/B.res" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=counting \ - REWATCH_BSC_CALL_LOG="$(native_path "$namespace_call_log")" \ +REWATCH_COMPILER_CALL_LOG="$(native_path "$namespace_call_log")" \ "$port" build "$namespace" grep -F 'Widget.mlmap' "$namespace_call_log" >/dev/null diff --git a/rewatch-ocaml/toolchain.ml b/rewatch-ocaml/toolchain.ml index 750e9fe2026..d8fc373d71b 100644 --- a/rewatch-ocaml/toolchain.ml +++ b/rewatch-ocaml/toolchain.ml @@ -17,28 +17,60 @@ let absolute_program ~cwd program = if Filename.is_relative resolved then Filename.concat cwd resolved else resolved -let sibling_bsc_candidate ~cwd ~executable = +(* The npm package (@rescript/) with the binaries for the platform + [system] and [architecture] name, as in cli/common/platform.cjs. Windows on + ARM runs the x64 binaries, which are built for amd64. *) +let platform_package ~system ~architecture = + let os = + match system with + | "linux" -> Some "linux" + | "macosx" -> Some "darwin" + | "mingw" | "mingw64" | "win32" | "win64" | "cygwin" -> Some "win32" + | _ -> None + in + let arch = + match architecture with + | "amd64" -> Some "x64" + | "arm64" -> Some "arm64" + | _ -> None + in + match (os, arch) with + | Some os, Some arch -> Some ("@rescript/" ^ os ^ "-" ^ arch) + | _ -> None + +(* Builds use the embedded compiler. The bsc.exe shipped next to the + executable is still recorded in compiler-info.json, where editor tooling + looks for bsc.exe and the other platform binaries. A development build has + no bsc.exe next to it, so it records the one in the platform package + installed with rescript instead, if there is one. *) +let bundled_bsc ~cwd ~executable ~root ~find_package = let executable = absolute_program ~cwd executable in let executable = canonical_existing ~message:(fun path -> "Could not locate current executable " ^ path) executable in - Filename.concat (Filename.dirname executable) "bsc.exe" - -let bsc () = - let candidate, message = - match Sys.getenv_opt "RESCRIPT_BSC_EXE" with - | Some path -> - (path, fun missing -> "RESCRIPT_BSC_EXE points to missing path " ^ missing) + let sibling = Filename.concat (Filename.dirname executable) "bsc.exe" in + let package_bsc directory = + let bsc = Filename.concat (Filename.concat directory "bin") "bsc.exe" in + if File_util.exists bsc then Some bsc else None + in + let platform_bsc name = + match find_package root name with + | Some directory -> package_bsc directory | None -> - ( sibling_bsc_candidate ~cwd:(Sys.getcwd ()) - ~executable:Sys.executable_name, - fun missing -> - "Could not locate bsc next to the ReScript executable at " ^ missing - ^ "; set RESCRIPT_BSC_EXE to override it" ) + (* With pnpm, the platform package is only visible from rescript. *) + Option.bind (find_package root "rescript") (fun rescript -> + Option.bind (find_package rescript name) package_bsc) in - canonical_existing ~message candidate + if File_util.exists sibling then sibling + else + match + platform_package ~system:Build_platform.system + ~architecture:Build_platform.architecture + with + | None -> sibling + | Some name -> Option.value (platform_bsc name) ~default:sibling let runtime ~find_package = match Sys.getenv_opt "RESCRIPT_RUNTIME" with diff --git a/rewatch-ocaml/toolchain.mli b/rewatch-ocaml/toolchain.mli index 3fc8a661719..85adfa43b12 100644 --- a/rewatch-ocaml/toolchain.mli +++ b/rewatch-ocaml/toolchain.mli @@ -1,5 +1,13 @@ exception Error of string -val sibling_bsc_candidate : cwd:string -> executable:string -> string -val bsc : unit -> string +val platform_package : system:string -> architecture:string -> string option + +val bundled_bsc : + cwd:string -> + executable:string -> + root:string -> + find_package:(string -> string -> string option) -> + string +(** [find_package directory name] resolves package [name] from [directory]. *) + val runtime : find_package:(string -> string option) -> string diff --git a/tests/rewatch_ounit_tests/build_artifacts_tests.ml b/tests/rewatch_ounit_tests/build_artifacts_tests.ml index a20d37165f1..48ab9990066 100644 --- a/tests/rewatch_ounit_tests/build_artifacts_tests.ml +++ b/tests/rewatch_ounit_tests/build_artifacts_tests.ml @@ -133,8 +133,8 @@ let tests = write_file config_path {|{"name":"moved-source","sources":{"dir":"src","subdirs":true}}|}; write_file new_source "let value = 1"; - write_file published_ast - ("Caml1999X\nDependency\n" ^ old_source ^ "\nbinary payload"); + Test_support.write_ast_header published_ast ~dependencies:["Dependency"] + ~source:old_source; write_file working_ast "old working AST"; let config = Config.load_root root in let module_ : Source.module_ = diff --git a/tests/rewatch_ounit_tests/build_attempt_tests.ml b/tests/rewatch_ounit_tests/build_attempt_tests.ml index ca21e60c291..1d739752026 100644 --- a/tests/rewatch_ounit_tests/build_attempt_tests.ml +++ b/tests/rewatch_ounit_tests/build_attempt_tests.ml @@ -53,7 +53,7 @@ let pending_work_is_drained_once _context = Process.{program = "unused"; args = []; cwd = Sys.getcwd ()} in Build_attempt.add_namespace_job attempt - Build_attempt.{job = process_job; finish = ignore}; + Build_attempt.{task = Process.task process_job; finish = ignore}; let build_state = Build_state.create 1 in Build_state.add build_state ~key:"A" ~kind:Build_state.Source_module ~last_compiled_cmi:None ~last_compiled_cmt:None; diff --git a/tests/rewatch_ounit_tests/compile_assets_tests.ml b/tests/rewatch_ounit_tests/compile_assets_tests.ml index cb2c1e3f9b9..12bc260c620 100644 --- a/tests/rewatch_ounit_tests/compile_assets_tests.ml +++ b/tests/rewatch_ounit_tests/compile_assets_tests.ml @@ -8,6 +8,18 @@ let write path contents = ~finally:(fun () -> close_out_noerr channel) (fun () -> output_string channel contents) +let write_ast path ~dependencies ~source = + let channel = open_out_bin path in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> + let dependency_block = "\n" ^ String.concat "\n" dependencies ^ "\n" in + output_binary_int channel (String.length dependency_block); + output_string channel dependency_block; + output_string channel source; + output_char channel '\n'; + output_value channel "Belt_HashSet\nBelt\n") + let with_temp_dir = Test_support.with_temp_dir "rewatch-compile-assets-" let tests = @@ -24,19 +36,51 @@ let tests = write second "cmt"; write unrelated "notes"; write cleanup_only "cmj"; - write ast ("Caml1999X\nDependency\n" ^ source ^ "\nbinary payload"); + write_ast ast ~dependencies:["Dependency"] ~source; + let relative_ast = Filename.concat root "Relative.iast" in + write_ast relative_ast ~dependencies:["Belt_Id"] + ~source:"../../src/Relative.resi"; + let relative_header = Ast_header.read relative_ast in + check + (relative_header.dependencies = ["Belt_Id"] + && relative_header.source = Some "../../src/Relative.resi") + "relative source paths terminate the dependency header before the AST"; + (* A damaged header that claims a huge dependency block is rejected + without allocating it. *) + let damaged = Filename.concat root "Damaged.ast" in + write damaged "\x3f\xff\xff\xffshort"; + let allocated = Gc.allocated_bytes () in + let damaged_header = Ast_header.read damaged in + check + (damaged_header.dependencies = [] && damaged_header.source = None) + "a damaged dependency length reads as an empty header"; + check + (Gc.allocated_bytes () -. allocated < 1_000_000.) + "a damaged dependency length is not allocated"; + Sys.remove damaged; Unix.mkdir nested 0o755; write (Filename.concat nested "Nested.cmi") "nested"; let state = Compile_assets.create [root; root] in check (Compile_assets.files state root |> List.sort String.compare - = List.sort String.compare [ast; cleanup_only; first; second]) + = List.sort String.compare + [ast; relative_ast; cleanup_only; first; second]) "the flat cleanup inventory retains only managed compiler assets"; check - (Compile_assets.ast_sources state root - = [{Compile_assets.ast_path = ast; source_path = source}]) - "published ASTs retain their encoded absolute source location"; + (List.sort + (fun first second -> + String.compare first.Compile_assets.ast_path + second.Compile_assets.ast_path) + (Compile_assets.ast_sources state root) + = [ + {Compile_assets.ast_path = ast; source_path = source}; + { + Compile_assets.ast_path = relative_ast; + source_path = "../../src/Relative.resi"; + }; + ]) + "published ASTs retain absolute and relative source locations"; check (Compile_assets.ast state source |> Option.map (fun entry -> entry.Compile_assets.path) diff --git a/tests/rewatch_ounit_tests/compiler_info_tests.ml b/tests/rewatch_ounit_tests/compiler_info_tests.ml index 6c27df9aa15..ad60f987a05 100644 --- a/tests/rewatch_ounit_tests/compiler_info_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_info_tests.ml @@ -18,8 +18,9 @@ let context ?(inherited_compiler_args = []) root config source_map_args = let runtime = Filename.concat root "runtime" in if not (Sys.file_exists bsc) then write bsc "compiler-v1"; File_util.ensure_dir runtime; - Compiler_info.make_context ~bsc_path:bsc ~runtime_path:runtime - ~source_map_args ~inherited_compiler_args + Compiler_info.make_context ~compiler_path:bsc + ~compiler_identity:(Digest.file bsc |> Digest.to_hex) + ~runtime_path:runtime ~source_map_args ~inherited_compiler_args ~package_output_specs:(Compiler_info.package_output_specs config) let tests = @@ -123,15 +124,17 @@ let tests = ] in let initial = - Compiler_info.make_context ~bsc_path:bsc ~runtime_path:runtime - ~source_map_args:[] ~inherited_compiler_args:[] + Compiler_info.make_context ~compiler_path:bsc + ~compiler_identity:(Digest.file bsc |> Digest.to_hex) + ~runtime_path:runtime ~source_map_args:[] ~inherited_compiler_args:[] ~package_output_specs:commonjs in Compiler_info.write_package initial dependency; let marker = File_util.path_of_parts root ["lib"; "ocaml"; "marker"] in write marker "keep"; let changed = - Compiler_info.make_context ~bsc_path:bsc ~runtime_path:runtime + Compiler_info.make_context ~compiler_path:bsc + ~compiler_identity:"changed-compiler" ~runtime_path:runtime ~source_map_args:[] ~inherited_compiler_args:[] ~package_output_specs:esmodule in diff --git a/tests/rewatch_ounit_tests/compiler_process_tests.ml b/tests/rewatch_ounit_tests/compiler_process_tests.ml index 5715a7f8dd6..1028036cf34 100644 --- a/tests/rewatch_ounit_tests/compiler_process_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_process_tests.ml @@ -2,8 +2,7 @@ open OUnit2 let check condition message = assert_bool message condition -let tests = - "compiler_process_tests" >:: fun _context -> +let publication_tests _context = Test_support.with_temp_dir "rewatch-compiler-process-" (fun root -> let build_dir = Filename.concat root "build" in let ocaml_dir = Filename.concat root "ocaml" in @@ -17,9 +16,8 @@ let tests = ["cmi"; "cmj"; "cmt"]; File_util.ensure_dir (Filename.concat ocaml_dir "Ns.cmj"); let namespace_task = - Compiler_process.namespace_task ~bsc:"unused" ~runtime:"unused" - ~build_dir ~ocaml_dir ~entry:None ~package_dirty:true ~force:false - "Ns" [] + Compiler_process.namespace_task ~runtime:"unused" ~build_dir ~ocaml_dir + ~entry:None ~package_dirty:true ~force:false "Ns" [] |> Option.get in let result = @@ -53,16 +51,209 @@ let tests = ["cmi"; "cmj"; "cmt"; "mlmap"]; check (Option.is_some - (Compiler_process.namespace_task ~bsc:"unused" ~runtime:"unused" - ~build_dir ~ocaml_dir ~entry:None ~package_dirty:false - ~force:false "Ns" [])) + (Compiler_process.namespace_task ~runtime:"unused" ~build_dir + ~ocaml_dir ~entry:None ~package_dirty:false ~force:false "Ns" [])) "a published namespace map that differs from membership is rebuilt"; Test_support.write_file (Filename.concat ocaml_dir "Ns.mlmap") "randjbuildsystem\n"; check (Option.is_some - (Compiler_process.namespace_task ~bsc:"unused" ~runtime:"unused" - ~build_dir ~ocaml_dir ~entry:None ~package_dirty:false ~force:true - "Ns" [])) + (Compiler_process.namespace_task ~runtime:"unused" ~build_dir + ~ocaml_dir ~entry:None ~package_dirty:false ~force:true "Ns" [])) "retained namespace publication dirtiness forces a retry") + +let restore_environment name previous = + match previous with + | Some value -> Unix.putenv name value + | None -> Test_support.unsetenv name + +(* A request for DomainPpx.res whose PPX writes its PID to [marker] and then + waits. *) +let waiting_ppx_request root marker = + Test_support.write_file + (Filename.concat root "DomainPpx.res") + "let value = 1\n"; + let ppx_command = + Filename.quote (Unix.realpath Sys.executable_name) + ^ " --ppx-wait " ^ Filename.quote marker + in + Compiler_process. + { + cwd = root; + args = + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + root; + "-bs-package-name"; + "domain-ppx"; + "-bs-package-output"; + "commonjs:.:.js"; + "-ppx"; + ppx_command; + "DomainPpx.res"; + ]; + } + +let check_ppx_gone marker = + if not Sys.win32 then + let pid = File_util.read_file marker |> int_of_string in + check + (try + Unix.kill pid 0; + false + with Unix.Unix_error (Unix.ESRCH, _, _) -> true) + "the domain PPX process is gone when the request returns" + +let domain_ppx_cancellation_test _context = + Test_support.with_temp_dir "rewatch-domain-ppx-cancellation-" (fun root -> + let marker = Filename.concat root "ppx-started" in + let job = waiting_ppx_request root marker in + let started = Unix.gettimeofday () in + let interrupted = + try + ignore + (Process.run_tasks ~max_jobs:1 + ~poll:(fun () -> + if Sys.file_exists marker then raise (Process.Interrupted 15)) + [Compiler_process.task job]); + false + with Process.Interrupted 15 -> true + in + check interrupted "domain task cancellation is reported"; + (* The PPX waits 30 s: returning sooner shows that cancellation reached + it instead of waiting for it to finish. *) + check + (Unix.gettimeofday () -. started < 10.) + "domain task cancellation reaches a running PPX"; + check (Sys.file_exists marker) "the domain PPX started"; + check_ppx_gone marker) + +(* An exception that escapes the compiler fails only its own request: the + module fails with exit status 2 and the exception in its output. *) +let escaped_exception_test _context = + Test_support.with_temp_dir "rewatch-escaped-exception-" (fun root -> + let marker = Filename.concat root "ppx-started" in + let raised = ref false in + let poll () = + if Sys.file_exists marker && not !raised then ( + raised := true; + failwith "request failed") + in + let result = + Compiler_process.run ~poll (waiting_ppx_request root marker) + in + check !raised "the exception was raised while the PPX ran"; + assert_equal (Unix.WEXITED 2) result.status; + check + (String.ends_with ~suffix:"Failure(\"request failed\")\n" result.stderr) + ("the request reports the exception: " ^ result.stderr); + check_ppx_gone marker) + +let domain_execution_test _context = + Test_support.with_temp_dir "rewatch-domain-execution-" (fun root -> + let previous_count = Sys.getenv_opt "REWATCH_COMPILER_DOMAINS" in + Fun.protect + ~finally:(fun () -> + restore_environment "REWATCH_COMPILER_DOMAINS" previous_count) + (fun () -> + List.iter + (fun (cpus, workers) -> + assert_equal workers + (Compiler_execution_mode.recommended_domain_count cpus)) + [(1, 1); (2, 1); (4, 3); (8, 7); (10, 8); (16, 8)]; + Test_support.unsetenv "REWATCH_COMPILER_DOMAINS"; + assert_equal + (Compiler_execution_mode.recommended_domain_count + (Domain.recommended_domain_count ())) + (Compiler_execution_mode.configured_count ()); + let count = + if Sys.getenv_opt "REWATCH_TEST_DOMAIN_CONCURRENCY" = Some "1" then + 2 + else 1 + in + Unix.putenv "REWATCH_COMPILER_DOMAINS" (string_of_int count); + assert_equal count (Compiler_execution_mode.configured_count ()); + List.iter + (fun name -> + Test_support.write_file + (Filename.concat root (name ^ ".res")) + "let value = 1\n") + ["First"; "Second"]; + let jobs = + List.map + (fun name -> + Compiler_process. + { + cwd = root; + args = ["-bs-ast"; "-o"; name ^ ".ast"; name ^ ".res"]; + }) + ["First"; "Second"] + in + let results = Compiler_process.run_requests jobs in + List.iter + (fun result -> check (Process.succeeded result) result.stderr) + results; + List.iter + (fun name -> + check + (Sys.file_exists (Filename.concat root (name ^ ".ast"))) + "domain mode retains parser artifacts") + ["First"; "Second"]; + let marker = Filename.concat root "ppx-started" in + let ppx_command = + Filename.quote (Unix.realpath Sys.executable_name) + ^ " --ppx-copy " ^ Filename.quote marker + in + let ppx_result = + Compiler_process.run + Compiler_process. + { + cwd = root; + args = + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + root; + "-bs-package-name"; + "domain-ppx"; + "-bs-package-output"; + "commonjs:.:.js"; + "-ppx"; + ppx_command; + "First.res"; + ]; + } + in + check (Process.succeeded ppx_result) ppx_result.stderr; + check (Sys.file_exists marker) "a domain request launches its PPX"; + check + (Sys.file_exists (Filename.concat root "First.js")) + "the PPX transformed request still writes JavaScript"; + List.iter + (fun value -> + Unix.putenv "REWATCH_COMPILER_DOMAINS" value; + check + (try + ignore (Compiler_execution_mode.configured_count ()); + false + with Process.Error _ -> true) + ("domain count " ^ value ^ " is reported as invalid")) + ["0"; "-1"; "abc"]; + Unix.putenv "REWATCH_COMPILER_DOMAINS" + (string_of_int (Compiler_execution_mode.max_domain_count + 1)); + assert_equal Compiler_execution_mode.max_domain_count + (Compiler_execution_mode.configured_count ()) + ~msg:"domain counts are capped at the scheduler bound")) + +let tests = + "compiler_process_tests" + >::: [ + "publication" >:: publication_tests; + "domain_ppx_cancellation" >:: domain_ppx_cancellation_test; + "escaped_exception" >:: escaped_exception_test; + "domain_execution" >:: domain_execution_test; + ] diff --git a/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml b/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml index 4c85e18c179..5c6adb73cfc 100644 --- a/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml @@ -15,6 +15,17 @@ let wait_for_release_job root = let with_temp_dir = Test_support.with_temp_dir "rewatch-scheduler-" +let with_single_domain action = + let previous = Sys.getenv_opt "REWATCH_COMPILER_DOMAINS" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_COMPILER_DOMAINS" value + | None -> Test_support.unsetenv "REWATCH_COMPILER_DOMAINS") + (fun () -> + Unix.putenv "REWATCH_COMPILER_DOMAINS" "1"; + action ()) + let source name = Source. { @@ -26,276 +37,210 @@ let source name = let tests = "compiler_scheduler_tests" >:: fun _context -> - with_temp_dir (fun root -> - let ocaml_dir = Build_artifacts.lib_path root "ocaml" in - File_util.ensure_dir ocaml_dir; - File_util.ensure_dir (Build_artifacts.lib_path root "bs"); - Compiler_log.initialize root; - let a_source = source "A" in - let b_source = source "B" in - let c_source = source "C" in - let build_state = Build_state.create 3 in - List.iter - (fun key -> - Build_state.add build_state ~key ~kind:Build_state.Source_module - ~last_compiled_cmi:(Some 0.) ~last_compiled_cmt:(Some 0.)) - ["A"; "B"; "C"]; - Build_state.set_dependencies build_state ~key:"B" ["A"]; - let a_state = Build_state.find_exn build_state "A" in - let b_state = Build_state.find_exn build_state "B" in - let c_state = Build_state.find_exn build_state "C" in - a_state.compile_dirty <- true; - let a_cmi = Filename.concat ocaml_dir "A.cmi" in - let b_cmi = Filename.concat ocaml_dir "B.cmi" in - let c_cmi = Filename.concat ocaml_dir "C.cmi" in - let a_ast = Filename.concat ocaml_dir "A.ast" in - write_file a_cmi "old interface"; - write_file b_cmi "dependent interface"; - write_file a_ast "published AST"; - let compile_assets = Compile_assets.create [ocaml_dir] in - let fail_a_publication = ref true in - let b_compilations = ref 0 in - let c_candidates_built = ref 0 in - let scheduler_thread = Thread.id (Thread.self ()) in - let output_inventory = Hashtbl.create 1 in - let make_scheduled key source state cmi_path = - Compiler_scheduler.create ~key - ~dependencies:state.Build_state.dependencies ~source ~state ~cmi_path - ~prepare:(fun () -> ()) - ~compile:(fun ~source_kind:_ _path -> - if key = "B" then incr b_compilations; - process_job ()) - ~publish:(fun ~source_kind:_ _path _result -> - write_file cmi_path - (if key = "A" then "new interface" else "dependent interface"); - if key = "A" && !fail_a_publication then ( - fail_a_publication := false; - raise (Failure "later publication failed")); - Compiler_scheduler. - { - stderr = ""; - cmi_change = (if key = "A" then Cmi_changed else Cmi_unchanged); - }) - ~record_published_outputs:(fun ~source_kind:_ _path -> - check - (Thread.id (Thread.self ()) = scheduler_thread) - "the scheduler thread owns the shared output inventory"; - for index = 0 to 127 do - Hashtbl.replace output_inventory - (Printf.sprintf "%s-%d" key index) - () - done) - ~post_build:(fun _ -> []) - ~package_root:root ~is_local:true - ~mark_warning:(fun _ -> ()) - in - let run () = - let candidates = - [ - ("A", a_source, a_state, a_cmi, fun () -> ()); - ("B", b_source, b_state, b_cmi, fun () -> ()); - ("C", c_source, c_state, c_cmi, fun () -> incr c_candidates_built); - ] - |> List.map (fun (key, source, state, cmi_path, on_make) -> - Compiler_scheduler.candidate ~key ~state ~warning_paths:[] - ~make:(fun () -> - on_make (); - make_scheduled key source state cmi_path)) - in - Compiler_scheduler.run ~poll:None - ~warning_state:(Warning_state.create ()) ~compile_assets ~build_state - ~candidates - ~mark_compiled:(fun () -> ()) - ~mark_had_warnings:(fun () -> ()) - ~progress:(Output.Progress.create ~enabled:false ~color:false) - ~compile_step:"1/1" ~namespace_count:0 ~verbosity:0 - in - let first_failed = - try - run (); - false - with Compiler_scheduler.Build_failure message -> - Test_support.contains_text message "later publication failed" - in - check first_failed "a later publication failure is reported normally"; - check - (not (Sys.file_exists a_ast)) - "failed completion invalidates durable freshness for a later process"; - check b_state.compile_dirty - "a published CMI change survives a later publication failure"; - check (!b_compilations = 0) - "a dependent is not compiled during its dependency's failed attempt"; - run (); - check - (!b_compilations = 1 && not b_state.compile_dirty) - "the retained dependent recompiles after publication recovers"; - check - (Hashtbl.length output_inventory = 256) - "scheduler-owned publication inventory updates survive table growth"; - check (!c_candidates_built = 0) - "an unaffected module does not construct compiler callbacks"; - let abort_state = Build_state.create 4 in - List.iter - (fun key -> - Build_state.add abort_state ~key ~kind:Build_state.Source_module - ~last_compiled_cmi:(Some 0.) ~last_compiled_cmt:(Some 0.)) - ["AbortA"; "AbortB"; "AbortC"; "AbortD"]; - Build_state.set_dependencies abort_state ~key:"AbortB" ["AbortC"]; - Build_state.set_dependencies abort_state ~key:"AbortD" ["AbortA"]; - let abort_a = Build_state.find_exn abort_state "AbortA" in - let abort_c = Build_state.find_exn abort_state "AbortC" in - abort_a.compile_dirty <- true; - abort_c.compile_dirty <- true; - let abort_a_ast = Filename.concat ocaml_dir "AbortA.ast" in - write_file abort_a_ast "published AST"; - let published_marker = Filename.concat root "abort-a-published" in - let release_marker = Filename.concat root "abort-a-release" in - let rec wait_for path remaining = - if Sys.file_exists path then () - else if remaining = 0 then failwith ("timed out waiting for " ^ path) - else ( - Thread.delay 0.001; - wait_for path (remaining - 1)) - in - let abort_candidate key dependencies prepare publish = - let state = Build_state.find_exn abort_state key in - Compiler_scheduler.candidate ~key ~state ~warning_paths:[] - ~make:(fun () -> - Compiler_scheduler.create ~key ~dependencies ~source:(source key) - ~state - ~cmi_path:(Filename.concat ocaml_dir (key ^ ".cmi")) - ~prepare - ~compile:(fun ~source_kind:_ _path -> process_job ()) - ~publish - ~record_published_outputs:(fun ~source_kind:_ _path -> ()) - ~post_build:(fun output -> - if key = "AbortA" then - [ - Compiler_scheduler. - {output; task = Process.task (process_job ())}; - ] - else []) - ~package_root:root ~is_local:true - ~mark_warning:(fun _ -> ())) - in - let abort_candidates = - [ - abort_candidate "AbortA" [] - (fun () -> ()) - (fun ~source_kind:_ _path _result -> - write_file (Filename.concat ocaml_dir "AbortA.cmi") "new A"; - write_file published_marker ""; - wait_for release_marker 5000; - Compiler_scheduler.{stderr = ""; cmi_change = Cmi_changed}); - abort_candidate "AbortC" [] - (fun () -> ()) - (fun ~source_kind:_ _path _result -> - wait_for published_marker 5000; - write_file (Filename.concat ocaml_dir "AbortC.cmi") "new C"; - Compiler_scheduler.{stderr = ""; cmi_change = Cmi_changed}); - abort_candidate "AbortB" ["AbortC"] - (fun () -> - write_file release_marker ""; - raise Exit) - (fun ~source_kind:_ _path _result -> assert false); - abort_candidate "AbortD" ["AbortA"] - (fun () -> ()) - (fun ~source_kind:_ _path _result -> assert false); - ] - in - let aborted = - try - Compiler_scheduler.run ~poll:None - ~warning_state:(Warning_state.create ()) - ~compile_assets:(Compile_assets.create [ocaml_dir]) - ~build_state:abort_state ~candidates:abort_candidates - ~mark_compiled:(fun () -> ()) - ~mark_had_warnings:(fun () -> ()) - ~progress:(Output.Progress.create ~enabled:false ~color:false) - ~compile_step:"1/1" ~namespace_count:0 ~verbosity:0; - false - with Exit -> true - in - check aborted "an operational scheduler failure aborts the attempt"; - check (Build_state.find_exn abort_state "AbortD").compile_dirty - "CMI publication completed during abort still invalidates dependents"; - check - (not (Sys.file_exists abort_a_ast)) - "abort before post-build scheduling invalidates persistent freshness"; - let interrupted_state = Build_state.create 1 in - Build_state.add interrupted_state ~key:"Interrupted" - ~kind:Build_state.Source_module ~last_compiled_cmi:(Some 0.) - ~last_compiled_cmt:(Some 0.); - let interrupted_module = - Build_state.find_exn interrupted_state "Interrupted" - in - interrupted_module.compile_dirty <- true; - let interrupted_ast = Filename.concat ocaml_dir "Interrupted.ast" in - let interrupted_cmi = Filename.concat ocaml_dir "Interrupted.cmi" in - let interrupted_hook_root = Filename.concat root "interrupted-hook" in - Unix.mkdir interrupted_hook_root 0o755; - write_file interrupted_ast "published AST"; - let interrupted_candidate = - Compiler_scheduler.candidate ~key:"Interrupted" - ~state:interrupted_module ~warning_paths:[] ~make:(fun () -> - Compiler_scheduler.create ~key:"Interrupted" ~dependencies:[] - ~source:(source "Interrupted") ~state:interrupted_module - ~cmi_path:interrupted_cmi + with_single_domain (fun () -> + with_temp_dir (fun root -> + let ocaml_dir = Build_artifacts.lib_path root "ocaml" in + File_util.ensure_dir ocaml_dir; + File_util.ensure_dir (Build_artifacts.lib_path root "bs"); + Compiler_log.initialize root; + let a_source = source "A" in + let b_source = source "B" in + let c_source = source "C" in + let build_state = Build_state.create 3 in + List.iter + (fun key -> + Build_state.add build_state ~key ~kind:Build_state.Source_module + ~last_compiled_cmi:(Some 0.) ~last_compiled_cmt:(Some 0.)) + ["A"; "B"; "C"]; + Build_state.set_dependencies build_state ~key:"B" ["A"]; + let a_state = Build_state.find_exn build_state "A" in + let b_state = Build_state.find_exn build_state "B" in + let c_state = Build_state.find_exn build_state "C" in + a_state.compile_dirty <- true; + c_state.compile_dirty <- true; + let a_cmi = Filename.concat ocaml_dir "A.cmi" in + let b_cmi = Filename.concat ocaml_dir "B.cmi" in + let c_cmi = Filename.concat ocaml_dir "C.cmi" in + let a_ast = Filename.concat ocaml_dir "A.ast" in + write_file a_cmi "old interface"; + write_file b_cmi "dependent interface"; + Test_support.write_ast_header a_ast ~dependencies:[] + ~source:"src/A.res"; + let compile_assets = Compile_assets.create [ocaml_dir] in + let fail_a_publication = ref true in + let b_compilations = ref 0 in + let c_compilations = ref 0 in + let c_candidates_built = ref 0 in + let scheduler_thread = Thread.id (Thread.self ()) in + let output_inventory = Hashtbl.create 1 in + let make_scheduled key source state cmi_path = + Compiler_scheduler.create ~key + ~dependencies:state.Build_state.dependencies ~source ~state + ~cmi_path ~prepare:(fun () -> ()) - ~compile:(fun ~source_kind:_ _path -> process_job ()) + ~compile:(fun ~source_kind:_ _path -> + if key = "B" then incr b_compilations; + if key = "C" then ( + check (not !fail_a_publication) + "independent work starts after A's publication failure"; + incr c_compilations); + Process.task (process_job ())) ~publish:(fun ~source_kind:_ _path _result -> - write_file interrupted_cmi "published CMI"; - Compiler_scheduler.{stderr = ""; cmi_change = Cmi_changed}) - ~record_published_outputs:(fun ~source_kind:_ _path -> ()) - ~post_build:(fun output -> - [ - Compiler_scheduler. - { - output; - task = - Process.task - (wait_for_release_job interrupted_hook_root); - }; - ]) + write_file cmi_path + (if key = "A" then "new interface" else "dependent interface"); + if key = "A" && !fail_a_publication then ( + fail_a_publication := false; + raise (Failure "later publication failed")); + Compiler_scheduler. + { + stderr = ""; + cmi_change = + (if key = "A" then Cmi_changed else Cmi_unchanged); + }) + ~record_published_outputs:(fun ~source_kind:_ _path -> + check + (Thread.id (Thread.self ()) = scheduler_thread) + "the scheduler thread owns the shared output inventory"; + for index = 0 to 127 do + Hashtbl.replace output_inventory + (Printf.sprintf "%s-%d" key index) + () + done) + ~post_build:(fun _ -> []) ~package_root:root ~is_local:true - ~mark_warning:(fun _ -> ())) - in - let hook_interrupted = - try - Compiler_scheduler.run - ~poll: - (Some - (fun () -> - if - Sys.file_exists - (Filename.concat interrupted_hook_root "child-started") - then raise Exit)) - ~warning_state:(Warning_state.create ()) - ~compile_assets:(Compile_assets.create [ocaml_dir]) - ~build_state:interrupted_state ~candidates:[interrupted_candidate] - ~mark_compiled:(fun () -> ()) - ~mark_had_warnings:(fun () -> ()) - ~progress:(Output.Progress.create ~enabled:false ~color:false) - ~compile_step:"1/1" ~namespace_count:0 ~verbosity:0; - false - with Exit -> true - in - check hook_interrupted "a running post-build hook can be interrupted"; - check - (not (Sys.file_exists interrupted_ast)) - "interrupted post-build invalidates persistent compiler freshness"; - let marker = Failure "copy after CMI failed" in - match - Compiler_scheduler.capture_publication (fun () -> - raise - (Compiler_scheduler.Publication_failure - (marker, Compiler_scheduler.Cmi_changed))) - with - | Compiler_scheduler.Failed_after_cmi_publication - {error; cmi_change = Compiler_scheduler.Cmi_changed} - when error == marker -> - () - | _ -> - assert_failure - "publication capture must retain a CMI change across later copy \ - failure") + ~mark_warning:(fun _ -> ()) + in + let run () = + let candidates = + [ + ("A", a_source, a_state, a_cmi, fun () -> ()); + ("B", b_source, b_state, b_cmi, fun () -> ()); + ( "C", + c_source, + c_state, + c_cmi, + fun () -> incr c_candidates_built ); + ] + |> List.map (fun (key, source, state, cmi_path, on_make) -> + Compiler_scheduler.candidate ~key ~state ~warning_paths:[] + ~make:(fun () -> + on_make (); + make_scheduled key source state cmi_path)) + in + Compiler_scheduler.run ~poll:None + ~warning_state:(Warning_state.create ()) ~compile_assets + ~build_state ~candidates + ~mark_compiled:(fun () -> ()) + ~mark_had_warnings:(fun () -> ()) + ~progress:(Output.Progress.create ~enabled:false ~color:false) + ~compile_step:"1/1" ~namespace_count:0 ~verbosity:0 + in + let first_failed = + try + run (); + false + with Compiler_scheduler.Build_failure message -> + Test_support.contains_text message "later publication failed" + in + check first_failed "a later publication failure is reported normally"; + check + (not (Sys.file_exists a_ast)) + "failed completion invalidates durable freshness for a later \ + process"; + check b_state.compile_dirty + "a published CMI change survives a later publication failure"; + check (!b_compilations = 0) + "a dependent is not compiled during its dependency's failed attempt"; + check (!c_compilations = 1) + "independent work completes after another module fails"; + run (); + check + (!b_compilations = 1 && not b_state.compile_dirty) + "the retained dependent recompiles after publication recovers"; + check + (Hashtbl.length output_inventory = 384) + "scheduler-owned publication inventory updates survive table growth"; + check + (!c_candidates_built = 1 && !c_compilations = 1) + "a completed independent module remains fresh on retry"; + let interrupted_state = Build_state.create 1 in + Build_state.add interrupted_state ~key:"Interrupted" + ~kind:Build_state.Source_module ~last_compiled_cmi:(Some 0.) + ~last_compiled_cmt:(Some 0.); + let interrupted_module = + Build_state.find_exn interrupted_state "Interrupted" + in + interrupted_module.compile_dirty <- true; + let interrupted_ast = Filename.concat ocaml_dir "Interrupted.ast" in + let interrupted_cmi = Filename.concat ocaml_dir "Interrupted.cmi" in + let interrupted_hook_root = Filename.concat root "interrupted-hook" in + Unix.mkdir interrupted_hook_root 0o755; + Test_support.write_ast_header interrupted_ast ~dependencies:[] + ~source:"src/Interrupted.res"; + let interrupted_candidate = + Compiler_scheduler.candidate ~key:"Interrupted" + ~state:interrupted_module ~warning_paths:[] ~make:(fun () -> + Compiler_scheduler.create ~key:"Interrupted" ~dependencies:[] + ~source:(source "Interrupted") ~state:interrupted_module + ~cmi_path:interrupted_cmi + ~prepare:(fun () -> ()) + ~compile:(fun ~source_kind:_ _path -> + Process.task (process_job ())) + ~publish:(fun ~source_kind:_ _path _result -> + write_file interrupted_cmi "published CMI"; + Compiler_scheduler.{stderr = ""; cmi_change = Cmi_changed}) + ~record_published_outputs:(fun ~source_kind:_ _path -> ()) + ~post_build:(fun output -> + [ + Compiler_scheduler. + { + output; + task = + Process.task + (wait_for_release_job interrupted_hook_root); + }; + ]) + ~package_root:root ~is_local:true + ~mark_warning:(fun _ -> ())) + in + let hook_interrupted = + try + Compiler_scheduler.run + ~poll: + (Some + (fun () -> + if + Sys.file_exists + (Filename.concat interrupted_hook_root + "child-started") + then raise Exit)) + ~warning_state:(Warning_state.create ()) + ~compile_assets:(Compile_assets.create [ocaml_dir]) + ~build_state:interrupted_state + ~candidates:[interrupted_candidate] + ~mark_compiled:(fun () -> ()) + ~mark_had_warnings:(fun () -> ()) + ~progress:(Output.Progress.create ~enabled:false ~color:false) + ~compile_step:"1/1" ~namespace_count:0 ~verbosity:0; + false + with Exit -> true + in + check hook_interrupted "a running post-build hook can be interrupted"; + check + (not (Sys.file_exists interrupted_ast)) + "interrupted post-build invalidates persistent compiler freshness"; + let marker = Failure "copy after CMI failed" in + match + Compiler_scheduler.capture_publication (fun () -> + raise + (Compiler_scheduler.Publication_failure + (marker, Compiler_scheduler.Cmi_changed))) + with + | Compiler_scheduler.Failed_after_cmi_publication + {error; cmi_change = Compiler_scheduler.Cmi_changed} + when error == marker -> + () + | _ -> + assert_failure + "publication capture must retain a CMI change across later copy \ + failure")) diff --git a/tests/rewatch_ounit_tests/config_tests.ml b/tests/rewatch_ounit_tests/config_tests.ml index 0e3e88008ca..d17ae3dee90 100644 --- a/tests/rewatch_ounit_tests/config_tests.ml +++ b/tests/rewatch_ounit_tests/config_tests.ml @@ -275,7 +275,7 @@ let compiler_job_tests = File_util.ensure_dir (Filename.dirname source); write_file source "let value = 1\n"; let parse_job = - Compiler_process.parse_job ~bsc:"bsc" ~build_dir ~config "src/A.res" + Compiler_process.parse_request ~build_dir ~config "src/A.res" in let module_ = Source. @@ -287,7 +287,7 @@ let compiler_job_tests = } in let compile_job = - Compiler_process.compile_job ~bsc:"bsc" ~build_dir ~config + Compiler_process.compile_request ~build_dir ~config ~common_args: (Compiler_args.compiler_common_arguments ~config ~runtime:"runtime" ~dependency_dirs:[] ~watch:false ~gentype_dependency_args:[]) @@ -299,7 +299,7 @@ let compiler_job_tests = | [] -> None in check - (parse_job.Process.cwd = compile_job.Process.cwd + (parse_job.Compiler_process.cwd = compile_job.Compiler_process.cwd && parse_job.cwd = build_dir) "parser and compiler jobs derive the same canonical working directory"; check diff --git a/tests/rewatch_ounit_tests/dune b/tests/rewatch_ounit_tests/dune index b169b0e0552..baf8a5e5277 100644 --- a/tests/rewatch_ounit_tests/dune +++ b/tests/rewatch_ounit_tests/dune @@ -45,4 +45,6 @@ (foreign_stubs (language c) (names test_env_stubs)) + (flags + (:standard -open Rewatch_ocaml_lib)) (libraries rewatch_ocaml_lib ounit2)) diff --git a/tests/rewatch_ounit_tests/format_tests.ml b/tests/rewatch_ounit_tests/format_tests.ml index 48a906fbef3..364226a516e 100644 --- a/tests/rewatch_ounit_tests/format_tests.ml +++ b/tests/rewatch_ounit_tests/format_tests.ml @@ -16,6 +16,11 @@ let write_file = Test_support.write_file let with_temp_dir = Test_support.with_temp_dir "rewatch-ocaml-format-" +(* The formatter writes text-mode output, so lines end in CRLF on Windows. *) +let native text = + if Sys.win32 then String.concat "\r\n" (String.split_on_char '\n' text) + else text + let tests = "format_tests" >:: fun _context -> check @@ -44,31 +49,6 @@ let tests = contains message "Could not write formatted file" && contains message path) "formatter write failures retain their operation and source path"); - with_temp_dir (fun root -> - write_file (Filename.concat root "rescript.json") "{"; - let previous_directory = Sys.getcwd () in - let previous_bsc = Sys.getenv_opt "RESCRIPT_BSC_EXE" in - Unix.chdir root; - Unix.putenv "RESCRIPT_BSC_EXE" (Filename.concat root "missing-bsc"); - let message = - Fun.protect - ~finally:(fun () -> - Unix.chdir previous_directory; - match previous_bsc with - | Some value -> Unix.putenv "RESCRIPT_BSC_EXE" value - | None -> Test_support.unsetenv "RESCRIPT_BSC_EXE") - (fun () -> - try - Format.run_files ~verbosity:0 ~check:false []; - None - with Format.Error message -> Some message) - in - check - (match message with - | Some message -> - contains message "RESCRIPT_BSC_EXE points to missing path" - | None -> false) - "format resolves the compiler before discovering implicit project files"); if not Sys.win32 then with_temp_dir (fun root -> let target = Filename.concat root "target.res" in @@ -88,25 +68,32 @@ let tests = && File_util.read_file target = "through hard link") "formatting should preserve hard-link identity"); with_temp_dir (fun root -> - let first = Filename.concat root "First.res" in - let second = Filename.concat root "Second.res" in - write_file first "let first = 1\n"; - write_file second "let second = 2\n"; - let previous_root = Sys.getenv_opt "REWATCH_FORMAT_TEST_ROOT" in - Unix.putenv "REWATCH_FORMAT_TEST_ROOT" root; - Fun.protect - ~finally:(fun () -> - match previous_root with - | Some value -> Unix.putenv "REWATCH_FORMAT_TEST_ROOT" value - | None -> Test_support.unsetenv "REWATCH_FORMAT_TEST_ROOT") - (fun () -> - Format.format_files_with_bsc ~max_jobs:2 - ~bsc:(Unix.realpath Sys.executable_name) - ~check:true [first; second]); + let unformatted = Filename.concat root "Unformatted.res" in + let formatted = Filename.concat root "Formatted.res" in + write_file unformatted "let first=1\n"; + write_file formatted (native "let second = 2\n"); + check + (try + Format.format_files ~check:true [unformatted; formatted]; + false + with Format.Error message -> message = "Formatting check failed") + "format --check reports a file that needs formatting"; check - (Sys.file_exists (first ^ ".started") - && Sys.file_exists (second ^ ".started")) - "formatter subprocesses overlap rather than running serially"); + (File_util.read_file unformatted = "let first=1\n") + "format --check leaves files unchanged"; + Format.format_files ~check:false [unformatted; formatted]; + check + (File_util.read_file unformatted = native "let first = 1\n" + && File_util.read_file formatted = native "let second = 2\n") + "the embedded formatter rewrites only files that need formatting"; + check + (try + write_file unformatted "let =\n"; + Format.format_files ~check:false [unformatted]; + false + with Format.Error message -> + contains message ("Error formatting " ^ unformatted)) + "syntax errors are reported with the source path"); with_temp_dir (fun root -> let root_source = Test_support.path root "src/App.res" in let orphan_interface = Test_support.path root "src/Orphan.resi" in @@ -118,46 +105,31 @@ let tests = write_file (Filename.concat root "rescript.json") {|{"name":"app","sources":[{"dir":"src","subdirs":true}],"dependencies":["installed"]}|}; - write_file root_source "let value = 1\n"; - write_file orphan_interface "let value: int\n"; - write_file duplicate_one "let value = 1\n"; - write_file duplicate_two "let value = 2\n"; + write_file root_source "let value=1\n"; + write_file orphan_interface "let value:int\n"; + write_file duplicate_one "let value=1\n"; + write_file duplicate_two "let value=1\n"; write_file (Test_support.path root "node_modules/installed/rescript.json") {|{"name":"installed","sources":["src"]}|}; - write_file installed_source "let value = 2\n"; + write_file installed_source "let value=1\n"; let previous = Sys.getcwd () in - let previous_bsc = Sys.getenv_opt "RESCRIPT_BSC_EXE" in - let previous_inventory_root = - Sys.getenv_opt "REWATCH_FORMAT_INVENTORY_TEST_ROOT" - in - let marker path = - Filename.concat root (Digest.string path |> Digest.to_hex) - in - Unix.putenv "RESCRIPT_BSC_EXE" (Unix.realpath Sys.executable_name); - Unix.putenv "REWATCH_FORMAT_INVENTORY_TEST_ROOT" root; Fun.protect - ~finally:(fun () -> - Unix.chdir previous; - (match previous_bsc with - | Some value -> Unix.putenv "RESCRIPT_BSC_EXE" value - | None -> Test_support.unsetenv "RESCRIPT_BSC_EXE"); - match previous_inventory_root with - | Some value -> Unix.putenv "REWATCH_FORMAT_INVENTORY_TEST_ROOT" value - | None -> Test_support.unsetenv "REWATCH_FORMAT_INVENTORY_TEST_ROOT") + ~finally:(fun () -> Unix.chdir previous) (fun () -> Unix.chdir root; - Format.run_files ~verbosity:0 ~check:true []); - check - (Sys.file_exists (marker root_source)) + Format.run_files ~verbosity:0 ~check:false []); + let formatted path = + File_util.read_file path = native "let value = 1\n" + in + check (formatted root_source) "implicit format includes the current package"; check - (Sys.file_exists (marker orphan_interface)) + (File_util.read_file orphan_interface = native "let value: int\n") "implicit format includes an orphan interface"; check - (Sys.file_exists (marker duplicate_one) - && Sys.file_exists (marker duplicate_two)) + (formatted duplicate_one && formatted duplicate_two) "implicit format does not impose compilation module uniqueness"; check - (not (Sys.file_exists (marker installed_source))) + (File_util.read_file installed_source = "let value=1\n") "implicit format does not rewrite installed node_modules dependencies") diff --git a/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.ml b/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.ml index 1bf0d8cb878..7d9c17158c0 100644 --- a/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.ml +++ b/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.ml @@ -1,10 +1,12 @@ +(* A bsc stand-in for Rust rewatch in the watch performance gate: it logs each + call's arguments to REWATCH_BSC_CALL_LOG, then runs REWATCH_REAL_BSC. OCaml + rewatch compiles in-process and logs its requests itself. *) + let getenv name = match Sys.getenv_opt name with | Some value -> value | None -> failwith ("Missing environment variable " ^ name) -let touch path = close_out (open_out_bin path) - (* Parallel compiler calls append to one log. Windows emulates append mode by seeking before each write, so concurrent appends can overwrite each other. A one-byte lock on a separate file serializes them on every platform; @@ -22,34 +24,6 @@ let append_line path line = output_char channel '\n'; close_out channel) -let remove_if_present path = try Sys.remove path with Sys_error _ -> () - -let has_argument expected = Array.exists (String.equal expected) Sys.argv - -let output_argument () = - let rec loop index = - if index + 1 >= Array.length Sys.argv then None - else if Sys.argv.(index) = "-o" then Some Sys.argv.(index + 1) - else loop (index + 1) - in - loop 1 - -let basename path = - path - |> String.map (fun character -> if character = '\\' then '/' else character) - |> Filename.basename - -let arguments () = - Array.to_list (Array.sub Sys.argv 1 (Array.length Sys.argv - 1)) - -let wait_for_file path = - let rec wait attempts = - if attempts < 400 && not (Sys.file_exists path) then ( - Unix.sleepf 0.05; - wait (attempts + 1)) - in - wait 0 - let run_compiler () = let program = getenv "REWATCH_REAL_BSC" in let argv = Array.copy Sys.argv in @@ -61,78 +35,8 @@ let run_compiler () = | Unix.WEXITED status -> status | Unix.WSIGNALED signal | Unix.WSTOPPED signal -> 128 + signal -let block_for_scope_transition () = - let request = getenv "REWATCH_SCOPE_BLOCK_REQUEST" in - let started = getenv "REWATCH_SCOPE_BLOCK_STARTED" in - if Sys.file_exists request && not (Sys.file_exists started) then ( - touch started; - let release = getenv "REWATCH_SCOPE_BLOCK_RELEASE" in - let rec wait attempts = - if attempts < 200 && not (Sys.file_exists release) then ( - Unix.sleepf 0.05; - wait (attempts + 1)) - in - wait 0) - -let before_compiler mode is_parse = - if mode = "scope-block" then block_for_scope_transition (); - if mode = "block-compile" && not is_parse then ( - touch (getenv "REWATCH_OCAML_COMPILE_STARTED"); - wait_for_file (getenv "REWATCH_OCAML_RELEASE_FILE")); - if mode = "slow" then ( - touch (getenv "REWATCH_OCAML_CHILD_STARTED"); - match Sys.getenv_opt "REWATCH_OCAML_RELEASE_FILE" with - | Some release -> wait_for_file release - | None -> Unix.sleepf 5.0); - if mode = "counting" || mode = "parse-warning-log" then - append_line - (getenv "REWATCH_BSC_CALL_LOG") - (String.concat " " (arguments ())) - -let after_compiler mode is_parse status = - if status = 0 && mode = "parse-warning" && is_parse then - prerr_endline "PARSE_WARNING_MARKER"; - (if status = 0 && mode = "parse-warning-log" && is_parse then - let source = getenv "REWATCH_PARSE_WARNING_SOURCE" in - if Array.exists (fun argument -> basename argument = source) Sys.argv then - prerr_endline "REWATCH_PARSE_WARNING"); - if - status = 0 - && mode = "fail-late-publication" - && (not is_parse) - && Array.exists (fun argument -> basename argument = "A.ast") Sys.argv - && Sys.file_exists (getenv "REWATCH_FAIL_PUBLICATION") - && not (Sys.file_exists (getenv "REWATCH_PUBLICATION_FAILED")) - then ( - let destination = getenv "REWATCH_PUBLICATION_DESTINATION" in - remove_if_present destination; - Unix.mkdir destination 0o755; - touch (getenv "REWATCH_PUBLICATION_FAILED")) - let () = - let mode = getenv "REWATCH_BSC_PROXY_MODE" in - let is_parse = has_argument "-bs-ast" in - before_compiler mode is_parse; - (if mode = "delete-parse-sources" && is_parse then - let marker = getenv "REWATCH_SOURCES_DELETED" in - if not (Sys.file_exists marker) then ( - remove_if_present (getenv "REWATCH_SOURCE_A"); - remove_if_present (getenv "REWATCH_SOURCE_B"); - touch marker)); - let status = run_compiler () in - after_compiler mode is_parse status; - (if status = 0 then - if mode = "delete-source" && not is_parse then ( - let marker = getenv "REWATCH_SOURCE_DELETED" in - if not (Sys.file_exists marker) then ( - remove_if_present (getenv "REWATCH_SOURCE_TO_DELETE"); - touch marker)) - else if mode = "delete-ast" && is_parse then - match output_argument () with - | None -> () - | Some output -> - let marker = getenv "REWATCH_AST_DELETED" in - if not (Sys.file_exists marker) then ( - remove_if_present output; - touch marker)); - exit status + append_line + (getenv "REWATCH_BSC_CALL_LOG") + (String.concat " " (List.tl (Array.to_list Sys.argv))); + exit (run_compiler ()) diff --git a/tests/rewatch_ounit_tests/test_support.ml b/tests/rewatch_ounit_tests/test_support.ml index 2986c39d06f..3ccaa3202f8 100644 --- a/tests/rewatch_ounit_tests/test_support.ml +++ b/tests/rewatch_ounit_tests/test_support.ml @@ -9,6 +9,18 @@ let write_file path contents = ~finally:(fun () -> close_out_noerr channel) (fun () -> output_string channel contents) +let write_ast_header path ~dependencies ~source = + File_util.ensure_dir (Filename.dirname path); + let channel = open_out_bin path in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> + let dependency_block = "\n" ^ String.concat "\n" dependencies ^ "\n" in + output_binary_int channel (String.length dependency_block); + output_string channel dependency_block; + output_string channel source; + output_char channel '\n') + let path root relative = relative |> String.split_on_char '/' |> File_util.path_of_parts root diff --git a/tests/rewatch_ounit_tests/toolchain_tests.ml b/tests/rewatch_ounit_tests/toolchain_tests.ml index 1c77ab6982d..4ca81d0efb6 100644 --- a/tests/rewatch_ounit_tests/toolchain_tests.ml +++ b/tests/rewatch_ounit_tests/toolchain_tests.ml @@ -17,15 +17,71 @@ let tests = Unix.mkdir bin 0o755; let executable = Filename.concat bin "rescript.exe" in write_file executable "test executable"; + let project = Filename.concat root "project" in + Unix.mkdir project 0o755; + let no_packages _ _ = None in + let bundled ?(executable = executable) find_package = + Toolchain.bundled_bsc ~cwd:root ~executable ~root:project ~find_package + in + let sibling = Filename.concat bin "bsc.exe" in check - (Toolchain.sibling_bsc_candidate ~cwd:root ~executable - = Filename.concat bin "bsc.exe") + (bundled no_packages = sibling) + "without any bsc.exe, the sibling path is recorded"; + (match + Toolchain.platform_package ~system:Build_platform.system + ~architecture:Build_platform.architecture + with + | None -> () + | Some platform -> + let package = Filename.concat root "platform" in + let package_bsc = + Filename.concat (Filename.concat package "bin") "bsc.exe" + in + Unix.mkdir package 0o755; + Unix.mkdir (Filename.concat package "bin") 0o755; + write_file package_bsc "test bsc"; + check + (bundled (fun directory name -> + if directory = project && name = platform then Some package + else None) + = package_bsc) + "a development build records the platform package's bsc.exe"; + let rescript = Filename.concat root "rescript" in + check + (bundled (fun directory name -> + if directory = project && name = "rescript" then Some rescript + else if directory = rescript && name = platform then Some package + else None) + = package_bsc) + "the platform package is also found from the rescript package"; + check + (bundled (fun _ name -> if name = platform then Some root else None) + = sibling) + "a platform package without bsc.exe is ignored"); + write_file sibling "test bsc"; + check + (bundled (fun _ _ -> Some root) = sibling) "absolute executable paths locate sibling bsc.exe"; check - (Toolchain.sibling_bsc_candidate ~cwd:root - ~executable:(Filename.concat "bin" "rescript.exe") - = Filename.concat bin "bsc.exe") + (bundled ~executable:(Filename.concat "bin" "rescript.exe") (fun _ _ -> + Some root) + = sibling) "relative executable paths locate sibling bsc.exe"); + List.iter + (fun (system, architecture, expected) -> + check + (Toolchain.platform_package ~system ~architecture = expected) + (Printf.sprintf "%s/%s names its platform package" system architecture)) + [ + ("linux", "amd64", Some "@rescript/linux-x64"); + ("linux", "arm64", Some "@rescript/linux-arm64"); + ("macosx", "amd64", Some "@rescript/darwin-x64"); + ("macosx", "arm64", Some "@rescript/darwin-arm64"); + ("mingw64", "amd64", Some "@rescript/win32-x64"); + ("win64", "amd64", Some "@rescript/win32-x64"); + ("linux", "riscv", None); + ("freebsd", "amd64", None); + ]; check (Platform_windows.strip_verbatim_prefix "\\\\?\\C:\\ReScript\\bin\\bsc.exe" = "C:\\ReScript\\bin\\bsc.exe") diff --git a/tests/rewatch_ounit_tests/unit_tests.ml b/tests/rewatch_ounit_tests/unit_tests.ml index 053e132b1b2..e2a30ded55f 100644 --- a/tests/rewatch_ounit_tests/unit_tests.ml +++ b/tests/rewatch_ounit_tests/unit_tests.ml @@ -2,9 +2,10 @@ open OUnit2 let check condition message = assert_bool message condition -module Checked_windows_platform : module type of Platform = Platform_windows - -type lazy_job = First | Second +(* Type-checks the Windows backend against the platform interface on every + platform. The library is wrapped, so its Platform module is named in full. *) +module Checked_windows_platform : module type of Rewatch_ocaml_lib__Platform = + Platform_windows let write_file = Test_support.write_file @@ -69,6 +70,14 @@ let () = while true do ignore (Unix.select [] [] [] 1.) done + | "--ppx-wait" -> + write_file (argument 2) (string_of_int (Unix.getpid ())); + Unix.sleepf 30.; + exit 0 + | "--ppx-copy" -> + write_file (argument 2) "started"; + write_file (argument 4) (read_file (argument 3)); + exit 0 | "--sleep" -> Thread.delay (float_of_string (argument 2)); exit 0 @@ -86,29 +95,6 @@ let () = write_file pending (Unix.getpid () |> string_of_int); Unix.rename pending marker; exit 0 - | "-format" -> ( - if Sys.win32 then set_binary_mode_out stdout true; - match - ( Sys.getenv_opt "REWATCH_FORMAT_TEST_ROOT", - Sys.getenv_opt "REWATCH_FORMAT_INVENTORY_TEST_ROOT" ) - with - | _, Some root -> - let source = argument 2 in - let marker = Digest.string source |> Digest.to_hex in - touch_file (Filename.concat root marker); - print_string (read_file source); - exit 0 - | None, None -> () - | Some root, None -> - let source = argument 2 in - touch_file - (Filename.concat root (Filename.basename source ^ ".started")); - let first_started = Filename.concat root "First.res.started" in - let second_started = Filename.concat root "Second.res.started" in - if not (wait_for_file first_started && wait_for_file second_started) - then exit 2; - print_string (read_file source); - exit 0) | _ -> () let test_executable () = Unix.realpath Sys.executable_name @@ -155,14 +141,15 @@ let process_parallel_tests _context = "parallel subprocess bound follows the available CPUs"; let completed_indices = ref [] in let parallel_results = - Process.run_parallel ~max_jobs:2 + Process.run_tasks ~max_jobs:2 ~on_complete:(fun index -> completed_indices := index :: !completed_indices) - [ - process_job ["--process-result"; "first"; ""; "0"]; - process_job ["--process-result"; "second"; ""; "0"]; - process_job ["--process-result"; "third"; ""; "0"]; - ] + (List.map Process.task + [ + process_job ["--process-result"; "first"; ""; "0"]; + process_job ["--process-result"; "second"; ""; "0"]; + process_job ["--process-result"; "third"; ""; "0"]; + ]) in check (List.map (fun (result : Process.result) -> result.stdout) parallel_results @@ -173,8 +160,9 @@ let process_parallel_tests _context = "parallel subprocess completion reports every input index once"; let recycled_handle_results = List.init 64 (fun index -> - process_job ["--process-result"; string_of_int index; ""; "0"]) - |> Process.run_parallel ~max_jobs:4 + Process.task + (process_job ["--process-result"; string_of_int index; ""; "0"])) + |> Process.run_tasks ~max_jobs:4 in check (List.mapi @@ -183,26 +171,6 @@ let process_parallel_tests _context = recycled_handle_results |> List.for_all Fun.id) "rapid subprocess completion cannot confuse recycled Windows handles"; - let lazy_root = Filename.temp_file "rewatch-lazy-jobs-" "" in - Sys.remove lazy_root; - Unix.mkdir lazy_root 0o755; - let lazy_results = - Fun.protect - ~finally:(fun () -> File_util.remove_tree lazy_root) - (fun () -> - Process.run_parallel_map ~max_jobs:2 [First; Second] ~job:(function - | First -> process_job ["--wait-for-release"; lazy_root] - | Second -> - check - (wait_for_file (Filename.concat lazy_root "child-started")) - "later job preparation overlaps an already-running child"; - touch_file (Filename.concat lazy_root "release"); - process_job ["--process-result"; "second"; ""; "0"])) - in - check - (List.map (fun (result : Process.result) -> result.stdout) lazy_results - = [""; "second"]) - "demand-built subprocess results retain input order"; let large_result = Process.run ~cwd:(Sys.getcwd ()) test_executable ["--large-process-result"] in @@ -213,7 +181,7 @@ let process_parallel_tests _context = "stdout and stderr pipes are drained concurrently without truncation"; let invalid_parallel_bound_rejected = try - ignore (Process.run_parallel ~max_jobs:0 []); + ignore (Process.run_tasks ~max_jobs:0 []); false with Process.Error _ -> true in @@ -223,6 +191,37 @@ let graph_work key dependencies = Process.{key; dependencies; value = key} let process_cancellation_tests _context = let test_executable = test_executable () in + let completed_request = + Process.{status = Unix.WEXITED 0; stdout = ""; stderr = ""} + in + let domain_interrupt_requested = Atomic.make false in + let second_domain_request_started = Atomic.make false in + let domain_cancelled = + try + ignore + (Process.run_tasks ~max_jobs:1 + ~poll:(fun () -> + if Atomic.get domain_interrupt_requested then + raise (Process.Interrupted 130)) + [ + Process.concurrent_task + ~cancel:(fun () -> ()) + ~on_result:(fun result -> + Atomic.set domain_interrupt_requested true; + result) + (fun () -> completed_request); + Process.concurrent_task + ~cancel:(fun () -> ()) + (fun () -> + Atomic.set second_domain_request_started true; + completed_request); + ]); + false + with Process.Interrupted 130 -> true + in + check + (domain_cancelled && not (Atomic.get second_domain_request_started)) + "an interrupt after a domain request stops the next request"; let cancellation_polls = ref 0 in let dependency_graph_cancelled = let exception Cancel in @@ -281,6 +280,33 @@ let process_cancellation_tests _context = in check process_cancelled "single subprocess cancellation terminates the active process"; + let concurrent_cancelled = Atomic.make false in + let concurrent_started = Atomic.make false in + let concurrent_task_cancelled = + let exception Cancel in + try + Process.run_dependency_graph ~max_jobs:1 + [graph_work "concurrent-cancel" []] + ~poll:(fun () -> if Atomic.get concurrent_started then raise Cancel) + ~next:(fun _ result -> + match result with + | Some _ -> None + | None -> + Some + (Process.concurrent_task + ~cancel:(fun () -> Atomic.set concurrent_cancelled true) + (fun () -> + Atomic.set concurrent_started true; + while not (Atomic.get concurrent_cancelled) do + Thread.delay 0.001 + done; + Process.{status = Unix.WEXITED 0; stdout = ""; stderr = ""}))); + false + with Cancel -> true + in + check + (concurrent_task_cancelled && Atomic.get concurrent_cancelled) + "dependency scheduler cancellation invokes active concurrent-task cleanup"; if not Sys.win32 then Test_support.with_temp_dir "rewatch-descendant-pipe-" (fun root -> let marker = Filename.concat root "parent-exiting" in @@ -374,6 +400,36 @@ let process_dependency_graph_tests _context = in check parallel_finalizers_completed "independent subprocess finalizers run before scheduler dispatch resumes"; + let concurrent_tasks_entered = Atomic.make 0 in + let concurrent_tasks_completed = + let exception Tasks_serialized in + try + Process.run_dependency_graph ~max_jobs:2 + [graph_work "concurrent-first" []; graph_work "concurrent-second" []] + ~next:(fun _ result -> + match result with + | Some _ -> None + | None -> + Some + (Process.concurrent_task + ~cancel:(fun () -> ()) + (fun () -> + ignore (Atomic.fetch_and_add concurrent_tasks_entered 1); + let deadline = Unix.gettimeofday () +. 2. in + while + Atomic.get concurrent_tasks_entered < 2 + && Unix.gettimeofday () < deadline + do + Thread.delay 0.001 + done; + if Atomic.get concurrent_tasks_entered < 2 then + raise Tasks_serialized; + Process.{status = Unix.WEXITED 0; stdout = ""; stderr = ""}))); + true + with Tasks_serialized -> false + in + check concurrent_tasks_completed + "independent concurrent tasks run on separate scheduler workers"; let graph_cycle_rejected = try Process.run_dependency_graph @@ -597,8 +653,8 @@ let scheduler_tests _context = } in let results = - Process.run_parallel ~max_jobs:2 - [job "first"; job "second"; job "third"] + Process.run_tasks ~max_jobs:2 + (List.map Process.task [job "first"; job "second"; job "third"]) in let _, helper_status = Unix.waitpid [] helper in check (helper_status = Unix.WEXITED 0) "scheduler test helper exits"; @@ -611,8 +667,11 @@ let scheduler_tests _context = = ["first"; "second"; "third"]) "dynamically scheduled results retain input order"; let failure = - Process.run_parallel ~max_jobs:1 - [process_job ["--process-result"; "partial"; "diagnostic"; "7"]] + Process.run_tasks ~max_jobs:1 + [ + Process.task + (process_job ["--process-result"; "partial"; "diagnostic"; "7"]); + ] |> List.hd in check @@ -922,7 +981,6 @@ let lock_tests _context = File_util.remove_file lock) let dependency_validation_tests _context = - let test_executable = test_executable () in let dependency_root = Filename.temp_file "rewatch-ocaml-allowed-dependents-" "" in @@ -939,44 +997,33 @@ let dependency_validation_tests _context = (List.fold_left Filename.concat dependency_root ["node_modules"; "restricted"; "rescript.json"]) {|{"name":"restricted","allowed-dependents":["other"]}|}; - let previous_bsc = Sys.getenv_opt "RESCRIPT_BSC_EXE" in - Unix.putenv "RESCRIPT_BSC_EXE" test_executable; - Fun.protect - ~finally:(fun () -> - match previous_bsc with - | Some value -> Unix.putenv "RESCRIPT_BSC_EXE" value - | None -> Test_support.unsetenv "RESCRIPT_BSC_EXE") - (fun () -> - let rejected = - try - Build.run - ~poll:(fun () -> ()) - ~verbosity:0 ~folder:dependency_root ~prod:false ~features:None - ~warn_error:None ~after_build:None ~filter:None ~no_timing:false; - false - with Project_context.Error message -> - if - Test_support.contains_text message - "app dependencies: restricted" - then true - else failwith ("unexpected allowed-dependents error: " ^ message) - in - check rejected "unallowed package dependency is rejected"; - write_file - (Filename.concat dependency_root "rescript.json") - {|{"name":"app","dev-dependencies":["restricted"]}|}; - let rejected = - try - Build.run - ~poll:(fun () -> ()) - ~verbosity:0 ~folder:dependency_root ~prod:false ~features:None - ~warn_error:None ~after_build:None ~filter:None ~no_timing:false; - false - with Project_context.Error message -> - Test_support.contains_text message - "app dev-dependencies: restricted" - in - check rejected "unallowed development dependency is rejected")) + let rejected = + try + Build.run + ~poll:(fun () -> ()) + ~verbosity:0 ~folder:dependency_root ~prod:false ~features:None + ~warn_error:None ~after_build:None ~filter:None ~no_timing:false; + false + with Project_context.Error message -> + if Test_support.contains_text message "app dependencies: restricted" + then true + else failwith ("unexpected allowed-dependents error: " ^ message) + in + check rejected "unallowed package dependency is rejected"; + write_file + (Filename.concat dependency_root "rescript.json") + {|{"name":"app","dev-dependencies":["restricted"]}|}; + let rejected = + try + Build.run + ~poll:(fun () -> ()) + ~verbosity:0 ~folder:dependency_root ~prod:false ~features:None + ~warn_error:None ~after_build:None ~filter:None ~no_timing:false; + false + with Project_context.Error message -> + Test_support.contains_text message "app dev-dependencies: restricted" + in + check rejected "unallowed development dependency is rejected") let tests = "unit_tests"