diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7826ca538db..c6f3779824e 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -2,7 +2,7 @@ name: CI on: push: - branches: [master, 11.0_release] + branches: [master, 11.0_release, rewatch-ocaml-consolidated] pull_request: branches: [master, 11.0_release] @@ -198,7 +198,7 @@ jobs: - name: Run analysis / tools tests if: runner.os != 'Windows' && runner.os != 'Linux' - run: opam exec -- make -C tests/analysis_tests test && make -C tests/tools_tests test + run: opam exec -- make test-analysis test-tools - name: Run gentype tests if: runner.os != 'Windows' @@ -246,20 +246,41 @@ jobs: shell: bash - name: Run OCaml rewatch unit tests + id: rewatch-unit-tests timeout-minutes: 10 run: | opam exec -- dune build tests/rewatch_ounit_tests/rewatch_ounit_tests_main.exe # Run the executable directly so a stuck test leaves live progress; # dune otherwise buffers the test output until the action exits. - opam exec -- ./_build/default/tests/rewatch_ounit_tests/rewatch_ounit_tests_main.exe -runner sequential + REWATCH_COMPILER_WORKER_EXECUTABLE="$PWD/_build/default/rewatch-ocaml/rescript_ocaml.exe" \ + opam exec -- ./_build/default/tests/rewatch_ounit_tests/rewatch_ounit_tests_main.exe -runner sequential -verbose true shell: bash + - name: Upload OCaml rewatch unit test failure logs + if: failure() && steps.rewatch-unit-tests.outcome == 'failure' + uses: actions/upload-artifact@v7 + with: + name: rewatch-unit-test-logs-${{ matrix.os }}-${{ matrix.ocaml_compiler }} + path: _build/oUnit-rewatch-*.log + if-no-files-found: warn + - name: Run OCaml rewatch focused integration tests timeout-minutes: 30 run: | + REWATCH_COMPILER_DOMAINS=1 sh rewatch-ocaml/tests/run.sh packages/@rescript/${{ matrix.node-target }}/bin/rescript.exe + REWATCH_COMPILER_DOMAINS=4 sh rewatch-ocaml/tests/run.sh packages/@rescript/${{ matrix.node-target }}/bin/rescript.exe sh rewatch-ocaml/tests/run.sh packages/@rescript/${{ matrix.node-target }}/bin/rescript.exe shell: bash + - name: Check frozen compiler and GenType parity + if: matrix.node-target == 'linux-arm64' + timeout-minutes: 15 + run: | + opam exec -- dune build rewatch-ocaml/bench/cmt_compare.exe + python3 rewatch-ocaml/bench/frozen_gentype_parity.py "$RUNNER_TEMP/frozen-gentype-parity" + python3 rewatch-ocaml/bench/legacy_ppx_gate.py "$RUNNER_TEMP/legacy-ppx-gate" 5 + shell: bash + - name: Run OCaml rewatch canonical tests run: ./rewatch/tests/suite.sh packages/@rescript/${{ matrix.node-target }}/bin/rescript.exe shell: bash @@ -372,7 +393,9 @@ jobs: - name: Generate API Docs if: ${{ matrix.generate_api_docs }} - run: yarn apidocs:generate + run: | + opam exec -- make annotated-tooling-deps + REWATCH_BIN_ANNOT=1 yarn apidocs:generate - name: "Upload artifacts: scripts/res/apiDocs" id: upload-api-docs diff --git a/CHANGELOG.md b/CHANGELOG.md index 311d5eee7ff..ba7ac0776a7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -18,18 +18,25 @@ #### :rocket: New Feature +- Use the OCaml rewatch build system with parallel in-process compiler workers as the default `rescript` executable; keep the Rust implementation available as `rescript-rust`. https://github.com/rescript-lang/rescript/pull/8653 + #### :bug: Bug fix - Make rewatch compile independent modules after an unrelated failure and recompile blocked dependents when a changed interface survives a failed implementation, including across full watcher rebuilds. https://github.com/rescript-lang/rescript/pull/8667 +- Avoid a parser-artifact publication error when an OCaml rewatch compilation fails while its AST is being exported. https://github.com/rescript-lang/rescript/pull/8680 #### :memo: Documentation #### :nail_care: Polish +- Speed up OCaml rewatch builds with project-owned compiler caches, in-memory module results, and fewer compatibility copies. https://github.com/rescript-lang/rescript/pull/8680 +- Use frozen compiler imports in mixed GenType builds while preserving generated TypeScript and editor annotations. https://github.com/rescript-lang/rescript/pull/8680 - Avoid running `rescript-schema-ppx` and `sury-ppx` on source files without an `@schema` annotation. https://github.com/rescript-lang/rescript/pull/8662 #### :house: Internal +- Share immutable compiled interfaces across OCaml rewatch compiler workers, with request-local type views. https://github.com/rescript-lang/rescript/pull/8680 + # 13.0.0-alpha.6 #### :boom: Breaking Change diff --git a/Makefile b/Makefile index f0fda0191d3..6760bc27170 100644 --- a/Makefile +++ b/Makefile @@ -162,8 +162,12 @@ bench: compiler test: lib node scripts/test.js -all -test-analysis: lib - make -C tests/analysis_tests clean test +annotated-tooling-deps: lib + REWATCH_BIN_ANNOT=1 REWATCH_FROZEN_VALUES=0 $(RESCRIPT_EXE) build $(RUNTIME_DIR) + REWATCH_BIN_ANNOT=1 REWATCH_FROZEN_VALUES=0 $(RESCRIPT_EXE) build $(BELT_DIR) + +test-analysis: annotated-tooling-deps + REWATCH_BIN_ANNOT=1 REWATCH_FROZEN_VALUES=0 $(MAKE) -C tests/analysis_tests clean test test-reanalyze: lib make -C tests/analysis_tests/tests-reanalyze/deadcode test @@ -172,8 +176,8 @@ test-reanalyze: lib benchmark-reanalyze: lib make -C tests/analysis_tests/tests-reanalyze/deadcode-benchmark benchmark COPIES=$(or $(COPIES),50) -test-tools: lib - make -C tests/tools_tests clean test +test-tools: annotated-tooling-deps + REWATCH_BIN_ANNOT=1 REWATCH_FROZEN_VALUES=0 $(MAKE) -C tests/tools_tests clean test test-syntax: compiler ./scripts/test_syntax.sh @@ -374,4 +378,4 @@ dev-container: .DEFAULT_GOAL := build -.PHONY: yarn-install build rewatch compiler lib artifacts bench test test-analysis test-reanalyze benchmark-reanalyze test-tools test-syntax test-syntax-roundtrip test-gentype test-rewatch test-all playground playground-compiler playground-test playground-cmijs playground-release format checkformat clean-rewatch clean-compiler clean-lib clean-gentype clean-tests clean dev-container +.PHONY: yarn-install build rewatch compiler lib artifacts bench test annotated-tooling-deps test-analysis test-reanalyze benchmark-reanalyze test-tools test-syntax test-syntax-roundtrip test-gentype test-rewatch test-all playground playground-compiler playground-test playground-cmijs playground-release format checkformat clean-rewatch clean-compiler clean-lib clean-gentype clean-tests clean dev-container diff --git a/compiler/bsc/rescript_compiler_driver.ml b/compiler/bsc/rescript_compiler_driver.ml index f2b6cd152f5..ace2b8f80a2 100644 --- a/compiler/bsc/rescript_compiler_driver.ml +++ b/compiler/bsc/rescript_compiler_driver.ml @@ -12,6 +12,11 @@ let absname_key = Domain.DLS.new_key (fun () -> ref false) let absname () = Domain.DLS.get absname_key +let with_fresh_absname action = + let previous = absname () in + Domain.DLS.set absname_key (ref false); + Fun.protect action ~finally:(fun () -> Domain.DLS.set absname_key previous) + exception Request_exit of int module Error_message_utils_support = struct @@ -55,48 +60,52 @@ let setup_outcome_printer () = Lazy.force Res_outcome_printer.setup let setup_runtime_path path = Runtime_package.set_path path let process_file sourcefile ?kind ppf = - (* The input name must identify the source when writing the binary AST. *) - setup_outcome_printer (); - Error_message_utils_support.setup (); - let kind = - match kind with - | None -> - Ext_file_extensions.classify_input - (Ext_filename.get_extension_maybe sourcefile) - | Some kind -> kind - in - let res = - match kind with - | Res -> - let sourcefile = set_abs_input_name sourcefile in - Js_implementation.implementation - ~parser: - (Res_driver.parse_implementation - ~ignore_parse_errors:!((Clflags.current ()).ignore_parse_errors)) - ppf sourcefile - | Resi -> - let sourcefile = set_abs_input_name sourcefile in - Js_implementation.interface - ~parser: - (Res_driver.parse_interface - ~ignore_parse_errors:!((Clflags.current ()).ignore_parse_errors)) - ppf sourcefile - | Intf_ast -> Js_implementation.interface_mliast ppf sourcefile - (* The printer setup is done in the runtime depends on + Compiler_phase_trace.section "request.other" (fun () -> + (* The input name must identify the source when writing the binary AST. *) + setup_outcome_printer (); + Error_message_utils_support.setup (); + let kind = + match kind with + | None -> + Ext_file_extensions.classify_input + (Ext_filename.get_extension_maybe sourcefile) + | Some kind -> kind + in + let res = + match kind with + | Res -> + let sourcefile = set_abs_input_name sourcefile in + Js_implementation.implementation + ~parser: + (Res_driver.parse_implementation + ~ignore_parse_errors: + !((Clflags.current ()).ignore_parse_errors)) + ppf sourcefile + | Resi -> + let sourcefile = set_abs_input_name sourcefile in + Js_implementation.interface + ~parser: + (Res_driver.parse_interface + ~ignore_parse_errors: + !((Clflags.current ()).ignore_parse_errors)) + ppf sourcefile + | Intf_ast -> Js_implementation.interface_mliast ppf sourcefile + (* The printer setup is done in the runtime depends on the content of ast *) - | Impl_ast -> Js_implementation.implementation_mlast ppf sourcefile - | Mlmap -> - Location.set_input_name sourcefile; - Js_implementation.implementation_map ppf sourcefile - | Cmi -> - let cmi_sign = (Cmi_format.read_cmi sourcefile).cmi_sign in - let output = Compiler_request_output.stdout_formatter () in - Printtyp.signature output cmi_sign; - Format.pp_print_newline output () - | Unknown -> Bsc_args.bad_arg ("don't know what to do with " ^ sourcefile) - in - res + | Impl_ast -> Js_implementation.implementation_mlast ppf sourcefile + | Mlmap -> + Location.set_input_name sourcefile; + Js_implementation.implementation_map ppf sourcefile + | Cmi -> + let cmi_sign = (Cmi_format.read_cmi sourcefile).cmi_sign in + let output = Compiler_request_output.stdout_formatter () in + Printtyp.signature output cmi_sign; + Format.pp_print_newline output () + | Unknown -> + Bsc_args.bad_arg ("don't know what to do with " ^ sourcefile) + in + res) let reprint_source_file sourcefile = let kind = @@ -542,7 +551,339 @@ let () = Ast_config.add_signature flags file_level_flags_handler; Ident.capture_request_baseline () -type result = {exit_code: int; stdout: string; stderr: string} +type result = { + exit_code: int; + stdout: string; + stderr: string; + diagnostics: Location.diagnostic list; +} + +type prepared_options = { + clflags: Clflags.snapshot; + js_config: Js_config.snapshot; + packages: Js_packages_state.snapshot; + gentype: Gentype_config.flags_snapshot; + warnings: Warnings.snapshot; + debug: Debug.snapshot; + experimental: Experimental_features.snapshot; + runtime_path: string option; + project_root: string option; + absname: bool; + rev_other_inputs: string list; +} +type published_cmj = { + filename: string; + source: string option; + stats: Unix.stats; + fingerprint: Digest.t; + image: Js_cmj_format.frozen; +} +type session_ast = { + input_path: string; + generation: int; + source_stats: Unix.stats; + disk_stats: Unix.stats option; + result: Binary_ast.result; + contents: string option; + parsed_at: float; +} +type published_semantic = { + stats: Unix.stats; + generation: int; + value: Cmt_format.cmt_infos; +} +type published_fingerprint = { + source: string option; + stats: Unix.stats; + fingerprint: Digest.t; +} +type 'a staged_artifact = {stats: Unix.stats; value: 'a} +type owned_cmi = { + input_path: string; + source_path: string; + generation: int; + source_stats: Unix.stats; + crc: Digest.t; + cmi: Cmi_format.cmi_infos; + contents: string; +} +type owned_cmj = { + input_path: string; + source_path: string; + generation: int; + source_stats: Unix.stats; + fingerprint: Digest.t; + cmj: Js_cmj_format.t; + contents: string; +} +type owned_cmt = { + input_path: string; + source_path: string; + generation: int; + source_stats: Unix.stats; + semantic: Cmt_format.cmt_infos; + contents: string; +} + +type staged_semantic = { + stats: Unix.stats; + value: Cmt_format.cmt_infos; + generation: int; +} +type module_result = { + interface_file: string; + interface_source: string option; + interface_stats: Unix.stats; + interface_fingerprint: Digest.t option; + interface_image: Frozen_values.t option; + optimization: + (string + * string option + * Unix.stats + * Digest.t + * Js_cmj_format.frozen option) + option; + semantic: unit -> Cmt_format.cmt_infos option; + diagnostics: Location.diagnostic list; + dependencies: string list; + generated_outputs: string list; +} +type session = { + mutable dependencies: Env.dependency_cache; + handoff_enabled: bool Atomic.t; + frozen_lookup_enabled: bool Atomic.t; + owned_ast_enabled: bool Atomic.t; + owned_artifacts_enabled: bool Atomic.t; + use_frozen_for_compile: bool Atomic.t; + options_lock: Mutex.t; + option_templates: (string * string list, prepared_options) Hashtbl.t; + staging_lock: Mutex.t; + staged_cmis: + (string, (Digest.t * Cmi_format.cmi_infos) staged_artifact) Hashtbl.t; + owned_cmis: (string, owned_cmi) Hashtbl.t; + staged_cmjs: (string, (Digest.t * Js_cmj_format.t) staged_artifact) Hashtbl.t; + owned_cmjs: (string, owned_cmj) Hashtbl.t; + owned_cmts: (string, owned_cmt) Hashtbl.t; + published_cmjs: (string, published_cmj) Hashtbl.t; + cmi_fingerprints: (string, published_fingerprint) Hashtbl.t; + cmj_fingerprints: (string, published_fingerprint) Hashtbl.t; + staged_diagnostics: (string, Location.diagnostic list) Hashtbl.t; + staged_generated_outputs: (string, string list) Hashtbl.t; + staged_request_files: (string, string list) Hashtbl.t; + request_generations: (string, int) Hashtbl.t; + mutable next_request_generation: int; + published_results: (string, module_result) Hashtbl.t; + staged_asts: (string, session_ast) Hashtbl.t; + published_asts: (string, session_ast) Hashtbl.t; + staged_semantics: (string, staged_semantic) Hashtbl.t; + mutable staged_semantic_bytes: int; + mutable staged_semantic_generation: int; + published_semantics: (string, published_semantic) Hashtbl.t; + published_semantic_sources: (string, string * Unix.stats) Hashtbl.t; + mutable semantic_bytes: int; + mutable semantic_generation: int; +} + +let max_owned_artifact_bytes = 32 * 1024 * 1024 + +let owned_artifact_bytes session = + let bytes = ref 0 in + Hashtbl.iter + (fun _ (entry : owned_cmi) -> + bytes := !bytes + String.length entry.contents) + session.owned_cmis; + Hashtbl.iter + (fun _ (entry : owned_cmj) -> + bytes := !bytes + String.length entry.contents) + session.owned_cmjs; + Hashtbl.iter + (fun _ (entry : owned_cmt) -> + bytes := !bytes + String.length entry.contents) + session.owned_cmts; + !bytes + +let create_session () = + { + dependencies = Env.create_dependency_cache (); + handoff_enabled = Atomic.make true; + frozen_lookup_enabled = Atomic.make true; + owned_ast_enabled = Atomic.make false; + owned_artifacts_enabled = Atomic.make false; + use_frozen_for_compile = Atomic.make true; + options_lock = Mutex.create (); + option_templates = Hashtbl.create 32; + staging_lock = Mutex.create (); + staged_cmis = Hashtbl.create 32; + owned_cmis = Hashtbl.create 32; + staged_cmjs = Hashtbl.create 32; + owned_cmjs = Hashtbl.create 32; + owned_cmts = Hashtbl.create 32; + published_cmjs = Hashtbl.create 64; + cmi_fingerprints = Hashtbl.create 64; + cmj_fingerprints = Hashtbl.create 64; + staged_diagnostics = Hashtbl.create 64; + staged_generated_outputs = Hashtbl.create 64; + staged_request_files = Hashtbl.create 64; + request_generations = Hashtbl.create 64; + next_request_generation = 0; + published_results = Hashtbl.create 64; + staged_asts = Hashtbl.create 64; + published_asts = Hashtbl.create 64; + staged_semantics = Hashtbl.create 32; + staged_semantic_bytes = 0; + staged_semantic_generation = 0; + published_semantics = Hashtbl.create 32; + published_semantic_sources = Hashtbl.create 32; + semantic_bytes = 0; + semantic_generation = 0; + } + +let invalidate_session_policy_caches session = + (* Build preparation changes policies before launching compiler workers. Do + not retain images or staged results produced under the previous policy. *) + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + session.dependencies <- Env.create_dependency_cache (); + Hashtbl.clear session.staged_diagnostics; + Hashtbl.clear session.staged_generated_outputs; + Hashtbl.clear session.staged_request_files; + Hashtbl.clear session.staged_cmis; + Hashtbl.clear session.owned_cmis; + Hashtbl.clear session.staged_cmjs; + Hashtbl.clear session.owned_cmjs; + Hashtbl.clear session.owned_cmts; + Hashtbl.clear session.published_cmjs; + Hashtbl.clear session.cmi_fingerprints; + Hashtbl.clear session.cmj_fingerprints; + Hashtbl.clear session.request_generations; + Hashtbl.clear session.published_results; + Hashtbl.clear session.staged_asts; + Hashtbl.clear session.published_asts; + Hashtbl.clear session.staged_semantics; + Hashtbl.clear session.published_semantics; + Hashtbl.clear session.published_semantic_sources; + session.staged_semantic_bytes <- 0; + session.semantic_bytes <- 0; + Atomic.set session.use_frozen_for_compile true) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + +let set_frozen_for_compile session enabled = + Atomic.set session.use_frozen_for_compile enabled + +let set_session_handoff_enabled session enabled = + if Atomic.exchange session.handoff_enabled enabled <> enabled then + invalidate_session_policy_caches session + +let set_session_frozen_lookup_enabled session enabled = + if Atomic.exchange session.frozen_lookup_enabled enabled <> enabled then + invalidate_session_policy_caches session + +let set_session_owned_ast_enabled session enabled = + if Atomic.exchange session.owned_ast_enabled enabled <> enabled then + invalidate_session_policy_caches session + +let set_session_owned_artifacts_enabled session enabled = + if Atomic.exchange session.owned_artifacts_enabled enabled <> enabled then + invalidate_session_policy_caches session + +let session_owned_artifacts_enabled session = + Atomic.get session.owned_artifacts_enabled + +let session_owned_ast_enabled session = + Atomic.get session.owned_ast_enabled + && Sys.getenv_opt "REWATCH_OWNED_AST" <> Some "0" + +let session_handoff_enabled session = + Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "0" + && Atomic.get session.handoff_enabled + +let session_frozen_lookup_enabled session = + session_handoff_enabled session && Atomic.get session.frozen_lookup_enabled + +let same_file_stats first second = + first.Unix.st_dev = second.Unix.st_dev + && first.Unix.st_ino = second.Unix.st_ino + && first.Unix.st_size = second.Unix.st_size + && first.Unix.st_mtime = second.Unix.st_mtime + && first.Unix.st_ctime = second.Unix.st_ctime + +let unit_name_of_artifact filename = + filename |> Filename.basename |> Filename.remove_extension + |> String.capitalize_ascii + +let lookup_session_cmj session name filename = + let entry = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> Hashtbl.find_opt session.published_cmjs name) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + match entry with + | None -> None + | Some entry -> ( + try + let selected = Compiler_request_state.canonical_output_path filename in + let checked = Option.value entry.source ~default:entry.filename in + if + Compiler_request_state.same_output_path selected entry.filename + && same_file_stats (Unix.stat checked) entry.stats + then Some (Js_cmj_format.view entry.image) + else None + with Sys_error _ | Unix.Unix_error _ -> None) + +let valid_session_ast session ~path (entry : session_ast) = + Hashtbl.find_opt session.request_generations entry.input_path + = Some entry.generation + && + try + same_file_stats (Unix.stat entry.input_path) entry.source_stats + && + match entry.disk_stats with + | None -> true + | Some stats -> same_file_stats (Unix.stat path) stats + with Sys_error _ | Unix.Unix_error _ -> false + +let persist_stale_ast_for_disk_fallback session ~path (entry : session_ast) = + if + Hashtbl.find_opt session.request_generations entry.input_path + = Some entry.generation + then + Option.iter + (fun contents -> + (* The source changed after parsing. Keep the captured AST available + to the disk reader while the watcher schedules a fresh parse. *) + Misc.output_to_file_via_temporary ~mode:[Open_binary] path + (fun _ output -> output_string output contents); + Unix.utimes path entry.parsed_at entry.parsed_at) + entry.contents + +let staged_ast_dependencies session ~path = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + Option.bind (Hashtbl.find_opt session.staged_asts path) (fun entry -> + if valid_session_ast session ~path entry then + Some (Binary_ast.dependencies entry.result) + else None)) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + +let take_session_ast session filename = + let path = Compiler_request_state.resolve_path filename in + let entry = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let entry = Hashtbl.find_opt session.published_asts path in + Hashtbl.remove session.published_asts path; + Option.bind entry (fun entry -> + if valid_session_ast session ~path entry then Some entry.result + else ( + persist_stale_ast_for_disk_fallback session ~path entry; + None))) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + entry let build_identity = Rescript_compiler_build_identity.value @@ -577,6 +918,17 @@ let reset_state ?(new_request = false) () = Location.reset_input_name (); absname () := false +let with_fresh_option_states ~cwd action = + Clflags.with_fresh (fun () -> + Js_config.with_fresh (fun () -> + Js_packages_state.with_fresh (fun () -> + Warnings.with_fresh (fun () -> + Experimental_features.with_fresh (fun () -> + Gentype_config.with_fresh_flags (fun () -> + Debug.with_fresh (fun () -> + with_fresh_absname (fun () -> + Compiler_request_state.with_fresh ~cwd action)))))))) + let with_fresh_request_states ~cwd action = Predef.with_fresh (fun () -> Env.with_fresh_initial (fun () -> @@ -584,68 +936,1213 @@ let with_fresh_request_states ~cwd action = Typecore.with_fresh (fun () -> Stypes.with_fresh (fun () -> Ident.with_fresh (fun () -> - Clflags.with_fresh (fun () -> - Env.with_fresh (fun () -> - Js_config.with_fresh (fun () -> - Warnings.with_fresh (fun () -> - Experimental_features.with_fresh - (fun () -> - Btype.with_fresh (fun () -> - Js_packages_state.with_fresh - (fun () -> - Compiler_request_state - .with_fresh ~cwd action))))))))))))) - -let run_argv ?run_external ~cwd argv = - with_fresh_request_states ~cwd (fun () -> - reset_state ~new_request:true (); - Cmt_format.set_args argv; - let execute () = - try - Bsc_args.parse_exn ~argv (command_line_flags ()) anonymous ~usage; - 0 - with - | Request_exit code -> code - | Bsc_args.Help message -> - Compiler_request_output.write_stdout message; - 0 - | Res_driver.Already_reported -> 1 - | Bsc_args.Bad msg -> - Format.fprintf (ppf ()) "%s@." msg; - 2 - | x -> - Location.report_exception (ppf ()) x; - 2 - in - let run_with_external_owner action = - match run_external with - | None -> action () - | Some run_external -> - Ccomp.with_command_runner - (fun command -> - let status, stdout, stderr = run_external command in - Compiler_request_output.write_stdout stdout; - Format.pp_print_string (ppf ()) stderr; - status) - action - in - let exit_code, stdout, stderr = - Fun.protect - (fun () -> - Compiler_request_output.with_capture (fun () -> - Misc.Color.set_color_tag_handling - (Compiler_request_output.stdout_formatter ()); - Misc.Color.set_color_tag_handling - (Compiler_request_output.stderr_formatter ()); - run_with_external_owner execute)) - ~finally:reset_state - in - {exit_code; stdout; stderr}) + Env.with_fresh (fun () -> + Btype.with_fresh (fun () -> + with_fresh_option_states ~cwd action)))))))) + +let with_fresh_request_states_and_snapshot ~cwd action = + Fun.protect + (fun () -> with_fresh_request_states ~cwd action) + ~finally:Env.finalize_expanded_snapshot_cache + +let effectful_option = function + | "-e" | "-format" | "-reprint-source" | "-v" | "-version" | "-warn-help" + | "-help" | "--help" | "-h" -> + true + | _ -> false + +let prepare_options ~cwd argv = + if List.exists effectful_option argv then None + else + try + Some + (with_fresh_option_states ~cwd (fun () -> + Clflags.reset (); + Js_config.reset (); + Warnings.reset (); + let rev_other_inputs = ref [] in + Bsc_args.parse_exn + ~argv:(Array.of_list ("bsc" :: argv)) + (command_line_flags ()) + (fun ~rev_args -> rev_other_inputs := rev_args) + ~usage; + let request_state = Compiler_request_state.current () in + { + clflags = Clflags.snapshot (); + js_config = Js_config.snapshot (); + packages = Js_packages_state.snapshot (); + gentype = Gentype_config.snapshot_flags (); + warnings = Warnings.snapshot (); + debug = Debug.snapshot (); + experimental = Experimental_features.snapshot (); + runtime_path = request_state.runtime_path_override; + project_root = request_state.project_root; + absname = !(absname ()); + rev_other_inputs = !rev_other_inputs; + })) + with Bsc_args.Bad _ | Bsc_args.Help _ | Request_exit _ -> None + +let install_options options = + Clflags.install_copy options.clflags; + Js_config.install_copy options.js_config; + Js_packages_state.install_copy options.packages; + Gentype_config.install_flags_snapshot options.gentype; + Warnings.install_copy options.warnings; + Debug.install_copy options.debug; + Experimental_features.install_copy options.experimental; + let request_state = Compiler_request_state.current () in + request_state.runtime_path_override <- options.runtime_path; + request_state.project_root <- options.project_root; + absname () := options.absname + +let session_options session ~cwd ~argv = + let key = (cwd, argv) in + let cached = + Mutex.lock session.options_lock; + Fun.protect + (fun () -> Hashtbl.find_opt session.option_templates key) + ~finally:(fun () -> Mutex.unlock session.options_lock) + in + match cached with + | Some options -> Some options + | None -> ( + match prepare_options ~cwd argv with + | None -> None + | Some options -> + Mutex.lock session.options_lock; + Fun.protect + (fun () -> + (* A changed project configuration produces a new argv key. Bound + templates retained by a long-lived watch process. *) + if Hashtbl.length session.option_templates >= 256 then + Hashtbl.clear session.option_templates; + Hashtbl.replace session.option_templates key options) + ~finally:(fun () -> Mutex.unlock session.options_lock); + Some options) + +let run_argv ?run_external ?frozen_override ?prepared ~cwd argv = + let input = argv.(Array.length argv - 1) in + Gentype_summary.with_compiler_identity build_identity (fun () -> + Env.with_frozen_values_setting ?enabled:frozen_override (fun () -> + Compiler_phase_trace.request ~cwd ~input (fun () -> + with_fresh_request_states_and_snapshot ~cwd (fun () -> + Compiler_phase_trace.section "request.reset" (fun () -> + reset_state ~new_request:true ()); + Cmt_format.set_args argv; + let execute () = + try + (match prepared with + | None -> + let flags = + Compiler_phase_trace.section "request.flags" + command_line_flags + in + Compiler_phase_trace.section "request.dispatch" + (fun () -> + Bsc_args.parse_exn ~argv flags anonymous ~usage) + | Some options -> + Compiler_phase_trace.section "request.flags" (fun () -> + install_options options); + Compiler_phase_trace.section "request.dispatch" + (fun () -> + anonymous + ~rev_args:(input :: options.rev_other_inputs))); + 0 + with + | Request_exit code -> code + | Bsc_args.Help message -> + Compiler_request_output.write_stdout message; + 0 + | Res_driver.Already_reported -> 1 + | Bsc_args.Bad msg -> + Format.fprintf (ppf ()) "%s@." msg; + 2 + | x -> + Location.report_exception (ppf ()) x; + 2 + in + let run_with_external_owner action = + match run_external with + | None -> action () + | Some run_external -> + Ccomp.with_command_runner + (fun command -> + let status, stdout, stderr = run_external command in + Compiler_request_output.write_stdout stdout; + Format.pp_print_string (ppf ()) stderr; + status) + action + in + let (exit_code, stdout, stderr), diagnostics = + Fun.protect + (fun () -> + Location.with_diagnostic_capture (fun () -> + Compiler_request_output.with_capture (fun () -> + Misc.Color.set_color_tag_handling + (Compiler_request_output.stdout_formatter ()); + Misc.Color.set_color_tag_handling + (Compiler_request_output.stderr_formatter ()); + run_with_external_owner execute))) + ~finally:reset_state + in + {exit_code; stdout; stderr; diagnostics})))) let run_request ~run_external ~cwd ~argv ~input = let logical_argv = Array.of_list ("bsc" :: (argv @ [input])) in run_argv ?run_external ~cwd logical_argv +let run_request_with_frozen ~prepared ~frozen_override ~run_external ~cwd ~argv + ~input = + let logical_argv = Array.of_list ("bsc" :: (argv @ [input])) in + run_argv ?run_external ~frozen_override ?prepared ~cwd logical_argv + +let remove_staged_semantic session filename = + match Hashtbl.find_opt session.staged_semantics filename with + | None -> () + | Some entry -> + session.staged_semantic_bytes <- + session.staged_semantic_bytes - entry.stats.Unix.st_size; + Hashtbl.remove session.staged_semantics filename + +let stage_semantic session filename value = + try + let stats = Unix.stat filename in + remove_staged_semantic session filename; + if stats.Unix.st_size <= 4 * 1024 * 1024 then ( + session.staged_semantic_generation <- + session.staged_semantic_generation + 1; + Hashtbl.replace session.staged_semantics filename + {stats; value; generation = session.staged_semantic_generation}; + session.staged_semantic_bytes <- + session.staged_semantic_bytes + stats.Unix.st_size; + while + session.staged_semantic_bytes > 16 * 1024 * 1024 + || Hashtbl.length session.staged_semantics > 64 + do + let oldest = + Hashtbl.fold + (fun path (entry : staged_semantic) oldest -> + match oldest with + | Some (_, generation) when generation <= entry.generation -> + oldest + | _ -> Some (path, entry.generation)) + session.staged_semantics None + in + match oldest with + | None -> assert false + | Some (path, _) -> remove_staged_semantic session path + done; + true) + else false + with Sys_error _ | Unix.Unix_error _ -> false + +let lookup_session_semantic session ~filename = + let entry, destination, source_stats = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + match Hashtbl.find_opt session.published_semantics filename with + | Some entry -> (Some entry, filename, None) + | None -> ( + match + Hashtbl.find_opt session.published_semantic_sources filename + with + | None -> (None, filename, None) + | Some (destination, stats) -> + ( Hashtbl.find_opt session.published_semantics destination, + destination, + Some stats ))) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + match entry with + | None -> None + | Some entry -> ( + try + let valid_source = + match source_stats with + | None -> true + | Some stats -> same_file_stats (Unix.stat filename) stats + in + if valid_source && same_file_stats (Unix.stat destination) entry.stats + then + Some + (Marshal.from_bytes (Marshal.to_bytes entry.value []) 0 + : Cmt_format.cmt_infos) + else None + with Sys_error _ | Unix.Unix_error _ -> None) + +let run_request_in_session session ~run_external ~cwd ~argv ~input = + let prepared = session_options session ~cwd ~argv in + let input_path = + if Filename.is_relative input then Filename.concat cwd input else input + in + let generation = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + List.iter + (fun path -> + Hashtbl.remove session.staged_cmis path; + (match Hashtbl.find_opt session.owned_cmis path with + | Some entry when entry.input_path = input_path -> + Hashtbl.remove session.owned_cmis path + | Some _ -> () + | None -> ()); + Hashtbl.remove session.staged_cmjs path; + (match Hashtbl.find_opt session.owned_cmjs path with + | Some entry when entry.input_path = input_path -> + Hashtbl.remove session.owned_cmjs path + | Some _ | None -> ()); + (match Hashtbl.find_opt session.owned_cmts path with + | Some entry when entry.input_path = input_path -> + Hashtbl.remove session.owned_cmts path + | Some _ | None -> ()); + Hashtbl.remove session.staged_asts path; + remove_staged_semantic session path) + (Hashtbl.find_opt session.staged_request_files input_path + |> Option.value ~default:[]); + Hashtbl.remove session.staged_request_files input_path; + Hashtbl.remove session.staged_diagnostics input_path; + Hashtbl.remove session.staged_generated_outputs input_path; + session.next_request_generation <- session.next_request_generation + 1; + let generation = session.next_request_generation in + Hashtbl.replace session.request_generations input_path generation; + generation) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + Env.with_dependency_cache session.dependencies (fun () -> + let handoff_enabled = session_handoff_enabled session in + let frozen_lookup_enabled = session_frozen_lookup_enabled session in + (* GenType uses disk-backed interface precedence and source summaries. + Keep its requests on the classic path while unrelated jobs use the + frozen session image. *) + let request_frozen_lookup_enabled = + frozen_lookup_enabled && not (List.mem "-bs-gentype" argv) + in + let cmi_enabled = + handoff_enabled && Sys.getenv_opt "REWATCH_SESSION_CMI" <> Some "0" + in + let cmj_enabled = + handoff_enabled && Sys.getenv_opt "REWATCH_SESSION_CMJ" <> Some "0" + in + let owned_cmi_enabled = + cmi_enabled && request_frozen_lookup_enabled + && session_owned_artifacts_enabled session + && Sys.getenv_opt "REWATCH_OWNED_CMI" <> Some "0" + && (Filename.check_suffix input ".ast" + || Filename.check_suffix input ".iast") + in + let owned_cmj_enabled = + cmj_enabled && request_frozen_lookup_enabled + && session_owned_artifacts_enabled session + && Sys.getenv_opt "REWATCH_OWNED_CMJ" <> Some "0" + && Filename.check_suffix input ".ast" + in + let owned_cmt_enabled = + request_frozen_lookup_enabled + && session_owned_artifacts_enabled session + && Sys.getenv_opt "REWATCH_OWNED_CMT" <> Some "0" + && (Filename.check_suffix input ".ast" + || Filename.check_suffix input ".iast") + in + (* Classic requests retain the disk AST roundtrip, including the sharing + shape serialized in binary annotations. *) + let ast_enabled = + request_frozen_lookup_enabled + && Sys.getenv_opt "REWATCH_SESSION_AST" <> Some "0" + in + let owned_ast_enabled = + ast_enabled && session_owned_ast_enabled session + in + let use_session_cmj_lookup = + cmj_enabled && request_frozen_lookup_enabled + && Atomic.get session.use_frozen_for_compile + in + let compiled_cmi = ref None in + let owned_cmi = ref None in + let compiled_cmj = ref None in + let owned_cmj = ref None in + let parsed_ast = ref None in + let semantic = ref None in + let owned_cmt = ref None in + let generated_outputs = ref [] in + let run () = + let use_frozen = + request_frozen_lookup_enabled + && (List.mem "-bs-ast" argv + || Atomic.get session.use_frozen_for_compile) + in + run_request_with_frozen ~prepared ~frozen_override:use_frozen + ~run_external ~cwd ~argv ~input + in + let run () = + if cmi_enabled then + Env.with_compiled_cmi_capture + (fun filename crc cmi -> + compiled_cmi := + Some (Compiler_request_state.resolve_path filename, crc, cmi)) + run + else run () + in + let run () = + if owned_cmi_enabled then + Cmi_format.with_output_capture + (fun filename crc cmi contents -> + if String.length contents > 1024 * 1024 then false + else ( + owned_cmi := + Some + ( Compiler_request_state.resolve_path filename, + Compiler_request_state.resolve_path + (Location.get_input_name ()), + crc, + cmi, + contents ); + true)) + run + else run () + in + let run () = + if cmj_enabled then + Js_cmj_format.with_capture + (fun filename fingerprint cmj -> + compiled_cmj := + Some + ( Compiler_request_state.resolve_path filename, + fingerprint, + cmj )) + run + else run () + in + let run () = + if owned_cmj_enabled then + Js_cmj_format.with_output_capture + (fun filename fingerprint cmj contents -> + if String.length contents > 1024 * 1024 then false + else ( + owned_cmj := + Some + ( Compiler_request_state.resolve_path filename, + Compiler_request_state.resolve_path + (Location.get_input_name ()), + fingerprint, + cmj, + contents ); + true)) + run + else run () + in + let run () = + if ast_enabled then + Binary_ast.with_capture + (fun filename ast -> + parsed_ast := + Some (Compiler_request_state.resolve_path filename, ast); + owned_ast_enabled) + run + else run () + in + let run () = + match prepared with + | Some options + when not (Clflags.snapshot_binary_annotations options.clflags) -> + run () + | Some _ | None -> + Cmt_format.with_capture + (fun filename cmt -> + semantic := + Some (Compiler_request_state.resolve_path filename, cmt)) + run + in + let run () = + if owned_cmt_enabled then + Cmt_format.with_output_capture + (fun filename cmt contents -> + match cmt.Cmt_format.cmt_annots with + | Partial_implementation _ | Partial_interface _ -> + owned_cmt := None; + false + | Implementation _ | Interface _ | Packed _ -> ( + match cmt.cmt_sourcefile with + | None -> false + | Some _ when String.length contents > 4 * 1024 * 1024 -> false + | Some source_path -> + owned_cmt := + Some + ( Compiler_request_state.resolve_path filename, + Compiler_request_state.resolve_path source_path, + cmt, + contents ); + true)) + run + else run () + in + let run () = + Gentype_main.with_generated_output_capture + (fun filename -> + generated_outputs := + Compiler_request_state.resolve_path filename :: !generated_outputs) + run + in + let result = + let run () = + if use_session_cmj_lookup then + Js_cmj_load.with_session_lookup (lookup_session_cmj session) run + else run () + in + let run () = + if ast_enabled then + Binary_ast.with_lookup (take_session_ast session) run + else run () + in + Gentype_main.with_semantic_lookup + (fun filename -> lookup_session_semantic session ~filename) + run + in + (match result.exit_code with + | code when code <> 0 -> + Option.iter + (fun (filename, _, _, contents) -> + Misc.output_to_file_via_temporary ~mode:[Open_binary] filename + (fun _ output -> output_string output contents)) + !owned_cmt + | _ -> + let owned_cmi = + Option.bind !owned_cmi + (fun (filename, source_path, crc, cmi, contents) -> + try + Some + ( filename, + { + input_path; + source_path; + generation; + source_stats = Unix.stat source_path; + crc; + cmi; + contents; + } ) + with Sys_error _ | Unix.Unix_error _ -> + Ext_io.write_file filename contents; + None) + in + let owned_cmj = + Option.bind !owned_cmj + (fun (filename, source_path, fingerprint, cmj, contents) -> + try + Some + ( filename, + { + input_path; + source_path; + generation; + source_stats = Unix.stat source_path; + fingerprint; + cmj; + contents; + } ) + with Sys_error _ | Unix.Unix_error _ -> + Ext_io.write_file filename contents; + None) + in + let owned_cmt = + Option.bind !owned_cmt + (fun (filename, source_path, semantic, contents) -> + try + Some + ( filename, + { + input_path; + source_path; + generation; + source_stats = Unix.stat source_path; + semantic; + contents; + } ) + with Sys_error _ | Unix.Unix_error _ -> + Misc.output_to_file_via_temporary ~mode:[Open_binary] filename + (fun _ output -> output_string output contents); + None) + in + let parsed_ast = + Option.bind !parsed_ast (fun (filename, ast) -> + try + let source_stats = Unix.stat input_path in + let contents, disk_stats = + if owned_ast_enabled then + (Some (Binary_ast.serialize_result ast), None) + else (None, Some (Unix.stat filename)) + in + Some + ( filename, + { + input_path; + generation; + source_stats; + disk_stats; + result = ast; + contents; + parsed_at = Unix.gettimeofday (); + } ) + with Sys_error _ | Unix.Unix_error _ -> None) + in + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + if + Hashtbl.find_opt session.request_generations input_path + = Some generation + then ( + let files = ref [] in + let record filename = files := filename :: !files in + let stage table filename value = + try + let stats = Unix.stat filename in + record filename; + Hashtbl.replace table filename {stats; value} + with Sys_error _ | Unix.Unix_error _ -> () + in + let retain_owned table filename entry ~size ~fallback = + (* Bound byte images held across completed requests. When the + budget is full, persist this request before handoff. *) + Hashtbl.remove table filename; + if + owned_artifact_bytes session + size entry + <= max_owned_artifact_bytes + then Hashtbl.replace table filename entry + else fallback () + in + if + Option.is_some !compiled_cmi + || Option.is_some !compiled_cmj + || Option.is_some !semantic + then + Hashtbl.replace session.staged_diagnostics input_path + result.diagnostics; + Hashtbl.replace session.staged_generated_outputs input_path + !generated_outputs; + Option.iter + (fun (filename, crc, cmi) -> + stage session.staged_cmis filename (crc, cmi)) + !compiled_cmi; + Option.iter + (fun (filename, owned) -> + record filename; + retain_owned session.owned_cmis filename owned + ~size:(fun (entry : owned_cmi) -> + String.length entry.contents) + ~fallback:(fun () -> + Ext_io.write_file filename owned.contents; + stage session.staged_cmis filename (owned.crc, owned.cmi))) + owned_cmi; + Option.iter + (fun (filename, fingerprint, cmj) -> + stage session.staged_cmjs filename (fingerprint, cmj)) + !compiled_cmj; + Option.iter + (fun (filename, owned) -> + record filename; + retain_owned session.owned_cmjs filename owned + ~size:(fun (entry : owned_cmj) -> + String.length entry.contents) + ~fallback:(fun () -> + Ext_io.write_file filename owned.contents; + stage session.staged_cmjs filename + (owned.fingerprint, owned.cmj))) + owned_cmj; + Option.iter + (fun (filename, ast) -> + record filename; + Hashtbl.replace session.staged_asts filename ast) + parsed_ast; + Option.iter + (fun (filename, cmt) -> + if stage_semantic session filename cmt then record filename) + !semantic; + Option.iter + (fun (filename, owned) -> + record filename; + retain_owned session.owned_cmts filename owned + ~size:(fun (entry : owned_cmt) -> + String.length entry.contents) + ~fallback:(fun () -> + Misc.output_to_file_via_temporary ~mode:[Open_binary] + filename (fun _ output -> + output_string output owned.contents); + ignore (stage_semantic session filename owned.semantic))) + owned_cmt; + Hashtbl.replace session.staged_request_files input_path !files)) + ~finally:(fun () -> Mutex.unlock session.staging_lock)); + result) + +let valid_owned_source session ~input_path ~generation ~source_path + ~source_stats = + Hashtbl.find_opt session.request_generations input_path = Some generation + && + try same_file_stats (Unix.stat source_path) source_stats + with Sys_error _ | Unix.Unix_error _ -> false + +let persist_owned_cmi session ~path = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let owned = Hashtbl.find_opt session.owned_cmis path in + Option.iter + (fun (entry : owned_cmi) -> + if + not + (valid_owned_source session ~input_path:entry.input_path + ~generation:entry.generation ~source_path:entry.source_path + ~source_stats:entry.source_stats) + then failwith ("stale owned CMI: " ^ path); + Ext_io.write_file path entry.contents; + Hashtbl.replace session.staged_cmis path + {stats = Unix.stat path; value = (entry.crc, entry.cmi)}; + Hashtbl.remove session.owned_cmis path) + owned) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + +let persist_owned_cmj session ~path = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let owned = Hashtbl.find_opt session.owned_cmjs path in + Option.iter + (fun (entry : owned_cmj) -> + if + not + (valid_owned_source session ~input_path:entry.input_path + ~generation:entry.generation ~source_path:entry.source_path + ~source_stats:entry.source_stats) + then failwith ("stale owned CMJ: " ^ path); + Ext_io.write_file path entry.contents; + Hashtbl.replace session.staged_cmjs path + {stats = Unix.stat path; value = (entry.fingerprint, entry.cmj)}; + Hashtbl.remove session.owned_cmjs path) + owned) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + +let persist_owned_cmt session ~path = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let owned = Hashtbl.find_opt session.owned_cmts path in + Option.iter + (fun (entry : owned_cmt) -> + if + not + (valid_owned_source session ~input_path:entry.input_path + ~generation:entry.generation ~source_path:entry.source_path + ~source_stats:entry.source_stats) + then failwith ("stale owned CMT: " ^ path); + Misc.output_to_file_via_temporary ~mode:[Open_binary] path + (fun _ output -> output_string output entry.contents); + ignore (stage_semantic session path entry.semantic); + Hashtbl.remove session.owned_cmts path) + owned) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + +let validated_stage source (staged : 'a staged_artifact) = + try + if same_file_stats (Unix.stat source) staged.stats then Some staged.value + else None + with Sys_error _ | Unix.Unix_error _ -> None + +let staged_value session table source = + let staged = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> Hashtbl.find_opt table source) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + Option.bind staged (validated_stage source) + +let stage_session_cmi session ~source ~destination = + match staged_value session session.staged_cmis source with + | None -> false + | Some (crc, cmi) -> + if + Env.publish_pending_compiled_cmi session.dependencies ~source ~destination + ~crc cmi + then ( + Atomic.set session.use_frozen_for_compile true; + let stats = Unix.stat source in + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + Hashtbl.replace session.cmi_fingerprints destination + {source = Some source; stats; fingerprint = crc}) + ~finally:(fun () -> Mutex.unlock session.staging_lock); + true) + else false + +let stage_session_cmj session ~source ~destination = + match staged_value session session.staged_cmjs source with + | None -> false + | Some (fingerprint, cmj) -> + Atomic.set session.use_frozen_for_compile true; + let stats = Unix.stat source in + let image = Js_cmj_format.freeze cmj in + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + Hashtbl.replace session.cmj_fingerprints destination + {source = Some source; stats; fingerprint}; + let name = unit_name_of_artifact destination in + Hashtbl.replace session.published_cmjs name + { + filename = Compiler_request_state.canonical_output_path destination; + source = Some source; + stats; + fingerprint; + image; + }) + ~finally:(fun () -> Mutex.unlock session.staging_lock); + true + +let discard_pending_session_artifacts session ~interface_file ~optimization_file + = + Env.discard_pending_compiled_cmi session.dependencies ~filename:interface_file; + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + (match Hashtbl.find_opt session.published_results interface_file with + | Some result when Option.is_some result.interface_source -> + Hashtbl.remove session.published_results interface_file + | Some _ | None -> ()); + let discard table filename = + match Hashtbl.find_opt table filename with + | Some {source = Some _; stats = _; fingerprint = _} -> + Hashtbl.remove table filename + | Some _ | None -> () + in + discard session.cmi_fingerprints interface_file; + Option.iter + (fun filename -> + discard session.cmj_fingerprints filename; + let name = unit_name_of_artifact filename in + match Hashtbl.find_opt session.published_cmjs name with + | Some + { + filename = published; + source = Some _; + stats = _; + fingerprint = _; + image = _; + } + when Compiler_request_state.same_output_path published filename -> + Hashtbl.remove session.published_cmjs name + | Some _ | None -> ()) + optimization_file) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + +let publish_session_cmi session ~retain ~source ~destination = + let staged = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let staged = Hashtbl.find_opt session.staged_cmis source in + Hashtbl.remove session.staged_cmis source; + staged) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + Option.bind staged (validated_stage source) + |> Option.iter (fun (crc, cmi) -> + let stats = Unix.stat destination in + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + Hashtbl.replace session.cmi_fingerprints destination + {source = None; stats; fingerprint = crc}) + ~finally:(fun () -> Mutex.unlock session.staging_lock); + if retain then + Env.publish_compiled_cmi session.dependencies ~filename:destination ~crc + cmi) + +let publish_session_cmj session ~retain ~source ~destination = + let staged = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let staged = Hashtbl.find_opt session.staged_cmjs source in + Hashtbl.remove session.staged_cmjs source; + staged) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + Option.bind staged (validated_stage source) + |> Option.iter (fun (fingerprint, cmj) -> + let stats = Unix.stat destination in + let name = unit_name_of_artifact destination in + let pending_image = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + match Hashtbl.find_opt session.published_cmjs name with + | Some entry + when entry.source = Some source + && entry.fingerprint = fingerprint + && Compiler_request_state.same_output_path entry.filename + destination -> + Some entry.image + | Some _ | None -> None) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + let image = + if retain then + Some + (match pending_image with + | Some image -> image + | None -> Js_cmj_format.freeze cmj) + else None + in + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + Hashtbl.replace session.cmj_fingerprints destination + {source = None; stats; fingerprint}; + Option.iter + (fun image -> + Hashtbl.replace session.published_cmjs name + { + filename = + Compiler_request_state.canonical_output_path destination; + source = None; + stats; + fingerprint; + image; + }) + image) + ~finally:(fun () -> Mutex.unlock session.staging_lock)) + +type fingerprint_kind = Interface | Optimization + +let published_fingerprint session ~kind ~filename = + let entry = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let table = + match kind with + | Interface -> session.cmi_fingerprints + | Optimization -> session.cmj_fingerprints + in + Hashtbl.find_opt table filename) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + match entry with + | None -> None + | Some entry -> ( + try + let checked = Option.value entry.source ~default:filename in + if same_file_stats (Unix.stat checked) entry.stats then + Some entry.fingerprint + else None + with Sys_error _ | Unix.Unix_error _ -> None) + +let publish_session_ast session ~source = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let staged = Hashtbl.find_opt session.staged_asts source in + Hashtbl.remove session.staged_asts source; + Option.bind staged (fun entry -> + if not (valid_session_ast session ~path:source entry) then ( + persist_stale_ast_for_disk_fallback session ~path:source entry; + None) + else ( + if Hashtbl.length session.published_asts >= 2048 then + Hashtbl.clear session.published_asts; + Hashtbl.replace session.published_asts source entry; + Option.map + (fun contents -> (contents, entry.parsed_at)) + entry.contents))) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + +let record_session_ast_persistence session ~path = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + match Hashtbl.find_opt session.published_asts path with + | None -> () + | Some entry -> ( + try + if valid_session_ast session ~path entry then + Hashtbl.replace session.published_asts path + {entry with disk_stats = Some (Unix.stat path); contents = None} + with Sys_error _ | Unix.Unix_error _ -> ())) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + +let remove_semantic_source_aliases session destination = + Hashtbl.filter_map_inplace + (fun _ (published, stats) -> + if published = destination then None else Some (published, stats)) + session.published_semantic_sources + +let publish_session_semantic session ~retain ~source ~destination = + let staged = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let staged = Hashtbl.find_opt session.staged_semantics source in + remove_staged_semantic session source; + staged) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + if retain then + Option.bind staged (fun entry -> + validated_stage source {stats = entry.stats; value = entry.value} + |> Option.map (fun value -> (value, entry.stats))) + |> Option.iter (fun (value, source_stats) -> + let stats = Unix.stat destination in + if stats.Unix.st_size <= 4 * 1024 * 1024 then ( + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let previous = + Hashtbl.find_opt session.published_semantics destination + in + Option.iter + (fun (entry : published_semantic) -> + session.semantic_bytes <- + session.semantic_bytes - entry.stats.st_size) + previous; + remove_semantic_source_aliases session destination; + session.semantic_generation <- session.semantic_generation + 1; + Hashtbl.replace session.published_semantics destination + {stats; generation = session.semantic_generation; value}; + Hashtbl.replace session.published_semantic_sources source + (destination, source_stats); + session.semantic_bytes <- session.semantic_bytes + stats.st_size; + while + session.semantic_bytes > 16 * 1024 * 1024 + || Hashtbl.length session.published_semantics > 64 + do + let oldest = + Hashtbl.fold + (fun path (entry : published_semantic) oldest -> + match oldest with + | Some (_, generation) when generation <= entry.generation + -> + oldest + | _ -> Some (path, entry.generation)) + session.published_semantics None + in + match oldest with + | None -> assert false + | Some (path, _) -> + let entry = Hashtbl.find session.published_semantics path in + session.semantic_bytes <- + session.semantic_bytes - entry.stats.st_size; + Hashtbl.remove session.published_semantics path; + remove_semantic_source_aliases session path + done) + ~finally:(fun () -> Mutex.unlock session.staging_lock))) + +let semantic_result = lookup_session_semantic + +let stage_module_result session ~input ~interface_source ~interface_file + ~optimization_source ~optimization_file ~semantic_source ~dependencies + ~generated_outputs = + let interface_stats = Unix.stat interface_source in + let interface_image = + Env.published_compiled_cmi session.dependencies ~filename:interface_file + |> Option.map snd + in + let interface_fingerprint = + published_fingerprint session ~kind:Interface ~filename:interface_file + in + let optimization = + match (optimization_source, optimization_file) with + | Some source, Some filename -> ( + let stats = Unix.stat source in + match published_fingerprint session ~kind:Optimization ~filename with + | None -> None + | Some fingerprint -> + let name = unit_name_of_artifact filename in + let image = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + match Hashtbl.find_opt session.published_cmjs name with + | Some entry + when entry.fingerprint = fingerprint + && same_file_stats entry.stats stats -> + Some entry.image + | Some _ | None -> None) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + Some (filename, Some source, stats, fingerprint, image)) + | None, None | None, Some _ | Some _, None -> None + in + let semantic () = + Option.bind semantic_source (fun source -> + let staged = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> Hashtbl.find_opt session.staged_semantics source) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + Option.bind staged (fun staged -> + try + if same_file_stats (Unix.stat source) staged.stats then + Some + (Marshal.from_bytes (Marshal.to_bytes staged.value []) 0 + : Cmt_format.cmt_infos) + else None + with Sys_error _ | Unix.Unix_error _ -> None)) + in + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let diagnostics = + Hashtbl.find_opt session.staged_diagnostics input + |> Option.value ~default:[] + in + let captured_outputs = + Hashtbl.find_opt session.staged_generated_outputs input + |> Option.value ~default:[] + in + let result = + { + interface_file; + interface_source = Some interface_source; + interface_stats; + interface_fingerprint; + interface_image; + optimization; + semantic; + diagnostics; + dependencies; + generated_outputs = + List.sort_uniq String.compare (generated_outputs @ captured_outputs); + } + in + Hashtbl.replace session.published_results interface_file result) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + +let publish_module_result session ~input ~interface_file ~optimization_file + ~semantic_file ~dependencies ~generated_outputs = + let interface_stats = Unix.stat interface_file in + let interface_image = + Env.published_compiled_cmi session.dependencies ~filename:interface_file + |> Option.map snd + in + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let valid_fingerprint (table : (string, published_fingerprint) Hashtbl.t) + path stats = + match Hashtbl.find_opt table path with + | Some entry when same_file_stats entry.stats stats -> + Some entry.fingerprint + | _ -> None + in + let interface_fingerprint = + valid_fingerprint session.cmi_fingerprints interface_file + interface_stats + in + let optimization = + Option.bind optimization_file (fun path -> + try + let stats = Unix.stat path in + Option.map + (fun fingerprint -> + let name = unit_name_of_artifact path in + let image = + match Hashtbl.find_opt session.published_cmjs name with + | Some entry + when same_file_stats entry.stats stats + && entry.fingerprint = fingerprint -> + Some entry.image + | _ -> None + in + (path, None, stats, fingerprint, image)) + (valid_fingerprint session.cmj_fingerprints path stats) + with Sys_error _ | Unix.Unix_error _ -> None) + in + let semantic () = + Option.bind semantic_file (fun filename -> + semantic_result session ~filename) + in + let diagnostics = + Hashtbl.find_opt session.staged_diagnostics input + |> Option.value ~default:[] + in + Hashtbl.remove session.staged_diagnostics input; + let generated_outputs = + let captured = + Hashtbl.find_opt session.staged_generated_outputs input + |> Option.value ~default:[] + in + Hashtbl.remove session.staged_generated_outputs input; + List.sort_uniq String.compare (generated_outputs @ captured) + |> List.filter Sys.file_exists + in + let result = + { + interface_file; + interface_source = None; + interface_stats; + interface_fingerprint; + interface_image; + optimization; + semantic; + diagnostics; + dependencies; + generated_outputs; + } + in + Hashtbl.replace session.published_results interface_file result) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + +let result_interface_is_current (result : module_result) = + try + same_file_stats + (Unix.stat + (Option.value result.interface_source ~default:result.interface_file)) + result.interface_stats + with Sys_error _ | Unix.Unix_error _ -> false + +let module_result session ~interface_file = + let result = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> Hashtbl.find_opt session.published_results interface_file) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + match result with + | Some result when result_interface_is_current result -> Some result + | Some _ | None -> None + +let interface_fingerprint (result : module_result) = + result.interface_fingerprint +let optimization_fingerprint (result : module_result) = + Option.map (fun (_, _, _, fingerprint, _) -> fingerprint) result.optimization + +let interface_signature (result : module_result) = + if result_interface_is_current result then + Option.map + (fun image -> + Frozen_values.copy_signature (Frozen_values.create_view image)) + result.interface_image + else None + +let optimization_metadata (result : module_result) = + match result.optimization with + | None -> None + | Some (path, source, stats, _, image) -> ( + try + if same_file_stats (Unix.stat (Option.value source ~default:path)) stats + then Option.map Js_cmj_format.view image + else None + with Sys_error _ | Unix.Unix_error _ -> None) + +let typed_semantic (result : module_result) = result.semantic () + +let result_diagnostics (result : module_result) = result.diagnostics +let result_dependencies (result : module_result) = result.dependencies +let result_generated_outputs (result : module_result) = result.generated_outputs + let run argv = let result = run_argv ~cwd:(Sys.getcwd ()) argv in prerr_string result.stderr; diff --git a/compiler/bsc/rescript_compiler_driver.mli b/compiler/bsc/rescript_compiler_driver.mli index e84ef7f944c..f216b94e86f 100644 --- a/compiler/bsc/rescript_compiler_driver.mli +++ b/compiler/bsc/rescript_compiler_driver.mli @@ -1,4 +1,37 @@ -type result = {exit_code: int; stdout: string; stderr: string} +type result = { + exit_code: int; + stdout: string; + stderr: string; + diagnostics: Location.diagnostic list; +} +type session + +val create_session : unit -> session + +val set_session_handoff_enabled : session -> bool -> unit + +val session_handoff_enabled : session -> bool +(** Capture and publish request results independently from the dependency + lookup strategy. Changing the policy discards retained session artifacts. + [REWATCH_FROZEN_VALUES=0] disables both handoff and frozen lookup. *) + +val set_session_frozen_lookup_enabled : session -> bool -> unit +val set_session_owned_ast_enabled : session -> bool -> unit +val session_owned_ast_enabled : session -> bool +val set_session_owned_artifacts_enabled : session -> bool -> unit +val persist_owned_cmi : session -> path:string -> unit +val persist_owned_cmj : session -> path:string -> unit +val persist_owned_cmt : session -> path:string -> unit + +val session_frozen_lookup_enabled : session -> bool +(** GenType projects retain classic dependency lookup while their typed output + is checked for frozen-lookup equivalence. Changing this policy discards + retained session artifacts. *) + +val set_frozen_for_compile : session -> bool -> unit +(** Small incremental builds can skip frozen dependency lookup when only one + module is ready to compile. Set before launching worker jobs. Capturing + the compiled result remains enabled. *) val build_identity : string (** A digest of the compiler implementation linked into this driver. The @@ -13,14 +46,121 @@ val run_request : result (** Run one compiler request in the logical working directory. [argv] contains only options; [input] is kept separate so build-system callers cannot - accidentally construct a request without a compilation input. Requests are - serialized by the caller because the native compiler owns global mutable - state. Compiler and external-command stdout and stderr are captured in the - result, including for help, version, formatting, and reprinting requests. - Ordinary argument, parse, type, and compilation outcomes are returned as an - exit code and never terminate the host process. The request resolves file - I/O against [cwd] without changing the process working directory. Request - state is restored on success and failure. *) + accidentally construct a request without a compilation input. Each request + has fresh inference, environment, and diagnostic state. Compiler and + external-command stdout and stderr are captured in the result. Ordinary + argument, parse, type, and compilation outcomes are returned as an exit + code and never terminate the host process. File I/O resolves against [cwd] + without changing the process working directory. *) + +val run_request_in_session : + session -> + run_external:(string -> int * string * string) option -> + cwd:string -> + argv:string list -> + input:string -> + result +(** Run a module job with project-owned dependency information. Each job still + receives fresh inference and request state. Valid option sequences are + decoded by the same parser as standalone [bsc], cached in the session, + and copied into each request before source-level flags are applied. The + original logical [argv] remains in binary annotations. *) + +val publish_session_cmi : + session -> retain:bool -> source:string -> destination:string -> unit +(** Make a successful staged interface available to later jobs after artifact + publication. Both paths are absolute. [retain] skips freezing an unused + leaf interface; a later new dependent can still load the disk artifact. + An implementation with an explicit interface may have no new CMI; the + published interface remains in force. *) + +val stage_session_cmi : session -> source:string -> destination:string -> bool +(** Make a frozen CMI visible at its virtual destination before copying it. + [false] means the producer supplied no valid freezable staged CMI. *) + +val publish_session_cmj : + session -> retain:bool -> source:string -> destination:string -> unit +(** Publish cross-module optimization metadata after its artifact is copied. + Views handed to later requests own their mutable Lambda identifiers. *) + +val stage_session_cmj : session -> source:string -> destination:string -> bool +(** Make frozen optimization metadata visible before copying its artifact. *) + +val discard_pending_session_artifacts : + session -> interface_file:string -> optimization_file:string option -> unit +(** Withdraw virtual outputs when export is cancelled or fails. *) + +type fingerprint_kind = Interface | Optimization + +val published_fingerprint : + session -> kind:fingerprint_kind -> filename:string -> Digest.t option +(** Only returns a session fingerprint while the published artifact still has + the same file identity. *) + +val staged_ast_dependencies : session -> path:string -> string list option +(** The parser's dependency list before AST artifact publication. [path] is + the absolute staging path. *) + +val publish_session_ast : session -> source:string -> (string * float) option +(** Transfer a successful parse result to one later compiler request. + [source] is the absolute staging path. Return serialized contents when + persistence was deferred; the caller must publish them before completion. *) + +val record_session_ast_persistence : session -> path:string -> unit +(** Attach the staged file identity once its deferred write finishes. *) + +val publish_session_semantic : + session -> retain:bool -> source:string -> destination:string -> unit +(** Retain a published typed result for future editor analysis. Results above + 4 MiB are skipped; the session keeps at most 64 results or 16 MiB of + on-disk CMT size, evicting the oldest result first. *) + +val semantic_result : session -> filename:string -> Cmt_format.cmt_infos option +(** Return an independent typed graph for a retained CMT path. A changed + artifact or an evicted result returns [None], allowing disk fallback. *) + +type module_result + +val stage_module_result : + session -> + input:string -> + interface_source:string -> + interface_file:string -> + optimization_source:string option -> + optimization_file:string option -> + semantic_source:string option -> + dependencies:string list -> + generated_outputs:string list -> + unit +(** Publish one request's immutable result for dependent jobs before artifact + export. Its source identities remain validated until export completes. *) + +val publish_module_result : + session -> + input:string -> + interface_file:string -> + optimization_file:string option -> + semantic_file:string option -> + dependencies:string list -> + generated_outputs:string list -> + unit +(** Commit one complete module result after every output has been published. + Paths are absolute. Failed or cancelled requests never reach this step. *) + +val module_result : session -> interface_file:string -> module_result option +(** A published result is unavailable after its interface artifact changes. *) + +val interface_fingerprint : module_result -> Digest.t option +val optimization_fingerprint : module_result -> Digest.t option +val interface_signature : module_result -> Types.signature option +val optimization_metadata : module_result -> Js_cmj_format.t option +val typed_semantic : module_result -> Cmt_format.cmt_infos option +val result_diagnostics : module_result -> Location.diagnostic list +val result_dependencies : module_result -> string list + +val result_generated_outputs : module_result -> string list +(** Views of compiler graphs own their mutable nodes; metadata lists and + fingerprints are immutable. Unretained leaves can use disk fallback. *) val run : string array -> int (** Shared command-line entry point used by the standalone [bsc] wrapper. *) diff --git a/compiler/common/js_config.ml b/compiler/common/js_config.ml index f551fc6dc6a..9a6ca963d02 100644 --- a/compiler/common/js_config.ml +++ b/compiler/common/js_config.ml @@ -96,6 +96,42 @@ let create () = let key = Domain.DLS.new_key create let current () = Domain.DLS.get key +type snapshot = t + +let copy state = + { + no_version_header = ref !(state.no_version_header); + directives = ref !(state.directives); + cross_module_inline = ref !(state.cross_module_inline); + debug_ir = ref !(state.debug_ir); + check_lam = ref !(state.check_lam); + no_builtin_ppx = ref !(state.no_builtin_ppx); + check_div_by_zero = ref !(state.check_div_by_zero); + syntax_only = ref !(state.syntax_only); + binary_ast = ref !(state.binary_ast); + test_ast_conversion = ref !(state.test_ast_conversion); + debug = ref !(state.debug); + cmi_only = ref !(state.cmi_only); + cmj_only = ref !(state.cmj_only); + force_cmi = ref !(state.force_cmi); + force_cmj = ref !(state.force_cmj); + jsx_version = ref !(state.jsx_version); + jsx_module = ref !(state.jsx_module); + jsx_preserve = ref !(state.jsx_preserve); + js_stdout = ref !(state.js_stdout); + source_map = ref !(state.source_map); + source_map_sources_content = ref !(state.source_map_sources_content); + source_map_root = ref !(state.source_map_root); + all_module_aliases = ref !(state.all_module_aliases); + no_stdlib = ref !(state.no_stdlib); + no_export = ref !(state.no_export); + as_pp = ref !(state.as_pp); + self_stack = Stack.copy state.self_stack; + } + +let snapshot () = copy (current ()) +let install_copy snapshot = Domain.DLS.set key (copy snapshot) + let with_fresh action = let previous = current () in Domain.DLS.set key (create ()); diff --git a/compiler/common/js_config.mli b/compiler/common/js_config.mli index c6d4b68795d..441666bc276 100644 --- a/compiler/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -68,6 +68,13 @@ val current : unit -> t val with_fresh : (unit -> 'a) -> 'a (* Run with default settings and restore the previous request on exit. *) +type snapshot +val snapshot : unit -> snapshot + +val install_copy : snapshot -> unit +(** Clone parsed options into a request, including a private transformation + stack. Source-level flags may then update the clone. *) + val tool_name : string val int_of_jsx_version : jsx_version -> int diff --git a/compiler/core/bs_cmi_load.ml b/compiler/core/bs_cmi_load.ml index 4e1d5e56c8e..a0df4ee6b79 100644 --- a/compiler/core/bs_cmi_load.ml +++ b/compiler/core/bs_cmi_load.ml @@ -23,33 +23,36 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let load_cmi ~unit_name : Env.Persistent_signature.t option = - (* On case-insensitive filesystems a lowercase alias can remain visible to + Compiler_phase_trace.dependency ("dependency.search_open:" ^ unit_name) + (fun () -> + (* On case-insensitive filesystems a lowercase alias can remain visible to [Sys.file_exists] briefly after its CMI is removed. Open each candidate once and parse that descriptor, so a vanished CMI is a missing module. *) - let name = unit_name ^ ".cmi" in - let lower_name = String.uncapitalize_ascii name in - let rec find = function - | [] -> None - | directory :: rest -> - let rec try_names = function - | [] -> find rest - | name :: names -> ( - let filename = Filename.concat directory name in - let path = Compiler_request_state.resolve_path filename in - match Unix.openfile path [Unix.O_RDONLY] 0 with - | descriptor -> - let channel = Unix.in_channel_of_descr descriptor in - let cmi = - Fun.protect - (fun () -> Cmi_format.read_cmi_channel filename channel) - ~finally:(fun () -> close_in_noerr channel) - in - Some Env.Persistent_signature.{filename; cmi} - | exception Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> - try_names names - | exception Unix.Unix_error (error, _, _) -> - raise (Sys_error (path ^ ": " ^ Unix.error_message error))) + let name = unit_name ^ ".cmi" in + let lower_name = String.uncapitalize_ascii name in + let rec find = function + | [] -> None + | directory :: rest -> + let rec try_names = function + | [] -> find rest + | name :: names -> ( + let filename = Filename.concat directory name in + let path = Compiler_request_state.resolve_path filename in + match Unix.openfile path [Unix.O_RDONLY] 0 with + | descriptor -> + let channel = Unix.in_channel_of_descr descriptor in + let cmi = + Fun.protect + (fun () -> Cmi_format.read_cmi_channel filename channel) + ~finally:(fun () -> close_in_noerr channel) + in + Some Env.Persistent_signature.{filename; cmi} + | exception Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) + -> + try_names names + | exception Unix.Unix_error (error, _, _) -> + raise (Sys_error (path ^ ": " ^ Unix.error_message error))) + in + try_names (if lower_name = name then [name] else [lower_name; name]) in - try_names (if lower_name = name then [name] else [lower_name; name]) - in - find (Config.get_load_path ()) + find (Config.get_load_path ())) diff --git a/compiler/core/cmd_ppx_apply.ml b/compiler/core/cmd_ppx_apply.ml index 16104e823cb..79c4dcfe0b0 100644 --- a/compiler/core/cmd_ppx_apply.ml +++ b/compiler/core/cmd_ppx_apply.ml @@ -21,78 +21,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* Note: some of the functions here should go to Ast_mapper instead, - which would encapsulate the "binary AST" protocol. *) - -let write_ast fn (ast0 : Ml_binary.ast0) = - let oc = open_out_bin fn in - output_string oc (Ml_binary.magic_of_ast0 ast0); - output_value oc (Location.get_input_name () : string); - (match ast0 with - | Ml_binary.Impl ast -> output_value oc (ast : Parsetree0.structure) - | Ml_binary.Intf ast -> output_value oc (ast : Parsetree0.signature)); - close_out oc - -let temp_ppx_file () = - Filename.temp_file "ppx" (Filename.basename (Location.get_input_name ())) - -let apply_rewriter kind fn_in ppx = - let magic = Ml_binary.magic_of_kind kind in - let fn_out = temp_ppx_file () in - let comm = - Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out) - in - let ok = Ccomp.command comm = 0 in - if not ok then Cmd_ast_exception.cannot_run comm; - if not (Sys.file_exists fn_out) then Cmd_ast_exception.cannot_run comm; - (* check magic before passing to the next ppx *) - let ic = open_in_bin fn_out in - let buffer = - try really_input_string ic (String.length magic) with End_of_file -> "" - in - close_in ic; - if buffer <> magic then Cmd_ast_exception.wrong_magic buffer; - fn_out - -(* This is a fatal error, no need to protect it *) -let read_ast (type a) (kind : a Ml_binary.kind) fn : Ml_binary.ast0 = - let ic = open_in_bin fn in - let magic = Ml_binary.magic_of_kind kind in - let buffer = really_input_string ic (String.length magic) in - assert (buffer = magic); - (* already checked by apply_rewriter *) - Location.set_input_name @@ (input_value ic : string); - let ast0 = - match kind with - | Ml_binary.Ml -> Ml_binary.Impl (input_value ic : Parsetree0.structure) - | Ml_binary.Mli -> Ml_binary.Intf (input_value ic : Parsetree0.signature) - in - close_in ic; - ast0 - -(** [ppxs] are a stack, - [-ppx1 -ppx2 -ppx3] - are stored as [-ppx3; -ppx2; -ppx1] - [fold_right] happens to process the first one *) -let rewrite kind ppxs ast = - let fn_in = temp_ppx_file () in - let ast0 = Ml_binary.to_ast0 kind ast in - write_ast fn_in ast0; - let temp_files = - List.fold_right - (fun ppx fns -> - match fns with - | [] -> assert false - | fn_in :: _ -> apply_rewriter kind fn_in ppx :: fns) - ppxs [fn_in] - in - match temp_files with - | last_fn :: _ -> - let out = read_ast kind last_fn in - Ext_list.iter temp_files Misc.remove_file; - out - | _ -> assert false - let apply_rewriters_str ?(restore = true) ~tool_name ast = match !((Clflags.current ()).all_ppx) with | [] -> @@ -102,7 +30,7 @@ let apply_rewriters_str ?(restore = true) ~tool_name ast = | ppxs -> ast |> Ast_mapper.add_ppx_context_str ~tool_name - |> rewrite Ml ppxs |> Ml_binary.ast0_to_structure + |> Legacy_ppx_adapter.rewrite Ml ppxs |> Ast_mapper.drop_ppx_context_str ~restore let apply_rewriters_sig ?(restore = true) ~tool_name ast = @@ -114,7 +42,7 @@ let apply_rewriters_sig ?(restore = true) ~tool_name ast = | ppxs -> ast |> Ast_mapper.add_ppx_context_sig ~tool_name - |> rewrite Mli ppxs |> Ml_binary.ast0_to_signature + |> Legacy_ppx_adapter.rewrite Mli ppxs |> Ast_mapper.drop_ppx_context_sig ~restore let apply_rewriters ?restore ~tool_name (type a) (kind : a Ml_binary.kind) diff --git a/compiler/core/js_cmj_format.ml b/compiler/core/js_cmj_format.ml index 088f9e1436b..c00d5b8e819 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -63,6 +63,84 @@ type t = { case: Ext_js_file_kind.case; } +type frozen_arity = + | Frozen_single of Lam_arity.t + | Frozen_submodule of Lam_arity.t list + +type frozen_value = { + frozen_name: string; + frozen_arity: frozen_arity; + frozen_lambda: bytes option; +} + +type frozen = { + frozen_values: frozen_value array; + frozen_hoisted_exports: hoisted_export list; + frozen_pure: bool; + frozen_package_spec: Js_packages_info.t; + frozen_case: Ext_js_file_kind.case; +} + +let freeze (table : t) = + { + frozen_values = + Array.map + (fun value -> + { + frozen_name = value.name; + frozen_arity = + (match value.arity with + | Single arity -> Frozen_single arity + | Submodule arities -> Frozen_submodule (Array.to_list arities)); + frozen_lambda = + Option.map + (fun lambda -> Marshal.to_bytes lambda []) + value.persistent_closed_lambda; + }) + table.values; + frozen_hoisted_exports = Array.to_list table.hoisted_exports; + frozen_pure = table.pure; + frozen_package_spec = table.package_spec; + frozen_case = table.case; + } + +let view (image : frozen) : t = + { + values = + Array.map + (fun value -> + { + name = value.frozen_name; + arity = + (match value.frozen_arity with + | Frozen_single arity -> Single arity + | Frozen_submodule arities -> Submodule (Array.of_list arities)); + persistent_closed_lambda = + Option.map + (fun bytes -> (Marshal.from_bytes bytes 0 : Lambda.t)) + value.frozen_lambda; + }) + image.frozen_values; + hoisted_exports = Array.of_list image.frozen_hoisted_exports; + pure = image.frozen_pure; + package_spec = image.frozen_package_spec; + case = image.frozen_case; + } + +let capture_key = Domain.DLS.new_key (fun () -> None) +let output_capture_key = Domain.DLS.new_key (fun () -> None) + +let with_capture capture action = + let previous = Domain.DLS.get capture_key in + Domain.DLS.set capture_key (Some capture); + Fun.protect action ~finally:(fun () -> Domain.DLS.set capture_key previous) + +let with_output_capture capture action = + let previous = Domain.DLS.get output_capture_key in + Domain.DLS.set output_capture_key (Some capture); + Fun.protect action ~finally:(fun () -> + Domain.DLS.set output_capture_key previous) + let make ~(values : cmj_value Map_string.t) ~hoisted_exports ~effect_ ~package_spec ~case : t = { @@ -81,11 +159,13 @@ let make ~(values : cmj_value Map_string.t) ~hoisted_exports ~effect_ (* Serialization .. *) let from_file name : t = - let ic = open_in_bin (Compiler_request_state.resolve_path name) in - let _digest = Digest.input ic in - let v : t = input_value ic in - close_in ic; - v + Compiler_phase_trace.dependency "dependency.cmj_read_decode" (fun () -> + let ic = open_in_bin (Compiler_request_state.resolve_path name) in + Fun.protect + (fun () -> + let _digest = Digest.input ic in + (input_value ic : t)) + ~finally:(fun () -> close_in_noerr ic)) let from_string s : t = Marshal.from_string s Ext_digest.length @@ -104,11 +184,20 @@ let to_file name ~check_exists (v : t) = let s = Marshal.to_string v [] in let cur_digest = Digest.string s in let header = cur_digest in - if not (check_exists && for_sure_not_changed name header) then ( - let oc = open_out_bin (Compiler_request_state.resolve_path name) in - output_string oc header; - output_string oc s; - close_out oc) + (if not (check_exists && for_sure_not_changed name header) then + let deferred = + match Domain.DLS.get output_capture_key with + | None -> false + | Some capture -> capture name cur_digest v (header ^ s) + in + if not deferred then ( + let oc = open_out_bin (Compiler_request_state.resolve_path name) in + output_string oc header; + output_string oc s; + close_out oc)); + Option.iter + (fun capture -> capture name cur_digest v) + (Domain.DLS.get capture_key) let key_comp a b = Map_string.compare_key a b.name diff --git a/compiler/core/js_cmj_format.mli b/compiler/core/js_cmj_format.mli index a6a9cf29b77..80f940c5e4f 100644 --- a/compiler/core/js_cmj_format.mli +++ b/compiler/core/js_cmj_format.mli @@ -79,6 +79,21 @@ type t = { case: Ext_js_file_kind.case; } +type frozen + +val freeze : t -> frozen + +val view : frozen -> t +(** [view] creates request-owned arrays and Lambda identifiers. The frozen + image shares only immutable metadata across compiler domains. *) + +val with_capture : (string -> Digest.t -> t -> unit) -> (unit -> 'a) -> 'a + +val with_output_capture : + (string -> Digest.t -> t -> string -> bool) -> (unit -> 'a) -> 'a +(** Capture the encoded optimization artifact before writing it. Return + [true] to let the caller persist the bytes. *) + val make : values:cmj_value Map_string.t -> hoisted_exports:hoisted_export list -> diff --git a/compiler/core/js_cmj_load.ml b/compiler/core/js_cmj_load.ml index 97ef4443492..e5b196732bd 100644 --- a/compiler/core/js_cmj_load.ml +++ b/compiler/core/js_cmj_load.ml @@ -27,15 +27,58 @@ make sure that the distributed files are platform independent *) +let session_lookup_key = Domain.DLS.new_key (fun () -> None) + +let with_session_lookup lookup action = + let previous = Domain.DLS.get session_lookup_key in + Domain.DLS.set session_lookup_key (Some lookup); + Fun.protect action ~finally:(fun () -> + Domain.DLS.set session_lookup_key previous) + let load_unit_with_file unit_name : Js_cmj_format.cmj_load_info = let file = unit_name ^ Literals.suffix_cmj in - match Config_util.find_opt file with - | Some f -> + let selected = + match Domain.DLS.get session_lookup_key with + | None -> + Option.map (fun filename -> (filename, None)) (Config_util.find_opt file) + | Some lookup -> + let lower_file = Ext_string.uncapitalize_ascii file in + let rec find = function + | [] -> None + | directory :: rest -> ( + let lower = Filename.concat directory lower_file in + let exact = Filename.concat directory file in + match lookup unit_name lower with + | Some table -> Some (lower, Some table) + | None -> ( + match lookup unit_name exact with + | Some table -> + if + Compiler_request_state.is_regular_file lower + && Compiler_request_state.has_exact_directory_entry lower + then Some (lower, None) + else Some (exact, Some table) + | None -> + if Compiler_request_state.is_regular_file lower then + Some (lower, None) + else if Compiler_request_state.is_regular_file exact then + Some (exact, None) + else find rest)) + in + find (Config.get_load_path ()) + in + match selected with + | Some (f, session_table) -> { package_path = (* hacking relying on the convention of pkg/lib/ocaml/xx.cmj*) Filename.dirname (Filename.dirname (Filename.dirname f)); - cmj_table = Js_cmj_format.from_file f; + cmj_table = + (match session_table with + | Some table -> + Compiler_phase_trace.dependency "dependency.session_cmj_lookup" + (fun () -> table) + | None -> Js_cmj_format.from_file f); } | None -> Bs_exception.error (Cmj_not_found unit_name) diff --git a/compiler/core/js_cmj_load.mli b/compiler/core/js_cmj_load.mli index 08da39f4e7c..121dfb37b2c 100644 --- a/compiler/core/js_cmj_load.mli +++ b/compiler/core/js_cmj_load.mli @@ -27,3 +27,9 @@ *) val load_unit : (string -> Js_cmj_format.cmj_load_info) ref + +val with_session_lookup : + (string -> string -> Js_cmj_format.t option) -> (unit -> 'a) -> 'a +(** Resolve a previously published CMJ by compiler unit name and the path + selected from the current request's load path. Falls back to disk when no + matching session result exists. *) diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index 3eaab34b996..af0185b0bce 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -31,8 +31,12 @@ let print_if_pipe ppf flag printer arg = let print_if ppf flag printer arg = if !flag then fprintf ppf "%a@." printer arg let process_with_gentype cmt_file = - if !((Clflags.current ()).bs_gentype) then - Gentype_main.process_cmt_file cmt_file + if !((Clflags.current ()).bs_gentype) then ( + let compiled_cmt = Cmt_format.last_saved_cmt () in + Gentype_main.process_cmt_file ?compiled_cmt cmt_file; + match compiled_cmt with + | Some cmt -> Gentype_summary.save ~cmt_file cmt + | None -> Gentype_summary.remove ~cmt_file) let after_parsing_sig ppf outputprefix ast = if !((Clflags.current ()).only_parse) = false then ( @@ -54,13 +58,17 @@ let after_parsing_sig ppf outputprefix ast = Lam_compile_env.reset (); let initial_env = Res_compmisc.initial_env ~modulename () in Env.set_unit_name modulename; - let tsg = Typemod.transl_signature initial_env ast in + let tsg = + Compiler_phase_trace.section "source.check" (fun () -> + Typemod.transl_signature initial_env ast) + in if !((Clflags.current ()).dump_typedtree) then fprintf ppf "%a@." Printtyped.interface tsg; let sg = tsg.sig_type in - ignore (Includemod.signatures initial_env sg sg); - Delayed_checks.force_delayed_checks (); - Warnings.check_fatal (); + Compiler_phase_trace.section "source.check" (fun () -> + ignore (Includemod.signatures initial_env sg sg); + Delayed_checks.force_delayed_checks (); + Warnings.check_fatal ()); let deprecated = Builtin_attributes.deprecated_of_sig ast in let sg = Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi") @@ -76,7 +84,7 @@ let interface ~parser ppf ?outputprefix fname = | None -> Config_util.output_prefix fname | Some x -> x in - Res_compmisc.init_path (); + Compiler_phase_trace.section "setup.path" Res_compmisc.init_path; parser fname |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Mli @@ -86,7 +94,7 @@ let interface ~parser ppf ?outputprefix fname = |> after_parsing_sig ppf outputprefix let interface_mliast ppf fname = - Res_compmisc.init_path (); + Compiler_phase_trace.section "setup.path" Res_compmisc.init_path; Binary_ast.read_ast_exn ~fname Mli |> print_if_pipe ppf (Clflags.current ()).dump_parsetree Printast.interface |> print_if_pipe ppf (Clflags.current ()).dump_source Pprintast.signature @@ -170,7 +178,7 @@ let implementation ~parser ppf ?outputprefix fname = | None -> Config_util.output_prefix fname | Some x -> x in - Res_compmisc.init_path (); + Compiler_phase_trace.section "setup.path" Res_compmisc.init_path; parser fname |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Ml @@ -181,7 +189,7 @@ let implementation ~parser ppf ?outputprefix fname = |> after_parsing_impl ppf outputprefix let implementation_mlast ppf fname = - Res_compmisc.init_path (); + Compiler_phase_trace.section "setup.path" Res_compmisc.init_path; Binary_ast.read_ast_exn ~fname Ml |> print_if_pipe ppf (Clflags.current ()).dump_parsetree Printast.implementation diff --git a/compiler/core/js_packages_state.ml b/compiler/core/js_packages_state.ml index 263b889cb0b..f74b8566287 100644 --- a/compiler/core/js_packages_state.ml +++ b/compiler/core/js_packages_state.ml @@ -34,6 +34,17 @@ let fresh () = {packages_info = Js_packages_info.empty; making_runtime = false} let key = Domain.DLS.new_key fresh let current () = Domain.DLS.get key +type snapshot = Js_packages_info.t * bool + +let snapshot () = + let state = current () in + (state.packages_info, state.making_runtime) + +let install_copy (packages_info, making_runtime) = + let state = current () in + state.packages_info <- packages_info; + state.making_runtime <- making_runtime + let with_fresh action = let previous = current () in Domain.DLS.set key (fresh ()); diff --git a/compiler/core/js_packages_state.mli b/compiler/core/js_packages_state.mli index 8bf9230d304..e4081ad3891 100644 --- a/compiler/core/js_packages_state.mli +++ b/compiler/core/js_packages_state.mli @@ -37,3 +37,10 @@ val reset : unit -> unit val with_fresh : (unit -> 'a) -> 'a (** Use fresh package/output configuration for one compiler request on this domain, restoring the previous configuration even when it fails. *) + +type snapshot +val snapshot : unit -> snapshot + +val install_copy : snapshot -> unit +(** Package/output specifications are immutable; request-owned mutable state + still receives a separate record. *) diff --git a/compiler/core/legacy_ppx_adapter.ml b/compiler/core/legacy_ppx_adapter.ml new file mode 100644 index 00000000000..ad37b787bdd --- /dev/null +++ b/compiler/core/legacy_ppx_adapter.ml @@ -0,0 +1,122 @@ +(* Copyright (C) 2015 - Hongbo Zhang, Authors of ReScript + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +let temp_ppx_file () = + Filename.temp_file "ppx" (Filename.basename (Location.get_input_name ())) + +let write_ast fn (ast0 : Ml_binary.ast0) = + let source = + Compiler_phase_trace.section "ppx.serialize" (fun () -> + Marshal.to_string (Location.get_input_name () : string) []) + in + let ast = + Compiler_phase_trace.section "ppx.serialize" (fun () -> + match ast0 with + | Ml_binary.Impl tree -> + Marshal.to_string (tree : Parsetree0.structure) [] + | Ml_binary.Intf tree -> + Marshal.to_string (tree : Parsetree0.signature) []) + in + Compiler_phase_trace.section "ppx.write" (fun () -> + let channel = open_out_bin fn in + try + output_string channel (Ml_binary.magic_of_ast0 ast0); + output_string channel source; + output_string channel ast; + close_out channel + with error -> + close_out_noerr channel; + raise error) + +let apply_rewriter kind fn_in ppx = + let magic = Ml_binary.magic_of_kind kind in + let fn_out = temp_ppx_file () in + let command = + Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out) + in + let ok = + Compiler_phase_trace.section "ppx.execute" (fun () -> + Ccomp.command command = 0) + in + if not ok then Cmd_ast_exception.cannot_run command; + if not (Sys.file_exists fn_out) then Cmd_ast_exception.cannot_run command; + let buffer = + Compiler_phase_trace.section "ppx.read" (fun () -> + let channel = open_in_bin fn_out in + Fun.protect + (fun () -> + try really_input_string channel (String.length magic) + with End_of_file -> "") + ~finally:(fun () -> close_in_noerr channel)) + in + if buffer <> magic then Cmd_ast_exception.wrong_magic buffer; + fn_out + +let read_ast (type a) (kind : a Ml_binary.kind) fn : Ml_binary.ast0 = + let magic = Ml_binary.magic_of_kind kind in + let source, encoded_ast = + Compiler_phase_trace.section "ppx.read" (fun () -> + let channel = open_in_bin fn in + Fun.protect + (fun () -> + let buffer = really_input_string channel (String.length magic) in + assert (buffer = magic); + let source = (input_value channel : string) in + let bytes = in_channel_length channel - pos_in channel in + (source, really_input_string channel bytes)) + ~finally:(fun () -> close_in_noerr channel)) + in + Location.set_input_name source; + Compiler_phase_trace.section "ppx.deserialize" (fun () -> + match kind with + | Ml_binary.Ml -> + Ml_binary.Impl + (Marshal.from_string encoded_ast 0 : Parsetree0.structure) + | Ml_binary.Mli -> + Ml_binary.Intf + (Marshal.from_string encoded_ast 0 : Parsetree0.signature)) + +(* [-ppx1 -ppx2 -ppx3] is stored in reverse order. *) +let rewrite (type a) (kind : a Ml_binary.kind) ppxs (ast : a) : a = + let fn_in = temp_ppx_file () in + let ast0 = + Compiler_phase_trace.section "ppx.convert.to0" (fun () -> + Ml_binary.to_ast0 kind ast) + in + write_ast fn_in ast0; + let temp_files = + List.fold_right + (fun ppx fns -> + match fns with + | [] -> assert false + | fn_in :: _ -> apply_rewriter kind fn_in ppx :: fns) + ppxs [fn_in] + in + match temp_files with + | last_fn :: _ -> + let output = read_ast kind last_fn in + Ext_list.iter temp_files Misc.remove_file; + Compiler_phase_trace.section "ppx.convert.from0" (fun () : a -> + match kind with + | Ml_binary.Ml -> Ml_binary.ast0_to_structure output + | Ml_binary.Mli -> Ml_binary.ast0_to_signature output) + | [] -> assert false diff --git a/compiler/core/legacy_ppx_adapter.mli b/compiler/core/legacy_ppx_adapter.mli new file mode 100644 index 00000000000..aefbecf6fd5 --- /dev/null +++ b/compiler/core/legacy_ppx_adapter.mli @@ -0,0 +1,4 @@ +(** The frozen AST 0 file protocol used by external PPXs. The caller decides + whether a PPX is present; this module never runs for ordinary requests. *) + +val rewrite : 'a Ml_binary.kind -> string list -> 'a -> 'a diff --git a/compiler/core/res_compmisc.ml b/compiler/core/res_compmisc.ml index 7f117a2ad26..9da31a2eff0 100644 --- a/compiler/core/res_compmisc.ml +++ b/compiler/core/res_compmisc.ml @@ -46,22 +46,23 @@ let open_implicit_module m env = snd (Typemod.type_open_ Override env lid.loc lid) let initial_env ?modulename () = - Ident.reinit (); - let open_modules = - match modulename with - | None -> !((Clflags.current ()).open_modules) - | Some modulename -> - !((Clflags.current ()).open_modules) - |> List.filter (fun m -> m <> modulename) - in - let initial = Env.initial_safe_string () in - let env = - if !((Clflags.current ()).nopervasives) then initial - else - initial - |> open_implicit_module "Pervasives" - |> open_implicit_module "Stdlib" - in - List.fold_left - (fun env m -> open_implicit_module m env) - env (List.rev open_modules) + Compiler_phase_trace.section "setup.initial_env" (fun () -> + Ident.reinit (); + let open_modules = + match modulename with + | None -> !((Clflags.current ()).open_modules) + | Some modulename -> + !((Clflags.current ()).open_modules) + |> List.filter (fun m -> m <> modulename) + in + let initial = Env.initial_safe_string () in + let env = + if !((Clflags.current ()).nopervasives) then initial + else + initial + |> open_implicit_module "Pervasives" + |> open_implicit_module "Stdlib" + in + List.fold_left + (fun env m -> open_implicit_module m env) + env (List.rev open_modules)) diff --git a/compiler/depends/binary_ast.ml b/compiler/depends/binary_ast.ml index fd46501a031..2f613bb3ec4 100644 --- a/compiler/depends/binary_ast.ml +++ b/compiler/depends/binary_ast.ml @@ -29,18 +29,91 @@ type 'a kind = 'a Ml_binary.kind = | Ml : Parsetree.structure kind | Mli : Parsetree.signature kind -let read_ast_exn (type t) ~fname (_ : t kind) : t = - let ic = open_in_bin (Compiler_request_state.resolve_path fname) in - let dep_size = input_binary_int ic in - seek_in ic (pos_in ic + dep_size); - let sourcefile = input_line ic in - Location.set_input_name sourcefile; - let ast = input_value ic in - close_in ic; - ast +type result = + | Implementation of { + sourcefile: string; + dependencies: string list; + ast: Parsetree.structure; + } + | Interface of { + sourcefile: string; + dependencies: string list; + ast: Parsetree.signature; + } + +let dependencies = function + | Implementation {dependencies; _} | Interface {dependencies; _} -> + dependencies + +let capture_key = Domain.DLS.new_key (fun () -> None) +let lookup_key = Domain.DLS.new_key (fun () -> None) + +let with_capture capture action = + let previous = Domain.DLS.get capture_key in + Domain.DLS.set capture_key (Some capture); + Fun.protect action ~finally:(fun () -> Domain.DLS.set capture_key previous) + +let with_lookup lookup action = + let previous = Domain.DLS.get lookup_key in + Domain.DLS.set lookup_key (Some lookup); + Fun.protect action ~finally:(fun () -> Domain.DLS.set lookup_key previous) + +let read_ast_exn (type t) ~fname (kind : t kind) : t = + let staged = + match Domain.DLS.get lookup_key with + | None -> None + | Some lookup -> lookup fname + in + match (kind, staged) with + | Ml, Some (Implementation {sourcefile; ast; _}) -> + Compiler_phase_trace.dependency "dependency.session_ast_lookup" (fun () -> + Location.set_input_name sourcefile; + ast) + | Mli, Some (Interface {sourcefile; ast; _}) -> + Compiler_phase_trace.dependency "dependency.session_ast_lookup" (fun () -> + Location.set_input_name sourcefile; + ast) + | _, _ -> + Compiler_phase_trace.dependency "dependency.ast_read_decode" (fun () -> + let ic = open_in_bin (Compiler_request_state.resolve_path fname) in + Fun.protect + (fun () -> + let dep_size = input_binary_int ic in + seek_in ic (pos_in ic + dep_size); + let sourcefile = input_line ic in + Location.set_input_name sourcefile; + input_value ic) + ~finally:(fun () -> close_in_noerr ic)) let magic_sep_char = '\n' +let serialize_result result = + let sourcefile, dependencies, ast = + match result with + | Implementation {sourcefile; dependencies; ast} -> + (sourcefile, dependencies, Marshal.to_string ast []) + | Interface {sourcefile; dependencies; ast} -> + (sourcefile, dependencies, Marshal.to_string ast []) + in + let dependency_buffer = Buffer.create 1000 in + Buffer.add_char dependency_buffer magic_sep_char; + List.iter + (fun dependency -> + Buffer.add_string dependency_buffer dependency; + Buffer.add_char dependency_buffer magic_sep_char) + dependencies; + let dependency_size = Buffer.length dependency_buffer in + let output = Buffer.create (dependency_size + String.length ast + 128) in + for shift = 3 downto 0 do + Buffer.add_char output + (Char.chr ((dependency_size lsr (shift * 8)) land 255)) + done; + Buffer.add_buffer output dependency_buffer; + Buffer.add_string output sourcefile; + Buffer.add_char output '\n'; + Buffer.add_string output ast; + Buffer.contents output + (* Reasons that we don't [output_value] the set: 1. for performance , easy skipping and calcuate the length @@ -49,18 +122,33 @@ let magic_sep_char = '\n' let write_ast (type t) ~(sourcefile : string) ~output (kind : t kind) (pt : t) : unit = let output_set = Ast_extract.read_parse_and_extract kind pt in - let buf = Ext_buffer.create 1000 in - Ext_buffer.add_char buf magic_sep_char; - Set_string.iter - (fun s -> - if s <> "" && s.[0] <> '*' then - (* filter *predef* *) - Ext_buffer.add_string_char buf s magic_sep_char) - output_set; - let oc = open_out_bin (Compiler_request_state.resolve_path output) in - output_binary_int oc (Ext_buffer.length buf); - Ext_buffer.output_buffer oc buf; - output_string oc sourcefile; - output_char oc '\n'; - output_value oc pt; - close_out oc + let dependencies = + Set_string.elements output_set + |> List.filter (fun s -> s <> "" && s.[0] <> '*') + in + let result = + match kind with + | Ml -> Implementation {sourcefile; dependencies; ast = pt} + | Mli -> Interface {sourcefile; dependencies; ast = pt} + in + let deferred = + match Domain.DLS.get capture_key with + | None -> false + | Some capture -> capture output result + in + if deferred then + try Unix.unlink (Compiler_request_state.resolve_path output) + with Unix.Unix_error (Unix.ENOENT, _, _) -> () + else + let buf = Ext_buffer.create 1000 in + Ext_buffer.add_char buf magic_sep_char; + List.iter + (fun s -> Ext_buffer.add_string_char buf s magic_sep_char) + dependencies; + let oc = open_out_bin (Compiler_request_state.resolve_path output) in + output_binary_int oc (Ext_buffer.length buf); + Ext_buffer.output_buffer oc buf; + output_string oc sourcefile; + output_char oc '\n'; + output_value oc pt; + close_out oc diff --git a/compiler/depends/binary_ast.mli b/compiler/depends/binary_ast.mli index 97c98cb12bf..1ddd2139c20 100644 --- a/compiler/depends/binary_ast.mli +++ b/compiler/depends/binary_ast.mli @@ -24,6 +24,31 @@ type _ kind = Ml : Parsetree.structure kind | Mli : Parsetree.signature kind +type result = + | Implementation of { + sourcefile: string; + dependencies: string list; + ast: Parsetree.structure; + } + | Interface of { + sourcefile: string; + dependencies: string list; + ast: Parsetree.signature; + } + +val dependencies : result -> string list + +val with_capture : (string -> result -> bool) -> (unit -> 'a) -> 'a +(** The callback runs before the AST is written. Return [true] to retain the + result and defer persistence to the caller. *) + +val serialize_result : result -> string +(** Encode a captured result with the same bytes as the persistent AST. *) + +val with_lookup : (string -> result option) -> (unit -> 'a) -> 'a +(** Captured results are request-owned until publication. A lookup transfers + the mutable parsetree to one consuming compiler request. *) + val read_ast_exn : fname:string -> 'a kind -> 'a val magic_sep_char : char diff --git a/compiler/ext/compiler_phase_trace.ml b/compiler/ext/compiler_phase_trace.ml new file mode 100644 index 00000000000..54aabad268d --- /dev/null +++ b/compiler/ext/compiler_phase_trace.ml @@ -0,0 +1,121 @@ +(* Diagnostic request timings. Sections account for their own time only: a + nested section pauses its parent. Disabled unless an output path is set. *) +type bucket = {mutable seconds: float; mutable bytes: float; mutable calls: int} + +type state = { + path: string; + cwd: string; + input: string; + buckets: (string, bucket) Hashtbl.t; + mutable phase: string; + mutable clock: float; + mutable allocation: float; + started: float; + started_allocation: float; + gc: Gc.stat; +} + +let state_key = Domain.DLS.new_key (fun () -> None) +let output_lock = Mutex.create () + +let charge state now allocation = + let bucket = Hashtbl.find state.buckets state.phase in + bucket.seconds <- bucket.seconds +. (now -. state.clock); + bucket.bytes <- bucket.bytes +. (allocation -. state.allocation); + state.clock <- now; + state.allocation <- allocation + +let section name action = + match Domain.DLS.get state_key with + | None -> action () + | Some state -> + let now = Unix.gettimeofday () in + let allocation = Gc.allocated_bytes () in + charge state now allocation; + let previous = state.phase in + state.phase <- name; + let bucket = + match Hashtbl.find_opt state.buckets name with + | Some bucket -> bucket + | None -> + let bucket = {seconds = 0.; bytes = 0.; calls = 0} in + Hashtbl.add state.buckets name bucket; + bucket + in + bucket.calls <- bucket.calls + 1; + Fun.protect action ~finally:(fun () -> + charge state (Unix.gettimeofday ()) (Gc.allocated_bytes ()); + state.phase <- previous) + +let dependency name action = + match Domain.DLS.get state_key with + | Some {phase; _} when String.starts_with ~prefix:"artifact." phase -> + action () + | _ -> section name action + +let dependency_lazy name action = + match Domain.DLS.get state_key with + | None -> action () + | Some _ -> dependency (name ()) action + +let open_signature action = + match Domain.DLS.get state_key with + | Some {phase = "setup.initial_env"; _} -> section "setup.open" action + | _ -> section "source.open" action + +let request ~cwd ~input action = + match Sys.getenv_opt "REWATCH_TYPECHECK_TRACE" with + | None | Some "" -> action () + | Some path -> + let started = Unix.gettimeofday () in + let started_allocation = Gc.allocated_bytes () in + let buckets = Hashtbl.create 23 in + Hashtbl.add buckets "request.setup" {seconds = 0.; bytes = 0.; calls = 1}; + let state = + { + path; + cwd; + input; + buckets; + phase = "request.setup"; + clock = started; + allocation = started_allocation; + started; + started_allocation; + gc = Gc.quick_stat (); + } + in + let previous = Domain.DLS.get state_key in + Domain.DLS.set state_key (Some state); + Fun.protect action ~finally:(fun () -> + let finished = Unix.gettimeofday () in + let final_allocation = Gc.allocated_bytes () in + charge state finished final_allocation; + Domain.DLS.set state_key previous; + let gc = Gc.quick_stat () in + Mutex.lock output_lock; + Fun.protect + (fun () -> + let channel = + open_out_gen [Open_creat; Open_append; Open_text] 0o644 path + in + Fun.protect + (fun () -> + let emit phase bucket = + Printf.fprintf channel + "%s\t%s\t%s\t%.6f\t%.0f\t%d\t%.6f\t%.0f\t%d\t%d\t%d\t%d\n" + state.cwd state.input phase bucket.seconds bucket.bytes + bucket.calls + (finished -. state.started) + (final_allocation -. state.started_allocation) + (gc.minor_collections - state.gc.minor_collections) + (gc.major_collections - state.gc.major_collections) + (gc.compactions - state.gc.compactions) + gc.top_heap_words + in + Hashtbl.to_seq state.buckets + |> List.of_seq + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + |> List.iter (fun (phase, bucket) -> emit phase bucket)) + ~finally:(fun () -> close_out_noerr channel)) + ~finally:(fun () -> Mutex.unlock output_lock)) diff --git a/compiler/ext/compiler_request_output.ml b/compiler/ext/compiler_request_output.ml index 427161961eb..f583a219934 100644 --- a/compiler/ext/compiler_request_output.ml +++ b/compiler/ext/compiler_request_output.ml @@ -1,6 +1,8 @@ +type target = {buffer: Buffer.t; mutable file: (string * out_channel) option} + type streams = { - stdout: out_channel; - stderr: out_channel; + stdout: target; + stderr: target; stdout_formatter: Format.formatter; stderr_formatter: Format.formatter; } @@ -9,14 +11,52 @@ let key = Domain.DLS.new_key (fun () -> None) let current () = Domain.DLS.get key let is_active () = Option.is_some (current ()) +let create_target () = {buffer = Buffer.create 128; file = None} + +let write_substring target text offset length = + match target.file with + | None -> Buffer.add_substring target.buffer text offset length + | Some (_, channel) -> output_substring channel text offset length + +let write target text = write_substring target text 0 (String.length text) + +let flush target = + match target.file with + | None -> () + | Some (_, channel) -> flush channel + +let make_formatter target = + Format.make_formatter (write_substring target) (fun () -> flush target) + +(* Most requests only emit text through the formatter. An out_channel is + needed for binary AST output and the few channel-based printers, so create + its temporary file only when a caller asks for one. *) +let channel target formatter = + Format.pp_print_flush formatter (); + match target.file with + | Some (_, channel) -> channel + | None -> + let path, channel = + Filename.open_temp_file ~mode:[Open_binary] "rescript-compiler-output-" + ".log" + in + (try output_string channel (Buffer.contents target.buffer) + with exn -> + close_out_noerr channel; + Sys.remove path; + raise exn); + Buffer.clear target.buffer; + target.file <- Some (path, channel); + channel + let stdout_channel () = match current () with - | Some streams -> streams.stdout + | Some streams -> channel streams.stdout streams.stdout_formatter | None -> Stdlib.stdout let stderr_channel () = match current () with - | Some streams -> streams.stderr + | Some streams -> channel streams.stderr streams.stderr_formatter | None -> Stdlib.stderr let stdout_formatter () = @@ -29,58 +69,67 @@ let stderr_formatter () = | Some streams -> streams.stderr_formatter | None -> Format.err_formatter -let write_stdout text = output_string (stdout_channel ()) text -let write_stderr text = output_string (stderr_channel ()) text -let print_stdout text = write_stdout (text ^ "\n") -let print_stderr text = write_stderr (text ^ "\n") +let write_stdout text = + match current () with + | Some streams -> write streams.stdout text + | None -> output_string Stdlib.stdout text + +let write_stderr text = + match current () with + | Some streams -> write streams.stderr text + | None -> output_string Stdlib.stderr text + +let print_stdout text = + write_stdout text; + write_stdout "\n" + +let print_stderr text = + write_stderr text; + write_stderr "\n" + +let cleanup target = + match target.file with + | None -> () + | Some (path, channel) -> ( + target.file <- None; + close_out_noerr channel; + try Sys.remove path with Sys_error _ -> ()) + +let contents target = + match target.file with + | None -> Buffer.contents target.buffer + | Some (path, channel) -> + Stdlib.flush channel; + close_out channel; + target.file <- None; + Fun.protect + (fun () -> + let input = open_in_bin path in + Fun.protect + (fun () -> really_input_string input (in_channel_length input)) + ~finally:(fun () -> close_in input)) + ~finally:(fun () -> Sys.remove path) let with_capture action = - let stdout_path, stdout = - Filename.open_temp_file ~mode:[Open_binary] "rescript-compiler-stdout-" - ".log" - in - let stderr_path, stderr = - try - Filename.open_temp_file ~mode:[Open_binary] "rescript-compiler-stderr-" - ".log" - with exn -> - close_out_noerr stdout; - Sys.remove stdout_path; - raise exn - in - let previous = current () in + let stdout = create_target () in + let stderr = create_target () in let streams = { stdout; stderr; - stdout_formatter = Format.formatter_of_out_channel stdout; - stderr_formatter = Format.formatter_of_out_channel stderr; + stdout_formatter = make_formatter stdout; + stderr_formatter = make_formatter stderr; } in + let previous = current () in Domain.DLS.set key (Some streams); - let remove path = try Sys.remove path with Sys_error _ -> () in - let read path = - let channel = open_in_bin path in - Fun.protect - (fun () -> really_input_string channel (in_channel_length channel)) - ~finally:(fun () -> close_in channel) - in Fun.protect (fun () -> - let result = - Fun.protect action ~finally:(fun () -> - Fun.protect - (fun () -> - Format.pp_print_flush streams.stdout_formatter (); - Format.pp_print_flush streams.stderr_formatter (); - flush stdout; - flush stderr) - ~finally:(fun () -> - close_out_noerr stdout; - close_out_noerr stderr; - Domain.DLS.set key previous)) - in - (result, read stdout_path, read stderr_path)) + let result = action () in + Format.pp_print_flush streams.stdout_formatter (); + Format.pp_print_flush streams.stderr_formatter (); + (result, contents stdout, contents stderr)) ~finally:(fun () -> - remove stdout_path; - remove stderr_path) + Domain.DLS.set key previous; + cleanup stdout; + cleanup stderr) diff --git a/compiler/ext/compiler_request_state.ml b/compiler/ext/compiler_request_state.ml index dde0185c59c..6809575cd06 100644 --- a/compiler/ext/compiler_request_state.ml +++ b/compiler/ext/compiler_request_state.ml @@ -47,6 +47,38 @@ let resolve_path path = Filename.concat state.cwd path else path +let is_regular_file path = + try (Unix.stat (resolve_path path)).Unix.st_kind = Unix.S_REG + with Sys_error _ | Unix.Unix_error _ -> false + +let has_exact_directory_entry path = + try + Sys.readdir (resolve_path (Filename.dirname path)) + |> Array.exists (String.equal (Filename.basename path)) + with Sys_error _ | Unix.Unix_error _ -> false + +let canonical_output_path path = + let resolved = resolve_path path in + try + Filename.concat + (Unix.realpath (Filename.dirname resolved)) + (Filename.basename resolved) + with Sys_error _ | Unix.Unix_error _ -> resolved + +let same_output_path first second = + first = second + || + let first = canonical_output_path first in + let second = canonical_output_path second in + first = second + || + try + let first_stats = Unix.stat first in + let second_stats = Unix.stat second in + first_stats.Unix.st_dev = second_stats.Unix.st_dev + && first_stats.Unix.st_ino = second_stats.Unix.st_ino + with Sys_error _ | Unix.Unix_error _ -> false + let with_fresh ?cwd:requested_cwd action = let previous = current () in let cwd = diff --git a/compiler/ext/compiler_request_state.mli b/compiler/ext/compiler_request_state.mli index 926b15c3a25..ff0bd46d3f4 100644 --- a/compiler/ext/compiler_request_state.mli +++ b/compiler/ext/compiler_request_state.mli @@ -27,5 +27,20 @@ val resolve_path : string -> string (** Resolve a relative file path against the active request root. Outside a request, preserve the path so ordinary process-relative I/O is unchanged. *) +val is_regular_file : string -> bool +(** Test whether a request-relative path names a regular file. *) + +val has_exact_directory_entry : string -> bool +(** Check the actual spelling of a directory entry, even on a case-insensitive + filesystem with another spelling cached by the OS. *) + +val canonical_output_path : string -> string +(** Resolve a path and canonicalize its existing parent directory, including + when the output itself has not yet been exported. *) + +val same_output_path : string -> string -> bool +(** Compare output locations, accounting for alternate case spellings of one + existing file on case-insensitive filesystems. *) + val with_fresh : ?cwd:string -> (unit -> 'a) -> 'a (** Run with new request state and restore the prior state on success or failure. *) diff --git a/compiler/ext/dune b/compiler/ext/dune index a2daf826b76..178c9980600 100644 --- a/compiler/ext/dune +++ b/compiler/ext/dune @@ -28,6 +28,7 @@ (wrapped false) (instrumentation (backend bisect_ppx)) + (libraries unix) (foreign_stubs (language c) (names ext_platform_primitives_stubs))) diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml index c496fbae3fc..ad49efb0c01 100644 --- a/compiler/ext/ident.ml +++ b/compiler/ext/ident.ml @@ -15,7 +15,7 @@ open Format -type t = {stamp: int; name: string; mutable flags: int} +type t = {mutable stamp: int; name: string; mutable flags: int} let[@inlnie] max (x : int) y = if x >= y then x else y let global_flag = 1 @@ -23,10 +23,15 @@ let predef_exn_flag = 2 (* A stamp of 0 denotes a persistent identifier *) -type counter_state = {mutable currentstamp: int; mutable reinit_level: int} +type counter_state = { + mutable currentstamp: int; + mutable reinit_level: int; + mutable allocation_capture: t list ref option; +} let counter_key = - Domain.DLS.new_key (fun () -> {currentstamp = 0; reinit_level = -1}) + Domain.DLS.new_key (fun () -> + {currentstamp = 0; reinit_level = -1; allocation_capture = None}) let counter () = Domain.DLS.get counter_key @@ -44,25 +49,41 @@ let with_fresh action = | Some baseline -> baseline | None -> previous.currentstamp in - Domain.DLS.set counter_key {currentstamp = baseline; reinit_level = baseline}; + Domain.DLS.set counter_key + { + currentstamp = baseline; + reinit_level = baseline; + allocation_capture = None; + }; Fun.protect action ~finally:(fun () -> Domain.DLS.set counter_key previous) +let record_allocation state id = + match state.allocation_capture with + | Some captured -> captured := id :: !captured + | None -> () + let create s = let state = counter () in state.currentstamp <- state.currentstamp + 1; - {name = s; stamp = state.currentstamp; flags = 0} + let id = {name = s; stamp = state.currentstamp; flags = 0} in + record_allocation state id; + id let create_predef_exn s = let state = counter () in state.currentstamp <- state.currentstamp + 1; - {name = s; stamp = state.currentstamp; flags = predef_exn_flag} + let id = {name = s; stamp = state.currentstamp; flags = predef_exn_flag} in + record_allocation state id; + id let create_persistent s = {name = s; stamp = 0; flags = global_flag} let rename i = let state = counter () in state.currentstamp <- state.currentstamp + 1; - {i with stamp = state.currentstamp} + let id = {i with stamp = state.currentstamp} in + record_allocation state id; + id let name i = i.name @@ -74,12 +95,27 @@ let persistent i = i.stamp = 0 let equal i1 i2 = i1.name = i2.name -let same ({stamp; name} : t) i2 = - if stamp <> 0 then stamp = i2.stamp else i2.stamp = 0 && name = i2.name +let same i1 i2 = + let stamp = i1.stamp in + if stamp <> 0 then stamp = i2.stamp else i2.stamp = 0 && i1.name = i2.name let binding_time i = i.stamp let current_time () = (counter ()).currentstamp +let with_allocation_capture action = + let state = counter () in + let previous = state.allocation_capture in + let captured = ref [] in + state.allocation_capture <- Some captured; + Fun.protect + (fun () -> + let result = action () in + (result, Array.of_list (List.rev !captured))) + ~finally:(fun () -> + state.allocation_capture <- previous; + match previous with + | Some outer -> outer := !captured @ !outer + | None -> ()) let set_current_time t = let state = counter () in state.currentstamp <- max state.currentstamp t diff --git a/compiler/ext/ident.mli b/compiler/ext/ident.mli index d33b6a35a14..55d343b9578 100644 --- a/compiler/ext/ident.mli +++ b/compiler/ext/ident.mli @@ -15,7 +15,9 @@ (* Identifiers (unique names) *) -type t = {stamp: int; name: string; mutable flags: int} +type t = {mutable stamp: int; name: string; mutable flags: int} +(** [stamp] may be relocated only on a private, freshly deserialized + dependency graph before the identifier becomes visible to typing. *) include Identifiable.S with type t := t (* Notes: @@ -52,6 +54,10 @@ val is_predef_exn : t -> bool val binding_time : t -> int val current_time : unit -> int + +(* Record fresh identifiers made during [action]. Nested captures also + contribute to their outer capture. *) +val with_allocation_capture : (unit -> 'a) -> 'a * t array val set_current_time : int -> unit val reinit : unit -> unit diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index d324ddb64f7..f42ef819051 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -264,6 +264,14 @@ let without_warnings f = let backup () = !((request_state ()).current) let restore x = (request_state ()).current := x + +type snapshot = state + +let copy_state state = + {active = Array.copy state.active; error = Array.copy state.error} + +let snapshot () = copy_state (backup ()) +let install_copy snapshot = restore (copy_state snapshot) let is_active x = let state = request_state () in (not !(state.disabled)) && !(state.current).active.(number x) diff --git a/compiler/ext/warnings.mli b/compiler/ext/warnings.mli index 3832070ca20..7906b6a1012 100644 --- a/compiler/ext/warnings.mli +++ b/compiler/ext/warnings.mli @@ -101,6 +101,12 @@ val backup : unit -> state val restore : state -> unit +type snapshot +val snapshot : unit -> snapshot + +val install_copy : snapshot -> unit +(** Clone warning policy arrays for a request. Diagnostic counters stay fresh. *) + (* Isolate warning settings and counters for one compiler request. *) val with_fresh : (unit -> 'a) -> 'a diff --git a/compiler/gentype/debug.ml b/compiler/gentype/debug.ml index 4cc910c0781..71d2764b104 100644 --- a/compiler/gentype/debug.ml +++ b/compiler/gentype/debug.ml @@ -22,6 +22,32 @@ let type_env () = Domain.DLS.get type_env_key let type_resolution_key = new_flag () let type_resolution () = Domain.DLS.get type_resolution_key +type snapshot = bool array + +let flags () = + [| + basic (); + code_items (); + config (); + converter (); + dependencies (); + module_resolution (); + not_implemented (); + translation (); + type_env (); + type_resolution (); + |] + +let snapshot () = Array.map (fun flag -> !flag) (flags ()) + +let install_copy snapshot = + Array.iteri (fun i flag -> flag := snapshot.(i)) (flags ()) + +let with_fresh action = + let previous = snapshot () in + Array.iter (fun flag -> flag := false) (flags ()); + Fun.protect action ~finally:(fun () -> install_copy previous) + let reset () = basic () := false; code_items () := false; diff --git a/compiler/gentype/emit_js.ml b/compiler/gentype/emit_js.ml index 8acc6be72d7..53bd0da0dbf 100644 --- a/compiler/gentype/emit_js.ml +++ b/compiler/gentype/emit_js.ml @@ -414,10 +414,10 @@ let type_get_inlined ~config ~export_type_map type_ = ~lookup_id:(fun s -> export_type_map |> String_map.find s) ~type_name_is_interface:(fun _ -> false) -(** Read the cmt file referenced in an import type, - and recursively for the import types obtained from reading the cmt file. *) +(** Read the dependency input referenced in an import type, and recursively for + the import types obtained from its declarations. *) let rec read_cmt_files_recursively ~config ~env - ~input_cmt_translate_type_declarations ~output_file_relative ~resolver + ~input_annots_translate_type_declarations ~output_file_relative ~resolver {Code_item.type_name; as_type_name; import_path} = let update_type_map_from_other_files ~as_type ~export_type_map_from_cmt env = match export_type_map_from_cmt |> String_map.find type_name with @@ -447,9 +447,17 @@ let rec read_cmt_files_recursively ~config ~env | exception Not_found -> (* cmt file not read before: this ensures termination *) let type_declarations = - Cmt_format.read_cmt cmt_file - |> input_cmt_translate_type_declarations ~config ~output_file_relative - ~resolver + (match + Compiler_phase_trace.dependency "dependency.gentype_summary_read" + (fun () -> Gentype_summary.read ~cmt_file) + with + | Some annots -> annots + | None -> + Compiler_phase_trace.dependency + "dependency.gentype_dependency_cmt_read" (fun () -> + (Cmt_format.read_cmt cmt_file).cmt_annots)) + |> input_annots_translate_type_declarations ~config + ~output_file_relative ~resolver |> fun (x : Code_item.translation) -> x.type_declarations in let export_type_map_from_cmt = @@ -478,19 +486,20 @@ let rec read_cmt_files_recursively ~config ~env (fun env new_import_type -> new_import_type |> read_cmt_files_recursively ~config ~env - ~input_cmt_translate_type_declarations ~output_file_relative - ~resolver) + ~input_annots_translate_type_declarations + ~output_file_relative ~resolver) env) | _ -> env let emit_import_type ~config ~emitters ~env - ~input_cmt_translate_type_declarations ~output_file_relative ~resolver + ~input_annots_translate_type_declarations ~output_file_relative ~resolver ~type_name_is_interface ({Code_item.type_name; as_type_name; import_path} as import_type) = let env = import_type |> read_cmt_files_recursively ~config ~env - ~input_cmt_translate_type_declarations ~output_file_relative ~resolver + ~input_annots_translate_type_declarations ~output_file_relative + ~resolver in let emitters = Emit_type.emit_import_type_as ~emitters ~config ~type_name ~as_type_name @@ -500,13 +509,13 @@ let emit_import_type ~config ~emitters ~env (env, emitters) let emit_import_types ~config ~emitters ~env - ~input_cmt_translate_type_declarations ~output_file_relative ~resolver + ~input_annots_translate_type_declarations ~output_file_relative ~resolver ~type_name_is_interface import_types = import_types |> List.fold_left (fun (env, emitters) -> emit_import_type ~config ~emitters ~env - ~input_cmt_translate_type_declarations ~output_file_relative + ~input_annots_translate_type_declarations ~output_file_relative ~resolver ~type_name_is_interface) (env, emitters) @@ -602,7 +611,7 @@ let propagate_annotation_to_sub_types ~code_items (new_type_map, !annotated_set) let emit_translation_as_string ~config ~file_name - ~input_cmt_translate_type_declarations ~output_file_relative ~resolver + ~input_annots_translate_type_declarations ~output_file_relative ~resolver (translation : Translation.t) = let initial_env = { @@ -652,8 +661,8 @@ let emit_translation_as_string ~config ~file_name import_types_from_type_declarations @ translation.import_types |> List.sort_uniq Translation.import_type_compare |> emit_import_types ~config ~emitters ~env - ~input_cmt_translate_type_declarations ~output_file_relative ~resolver - ~type_name_is_interface + ~input_annots_translate_type_declarations ~output_file_relative + ~resolver ~type_name_is_interface in let env, emitters = export_from_type_declarations diff --git a/compiler/gentype/gentype_config.ml b/compiler/gentype/gentype_config.ml index 55916f9ecc7..c23116dacc7 100644 --- a/compiler/gentype/gentype_config.ml +++ b/compiler/gentype/gentype_config.ml @@ -85,21 +85,71 @@ type flag_refs = { (* A request builds its GenType config from these flags. Another request must not reset them while its CMT or declaration output is being generated. *) -let flag_refs = - Domain.DLS.new_key (fun () -> - { - project_root_ref = ref ""; - bsb_project_root_ref = ref ""; - module_ref = ref None; - module_resolution_ref = ref None; - export_interfaces_ref = ref false; - generated_file_extension_ref = ref None; - suffix_ref = ref None; - shims_ref = ref []; - bs_dependencies_ref = ref []; - source_dirs_ref = ref []; - dep_paths_ref = ref []; - }) +let fresh_flag_refs () = + { + project_root_ref = ref ""; + bsb_project_root_ref = ref ""; + module_ref = ref None; + module_resolution_ref = ref None; + export_interfaces_ref = ref false; + generated_file_extension_ref = ref None; + suffix_ref = ref None; + shims_ref = ref []; + bs_dependencies_ref = ref []; + source_dirs_ref = ref []; + dep_paths_ref = ref []; + } + +let flag_refs = Domain.DLS.new_key fresh_flag_refs + +type flags_snapshot = { + project_root: string; + bsb_project_root: string; + module_: module_ option; + module_resolution: module_resolution option; + export_interfaces: bool; + generated_file_extension: string option; + suffix: string option; + shims: (string * string) list; + bs_dependencies: string list; + source_dirs: string list; + dep_paths: (string * string) list; +} + +let snapshot_flags () = + let state = Domain.DLS.get flag_refs in + { + project_root = !(state.project_root_ref); + bsb_project_root = !(state.bsb_project_root_ref); + module_ = !(state.module_ref); + module_resolution = !(state.module_resolution_ref); + export_interfaces = !(state.export_interfaces_ref); + generated_file_extension = !(state.generated_file_extension_ref); + suffix = !(state.suffix_ref); + shims = !(state.shims_ref); + bs_dependencies = !(state.bs_dependencies_ref); + source_dirs = !(state.source_dirs_ref); + dep_paths = !(state.dep_paths_ref); + } + +let install_flags_snapshot snapshot = + let state = Domain.DLS.get flag_refs in + state.project_root_ref := snapshot.project_root; + state.bsb_project_root_ref := snapshot.bsb_project_root; + state.module_ref := snapshot.module_; + state.module_resolution_ref := snapshot.module_resolution; + state.export_interfaces_ref := snapshot.export_interfaces; + state.generated_file_extension_ref := snapshot.generated_file_extension; + state.suffix_ref := snapshot.suffix; + state.shims_ref := snapshot.shims; + state.bs_dependencies_ref := snapshot.bs_dependencies; + state.source_dirs_ref := snapshot.source_dirs; + state.dep_paths_ref := snapshot.dep_paths + +let with_fresh_flags action = + let previous = Domain.DLS.get flag_refs in + Domain.DLS.set flag_refs (fresh_flag_refs ()); + Fun.protect action ~finally:(fun () -> Domain.DLS.set flag_refs previous) let project_root () = (Domain.DLS.get flag_refs).project_root_ref let bsb_project_root () = (Domain.DLS.get flag_refs).bsb_project_root_ref diff --git a/compiler/gentype/gentype_main.ml b/compiler/gentype/gentype_main.ml index 55e02a0693b..bd6c72e1c5c 100644 --- a/compiler/gentype/gentype_main.ml +++ b/compiler/gentype/gentype_main.ml @@ -23,9 +23,8 @@ let signature_item_is_declaration signature_item = | Typedtree.Tsig_type _ | Tsig_modtype _ -> true | _ -> false -let input_cmt_translate_type_declarations ~config ~output_file_relative - ~resolver input_cmt : Code_item.translation = - let {Cmt_format.cmt_annots} = input_cmt in +let input_annots_translate_type_declarations ~config ~output_file_relative + ~resolver (cmt_annots : Cmt_format.binary_annots) : Code_item.translation = let type_env = Type_env.root () in let translations = match cmt_annots with @@ -50,6 +49,11 @@ let input_cmt_translate_type_declarations ~config ~output_file_relative translations |> Translation.combine |> Translation.add_type_declarations_from_module_equations ~type_env +let input_cmt_translate_type_declarations ~config ~output_file_relative + ~resolver (input_cmt : Cmt_format.cmt_infos) = + input_annots_translate_type_declarations ~config ~output_file_relative + ~resolver input_cmt.cmt_annots + let translate_cmt ~config ~output_file_relative ~resolver input_cmt : Translation.t = let {Cmt_format.cmt_annots} = input_cmt in @@ -69,29 +73,89 @@ let translate_cmt ~config ~output_file_relative ~resolver input_cmt : translations |> Translation.combine |> Translation.add_type_declarations_from_module_equations ~type_env +let generated_output_capture_key = Domain.DLS.new_key (fun () -> None) + +let with_generated_output_capture capture action = + let previous = Domain.DLS.get generated_output_capture_key in + Domain.DLS.set generated_output_capture_key (Some capture); + Fun.protect action ~finally:(fun () -> + Domain.DLS.set generated_output_capture_key previous) + let emit_translation ~config ~file_name ~output_file ~output_file_relative ~resolver ~source_file translation = let code_text = translation |> Emit_js.emit_translation_as_string ~config ~file_name - ~output_file_relative ~resolver ~input_cmt_translate_type_declarations + ~output_file_relative ~resolver + ~input_annots_translate_type_declarations in let file_contents = Emit_type.file_header ~source_file:(Filename.basename source_file) ^ "\n" ^ code_text ^ "\n" in - Generated_files.write_file_if_required ~output_file ~file_contents + Generated_files.write_file_if_required ~output_file ~file_contents; + Option.iter + (fun capture -> capture output_file) + (Domain.DLS.get generated_output_capture_key) let read_cmt cmt_file = - try Cmt_format.read_cmt cmt_file + try + Compiler_phase_trace.dependency "dependency.gentype_cmt_read" (fun () -> + Cmt_format.read_cmt cmt_file) with Cmi_format.Error _ -> Log_.item "Error loading %s\n\n" cmt_file; Log_.item "It looks like you might have stale compilation artifacts.\n"; Log_.item "Try to clean and rebuild.\n\n"; assert false -let read_input_cmt is_interface cmt_file = - let input_cmt = read_cmt cmt_file in +type semantic_inputs = { + implementation: Cmt_format.cmt_infos option; + interface: Cmt_format.cmt_infos option; +} + +let semantic_lookup_key = Domain.DLS.new_key (fun () -> None) + +let with_semantic_lookup lookup action = + let previous = Domain.DLS.get semantic_lookup_key in + Domain.DLS.set semantic_lookup_key (Some lookup); + Fun.protect action ~finally:(fun () -> + Domain.DLS.set semantic_lookup_key previous) + +let semantic_input ~filename = + match Domain.DLS.get semantic_lookup_key with + | None -> None + | Some lookup -> + Compiler_phase_trace.dependency "dependency.gentype_semantic_result" + (fun () -> lookup filename) + +let owned_semantic_result cmt = + Compiler_phase_trace.dependency "dependency.gentype_semantic_result" + (fun () -> cmt) + +let read_input_cmt ~inputs is_interface cmt_file = + let interface_cmt () = + match inputs.interface with + | Some cmt -> cmt + | None -> ( + match + Compiler_phase_trace.dependency + "dependency.gentype_interface_summary_read" (fun () -> + Gentype_summary.read_interface ~cmt_file) + with + | Some annots -> ( + match inputs.implementation with + | Some cmt -> {cmt with cmt_annots = annots} + | None -> read_cmt cmt_file) + | None -> read_cmt cmt_file) + in + let implementation_cmt () = + match inputs.implementation with + | Some cmt -> owned_semantic_result cmt + | None -> read_cmt cmt_file + in + let input_cmt = + if is_interface then interface_cmt () else implementation_cmt () + in let ignore_interface = ref false in let check_annotation ~loc:_ attributes = if @@ -112,7 +176,11 @@ let read_input_cmt is_interface cmt_file = let cmt_file_impl = (cmt_file |> (Filename.chop_extension [@doesNotRaise])) ^ ".cmt" in - let input_cmt_impl = read_cmt cmt_file_impl in + let input_cmt_impl = + match inputs.implementation with + | Some cmt -> owned_semantic_result cmt + | None -> read_cmt cmt_file_impl + in let has_gentype_annotations_impl = input_cmt_impl |> cmt_check_annotations ~check_annotation:(fun ~loc attributes -> @@ -133,15 +201,29 @@ let read_input_cmt is_interface cmt_file = | false -> has_gentype_annotations ) else (input_cmt, has_gentype_annotations) -let process_cmt_file cmt = +let process_cmt_file ?compiled_cmt cmt = let config = Paths.read_config ~namespace:(cmt |> Paths.find_name_space) in if !(Debug.basic ()) then Log_.item "Cmt %s\n" cmt; - let cmt_file = cmt |> Paths.get_cmt_file in + let cmt_file = + match (Paths.get_cmt_file cmt, compiled_cmt) with + | "", Some _ -> Compiler_request_state.resolve_path cmt + | path, _ -> path + in if cmt_file <> "" then let file_name = cmt |> Paths.get_module_name in let is_interface = Filename.check_suffix cmt_file ".cmti" in + let inputs = + { + implementation = compiled_cmt; + interface = + (if is_interface then + if Filename.check_suffix cmt ".cmti" then compiled_cmt + else semantic_input ~filename:cmt_file + else None); + } + in let input_cmt, has_gentype_annotations = - read_input_cmt is_interface cmt_file + read_input_cmt ~inputs is_interface cmt_file in let source_file = match input_cmt.cmt_annots |> Find_source_file.cmt with diff --git a/compiler/gentype/gentype_summary.ml b/compiler/gentype/gentype_summary.ml new file mode 100644 index 00000000000..cd95ec6b13b --- /dev/null +++ b/compiler/gentype/gentype_summary.ml @@ -0,0 +1,198 @@ +(* Declaration-only inputs for imported GenType modules, with an optional full + interface input when editor annotations are disabled. The version and + provenance fields keep stale summaries from replacing their CMT fallback. *) + +let magic = "ReScript genType summary 3\n" +let version = 3 + +type dependency = {path: string; digest: Digest.t} + +type t = { + version: int; + compiler_identity: string; + project_root: string; + config_digest: Digest.t; + config_source: dependency option; + source_path: string; + source_digest: Digest.t; + dependencies: dependency list; + annots: Cmt_format.binary_annots; + interface_annots: Cmt_format.binary_annots option; +} + +let summary_file cmt_file = cmt_file ^ ".gts" + +let remove ~cmt_file = + try Sys.remove (summary_file cmt_file) + with Sys_error _ | Unix.Unix_error _ -> () + +let compiler_identity_key = Domain.DLS.new_key (fun () -> None) + +let with_compiler_identity identity action = + let previous = Domain.DLS.get compiler_identity_key in + Domain.DLS.set compiler_identity_key (Some identity); + Fun.protect action ~finally:(fun () -> + Domain.DLS.set compiler_identity_key previous) + +let absolute ~cwd path = + if Filename.is_relative path then Filename.concat cwd path else path + +let config_digest ~namespace = + Digest.string + (Marshal.to_string (Gentype_config.snapshot_flags (), namespace) []) + +let config_source ~project_root = + ["rescript.json"; "bsconfig.json"] + |> List.find_map (fun name -> + let path = Filename.concat project_root name in + if Sys.file_exists path then Some {path; digest = Digest.file path} + else None) + +let declaration_annots = function + | Cmt_format.Implementation structure -> + Cmt_format.Implementation + { + structure with + str_items = + List.filter + (fun (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_type _ | Tstr_modtype _ | Tstr_module _ -> true + | _ -> false) + structure.str_items; + } + | Interface signature -> + Interface + { + signature with + sig_items = + List.filter + (fun (item : Typedtree.signature_item) -> + match item.sig_desc with + | Tsig_type _ | Tsig_modtype _ -> true + | _ -> false) + signature.sig_items; + } + | (Packed _ | Partial_implementation _ | Partial_interface _) as annots -> + annots + +let dependency_paths ~cmt_file (cmt : Cmt_format.cmt_infos) = + let directories = + Filename.dirname (absolute ~cwd:cmt.cmt_builddir cmt_file) + :: List.map (absolute ~cwd:cmt.cmt_builddir) cmt.cmt_loadpath + in + cmt.cmt_imports + |> List.filter_map (function + | _, None -> Some None + | name, Some _ -> + let filename = name ^ ".cmi" in + directories + |> List.find_map (fun directory -> + let path = Filename.concat directory filename in + if Sys.file_exists path then Some path else None) + |> Option.map (fun path -> Some path)) + |> fun paths -> + if List.length paths <> List.length cmt.cmt_imports then None + else Some (paths |> List.filter_map Fun.id |> List.sort_uniq String.compare) + +let save ~cmt_file (cmt : Cmt_format.cmt_infos) = + let written = + try + match (cmt.cmt_sourcefile, Domain.DLS.get compiler_identity_key) with + | Some source_file, Some compiler_identity -> ( + let source_path = absolute ~cwd:cmt.cmt_builddir source_file in + let source_digest = Digest.file source_path in + if cmt.cmt_source_digest <> Some source_digest then false + else + match dependency_paths ~cmt_file cmt with + | None -> false + | Some paths -> + let dependencies = + List.map (fun path -> {path; digest = Digest.file path}) paths + in + let annots = declaration_annots cmt.cmt_annots in + let interface_annots = + match cmt.cmt_annots with + | Interface _ when not !((Clflags.current ()).binary_annotations) + -> + Some cmt.cmt_annots + | Interface _ | Implementation _ | Packed _ + | Partial_implementation _ | Partial_interface _ -> + None + in + let summary = + let project_root = + absolute + ~cwd:(Compiler_request_state.cwd ()) + !(Gentype_config.project_root ()) + in + { + version; + compiler_identity; + project_root; + config_digest = + config_digest ~namespace:(Paths.find_name_space cmt_file); + config_source = config_source ~project_root; + source_path; + source_digest; + dependencies; + annots; + interface_annots; + } + in + Misc.output_to_bin_file_directly (summary_file cmt_file) + (fun _ channel -> + output_string channel magic; + output_value channel summary); + true) + | None, _ | _, None -> false + with Sys_error _ | Unix.Unix_error _ | Invalid_argument _ -> false + in + if not written then remove ~cmt_file + +let load_validated ~cmt_file = + try + let channel = open_in_bin (summary_file cmt_file) in + let summary = + Fun.protect + (fun () -> + if really_input_string channel (String.length magic) <> magic then + None + else Some (input_value channel : t)) + ~finally:(fun () -> close_in_noerr channel) + in + Option.bind summary (fun summary -> + if + summary.version = version + && Some summary.compiler_identity + = Domain.DLS.get compiler_identity_key + && (match summary.config_source with + | Some {path; digest} -> Digest.file path = digest + | None -> true) + && (if + absolute + ~cwd:(Compiler_request_state.cwd ()) + !(Gentype_config.project_root ()) + = summary.project_root + then + summary.config_digest + = config_digest ~namespace:(Paths.find_name_space cmt_file) + else Option.is_some summary.config_source) + && Digest.file summary.source_path = summary.source_digest + && List.for_all + (fun {path; digest} -> Digest.file path = digest) + summary.dependencies + then Some summary + else None) + with + | Sys_error _ | Unix.Unix_error _ | End_of_file | Failure _ + | Invalid_argument _ + -> + None + +let read ~cmt_file = + Option.map (fun summary -> summary.annots) (load_validated ~cmt_file) + +let read_interface ~cmt_file = + Option.bind (load_validated ~cmt_file) (fun summary -> + summary.interface_annots) diff --git a/compiler/gentype/paths.ml b/compiler/gentype/paths.ml index 6f248b210dc..7483727d681 100644 --- a/compiler/gentype/paths.ml +++ b/compiler/gentype/paths.ml @@ -59,6 +59,9 @@ let get_module_name cmt = cmt |> handle_namespace |> Filename.basename |> Module_name.from_string_unsafe let get_cmt_file cmt = + let has_semantic_input path = + Sys.file_exists path || Sys.file_exists (path ^ ".gts") + in let path_cmt = if Filename.is_relative cmt then Filename.concat (Compiler_request_state.cwd ()) cmt @@ -77,10 +80,10 @@ let get_cmt_file cmt = let path_cmti_lower_case = (Filename.chop_extension path_cmt_lower_case [@doesNotRaise]) ^ ".cmti" in - if Sys.file_exists path_cmti_lower_case then path_cmti_lower_case - else if Sys.file_exists path_cmti then path_cmti - else if Sys.file_exists path_cmt_lower_case then path_cmt_lower_case - else if Sys.file_exists path_cmt then path_cmt + if has_semantic_input path_cmti_lower_case then path_cmti_lower_case + else if has_semantic_input path_cmti then path_cmti + else if has_semantic_input path_cmt_lower_case then path_cmt_lower_case + else if has_semantic_input path_cmt then path_cmt else "" else "" in diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index 8af27ef9a59..075fd0e0950 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -555,8 +555,8 @@ module Compile = struct |> Gentype_main.translate_cmt ~config ~output_file_relative ~resolver |> Emit_js.emit_translation_as_string ~config ~file_name ~output_file_relative ~resolver - ~input_cmt_translate_type_declarations: - Gentype_main.input_cmt_translate_type_declarations + ~input_annots_translate_type_declarations: + Gentype_main.input_annots_translate_type_declarations in Emit_type.file_header ~source_file:(Filename.basename source_file) ^ "\n" ^ code_text ^ "\n" diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index db7532c0873..a9152925fb3 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -41,6 +41,22 @@ let pivot_level = (2 * lowest_level) - 1 (**** Some type creators ****) +let allocation_capture_key = Domain.DLS.new_key (fun () -> None) + +let with_allocation_capture action = + let previous = Domain.DLS.get allocation_capture_key in + let captured = ref [] in + Domain.DLS.set allocation_capture_key (Some captured); + Fun.protect + (fun () -> + let result = action () in + (result, Array.of_list (List.rev !captured))) + ~finally:(fun () -> + Domain.DLS.set allocation_capture_key previous; + match previous with + | Some outer -> outer := !captured @ !outer + | None -> ()) + let reinit () = let state = Compiler_request_state.current () in match state.type_node_reset_id with @@ -50,7 +66,11 @@ let reinit () = let newty2 level desc = let state = Compiler_request_state.current () in state.type_node_id <- state.type_node_id + 1; - {desc; level; id = state.type_node_id} + let ty = {desc; level; id = state.type_node_id} in + (match Domain.DLS.get allocation_capture_key with + | Some captured -> captured := ty :: !captured + | None -> ()); + ty let newgenty desc = newty2 generic_level desc let newgenvar ?name () = newgenty (Tvar name) (* diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index 6f9b51cc75d..1c654aa4f4f 100644 --- a/compiler/ml/btype.mli +++ b/compiler/ml/btype.mli @@ -31,6 +31,10 @@ val generic_level : int val newty2 : int -> type_desc -> type_expr (* Create a type *) +val with_allocation_capture : (unit -> 'a) -> 'a * type_expr array +(** Record fresh type nodes created by [newty2] during [action]. Nested + captures also contribute to their outer capture. *) + val newgenty : type_desc -> type_expr (* Create a generic type *) diff --git a/compiler/ml/clflags.ml b/compiler/ml/clflags.ml index 7d334147a5f..bec72433b8a 100644 --- a/compiler/ml/clflags.ml +++ b/compiler/ml/clflags.ml @@ -74,6 +74,48 @@ let create () = let key = Domain.DLS.new_key create let current () = Domain.DLS.get key +type snapshot = t + +let snapshot_binary_annotations snapshot = !(snapshot.binary_annotations) + +let copy state = + { + output_name = ref !(state.output_name); + include_dirs = ref !(state.include_dirs); + debug = ref !(state.debug); + fast = ref !(state.fast); + nopervasives = ref !(state.nopervasives); + preprocessor = ref !(state.preprocessor); + all_ppx = ref !(state.all_ppx); + annotations = ref !(state.annotations); + binary_annotations = ref !(state.binary_annotations); + noassert = ref !(state.noassert); + verbose = ref !(state.verbose); + open_modules = ref !(state.open_modules); + real_paths = ref !(state.real_paths); + applicative_functors = ref !(state.applicative_functors); + error_size = ref !(state.error_size); + transparent_modules = ref !(state.transparent_modules); + dump_source = ref !(state.dump_source); + dump_parsetree = ref !(state.dump_parsetree); + dump_typedtree = ref !(state.dump_typedtree); + dump_rawlambda = ref !(state.dump_rawlambda); + only_parse = ref !(state.only_parse); + editor_mode = ref !(state.editor_mode); + ignore_parse_errors = ref !(state.ignore_parse_errors); + dont_write_files = ref !(state.dont_write_files); + keep_locs = ref !(state.keep_locs); + color = ref !(state.color); + assume_no_mli = ref !(state.assume_no_mli); + dont_record_crc_unit = ref !(state.dont_record_crc_unit); + bs_gentype = ref !(state.bs_gentype); + no_assert_false = ref !(state.no_assert_false); + dump_location = ref !(state.dump_location); + } + +let snapshot () = copy (current ()) +let install_copy snapshot = Domain.DLS.set key (copy snapshot) + let with_fresh action = let previous = current () in Domain.DLS.set key (create ()); diff --git a/compiler/ml/clflags.mli b/compiler/ml/clflags.mli index 8a6be34427d..d0ed6df2caf 100644 --- a/compiler/ml/clflags.mli +++ b/compiler/ml/clflags.mli @@ -40,6 +40,15 @@ val current : unit -> t val with_fresh : (unit -> 'a) -> 'a (* Run with fresh flags and restore the previous request on exit. *) +type snapshot +val snapshot : unit -> snapshot +val snapshot_binary_annotations : snapshot -> bool + +val install_copy : snapshot -> unit +(** Copy option values into an already isolated request. The snapshot and + request have distinct mutable refs, so source flags cannot change a + reusable option template. *) + val parse_color_setting : string -> Misc.Color.setting option val reset_dump_state : unit -> unit val reset : unit -> unit diff --git a/compiler/ml/cmi_format.ml b/compiler/ml/cmi_format.ml index 805b6fb14e5..e3d843683e6 100644 --- a/compiler/ml/cmi_format.ml +++ b/compiler/ml/cmi_format.ml @@ -36,24 +36,27 @@ let input_cmi ic = {cmi_name = name; cmi_sign = sign; cmi_crcs = crcs; cmi_flags = flags} let read_cmi_channel filename ic = - try - let buffer = - really_input_string ic (String.length Config.cmi_magic_number) - in - (if buffer <> Config.cmi_magic_number then - let pre_len = String.length Config.cmi_magic_number - 3 in - if - String.sub buffer 0 pre_len - = String.sub Config.cmi_magic_number 0 pre_len - then - let msg = - if buffer < Config.cmi_magic_number then "an older" else "a newer" - in - raise (Error (Wrong_version_interface (filename, msg))) - else raise (Error (Not_an_interface filename))); - let cmi = input_cmi ic in - cmi - with End_of_file | Failure _ -> raise (Error (Corrupted_interface filename)) + Compiler_phase_trace.dependency "dependency.read_decode" (fun () -> + try + let buffer = + really_input_string ic (String.length Config.cmi_magic_number) + in + (if buffer <> Config.cmi_magic_number then + let pre_len = String.length Config.cmi_magic_number - 3 in + if + String.sub buffer 0 pre_len + = String.sub Config.cmi_magic_number 0 pre_len + then + let msg = + if buffer < Config.cmi_magic_number then "an older" + else "a newer" + in + raise (Error (Wrong_version_interface (filename, msg))) + else raise (Error (Not_an_interface filename))); + let cmi = input_cmi ic in + cmi + with End_of_file | Failure _ -> + raise (Error (Corrupted_interface filename))) let read_cmi filename = let ic = open_in_bin (Compiler_request_state.resolve_path filename) in @@ -61,6 +64,14 @@ let read_cmi filename = (fun () -> read_cmi_channel filename ic) ~finally:(fun () -> close_in_noerr ic) +let encode_cmi cmi = + let prefix = + Config.cmi_magic_number ^ Marshal.to_string (cmi.cmi_name, cmi.cmi_sign) [] + in + let crc = Digest.string prefix in + let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in + (prefix ^ Marshal.to_string crcs [] ^ Marshal.to_string cmi.cmi_flags [], crc) + let output_cmi filename oc cmi = (* beware: the provided signature must have been substituted for saving *) output_string oc Config.cmi_magic_number; @@ -72,43 +83,73 @@ let output_cmi filename oc cmi = output_value oc cmi.cmi_flags; crc +let output_capture_key = Domain.DLS.new_key (fun () -> None) + +let with_output_capture capture action = + let previous = Domain.DLS.get output_capture_key in + Domain.DLS.set output_capture_key (Some capture); + Fun.protect action ~finally:(fun () -> + Domain.DLS.set output_capture_key previous) + (* This function is also called by [save_cmt] as cmi_format is subset of cmt_format, so dont close the channel yet *) let create_cmi ?check_exists filename (cmi : cmi_infos) = - (* beware: the provided signature must have been substituted for saving *) - let content = - Config.cmi_magic_number ^ Marshal.to_string (cmi.cmi_name, cmi.cmi_sign) [] - (* checkout [output_value] in {!Pervasives} module *) - in - let crc = Digest.string content in - let cmi_infos = - if - check_exists <> None - && Sys.file_exists (Compiler_request_state.resolve_path filename) - then Some (read_cmi filename) - else None - in - match cmi_infos with - | Some - { - cmi_name = _; - cmi_sign = _; - cmi_crcs = (old_name, Some old_crc) :: rest; - cmi_flags; - } - (* TODO: design the cmi format so that we don't need read the whole cmi *) - when cmi.cmi_name = old_name && crc = old_crc && cmi.cmi_crcs = rest - && cmi_flags = cmi.cmi_flags -> - crc - | _ -> - let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in - let oc = open_out_bin (Compiler_request_state.resolve_path filename) in - output_string oc content; - output_value oc crcs; - output_value oc cmi.cmi_flags; - close_out oc; - crc + Compiler_phase_trace.section "artifact.cmi_persist" (fun () -> + (* beware: the provided signature must have been substituted for saving *) + let content = + Compiler_phase_trace.section "artifact.cmi_serialize" (fun () -> + Config.cmi_magic_number + ^ Marshal.to_string (cmi.cmi_name, cmi.cmi_sign) []) + (* checkout [output_value] in {!Pervasives} module *) + in + let crc = + Compiler_phase_trace.section "artifact.cmi_hash" (fun () -> + Digest.string content) + in + let cmi_infos = + if + check_exists <> None + && Sys.file_exists (Compiler_request_state.resolve_path filename) + then + Some + (Compiler_phase_trace.section "artifact.cmi_compare" (fun () -> + read_cmi filename)) + else None + in + match cmi_infos with + | Some + { + cmi_name = _; + cmi_sign = _; + cmi_crcs = (old_name, Some old_crc) :: rest; + cmi_flags; + } + (* TODO: design the cmi format so that we don't need read the whole cmi *) + when cmi.cmi_name = old_name && crc = old_crc && cmi.cmi_crcs = rest + && cmi_flags = cmi.cmi_flags -> + crc + | _ -> + let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in + let deferred = + match Domain.DLS.get output_capture_key with + | None -> false + | Some capture -> + let contents = + content ^ Marshal.to_string crcs [] + ^ Marshal.to_string cmi.cmi_flags [] + in + capture filename crc cmi contents + in + if not deferred then ( + let oc = + open_out_bin (Compiler_request_state.resolve_path filename) + in + output_string oc content; + output_value oc crcs; + output_value oc cmi.cmi_flags; + close_out oc); + crc) (* Error report *) diff --git a/compiler/ml/cmi_format.mli b/compiler/ml/cmi_format.mli index 15273591efc..5984638768b 100644 --- a/compiler/ml/cmi_format.mli +++ b/compiler/ml/cmi_format.mli @@ -27,6 +27,14 @@ val output_cmi : string -> out_channel -> cmi_infos -> Digest.t val create_cmi : ?check_exists:unit -> string -> cmi_infos -> Digest.t +val encode_cmi : cmi_infos -> string * Digest.t +(** Encode the complete CMI prefix and return its interface digest. *) + +val with_output_capture : + (string -> Digest.t -> cmi_infos -> string -> bool) -> (unit -> 'a) -> 'a +(** Capture the encoded interface before writing it. Return [true] to defer + the staging write to the owner of the captured bytes. *) + (* read the cmi information (the magic is supposed to have already been read) *) val input_cmi : in_channel -> cmi_infos diff --git a/compiler/ml/cmt_format.ml b/compiler/ml/cmt_format.ml index e904605abff..565716fc86b 100644 --- a/compiler/ml/cmt_format.ml +++ b/compiler/ml/cmt_format.ml @@ -2,7 +2,33 @@ include Cmt_format_common let set_args = Cmt_format_persistence.set_args +let last_saved = Domain.DLS.new_key (fun () -> ref None) +let capture_key = Domain.DLS.new_key (fun () -> None) +let output_capture_key = Domain.DLS.new_key (fun () -> None) + +let with_capture capture action = + let previous = Domain.DLS.get capture_key in + Domain.DLS.set capture_key (Some capture); + Fun.protect action ~finally:(fun () -> Domain.DLS.set capture_key previous) + +let with_output_capture capture action = + let previous = Domain.DLS.get output_capture_key in + Domain.DLS.set output_capture_key (Some capture); + Fun.protect action ~finally:(fun () -> + Domain.DLS.set output_capture_key previous) + +let clear () = + Cmt_format_common.clear (); + Domain.DLS.get last_saved := None + +let last_saved_cmt () = !(Domain.DLS.get last_saved) + let save_cmt filename modname binary_annots sourcefile initial_env cmi = - Cmt_format_persistence.save_cmt filename modname binary_annots sourcefile - initial_env cmi; - clear () + Domain.DLS.get last_saved := + Cmt_format_persistence.save_cmt + ?capture:(Domain.DLS.get output_capture_key) + filename modname binary_annots sourcefile initial_env cmi; + Option.iter + (fun capture -> Option.iter (capture filename) (last_saved_cmt ())) + (Domain.DLS.get capture_key); + Cmt_format_common.clear () diff --git a/compiler/ml/cmt_format.mli b/compiler/ml/cmt_format.mli index 5472a22b31c..f677fa96aaf 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -103,6 +103,20 @@ val save_cmt : (** [save_cmt filename modname binary_annots sourcefile initial_env cmi] writes a cmt(i) file. *) +val last_saved_cmt : unit -> cmt_infos option +(** The semantic result of the most recent successful [save_cmt] in this + compiler request. It belongs to the current domain and is reset by + [clear]. Callers must not share its mutable typed tree across domains. *) + +val with_capture : (string -> cmt_infos -> unit) -> (unit -> 'a) -> 'a +(** Capture the typed semantic result before request state is reset. The + captured graph is mutable and must be copied before another domain uses it. *) + +val with_output_capture : + (string -> cmt_infos -> string -> bool) -> (unit -> 'a) -> 'a +(** Capture a complete encoded annotation before its staging write. Return + [true] to let the caller persist the owned bytes. *) + (* Miscellaneous functions *) val read_magic_number : in_channel -> string diff --git a/compiler/ml/cmt_format_common.ml b/compiler/ml/cmt_format_common.ml index 9ffcb4546c8..519ade2f45a 100644 --- a/compiler/ml/cmt_format_common.ml +++ b/compiler/ml/cmt_format_common.ml @@ -169,28 +169,33 @@ let clear () = state.deprecated_used <- [] let add_saved_type b = - let state = current_accumulators () in - state.saved_types <- b :: state.saved_types + if !((Clflags.current ()).binary_annotations) then + let state = current_accumulators () in + state.saved_types <- b :: state.saved_types let get_saved_types () = (current_accumulators ()).saved_types let set_saved_types l = (current_accumulators ()).saved_types <- l let record_deprecated_used ?deprecated_context ?migration_template ?migration_in_pipe_chain_template source_loc deprecated_text = - let state = current_accumulators () in - state.deprecated_used <- - { - Cmt_utils.source_loc; - deprecated_text; - migration_template; - migration_in_pipe_chain_template; - context = deprecated_context; - } - :: state.deprecated_used + if !((Clflags.current ()).binary_annotations) then + let state = current_accumulators () in + state.deprecated_used <- + { + Cmt_utils.source_loc; + deprecated_text; + migration_template; + migration_in_pipe_chain_template; + context = deprecated_context; + } + :: state.deprecated_used let _ = Cmt_utils.record_deprecated_used := record_deprecated_used let record_value_dependency vd1 vd2 = - if vd1.Types.val_loc <> vd2.Types.val_loc then + if + !((Clflags.current ()).binary_annotations) + && vd1.Types.val_loc <> vd2.Types.val_loc + then let state = current_accumulators () in state.value_deps <- (vd1, vd2) :: state.value_deps diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 48af05a9018..5822e45ba11 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -169,8 +169,13 @@ module Tycomp_tbl = struct (** Symbolic representation of the last (innermost) open, if any. *) } + and 'a source = { + find: string -> 'a list option; + iter: (string -> 'a list -> unit) -> unit; + } + and 'a opened = { - components: (string, 'a list) Tbl.t; + components: 'a source; (** Components from the opened module. We keep a list of bindings for each name, as in comp_labels and comp_constrs. *) @@ -185,7 +190,15 @@ module Tycomp_tbl = struct let add id x tbl = {tbl with current = Ident.add id x tbl.current} - let add_open slot wrap components next = + let source_of_table table = + { + find = + (fun name -> + try Some (Tbl.find_str name table) with Not_found -> None); + iter = (fun callback -> Tbl.iter callback table); + } + + let add_open_source slot wrap components next = let using = match slot with | None -> None @@ -193,6 +206,9 @@ module Tycomp_tbl = struct in {current = Ident.empty; opened = Some {using; components; next}} + let add_open slot wrap components next = + add_open_source slot wrap (source_of_table components) next + let rec find_same id tbl = try Ident.find_same id tbl.current with Not_found as exn -> ( @@ -219,9 +235,9 @@ module Tycomp_tbl = struct | None -> [] | Some {using; next; components} -> ( let rest = find_all name next in - match Tbl.find_str name components with - | exception Not_found -> rest - | opened -> + match components.find name with + | None -> rest + | Some opened -> List.map (fun desc -> (desc, mk_callback rest name desc using)) opened @ rest) @@ -229,9 +245,10 @@ module Tycomp_tbl = struct let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in match tbl.opened with | Some {using = _; next; components} -> - acc - |> Tbl.fold (fun _name -> List.fold_right (fun desc -> f desc)) components - |> fold_name f next + let acc = ref acc in + components.iter (fun _name descriptions -> + acc := List.fold_right (fun desc -> f desc) descriptions !acc); + fold_name f next !acc | None -> acc let rec local_keys tbl acc = @@ -263,13 +280,17 @@ module Id_tbl = struct (** Symbolic representation of the last (innermost) open, if any. *) } + and 'a source = { + find: string -> ('a * int) option; + iter: (string -> 'a * int -> unit) -> unit; + } + and 'a opened = { root: Path.t; (** The path of the opened module, to be prefixed in front of its local names to produce a valid path in the current environment. *) - components: (string, 'a * int) Tbl.t; - (** Components from the opened module. *) + components: 'a source; (** Components from the opened module. *) using: (string -> ('a * 'a) option -> unit) option; (** A callback to be applied when a component is used from this "open". This is used to detect unused "opens". The @@ -281,7 +302,15 @@ module Id_tbl = struct let add id x tbl = {tbl with current = Ident.add id x tbl.current} - let add_open slot wrap root components next = + let source_of_table table = + { + find = + (fun name -> + try Some (Tbl.find_str name table) with Not_found -> None); + iter = (fun callback -> Tbl.iter callback table); + } + + let add_open_source slot wrap root components next = let using = match slot with | None -> None @@ -289,6 +318,9 @@ module Id_tbl = struct in {current = Ident.empty; opened = Some {using; root; components; next}} + let add_open slot wrap root components next = + add_open_source slot wrap root (source_of_table components) next + let rec find_same id tbl = try Ident.find_same id tbl.current with Not_found as exn -> ( @@ -303,8 +335,8 @@ module Id_tbl = struct with Not_found as exn -> ( match tbl.opened with | Some {using; root; next; components} -> ( - try - let descr, pos = Tbl.find_str name components in + match components.find name with + | Some (descr, pos) -> let res = (Pdot (root, name, pos), descr) in (if mark then match using with @@ -313,7 +345,7 @@ module Id_tbl = struct try f name (Some (snd (find_name false name next), snd res)) with Not_found -> f name None)); res - with Not_found -> find_name mark name next) + | None -> find_name mark name next) | None -> raise exn) let find_name name tbl = find_name true name tbl @@ -326,12 +358,25 @@ module Id_tbl = struct with Not_found -> ( match tbl.opened with | Some {root; using; next; components} -> ( - try - let desc, pos = Tbl.find_str name components in + match components.find name with + | Some (desc, pos) -> let new_desc = f desc in - let components = Tbl.add name (new_desc, pos) components in + let previous = components in + let components = + { + find = + (fun query -> + if query = name then Some (new_desc, pos) + else previous.find query); + iter = + (fun callback -> + previous.iter (fun query entry -> + callback query + (if query = name then (new_desc, pos) else entry))); + } + in {tbl with opened = Some {root; using; next; components}} - with Not_found -> + | None -> let next = update name f next in {tbl with opened = Some {root; using; next; components}}) | None -> tbl) @@ -344,10 +389,9 @@ module Id_tbl = struct match tbl.opened with | None -> [] | Some {root; using = _; next; components} -> ( - try - let desc, pos = Tbl.find_str name components in - (Pdot (root, name, pos), desc) :: find_all name next - with Not_found -> find_all name next) + match components.find name with + | Some (desc, pos) -> (Pdot (root, name, pos), desc) :: find_all name next + | None -> find_all name next) let rec fold_name f tbl acc = let acc = @@ -357,11 +401,10 @@ module Id_tbl = struct in match tbl.opened with | Some {root; using = _; next; components} -> - acc - |> Tbl.fold - (fun name (desc, pos) -> f name (Pdot (root, name, pos), desc)) - components - |> fold_name f next + let acc = ref acc in + components.iter (fun name (desc, pos) -> + acc := f name (Pdot (root, name, pos), desc) !acc); + fold_name f next !acc | None -> acc let rec local_keys tbl acc = @@ -374,10 +417,8 @@ module Id_tbl = struct Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; match tbl.opened with | Some {root; using = _; next; components} -> - Tbl.iter - (fun s (x, pos) -> - f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x)) - components; + components.iter (fun s (x, pos) -> + f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x)); iter f next | None -> () @@ -414,6 +455,7 @@ type t = { and module_components = { deprecated: string option; loc: Location.t; + frozen_root: Frozen_values.view option; comps: ( t * Subst.t * Path.t * Types.module_type, module_components_repr option ) @@ -575,10 +617,21 @@ let strengthen = let md md_type = {md_type; md_attributes = []; md_loc = Location.none} let get_components_opt c = + let maker = + match c.frozen_root with + | None -> !components_of_module_maker' + | Some view -> + fun (env, sub, path, _) -> + let signature = + Compiler_phase_trace.dependency + "dependency.frozen_source_signature_fallback" (fun () -> + Frozen_values.source_signature view) + in + !components_of_module_maker' (env, sub, path, Mty_signature signature) + in match !(can_load_cmis ()) with - | Can_load_cmis -> Env_lazy.force !components_of_module_maker' c.comps - | Cannot_load_cmis log -> - Env_lazy.force_logged log !components_of_module_maker' c.comps + | Can_load_cmis -> Env_lazy.force maker c.comps + | Cannot_load_cmis log -> Env_lazy.force_logged log maker c.comps let empty_structure = Structure_comps @@ -605,6 +658,91 @@ let current_unit () = Domain.DLS.get current_unit_key (* Persistent structure descriptions *) +(* The three lazy expansion stages allocate identifiers at different points in + a request. Capture their nodes in allocation order so each stage can take + fresh request-local IDs without walking the large signature again. *) +type allocation_stage = { + first_type_id: int; + allocated_type_ids: int; + type_nodes: type_expr array; + first_ident_stamp: int; + allocated_ident_stamps: int; + identifiers: Ident.t array; +} + +type alias_key = { + target_name: string; + namespace_name: string; + alias_name: string; +} + +type expanded_snapshot = { + raw_signature: signature; + expanded_signature: signature; + target_components: module_components_repr option; + alias_components: module_components_repr option; + target_ids: allocation_stage; + signature_ids: allocation_stage; + alias_ids: allocation_stage; + crcs: (string * Digest.t option) list; + flags: pers_flags list; +} + +type request_snapshot = { + key: alias_key; + graph: expanded_snapshot; + mutable target_relocated: bool; + mutable signature_relocated: bool; + mutable alias_relocated: bool; +} + +let capture_allocation_stage action = + let state = Compiler_request_state.current () in + let first_type_id = state.type_node_id in + let first_ident_stamp = Ident.current_time () in + let (result, identifiers), type_nodes = + Btype.with_allocation_capture (fun () -> + Ident.with_allocation_capture action) + in + let allocated_type_ids = state.type_node_id - first_type_id in + let allocated_ident_stamps = Ident.current_time () - first_ident_stamp in + if + Array.length type_nodes <> allocated_type_ids + || Array.length identifiers <> allocated_ident_stamps + then invalid_arg "incomplete dependency allocation capture"; + ( result, + { + first_type_id; + allocated_type_ids; + type_nodes; + first_ident_stamp; + allocated_ident_stamps; + identifiers; + } ) + +(* A cache entry is exclusive to one compiler domain. The graph is visible to + only one request at a time, and its IDs are reset before it can be reused. *) +let relocate_allocation_stage stage = + let state = Compiler_request_state.current () in + let first_type_id = state.type_node_id in + let first_ident_stamp = Ident.current_time () in + Array.iteri + (fun index ty -> ty.id <- first_type_id + index + 1) + stage.type_nodes; + Array.iteri + (fun index id -> id.Ident.stamp <- first_ident_stamp + index + 1) + stage.identifiers; + state.type_node_id <- first_type_id + stage.allocated_type_ids; + Ident.set_current_time (first_ident_stamp + stage.allocated_ident_stamps) + +let reset_allocation_stage stage = + Array.iteri + (fun index ty -> ty.id <- stage.first_type_id + index + 1) + stage.type_nodes; + Array.iteri + (fun index id -> id.Ident.stamp <- stage.first_ident_stamp + index + 1) + stage.identifiers + type pers_struct = { ps_name: string; ps_sig: signature Lazy.t; @@ -612,6 +750,9 @@ type pers_struct = { ps_crcs: (string * Digest.t option) list; ps_filename: string; ps_flags: pers_flags list; + ps_snapshot: request_snapshot option; + ps_frozen_values: Frozen_values.view option; + ps_frozen_components: (Path.t, module_components) Hashtbl.t; } [@@warning "-69"] @@ -620,6 +761,268 @@ let persistent_structures_key = (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t)) let persistent_structures () = Domain.DLS.get persistent_structures_key +let same_file_stats first second = + first.Unix.st_dev = second.Unix.st_dev + && first.Unix.st_ino = second.Unix.st_ino + && first.Unix.st_size = second.Unix.st_size + && first.Unix.st_mtime = second.Unix.st_mtime + && first.Unix.st_ctime = second.Unix.st_ctime + +type frozen_values_entry = { + resolved_filename: string; + stats: Unix.stats; + image: Frozen_values.t; + crcs: (string * Digest.t option) list; + flags: Cmi_format.pers_flags list; +} + +type frozen_values_cache = { + lock: Mutex.t; + entries: (string, frozen_values_entry) Hashtbl.t; +} + +let frozen_values_cache_key : frozen_values_cache option Domain.DLS.key = + Domain.DLS.new_key (fun () -> None) + +type published_cmi = { + filename: string; + stats: Unix.stats; + name: string; + fingerprint: Digest.t; + crcs: (string * Digest.t option) list; + flags: Cmi_format.pers_flags list; + image: Frozen_values.t; +} + +type pending_cmi = { + destination: string; + source: string; + source_stats: Unix.stats; + value: published_cmi; +} + +type published_cmis = { + lock: Mutex.t; + entries: (string, published_cmi) Hashtbl.t; + pending: (string, pending_cmi) Hashtbl.t; +} + +let published_cmis_key : published_cmis option Domain.DLS.key = + Domain.DLS.new_key (fun () -> None) + +let frozen_values_setting_key = Domain.DLS.new_key (fun () -> None) +let frozen_type_cache_key = + Domain.DLS.new_key (fun () -> + (Hashtbl.create 64 + : ( Path.t, + type_declaration + * (constructor_description list * label_description list) ) + Hashtbl.t)) + +let frozen_values_enabled () = + match Domain.DLS.get frozen_values_setting_key with + | Some enabled -> enabled + | None -> Sys.getenv_opt "REWATCH_FROZEN_VALUES" = Some "1" + +let with_frozen_values_setting ?enabled action = + let previous = Domain.DLS.get frozen_values_setting_key in + let enabled = + Option.value enabled + ~default:(Sys.getenv_opt "REWATCH_FROZEN_VALUES" = Some "1") + in + Domain.DLS.set frozen_values_setting_key (Some enabled); + Fun.protect action ~finally:(fun () -> + Domain.DLS.set frozen_values_setting_key previous) + +let session_cmi_enabled () = + frozen_values_enabled () && Sys.getenv_opt "REWATCH_SESSION_CMI" <> Some "0" + +let has_published_cmi name = + if not (session_cmi_enabled ()) then false + else + match Domain.DLS.get published_cmis_key with + | None -> false + | Some published -> + Mutex.lock published.lock; + Fun.protect + (fun () -> + Hashtbl.mem published.entries name + || Hashtbl.mem published.pending name) + ~finally:(fun () -> Mutex.unlock published.lock) + +let pending_cmi_path name = + match Domain.DLS.get published_cmis_key with + | None -> None + | Some published -> + let pending = + Mutex.lock published.lock; + Fun.protect + (fun () -> Hashtbl.find_opt published.pending name) + ~finally:(fun () -> Mutex.unlock published.lock) + in + Option.bind pending (fun entry -> + try + if same_file_stats (Unix.stat entry.source) entry.source_stats then + Some entry.destination + else None + with Sys_error _ | Unix.Unix_error _ -> None) + +let find_in_path_with_pending name = + let pending = pending_cmi_path (Filename.remove_extension name) in + let is_pending filename = + match pending with + | Some path -> Compiler_request_state.same_output_path filename path + | None -> false + in + let lower_name = String.uncapitalize_ascii name in + let rec find = function + | [] -> raise Not_found + | directory :: rest -> + let lower = Filename.concat directory lower_name in + let exact = Filename.concat directory name in + if is_pending lower then lower + else if is_pending exact then + if + Compiler_request_state.is_regular_file lower + && Compiler_request_state.has_exact_directory_entry lower + then lower + else exact + else if Compiler_request_state.is_regular_file lower then lower + else if Compiler_request_state.is_regular_file exact then exact + else find rest + in + find (Config.get_load_path ()) + +let find_compiled_cmi name = + if session_cmi_enabled () && has_published_cmi name then + find_in_path_with_pending (name ^ ".cmi") + else find_in_path_uncap (Config.get_load_path ()) (name ^ ".cmi") + +let lookup_published_cmi name filename = + if not (session_cmi_enabled ()) then None + else + match Domain.DLS.get published_cmis_key with + | None -> None + | Some published -> ( + try + Mutex.lock published.lock; + Fun.protect + (fun () -> + let current = + match Hashtbl.find_opt published.pending name with + | Some pending + when Compiler_request_state.same_output_path pending.destination + filename + && same_file_stats (Unix.stat pending.source) + pending.source_stats -> + Some pending.value + | Some _ | None -> ( + match Hashtbl.find_opt published.entries name with + | Some entry + when Compiler_request_state.same_output_path entry.filename + filename + && same_file_stats + (Unix.stat + (Compiler_request_state.resolve_path filename)) + entry.stats -> + Some entry + | Some _ | None -> None) + in + match current with + | Some entry -> + Compiler_phase_trace.dependency "dependency.session_cmi_lookup" + (fun () -> + let cmi = + Cmi_format. + { + cmi_name = entry.name; + cmi_sign = []; + cmi_crcs = entry.crcs; + cmi_flags = entry.flags; + } + in + Some (cmi, entry.image)) + | None -> None) + ~finally:(fun () -> Mutex.unlock published.lock) + with Sys_error _ | Unix.Unix_error _ -> None) + +let compiled_cmi_capture_key = Domain.DLS.new_key (fun () -> None) + +let with_compiled_cmi_capture capture action = + let previous = Domain.DLS.get compiled_cmi_capture_key in + Domain.DLS.set compiled_cmi_capture_key (Some capture); + Fun.protect action ~finally:(fun () -> + Domain.DLS.set compiled_cmi_capture_key previous) + +let prepare_frozen_values ~name ~filename cmi = + if not (frozen_values_enabled ()) then None + else + match Domain.DLS.get frozen_values_cache_key with + | None -> None + | Some cache -> ( + try + let resolved_filename = Compiler_request_state.resolve_path filename in + let stats = Unix.stat resolved_filename in + Mutex.lock cache.lock; + Fun.protect + (fun () -> + match Hashtbl.find_opt cache.entries name with + | Some entry + when entry.resolved_filename = resolved_filename + && same_file_stats entry.stats stats -> + Some entry.image + | _ -> + Compiler_phase_trace.dependency "dependency.frozen_values_prepare" + (fun () -> + match Frozen_values.freeze cmi with + | Error _ -> None + | Ok image -> + if same_file_stats (Unix.stat resolved_filename) stats then ( + Hashtbl.replace cache.entries name + { + resolved_filename; + stats; + image; + crcs = cmi.cmi_crcs; + flags = cmi.cmi_flags; + }; + Some image) + else None)) + ~finally:(fun () -> Mutex.unlock cache.lock) + with Sys_error _ | Unix.Unix_error _ -> None) + +let lookup_cached_frozen_values ~name ~filename = + if not (frozen_values_enabled ()) then None + else + match Domain.DLS.get frozen_values_cache_key with + | None -> None + | Some cache -> ( + try + let resolved_filename = Compiler_request_state.resolve_path filename in + let stats = Unix.stat resolved_filename in + Mutex.lock cache.lock; + Fun.protect + (fun () -> + match Hashtbl.find_opt cache.entries name with + | Some entry + when entry.resolved_filename = resolved_filename + && same_file_stats entry.stats stats -> + Compiler_phase_trace.dependency "dependency.frozen_cmi_lookup" + (fun () -> + let cmi = + Cmi_format. + { + cmi_name = name; + cmi_sign = []; + cmi_crcs = entry.crcs; + cmi_flags = entry.flags; + } + in + Some (cmi, entry.image)) + | Some _ | None -> None) + ~finally:(fun () -> Mutex.unlock cache.lock) + with Sys_error _ | Unix.Unix_error _ -> None) + (* Consistency between persistent structures *) let crc_units_key = Domain.DLS.new_key Consistbl.create @@ -640,17 +1043,18 @@ let clear_imports () = imported_units () := String_set.empty let check_consistency ps = - try - List.iter - (fun (name, crco) -> - match crco with - | None -> () - | Some crc -> - add_import name; - Consistbl.check (crc_units ()) name crc ps.ps_filename) - ps.ps_crcs - with Consistbl.Inconsistency (name, source, auth) -> - error (Inconsistent_import (name, auth, source)) + Compiler_phase_trace.dependency "dependency.consistency" (fun () -> + try + List.iter + (fun (name, crco) -> + match crco with + | None -> () + | Some crc -> + add_import name; + Consistbl.check (crc_units ()) name crc ps.ps_filename) + ps.ps_crcs + with Consistbl.Inconsistency (name, source, auth) -> + error (Inconsistent_import (name, auth, source))) (* Reading persistent structures from .cmi files *) @@ -673,42 +1077,84 @@ module Persistent_signature = struct | exception Not_found -> None) end -let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = - let name = cmi.cmi_name in - let sign = cmi.cmi_sign in - let crcs = cmi.cmi_crcs in - let flags = cmi.cmi_flags in - let deprecated = - List.fold_left - (fun _ -> function - | Deprecated s -> Some s) - None flags - in - let comps = - !components_of_module' ~deprecated ~loc:Location.none empty Subst.identity - (Pident (Ident.create_persistent name)) - (Mty_signature sign) - in - let ps = - { - ps_name = name; - ps_sig = lazy (Subst.signature Subst.identity sign); - ps_comps = comps; - ps_crcs = crcs; - ps_filename = filename; - ps_flags = flags; - } - in - if ps.ps_name <> modname then - error (Illegal_renaming (modname, ps.ps_name, filename)); - if check then check_consistency ps; - Hashtbl.add (persistent_structures ()) modname (Some ps); - ps +let cached_pers_struct_loader : + (check:bool -> name:string -> pers_struct option) ref = + ref (fun ~check:_ ~name:_ -> None) + +let cached_cmi_loader : + (name:string -> Persistent_signature.t option option) ref = + ref (fun ~name:_ -> None) + +let acknowledge_pers_struct ?published_image check modname + {Persistent_signature.filename; cmi} = + Compiler_phase_trace.dependency "dependency.make_available" (fun () -> + let name = cmi.cmi_name in + let sign = cmi.cmi_sign in + let crcs = cmi.cmi_crcs in + let flags = cmi.cmi_flags in + let frozen_values = + (match published_image with + | Some image -> Some image + | None -> prepare_frozen_values ~name ~filename cmi) + |> Option.map Frozen_values.create_view + in + let deprecated = + List.fold_left + (fun _ -> function + | Deprecated s -> Some s) + None flags + in + let comps = + !components_of_module' ~deprecated ~loc:Location.none empty + Subst.identity + (Pident (Ident.create_persistent name)) + (Mty_signature (if Option.is_some frozen_values then [] else sign)) + in + let comps = + match frozen_values with + | Some view -> {comps with frozen_root = Some view} + | None -> comps + in + let ps = + { + ps_name = name; + ps_sig = + lazy + (Compiler_phase_trace.dependency_lazy + (fun () -> "dependency.signature_copy:" ^ name) + (fun () -> + match frozen_values with + | Some view -> Frozen_values.copy_signature view + | None -> Subst.signature Subst.identity sign)); + ps_comps = comps; + ps_crcs = crcs; + ps_filename = filename; + ps_flags = flags; + ps_snapshot = None; + ps_frozen_values = frozen_values; + ps_frozen_components = Hashtbl.create 8; + } + in + if ps.ps_name <> modname then + error (Illegal_renaming (modname, ps.ps_name, filename)); + if check then check_consistency ps; + Hashtbl.add (persistent_structures ()) modname (Some ps); + ps) let read_pers_struct check modname filename = add_import modname; - let cmi = read_cmi filename in - acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} + let cached = + match lookup_published_cmi modname filename with + | Some _ as published -> published + | None -> lookup_cached_frozen_values ~name:modname ~filename + in + match cached with + | Some (cmi, image) -> + acknowledge_pers_struct ~published_image:image check modname + {Persistent_signature.filename; cmi} + | None -> + let cmi = read_cmi filename in + acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} let find_pers_struct check name = if name = "*predef*" then raise Not_found; @@ -718,16 +1164,59 @@ let find_pers_struct check name = | exception Not_found -> ( match !(can_load_cmis ()) with | Cannot_load_cmis _ -> raise Not_found - | Can_load_cmis -> - let ps = - match !Persistent_signature.load ~unit_name:name with - | Some ps -> ps - | None -> - Hashtbl.add (persistent_structures ()) name None; - raise Not_found + | Can_load_cmis -> ( + let published = + if not (has_published_cmi name) then None + else + try + let filename = find_in_path_with_pending (name ^ ".cmi") in + Option.map + (fun (cmi, image) -> (filename, cmi, image)) + (lookup_published_cmi name filename) + with Not_found -> None in - add_import name; - acknowledge_pers_struct check name ps) + match published with + | Some (filename, cmi, image) -> + add_import name; + acknowledge_pers_struct ~published_image:image check name + {Persistent_signature.filename; cmi} + | None -> ( + let cached_frozen = + if not (frozen_values_enabled ()) then None + else + try + let filename = find_compiled_cmi name in + Option.map + (fun (cmi, image) -> (filename, cmi, image)) + (lookup_cached_frozen_values ~name ~filename) + with Not_found -> None + in + match cached_frozen with + | Some (filename, cmi, image) -> + add_import name; + acknowledge_pers_struct ~published_image:image check name + {Persistent_signature.filename; cmi} + | None -> ( + match !cached_pers_struct_loader ~check ~name with + | Some ps -> + add_import name; + if check then check_consistency ps; + Hashtbl.add (persistent_structures ()) name (Some ps); + ps + | None -> + let ps = + match + match !cached_cmi_loader ~name with + | Some cached -> cached + | None -> !Persistent_signature.load ~unit_name:name + with + | Some ps -> ps + | None -> + Hashtbl.add (persistent_structures ()) name None; + raise Not_found + in + add_import name; + acknowledge_pers_struct check name ps)))) (* Emits a warning if there is no valid cmi for name *) let check_pers_struct name = @@ -772,6 +1261,7 @@ let reset_cache () = clear_imports (); Hashtbl.clear (value_declarations ()); Hashtbl.clear (type_declarations ()); + Hashtbl.clear (Domain.DLS.get frozen_type_cache_key); Hashtbl.clear (module_declarations ()); Hashtbl.clear (used_constructors ()); Hashtbl.clear (prefixed_sg ()) @@ -796,6 +1286,34 @@ let get_unit_name () = !(current_unit ()) (* Lookup by identifier *) +let find_frozen_scope_path path = + if not (frozen_values_enabled ()) then None + else + let rec find visited path = + if List.exists (Path.same path) visited then None + else + let visited = path :: visited in + match path with + | Pident id + when Ident.persistent id && Ident.name id <> !(current_unit ()) -> + let ps = find_pers_struct (Ident.name id) in + Option.map + (fun view -> (view, Frozen_values.root_scope view)) + ps.ps_frozen_values + | Pdot (parent, name, _) -> ( + match find visited parent with + | Some (view, scope) -> ( + match Frozen_values.find_module scope name with + | Some (nested, _, _, _) -> Some (view, nested) + | None -> ( + match Frozen_values.find_module_alias view scope name with + | Some target -> find visited target + | None -> None)) + | None -> None) + | Pident _ | Papply _ -> None + in + find [] path + let rec find_module_descr path env = match path with | Pident id -> ( @@ -805,11 +1323,34 @@ let rec find_module_descr path env = (find_pers_struct (Ident.name id)).ps_comps else raise Not_found) | Pdot (p, s, _pos) -> ( - match get_components (find_module_descr p env) with - | Structure_comps c -> - let descr, _pos = Tbl.find_str s c.comp_components in - descr - | Functor_comps _ -> raise Not_found) + let generic () = + match get_components (find_module_descr p env) with + | Structure_comps c -> + let descr, _pos = Tbl.find_str s c.comp_components in + descr + | Functor_comps _ -> raise Not_found + in + match find_frozen_scope_path p with + | Some (view, scope) -> ( + match Frozen_values.find_module_declaration view scope s with + | Some (declaration, position) -> ( + let path = Pdot (p, s, position) in + let ps = find_pers_struct (Ident.name (Path.head p)) in + match Hashtbl.find_opt ps.ps_frozen_components path with + | Some components -> components + | None -> + let components = + !components_of_module' + ~deprecated: + (Builtin_attributes.deprecated_of_attrs + declaration.md_attributes) + ~loc:declaration.md_loc empty Subst.identity path + declaration.md_type + in + Hashtbl.add ps.ps_frozen_components path components; + components) + | None -> generic ()) + | None -> generic ()) | Papply (p1, p2) -> ( match get_components (find_module_descr p1 env) with | Functor_comps f -> !components_of_functor_appl' f env p1 p2 @@ -826,22 +1367,83 @@ let find proj1 proj2 path env = | Functor_comps _ -> raise Not_found) | Papply _ -> raise Not_found -let find_value = find (fun env -> env.values) (fun sc -> sc.comp_values) +let find_value_generic = find (fun env -> env.values) (fun sc -> sc.comp_values) -and find_type_full = find (fun env -> env.types) (fun sc -> sc.comp_types) +let find_value path env = + if not (frozen_values_enabled ()) then find_value_generic path env + else + match path with + | Pdot (module_path, name, _) -> ( + match find_frozen_scope_path module_path with + | Some (view, scope) -> ( + match + Compiler_phase_trace.dependency "dependency.frozen_value_lookup" + (fun () -> Frozen_values.find_in_scope view scope name) + with + | Some (description, _) -> description + | None -> find_value_generic path env) + | None -> find_value_generic path env) + | _ -> find_value_generic path env -and find_modtype = find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) +and find_type_full_generic = + find (fun env -> env.types) (fun sc -> sc.comp_types) + +and find_modtype path env = + match path with + | Pdot (module_path, name, _) -> ( + match find_frozen_scope_path module_path with + | Some (view, scope) -> ( + match Frozen_values.find_modtype_declaration view scope name with + | Some declaration -> declaration + | None -> + find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) path env) + | None -> + find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) path env) + | Pident _ | Papply _ -> + find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) path env let type_of_cstr path = function | {cstr_inlined = Some d; _} -> (d, ([], List.map snd (Datarepr.labels_of_type path d))) | _ -> assert false -let find_type_full path env = +let find_frozen_type path = + if not (frozen_values_enabled ()) then None + else + let cache = Domain.DLS.get frozen_type_cache_key in + match Hashtbl.find_opt cache path with + | Some declaration -> Some declaration + | None -> + let declaration = + match path with + | Pdot (module_path, name, _) -> ( + match find_frozen_scope_path module_path with + | Some (view, scope) -> + Compiler_phase_trace.dependency "dependency.frozen_type_lookup" + (fun () -> Frozen_values.find_type_in_scope view scope name) + | None -> None) + | Pident _ | Papply _ -> None + in + Option.iter (Hashtbl.replace cache path) declaration; + declaration + +let find_frozen_extension mod_path name = + if not (frozen_values_enabled ()) then None + else + match find_frozen_scope_path mod_path with + | Some (view, scope) -> + Compiler_phase_trace.dependency "dependency.frozen_extension_lookup" + (fun () -> Frozen_values.find_extension_in_scope view scope name) + | None -> None + +let rec find_type_full path env = match Path.constructor_typath path with | Regular p -> ( try (Path_map.find p env.local_constraints, ([], [])) - with Not_found -> find_type_full p env) + with Not_found -> ( + match find_frozen_type p with + | Some declaration -> declaration + | None -> find_type_full_generic p env)) | Cstr (ty_path, s) -> let _, (cstrs, _) = try find_type_full ty_path env with Not_found -> assert false @@ -857,25 +1459,29 @@ let find_type_full path env = in type_of_cstr path cstr | Ext (mod_path, s) -> ( - let comps = - try find_module_descr mod_path env with Not_found -> assert false - in - let comps = - match get_components comps with - | Structure_comps c -> c - | Functor_comps _ -> assert false - in - let exts = - Ext_list.filter - (try Tbl.find_str s comps.comp_constrs with Not_found -> assert false) - (function - | {cstr_kind = Extension_constructor _} -> true - | _ -> false) - in + match find_frozen_extension mod_path s with + | Some constructor -> type_of_cstr path constructor + | None -> ( + let comps = + try find_module_descr mod_path env with Not_found -> assert false + in + let comps = + match get_components comps with + | Structure_comps c -> c + | Functor_comps _ -> assert false + in + let exts = + Ext_list.filter + (try Tbl.find_str s comps.comp_constrs + with Not_found -> assert false) + (function + | {cstr_kind = Extension_constructor _} -> true + | _ -> false) + in - match exts with - | [cstr] -> type_of_cstr path cstr - | _ -> assert false) + match exts with + | [cstr] -> type_of_cstr path cstr + | _ -> assert false)) let find_type p env = fst (find_type_full p env) let find_type_descrs p env = snd (find_type_full p env) @@ -892,11 +1498,22 @@ let find_module ~alias path env = md (Mty_signature (Lazy.force ps.ps_sig)) else raise Not_found) | Pdot (p, s, _pos) -> ( - match get_components (find_module_descr p env) with - | Structure_comps c -> - let data, _pos = Tbl.find_str s c.comp_modules in - Env_lazy.force subst_modtype_maker data - | Functor_comps _ -> raise Not_found) + match find_frozen_scope_path p with + | Some (view, scope) -> ( + match Frozen_values.find_module_declaration view scope s with + | Some (declaration, _) -> declaration + | None -> ( + match get_components (find_module_descr p env) with + | Structure_comps c -> + let data, _pos = Tbl.find_str s c.comp_modules in + Env_lazy.force subst_modtype_maker data + | Functor_comps _ -> raise Not_found)) + | None -> ( + match get_components (find_module_descr p env) with + | Structure_comps c -> + let data, _pos = Tbl.find_str s c.comp_modules in + Env_lazy.force subst_modtype_maker data + | Functor_comps _ -> raise Not_found)) | Papply (p1, p2) -> ( let desc1 = find_module_descr p1 env in match get_components desc1 with @@ -927,9 +1544,42 @@ let rec normalize_path lax env path = | _ -> path in try - match find_module ~alias:true path env with - | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 - | _ -> path + match path with + | Pdot (parent, name, _) when lax -> ( + match find_frozen_scope_path parent with + | Some (view, scope) -> ( + match Frozen_values.find_module_alias view scope name with + | Some target -> normalize_path lax env target + | None -> ( + if + Option.is_some (Frozen_values.find_module scope name) + || Frozen_values.is_type_name_in_scope scope name + then path + else + match find_module ~alias:true path env with + | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 + | _ -> path)) + | None -> ( + match find_module ~alias:true path env with + | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 + | _ -> path)) + | Pident id when Ident.persistent id && Ident.name id <> !(current_unit ()) + -> ( + match Id_tbl.find_same id env.modules with + | _ -> ( + match find_module ~alias:true path env with + | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 + | _ -> path) + | exception Not_found -> + (* A compiled unit's root is a signature, never a module alias. + Loading it validates the dependency without copying its entire + signature just to normalize a value access path. *) + ignore (find_pers_struct (Ident.name id)); + path) + | Pident _ | Pdot _ | Papply _ -> ( + match find_module ~alias:true path env with + | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 + | _ -> path) with | Not_found when lax @@ -1032,6 +1682,44 @@ let rec lookup_module_descr_aux ?loc lid env = (Pdot (p, s, pos), descr) | Functor_comps _ -> raise Not_found) +and lookup_frozen_scope ?loc lid env = + if not (frozen_values_enabled ()) then None + else + match lid with + | Lident name -> ( + let path, _ = lookup_module_descr ?loc lid env in + match path with + | Pident id when Ident.persistent id -> + let ps = find_pers_struct name in + Option.map + (fun view -> (path, view, Frozen_values.root_scope view)) + ps.ps_frozen_values + | Pident _ | Pdot _ | Papply _ -> None) + | Ldot (parent, name) -> ( + match lookup_frozen_scope ?loc parent env with + | Some (parent_path, view, scope) -> ( + match Frozen_values.find_module scope name with + | Some (nested, position, module_loc, deprecated) -> + let path = Pdot (parent_path, name, position) in + mark_module_used env name module_loc; + report_deprecated ?loc path deprecated; + Some (path, view, nested) + | None -> ( + match + ( Frozen_values.find_module_info scope name, + Frozen_values.find_module_alias view scope name ) + with + | Some (position, module_loc, deprecated), Some target -> ( + match find_frozen_scope_path target with + | Some (target_view, target_scope) -> + let path = Pdot (parent_path, name, position) in + mark_module_used env name module_loc; + report_deprecated ?loc path deprecated; + Some (path, target_view, target_scope) + | None -> None) + | _ -> None)) + | None -> None) + and lookup_module_descr ?loc lid env = let ((p, comps) as res) = lookup_module_descr_aux ?loc lid env in mark_module_used env (Path.last p) comps.loc; @@ -1070,16 +1758,36 @@ and lookup_module ~load ?loc lid env : Path.t = report_deprecated ?loc p ps.ps_comps.deprecated); p) | Ldot (l, s) -> ( - let p, descr = lookup_module_descr ?loc l env in - match get_components descr with - | Structure_comps c -> - let _data, pos = Tbl.find_str s c.comp_modules in - let comps, _ = Tbl.find_str s c.comp_components in - mark_module_used env s comps.loc; - let p = Pdot (p, s, pos) in - report_deprecated ?loc p comps.deprecated; - p - | Functor_comps _ -> raise Not_found) + match lookup_frozen_scope ?loc l env with + | Some (parent_path, _, scope) -> ( + match Frozen_values.find_module_info scope s with + | Some (position, module_loc, deprecated) -> + let path = Pdot (parent_path, s, position) in + mark_module_used env s module_loc; + report_deprecated ?loc path deprecated; + path + | None -> ( + let p, descr = lookup_module_descr ?loc l env in + match get_components descr with + | Structure_comps c -> + let _data, pos = Tbl.find_str s c.comp_modules in + let comps, _ = Tbl.find_str s c.comp_components in + mark_module_used env s comps.loc; + let p = Pdot (p, s, pos) in + report_deprecated ?loc p comps.deprecated; + p + | Functor_comps _ -> raise Not_found)) + | None -> ( + let p, descr = lookup_module_descr ?loc l env in + match get_components descr with + | Structure_comps c -> + let _data, pos = Tbl.find_str s c.comp_modules in + let comps, _ = Tbl.find_str s c.comp_components in + mark_module_used env s comps.loc; + let p = Pdot (p, s, pos) in + report_deprecated ?loc p comps.deprecated; + p + | Functor_comps _ -> raise Not_found)) let lookup proj1 proj2 ?loc lid env = match lid with @@ -1120,20 +1828,100 @@ let cstr_shadow cstr1 cstr2 = let lbl_shadow _lbl1 _lbl2 = false -let lookup_value = lookup (fun env -> env.values) (fun sc -> sc.comp_values) -let lookup_all_constructors = +let lookup_value_generic = + lookup (fun env -> env.values) (fun sc -> sc.comp_values) + +let lookup_value ?loc lid env = + if not (frozen_values_enabled ()) then lookup_value_generic ?loc lid env + else + match lid with + | Longident.Ldot (module_lid, name) -> ( + match lookup_frozen_scope ?loc module_lid env with + | Some (module_path, view, scope) -> ( + match + Compiler_phase_trace.dependency "dependency.frozen_value_lookup" + (fun () -> Frozen_values.find_in_scope view scope name) + with + | Some (description, position) -> + (Pdot (module_path, name, position), description) + | None -> lookup_value_generic ?loc lid env) + | None -> lookup_value_generic ?loc lid env) + | Longident.Lident _ -> lookup_value_generic ?loc lid env +let lookup_all_constructors_generic = lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) cstr_shadow -let lookup_all_labels = + +let lookup_all_constructors ?loc lid env = + if not (frozen_values_enabled ()) then + lookup_all_constructors_generic ?loc lid env + else + match lid with + | Longident.Ldot (module_lid, name) -> ( + match lookup_frozen_scope ?loc module_lid env with + | Some (_, view, scope) -> ( + match + Compiler_phase_trace.dependency "dependency.frozen_constructor_lookup" + (fun () -> Frozen_values.find_constructors_in_scope view scope name) + with + | Some constructors -> + List.map (fun constructor -> (constructor, fun () -> ())) constructors + | None -> lookup_all_constructors_generic ?loc lid env) + | None -> lookup_all_constructors_generic ?loc lid env) + | Longident.Lident _ -> lookup_all_constructors_generic ?loc lid env +let lookup_all_labels_generic = lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) lbl_shadow -let lookup_type = lookup (fun env -> env.types) (fun sc -> sc.comp_types) -let lookup_modtype = - lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + +let lookup_all_labels ?loc lid env = + if not (frozen_values_enabled ()) then lookup_all_labels_generic ?loc lid env + else + match lid with + | Longident.Ldot (module_lid, name) -> ( + match lookup_frozen_scope ?loc module_lid env with + | Some (_, view, scope) -> ( + match + Compiler_phase_trace.dependency "dependency.frozen_label_lookup" + (fun () -> Frozen_values.find_labels_in_scope view scope name) + with + | Some labels -> List.map (fun label -> (label, fun () -> ())) labels + | None -> lookup_all_labels_generic ?loc lid env) + | None -> lookup_all_labels_generic ?loc lid env) + | Longident.Lident _ -> lookup_all_labels_generic ?loc lid env +let lookup_type_generic = + lookup (fun env -> env.types) (fun sc -> sc.comp_types) + +let lookup_type ?loc lid env = + if not (frozen_values_enabled ()) then lookup_type_generic ?loc lid env + else + match lid with + | Longident.Ldot (module_lid, name) -> ( + match lookup_frozen_scope ?loc module_lid env with + | Some (module_path, view, scope) -> ( + match + Compiler_phase_trace.dependency "dependency.frozen_type_lookup" + (fun () -> Frozen_values.find_type_in_scope view scope name) + with + | Some declaration -> (Pdot (module_path, name, nopos), declaration) + | None -> lookup_type_generic ?loc lid env) + | None -> lookup_type_generic ?loc lid env) + | Longident.Lident _ -> lookup_type_generic ?loc lid env +let lookup_modtype ?loc lid env = + let generic () = + lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) ?loc lid env + in + match lid with + | Lident _ -> generic () + | Ldot (module_lid, name) -> ( + match lookup_frozen_scope ?loc module_lid env with + | Some (module_path, view, scope) -> ( + match Frozen_values.find_modtype_declaration view scope name with + | Some declaration -> (Pdot (module_path, name, nopos), declaration) + | None -> generic ()) + | None -> generic ()) let copy_types l env = let f desc = @@ -1494,10 +2282,739 @@ let add_to_tbl id decl tbl = let decls = try Tbl.find_str id tbl with Not_found -> [] in Tbl.add id (decl :: decls) tbl +module Physical_type_table = Hashtbl.Make (struct + type t = type_expr + + let equal first second = first == second + let hash ty = ty.id +end) + +module Physical_ident_table = Hashtbl.Make (struct + type t = Ident.t + + let equal first second = first == second + let hash id = Hashtbl.hash (id.Ident.stamp, id.Ident.name) +end) + +module Physical_label_table = Hashtbl.Make (struct + type t = label_description + + let equal first second = first == second + let hash label = Hashtbl.hash (label.lbl_name, label.lbl_res.id) +end) + +type type_snapshot = { + nodes: (type_expr * type_desc * int * int) array; + identifiers: (Ident.t * int * int) array; + abbrevs: (abbrev_memo ref * abbrev_memo) array; + mutabilities: (field_mutability ref * field_mutability) array; + row_fields: (row_field option ref * row_field option) array; + label_links: (label_description * label_description array) array; + label_arrays: (label_description array * label_description array) array; + layouts: (Variant_runtime.layout_ref * Variant_runtime.layout) array; + component_checks: (unit -> bool) array; + unsupported: bool; +} + +(* Track the mutable fields reachable from the cached signature and component + tables. Unsupported memo shapes make the entry ineligible for direct reuse. *) +let snapshot_type_graph ~raw_signature ~expanded_signature ~target_components + ~alias_components ~stages ~require_components = + let seen = Physical_type_table.create 32768 in + let seen_identifiers = Physical_ident_table.create 8192 in + let seen_label_arrays = Physical_label_table.create 1024 in + let abbrevs = ref [] in + let mutabilities = ref [] in + let row_fields = ref [] in + let label_links = ref [] in + let label_arrays = ref [] in + let layouts = ref [] in + let component_checks = ref [] in + let unsupported = ref false in + let visit_ident id = Physical_ident_table.replace seen_identifiers id () in + let rec visit_path = function + | Pident id -> visit_ident id + | Pdot (path, _, _) -> visit_path path + | Papply (first, second) -> + visit_path first; + visit_path second + in + let visit_abbrev = function + | Mnil -> () + | Mcons _ | Mlink _ -> unsupported := true + in + let rec visit_mutability depth reference = + if depth > 128 then unsupported := true + else ( + mutabilities := (reference, !reference) :: !mutabilities; + match !reference with + | Mutability_value _ -> () + | Mutability_link next -> visit_mutability (depth + 1) next) + in + let rec visit_row_field depth field = + if depth > 128 then unsupported := true + else + match field with + | Reither (_, _, _, reference) -> + row_fields := (reference, !reference) :: !row_fields; + Option.iter (visit_row_field (depth + 1)) !reference + | Rpresent _ | Rabsent -> () + in + let visit_layout reference = + try layouts := (reference, Variant_runtime.get_layout reference) :: !layouts + with Failure _ -> unsupported := true + in + let visit_record_representation = function + | Record_inlined {representation} -> visit_layout representation.variant + | Record_regular | Record_float_unused | Record_unboxed _ | Record_extension + -> + () + in + let rec visit ty = + if not (Physical_type_table.mem seen ty) then ( + Physical_type_table.add seen ty (); + (match ty.desc with + | Tconstr (path, _, reference) -> + visit_path path; + abbrevs := (reference, !reference) :: !abbrevs; + visit_abbrev !reference + | Tfield {mutability} -> visit_mutability 0 mutability + | Tvariant row -> + List.iter (fun (_, field) -> visit_row_field 0 field) row.row_fields; + Option.iter (fun (path, _) -> visit_path path) row.row_name + | Tpackage (path, _, _) -> visit_path path + | Tvar _ | Tarrow _ | Ttuple _ | Tobject _ | Tnil | Tlink _ | Tsubst _ + | Tunivar _ | Tpoly _ -> + ()); + Btype.iter_type_expr visit ty) + in + let original = Btype.type_iterators in + let iterator = + { + original with + it_type_expr = (fun _ ty -> visit ty); + it_type_declaration = + (fun iterator declaration -> + (match declaration.type_kind with + | Type_variant (_, reference) -> visit_layout reference + | Type_abstract | Type_record _ | Type_open -> ()); + original.it_type_declaration iterator declaration); + } + in + let visit_label_declaration declaration = visit_ident declaration.ld_id in + let visit_constructor_declaration declaration = + visit_ident declaration.cd_id; + match declaration.cd_args with + | Cstr_tuple _ -> () + | Cstr_record labels -> List.iter visit_label_declaration labels + in + let visit_type_declaration declaration = + (match declaration.type_kind with + | Type_variant (constructors, _) -> + List.iter visit_constructor_declaration constructors + | Type_record (labels, representation) -> + List.iter visit_label_declaration labels; + visit_record_representation representation + | Type_abstract | Type_open -> ()); + List.iter + (function + | Record {labels} -> List.iter visit_label_declaration labels) + declaration.type_inlined_types + in + let rec visit_module_type = function + | Mty_ident path | Mty_alias (_, path) -> visit_path path + | Mty_signature signature -> List.iter visit_signature_item signature + | Mty_functor (id, argument, result) -> + visit_ident id; + Option.iter visit_module_type argument; + visit_module_type result + and visit_signature_item = function + | Sig_value (id, _) -> visit_ident id + | Sig_type (id, declaration, _) -> + visit_ident id; + visit_type_declaration declaration + | Sig_typext (id, extension, _) -> ( + visit_ident id; + visit_path extension.ext_type_path; + match extension.ext_args with + | Cstr_tuple _ -> () + | Cstr_record labels -> List.iter visit_label_declaration labels) + | Sig_module (id, declaration, _) -> + visit_ident id; + visit_module_type declaration.md_type + | Sig_modtype (id, declaration) -> + visit_ident id; + Option.iter visit_module_type declaration.mtd_type + in + iterator.it_signature iterator raw_signature; + iterator.it_signature iterator expanded_signature; + List.iter visit_signature_item raw_signature; + List.iter visit_signature_item expanded_signature; + List.iter (fun stage -> Array.iter visit stage.type_nodes) stages; + let capture_components = function + | Some (Structure_comps components) -> + let values = components.comp_values in + let constrs = components.comp_constrs in + let labels_table = components.comp_labels in + let types = components.comp_types in + let modules = components.comp_modules in + let modtypes = components.comp_modtypes in + let nested = components.comp_components in + component_checks := + (fun () -> + components.comp_values == values + && components.comp_constrs == constrs + && components.comp_labels == labels_table + && components.comp_types == types + && components.comp_modules == modules + && components.comp_modtypes == modtypes + && components.comp_components == nested) + :: !component_checks; + Tbl.iter (fun _ (description, _) -> visit description.val_type) values; + Tbl.iter + (fun _ descriptions -> + List.iter + (fun label -> + visit label.lbl_res; + visit label.lbl_arg; + let all = label.lbl_all in + visit_record_representation label.lbl_repres; + if Array.length all = 0 then + label_links := (label, all) :: !label_links + else + let first = all.(0) in + if not (Physical_label_table.mem seen_label_arrays first) then ( + Physical_label_table.add seen_label_arrays first (); + label_arrays := (all, Array.copy all) :: !label_arrays; + Array.iter + (fun member -> + label_links := (member, member.lbl_all) :: !label_links) + all)) + descriptions) + labels_table; + Tbl.iter + (fun _ ((declaration, (constructors, labels)), _) -> + visit_type_declaration declaration; + iterator.it_type_declaration iterator declaration; + List.iter (fun description -> visit description.cstr_res) constructors; + List.iter + (fun description -> + visit description.lbl_res; + visit description.lbl_arg) + labels; + match declaration.type_kind with + | Type_variant (_, reference) -> visit_layout reference + | Type_abstract | Type_record _ | Type_open -> ()) + types; + Tbl.iter + (fun _ descriptions -> + List.iter + (fun description -> + visit description.cstr_res; + List.iter visit description.cstr_existentials; + List.iter visit description.cstr_args; + Option.iter + (fun declaration -> + iterator.it_type_declaration iterator declaration) + description.cstr_inlined; + match description.cstr_kind with + | Ordinary_constructor reference -> visit_layout reference.variant + | Extension_constructor path -> visit_path path) + descriptions) + constrs; + Tbl.iter + (fun _ (declaration, _) -> + Option.iter visit_module_type declaration.mtd_type; + Option.iter + (fun module_type -> iterator.it_module_type iterator module_type) + declaration.mtd_type) + modtypes + | Some (Functor_comps _) -> unsupported := true + | None -> if require_components then unsupported := true + in + capture_components target_components; + capture_components alias_components; + List.iter + (fun (stage : allocation_stage) -> Array.iter visit_ident stage.identifiers) + stages; + let identifiers = + Physical_ident_table.to_seq_keys seen_identifiers + |> Seq.map (fun id -> (id, id.Ident.stamp, id.Ident.flags)) + |> Array.of_seq + in + { + nodes = + Physical_type_table.to_seq_keys seen + |> Seq.map (fun ty -> (ty, ty.desc, ty.level, ty.id)) + |> Array.of_seq; + identifiers; + abbrevs = Array.of_list !abbrevs; + mutabilities = Array.of_list !mutabilities; + row_fields = Array.of_list !row_fields; + label_links = Array.of_list !label_links; + label_arrays = Array.of_list !label_arrays; + layouts = Array.of_list !layouts; + component_checks = Array.of_list !component_checks; + unsupported = !unsupported; + } + +let snapshot_expanded_type_graph graph = + snapshot_type_graph ~raw_signature:graph.raw_signature + ~expanded_signature:graph.expanded_signature + ~target_components:graph.target_components + ~alias_components:graph.alias_components + ~stages:[graph.target_ids; graph.signature_ids; graph.alias_ids] + ~require_components:true + +let type_graph_unchanged snapshot = + (not snapshot.unsupported) + && Array.for_all + (fun (ty, desc, level, id) -> + ty.desc == desc && ty.level = level && ty.id = id) + snapshot.nodes + && Array.for_all + (fun (id, stamp, flags) -> + id.Ident.stamp = stamp && id.Ident.flags = flags) + snapshot.identifiers + && Array.for_all + (fun (reference, value) -> !reference == value) + snapshot.abbrevs + && Array.for_all + (fun (reference, value) -> !reference == value) + snapshot.mutabilities + && Array.for_all + (fun (reference, value) -> !reference == value) + snapshot.row_fields + && Array.for_all + (fun (label, array) -> label.lbl_all == array) + snapshot.label_links + && Array.for_all + (fun (array, contents) -> + Array.length array = Array.length contents + && Array.for_all2 ( == ) array contents) + snapshot.label_arrays + && Array.for_all + (fun (reference, layout) -> + Variant_runtime.get_layout reference == layout) + snapshot.layouts + && Array.for_all (fun check -> check ()) snapshot.component_checks + +type expanded_snapshot_cache_entry = { + key: alias_key; + target_filename: string; + namespace_filename: string; + resolved_load_path: string list; + target_stats: Unix.stats; + namespace_stats: Unix.stats; + bytes: string; + mutable graph: expanded_snapshot option; + mutable typed_integrity: type_snapshot option; + mutable in_use: bool; +} + +let expanded_snapshot_cache_key = Domain.DLS.new_key (fun () -> ref None) +let expanded_snapshot_cache () = Domain.DLS.get expanded_snapshot_cache_key + +(* The marshaled image is available to every project, while a decoded graph + moves between domains only through an exclusive project cache lease. The + lock also lets one worker prepare the shared image while others wait. *) +type shared_expanded_snapshot = { + key: alias_key; + target_filename: string; + namespace_filename: string; + resolved_load_path: string list; + target_stats: Unix.stats; + namespace_stats: Unix.stats; + bytes: string; +} + +let shared_expanded_snapshot = ref None +let shared_expanded_snapshot_lock = Mutex.create () + +(* Preparing a large graph costs more than one ordinary alias expansion. Wait + for a second compiler request across the process so one-off edits stay cheap. + An expanded graph remains exclusive to one compiler request at a time. *) +let expanded_snapshot_candidates = Hashtbl.create 8 +let expanded_snapshot_candidates_lock = Mutex.create () + +let candidate_seen_in_previous_request key filename request = + Mutex.lock expanded_snapshot_candidates_lock; + Fun.protect + (fun () -> + let candidate = (key, filename) in + let seen = + match Hashtbl.find_opt expanded_snapshot_candidates candidate with + | Some previous -> previous != request + | None -> false + in + Hashtbl.replace expanded_snapshot_candidates candidate request; + seen) + ~finally:(fun () -> Mutex.unlock expanded_snapshot_candidates_lock) + +let forget_snapshot_candidate key filename = + Mutex.lock expanded_snapshot_candidates_lock; + Fun.protect + (fun () -> Hashtbl.remove expanded_snapshot_candidates (key, filename)) + ~finally:(fun () -> Mutex.unlock expanded_snapshot_candidates_lock) + +let expanded_snapshot_enabled_key = Domain.DLS.new_key (fun () -> false) + +let with_expanded_snapshot_cache action = + let previous = Domain.DLS.get expanded_snapshot_enabled_key in + Domain.DLS.set expanded_snapshot_enabled_key true; + Fun.protect action ~finally:(fun () -> + Domain.DLS.set expanded_snapshot_enabled_key previous) + +let preparing_expanded_snapshot = Domain.DLS.new_key (fun () -> false) +let prepare_expanded_snapshot : (alias_key -> unit) ref = ref (fun _ -> ()) + +let expanded_snapshot_enabled () = + if frozen_values_enabled () then false + else + match Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" with + | Some "0" -> false + | Some ("force" | "force_typed" | "typed" | "audit") -> true + | _ -> Domain.DLS.get expanded_snapshot_enabled_key + +let typed_expanded_snapshot_reuse () = + not (Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" = Some "force") + +let audit_expanded_snapshot_reuse () = + Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" = Some "audit" + +let force_fresh_expanded_snapshot () = + Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" = Some "force" + +type cmi_cache_entry = { + resolved_filename: string; + stats: Unix.stats; + bytes: bytes; + mutable cmi: Cmi_format.cmi_infos; + mutable integrity: type_snapshot option; + mutable used: bool; +} + +type dependency_cache = { + mutex: Mutex.t; + mutable available: dependency_cache_table list; + frozen_values: frozen_values_cache; + published_cmis: published_cmis; +} + +and dependency_cache_table = { + cmis: (string, cmi_cache_entry) Hashtbl.t; + expanded_snapshot: expanded_snapshot_cache_entry option ref; +} + +let create_dependency_cache () = + { + mutex = Mutex.create (); + available = []; + frozen_values = {lock = Mutex.create (); entries = Hashtbl.create 32}; + published_cmis = + { + lock = Mutex.create (); + entries = Hashtbl.create 128; + pending = Hashtbl.create 32; + }; + } + +let make_published_cmi ~filename ~stats ~crc cmi image = + { + filename; + stats; + name = cmi.Cmi_format.cmi_name; + fingerprint = crc; + crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs; + flags = cmi.cmi_flags; + image; + } + +let publish_pending_compiled_cmi cache ~source ~destination ~crc cmi = + let destination = Compiler_request_state.canonical_output_path destination in + let source_stats = Unix.stat source in + match Frozen_values.freeze cmi with + | Error _ -> false + | Ok image -> + if not (same_file_stats (Unix.stat source) source_stats) then false + else + let value = + make_published_cmi ~filename:destination ~stats:source_stats ~crc cmi + image + in + Mutex.lock cache.published_cmis.lock; + Fun.protect + (fun () -> + Hashtbl.replace cache.published_cmis.pending value.name + {destination; source; source_stats; value}) + ~finally:(fun () -> Mutex.unlock cache.published_cmis.lock); + true + +let discard_pending_compiled_cmi cache ~filename = + let filename = Compiler_request_state.canonical_output_path filename in + let name = Filename.basename filename |> Filename.remove_extension in + Mutex.lock cache.published_cmis.lock; + Fun.protect + (fun () -> + match Hashtbl.find_opt cache.published_cmis.pending name with + | Some pending + when Compiler_request_state.same_output_path pending.destination + filename -> + Hashtbl.remove cache.published_cmis.pending name + | Some _ | None -> ()) + ~finally:(fun () -> Mutex.unlock cache.published_cmis.lock) + +let publish_compiled_cmi cache ~filename ~crc cmi = + let filename = Compiler_request_state.canonical_output_path filename in + let pending = + Mutex.lock cache.published_cmis.lock; + Fun.protect + (fun () -> + Hashtbl.find_opt cache.published_cmis.pending cmi.Cmi_format.cmi_name) + ~finally:(fun () -> Mutex.unlock cache.published_cmis.lock) + in + let image = + match pending with + | Some pending + when Compiler_request_state.same_output_path pending.destination filename + && pending.value.fingerprint = crc -> + Some pending.value.image + | Some _ | None -> ( + match Frozen_values.freeze cmi with + | Error _ -> None + | Ok image -> Some image) + in + Mutex.lock cache.published_cmis.lock; + Fun.protect + (fun () -> + Hashtbl.remove cache.published_cmis.pending cmi.Cmi_format.cmi_name; + Option.iter + (fun image -> + let stats = Unix.stat filename in + let entry = make_published_cmi ~filename ~stats ~crc cmi image in + Hashtbl.replace cache.published_cmis.entries entry.name entry) + image) + ~finally:(fun () -> Mutex.unlock cache.published_cmis.lock) + +let published_compiled_cmi cache ~filename = + let filename = Compiler_request_state.canonical_output_path filename in + let name = Filename.basename filename |> Filename.remove_extension in + let entry, pending = + Mutex.lock cache.published_cmis.lock; + Fun.protect + (fun () -> + ( Hashtbl.find_opt cache.published_cmis.entries name, + Hashtbl.find_opt cache.published_cmis.pending name )) + ~finally:(fun () -> Mutex.unlock cache.published_cmis.lock) + in + let pending_result = + Option.bind pending (fun pending -> + try + if + Compiler_request_state.same_output_path pending.destination filename + && same_file_stats (Unix.stat pending.source) pending.source_stats + then Some (pending.value.fingerprint, pending.value.image) + else None + with Sys_error _ | Unix.Unix_error _ -> None) + in + match pending_result with + | Some _ -> pending_result + | None -> + Option.bind entry (fun entry -> + try + if + Compiler_request_state.same_output_path entry.filename filename + && same_file_stats (Unix.stat filename) entry.stats + then Some (entry.fingerprint, entry.image) + else None + with Sys_error _ | Unix.Unix_error _ -> None) + +let cmi_cache_key = Domain.DLS.new_key (fun () -> Hashtbl.create 2) +let cmi_cache () = Domain.DLS.get cmi_cache_key + +let capture_cmi_integrity cmi = + let snapshot = + Compiler_phase_trace.dependency "dependency.cmi_cache_capture" (fun () -> + snapshot_type_graph ~raw_signature:cmi.Cmi_format.cmi_sign + ~expanded_signature:[] ~target_components:None ~alias_components:None + ~stages:[] ~require_components:false) + in + if snapshot.unsupported then None else Some snapshot + +(* Each decoded interface table belongs to one request at a time. A request + may mutate its graph, so [finalize_cmi_cache] restores the saved image before + the table returns to its project. Resolve the path on every hit to notice + newly shadowing or replaced CMIs after a watch edit. *) +let load_cached_cmi ~name = + if + (not + (Domain.DLS.get expanded_snapshot_enabled_key + || expanded_snapshot_enabled ())) + || Domain.DLS.get preparing_expanded_snapshot + || Sys.getenv_opt "REWATCH_PROJECT_CMI_CACHE" = Some "0" + && name <> "Stdlib" && name <> "Pervasives" + then None + else + let cache = cmi_cache () in + let load_fresh () = + let loaded = !Persistent_signature.load ~unit_name:name in + (match loaded with + | None -> () + | Some {filename; cmi} -> ( + let resolved_filename = Compiler_request_state.resolve_path filename in + try + let stats = Unix.stat resolved_filename in + let bytes = Marshal.to_bytes cmi [] in + if + Bytes.length bytes <= 64 * 1024 + && (Hashtbl.mem cache name || Hashtbl.length cache < 32) + && same_file_stats (Unix.stat resolved_filename) stats + then + Hashtbl.replace cache name + { + resolved_filename; + stats; + bytes; + cmi; + integrity = capture_cmi_integrity cmi; + used = true; + } + with Sys_error _ | Unix.Unix_error _ | Invalid_argument _ -> ())); + Some loaded + in + match Hashtbl.find_opt cache name with + | Some entry -> ( + try + let filename = + Compiler_phase_trace.dependency "dependency.cmi_cache_validate" + (fun () -> + find_in_path_uncap (Config.get_load_path ()) (name ^ ".cmi")) + in + if + Compiler_request_state.resolve_path filename = entry.resolved_filename + && same_file_stats (Unix.stat entry.resolved_filename) entry.stats + then ( + entry.used <- true; + Some (Some Persistent_signature.{filename; cmi = entry.cmi})) + else ( + Hashtbl.remove cache name; + load_fresh ()) + with Not_found | Sys_error _ | Unix.Unix_error _ -> + Hashtbl.remove cache name; + load_fresh ()) + | None -> load_fresh () + +let finalize_cmi_cache () = + Hashtbl.iter + (fun _ entry -> + if entry.used then ( + entry.used <- false; + let pristine = + Compiler_phase_trace.dependency "dependency.cmi_cache_verify" + (fun () -> + match entry.integrity with + | Some snapshot -> + let typed = type_graph_unchanged snapshot in + if + typed + && Sys.getenv_opt "REWATCH_PROJECT_CMI_CACHE" = Some "audit" + && not + (Bytes.equal (Marshal.to_bytes entry.cmi []) entry.bytes) + then failwith "typed CMI integrity check missed mutation"; + typed + | None -> ( + try Bytes.equal (Marshal.to_bytes entry.cmi []) entry.bytes + with Invalid_argument _ -> false)) + in + if not pristine then ( + entry.cmi <- Marshal.from_bytes entry.bytes 0; + entry.integrity <- capture_cmi_integrity entry.cmi))) + (cmi_cache ()) + +let () = cached_cmi_loader := load_cached_cmi + +let is_target_path name = function + | Pident id -> Ident.persistent id && Ident.name id = name + | Pdot _ | Papply _ -> false + +let alias_key_of_module path mty = + match (path, mty) with + | Pdot (Pident root, alias_name, _), Mty_alias (_, Pident target) + when Ident.persistent root && Ident.persistent target -> + Some + { + target_name = Ident.name target; + namespace_name = Ident.name root; + alias_name; + } + | _ -> None + +let is_alias_path key path mty = alias_key_of_module path mty = Some key + let rec components_of_module ~deprecated ~loc env sub path mty = - {deprecated; loc; comps = Env_lazy.create (env, sub, path, mty)} + { + deprecated; + loc; + frozen_root = None; + comps = Env_lazy.create (env, sub, path, mty); + } and components_of_module_maker (env, sub, path, mty) = + Compiler_phase_trace.dependency_lazy + (fun () -> + let origin = + match mty with + | Mty_alias (_, target) -> ":alias=" ^ Path.name target + | Mty_ident target -> ":ident=" ^ Path.name target + | Mty_signature _ -> ":signature" + | Mty_functor _ -> ":functor" + in + "dependency.expand_components:" ^ Path.name path ^ origin) + (fun () -> + if not (expanded_snapshot_enabled ()) then + components_of_module_maker_uncached (env, sub, path, mty) + else + let alias_key = alias_key_of_module path mty in + let target_name = + match path with + | Pident id when Ident.persistent id -> Some (Ident.name id) + | _ -> Option.map (fun key -> key.target_name) alias_key + in + let cached = + match target_name with + | Some target_name -> ( + try (find_pers_struct target_name).ps_snapshot + with Not_found -> None) + | None -> None + in + match cached with + | Some snapshot when is_target_path snapshot.key.target_name path -> + if not snapshot.target_relocated then ( + relocate_allocation_stage snapshot.graph.target_ids; + snapshot.target_relocated <- true); + snapshot.graph.target_components + | Some snapshot when is_alias_path snapshot.key path mty -> + ignore (Lazy.force (find_pers_struct snapshot.key.target_name).ps_sig); + if not snapshot.alias_relocated then ( + relocate_allocation_stage snapshot.graph.alias_ids; + snapshot.alias_relocated <- true); + snapshot.graph.alias_components + | _ -> + let result = + components_of_module_maker_uncached (env, sub, path, mty) + in + (match alias_key with + | Some key when not (Domain.DLS.get preparing_expanded_snapshot) -> ( + try !prepare_expanded_snapshot key + with + | Not_found | Sys_error _ | Unix.Unix_error _ | Cmi_format.Error _ + | Error _ | Invalid_argument _ + -> + ()) + | _ -> ()); + result) + +and components_of_module_maker_uncached (env, sub, path, mty) = match scrape_alias env mty with | Mty_signature sg -> let c = @@ -1514,60 +3031,82 @@ and components_of_module_maker (env, sub, path, mty) = let pl, sub = prefix_idents path sub sg in let env = ref env in let pos = ref 0 in - List.iter2 - (fun item path -> - match item with - | Sig_value (id, decl) -> ( - let decl' = Subst.value_description sub decl in - c.comp_values <- Tbl.add (Ident.name id) (decl', !pos) c.comp_values; - match decl.val_kind with - | Val_prim _ -> () - | _ -> incr pos) - | Sig_type (id, decl, _) -> - let decl' = Subst.type_declaration sub decl in - Datarepr.set_row_name decl' (Subst.type_path sub (Path.Pident id)); - let constructors = - List.map snd (Datarepr.constructors_of_type path decl') - in - let labels = List.map snd (Datarepr.labels_of_type path decl') in - c.comp_types <- - Tbl.add (Ident.name id) - ((decl', (constructors, labels)), nopos) - c.comp_types; - List.iter - (fun descr -> - c.comp_constrs <- add_to_tbl descr.cstr_name descr c.comp_constrs) - constructors; - List.iter - (fun descr -> - c.comp_labels <- add_to_tbl descr.lbl_name descr c.comp_labels) - labels; - env := store_type_infos id decl !env - | Sig_typext (id, ext, _) -> - let ext' = Subst.extension_constructor sub ext in - let descr = Datarepr.extension_descr path ext' in - c.comp_constrs <- add_to_tbl (Ident.name id) descr c.comp_constrs; - incr pos - | Sig_module (id, md, _) -> - let md' = Env_lazy.create (sub, md) in - c.comp_modules <- Tbl.add (Ident.name id) (md', !pos) c.comp_modules; - let deprecated = - Builtin_attributes.deprecated_of_attrs md.md_attributes - in - let comps = - components_of_module ~deprecated ~loc:md.md_loc !env sub path - md.md_type - in - c.comp_components <- - Tbl.add (Ident.name id) (comps, !pos) c.comp_components; - env := store_module ~check:false id md !env; - incr pos - | Sig_modtype (id, decl) -> - let decl' = Subst.modtype_declaration sub decl in - c.comp_modtypes <- - Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; - env := store_modtype id decl !env) - sg pl; + let labels_by_name = Hashtbl.create 127 in + let label_names_rev = ref [] in + Compiler_phase_trace.dependency "dependency.components_build" (fun () -> + List.iter2 + (fun item path -> + match item with + | Sig_value (id, decl) -> ( + let decl' = Subst.value_description sub decl in + c.comp_values <- + Tbl.add (Ident.name id) (decl', !pos) c.comp_values; + match decl.val_kind with + | Val_prim _ -> () + | _ -> incr pos) + | Sig_type (id, decl, _) -> + let decl' = Subst.type_declaration sub decl in + Datarepr.set_row_name decl' (Subst.type_path sub (Path.Pident id)); + let constructors = + List.map snd (Datarepr.constructors_of_type path decl') + in + let labels = List.map snd (Datarepr.labels_of_type path decl') in + c.comp_types <- + Tbl.add (Ident.name id) + ((decl', (constructors, labels)), nopos) + c.comp_types; + List.iter + (fun descr -> + c.comp_constrs <- + add_to_tbl descr.cstr_name descr c.comp_constrs) + constructors; + List.iter + (fun descr -> + let name = descr.lbl_name in + match Hashtbl.find labels_by_name name with + | _, previous -> + Hashtbl.replace labels_by_name name (name, descr :: previous) + | exception Not_found -> + Hashtbl.add labels_by_name name (name, [descr]); + label_names_rev := name :: !label_names_rev) + labels; + env := store_type_infos id decl !env + | Sig_typext (id, ext, _) -> + let ext' = Subst.extension_constructor sub ext in + let descr = Datarepr.extension_descr path ext' in + c.comp_constrs <- add_to_tbl (Ident.name id) descr c.comp_constrs; + incr pos + | Sig_module (id, md, _) -> + let md' = Env_lazy.create (sub, md) in + c.comp_modules <- + Tbl.add (Ident.name id) (md', !pos) c.comp_modules; + let deprecated = + Builtin_attributes.deprecated_of_attrs md.md_attributes + in + let comps = + components_of_module ~deprecated ~loc:md.md_loc !env sub path + md.md_type + in + c.comp_components <- + Tbl.add (Ident.name id) (comps, !pos) c.comp_components; + env := store_module ~check:false id md !env; + incr pos + | Sig_modtype (id, decl) -> + let decl' = Subst.modtype_declaration sub decl in + c.comp_modtypes <- + Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; + env := store_modtype id decl !env) + sg pl); + (* Large signatures often repeat label names. Keep first appearance order + to preserve Tbl's shape and the latest key and declarations to preserve + its contents. *) + c.comp_labels <- + List.fold_left + (fun table name -> + let latest_name, declarations = Hashtbl.find labels_by_name name in + Tbl.add latest_name declarations table) + Tbl.empty + (List.rev !label_names_rev); Some (Structure_comps c) | Mty_functor (param, _ty_arg, ty_res) -> Some @@ -1850,10 +3389,127 @@ let add_components slot root env0 comps = modules; } +let add_frozen_components slot root env0 view scope = + let generic_components () = + Compiler_phase_trace.dependency "dependency.frozen_open_fallback" (fun () -> + match get_components (find_module_descr root env0) with + | Structure_comps components -> components + | Functor_comps _ -> raise Not_found) + in + let from_table table name = + try Some (Tbl.find_str name table) with Not_found -> None + in + let id_source names contains lookup : _ Id_tbl.source = + let find name = if contains name then lookup name else None in + { + find; + iter = + (fun callback -> + List.iter (fun name -> Option.iter (callback name) (find name)) names); + } + in + let ty_source names contains lookup : _ Tycomp_tbl.source = + let find name = if contains name then lookup name else None in + { + find; + iter = + (fun callback -> + List.iter (fun name -> Option.iter (callback name) (find name)) names); + } + in + let values = + id_source (Frozen_values.value_names scope) (Frozen_values.has_value scope) + (fun name -> + match Frozen_values.find_in_scope view scope name with + | Some value -> Some value + | None -> from_table (generic_components ()).comp_values name) + in + let types = + id_source (Frozen_values.type_names scope) (Frozen_values.has_type scope) + (fun name -> + match Frozen_values.find_type_in_scope view scope name with + | Some declaration -> Some (declaration, nopos) + | None -> from_table (generic_components ()).comp_types name) + in + let constrs = + ty_source (Frozen_values.constructor_names scope) + (Frozen_values.has_constructor scope) (fun name -> + match Frozen_values.find_constructors_in_scope view scope name with + | Some constructors -> Some constructors + | None -> from_table (generic_components ()).comp_constrs name) + in + let labels = + ty_source (Frozen_values.label_names scope) (Frozen_values.has_label scope) + (fun name -> + match Frozen_values.find_labels_in_scope view scope name with + | Some labels -> Some labels + | None -> from_table (generic_components ()).comp_labels name) + in + let module_cache = Hashtbl.create 8 in + let modules = + id_source (Frozen_values.module_names scope) + (Frozen_values.has_module scope) (fun name -> + match Hashtbl.find_opt module_cache name with + | Some module_entry -> Some module_entry + | None -> + let result = + match Frozen_values.find_module_declaration view scope name with + | Some (declaration, position) -> + Some (Env_lazy.create (Subst.identity, declaration), position) + | None -> from_table (generic_components ()).comp_modules name + in + Option.iter (Hashtbl.add module_cache name) result; + result) + in + let modtypes = + id_source (Frozen_values.modtype_names scope) + (Frozen_values.has_modtype scope) (fun name -> + match Frozen_values.find_modtype_declaration view scope name with + | Some declaration -> Some (declaration, nopos) + | None -> from_table (generic_components ()).comp_modtypes name) + in + let components = + id_source (Frozen_values.module_names scope) + (Frozen_values.has_module scope) (fun name -> + match Frozen_values.find_module_info scope name with + | Some (position, _, _) -> + Some (find_module_descr (Pdot (root, name, position)) env0, position) + | None -> from_table (generic_components ()).comp_components name) + in + { + env0 with + summary = Env_open (env0.summary, root); + values = + Id_tbl.add_open_source slot (fun x -> `Value x) root values env0.values; + types = Id_tbl.add_open_source slot (fun x -> `Type x) root types env0.types; + constrs = + Tycomp_tbl.add_open_source slot + (fun x -> `Constructor x) + constrs env0.constrs; + labels = + Tycomp_tbl.add_open_source slot (fun x -> `Label x) labels env0.labels; + modules = + Id_tbl.add_open_source slot (fun x -> `Module x) root modules env0.modules; + modtypes = + Id_tbl.add_open_source slot + (fun x -> `Module_type x) + root modtypes env0.modtypes; + components = + Id_tbl.add_open_source slot + (fun x -> `Component x) + root components env0.components; + } + let open_signature slot root env0 = - match get_components (find_module_descr root env0) with - | Functor_comps _ -> None - | Structure_comps comps -> Some (add_components slot root env0 comps) + match find_frozen_scope_path root with + | Some (view, scope) -> + Some + (Compiler_phase_trace.dependency "dependency.frozen_open" (fun () -> + add_frozen_components slot root env0 view scope)) + | None -> ( + match get_components (find_module_descr root env0) with + | Functor_comps _ -> None + | Structure_comps comps -> Some (add_components slot root env0 comps)) (* Open a signature from a file *) @@ -1914,43 +3570,57 @@ let imports () = let save_signature_with_imports ?check_exists ~deprecated sg modname filename imports = - (*prerr_endline filename; + Compiler_phase_trace.section "artifact.cmi_prep" (fun () -> + (*prerr_endline filename; List.iter (fun (name, crc) -> prerr_endline name) imports;*) - Btype.cleanup_abbrev (); - Subst.reset_for_saving (); - let sg = Subst.signature (Subst.for_saving Subst.identity) sg in - let flags = - match deprecated with - | Some s -> [Deprecated s] - | None -> [] - in - try - let cmi = - {cmi_name = modname; cmi_sign = sg; cmi_crcs = imports; cmi_flags = flags} - in - let crc = create_cmi ?check_exists filename cmi in - (* Enter signature in persistent table so that imported_unit() + Btype.cleanup_abbrev (); + Subst.reset_for_saving (); + let sg = Subst.signature (Subst.for_saving Subst.identity) sg in + let flags = + match deprecated with + | Some s -> [Deprecated s] + | None -> [] + in + try + let cmi = + { + cmi_name = modname; + cmi_sign = sg; + cmi_crcs = imports; + cmi_flags = flags; + } + in + let crc = create_cmi ?check_exists filename cmi in + (* Enter signature in persistent table so that imported_unit() will also return its crc *) - let comps = - components_of_module ~deprecated ~loc:Location.none empty Subst.identity - (Pident (Ident.create_persistent modname)) - (Mty_signature sg) - in - let ps = - { - ps_name = modname; - ps_sig = lazy (Subst.signature Subst.identity sg); - ps_comps = comps; - ps_crcs = (cmi.cmi_name, Some crc) :: imports; - ps_filename = filename; - ps_flags = cmi.cmi_flags; - } - in - save_pers_struct crc ps; - cmi - with exn -> - remove_file filename; - raise exn + let comps = + Compiler_phase_trace.section "artifact.cmi_register" (fun () -> + components_of_module ~deprecated ~loc:Location.none empty + Subst.identity + (Pident (Ident.create_persistent modname)) + (Mty_signature sg)) + in + let ps = + { + ps_name = modname; + ps_sig = lazy (Subst.signature Subst.identity sg); + ps_comps = comps; + ps_crcs = (cmi.cmi_name, Some crc) :: imports; + ps_filename = filename; + ps_flags = cmi.cmi_flags; + ps_snapshot = None; + ps_frozen_values = None; + ps_frozen_components = Hashtbl.create 0; + } + in + save_pers_struct crc ps; + Option.iter + (fun capture -> capture filename crc cmi) + (Domain.DLS.get compiled_cmi_capture_key); + cmi + with exn -> + remove_file filename; + raise exn) let save_signature ?check_exists ~deprecated sg modname filename = save_signature_with_imports ?check_exists ~deprecated sg modname filename @@ -2071,45 +3741,381 @@ let with_fresh_key key create action = (* The persistent CMI cache, import consistency table, declaration usage callbacks, and summary memo all belong to one compilation request. *) let with_fresh action = - with_fresh_key value_declarations_key - (fun () -> Hashtbl.create 16) + with_fresh_key frozen_type_cache_key + (fun () -> Hashtbl.create 64) (fun () -> - with_fresh_key type_declarations_key + with_fresh_key value_declarations_key (fun () -> Hashtbl.create 16) (fun () -> - with_fresh_key module_declarations_key + with_fresh_key type_declarations_key (fun () -> Hashtbl.create 16) (fun () -> - with_fresh_key used_constructors_key + with_fresh_key module_declarations_key (fun () -> Hashtbl.create 16) (fun () -> - with_fresh_key prefixed_sg_key - (fun () -> Hashtbl.create 113) + with_fresh_key used_constructors_key + (fun () -> Hashtbl.create 16) (fun () -> - with_fresh_key can_load_cmis_key - (fun () -> ref Can_load_cmis) + with_fresh_key prefixed_sg_key + (fun () -> Hashtbl.create 113) (fun () -> - with_fresh_key current_unit_key - (fun () -> ref "") + with_fresh_key can_load_cmis_key + (fun () -> ref Can_load_cmis) (fun () -> - with_fresh_key persistent_structures_key - (fun () -> Hashtbl.create 17) + with_fresh_key current_unit_key + (fun () -> ref "") (fun () -> - with_fresh_key crc_units_key Consistbl.create + with_fresh_key persistent_structures_key + (fun () -> Hashtbl.create 17) (fun () -> - with_fresh_key imported_units_key - (fun () -> ref String_set.empty) - (fun () -> - with_fresh_key iter_env_cont_key - (fun () -> ref []) + with_fresh_key crc_units_key + Consistbl.create (fun () -> + with_fresh_key imported_units_key + (fun () -> ref String_set.empty) (fun () -> - with_fresh_key last_env_key - (fun () -> ref empty) + with_fresh_key iter_env_cont_key + (fun () -> ref []) (fun () -> - with_fresh_key - last_reduced_env_key + with_fresh_key last_env_key (fun () -> ref empty) - action)))))))))))) + (fun () -> + with_fresh_key + last_reduced_env_key + (fun () -> ref empty) + action))))))))))))) + +let snapshot_graph_from_cmis key = + let namespace = find_pers_struct key.namespace_name in + let dependency = find_pers_struct key.target_name in + let raw_signature = + match Env_lazy.get_arg dependency.ps_comps.comps with + | Some (_, _, _, Mty_signature signature) -> signature + | _ -> raise Not_found + in + let alias_component = + match get_components namespace.ps_comps with + | Structure_comps components -> + fst (Tbl.find_str key.alias_name components.comp_components) + | Functor_comps _ -> raise Not_found + in + let env, sub, path, mty = + match Env_lazy.get_arg alias_component.comps with + | Some context -> context + | None -> raise Not_found + in + if not (is_alias_path key path mty) then raise Not_found; + let target_components, target_ids = + capture_allocation_stage (fun () -> get_components_opt dependency.ps_comps) + in + let expanded_signature, signature_ids = + capture_allocation_stage (fun () -> Lazy.force dependency.ps_sig) + in + let alias_components, alias_ids = + capture_allocation_stage (fun () -> + components_of_module_maker_uncached (env, sub, path, mty)) + in + (match alias_components with + | Some (Structure_comps components) -> + if + Tbl.fold (fun _ _ _ -> true) components.comp_modules false + || Tbl.fold (fun _ _ _ -> true) components.comp_components false + then raise Not_found + | Some (Functor_comps _) | None -> raise Not_found); + { + raw_signature; + expanded_signature; + target_components; + alias_components; + target_ids; + signature_ids; + alias_ids; + crcs = dependency.ps_crcs; + flags = dependency.ps_flags; + } + +let prepare_expanded_snapshot_now key = + let cache = expanded_snapshot_cache () in + if !cache = None then + let namespace = find_pers_struct key.namespace_name in + let dependency = find_pers_struct key.target_name in + let namespace_filename = + Compiler_request_state.resolve_path namespace.ps_filename + in + let target_filename = + Compiler_request_state.resolve_path dependency.ps_filename + in + let resolved_load_path = + List.map Compiler_request_state.resolve_path (Config.get_load_path ()) + in + let namespace_stats = Unix.stat namespace_filename in + let target_stats = Unix.stat target_filename in + let forced = + match Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" with + | Some ("force" | "force_typed") -> true + | _ -> false + in + if target_stats.Unix.st_size >= 256 * 1024 || forced then + let request = Compiler_request_state.current () in + let seen_in_previous_request = + candidate_seen_in_previous_request key target_filename request + in + let prepared = + Mutex.lock shared_expanded_snapshot_lock; + Fun.protect + (fun () -> + match !shared_expanded_snapshot with + | Some shared + when shared.key = key + && shared.target_filename = target_filename + && shared.namespace_filename = namespace_filename + && shared.resolved_load_path = resolved_load_path + && same_file_stats shared.target_stats target_stats + && same_file_stats shared.namespace_stats namespace_stats -> + Some (shared.bytes, None) + | _ when forced || seen_in_previous_request -> + let cwd = Compiler_request_state.cwd () in + let load_path = Config.get_load_path () in + let previous = Domain.DLS.get preparing_expanded_snapshot in + Domain.DLS.set preparing_expanded_snapshot true; + let graph = + Fun.protect + (fun () -> + Ident.with_fresh (fun () -> + with_fresh (fun () -> + Btype.with_fresh (fun () -> + Compiler_request_state.with_fresh ~cwd + (fun () -> + Config.set_load_path load_path; + snapshot_graph_from_cmis key))))) + ~finally:(fun () -> + Domain.DLS.set preparing_expanded_snapshot previous) + in + let bytes = Marshal.to_string graph [] in + if + String.length bytes <= 8 * 1024 * 1024 + && same_file_stats + (Unix.stat namespace_filename) + namespace_stats + && same_file_stats (Unix.stat target_filename) target_stats + then ( + shared_expanded_snapshot := + Some + { + key; + target_filename; + namespace_filename; + resolved_load_path; + target_stats; + namespace_stats; + bytes; + }; + Some (bytes, Some graph)) + else None + | _ -> None) + ~finally:(fun () -> Mutex.unlock shared_expanded_snapshot_lock) + in + match prepared with + | None -> () + | Some (bytes, prepared_graph) -> + let graph = + match prepared_graph with + | Some graph -> graph + | None -> + Compiler_phase_trace.dependency "dependency.snapshot_shared_restore" + (fun () -> Marshal.from_string bytes 0) + in + cache := + Some + { + key; + target_filename; + namespace_filename; + resolved_load_path; + target_stats; + namespace_stats; + bytes; + graph = Some graph; + typed_integrity = + (if typed_expanded_snapshot_reuse () then + Some + (Compiler_phase_trace.dependency + "dependency.snapshot_capture" (fun () -> + snapshot_expanded_type_graph graph)) + else None); + in_use = false; + } + +let load_expanded_snapshot ~check:_ ~name = + if + (not (expanded_snapshot_enabled ())) + || Domain.DLS.get preparing_expanded_snapshot + then None + else + let cached = !(expanded_snapshot_cache ()) in + match cached with + | Some entry when name = entry.key.target_name -> + let valid = + Compiler_phase_trace.dependency "dependency.snapshot_validate" + (fun () -> + try + let path name = + find_in_path_uncap (Config.get_load_path ()) (name ^ ".cmi") + |> Compiler_request_state.resolve_path + in + path entry.key.target_name = entry.target_filename + && path entry.key.namespace_name = entry.namespace_filename + && List.map Compiler_request_state.resolve_path + (Config.get_load_path ()) + = entry.resolved_load_path + && same_file_stats + (Unix.stat entry.target_filename) + entry.target_stats + && same_file_stats + (Unix.stat entry.namespace_filename) + entry.namespace_stats + with Not_found | Sys_error _ | Unix.Unix_error _ -> false) + in + if not valid then ( + forget_snapshot_candidate entry.key entry.target_filename; + expanded_snapshot_cache () := None; + None) + else + Some + (Compiler_phase_trace.dependency "dependency.snapshot_reuse" + (fun () -> + let graph : expanded_snapshot = + match entry.graph with + | Some graph when not (force_fresh_expanded_snapshot ()) -> + graph + | Some _ | None -> + let graph = + Compiler_phase_trace.dependency + "dependency.snapshot_restore" (fun () -> + Marshal.from_string entry.bytes 0) + in + entry.graph <- Some graph; + entry.typed_integrity <- + (if typed_expanded_snapshot_reuse () then + Some + (Compiler_phase_trace.dependency + "dependency.snapshot_capture" (fun () -> + snapshot_expanded_type_graph graph)) + else None); + graph + in + entry.in_use <- true; + let snapshot = + { + key = entry.key; + graph; + target_relocated = false; + signature_relocated = false; + alias_relocated = false; + } + in + let deprecated = + List.fold_left + (fun _ -> function + | Deprecated s -> Some s) + None graph.flags + in + let ps_comps = + components_of_module ~deprecated ~loc:Location.none empty + Subst.identity + (Pident (Ident.create_persistent name)) + (Mty_signature graph.raw_signature) + in + let ps_sig = + lazy + (if not snapshot.signature_relocated then ( + relocate_allocation_stage graph.signature_ids; + snapshot.signature_relocated <- true); + graph.expanded_signature) + in + { + ps_name = name; + ps_sig; + ps_comps; + ps_crcs = graph.crcs; + ps_filename = entry.target_filename; + ps_flags = graph.flags; + ps_snapshot = Some snapshot; + ps_frozen_values = None; + ps_frozen_components = Hashtbl.create 0; + })) + | _ -> None + +let finalize_expanded_snapshot_cache () = + finalize_cmi_cache (); + match !(expanded_snapshot_cache ()) with + | Some entry when entry.in_use -> ( + entry.in_use <- false; + match entry.graph with + | Some _ when force_fresh_expanded_snapshot () -> + entry.graph <- None; + entry.typed_integrity <- None + | Some graph -> + let pristine = + Compiler_phase_trace.dependency "dependency.snapshot_verify" (fun () -> + reset_allocation_stage graph.target_ids; + reset_allocation_stage graph.signature_ids; + reset_allocation_stage graph.alias_ids; + let typed = + match entry.typed_integrity with + | Some snapshot -> type_graph_unchanged snapshot + | None -> false + in + (if audit_expanded_snapshot_reuse () then + let full = Marshal.to_string graph [] = entry.bytes in + if typed && not full then + failwith "typed dependency integrity check missed mutation"); + typed) + in + if not pristine then ( + Compiler_phase_trace.dependency "dependency.snapshot_dirty" (fun () -> + ()); + entry.graph <- None; + entry.typed_integrity <- None) + | None -> ()) + | _ -> () + +let with_dependency_cache cache action = + let table = + Mutex.lock cache.mutex; + Fun.protect + (fun () -> + match cache.available with + | table :: rest -> + cache.available <- rest; + table + | [] -> {cmis = Hashtbl.create 32; expanded_snapshot = ref None}) + ~finally:(fun () -> Mutex.unlock cache.mutex) + in + let previous_cmis = cmi_cache () in + let previous_snapshot = expanded_snapshot_cache () in + let previous_frozen_values = Domain.DLS.get frozen_values_cache_key in + let previous_published_cmis = Domain.DLS.get published_cmis_key in + Domain.DLS.set cmi_cache_key table.cmis; + Domain.DLS.set expanded_snapshot_cache_key table.expanded_snapshot; + Domain.DLS.set frozen_values_cache_key (Some cache.frozen_values); + Domain.DLS.set published_cmis_key (Some cache.published_cmis); + Fun.protect action ~finally:(fun () -> + (* Both graphs are exclusive to this request. Finalization restores + allocation IDs and any mutated nodes before another domain leases + the same table. A failed finalization discards the table. *) + Fun.protect finalize_expanded_snapshot_cache ~finally:(fun () -> + Domain.DLS.set cmi_cache_key previous_cmis; + Domain.DLS.set expanded_snapshot_cache_key previous_snapshot; + Domain.DLS.set frozen_values_cache_key previous_frozen_values; + Domain.DLS.set published_cmis_key previous_published_cmis); + Mutex.lock cache.mutex; + Fun.protect + (fun () -> cache.available <- table :: cache.available) + ~finally:(fun () -> Mutex.unlock cache.mutex)) + +let () = + prepare_expanded_snapshot := prepare_expanded_snapshot_now; + cached_pers_struct_loader := load_expanded_snapshot let keep_only_summary env = if !(last_env ()) == env then !(last_reduced_env ()) diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli index 04411ac872a..694608f4990 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -215,6 +215,61 @@ val crc_units : unit -> Consistbl.t val add_import : string -> unit val with_fresh : (unit -> 'a) -> 'a + +(* Finish the exclusive cache lease after a compiler request, resetting + allocated IDs and discarding a graph if typing changed it. *) +val finalize_expanded_snapshot_cache : unit -> unit + +(* Enable the per-domain expanded CMI cache for Rewatch requests. *) +val with_expanded_snapshot_cache : (unit -> 'a) -> 'a + +(* Project-owned decoded CMIs and expanded signature graphs. A request leases + one table exclusively, verifies it, and returns it to the session. Finished + worker domains therefore do not discard the dependency information. *) +type dependency_cache +val create_dependency_cache : unit -> dependency_cache +val with_dependency_cache : dependency_cache -> (unit -> 'a) -> 'a + +val with_frozen_values_setting : ?enabled:bool -> (unit -> 'a) -> 'a +(** Snapshot the experimental setting once for a compiler request. *) + +val with_compiled_cmi_capture : + (string -> Digest.t -> Cmi_format.cmi_infos -> unit) -> (unit -> 'a) -> 'a +(** Capture a saved interface in its producer request. The value remains + request-owned until the caller freezes it after successful publication. *) + +val publish_compiled_cmi : + dependency_cache -> + filename:string -> + crc:Digest.t -> + Cmi_format.cmi_infos -> + unit +(** Publish a successful artifact as an immutable interface image. A later + request uses it only while the published file still has the same identity. *) + +val publish_pending_compiled_cmi : + dependency_cache -> + source:string -> + destination:string -> + crc:Digest.t -> + Cmi_format.cmi_infos -> + bool +(** Publish a request's frozen interface before artifact export. The virtual + destination participates in load-path selection while the source artifact + still has its captured identity. Returns [false] when freezing fails. *) + +val discard_pending_compiled_cmi : dependency_cache -> filename:string -> unit +(** Remove a virtual interface after cancellation or failed export. *) + +val published_compiled_cmi : + dependency_cache -> filename:string -> (Digest.t * Frozen_values.t) option +(** Return an immutable published interface only while its disk artifact is + still the selected file. *) + +val find_compiled_cmi : string -> string +(** Select an explicit interface CMI from the load path, including a staged + virtual destination in the active compiler session. *) + (* Keep persistent modules, imports, usage callbacks, and memoized summaries local to a compiler request. *) diff --git a/compiler/ml/experimental_features.ml b/compiler/ml/experimental_features.ml index 04da6dabcca..8e74dfb169b 100644 --- a/compiler/ml/experimental_features.ml +++ b/compiler/ml/experimental_features.ml @@ -32,4 +32,8 @@ let enable_from_string (s : string) = let reset () = enabled_features () := Feature_set.empty +type snapshot = Feature_set.t +let snapshot () = !(enabled_features ()) +let install_copy snapshot = enabled_features () := snapshot + let is_enabled (f : feature) = Feature_set.mem f !(enabled_features ()) diff --git a/compiler/ml/experimental_features.mli b/compiler/ml/experimental_features.mli index 7518e4f7e20..29b926caad1 100644 --- a/compiler/ml/experimental_features.mli +++ b/compiler/ml/experimental_features.mli @@ -7,3 +7,9 @@ val with_fresh : (unit -> 'a) -> 'a val is_enabled : feature -> bool val to_string : feature -> string val reset : unit -> unit + +type snapshot +val snapshot : unit -> snapshot + +val install_copy : snapshot -> unit +(** Feature sets are immutable; each request retains its own mutable ref. *) diff --git a/compiler/ml/frozen_type_graph.ml b/compiler/ml/frozen_type_graph.ml new file mode 100644 index 00000000000..8d1e98f7127 --- /dev/null +++ b/compiler/ml/frozen_type_graph.ml @@ -0,0 +1,545 @@ +open Types + +type frozen_row_field = + | Fpresent of int option + | Feither of bool * int list * bool * int + | Fabsent + +type frozen_variant = { + fields: (int * frozen_row_field) list; + more: int; + closed: bool; + fixed: bool; + name: (int * int list) option; +} + +(* Common nodes use a byte tag, a scalar payload, and a contiguous slice of + [edges]. Less common row and package data lives in indexed side tables. + The image retains no mutable type nodes, paths, or identifier records. *) +type t = { + roots: int array; + requested_identifiers: int array; + kinds: bytes; + levels: int array; + payloads: int array; + edge_offsets: int array; + edges: int array; + arrow_labels: Asttypes.arg_label array; + names: string array; + ident_names: int array; + ident_stamps: int array; + ident_flags: int array; + path_kinds: bytes; + path_first: int array; + path_second: int array; + path_positions: int array; + field_data: int array; + variants: frozen_variant array; + packages: (int * Longident.t list) array; + mutabilities: Asttypes.mutable_flag array; + row_references: frozen_row_field option array; +} + +module Int_buffer = struct + type t = {mutable values: int array; mutable length: int} + + let create () = {values = Array.make 16 0; length = 0} + + let reserve buffer count = + let start = buffer.length in + let needed = start + count in + if needed > Array.length buffer.values then ( + let capacity = ref (Array.length buffer.values) in + while !capacity < needed do + capacity := 2 * !capacity + done; + let grown = Array.make !capacity 0 in + Array.blit buffer.values 0 grown 0 buffer.length; + buffer.values <- grown); + buffer.length <- needed; + start + + let add buffer value = + if buffer.length = Array.length buffer.values then ( + let grown = Array.make (2 * buffer.length) 0 in + Array.blit buffer.values 0 grown 0 buffer.length; + buffer.values <- grown); + buffer.values.(buffer.length) <- value; + buffer.length <- buffer.length + 1 + + let set buffer index value = buffer.values.(index) <- value + + let to_array buffer = Array.sub buffer.values 0 buffer.length +end + +module Byte_buffer = struct + type t = {mutable values: bytes; mutable length: int} + + let create () = {values = Bytes.make 16 '\000'; length = 0} + + let add buffer value = + if buffer.length = Bytes.length buffer.values then ( + let grown = Bytes.make (2 * buffer.length) '\000' in + Bytes.blit buffer.values 0 grown 0 buffer.length; + buffer.values <- grown); + Bytes.set buffer.values buffer.length value; + buffer.length <- buffer.length + 1 + + let set buffer index value = Bytes.set buffer.values index value + + let to_bytes buffer = Bytes.sub buffer.values 0 buffer.length +end + +let tag_var = 0 +let tag_arrow = 1 +let tag_tuple = 2 +let tag_constr = 3 +let tag_object = 4 +let tag_field = 5 +let tag_nil = 6 +let tag_variant = 7 +let tag_univar = 8 +let tag_poly = 9 +let tag_package = 10 + +let path_ident = 0 +let path_dot = 1 +let path_apply = 2 + +module Physical_type = Hashtbl.Make (struct + type t = type_expr + let equal a b = a == b + let hash ty = ty.id +end) + +module Physical_ident = Hashtbl.Make (struct + type t = Ident.t + let equal a b = a == b + let hash id = Hashtbl.hash (id.Ident.stamp, id.Ident.name) +end) + +module Physical_mutability = Hashtbl.Make (struct + type t = field_mutability ref + let equal a b = a == b + let hash = Hashtbl.hash +end) + +module Physical_row_reference = Hashtbl.Make (struct + type t = row_field option ref + let equal a b = a == b + let hash = Hashtbl.hash +end) + +exception Unsupported of string + +let freeze ?(identifiers = []) roots = + try + let seen_types = Physical_type.create 128 in + let seen_idents = Physical_ident.create 32 in + let seen_mutabilities = Physical_mutability.create 16 in + let seen_row_references = Physical_row_reference.create 16 in + let seen_names = Hashtbl.create 64 in + let idents = ref [] in + let paths = ref [] in + let names = ref [] in + let mutabilities = ref [] in + let row_references = ref [] in + let kinds = Byte_buffer.create () in + let levels = Int_buffer.create () in + let payloads = Int_buffer.create () in + let edge_offsets = Int_buffer.create () in + let edges = Int_buffer.create () in + let arrow_labels = ref [] in + let arrow_label_count = ref 0 in + let field_data = Int_buffer.create () in + let variants = ref [] in + let packages = ref [] in + let variant_count = ref 0 in + let package_count = ref 0 in + let ident_count = ref 0 in + let path_count = ref 0 in + let name_count = ref 0 in + let mutability_count = ref 0 in + let row_reference_count = ref 0 in + let index_name name = + match Hashtbl.find_opt seen_names name with + | Some index -> index + | None -> + let index = !name_count in + incr name_count; + Hashtbl.add seen_names name index; + names := (index, name) :: !names; + index + in + let index_optional_name = function + | None -> -1 + | Some name -> index_name name + in + let index_ident id = + match Physical_ident.find_opt seen_idents id with + | Some index -> index + | None -> + let index = !ident_count in + incr ident_count; + Physical_ident.add seen_idents id index; + idents := + (index, (index_name id.Ident.name, id.Ident.stamp, id.Ident.flags)) + :: !idents; + index + in + let rec index_path = function + | Path.Pident id -> add_path path_ident (index_ident id) 0 0 + | Path.Pdot (parent, name, position) -> + let parent = index_path parent in + add_path path_dot parent (index_name name) position + | Path.Papply (first, second) -> + let first = index_path first in + let second = index_path second in + add_path path_apply first second 0 + and add_path kind first second position = + let index = !path_count in + incr path_count; + paths := (index, kind, first, second, position) :: !paths; + index + in + let index_mutability cell = + let cell = Btype.mutability_ref_repr cell in + match Physical_mutability.find_opt seen_mutabilities cell with + | Some index -> index + | None -> + let index = !mutability_count in + incr mutability_count; + Physical_mutability.add seen_mutabilities cell index; + mutabilities := (index, Btype.mutability_repr cell) :: !mutabilities; + index + in + let rec freeze_type ty = + match Physical_type.find_opt seen_types ty with + | Some index -> index + | None -> + let index = levels.length in + Physical_type.add seen_types ty index; + Int_buffer.add levels ty.level; + Byte_buffer.add kinds '\000'; + Int_buffer.add payloads 0; + Int_buffer.add edge_offsets edges.length; + let width = + match ty.desc with + | Tarrow (arguments, _) -> List.length arguments + 1 + | Ttuple types -> List.length types + | Tconstr (_, parameters, memo) -> + (match !memo with + | Mnil -> () + | Mcons _ | Mlink _ -> + raise (Unsupported "an active abbreviation memo")); + List.length parameters + | Tfield _ -> 2 + | Tpoly (_, variables) -> List.length variables + | Tpackage (_, _, types) -> List.length types + | Tlink _ -> raise (Unsupported "a linked type node") + | Tsubst _ -> raise (Unsupported "an active type copy mark") + | Tvar _ | Tobject _ | Tnil | Tvariant _ | Tunivar _ -> 0 + in + (* Reserve a node's full edge range before visiting its children. DFS + then assigns contiguous ranges in node-index order, even for cycles. *) + let start = Int_buffer.reserve edges width in + let kind, payload = + match ty.desc with + | Tvar name -> (tag_var, index_optional_name name) + | Tarrow (arguments, result) -> + let label_start = !arrow_label_count in + let count = List.length arguments in + arrow_label_count := label_start + count; + List.iteri + (fun offset argument -> + arrow_labels := + (label_start + offset, argument.lbl) :: !arrow_labels; + Int_buffer.set edges (start + offset) (freeze_type argument.typ)) + arguments; + Int_buffer.set edges (start + count) (freeze_type result); + (tag_arrow, label_start) + | Ttuple types -> + freeze_children start types; + (tag_tuple, 0) + | Tconstr (path, parameters, _) -> + let path = index_path path in + freeze_children start parameters; + (tag_constr, path) + | Tobject fields -> (tag_object, freeze_type fields) + | Tfield {name; mutability; typ; rest} -> + let field = field_data.length / 2 in + Int_buffer.add field_data (index_name name); + Int_buffer.add field_data (index_mutability mutability); + Int_buffer.set edges start (freeze_type typ); + Int_buffer.set edges (start + 1) (freeze_type rest); + (tag_field, field) + | Tnil -> (tag_nil, 0) + | Tvariant row -> + let side = !variant_count in + incr variant_count; + let variant = + { + fields = + List.map + (fun (label, field) -> + (index_name label, freeze_row_field field)) + row.row_fields; + more = freeze_type row.row_more; + closed = row.row_closed; + fixed = row.row_fixed; + name = + Option.map + (fun (path, parameters) -> + (index_path path, List.map freeze_type parameters)) + row.row_name; + } + in + variants := (side, variant) :: !variants; + (tag_variant, side) + | Tunivar name -> (tag_univar, index_optional_name name) + | Tpoly (body, variables) -> + let body = freeze_type body in + freeze_children start variables; + (tag_poly, body) + | Tpackage (path, package_names, types) -> + let side = !package_count in + incr package_count; + packages := (side, (index_path path, package_names)) :: !packages; + freeze_children start types; + (tag_package, side) + | Tlink _ | Tsubst _ -> assert false + in + Byte_buffer.set kinds index (Char.chr kind); + Int_buffer.set payloads index payload; + index + and freeze_children start types = + List.iteri + (fun offset typ -> + Int_buffer.set edges (start + offset) (freeze_type typ)) + types + and freeze_row_field = function + | Rpresent ty -> Fpresent (Option.map freeze_type ty) + | Reither (constant, types, matched, reference) -> + Feither + ( constant, + List.map freeze_type types, + matched, + freeze_row_reference reference ) + | Rabsent -> Fabsent + and freeze_row_reference reference = + match Physical_row_reference.find_opt seen_row_references reference with + | Some index -> index + | None -> + let index = !row_reference_count in + incr row_reference_count; + Physical_row_reference.add seen_row_references reference index; + row_references := + (index, Option.map freeze_row_field !reference) :: !row_references; + index + in + let requested_identifiers = + Array.of_list (List.map index_ident identifiers) + in + let roots = Array.of_list (List.map freeze_type roots) in + Int_buffer.add edge_offsets edges.length; + let array count entries empty = + let result = Array.make count empty in + List.iter (fun (index, value) -> result.(index) <- value) entries; + result + in + let ident_names = Array.make !ident_count 0 in + let ident_stamps = Array.make !ident_count 0 in + let ident_flags = Array.make !ident_count 0 in + List.iter + (fun (index, (name, stamp, flags)) -> + ident_names.(index) <- name; + ident_stamps.(index) <- stamp; + ident_flags.(index) <- flags) + !idents; + let path_kinds = Bytes.create !path_count in + let path_first = Array.make !path_count 0 in + let path_second = Array.make !path_count 0 in + let path_positions = Array.make !path_count 0 in + List.iter + (fun (index, kind, first, second, position) -> + Bytes.set path_kinds index (Char.chr kind); + path_first.(index) <- first; + path_second.(index) <- second; + path_positions.(index) <- position) + !paths; + Ok + { + roots; + requested_identifiers; + kinds = Byte_buffer.to_bytes kinds; + levels = Int_buffer.to_array levels; + payloads = Int_buffer.to_array payloads; + edge_offsets = Int_buffer.to_array edge_offsets; + edges = Int_buffer.to_array edges; + arrow_labels = array !arrow_label_count !arrow_labels Asttypes.Nolabel; + names = array !name_count !names ""; + ident_names; + ident_stamps; + ident_flags; + path_kinds; + path_first; + path_second; + path_positions; + field_data = Int_buffer.to_array field_data; + variants = + array !variant_count !variants + {fields = []; more = 0; closed = false; fixed = false; name = None}; + packages = array !package_count !packages (0, []); + mutabilities = array !mutability_count !mutabilities Asttypes.Immutable; + row_references = array !row_reference_count !row_references None; + } + with Unsupported reason -> Error reason + +type view = {type_at: int -> type_expr; identifier_at: int -> Ident.t} + +let create_view ?(map_type_path = Fun.id) ?(map_modtype_path = Fun.id) image = + let identifiers = Array.make (Array.length image.ident_names) None in + let mutabilities = Array.make (Array.length image.mutabilities) None in + let row_references = Array.make (Array.length image.row_references) None in + let nodes = Array.make (Bytes.length image.kinds) None in + let get_name index = image.names.(index) in + let get_optional_name index = + if index < 0 then None else Some (get_name index) + in + let get_ident index = + match identifiers.(index) with + | Some id -> id + | None -> + let id = + { + Ident.name = get_name image.ident_names.(index); + stamp = image.ident_stamps.(index); + flags = image.ident_flags.(index); + } + in + identifiers.(index) <- Some id; + id + in + let rec thaw_path index = + let first = image.path_first.(index) in + match Char.code (Bytes.get image.path_kinds index) with + | kind when kind = path_ident -> Path.Pident (get_ident first) + | kind when kind = path_dot -> + Path.Pdot + ( thaw_path first, + get_name image.path_second.(index), + image.path_positions.(index) ) + | kind when kind = path_apply -> + Path.Papply (thaw_path first, thaw_path image.path_second.(index)) + | _ -> assert false + in + let get_mutability index = + match mutabilities.(index) with + | Some cell -> cell + | None -> + let cell = ref (Mutability_value image.mutabilities.(index)) in + mutabilities.(index) <- Some cell; + cell + in + let rec get index = + match nodes.(index) with + | Some ty -> ty + | None -> + let ty = Btype.newty2 image.levels.(index) (Tvar None) in + nodes.(index) <- Some ty; + ty.desc <- thaw_desc index; + ty + and thaw_desc index = + let payload = image.payloads.(index) in + let start = image.edge_offsets.(index) in + let stop = image.edge_offsets.(index + 1) in + let edge offset = get image.edges.(start + offset) in + let children () = List.init (stop - start) edge in + match Char.code (Bytes.get image.kinds index) with + | kind when kind = tag_var -> Tvar (get_optional_name payload) + | kind when kind = tag_arrow -> + let count = stop - start - 1 in + let arguments = + List.init count (fun offset -> + Types. + {lbl = image.arrow_labels.(payload + offset); typ = edge offset}) + in + Tarrow (arguments, edge count) + | kind when kind = tag_tuple -> Ttuple (children ()) + | kind when kind = tag_constr -> + Tconstr (map_type_path (thaw_path payload), children (), ref Mnil) + | kind when kind = tag_object -> Tobject (get payload) + | kind when kind = tag_field -> + Tfield + { + name = get_name image.field_data.(2 * payload); + mutability = get_mutability image.field_data.((2 * payload) + 1); + typ = edge 0; + rest = edge 1; + } + | kind when kind = tag_nil -> Tnil + | kind when kind = tag_variant -> + let row = image.variants.(payload) in + Tvariant + { + row_fields = + List.map + (fun (label, field) -> (get_name label, thaw_row_field field)) + row.fields; + row_more = get row.more; + row_closed = row.closed; + row_fixed = row.fixed; + row_name = + Option.map + (fun (path, parameters) -> + (map_type_path (thaw_path path), List.map get parameters)) + row.name; + } + | kind when kind = tag_univar -> Tunivar (get_optional_name payload) + | kind when kind = tag_poly -> Tpoly (get payload, children ()) + | kind when kind = tag_package -> + let path, names = image.packages.(payload) in + Tpackage (map_modtype_path (thaw_path path), names, children ()) + | _ -> assert false + and thaw_row_field = function + | Fpresent ty -> Rpresent (Option.map get ty) + | Feither (constant, types, matched, reference) -> + Reither + (constant, List.map get types, matched, get_row_reference reference) + | Fabsent -> Rabsent + and get_row_reference index = + match row_references.(index) with + | Some reference -> reference + | None -> + let reference = ref None in + row_references.(index) <- Some reference; + reference := Option.map thaw_row_field image.row_references.(index); + reference + in + { + type_at = + (fun root -> + if root < 0 || root >= Array.length image.roots then + invalid_arg "Frozen_type_graph.type_at" + else get image.roots.(root)); + identifier_at = + (fun requested -> + if + requested < 0 || requested >= Array.length image.requested_identifiers + then invalid_arg "Frozen_type_graph.identifier_at" + else get_ident image.requested_identifiers.(requested)); + } + +let type_at view root = view.type_at root + +let identifier_at view requested = view.identifier_at requested + +let thaw image = + let view = create_view image in + List.init (Array.length image.roots) (type_at view) + +let thaw_root image root = type_at (create_view image) root + +let root_count image = Array.length image.roots + +let node_count image = Bytes.length image.kinds diff --git a/compiler/ml/frozen_type_graph.mli b/compiler/ml/frozen_type_graph.mli new file mode 100644 index 00000000000..42ffe15992e --- /dev/null +++ b/compiler/ml/frozen_type_graph.mli @@ -0,0 +1,47 @@ +(** An immutable, indexed image of the type expressions in a compiled + interface. The image contains no mutable compiler nodes and can be shared + between domains. [thaw] creates request-local [Types.type_expr] nodes. + + This is the type-graph part of the immutable-interface experiment. A full + interface image must also encode declarations, identifiers, and paths so + that all roots use the same identity table. *) + +type t + +val freeze : + ?identifiers:Ident.t list -> Types.type_expr list -> (t, string) result +(** Capture roots and their reachable graph. Active copy marks and abbreviation + memo entries are rejected; saved interfaces must not contain either. + [identifiers] registers signature binders in the same identifier table as + paths inside the type graph. *) + +type view + +val create_view : + ?map_type_path:(Path.t -> Path.t) -> + ?map_modtype_path:(Path.t -> Path.t) -> + t -> + view +(** A request-local memo for lazy materialization. Do not share a view between + compiler requests. The callbacks apply the request's path substitution + while a type node is materialized. *) + +val type_at : view -> int -> Types.type_expr +(** Materialize a zero-based root, preserving sharing with any other roots + already materialized through this view. *) + +val identifier_at : view -> int -> Ident.t +(** Materialize a zero-based identifier passed to [freeze]. A matching path + inside a type root receives this exact identifier object. *) + +val thaw : t -> Types.type_expr list +(** Materialize an independent graph, preserving sharing among its roots. *) + +val thaw_root : t -> int -> Types.type_expr +(** Materialize only nodes reachable from one zero-based root. This is a + request-local fallback for consumers which cannot read the frozen graph + directly. *) + +val root_count : t -> int + +val node_count : t -> int diff --git a/compiler/ml/frozen_values.ml b/compiler/ml/frozen_values.ml new file mode 100644 index 00000000000..e2fecf86a01 --- /dev/null +++ b/compiler/ml/frozen_values.ml @@ -0,0 +1,1059 @@ +open Types + +module String_map = Map.Make (String) +module String_set = Set.Make (String) +module Stamp_map = Map.Make (Int) +module Int_map = Map.Make (Int) + +type binder_kind = Bound_type | Bound_module | Bound_modtype +type binder_path = (string * int) list + +type value = { + typ: int; + kind: string option; + loc: Location.t; + attributes: string option; + position: int; +} + +type frozen_label = { + name: string; + flags: int; + runtime_name: string option; + mutable_flag: Asttypes.mutable_flag; + optional: bool; + typ: int; + loc: Location.t; + attributes: string option; +} + +type frozen_constructor_arguments = + | Frozen_tuple of int list + | Frozen_record_arguments of frozen_label list + +type frozen_constructor = { + name: string; + flags: int; + runtime_tag: Variant_runtime.literal_tag option; + args: frozen_constructor_arguments; + result: int option; + loc: Location.t; + attributes: string option; +} + +type frozen_extension = { + name: string; + position: int; + type_path: string; + type_params: int list; + args: frozen_constructor_arguments; + ret_type: int option; + private_flag: Asttypes.private_flag; + loc: Location.t; + attributes: string option; + is_exception: bool; +} + +type constructor_source = + | Variant_source of string + | Extension_source of frozen_extension + +type frozen_kind = + | Frozen_abstract + | Frozen_record of frozen_label list * frozen_record_representation + | Frozen_variant of frozen_constructor list * int + | Frozen_open + +and frozen_record_representation = + | Static_record of record_representation + | Inlined_record of {name: string; layout: int; position: int} + +type frozen_layout = { + configuration: Variant_runtime.configuration; + cases: Variant_runtime.constructor_case list; +} + +type frozen_inlined_type = Frozen_inlined_record of string * frozen_label list + +type frozen_type = { + params: int list; + arity: int; + kind: frozen_kind; + private_flag: Asttypes.private_flag; + manifest: int option; + variance: Variance.t list; + loc: Location.t; + attributes: string option; + immediate: bool; + representation: type_representation; + inlined_types: frozen_inlined_type list; +} + +type frozen_module_type = + | Simple_alias of alias_presence * string + | Simple_ident of string + | Complex_module_type of string + +let freeze_module_type = function + | Mty_alias (presence, path) -> + Simple_alias (presence, Marshal.to_string path []) + | Mty_ident ((Path.Pident _ | Path.Pdot _) as path) -> + Simple_ident (Marshal.to_string path []) + | (Mty_ident (Path.Papply _) | Mty_signature _ | Mty_functor _) as module_type + -> + Complex_module_type (Marshal.to_string module_type []) + +type scope = { + id: int; + path: binder_path; + context_id: int option; + values: value String_map.t; + type_names: String_set.t; + duplicate_type_names: String_set.t; + types: frozen_type String_map.t; + label_sources: string list String_map.t; + constructor_sources: constructor_source list String_map.t; + modules: module_entry String_map.t; + duplicate_module_names: String_set.t; + modtypes: modtype_entry String_map.t; + duplicate_modtype_names: String_set.t; +} + +and module_entry = { + position: int; + loc: Location.t; + deprecated: string option; + nested: scope option; + module_type: frozen_module_type; + attributes: string option; +} + +and modtype_entry = { + definition: frozen_module_type option; + loc: Location.t; + attributes: string option; +} + +type t = { + name: string; + signature_bytes: string; + graph: Frozen_type_graph.t; + type_binders: binder_path Stamp_map.t; + module_binders: binder_path Stamp_map.t; + modtype_binders: binder_path Stamp_map.t; + contexts: binder_context Int_map.t; + layouts: frozen_layout array; + root: scope; +} + +and binder_context = { + parent: int option; + type_binders: binder_path Stamp_map.t; + module_binders: binder_path Stamp_map.t; + modtype_binders: binder_path Stamp_map.t; +} + +type building_context = { + id: int; + parent: int option; + types: binder_path Stamp_map.t ref; + modules: binder_path Stamp_map.t ref; + modtypes: binder_path Stamp_map.t ref; +} + +type graph_context = { + graph: Frozen_type_graph.view Lazy.t; + map_type_path: Path.t -> Path.t; + map_module_path: Path.t -> Path.t; + map_modtype_path: Path.t -> Path.t; +} + +type view = { + image: t; + root_context: graph_context; + materialized_values: (int * string, value_description * int) Hashtbl.t; + materialized_types: + ( int * string, + type_declaration * (constructor_description list * label_description list) + ) + Hashtbl.t; + materialized_extensions: (int * int, constructor_description) Hashtbl.t; + materialized_modules: (int * string, module_declaration) Hashtbl.t; + materialized_modtypes: (int * string, modtype_declaration) Hashtbl.t; + substitutions: (int, Subst.t) Hashtbl.t; + context_graphs: (int, graph_context) Hashtbl.t; + materialized_layouts: (int option * int, Variant_runtime.layout_ref) Hashtbl.t; +} + +(* Keep imported member IDs outside the positive request-local stamp range. + Lazy materialization must not renumber IDs saved by the compiling module. *) +let imported_member_stamp = Atomic.make (-1_000_000_000) + +let freeze (cmi : Cmi_format.cmi_infos) = + let roots = ref [] in + let type_binders = ref Stamp_map.empty in + let module_binders = ref Stamp_map.empty in + let modtype_binders = ref Stamp_map.empty in + let next_root = ref 0 in + let next_scope = ref 0 in + let next_context = ref 0 in + let contexts = ref Int_map.empty in + let modtype_definitions = Hashtbl.create 16 in + let layout_refs = ref [] in + let layouts = ref [] in + let freeze_layout layout_ref = + match + List.find_opt (fun (saved, _) -> saved == layout_ref) !layout_refs + with + | Some (_, id) -> Some id + | None -> ( + match + try Some (Variant_runtime.get_layout layout_ref) + with Failure _ -> None + with + | None -> None + | Some layout -> + let id = List.length !layouts in + let cases = + List.init + (Variant_runtime.length layout) + (Variant_runtime.constructor_at layout) + in + layout_refs := (layout_ref, id) :: !layout_refs; + layouts := + {configuration = Variant_runtime.configuration layout; cases} + :: !layouts; + Some id) + in + let create_context parent = + let id = !next_context in + incr next_context; + { + id; + parent = Option.map (fun context -> context.id) parent; + types = ref Stamp_map.empty; + modules = ref Stamp_map.empty; + modtypes = ref Stamp_map.empty; + } + in + let add_binder scope_path context kind id position = + let entry = scope_path @ [(Ident.name id, position)] in + let add table = table := Stamp_map.add id.Ident.stamp entry !table in + match (context, kind) with + | None, Bound_type -> add type_binders + | None, Bound_module -> add module_binders + | None, Bound_modtype -> add modtype_binders + | Some context, Bound_type -> add context.types + | Some context, Bound_module -> add context.modules + | Some context, Bound_modtype -> add context.modtypes + in + let rec signature_of_modtype visited = function + | Mty_signature signature -> Some signature + | Mty_ident (Path.Pident id) -> + let stamp = id.Ident.stamp in + if List.mem stamp visited then None + else + Option.bind + (Hashtbl.find_opt modtype_definitions stamp) + (signature_of_modtype (stamp :: visited)) + | Mty_ident (Path.Pdot _ | Path.Papply _) | Mty_functor _ | Mty_alias _ -> + None + in + let add_root ty = + let root = !next_root in + incr next_root; + roots := ty :: !roots; + root + in + let marshal_nonempty = function + | [] -> None + | items -> Some (Marshal.to_string items []) + in + let freeze_label (label : label_declaration) = + { + name = label.ld_id.Ident.name; + flags = label.ld_id.Ident.flags; + runtime_name = label.ld_runtime_name; + mutable_flag = label.ld_mutable; + optional = label.ld_optional; + typ = add_root label.ld_type; + loc = label.ld_loc; + attributes = marshal_nonempty label.ld_attributes; + } + in + let freeze_constructor (constructor : constructor_declaration) = + { + name = constructor.cd_id.Ident.name; + flags = constructor.cd_id.Ident.flags; + runtime_tag = constructor.cd_runtime_tag; + args = + (match constructor.cd_args with + | Cstr_tuple types -> Frozen_tuple (List.map add_root types) + | Cstr_record labels -> + Frozen_record_arguments (List.map freeze_label labels)); + result = Option.map add_root constructor.cd_res; + loc = constructor.cd_loc; + attributes = marshal_nonempty constructor.cd_attributes; + } + in + let freeze_args = function + | Cstr_tuple types -> Frozen_tuple (List.map add_root types) + | Cstr_record labels -> + Frozen_record_arguments (List.map freeze_label labels) + in + let index_source table name source = + let previous = + match String_map.find_opt name !table with + | Some sources -> sources + | None -> [] + in + table := String_map.add name (source :: previous) !table + in + let rec freeze_scope scope_path context signature = + let id = !next_scope in + incr next_scope; + let values = ref String_map.empty in + let type_names = ref String_set.empty in + let duplicate_type_names = ref String_set.empty in + let types = ref String_map.empty in + let label_sources = ref String_map.empty in + let constructor_sources = ref String_map.empty in + let modules = ref String_map.empty in + let duplicate_module_names = ref String_set.empty in + let modtypes = ref String_map.empty in + let duplicate_modtype_names = ref String_set.empty in + let position = ref 0 in + List.iter + (function + | Sig_value (id, declaration) -> ( + let typ = add_root declaration.val_type in + let kind = + match declaration.val_kind with + | Val_reg -> None + | Val_prim _ as kind -> Some (Marshal.to_string kind []) + in + let attributes = marshal_nonempty declaration.val_attributes in + values := + String_map.add (Ident.name id) + { + typ; + kind; + loc = declaration.val_loc; + attributes; + position = !position; + } + !values; + match declaration.val_kind with + | Val_reg -> incr position + | Val_prim _ -> ()) + | Sig_type (id, declaration, _) -> ( + let type_name = Ident.name id in + if String_set.mem type_name !type_names then + duplicate_type_names := + String_set.add type_name !duplicate_type_names; + type_names := String_set.add type_name !type_names; + add_binder scope_path context Bound_type id Path.nopos; + let kind = + match declaration.type_kind with + | Type_abstract -> Some Frozen_abstract + | Type_record (labels, representation) -> ( + List.iter + (fun label -> + index_source label_sources (Ident.name label.ld_id) type_name) + labels; + match representation with + | Record_inlined {name; representation = {variant; position}} -> + Option.map + (fun layout -> + Frozen_record + ( List.map freeze_label labels, + Inlined_record {name; layout; position} )) + (freeze_layout variant) + | Record_regular | Record_float_unused | Record_unboxed _ + | Record_extension -> + Some + (Frozen_record + (List.map freeze_label labels, Static_record representation)) + ) + | Type_variant (constructors, layout_ref) -> + List.iter + (fun constructor -> + index_source constructor_sources + (Ident.name constructor.cd_id) + (Variant_source type_name)) + constructors; + Option.map + (fun layout -> + Frozen_variant + (List.map freeze_constructor constructors, layout)) + (freeze_layout layout_ref) + | Type_open -> Some Frozen_open + in + match kind with + | Some kind -> + let inlined_types = + List.map + (function + | Record {type_name; labels} -> + Frozen_inlined_record + (type_name, List.map freeze_label labels)) + declaration.type_inlined_types + in + types := + String_map.add (Ident.name id) + { + params = List.map add_root declaration.type_params; + arity = declaration.type_arity; + kind; + private_flag = declaration.type_private; + manifest = Option.map add_root declaration.type_manifest; + variance = declaration.type_variance; + loc = declaration.type_loc; + attributes = marshal_nonempty declaration.type_attributes; + immediate = declaration.type_immediate; + representation = declaration.type_representation; + inlined_types; + } + !types + | None -> ()) + | Sig_typext (id, extension, _) -> + add_binder scope_path context Bound_type id !position; + let source = + Extension_source + { + name = Ident.name id; + position = !position; + type_path = Marshal.to_string extension.ext_type_path []; + type_params = List.map add_root extension.ext_type_params; + args = freeze_args extension.ext_args; + ret_type = Option.map add_root extension.ext_ret_type; + private_flag = extension.ext_private; + loc = extension.ext_loc; + attributes = marshal_nonempty extension.ext_attributes; + is_exception = extension.ext_is_exception; + } + in + index_source constructor_sources (Ident.name id) source; + incr position + | Sig_module (id, declaration, _) -> + let name = Ident.name id in + if String_map.mem name !modules then + duplicate_module_names := + String_set.add name !duplicate_module_names; + add_binder scope_path context Bound_module id !position; + let nested = + match declaration.md_type with + | Mty_signature signature -> + Some + (freeze_scope + (scope_path @ [(name, !position)]) + context signature) + | Mty_ident _ as module_type -> ( + match signature_of_modtype [] module_type with + | None -> None + | Some signature -> + let instantiation = create_context context in + let nested = + freeze_scope + (scope_path @ [(name, !position)]) + (Some instantiation) signature + in + contexts := + Int_map.add instantiation.id + { + parent = instantiation.parent; + type_binders = !(instantiation.types); + module_binders = !(instantiation.modules); + modtype_binders = !(instantiation.modtypes); + } + !contexts; + Some nested) + | Mty_functor _ | Mty_alias _ -> None + in + modules := + String_map.add name + { + position = !position; + loc = declaration.md_loc; + deprecated = + Builtin_attributes.deprecated_of_attrs + declaration.md_attributes; + nested; + module_type = freeze_module_type declaration.md_type; + attributes = marshal_nonempty declaration.md_attributes; + } + !modules; + incr position + | Sig_modtype (id, declaration) -> + let name = Ident.name id in + if String_map.mem name !modtypes then + duplicate_modtype_names := + String_set.add name !duplicate_modtype_names; + add_binder scope_path context Bound_modtype id Path.nopos; + Option.iter + (fun module_type -> + Hashtbl.replace modtype_definitions id.Ident.stamp module_type) + declaration.mtd_type; + modtypes := + String_map.add name + { + definition = Option.map freeze_module_type declaration.mtd_type; + loc = declaration.mtd_loc; + attributes = marshal_nonempty declaration.mtd_attributes; + } + !modtypes) + signature; + { + id; + path = scope_path; + context_id = Option.map (fun context -> context.id) context; + values = !values; + type_names = !type_names; + duplicate_type_names = !duplicate_type_names; + types = !types; + label_sources = !label_sources; + constructor_sources = !constructor_sources; + modules = !modules; + duplicate_module_names = !duplicate_module_names; + modtypes = !modtypes; + duplicate_modtype_names = !duplicate_modtype_names; + } + in + let root = freeze_scope [] None cmi.cmi_sign in + match Frozen_type_graph.freeze (List.rev !roots) with + | Error reason -> Error reason + | Ok graph -> + Ok + { + name = cmi.cmi_name; + signature_bytes = Marshal.to_string cmi.cmi_sign []; + graph; + type_binders = !type_binders; + module_binders = !module_binders; + modtype_binders = !modtype_binders; + contexts = !contexts; + layouts = Array.of_list (List.rev !layouts); + root; + } + +let create_graph_context image context_id = + let root = Path.Pident (Ident.create_persistent image.name) in + let rec find_context_binder context_id select stamp = + match context_id with + | None -> None + | Some context_id -> ( + let context = Int_map.find context_id image.contexts in + match Stamp_map.find_opt stamp (select context) with + | Some _ as entry -> entry + | None -> find_context_binder context.parent select stamp) + in + let prefixed global select id = + let entry = + match find_context_binder context_id select id.Ident.stamp with + | Some _ as entry -> entry + | None -> Stamp_map.find_opt id.Ident.stamp global + in + match entry with + | Some segments -> + List.fold_left + (fun path (name, position) -> Path.Pdot (path, name, position)) + root segments + | None -> Path.Pident id + in + let rec map_module_path = function + | Path.Pident id -> + prefixed image.module_binders (fun context -> context.module_binders) id + | Path.Pdot (path, name, position) -> + Path.Pdot (map_module_path path, name, position) + | Path.Papply (first, second) -> + Path.Papply (map_module_path first, map_module_path second) + in + let map_type_path path = + match Path.constructor_typath path with + | Path.Regular (Path.Pident id) -> + prefixed image.type_binders (fun context -> context.type_binders) id + | Path.Regular (Path.Pdot (module_path, name, position)) -> + Path.Pdot (map_module_path module_path, name, position) + | Path.Regular (Path.Papply _) -> path + | Path.Cstr (type_path, constructor) -> + let type_path = + match type_path with + | Path.Pident id -> + prefixed image.type_binders (fun context -> context.type_binders) id + | Path.Pdot (module_path, name, position) -> + Path.Pdot (map_module_path module_path, name, position) + | Path.Papply _ -> type_path + in + Path.Pdot (type_path, constructor, Path.nopos) + | Path.LocalExt _ -> path + | Path.Ext (module_path, constructor) -> + Path.Pdot (map_module_path module_path, constructor, Path.nopos) + in + let map_modtype_path = function + | Path.Pident id -> + prefixed image.modtype_binders (fun context -> context.modtype_binders) id + | Path.Pdot (path, name, position) -> + Path.Pdot (map_module_path path, name, position) + | Path.Papply _ as path -> map_module_path path + in + { + graph = + lazy + (Frozen_type_graph.create_view ~map_type_path ~map_modtype_path + image.graph); + map_type_path; + map_module_path; + map_modtype_path; + } + +let create_view image = + { + image; + root_context = create_graph_context image None; + materialized_values = Hashtbl.create 16; + materialized_types = Hashtbl.create 16; + materialized_extensions = Hashtbl.create 8; + materialized_modules = Hashtbl.create 8; + materialized_modtypes = Hashtbl.create 8; + substitutions = Hashtbl.create 8; + context_graphs = Hashtbl.create 8; + materialized_layouts = Hashtbl.create 8; + } + +let has_materialized_type_graph view = + Lazy.is_val view.root_context.graph + || Hashtbl.fold + (fun _ context found -> found || Lazy.is_val context.graph) + view.context_graphs false + +let copy_signature view : signature = + let source = Marshal.from_string view.image.signature_bytes 0 in + Subst.signature Subst.identity source + +let source_signature view : signature = + Marshal.from_string view.image.signature_bytes 0 + +let scope_context view (scope : scope) = + match scope.context_id with + | None -> view.root_context + | Some context_id -> ( + match Hashtbl.find_opt view.context_graphs context_id with + | Some context -> context + | None -> + let context = create_graph_context view.image (Some context_id) in + Hashtbl.add view.context_graphs context_id context; + context) + +let scope_graph view scope = + let context = scope_context view scope in + (Lazy.force context.graph, context.map_type_path) + +let scope_layout view (scope : scope) id = + let key = (scope.context_id, id) in + match Hashtbl.find_opt view.materialized_layouts key with + | Some layout -> layout + | None -> + let {configuration; cases} = view.image.layouts.(id) in + let layout = Variant_runtime.pending_layout () in + Variant_runtime.complete_layout layout + (Variant_runtime.make_layout ~configuration (Array.of_list cases)); + Hashtbl.add view.materialized_layouts key layout; + layout + +let thaw_attributes = function + | None -> [] + | Some bytes -> Marshal.from_string bytes 0 + +let fresh_member_id name flags = + {Ident.name; stamp = Atomic.fetch_and_add imported_member_stamp (-1); flags} + +let thaw_label graph (label : frozen_label) = + { + ld_id = fresh_member_id label.name label.flags; + ld_runtime_name = label.runtime_name; + ld_mutable = label.mutable_flag; + ld_optional = label.optional; + ld_type = Frozen_type_graph.type_at graph label.typ; + ld_loc = label.loc; + ld_attributes = thaw_attributes label.attributes; + } + +let thaw_args graph = function + | Frozen_tuple types -> + Cstr_tuple (List.map (Frozen_type_graph.type_at graph) types) + | Frozen_record_arguments labels -> + Cstr_record (List.map (thaw_label graph) labels) + +let scope_path view (scope : scope) = + List.fold_left + (fun path (name, position) -> Path.Pdot (path, name, position)) + (Path.Pident (Ident.create_persistent view.image.name)) + scope.path + +let scope_substitution view (scope : scope) = + match Hashtbl.find_opt view.substitutions scope.id with + | Some substitution -> substitution + | None -> + let rec is_prefix prefix path = + match (prefix, path) with + | [], _ -> true + | first :: rest, next :: tail when first = next -> is_prefix rest tail + | _ -> false + in + let rec parent_segments = function + | [] | [_] -> [] + | first :: rest -> first :: parent_segments rest + in + let is_visible segments = is_prefix (parent_segments segments) scope.path in + let path segments = + List.fold_left + (fun path (name, position) -> Path.Pdot (path, name, position)) + (Path.Pident (Ident.create_persistent view.image.name)) + segments + in + let identifier stamp segments = + let name, _ = List.hd (List.rev segments) in + {Ident.name; stamp; flags = 0} + in + let add table add substitution = + Stamp_map.fold + (fun stamp segments substitution -> + if is_visible segments then + add (identifier stamp segments) (path segments) substitution + else substitution) + table substitution + in + let substitution = + Subst.identity + |> add view.image.type_binders Subst.add_type + |> add view.image.module_binders Subst.add_module + |> add view.image.modtype_binders (fun id path substitution -> + Subst.add_modtype id (Mty_ident path) substitution) + in + let rec context_chain = function + | None -> [] + | Some context_id -> + let context = Int_map.find context_id view.image.contexts in + context_chain context.parent @ [context] + in + let substitution = + List.fold_left + (fun substitution (context : binder_context) -> + substitution + |> add context.type_binders Subst.add_type + |> add context.module_binders Subst.add_module + |> add context.modtype_binders (fun id path substitution -> + Subst.add_modtype id (Mty_ident path) substitution)) + substitution + (context_chain scope.context_id) + in + Hashtbl.add view.substitutions scope.id substitution; + substitution + +let thaw_module_type view (scope : scope) = function + | Simple_alias (presence, bytes) -> + let source_path = Marshal.from_string bytes 0 in + let context = scope_context view scope in + Mty_alias (presence, context.map_module_path source_path) + | Simple_ident bytes -> + let source_path = Marshal.from_string bytes 0 in + let context = scope_context view scope in + Mty_ident (context.map_modtype_path source_path) + | Complex_module_type bytes -> + Compiler_phase_trace.dependency "dependency.frozen_complex_modtype_fallback" + (fun () -> + let source = Marshal.from_string bytes 0 in + Subst.modtype (scope_substitution view scope) source) + +let find_module_declaration view (scope : scope) name = + if String_set.mem name scope.duplicate_module_names then None + else + match String_map.find_opt name scope.modules with + | None -> None + | Some entry -> ( + let key = (scope.id, name) in + match Hashtbl.find_opt view.materialized_modules key with + | Some declaration -> Some (declaration, entry.position) + | None -> + let declaration = + { + md_type = thaw_module_type view scope entry.module_type; + md_attributes = thaw_attributes entry.attributes; + md_loc = entry.loc; + } + in + Hashtbl.add view.materialized_modules key declaration; + Some (declaration, entry.position)) + +let find_modtype_declaration view (scope : scope) name = + if String_set.mem name scope.duplicate_modtype_names then None + else + match String_map.find_opt name scope.modtypes with + | None -> None + | Some entry -> ( + let key = (scope.id, name) in + match Hashtbl.find_opt view.materialized_modtypes key with + | Some declaration -> Some declaration + | None -> + let declaration = + { + mtd_type = Option.map (thaw_module_type view scope) entry.definition; + mtd_attributes = thaw_attributes entry.attributes; + mtd_loc = entry.loc; + } + in + Hashtbl.add view.materialized_modtypes key declaration; + Some declaration) + +let thaw_extension view (scope : scope) (extension : frozen_extension) = + let key = (scope.id, extension.position) in + match Hashtbl.find_opt view.materialized_extensions key with + | Some descr -> descr + | None -> + let graph, map_type_path = scope_graph view scope in + let path = + Path.Pdot (scope_path view scope, extension.name, extension.position) + in + let ext : extension_constructor = + { + ext_type_path = map_type_path (Marshal.from_string extension.type_path 0); + ext_type_params = + List.map (Frozen_type_graph.type_at graph) extension.type_params; + ext_args = thaw_args graph extension.args; + ext_ret_type = + Option.map (Frozen_type_graph.type_at graph) extension.ret_type; + ext_private = extension.private_flag; + ext_loc = extension.loc; + ext_attributes = thaw_attributes extension.attributes; + ext_is_exception = extension.is_exception; + } + in + let descr = Datarepr.extension_descr path ext in + Hashtbl.add view.materialized_extensions key descr; + descr + +let find_in_scope view (scope : scope) name = + let key = (scope.id, name) in + match Hashtbl.find_opt view.materialized_values key with + | Some value -> Some value + | None -> ( + match String_map.find_opt name scope.values with + | None -> None + | Some {typ; kind; loc; attributes; position} -> + let graph, _ = scope_graph view scope in + let val_type = Frozen_type_graph.type_at graph typ in + let val_kind = + match kind with + | None -> Val_reg + | Some bytes -> Marshal.from_string bytes 0 + in + let val_attributes = thaw_attributes attributes in + let value = + ({val_type; val_kind; val_loc = loc; val_attributes}, position) + in + Hashtbl.add view.materialized_values key value; + Some value) + +let find_type_in_scope view (scope : scope) name = + let key = (scope.id, name) in + match Hashtbl.find_opt view.materialized_types key with + | Some declaration -> Some declaration + | None -> ( + match String_map.find_opt name scope.types with + | None -> None + | Some + { + params; + arity; + kind; + private_flag; + manifest; + variance; + loc; + attributes; + immediate; + representation; + inlined_types; + } -> + let graph, _ = scope_graph view scope in + let thaw_constructor (constructor : frozen_constructor) = + { + cd_id = fresh_member_id constructor.name constructor.flags; + cd_runtime_tag = constructor.runtime_tag; + cd_args = thaw_args graph constructor.args; + cd_res = + Option.map (Frozen_type_graph.type_at graph) constructor.result; + cd_loc = constructor.loc; + cd_attributes = thaw_attributes constructor.attributes; + } + in + let declaration = + { + type_params = List.map (Frozen_type_graph.type_at graph) params; + type_arity = arity; + type_kind = + (match kind with + | Frozen_abstract -> Type_abstract + | Frozen_record (labels, representation) -> + let representation = + match representation with + | Static_record representation -> representation + | Inlined_record {name; layout; position} -> + Record_inlined + { + name; + representation = + {variant = scope_layout view scope layout; position}; + } + in + Type_record (List.map (thaw_label graph) labels, representation) + | Frozen_variant (constructors, layout) -> + Type_variant + ( List.map thaw_constructor constructors, + scope_layout view scope layout ) + | Frozen_open -> Type_open); + type_private = private_flag; + type_manifest = Option.map (Frozen_type_graph.type_at graph) manifest; + type_variance = variance; + type_newtype_level = None; + type_loc = loc; + type_attributes = thaw_attributes attributes; + type_immediate = immediate; + type_representation = representation; + type_inlined_types = + List.map + (function + | Frozen_inlined_record (type_name, labels) -> + Record + {type_name; labels = List.map (thaw_label graph) labels}) + inlined_types; + } + in + let path = Path.Pdot (scope_path view scope, name, Path.nopos) in + Datarepr.set_row_name declaration path; + let descriptions = + ( List.map snd (Datarepr.constructors_of_type path declaration), + List.map snd (Datarepr.labels_of_type path declaration) ) + in + let result = (declaration, descriptions) in + Hashtbl.add view.materialized_types key result; + Some result) + +let find_labels_in_scope view (scope : scope) name = + match String_map.find_opt name scope.label_sources with + | None -> Some [] + | Some sources + when List.exists + (fun source -> String_set.mem source scope.duplicate_type_names) + sources -> + None + | Some sources -> + let rec collect acc = function + | [] -> Some (List.rev acc) + | source :: rest -> ( + match find_type_in_scope view scope source with + | None -> None + | Some (_, (_, labels)) -> + let matching = + List.filter (fun label -> label.lbl_name = name) labels + in + collect (List.rev_append matching acc) rest) + in + collect [] sources + +let find_constructors_in_scope view (scope : scope) name = + match String_map.find_opt name scope.constructor_sources with + | None -> Some [] + | Some sources -> + let rec collect acc = function + | [] -> Some (List.rev acc) + | Extension_source extension :: rest -> + collect (thaw_extension view scope extension :: acc) rest + | Variant_source source :: rest -> ( + if String_set.mem source scope.duplicate_type_names then None + else + match find_type_in_scope view scope source with + | None -> None + | Some (_, (constructors, _)) -> + let matching = + List.filter + (fun constructor -> constructor.cstr_name = name) + constructors + in + collect (List.rev_append matching acc) rest) + in + collect [] sources + +let find_extension_in_scope view (scope : scope) name = + match String_map.find_opt name scope.constructor_sources with + | None -> None + | Some sources -> ( + let extensions = + List.filter_map + (function + | Extension_source extension -> Some extension + | Variant_source _ -> None) + sources + in + match extensions with + | [extension] -> Some (thaw_extension view scope extension) + | [] | _ :: _ :: _ -> None) + +let root_scope view = view.image.root + +let names table = List.map fst (String_map.bindings table) +let value_names (scope : scope) = names scope.values +let type_names (scope : scope) = String_set.elements scope.type_names +let label_names (scope : scope) = names scope.label_sources +let constructor_names (scope : scope) = names scope.constructor_sources +let module_names (scope : scope) = names scope.modules +let modtype_names (scope : scope) = names scope.modtypes +let has_value (scope : scope) name = String_map.mem name scope.values +let has_type (scope : scope) name = String_set.mem name scope.type_names +let has_label (scope : scope) name = String_map.mem name scope.label_sources + +let has_constructor (scope : scope) name = + String_map.mem name scope.constructor_sources + +let has_module (scope : scope) name = String_map.mem name scope.modules +let has_modtype (scope : scope) name = String_map.mem name scope.modtypes + +let find_module_info (scope : scope) name = + if String_set.mem name scope.duplicate_module_names then None + else + match String_map.find_opt name scope.modules with + | Some {position; loc; deprecated} -> Some (position, loc, deprecated) + | None -> None + +let find_module_alias view (scope : scope) name = + if String_set.mem name scope.duplicate_module_names then None + else + match String_map.find_opt name scope.modules with + | Some {module_type = Simple_alias (_, bytes)} -> + let path = Marshal.from_string bytes 0 in + let context = scope_context view scope in + Some (context.map_module_path path) + | Some {module_type = Simple_ident _ | Complex_module_type _} | None -> None + +let find_module (scope : scope) name = + if String_set.mem name scope.duplicate_module_names then None + else + match String_map.find_opt name scope.modules with + | Some {nested = Some nested; position; loc; deprecated} -> + Some (nested, position, loc, deprecated) + | Some {nested = None} | None -> None + +let find view name = find_in_scope view view.image.root name +let find_type view name = find_type_in_scope view view.image.root name +let find_labels view name = find_labels_in_scope view view.image.root name + +let find_constructors view name = + find_constructors_in_scope view view.image.root name + +let find_extension view name = find_extension_in_scope view view.image.root name + +let value_count (image : t) = String_map.cardinal image.root.values +let is_type_name_in_scope scope name = String_set.mem name scope.type_names +let is_type_name view name = is_type_name_in_scope view.image.root name +let type_count (image : t) = String_map.cardinal image.root.types +let type_node_count (image : t) = Frozen_type_graph.node_count image.graph diff --git a/compiler/ml/frozen_values.mli b/compiler/ml/frozen_values.mli new file mode 100644 index 00000000000..51c16204b09 --- /dev/null +++ b/compiler/ml/frozen_values.mli @@ -0,0 +1,114 @@ +(** The directly indexed slice of an immutable compiled interface. The image + is safe to share between compiler domains; every [view] and materialized + declaration belongs to one compilation request. *) + +type t +type view +type scope + +val freeze : Cmi_format.cmi_infos -> (t, string) result +(** Snapshot an imported signature, its nested scopes, type graph, module + declarations, and name indexes into project-shareable data. *) + +val create_view : t -> view + +val has_materialized_type_graph : view -> bool +(** Report whether any request-local type graph has been materialized. *) + +val copy_signature : view -> Types.signature +(** Materialize an entire request-owned signature when a caller needs one. + This is intentionally a full-copy compatibility path. *) + +val source_signature : view -> Types.signature +(** Decode a private source signature for legacy component expansion. *) + +val root_scope : view -> scope + +val value_names : scope -> string list +val type_names : scope -> string list +val label_names : scope -> string list +val constructor_names : scope -> string list +val module_names : scope -> string list +val modtype_names : scope -> string list +val has_value : scope -> string -> bool +val has_type : scope -> string -> bool +val has_label : scope -> string -> bool +val has_constructor : scope -> string -> bool +val has_module : scope -> string -> bool +val has_modtype : scope -> string -> bool + +val find_module : + scope -> string -> (scope * int * Location.t * string option) option +(** Return a nested signature and its path position, location, and deprecation + message. Literal signatures and instances of locally declared module + types are indexed. Aliases, functors, and shadowed module names return + [None] here and have separate declaration or alias accessors. *) + +val find_module_info : + scope -> string -> (int * Location.t * string option) option + +val find_module_alias : view -> scope -> string -> Path.t option +(** Return the target of a module alias after prefixing local binders. *) + +val find_module_declaration : + view -> scope -> string -> (Types.module_declaration * int) option +(** Materialize one request-local module declaration. Simple paths use the + frozen binder map; complex signatures and functors are substituted. *) + +val find_modtype_declaration : + view -> scope -> string -> Types.modtype_declaration option +(** Materialize one request-local module-type declaration. *) + +val find_in_scope : + view -> scope -> string -> (Types.value_description * int) option + +val find_type_in_scope : + view -> + scope -> + string -> + (Types.type_declaration + * (Types.constructor_description list * Types.label_description list)) + option + +val find_labels_in_scope : + view -> scope -> string -> Types.label_description list option + +val find_constructors_in_scope : + view -> scope -> string -> Types.constructor_description list option + +val find_extension_in_scope : + view -> scope -> string -> Types.constructor_description option + +val is_type_name_in_scope : scope -> string -> bool + +val find : view -> string -> (Types.value_description * int) option +(** Return a request-local description and its signature position. No type + graph or declaration record from the image escapes this operation. *) + +val find_type : + view -> + string -> + (Types.type_declaration + * (Types.constructor_description list * Types.label_description list)) + option +(** Materialize a root type and its descriptions in the request-local view. *) + +val find_labels : view -> string -> Types.label_description list option +(** Return request-local root record labels. [None] means a duplicate or + unsupported declaration needs the legacy component path. *) + +val find_constructors : + view -> string -> Types.constructor_description list option +(** Return request-local top-level variant and extension constructors. [None] + means an unsupported declaration needs the existing component path. *) + +val find_extension : view -> string -> Types.constructor_description option +(** Return a unique extension constructor for a constructor type path. *) + +val value_count : t -> int + +val is_type_name : view -> string -> bool +(** Test whether a top-level name denotes a type, without materializing it. *) + +val type_count : t -> int +val type_node_count : t -> int diff --git a/compiler/ml/location.ml b/compiler/ml/location.ml index d33acc9bd6d..20b4560f2ae 100644 --- a/compiler/ml/location.ml +++ b/compiler/ml/location.ml @@ -167,10 +167,37 @@ let default_warning_printer loc ppf w = let warning_printer = ref default_warning_printer +type diagnostic = {severity: [`Error | `Warning]; location: t; message: string} + +let diagnostic_capture_key = Domain.DLS.new_key (fun () -> ref None) + +let with_diagnostic_capture action = + let slot = Domain.DLS.get diagnostic_capture_key in + let previous = !slot in + let captured = ref [] in + slot := Some captured; + Fun.protect + (fun () -> + let result = action () in + (result, List.rev !captured)) + ~finally:(fun () -> slot := previous) + +let capture_diagnostic diagnostic = + match !(Domain.DLS.get diagnostic_capture_key) with + | None -> () + | Some captured -> captured := diagnostic :: !captured + let print_warning loc ppf w = !warning_printer loc ppf w let formatter_for_warnings = ref err_formatter let prerr_warning loc w = + if Warnings.is_active w then + capture_diagnostic + { + severity = (if Warnings.is_error w then `Error else `Warning); + location = loc; + message = Warnings.message w; + }; let ppf = if Compiler_request_output.is_active () then Compiler_request_output.stderr_formatter () @@ -263,6 +290,7 @@ let rec default_error_reporter ?(custom_intro = None) ?(src = None) ppf let error_reporter = ref default_error_reporter let report_error ?(custom_intro = None) ?(src = None) ppf err = + capture_diagnostic {severity = `Error; location = err.loc; message = err.msg}; !error_reporter ~custom_intro ~src ppf err let error_of_printer loc print x = errorf ~loc "%a@?" print x diff --git a/compiler/ml/location.mli b/compiler/ml/location.mli index fcefcd3ef62..5b5238dc5ee 100644 --- a/compiler/ml/location.mli +++ b/compiler/ml/location.mli @@ -47,6 +47,12 @@ val print_loc : formatter -> t -> unit val prerr_warning : t -> Warnings.t -> unit +type diagnostic = {severity: [`Error | `Warning]; location: t; message: string} + +val with_diagnostic_capture : (unit -> 'a) -> 'a * diagnostic list +(** Capture located compiler diagnostics on the current domain while keeping + the ordinary formatted output unchanged. *) + val warning_printer : (t -> formatter -> Warnings.t -> unit) ref (** Hook for intercepting warnings. *) diff --git a/compiler/ml/platform/native/cmt_format_persistence.ml b/compiler/ml/platform/native/cmt_format_persistence.ml index 5289b8c1f04..44d902cdf39 100644 --- a/compiler/ml/platform/native/cmt_format_persistence.ml +++ b/compiler/ml/platform/native/cmt_format_persistence.ml @@ -17,42 +17,80 @@ open Cmt_format_common let set_args value = (Compiler_request_state.current ()).cmt_args <- value -let output_cmt output_channel cmt = - output_string output_channel Config.cmt_magic_number; - output_value output_channel (cmt : cmt_infos) - -let save_cmt filename modname binary_annots sourcefile initial_env cmi = +let save_cmt ?capture filename modname binary_annots sourcefile initial_env cmi + = if !((Clflags.current ()).binary_annotations) then - Misc.output_to_bin_file_directly filename - (fun temp_file_name output_channel -> - let interface_digest = + Compiler_phase_trace.section "artifact.cmt_persist" (fun () -> + let cmi_contents, interface_digest = match cmi with - | None -> None + | None -> ("", None) | Some cmi -> - Some (Cmi_format.output_cmi temp_file_name output_channel cmi) + let contents, digest = Cmi_format.encode_cmi cmi in + (contents, Some digest) in let cmt = - { - cmt_modname = modname; - cmt_annots = clear_env binary_annots; - cmt_value_dependencies = value_dependencies (); - cmt_comments = []; - cmt_args = (Compiler_request_state.current ()).cmt_args; - cmt_sourcefile = sourcefile; - cmt_builddir = Compiler_request_state.cwd (); - cmt_loadpath = Config.get_load_path (); - cmt_source_digest = - Misc.may_map - (fun path -> - Digest.file (Compiler_request_state.resolve_path path)) - sourcefile; - cmt_initial_env = - (if need_to_clear_env then keep_only_summary initial_env - else initial_env); - cmt_imports = List.sort compare (Env.imports ()); - cmt_interface_digest = interface_digest; - cmt_use_summaries = need_to_clear_env; - cmt_extra_info = {deprecated_used = deprecated_uses ()}; - } + Compiler_phase_trace.section "artifact.cmt_prep" (fun () -> + { + cmt_modname = modname; + cmt_annots = clear_env binary_annots; + cmt_value_dependencies = value_dependencies (); + cmt_comments = []; + cmt_args = (Compiler_request_state.current ()).cmt_args; + cmt_sourcefile = sourcefile; + cmt_builddir = Compiler_request_state.cwd (); + cmt_loadpath = Config.get_load_path (); + cmt_source_digest = + Compiler_phase_trace.section "artifact.cmt_source_hash" + (fun () -> + Misc.may_map + (fun path -> + Digest.file (Compiler_request_state.resolve_path path)) + sourcefile); + cmt_initial_env = + (if need_to_clear_env then keep_only_summary initial_env + else initial_env); + cmt_imports = List.sort compare (Env.imports ()); + cmt_interface_digest = interface_digest; + cmt_use_summaries = need_to_clear_env; + cmt_extra_info = {deprecated_used = deprecated_uses ()}; + }) + in + let contents = + Compiler_phase_trace.section "artifact.cmt_serialize" (fun () -> + cmi_contents ^ Config.cmt_magic_number ^ Marshal.to_string cmt []) + in + let deferred = + match capture with + | None -> false + | Some capture -> capture filename cmt contents in - output_cmt output_channel cmt) + if not deferred then + Misc.output_to_file_via_temporary ~mode:[Open_binary] filename + (fun _ output_channel -> output_string output_channel contents); + Some cmt) + else if !((Clflags.current ()).bs_gentype) then + match binary_annots with + | Partial_implementation _ | Partial_interface _ -> None + | Implementation _ | Interface _ | Packed _ -> + Some + { + cmt_modname = modname; + cmt_annots = clear_env binary_annots; + cmt_value_dependencies = []; + cmt_comments = []; + cmt_args = [||]; + cmt_sourcefile = sourcefile; + cmt_builddir = Compiler_request_state.cwd (); + cmt_loadpath = Config.get_load_path (); + cmt_source_digest = + Misc.may_map + (fun path -> + Digest.file (Compiler_request_state.resolve_path path)) + sourcefile; + cmt_initial_env = initial_env; + cmt_imports = List.sort compare (Env.imports ()); + cmt_interface_digest = None; + cmt_use_summaries = false; + cmt_extra_info = {deprecated_used = []}; + } + else None diff --git a/compiler/ml/platform/playground/cmt_format_persistence.ml b/compiler/ml/platform/playground/cmt_format_persistence.ml index e1dd676b61a..8fd5ff2504d 100644 --- a/compiler/ml/platform/playground/cmt_format_persistence.ml +++ b/compiler/ml/platform/playground/cmt_format_persistence.ml @@ -1,4 +1,5 @@ let set_args _value = () -let save_cmt _filename _modname _binary_annots _sourcefile _initial_env _cmi = - () +let save_cmt ?capture:_ _filename _modname _binary_annots _sourcefile + _initial_env _cmi = + None diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 2de770185d6..160531a4659 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -137,12 +137,15 @@ let type_package = ref (fun _ -> assert false) or [Typedtree.pattern] that will end up in the typed AST. *) let re node = - Cmt_format.add_saved_type (Cmt_format.Partial_expression node); - Stypes.record (Stypes.Ti_expr node); + if !((Clflags.current ()).binary_annotations) then + Cmt_format.add_saved_type (Cmt_format.Partial_expression node); + if !((Clflags.current ()).annotations) then + Stypes.record (Stypes.Ti_expr node); node let rp node = - Cmt_format.add_saved_type (Cmt_format.Partial_pattern node); - Stypes.record (Stypes.Ti_pat node); + if !((Clflags.current ()).binary_annotations) then + Cmt_format.add_saved_type (Cmt_format.Partial_pattern node); + if !((Clflags.current ()).annotations) then Stypes.record (Stypes.Ti_pat node); node type recarg = Allowed | Required | Rejected @@ -498,8 +501,7 @@ let enter_variable ?(is_module = false) ?(is_as_variable = false) loc name ty = if not !(allow_modules_ref ()) then raise (Error (loc, Env.empty, Modules_not_allowed)); module_variables_ref () := (name, loc) :: !(module_variables_ref ())) - else - (* moved to genannot *) + else if !((Clflags.current ()).annotations) then may (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s))) !(pattern_scope_ref ()); diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index 6f603c11700..c0b84c09faa 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -86,13 +86,14 @@ let extract_sig_open env loc mty = (* Compute the environment after opening a module *) let type_open_ ?used_slot ?toplevel ovf env loc lid = - let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in - match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with - | Some env -> (path, env) - | None -> - let md = Env.find_module path env in - ignore (extract_sig_open env lid.loc md.md_type); - assert false + Compiler_phase_trace.open_signature (fun () -> + let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in + match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with + | Some env -> (path, env) + | None -> + let md = Env.find_module path env in + ignore (extract_sig_open env lid.loc md.md_type); + assert false) let type_open ?toplevel env sod = let path, newenv = @@ -111,7 +112,7 @@ let type_open ?toplevel env sod = (* Record a module type *) let rm node = - Stypes.record (Stypes.Ti_mod node); + if !((Clflags.current ()).annotations) then Stypes.record (Stypes.Ti_mod node); node (* Forward declaration, to be filled in by type_module_type_of *) @@ -679,12 +680,14 @@ let mkmty desc typ env loc attrs = mty_attributes = attrs; } in - Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); + if !((Clflags.current ()).binary_annotations) then + Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); mty let mksig desc env loc = let sg = {sig_desc = desc; sig_loc = loc; sig_env = env} in - Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); + if !((Clflags.current ()).binary_annotations) then + Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); sg (* let signature sg = List.map (fun item -> item.sig_type) sg *) @@ -1730,67 +1733,74 @@ let () = let type_implementation_more ?check_exists sourcefile outputprefix modulename initial_env ast = - Cmt_format.clear (); - try - Delayed_checks.reset_delayed_checks (); - let str, sg, finalenv = - type_structure initial_env ast (Location.in_file sourcefile) - in - let simple_sg = simplify_signature sg in - let mli_status = !((Clflags.current ()).assume_no_mli) in - if mli_status = Clflags.Mli_exists then ( - let intf_file = - try find_in_path_uncap (Config.get_load_path ()) (modulename ^ ".cmi") - with Not_found -> - let sourceintf = - Filename.remove_extension sourcefile ^ Literals.suffix_resi + Compiler_phase_trace.section "source.check" (fun () -> + Cmt_format.clear (); + try + Delayed_checks.reset_delayed_checks (); + let str, sg, finalenv = + type_structure initial_env ast (Location.in_file sourcefile) + in + let simple_sg = simplify_signature sg in + let mli_status = !((Clflags.current ()).assume_no_mli) in + if mli_status = Clflags.Mli_exists then ( + let intf_file = + Compiler_phase_trace.dependency "dependency.interface_search" + (fun () -> + try Env.find_compiled_cmi modulename + with Not_found -> + let sourceintf = + Filename.remove_extension sourcefile ^ Literals.suffix_resi + in + raise + (Error + ( Location.in_file sourcefile, + Env.empty, + Interface_not_compiled sourceintf ))) in - raise - (Error - ( Location.in_file sourcefile, - Env.empty, - Interface_not_compiled sourceintf )) - in - let dclsig = Env.read_signature modulename intf_file in - let coercion = - Includemod.compunit initial_env sourcefile sg intf_file dclsig - in - Delayed_checks.force_delayed_checks (); - (* It is important to run these checks after the inclusion test above, + let dclsig = + Compiler_phase_trace.dependency "dependency.interface_open" + (fun () -> Env.read_signature modulename intf_file) + in + let coercion = + Includemod.compunit initial_env sourcefile sg intf_file dclsig + in + Delayed_checks.force_delayed_checks (); + (* It is important to run these checks after the inclusion test above, so that value declarations which are not used internally but exported are not reported as being unused. *) - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) (Some sourcefile) initial_env None; - (str, coercion, finalenv, dclsig) - (* identifier is useless might read from serialized cmi files*)) - else - let coercion = - Includemod.compunit initial_env sourcefile sg "(inferred signature)" - simple_sg - in - check_nongen_schemes finalenv simple_sg; - normalize_signature finalenv simple_sg; - Delayed_checks.force_delayed_checks (); - (* See comment above. Here the target signature contains all + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) (Some sourcefile) initial_env None; + (str, coercion, finalenv, dclsig) + (* identifier is useless might read from serialized cmi files*)) + else + let coercion = + Includemod.compunit initial_env sourcefile sg "(inferred signature)" + simple_sg + in + check_nongen_schemes finalenv simple_sg; + normalize_signature finalenv simple_sg; + Delayed_checks.force_delayed_checks (); + (* See comment above. Here the target signature contains all the value being exported. We can still capture unused declarations like "let x = true;; let x = 1;;", because in this case, the inferred signature contains only the last declaration. *) - (if not !((Clflags.current ()).dont_write_files) then - let deprecated = Builtin_attributes.deprecated_of_str ast in - let cmi = - Env.save_signature ?check_exists ~deprecated simple_sg modulename - (outputprefix ^ ".cmi") - in - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) (Some sourcefile) initial_env - (Some cmi)); - (str, coercion, finalenv, simple_sg) - with e -> - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Partial_implementation - (Array.of_list (Cmt_format.get_saved_types ()))) - (Some sourcefile) initial_env None; - raise e + (if not !((Clflags.current ()).dont_write_files) then + let deprecated = Builtin_attributes.deprecated_of_str ast in + let cmi = + Env.save_signature ?check_exists ~deprecated simple_sg modulename + (outputprefix ^ ".cmi") + in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) (Some sourcefile) initial_env + (Some cmi)); + (str, coercion, finalenv, simple_sg) + with e -> + if !((Clflags.current ()).binary_annotations) then + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Partial_implementation + (Array.of_list (Cmt_format.get_saved_types ()))) + (Some sourcefile) initial_env None; + raise e) let save_signature modname tsg outputprefix source_file initial_env cmi = Cmt_format.save_cmt (outputprefix ^ ".cmti") modname diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 94147e90342..318bfcc950a 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -19,7 +19,7 @@ open Asttypes (* Type expressions for the core language *) -type type_expr = {mutable desc: type_desc; mutable level: int; id: int} +type type_expr = {mutable desc: type_desc; mutable level: int; mutable id: int} and arg = {lbl: arg_label; typ: type_expr} diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 47c2aaf1473..ed8102235d9 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -24,7 +24,7 @@ open Asttypes (** Asttypes exposes basic definitions shared both by Parsetree and Types. *) -type type_expr = {mutable desc: type_desc; mutable level: int; id: int} +type type_expr = {mutable desc: type_desc; mutable level: int; mutable id: int} (** Type expressions for the core language. The [type_desc] variant defines all the possible type expressions one can @@ -32,6 +32,9 @@ type type_expr = {mutable desc: type_desc; mutable level: int; id: int} The [level] field tracks the level of polymorphism associated to a type, guiding the generalization algorithm. + [id] may be relocated only while a cached dependency graph is exclusive + to one compiler request and before it is exposed to typing or used as a + map key. Put shortly, when referring to a type in a given environment, both the type and the environment have a level. If the type has an higher level, then it can be considered fully polymorphic (type variables will be printed as diff --git a/rewatch-ocaml/PARITY_CHECKLIST.md b/rewatch-ocaml/PARITY_CHECKLIST.md index 5f11bab500e..53eb042dd18 100644 --- a/rewatch-ocaml/PARITY_CHECKLIST.md +++ b/rewatch-ocaml/PARITY_CHECKLIST.md @@ -112,7 +112,7 @@ omitted because the Rust and OCaml files are still changing. | Watch source selection | `build/packages.rs`: feature and positive `matches_filter` discovery; `watcher.rs`: event filtering | `source.ml` and `package_graph.ml`: active discovery; `watcher.ml`: feature-aware native registrations and scoped content snapshots | Differential watch cases edit included, filter-excluded, and feature-disabled sources and inspect generated output and hook counts; a delayed compiler gate activates a source directory, creates a file after discovery, and requires exactly one queued follow-up build; an external source-symlink target is atomically replaced, removed, and recreated | Deliberate Rust bug fix: OCaml retains the CLI's positive regex meaning across initial discovery and every rebuild instead of negating it only for watch events. Feature-disabled and filter-excluded edits do not perform a no-op rebuild. Snapshots read only package control files and active configured source trees rather than recursively walking unrelated package-root contents. Target-parent watches keep regular source symlinks observable outside those trees. | | Watch state lifetime and dependency edits | `watcher.rs`: retained `BuildState`; `build.rs`: `build_incremental`; `build/deps.rs`: dependency extraction and reverse-edge updates | `native_watcher.ml`: identity-bearing handles and event paths/kinds; `watcher.ml`: pre-build content baselines and structural reconciliation; `build.ml`: retained source index and incremental preparation; `build_preparation.ml` and `build_state.ml`: resolved and reverse edges | Focused long-lived watchers cover dependency-edge replacement, cycles and recovery, atomic replacement during active compilation, directory-handle replacement, polling fallback, and the same native Windows event lifecycle; unit coverage verifies obsolete reverse-edge removal and duplicate prevention; retained performance and filesystem gates verify exact compiler work and resource stability | Existing-file edits retain initialized package, compiler, artifact, cleanup, source-index, and module state and parse only affected source paths. Precise content events capture their baseline before building; edits arriving during compilation remain distinguishable. Structural/ambiguous events reconstruct state and refresh handles whose filesystem identity changed. Changed dependency headers replace graph edges and rerun cycle detection in memory. Deliberate low-risk Rust inefficiency fix: indexed source lookup and obsolete reverse-edge removal avoid Rust's full module scan and accumulated reverse edges. | | Format input mode and explicit files | `cli.rs`: `Command::Format`, `FileExtension`, Clap `format_input_mode`; `format.rs`: `format_files` | `cli.ml`: `format_term`; `format.ml`: `format_files_with_bsc` | `cli_tests.ml` covers `.res`/`.resi`, invalid stdin extensions, stdin/file conflicts, and stdin/check conflicts in either argument order; differential cases exactly compare missing-file, directory, and unsupported-extension diagnostics | Matched, including errors delegated to the formatter for explicit operands | -| `compiler-args` positional and filesystem input | `cli.rs`: `Command::CompilerArgs`; `build.rs`: `get_compiler_args`; `helpers.rs`: `read_file`; `build/compile.rs`: dependency arguments | `cli.ml`: `compiler_args_term`; `compiler_args_command.ml`: project/source resolution and JSON projection; `compiler_args.ml`: shared argument policy | `cli_tests.ml` covers missing and surplus paths; the differential command gate covers valid, non-ReScript, missing, and no-project sources; `compiler_args_tests.ml` covers dev/regular dependencies and context | Matched where Rust validates, with documented extension validation and three non-panicking OCaml fixes | +| `compiler-args` positional and filesystem input | `cli.rs`: `Command::CompilerArgs`; `build.rs`: `get_compiler_args`; `helpers.rs`: `read_file`; `build/compile.rs`: dependency arguments | `cli.ml`: `compiler_args_term`; `compiler_args_command.ml`: project/source resolution and JSON projection; `compiler_args.ml`: shared argument policy | `cli_tests.ml` covers missing and surplus paths; the differential command gate covers valid, non-ReScript, missing, and no-project sources; `compiler_args_tests.ml` covers dev/regular dependencies and context | Matched where Rust validates, with documented extension validation and three non-panicking OCaml fixes; the config acceptance gate requires every shared argument to match while checking OCaml's intentional `-bs-no-bin-annot` default separately | | After-build hook execution | `main.rs`: successful-build hook dispatch; `cmd.rs`: `run` | `after_build.ml`: command execution; `build.ml`: post-success dispatch | Canonical/focused integration covers a successful hook; three differential command cases cover an empty command, a missing program, and a program exiting 7 with captured stderr | Deliberate safety fixes: OCaml reports empty and unlaunchable hooks normally rather than panicking, and makes a nonzero hook fail the command instead of discarding its status; all commands are still split on whitespace and launched outside the build lock like Rust. Windows inherits interactive stdin while retaining Job Object ownership. Unix terminal stdin remains closed because Spawn cannot both give the child a new, cancellable process group and atomically foreground it; redirected stdin is inherited. Full Unix interactive-hook stdin needs a tested PTY relay rather than risking `SIGTTIN` or weakening descendant cancellation. | | Per-output JS post-build hook | `build/compile.rs`: `execute_post_build_command` and `compile_file` | `compiler_process.ml`: `run_post_build`; `platform.mli` command construction | Focused integration checks the generated-file argument for a successful hook; the differential command gate makes the shell command exit 7 and requires both diagnostics to identify the generated JavaScript path; both run natively on Windows | Matched for invocation timing, working directory, output argument, failure status, and path-bearing diagnostics, including native `cmd.exe` execution | | Missing folder, missing config, and parent-config discovery failures | `lock.rs`: `get_lock`; `project_context.rs`: `ProjectContext::new`; `build/packages.rs`: `read_config` | `build.ml`: `project_root`; `build_lock.ml`: lock acquisition; `project_context.ml`: `workspace_lock_root`; `config.ml`: `load_root` | The differential command gate covers nonexistent, config-less, malformed, directory-config, and malformed-parent project paths; the focused runner exactly checks missing-folder wording; configuration tests cover direct file-read failures | Matched for project/config discovery outcomes and selected-path context; JSON-parser and OS-error tails remain implementation-native | diff --git a/rewatch-ocaml/PERFORMANCE_PLAN.md b/rewatch-ocaml/PERFORMANCE_PLAN.md new file mode 100644 index 00000000000..fd2a6a92a08 --- /dev/null +++ b/rewatch-ocaml/PERFORMANCE_PLAN.md @@ -0,0 +1,246 @@ +# Embedded compiler performance plan + +**Goal workflow:** Process unchecked checkpoints in order. Each leaves a working +build. Record changed files, gate results, measurements, and the next checkpoint +before checking one off. Retain fallbacks until parity passes. + +**Target contract:** Fresh request-local inference, configuration, and diagnostics; +deterministic artifacts. `REWATCH_BIN_ANNOT=1` preserves `.cmt`/`.cmti`, source +paths, discovery metadata, and standalone editor analysis. Disabled builds skip +editor-only work, including when GenType is enabled. + +1. [x] **Baseline.** Record fixed-setting, interleaved [benchmarks](bench/README.md) + for clean, no-op, edit, shared-interface, GenType, PPX, restarted builds, and + annotation modes: elapsed time, CPU, allocation, and RSS. + + Record: Added `bench/embedded_baseline.py`, its usage in `bench/README.md`, + and [raw samples, settings, and medians](bench/baseline-2026-09-30.md). + The compiler and OCaml Rewatch built; smoke runs and the full 165-sample + run passed. With four domains, the 201-module clean-build median was 79.3 + ms and 9.4 MB allocated without annotations, versus 116.6 ms and 23.3 MB + with annotations. Next: checkpoint 2, typed requests and per-request + configuration. + +2. [x] **Typed requests.** Share option decoding with standalone `bsc`; copy + reusable configuration per request. Preserve option precedence, source + overrides, logical argv, and fresh state. + + Record: Updated the shared compiler driver, option-state modules, driver + tests, and OCaml Rewatch documentation. The session caches bounded option + templates by working directory and argv; requests install private copies. + Standalone and effectful requests retain direct dispatch. The five-run + one-domain testrepo gate passed with identical compiler work, complete file + sets, and artifact bytes. Clean medians were 1,658 ms before and 1,667 ms + after; unchanged 42/43 ms; edit 43/42 ms. The [four-domain wide-fixture + samples and gate report](bench/checkpoint-2-2026-09-30.md) record allocation, + RSS, and annotation modes. The four-domain full-fixture CMI comparison is + affected by existing parallel nondeterminism: two builds of checkpoint 1 + differed in 203 WebAPI CMIs, while one-domain repeats matched. `make test`, + `make test-rewatch`, focused OUnit (104 tests), `make test-gentype`, + `make test-analysis`, and `make checkformat` passed. Next: + checkpoint 3, separate compiler and editor policies. + +3. [x] **Independent policies.** Separate capture/handoff from frozen lookup, + and editor artifacts from GenType inputs. Preserve initial defaults; + invalidate caches on policy changes. + + Record: Split session capture/handoff from frozen dependency lookup in the + compiler driver. Policy changes discard retained session results; classic + lookup keeps disk publication ahead of dependents and the disk AST roundtrip. + Build metadata now fingerprints handoff, lookup, editor-artifact, and + GenType-input policies independently. The initial annotation behavior is + preserved. The one-domain five-run gate passed with identical compiler work, + file sets, and artifact bytes; clean medians were 1,686/1,703 ms. The + [GenType measurements](bench/checkpoint-3-2026-09-30.md) include all three + annotation settings, each with byte-identical generated artifacts across + revisions. `make test-all` (compiler, GenType, analysis, tools, and Rewatch), + focused OUnit (105 tests), and `make checkformat` passed. Next: checkpoint 4, + owned semantic inputs for GenType. + +4. [x] **Owned semantic inputs.** Provide file-independent implementation/interface + inputs to GenType with safe ownership/lifetimes. Preserve interface precedence, + TypeScript, and errors. Dependency reads move in checkpoint 5. + + Record: Updated GenType input selection, the embedded compiler session's + published-semantic lookup, focused ownership/precedence tests, and OCaml + Rewatch documentation. GenType consumes request-local implementation + semantics and an isolated session copy of a validated interface result; + missing or stale results use the original CMTI reader. A clean GenType trace + reduced current-module CMT reads from one to zero. The [five-run gate and + GenType measurements](bench/checkpoint-4-2026-09-30.md) passed with identical + compiler work, complete file sets, artifact bytes, TypeScript, and all three + annotation modes. `make test-all`, the OCaml Rewatch port integration suite, + a final `make test`, focused OUnit (107 tests), and `make checkformat` passed. + Next: checkpoint 5, versioned GenType dependency summaries. + +5. [x] **GenType dependency inputs.** Replace recursive annotation reads with + versioned summaries; validate sources, compiler, configuration, and dependencies. + Keep legacy readers for prebuilt packages. Require clean/edit/restart TypeScript + parity using summaries. + + Record: Added declaration-only CMT/CMTI sidecars, compiler/source/configuration/ + CMI validation, the recursive summary reader with legacy fallback, artifact + publication and cleanup, a recursive-import fixture, validation and integration + tests, and repeatable GenType parity and timing runners. The [five-run gate + and GenType measurements](bench/checkpoint-5-2026-09-30.md) passed with + identical compiler work, complete file sets, artifact bytes, and TypeScript + in clean/edit/restart builds for all three annotation modes. The small + GenType fixture showed added clean and restart latency from summary writing; + this is a preparatory step for removing forced annotations. `make test-all`, + the OCaml Rewatch port suite, focused OUnit (108 tests), and + `make checkformat` passed. Next: checkpoint 6, editor-only annotations. + +6. [x] **Editor-only annotations.** Remove GenType's forced annotations and + compatibility copies. Gate editor collection, metadata, capture, snapshots, + serialization, and export before allocation when disabled. Enabled builds + retain editor features and complete/partial annotations. + + Record: Decoupled GenType inputs from the editor annotation and compatibility + copy policies. The compiler retains a normalized request-local GenType + semantic result without writing CMT/CMTI, and summary-only interfaces keep + the semantic input needed after restart. Disabled builds skip editor type + collection, metadata, session capture, CMT serialization, and export; + enabled builds retain complete and partial annotations. The + [five-run gate and GenType measurements](bench/checkpoint-6-2026-09-30.md) + passed with identical compiler work, complete file sets and artifact bytes + outside GenType, and matching TypeScript, JavaScript, errors, and enabled + editor artifacts in GenType. Disabled GenType allocation fell 8% on the + interface fixture and 19% on recursive imports, with roughly level clean + wall time. `make test-all`, the OCaml Rewatch port suite, focused OUnit + (109 tests), and `make checkformat` passed. Next: checkpoint 7, owned AST + results. + +7. [x] **Owned AST results.** Return ASTs/dependencies before disk persistence; + validate session generations and disk identities. Preserve persistent caches, + restart behavior, and cancellation recovery. + + Record: Updated `compiler/depends/binary_ast.ml`, the embedded compiler + driver, and the OCaml Rewatch session, parse, and export modules. Frozen + requests capture ASTs and dependencies before staging writes; the export + worker persists byte-identical ASTs while compilation consumes the owned + result. Source identity, request generation, and then staging file identity + validate handoff. Classic lookup and an explicit synchronous fallback + remain. Added driver and export unit tests, updated Rewatch and benchmark + documentation, and recorded the [five-run gate](bench/checkpoint-7-2026-09-30.md). + It passed with identical compiler work, complete file sets, and artifact + bytes. Clean medians were 3,136/3,140 ms before/after with 196,304/198,708 + KiB sampled peak RSS; unchanged 229/227 ms and edit 245/262 ms. The clean + gate showed no demonstrated speed gain. `make test-all` passed before the + final buffer-retention cleanup; final `make test`, the OCaml Rewatch port + suite, focused OUnit (111 tests), and `make checkformat` passed afterward. + Next: checkpoint 8, owned CMI/CMJ and persistence. + +8. [x] **Owned CMI/CMJ and persistence.** Migrate CMI, CMJ, then optional editor + outputs. Snapshot mutable graphs before async serialization; serialize once; + bound retained heap memory. Preserve fingerprints, freshness, partial publication, + hook ordering, failure recovery, atomic editor files, and eviction/exit disk fallback. + + Record: Captured serialized CMI, CMJ, and optional complete CMT/CMTI byte + images in the embedded compiler session; publication validates source and + request generation before staging. A 32 MiB retained-image budget falls + back to immediate disk persistence. Partial annotations remain available + on failed requests; editor staging and published copies use atomic + replacement. Updated the compiler formats and driver, OCaml Rewatch + publication and file utilities, focused parity and failure tests, and the + Rewatch guide. The [five-run gates](bench/checkpoint-8-2026-09-30.md) + passed with identical compiler work, complete file sets, and artifact + bytes both with and without annotations. Clean medians were 3,155/3,228 ms + with annotations unset and 4,700/4,720 ms with them enabled; sampled peak + RSS was 197,892/208,852 and 253,916/259,152 KiB. GenType clean/edit/ + restart output and error diagnostics matched in unset, `0`, and `1` modes. + A final AST source-change fallback closed an intermittent watch race; the + final binary passed one-run full artifact comparisons in both annotation + modes. `make test-all` passed before that fallback; final `make test`, two + OCaml Rewatch port runs, focused OUnit (114 tests), and `make checkformat` + passed. Next: checkpoint 9, immutable imported types. + +9. [x] **Immutable imported types.** Measure copying/materialization; migrate + values, constructors, records, modules, then substitution/inclusion as separate + validated changes. Preserve sharing/identities; mutable nodes/views remain + request-local. Replace measured fallbacks. + + Record: Updated frozen module and module-type declarations, path substitution, + lazy request-local type graphs, the legacy expansion trace, focused ownership + tests, a 201-module inclusion fixture, and the annotation-aware parity gate. + The [five-run comparisons](bench/checkpoint-9-2026-09-30.md) passed in six + declaration modes with equal JavaScript/CMI/CMJ bytes, editor semantics, + incremental work, and inclusion diagnostics. With annotations enabled, raw + CMT bytes were stable within each policy; semantic CMT content and editor + responses matched across policies. Frozen lookup improved median clean time + on every focused fixture but raised peak RSS in some. Complete-signature + inclusion and complex functor substitution still materialize mutable + request-local structures; they cost below 1 ms per build and have no + demonstrated replacement gain. `make test` (345 OUnit cases), the OCaml + Rewatch port suite, `make test-analysis`, and `make checkformat` passed. + Next: checkpoint 10, GenType parity. + +10. [x] **Frozen GenType parity.** Fix TypeScript differences before enabling + frozen lookup. Test mixed imports both ways; restrict classic lookup to + affected requests and invalidate policy-dependent caches. + + Record: Updated the compiler driver, Rewatch request arguments, publication, + metadata, parity runner, port fixtures, and OUnit policy test. GenType parse + and compile requests retain classic disk lookup, while non-GenType requests + in either mixed-import direction use frozen lookup. Projects with GenType + publish compiler artifacts before releasing dependents, and the publication + policy participates in cache invalidation. The [parity and five-run + gate](bench/checkpoint-10-2026-09-30.md) passed clean/edit/restart/ + switch-back builds in all three annotation modes with matching TypeScript, + JavaScript, compiler artifacts, annotation semantics, and mismatch + diagnostics. On the 141-module GenType fixture, the frozen request split + reduced median wall time 3.6% with 18% higher peak RSS. `make test`, + `make test-gentype` with one and default domain counts, `make test-analysis`, + the OCaml Rewatch port suite, focused OUnit (114 tests), and + `make checkformat` passed. Next: checkpoint 11, the legacy PPX boundary. + +11. [x] **Legacy PPX boundary.** Measure AST 0 conversion, serialization, I/O, + and execution. Isolate the adapter; preserve frozen AST 0, bridge coverage, + and no conversion without external PPXs. + + Record: Moved the frozen AST 0 protocol into + `compiler/core/legacy_ppx_adapter.ml`, added per-phase trace buckets and a + repeatable PPX gate, and updated the Rewatch and benchmark guides. The + [five-run report](bench/checkpoint-11-2026-09-30.md) records equal generated + artifact hashes with and without an identity PPX, all seven adapter phases + only on PPX requests, and a successful real `sury-ppx` transformation. + Median conversion to/from AST 0 cost 0.024/0.027 ms for five requests, + versus 27.762 ms for external execution. `make test-syntax`, `make test`, + the OCaml Rewatch port suite, and the focused gate passed. Next: checkpoint + 12, core promotion. + +12. [ ] **Core promotion.** Pass final gates; enable validated defaults, remove + superseded paths, and update documentation, parity coverage, and changelog. + + Record (local preparation): The frozen session and owned handoff policies + were already OCaml Rewatch defaults. No remaining classic, disk, editor, or + PPX path is superseded; each serves a validated fallback or compatibility + contract. Updated the CI parity matrix, Rewatch guide, and changelog. The + [local gate report](bench/checkpoint-12-2026-09-30.md) records a passing + `make test-all`, focused OCaml Rewatch runs with 1, 4, and 12 domains, + mixed GenType and PPX parity, static-profile Linux builds, and formatting. + The symlink-source test now + creates its atomic replacement on the target filesystem, so the worker-count + gate measures the intended rename on split-filesystem hosts. The first + platform CI run failed on stale GenType argument-parity assumptions. + Updated the checker to assert the disabled-annotation flag and parser policy + marker explicitly before comparing all remaining arguments. Linux container + verification passed all 297 configuration cases, 108 command cases, both + coverage inventories, and verbose output parity. Parity then passed on all + platforms; Windows unit tests exposed rapid-rewrite timestamp assumptions. + Test edits now advance timestamps explicitly, and CI retains detailed failure + logs. Complete platform CI remains required before checking this off. + +**Separate PPX goals:** After checkpoint 11, persistent AST 0 workers require a +cooperating executable and request reset/recovery tests. A modern AST protocol +follows worker validation and requires a cooperating consumer. Retain the legacy +adapter; these integrations do not hold up core promotion. + +**Gates:** Each checkpoint builds and passes affected suites; compiler changes +require `make test`. Use `make test-rewatch`, focused OCaml tests, +`make test-gentype`, `make test-analysis`, and syntax suites where affected. +Check file sets per mode, retained artifact bytes, diagnostics, source maps; +GenType with annotations unset/`0`/`1`; editor completion, hover, references, and +incomplete-source recovery; cancellation and concurrent requests. +Final promotion requires Linux/macOS/Windows and multiple domain counts. +Optimizations need repeatable gains without material latency/memory regressions; +preparatory changes need parity. diff --git a/rewatch-ocaml/README.md b/rewatch-ocaml/README.md index cc8a9d961ec..b5e7554e7c3 100644 --- a/rewatch-ocaml/README.md +++ b/rewatch-ocaml/README.md @@ -9,9 +9,17 @@ implementation remains available as `rescript-rust` on every platform. The OCaml port's cross-platform baseline gates passed before parallel compiler domains became the default. Domain builds now pass repeated Linux artifact and focused concurrency checks; broader project and platform -validation continues. Current domain measurements and limits are in +validation continues. Reproducible performance and resource checks are in [`bench/README.md`](bench/README.md). +The embedded compiler performance plan has completed its local Linux gates: +`make test-all`, the focused OCaml Rewatch suite with one, four, and twelve +compiler domains, mixed GenType parity in all annotation modes, and the frozen +AST 0 PPX gate. The CI matrix also runs the focused suite with one and four +domains on Linux, macOS, and Windows; its results for this revision are pending +until the local commits are published. The retained classic GenType, disk, +editor compatibility, and legacy PPX paths are described below. + Before the domain cleanup, an uninterrupted `make test-all` run passed all compiler, runtime, build, GenType, analysis, tools, and canonical rewatch tests. The shared integration suite runs against the packaged OCaml executable. @@ -64,11 +72,13 @@ file _build/default/rewatch-ocaml/rescript_ocaml.exe ``` Build and watch requests compile on a bounded pool of OCaml domains by -default. The main domain schedules dependencies and publishes artifacts; -compiler workers parse and compile independent modules. The worker count is -the lesser of eight and one fewer than the available CPU count, with a minimum -of one. Set `REWATCH_COMPILER_DOMAINS` to override it (one through the -scheduler's platform bound, at least twelve). The heuristic is provisional. +default. The main domain schedules dependencies and records build state; +compiler workers parse and compile independent modules. One export domain can +copy independent implementation artifacts while compiler jobs continue. The +compiler worker count is the lesser of eight and one fewer than the available +CPU count, with a minimum of one. Set `REWATCH_COMPILER_DOMAINS` to override it +(one through the scheduler's platform bound, at least twelve). The heuristic +is provisional. PPXs and hooks remain external processes. When running outside this repository's normal Makefile environment, supply @@ -81,8 +91,8 @@ _build/default/rewatch-ocaml/rescript_ocaml.exe build path/to/project The repeated testrepo clean builds matched selected AST, IAST, CMI, CMJ, JavaScript, source-map, and namespace-map artifacts across one, two, four, -eight, and twelve domains. A rare earlier output mismatch remains unexplained; -see [`bench/README.md`](bench/README.md) for measurements and limits. +eight, and twelve domains. The benchmark gate checks these artifacts alongside +compiler work and elapsed time. On this experimental branch, published ReScript packages use the OCaml implementation for the normal `rescript` command. The Rust reference @@ -128,15 +138,88 @@ orchestration and aggregate dispatch, while `build_report.ml` owns presentation. `build_preparation.ml` consumes the prepared packages to initialize compiler context, clean stale assets, and run the preliminary parse; `module_graph.ml` owns dependency resolution, graph-node identities, and cycle analysis. + +The default compiler session passes newly parsed ASTs, dependency lists, +frozen interfaces, and cross-module optimization metadata directly between +jobs. Dependent compiler jobs can start before CMI and CMJ artifacts are +exported; export finishes before build success. Its +module-result API also retains bounded typed semantic data, structured +diagnostics, and output paths. Separate CMI and CMJ fingerprints control +dependent recompilation. `Frozen_values` and `Frozen_type_graph` provide +immutable shared images with request-local views; the benchmark commands are +in [`bench/README.md`](bench/README.md). +Set `REWATCH_FROZEN_VALUES=0` to compare the previous compiler path. +GenType parse requests use the classic disk AST path, and GenType compile +requests use classic interface lookup. When a project contains GenType, +compiler artifacts from every package reach disk before dependents run; GenType +uses those files to validate dependency summaries. Other requests in the same +project use frozen lookup, including dependencies of GenType packages and +consumers of GenType packages. The compiler metadata records the publication +and lookup policies and invalidates retained results when they change. +GenType consumes the current implementation's semantic result in its compiler +request. For a module with an interface, an embedded session supplies an +isolated copy of the published interface semantics when the staged source and +published file still match; a missing or stale session value falls back to the +existing CMTI reader. Standalone compilation also uses the CMTI reader. +For imported GenType types, the compiler writes a versioned declaration summary +at the CMT or CMTI path with a `.gts` suffix. A recursive import reads that +summary after checking the source, compiler build, producer configuration, +GenType settings for the same package, and CMI dependency contents. When a +CMT is available, missing or stale summaries use the existing CMT reader, +including for prebuilt packages. OCaml Rewatch publishes the summaries and +removes them when their source modules are removed. +With frozen lookup, parser requests hand their AST and dependency list to the +session before writing an AST file. The export domain writes the serialized +staging file and persistent cache copy while compilation proceeds. Source +identity and request generation guard the handoff; after persistence, the +staging file identity is checked too. A restarted build reads the persistent +AST cache. If the source changes before staging finishes, the captured AST is +written for the disk reader while the watcher schedules a fresh parse. +GenType's classic lookup keeps the original disk AST path. Set +`REWATCH_OWNED_AST=0` to use synchronous staging writes, or +`REWATCH_ASYNC_AST_EXPORT=0` to finish exports before compilation. +Frozen compiler requests also hand serialized CMI and CMJ byte images to the +session before staging writes. With editor annotations enabled, complete CMT +and CMTI images follow the same path; partial annotations are written during +the request so errors retain them. The publisher checks source identity and +request generation before writing each image. Retained images have a 32 MiB +session budget; a full budget writes the next result before handoff. Editor +files use atomic replacement in staging and published directories. Disk files +remain available for restarted builds and session cache misses. Set +`REWATCH_OWNED_CMI=0`, `REWATCH_OWNED_CMJ=0`, or `REWATCH_OWNED_CMT=0` to +disable the corresponding handoff. +OCaml Rewatch omits CMT and CMTI binary annotations by default, including in +GenType packages. GenType keeps request-owned typed results and `.gts` inputs; +an interface summary also retains the semantic information needed when its +implementation compiles after a restart. OCaml Rewatch uses CMJ modification +time as the compiled freshness marker without CMT. Set `REWATCH_BIN_ANNOT=1` +to produce complete and partial binary annotations for editor tools and other +consumers. +Compiler metadata records editor-artifact and GenType-input requirements +separately. Switching either policy invalidates incompatible cached artifacts. +In-source JavaScript is written directly to its configured output path. With +binary annotations disabled, OCaml Rewatch omits the private `lib/bs` +JavaScript mirror and copies of source files in `lib/bs` and `lib/ocaml`. +The parser and compiler made three source copies for a typical implementation, +and publication made one JavaScript mirror. These files are unused by +compilation. Set `REWATCH_COMPAT_COPIES=1` to restore them; packages with binary +annotations retain them automatically. GenType does not require these copies. +Switching this setting invalidates incompatible cached artifacts. `compiler_process.ml` is the boundary between logical compiler jobs and in-process execution. Independent parse and compile requests run on a bounded -domain pool while artifact publication stays on the scheduler domain. The +domain pool. The scheduler accepts module results and records build state; +eligible artifact exports run on one separate domain. The driver resets command-line flags, warnings, JSX and experimental settings, package and output state, runtime and project paths, load paths, environment and CRC caches, predefined type graphs, delayed checks, CMT accumulation, backend caches, and diagnostic state before and after every request, including exceptional returns. CMT files record each request's logical compiler argv rather than rewatch's process argv. +The session decodes recurring compiler options with the standalone `bsc` parser +once per working directory and option list, then installs a private copy for +each request. Source-level flags can still override those options without +changing the cached template. Help and other effectful options use the normal +standalone dispatch path. Compiler output routed through request-owned channels and formatters is captured per request and returned to rewatch; help, version, formatting, and reprinting requests return status instead of @@ -148,18 +231,37 @@ the recursive compiler source, platform-stub, C-stub, and Dune-rule inputs and shared by the embedded driver and standalone wrapper, so nested compiler changes invalidate artifacts while rewatch-only edits do not. `package_plan.ml` owns immutable per-package build inputs, `build_session.ml` -owns prepared state retained across watch rebuilds, and `build_attempt.ml` owns +owns the project graph, package configuration, compiled-artifact freshness, +and compiler dependency cache retained across watch rebuilds. The driver gives +each module job fresh inference, diagnostics, and +environment state while the project session lends each job a private table of +decoded small interfaces and an expanded signature graph. A cache hit checks +the current load path and file identity; typed graph checks detect mutations, +and changed graphs are restored from a saved image before reuse. Once a job +ends, its table returns to the session +and can be used by a later worker domain, including after a watch edit. A full +watch rebuild reconstructs the graph but retains the compiler dependency +session for the same project. Set +`REWATCH_PROJECT_CMI_CACHE=0` to limit the small-interface cache to `Stdlib` +and `Pervasives` when comparing build performance. +`build_attempt.ml` owns attempt kinds, parse outcomes, diagnostics, counters, scheduled work, and final cleanup for one build attempt. `source_dirs.ml` owns source-directory metadata projection and serialization. `process_child.ml` owns the lifecycle of one subprocess while `process.ml` owns scheduling. Command-level post-build execution and its error handling live in `after_build.ml`. -External PPXs are deliberately still subprocesses. Their launch is routed back -through rewatch's interruptible process owner so Unix process groups and Windows -Job Objects continue to terminate PPX descendants. JavaScript post-build hooks, -`--after-build`, formatting, and lock-owner probes likewise retain the generic -process infrastructure. +External PPXs use the isolated `compiler/core/legacy_ppx_adapter.ml` boundary. +It converts the current parsetree to frozen AST 0, writes the existing file +protocol, executes each PPX, reads its result, and converts back. Requests with +no external PPX bypass this adapter and its AST 0 conversions. Set +`REWATCH_TYPECHECK_TRACE` to measure `ppx.convert.to0`, `ppx.serialize`, +`ppx.write`, `ppx.execute`, `ppx.read`, `ppx.deserialize`, and +`ppx.convert.from0` separately. PPXs remain subprocesses; their launch is +routed through rewatch's interruptible process owner so Unix process groups and +Windows Job Objects continue to terminate descendants. JavaScript post-build +hooks, `--after-build`, formatting, and lock-owner probes likewise retain the +generic process infrastructure. Both rewatch implementations skip a small set of PPXs when the source does not contain the syntax that can trigger them. This is deliberately conservative: diff --git a/rewatch-ocaml/bench/README.md b/rewatch-ocaml/bench/README.md index f28b755e939..31f21014a40 100644 --- a/rewatch-ocaml/bench/README.md +++ b/rewatch-ocaml/bench/README.md @@ -1,184 +1,206 @@ -# OCaml rewatch performance measurements - -The OCaml rewatch now uses parallel in-process compiler domains by default. -`REWATCH_COMPILER_DOMAINS` overrides the CPU-based worker count; without it, -the worker count is `min(8, max(1, available CPUs - 1))`. Rust rewatch is the -build-level reference for compiler work, generated file sets, and stable -artifact bytes. Keep both implementations on the same compiler and runtime -build when comparing them. - -## Domain baseline - -On a ten-CPU Linux ARM64 host, clean builds of the 472-module testrepo fixture -at the same absolute path measured the following directional medians. The host -had light unrelated work. Each domain build's selected AST, IAST, CMI, CMJ, -JavaScript, source-map, and namespace-map artifacts matched a sequential -embedded baseline in the repeated checks performed before the mode cleanup. - -| compiler workers | samples | median wall | -| ---: | ---: | ---: | -| 1 | 3 | 5.49s | -| 2 | 3 | 4.56s | -| 4 | 3 | 2.40s | -| 8 | 10 | 1.94s | -| 12 | 10 | 2.17s | - -In separate samples, Rust rewatch took 4.62s, sequential embedded OCaml took -5.22s, one persistent process worker took 10.37s, and sequential external -compiler processes took 27.25s. Those last three execution modes have since -been removed. A later five-run comparison of eight, ten, and twelve domains -measured clean-build medians of 2.19s, 2.58s, and 2.37s, with peak RSS of -336, 430, and 499 MiB respectively. All fifteen selected-artifact comparisons -matched. Eight workers gave the best result on this host; the heuristic remains -provisional. - -One earlier twelve-domain build differed in two generated copies of `Net.mjs`. -Forty focused repeats and ten full selected-artifact comparisons did not -reproduce it. The cause remains unknown; compare stable artifacts as well as -wall time while testing parallel changes. - -The retained-watch gate with eight workers passed seven ordinary edits: OCaml -median 82 ms versus Rust 132 ms, equal seven-parse/seven-compile work, and -byte-identical edited JavaScript. The watcher held 12 file descriptors and -four tasks; RSS rose from 26,680 to 27,688 KiB. That small fixture dirties -only one module per edit and does not establish watch-time scaling. - -## AST I/O checkpoint - -Temporary counters on the same host and eight-domain fixture measured 917 -sequential scheduler AST-header reads totaling 123 kB in 5.5–7.8 ms (5.9 ms -median) per clean build. Compiler domains read and deserialized 512 full ASTs -totaling 6.93 MB in 71–120 ms summed across domains (75 ms median). Two -additional builds spent 97–98 ms summed across domains on the AST write path, -including dependency extraction and serialization. Three interleaved clean -builds with counters enabled and three with counters disabled measured median -wall times of 2.19s and 2.35s; unrelated work makes that difference noise, -not an optimization result. The counters were removed afterward. - -Avoiding scheduler header reads alone has little headroom on this fixture. -A parsed-tree handoff could avoid compiler reads, but summed concurrent-worker -time is not wall time saved. Preserve published AST/IAST files and freshness -behavior, then measure RSS, work, and artifact parity on a larger project. - -## Rust comparison gates - -Build both release executables, then run the Linux clean-build, work, resource, -and artifact comparison: +# OCaml rewatch performance checks + +These scripts compare build time, compiler work, generated artifacts, and +resource use. Run them on Linux; the performance and watch gates require +`/proc` and GNU utilities. Build both implementations with the same compiler, +runtime, Dune profile, and installed testrepo dependencies. Keep executable +locations comparable: launching `bsc` from a different filesystem has changed +the measured Rust baseline substantially. + +## Embedded compiler baseline + +Run the fixed-setting baseline for clean, no-op, implementation edit, +shared-interface edit, GenType, an external identity PPX, and build-after-restart +requests. It also measures a 201-module project for clean, no-op, leaf edit, and +shared-interface edit. Each scenario runs with `REWATCH_BIN_ANNOT` unset, `0`, +and `1`, in alternating order. The runner records elapsed time, `wait4` CPU, +embedded OCaml allocation, peak RSS, and generated artifact size. ```sh +opam exec -- dune build rewatch-ocaml/rescript_ocaml.exe \ + compiler/bsc/rescript_compiler_main.exe +python3 rewatch-ocaml/bench/embedded_baseline.py \ + /tmp/embedded-baseline --runs 5 --domains 4 +``` + +The output directory must not exist. It contains raw CSV samples, executable +hashes and host settings in `metadata.json`, and per-request logs. The recorded +starting point for this plan is [the 2026-09-30 baseline](baseline-2026-09-30.md). +The identity PPX measures the external protocol and subprocess boundary; use a +real PPX fixture when validating transformation behavior. + +The [checkpoint 11 PPX report](checkpoint-11-2026-09-30.md) separates frozen +AST 0 conversion, serialization, file reads and writes, and external execution. +Its repeatable identity-PPX gate also checks that ordinary requests do not +enter the adapter: + +```sh +python3 rewatch-ocaml/bench/legacy_ppx_gate.py \ + /tmp/legacy-ppx-gate 5 +``` + +The output directory must not exist. Each interleaved pair compiles the same +four-module project without a PPX and with a file-copying external PPX, checks +20 generated artifact hashes, and records trace phases and elapsed time. + +The [checkpoint 2 comparison](checkpoint-2-2026-09-30.md) records typed-request +option caching, interleaved measurements, and the one-domain artifact gate. +The [checkpoint 3 comparison](checkpoint-3-2026-09-30.md) records independent +compiler and editor policies and GenType artifact parity. +The [checkpoint 4 comparison](checkpoint-4-2026-09-30.md) records owned GenType +semantic inputs, reduced CMT reads, and interface precedence checks. +The [checkpoint 5 comparison](checkpoint-5-2026-09-30.md) records versioned +dependency summaries, recursive-read traces, TypeScript parity, and fallback +behavior. `gentype_summary_parity.py` checks clean, edit, and restart builds in +all three annotation modes against the previous executable. The focused +`gentype_summary_benchmark.py` measures clean, unchanged, and restarted edit +builds of its recursive-import fixture. Pass both runners the old executable, +new executable, and a new output directory, in that order. +The [checkpoint 6 comparison](checkpoint-6-2026-09-30.md) records the removal +of GenType's forced editor annotations, with allocation, artifact, diagnostics, +and TypeScript parity checks. `gentype_editor_policy_parity.py` checks interface +and error behavior across all three annotation modes. +The [checkpoint 7 comparison](checkpoint-7-2026-09-30.md) records the owned AST +handoff, deferred persistence, byte parity, and the one-domain artifact and +resource gate. +The [checkpoint 8 comparison](checkpoint-8-2026-09-30.md) records owned CMI, +CMJ, and editor artifact publication and its byte-parity gates. +The [checkpoint 9 comparison](checkpoint-9-2026-09-30.md) records imported type +graph costs, frozen lookup by declaration kind, module path substitution, and +the remaining full-signature fallback. +The [checkpoint 10 comparison](checkpoint-10-2026-09-30.md) records GenType +parity and mixed-package lookup in both directions. +The [checkpoint 12 local gate](checkpoint-12-2026-09-30.md) records the Linux +final-suite results and the cross-platform CI requirement still pending for +the unpushed branch. + +## Build and compare + +From the repository root: + +```sh +yarn --cwd rewatch/testrepo install --immutable +opam exec -- make lib cargo build --manifest-path rewatch/Cargo.toml --release -opam exec -- dune build --profile release rewatch-ocaml/rescript_ocaml.exe +opam exec -- dune build --profile release \ + compiler/bsc/rescript_compiler_main.exe \ + rewatch-ocaml/rescript_ocaml.exe +export RESCRIPT_BSC_EXE="$PWD/_build/default/compiler/bsc/rescript_compiler_main.exe" +export RESCRIPT_RUNTIME="$PWD/packages/@rescript/runtime" rewatch-ocaml/bench/performance_gate.sh \ rewatch/target/release/rescript \ _build/default/rewatch-ocaml/rescript_ocaml.exe 5 +rewatch-ocaml/bench/watch_performance_gate.sh \ + rewatch/target/release/rescript \ + _build/default/rewatch-ocaml/rescript_ocaml.exe 7 ``` -The harness isolates dependency trees, interleaves builds, traces Rust `bsc` -requests and OCaml's logical compiler-request log, compares clean, unchanged, -and one-edit work, and compares complete file sets and stable artifact bytes at -the same absolute path. `KEEP_REWATCH_BENCHMARK_WORKDIR=1` retains raw outputs. -The fixture currently does work on an unchanged build. In a one-run smoke check, -both implementations performed four compiler requests there, and their clean -and single-edit request counts matched too. The source of those unexpected -unchanged requests is unresolved. The same check found byte differences in -some `rescript-bun` CMI files and an AST despite equal generated file sets; -investigate these before using the artifact gate as an acceptance result. +The build gate interleaves clean, unchanged, and one-file-edit runs in isolated +copies of the testrepo fixture. It compares logical compiler requests, complete +generated file sets, and byte-stable artifacts, then reports elapsed time and +sampled process-tree RSS. The watch gate checks edit latency, generated +JavaScript, compiler work, and retained file descriptors, tasks, and RSS. +Run counts must be odd and at least five. The build gate's default clean-build +time and memory limit is 125% of the reference; the watch gate's median latency +limit is 150%. + +To compare two OCaml revisions, put both executables in the same directory and +set `REWATCH_FIRST_EMBEDDED=1`. The first executable is still labeled `Rust` +in the gate output. Use the same standalone compiler and runtime for both. +Set `REWATCH_COMPILER_DOMAINS` or `REWATCH_WATCH_COMPILER_DOMAINS` to hold the +worker count fixed. `KEEP_REWATCH_BENCHMARK_WORKDIR=1` and +`KEEP_REWATCH_WATCH_PERFORMANCE=1` retain raw results. + +Report host architecture, filesystem, compiler and executable hashes, Dune +profile, worker count, run count, elapsed medians, sampled RSS, compiler work, +and artifact comparison. The gates print most of these. Compare medians only +within one interleaved run: historical checkpoints used different code, +fixtures, compiler placement, and measurement methods. A worker-time trace +sums concurrent requests; its total is not elapsed build time. + +## Compiler probes + +Set `REWATCH_TYPECHECK_TRACE` to an absolute TSV path to collect exclusive +compiler-phase timings, then analyze the trace with: + +```sh +node rewatch-ocaml/bench/analyze_typecheck_trace.js /tmp/typecheck.trace.tsv +``` -## Filesystem-work audit +The trace is opt-in and adds instrumentation. The +`rewatch-ocaml/bench/typecheck_breakdown.sh` runner compares traced and plain +builds and archives their work, artifacts, and timings. The +`REWATCH_COMPILER_TIMING_LOG` setting and +`rewatch-ocaml/bench/analyze_compiler_timing.js` provide a lighter request +timeline. -Pipe-based subprocess capture has removed the intentional temporary capture -files. Run the second orchestration audit on Linux with: +For repeated imports of a large synthetic interface, generate a 201-module +project with: ```sh -rewatch-ocaml/bench/filesystem_audit.sh \ - rewatch/target/release/rescript \ - _build/default/rewatch-ocaml/rescript_ocaml.exe +python3 rewatch-ocaml/bench/make_immutable_interface_fixture.py /tmp/rewatch-interface-probe ``` -It traces isolated clean, unchanged, and single-edit builds with `strace`, -normalizes each fixture root, retains operations whose target is inside that -root, and reports per-path operation multisets plus metadata, open, -directory-scan, create, rename, remove, and execute categories. Set -`KEEP_REWATCH_FILESYSTEM_AUDIT=1` to retain normalized manifests and raw traces -for investigation. +The generator also accepts `--values-only`, `--types-only`, +`--variants-only`, `--modules-only`, `--open-only`, or `--inclusion-only`. +Compare builds with +`REWATCH_FROZEN_VALUES=0` and the default setting while holding binary +annotations and worker count fixed. The type-graph microprobe is +`rewatch-ocaml/bench/frozen_type_graph_probe.exe`; build it with Dune and pass +a CMI path and iteration count. + +For an interleaved comparison with artifact byte checks, run: -Do not gate on the raw process-wide syscall total: Rust, OCaml, libc, the -dynamic loader, and subprocess startup legitimately perform different -toolchain-level accesses. Report those separately, and treat repeated accesses -to the same project artifact or discovery path as the primary evidence of -superfluous orchestration work. The existing compiler-work and artifact checks -must remain enabled so fewer filesystem calls cannot conceal skipped work. +```sh +opam exec -- dune build rewatch-ocaml/bench/cmt_compare.exe \ + analysis/bin/main.exe +python3 rewatch-ocaml/bench/immutable_interface_gate.py \ + /tmp/immutable-interface-gate 5 +REWATCH_BIN_ANNOT=1 python3 rewatch-ocaml/bench/immutable_interface_gate.py \ + /tmp/immutable-interface-annotations 5 +``` -The older process-attributed syscall measurements used the removed external -compiler mode. Repeat the audit with domains before using it to guide I/O -changes. +The runner uses one compiler domain and records wall time, CPU, peak RSS, and +per-request traces and artifact manifests. Its output directory must not exist. +With annotations enabled, it checks typedtree and value-dependency semantics +across policies, raw annotation bytes across repeated builds of each policy, +and hover, references, completion, and incomplete-source recovery. Raw CMT +bytes can differ across policies because imported type nodes receive different +internal IDs when frozen lookup avoids eager graph materialization. +It removes generated projects after a successful run; set +`KEEP_REWATCH_IMMUTABLE_PROJECTS=1` to retain them. -For the ordinary-edit path inside one long-lived watcher, run: +To check GenType artifacts across classic and frozen policies, including +clean, edit, restart, all three annotation settings, and packages importing each +other in both directions, run: ```sh -rewatch-ocaml/bench/watch_filesystem_audit.sh \ - rewatch/target/release/rescript \ - _build/default/rewatch-ocaml/rescript_ocaml.exe +opam exec -- dune build rewatch-ocaml/bench/cmt_compare.exe +python3 rewatch-ocaml/bench/frozen_gentype_parity.py \ + /tmp/frozen-gentype-parity ``` -This starts each implementation on an isolated small project, waits for its -initial build hook, traces one dependency-preserving source edit, and stops the -watcher through its lock file. Only calls timestamped between the edit and the -successful incremental-build hook enter the normalized reports, so initial -discovery and shutdown do not obscure retained-state work. Set -`KEEP_REWATCH_WATCH_AUDIT=1` to retain raw traces, normalized path/category -tables, process attribution, and command output. As with the short-lived audit, -project-local repeated paths and compiler work are the useful comparison; raw -runtime-wide syscall totals are diagnostic rather than an acceptance limit. +The output directory must not exist. The gate checks TypeScript, JavaScript, +CMI, CMJ, GenType sidecars, mismatch diagnostics, request traces, and metadata +invalidation on both policy switches. -The retained-watch performance and resource gate exercises several ordinary -edits through the same long-lived watcher: +## Filesystem and source-size audits ```sh -rewatch-ocaml/bench/watch_performance_gate.sh \ +rewatch-ocaml/bench/filesystem_audit.sh \ + rewatch/target/release/rescript \ + _build/default/rewatch-ocaml/rescript_ocaml.exe +rewatch-ocaml/bench/watch_filesystem_audit.sh \ rewatch/target/release/rescript \ - _build/default/rewatch-ocaml/rescript_ocaml.exe \ - 7 + _build/default/rewatch-ocaml/rescript_ocaml.exe ``` -Set `REWATCH_WATCH_COMPILER_DOMAINS` to measure a specific worker count; -otherwise the compiler uses its CPU-based heuristic. - -It warms both implementations, interleaves an odd number of timed edits, -requires byte-identical generated JavaScript and equal logical parser/compiler -work counts, and samples file descriptors, tasks, and RSS after every build. -Rust work is observed through the counting `bsc` proxy; embedded OCaml work is -observed at the shared logical compiler-request boundary. -This catches retained-state implementations that appear fast by skipping work, -as well as resource growth that a one-event syscall trace cannot show. The -default median-latency limit is 150% of Rust because individual watch events -include operating-system notification and 50 ms polling intervals; override it -with `REWATCH_WATCH_PERFORMANCE_THRESHOLD_PERCENT` only for investigation. -The build gate's lower-noise 125% clean/incremental threshold remains the -authoritative general performance criterion. Set -`KEEP_REWATCH_WATCH_PERFORMANCE=1` to retain output, compiler-call logs, -latencies, and fixtures. This gate requires Linux `/proc`, GNU-compatible -millisecond `date`, and `setsid`. - -## Source-size snapshot - -Run `bench/source_size.sh` with `cloc` installed to record a reproducible -maintainability snapshot. The production comparison excludes Rust's explicitly -out-of-scope telemetry module and reports its inline `#[cfg(test)]` sections as -tests rather than implementation. Both OCaml platform backends count because -both remain maintained production source. All tracked OCaml test harnesses, -fixtures, and configuration files are reported together but separately from -implementation; benchmark tooling includes every executable shell/JavaScript -file in `bench`, including this counting script itself. The report also lists -the ten largest production modules and test/tooling files so growth and mixed -responsibilities are visible without treating line count as a target. Record -the `cloc` version with the result and rerun this at the final maintainability -review. - -Source lines are an observation, not an acceptance threshold. A smaller port -can indicate less machinery, but missing compatibility, weak tests, compressed -code, or too few explanatory comments can also reduce the number. Behavioral -and work equivalence, platform support, performance, module size, and review -findings remain the actual quality gates. - -Rerun the snapshot after the domain cleanup before quoting source counts. +These `strace`-based audits normalize project-local operations for clean, +unchanged, edit, and retained-watch work. Inspect repeated accesses to the +same project paths; process-wide syscall totals also include runtime and +toolchain differences. Set `KEEP_REWATCH_FILESYSTEM_AUDIT=1` or +`KEEP_REWATCH_WATCH_AUDIT=1` to retain raw traces. + +Run `rewatch-ocaml/bench/source_size.sh` with `cloc` to compare production, +test, and benchmark source sizes. Line counts are descriptive; use the +behavioral, artifact, resource, and performance gates to assess a change. diff --git a/rewatch-ocaml/bench/analyze_compiler_timing.js b/rewatch-ocaml/bench/analyze_compiler_timing.js new file mode 100644 index 00000000000..84926ef07ba --- /dev/null +++ b/rewatch-ocaml/bench/analyze_compiler_timing.js @@ -0,0 +1,93 @@ +#!/usr/bin/env node + +import fs from "node:fs"; + +if (process.argv.length !== 3) { + console.error("Usage: analyze_compiler_timing.js TIMING_LOG"); + process.exit(2); +} + +const rows = fs + .readFileSync(process.argv[2], "utf8") + .trim() + .split(/\r?\n/) + .filter(Boolean) + .map((line, index) => { + const [phase, cwd, input, startText, endText, ...extra] = line.split("\t"); + const start = Number(startText); + const end = Number(endText); + if ( + extra.length > 0 || + !["parse", "namespace", "interface", "implementation"].includes(phase) || + !cwd || + !input || + !Number.isFinite(start) || + !Number.isFinite(end) || + end < start + ) { + throw new Error(`Invalid timing row ${index + 1}: ${JSON.stringify(line)}`); + } + return { phase, cwd, input, start, end }; + }); + +function summarize(name, requests) { + if (requests.length === 0) return; + const durations = requests + .map(({ start, end }) => (end - start) * 1000) + .sort((a, b) => a - b); + const events = requests + .flatMap(({ start, end }) => [ + { time: start, delta: 1 }, + { time: end, delta: -1 }, + ]) + .sort((a, b) => a.time - b.time || a.delta - b.delta); + let active = 0; + let peak = 0; + let zeroActive = 0; + let previous = events[0].time; + for (const { time, delta } of events) { + if (active === 0) zeroActive += time - previous; + active += delta; + peak = Math.max(peak, active); + previous = time; + } + const span = (events.at(-1).time - events[0].time) * 1000; + const summed = durations.reduce((total, duration) => total + duration, 0); + console.log( + [ + name, + requests.length, + span.toFixed(1), + summed.toFixed(1), + (span > 0 ? summed / span : 0).toFixed(2), + peak, + (zeroActive * 1000).toFixed(1), + durations[Math.ceil(0.95 * durations.length) - 1].toFixed(2), + ].join(","), + ); +} + +console.log( + "phase,requests,span_ms,summed_job_ms,mean_active,peak_active,zero_active_ms,p95_job_ms", +); +summarize( + "parse", + rows.filter(({ phase }) => phase === "parse"), +); +summarize( + "namespace", + rows.filter(({ phase }) => phase === "namespace"), +); +summarize( + "compile", + rows.filter(({ phase }) => phase === "interface" || phase === "implementation"), +); + +console.log("longest compile jobs:"); +rows + .filter(({ phase }) => phase === "interface" || phase === "implementation") + .sort((a, b) => (b.end - b.start) - (a.end - a.start)) + .slice(0, 5) + .forEach(({ phase, cwd, input, start, end }) => { + console.log(`${((end - start) * 1000).toFixed(1)} ms ${phase} ${cwd}/${input}`); + }); diff --git a/rewatch-ocaml/bench/analyze_typecheck_trace.js b/rewatch-ocaml/bench/analyze_typecheck_trace.js new file mode 100644 index 00000000000..007ae497735 --- /dev/null +++ b/rewatch-ocaml/bench/analyze_typecheck_trace.js @@ -0,0 +1,78 @@ +#!/usr/bin/env node + +import fs from "node:fs"; + +if (process.argv.length !== 3) { + console.error("Usage: analyze_typecheck_trace.js TRACE.tsv"); + process.exit(2); +} + +const requests = new Map(); +const imports = new Map(); +const phaseTotals = new Map(); +for (const [index, line] of fs.readFileSync(process.argv[2], "utf8").trim().split("\n").entries()) { + const fields = line.split("\t"); + if (fields.length !== 12) throw new Error(`Invalid row ${index + 1}`); + const [cwd, input, rawPhase, msText, bytesText, callsText, totalText, + totalBytesText, minorText, majorText, compactText, heapText] = fields; + const values = [msText, bytesText, callsText, totalText, totalBytesText, + minorText, majorText, compactText, heapText].map(Number); + if (values.some((value) => !Number.isFinite(value))) { + throw new Error(`Invalid number on row ${index + 1}`); + } + const [seconds, bytes, calls, total, totalBytes, minor, major, compactions, heap] = values; + const kind = input.endsWith(".iast") ? "interface" + : input.endsWith(".ast") ? "implementation" + : input.endsWith(".mlmap") ? "namespace" + : "parse"; + const key = `${cwd}\0${input}`; + const request = requests.get(key) ?? { + kind, total, totalBytes, minor, major, compactions, heap, accounted: 0, + }; + if (Math.abs(request.total - total) > 0.000001 || request.kind !== kind) { + throw new Error(`Inconsistent request on row ${index + 1}`); + } + request.accounted += seconds; + requests.set(key, request); + const phase = rawPhase.startsWith("dependency.search_open:") + ? "dependency.search_open" : rawPhase; + if (phase !== rawPhase) { + const name = rawPhase.slice("dependency.search_open:".length); + const entry = imports.get(name) ?? {calls: 0, seconds: 0}; + entry.calls += calls; + entry.seconds += seconds; + imports.set(name, entry); + } + const entry = phaseTotals.get(`${kind}\0${phase}`) ?? {calls: 0, seconds: 0, bytes: 0}; + entry.calls += calls; + entry.seconds += seconds; + entry.bytes += bytes; + phaseTotals.set(`${kind}\0${phase}`, entry); +} + +for (const [key, request] of requests) { + if (Math.abs(request.total - request.accounted) > 0.00005) { + throw new Error(`Unaccounted request time for ${key.replace("\0", "/")}`); + } +} + +for (const kind of ["parse", "interface", "implementation", "namespace"]) { + const group = [...requests.values()].filter((request) => request.kind === kind); + if (group.length === 0) continue; + const sum = (field) => group.reduce((value, request) => value + request[field], 0); + console.log(`\n${kind}: ${group.length} requests, ${(sum("total") * 1000).toFixed(1)} summed request ms, ${(sum("totalBytes") / 1e6).toFixed(1)} allocated MB`); + console.log(`GC collections during requests: ${sum("minor")} minor, ${sum("major")} major, ${sum("compactions")} compactions; largest sampled heap ${Math.max(...group.map((request) => request.heap))} words`); + console.log("phase worker_ms alloc_MB calls"); + for (const [key, entry] of [...phaseTotals].sort(([a], [b]) => a.localeCompare(b))) { + const [entryKind, phase] = key.split("\0"); + if (entryKind !== kind) continue; + console.log(`${phase.padEnd(32)} ${String((entry.seconds * 1000).toFixed(1)).padStart(9)} ${String((entry.bytes / 1e6).toFixed(1)).padStart(9)} ${String(entry.calls).padStart(6)}`); + } + const mismatch = group.reduce((value, request) => value + Math.abs(request.total - request.accounted), 0) * 1000; + console.log(`Exclusive-accounting rounding difference: ${mismatch.toFixed(2)} ms`); +} + +console.log("\nMost repeated CMI lookups:"); +for (const [name, entry] of [...imports].sort((a, b) => b[1].calls - a[1].calls).slice(0, 12)) { + console.log(`${String(entry.calls).padStart(4)} calls ${String((entry.seconds * 1000).toFixed(1)).padStart(7)} search/open ms ${name}`); +} diff --git a/rewatch-ocaml/bench/baseline-2026-09-30.csv b/rewatch-ocaml/bench/baseline-2026-09-30.csv new file mode 100644 index 00000000000..07ee5939a36 --- /dev/null +++ b/rewatch-ocaml/bench/baseline-2026-09-30.csv @@ -0,0 +1,166 @@ +scenario,annotation,iteration,elapsed_ms,user_s,system_s,allocated_bytes,peak_rss_kib,artifact_files,artifact_bytes +clean,1,1,34.106,0.011642,0.017463,3137448,37104,44,43290 +clean,0,1,34.983,0.009935,0.017883,2806184,36972,30,8324 +clean,unset,1,36.488,0.024633,0.017736,2806248,37036,30,8324 +clean,unset,2,31.474,0.007961,0.016917,2805968,37088,30,8324 +clean,0,2,32.962,0.011614,0.014103,2806368,37200,30,8324 +clean,1,2,32.455,0.009353,0.018706,3137664,37328,44,43290 +clean,1,3,33.22,0.012151,0.016202,3137448,37420,44,43290 +clean,0,3,33.266,0.011246,0.014619,2806368,37056,30,8324 +clean,unset,3,31.601,0.00633,0.018992,2805952,37056,30,8324 +clean,unset,4,31.626,0.011764,0.014379,2805952,37200,30,8324 +clean,0,4,33.448,0.011057,0.014375,2806368,37072,30,8324 +clean,1,4,31.796,0.007412,0.023297,3137648,37328,44,43290 +clean,1,5,31.818,0.009002,0.018904,3137648,37528,44,43290 +clean,0,5,31.824,0.007325,0.020146,2806368,37068,30,8324 +clean,unset,5,32.345,0.005864,0.019939,2805952,36916,30,8324 +noop,1,1,21.66,0.001797,0.014377,2705600,23768,44,43218 +noop,0,1,22.336,0.004337,0.011928,2692464,23772,30,8296 +noop,unset,1,21.033,0.004777,0.010509,2692216,23776,30,8296 +noop,unset,2,20.956,0.004096,0.011265,2692216,23776,30,8296 +noop,0,2,20.625,0.004144,0.010774,2692464,23768,30,8296 +noop,1,2,20.16,0.003626,0.010878,2705600,23760,44,43218 +noop,1,3,21.104,0.003821,0.011463,2705600,23772,44,43218 +noop,0,3,23.12,0.003725,0.013661,2692464,23776,30,8296 +noop,unset,3,21.152,0.00513,0.01026,2692216,23772,30,8296 +noop,unset,4,21.705,0.002144,0.013941,2692216,23776,30,8296 +noop,0,4,20.01,0.004541,0.009992,2692464,23776,30,8296 +noop,1,4,22.586,0.004425,0.012391,2705616,23764,44,43218 +noop,1,5,22.236,0.00368,0.01288,2705600,23772,44,43218 +noop,0,5,25.219,0.002814,0.01501,2692464,23772,30,8296 +noop,unset,5,21.455,0.002221,0.013328,2692216,23772,30,8296 +edit,1,1,33.465,0.006806,0.013612,3078944,31948,44,43220 +edit,0,1,32.605,0.006746,0.012368,2999544,32056,30,8296 +edit,unset,1,34.402,0.008637,0.012476,2999264,32072,30,8296 +edit,unset,2,31.198,0.006657,0.012364,2999264,32104,30,8296 +edit,0,2,32.604,0.004429,0.015501,2999544,31928,30,8296 +edit,1,2,31.566,0.007681,0.011522,3078944,32032,44,43220 +edit,1,3,31.547,0.006646,0.013292,3078944,32048,44,43220 +edit,0,3,31.85,0.005592,0.013582,2999544,32080,30,8296 +edit,unset,3,35.568,0.004049,0.017211,2999264,32048,30,8296 +edit,unset,4,32.595,0.003847,0.016351,2999264,32088,30,8296 +edit,0,4,33.434,0.006985,0.012807,2999544,32036,30,8296 +edit,1,4,31.768,0.008766,0.01127,3078944,32104,44,43220 +edit,1,5,32.857,0.005836,0.015174,3078944,32156,44,43220 +edit,0,5,32.219,0.004834,0.014504,2999544,32096,30,8296 +edit,unset,5,31.86,0.010844,0.009639,2999264,32268,30,8296 +shared-interface,1,1,32.453,0.007038,0.015082,3794672,29748,24,28416 +shared-interface,0,1,31.28,0.007619,0.016192,3188680,29736,16,5618 +shared-interface,unset,1,36.838,0.011144,0.014184,3188360,29788,16,5618 +shared-interface,unset,2,31.358,0.008051,0.012076,3188464,29668,16,5618 +shared-interface,0,2,38.763,0.016195,0.013337,3188776,29740,16,5618 +shared-interface,1,2,33.268,0.014028,0.013093,3794472,29872,24,28416 +shared-interface,1,3,42.559,0.015343,0.017389,3794568,29744,24,28416 +shared-interface,0,3,32.059,0.00926,0.011906,3188680,29724,16,5618 +shared-interface,unset,3,33.384,0.008728,0.015516,3188464,29864,16,5618 +shared-interface,unset,4,37.886,0.013215,0.014096,3188360,29728,16,5618 +shared-interface,0,4,34.136,0.005148,0.017504,3188680,29868,16,5618 +shared-interface,1,4,33.619,0.006054,0.017154,3794672,29860,24,28416 +shared-interface,1,5,40.11,0.018718,0.009909,3794568,29740,24,28416 +shared-interface,0,5,37.733,0.013826,0.012839,3188976,29904,16,5618 +shared-interface,unset,5,31.728,0.0115,0.0115,3188264,30056,16,5618 +gentype,1,1,34.86,0.011792,0.019653,3272584,36824,46,48883 +gentype,0,1,33.09,0.012756,0.017009,3206608,37192,43,41641 +gentype,unset,1,37.882,0.01921,0.01582,3205896,37140,43,41641 +gentype,unset,2,33.803,0.014449,0.016255,3205600,37060,43,41641 +gentype,0,2,37.895,0.025305,0.016195,3206904,36616,43,41641 +gentype,1,2,32.56,0.004479,0.025756,3272784,37024,46,48883 +gentype,1,3,32.371,0.017122,0.013171,3272184,37244,46,48883 +gentype,0,3,38.602,0.020292,0.016427,3206904,36968,43,41641 +gentype,unset,3,37.762,0.019909,0.017813,3205496,36760,43,41641 +gentype,unset,4,44.054,0.025459,0.019094,3206192,36772,43,41641 +gentype,0,4,33.278,0.013164,0.019148,3206624,37300,43,41641 +gentype,1,4,34.776,0.011529,0.020753,3271984,37136,46,48883 +gentype,1,5,35.741,0.008306,0.025841,3272384,37228,46,48883 +gentype,0,5,33.629,0.009584,0.021298,3206224,37324,43,41641 +gentype,unset,5,40.321,0.031824,0.01768,3205496,36900,43,41641 +ppx,1,1,93.261,0.02075,0.031066,3185232,37520,44,43690 +ppx,0,1,91.163,0.017802,0.031764,2854400,37428,30,8268 +ppx,unset,1,93.778,0.014562,0.031303,2853688,37396,30,8268 +ppx,unset,2,90.244,0.018632,0.029344,2853592,37528,30,8268 +ppx,0,2,95.974,0.01266,0.039326,2854200,37600,30,8268 +ppx,1,2,97.089,0.026243,0.030208,3185128,37664,44,43690 +ppx,1,3,92.477,0.028925,0.030183,3184944,37280,44,43690 +ppx,0,3,83.792,0.014575,0.027841,2853600,37212,30,8268 +ppx,unset,3,86.799,0.014531,0.027406,2853392,37424,30,8268 +ppx,unset,4,90.983,0.021452,0.024188,2853904,37496,30,8268 +ppx,0,4,86.878,0.022012,0.024394,2854000,37268,30,8268 +ppx,1,4,90.097,0.010824,0.036063,3185248,37728,44,43690 +ppx,1,5,90.24,0.014158,0.035781,3185032,37584,44,43690 +ppx,0,5,86.76,0.015726,0.030762,2854000,37196,30,8268 +ppx,unset,5,88.988,0.020625,0.025159,2853792,37520,30,8268 +restart,1,1,31.12,0.007464,0.013062,3079528,32080,44,43436 +restart,0,1,32.889,0.006888,0.014637,3000072,32144,30,8380 +restart,unset,1,32.377,0.005491,0.014644,2999784,32028,30,8380 +restart,unset,2,32.08,0.006846,0.012714,2999784,32076,30,8380 +restart,0,2,31.853,0.005192,0.01428,3000072,31980,30,8380 +restart,1,2,30.638,0.003597,0.015588,3079512,32084,44,43436 +restart,1,3,31.302,0.004907,0.014723,3079528,32044,44,43436 +restart,0,3,32.692,0.005142,0.015428,3000072,31916,30,8380 +restart,unset,3,34.59,0.003468,0.017341,2999784,32104,30,8380 +restart,unset,4,33.208,0.004462,0.016733,2999784,32064,30,8380 +restart,0,4,33.457,0.006602,0.014148,3000072,31944,30,8380 +restart,1,4,37.839,0.006277,0.017039,3079512,31920,44,43436 +restart,1,5,31.937,0.007714,0.013225,3079512,32072,44,43436 +restart,0,5,31.675,0.006863,0.012354,3000072,32088,30,8380 +restart,unset,5,31.931,0.006007,0.013015,2999784,32076,30,8380 +wide-clean,1,1,113.975,0.124301,0.117169,23273952,47368,2014,3147070 +wide-clean,0,1,83.574,0.065487,0.089781,9423016,42492,1409,834022 +wide-clean,unset,1,79.04,0.084681,0.068396,9415912,41872,1409,834022 +wide-clean,unset,2,79.272,0.0749,0.082208,9415808,42344,1409,834022 +wide-clean,0,2,75.093,0.079863,0.073474,9423552,42128,1409,834022 +wide-clean,1,2,118.339,0.130602,0.120154,23269552,48408,2014,3147070 +wide-clean,1,3,122.083,0.141807,0.112263,23270408,47348,2014,3147070 +wide-clean,0,3,81.732,0.082582,0.074622,9423832,41888,1409,834022 +wide-clean,unset,3,81.624,0.075343,0.079588,9418008,42156,1409,834022 +wide-clean,unset,4,79.74,0.080023,0.078941,9417112,41448,1409,834022 +wide-clean,0,4,75.556,0.081599,0.07127,9422536,42456,1409,834022 +wide-clean,1,4,116.631,0.114696,0.136337,23273272,48564,2014,3147070 +wide-clean,1,5,116.058,0.109468,0.131787,23275032,47064,2014,3147070 +wide-clean,0,5,81.043,0.084509,0.070081,9423416,41928,1409,834022 +wide-clean,unset,5,78.285,0.079261,0.074858,9417728,41964,1409,834022 +wide-noop,1,1,26.488,0.007471,0.013875,8769440,24544,2014,3143844 +wide-noop,0,1,26.458,0.004917,0.015736,8204848,24392,1409,832812 +wide-noop,unset,1,25.986,0.008026,0.012039,8204600,24416,1409,832812 +wide-noop,unset,2,27.44,0.00595,0.015471,8204600,24412,1409,832812 +wide-noop,0,2,27.069,0.008138,0.012788,8204848,24416,1409,832812 +wide-noop,1,2,27.594,0.010939,0.010939,8769440,24524,2014,3143844 +wide-noop,1,3,27.767,0.007237,0.014474,8769440,24540,2014,3143844 +wide-noop,0,3,26.679,0.004983,0.01578,8204864,24392,1409,832812 +wide-noop,unset,3,26.941,0.006313,0.014731,8204600,24400,1409,832812 +wide-noop,unset,4,26.553,0.00656,0.014058,8204616,24412,1409,832812 +wide-noop,0,4,27.238,0.008716,0.01259,8204848,24416,1409,832812 +wide-noop,1,4,27.373,0.007485,0.014034,8769440,24540,2014,3143844 +wide-noop,1,5,27.394,0.008333,0.012963,8769440,24544,2014,3143844 +wide-noop,0,5,27.042,0.007045,0.014091,8204848,24416,1409,832812 +wide-noop,unset,5,27.427,0.007168,0.014336,8204600,24416,1409,832812 +wide-edit,1,1,39.37,0.011188,0.015256,8856320,28756,2014,3143910 +wide-edit,0,1,38.427,0.014142,0.010371,8225544,28532,1409,832812 +wide-edit,unset,1,37.583,0.009418,0.015304,8225280,28544,1409,832812 +wide-edit,unset,2,37.904,0.006689,0.017839,8225264,28660,1409,832812 +wide-edit,0,2,37.095,0.012052,0.012979,8225544,28604,1409,832812 +wide-edit,1,2,38.056,0.013475,0.012513,8856320,28944,2014,3143910 +wide-edit,1,3,38.865,0.011135,0.015184,8856320,28940,2014,3143910 +wide-edit,0,3,42.506,0.013352,0.013352,8225560,28716,1409,832812 +wide-edit,unset,3,38.873,0.010211,0.015316,8225264,28680,1409,832812 +wide-edit,unset,4,39.596,0.010255,0.015383,8225264,28576,1409,832812 +wide-edit,0,4,37.591,0.010132,0.014635,8225544,28576,1409,832812 +wide-edit,1,4,39.696,0.012083,0.015104,8856320,28872,2014,3143910 +wide-edit,1,5,39.047,0.014502,0.01243,8856320,28764,2014,3143910 +wide-edit,0,5,37.77,0.008404,0.016809,8225544,28592,1409,832812 +wide-edit,unset,5,37.416,0.010083,0.014564,8225264,28712,1409,832812 +wide-shared-interface,1,1,116.988,0.140709,0.111086,12416152,46012,2014,3214332 +wide-shared-interface,0,1,88.825,0.070872,0.069859,11225528,40984,1409,847909 +wide-shared-interface,unset,1,89.8,0.078723,0.078723,11222912,40548,1409,847909 +wide-shared-interface,unset,2,88.604,0.100669,0.065015,11219312,41072,1409,847909 +wide-shared-interface,0,2,82.96,0.076946,0.072949,11222336,40412,1409,847909 +wide-shared-interface,1,2,114.138,0.13925,0.108978,12413488,46244,2014,3214332 +wide-shared-interface,1,3,117.82,0.148227,0.10427,12416192,45984,2014,3214332 +wide-shared-interface,0,3,86.254,0.086004,0.074178,11224032,41136,1409,847909 +wide-shared-interface,unset,3,88.997,0.087959,0.071594,11221728,40952,1409,847909 +wide-shared-interface,unset,4,82.99,0.067657,0.083711,11223816,40384,1409,847909 +wide-shared-interface,0,4,85.424,0.082852,0.066281,11222832,40656,1409,847909 +wide-shared-interface,1,4,121.388,0.126577,0.128602,12414128,46700,2014,3214332 +wide-shared-interface,1,5,124.851,0.168806,0.098551,12412488,46172,2014,3214332 +wide-shared-interface,0,5,82.532,0.083297,0.063996,11223232,43128,1409,847909 +wide-shared-interface,unset,5,85.815,0.103838,0.055912,11221016,40788,1409,847909 diff --git a/rewatch-ocaml/bench/baseline-2026-09-30.json b/rewatch-ocaml/bench/baseline-2026-09-30.json new file mode 100644 index 00000000000..478bb9b0dc7 --- /dev/null +++ b/rewatch-ocaml/bench/baseline-2026-09-30.json @@ -0,0 +1,29 @@ +{ + "host": "Linux-7.0.12-linuxkit-aarch64-with-glibc2.41", + "python": "3.13.5", + "word_bytes": 8, + "commit": "ef0a737a8a18a6b2d50af2aefb98870e3cf09c1b", + "executable_sha256": "3bff6c6f8aa37210ef4cf8fd7f5c58f715c84d726b66665abb6a0b190cb27a1b", + "compiler_sha256": "837759c001322d04cc342eefab934559f247f0016f381d7fa305d37f58732a09", + "runtime": "/workspaces/rescript-compiler/packages/@rescript/runtime", + "domains": 4, + "runs": 5, + "scenarios": [ + "clean", + "noop", + "edit", + "shared-interface", + "gentype", + "ppx", + "restart", + "wide-clean", + "wide-noop", + "wide-edit", + "wide-shared-interface" + ], + "annotation_modes": [ + "unset", + "0", + "1" + ] +} diff --git a/rewatch-ocaml/bench/baseline-2026-09-30.md b/rewatch-ocaml/bench/baseline-2026-09-30.md new file mode 100644 index 00000000000..b63eac4c92e --- /dev/null +++ b/rewatch-ocaml/bench/baseline-2026-09-30.md @@ -0,0 +1,45 @@ +# Embedded compiler baseline: 2026-09-30 + +Source commit: `ef0a737a8a18a6b2d50af2aefb98870e3cf09c1b`. Host: `Linux-7.0.12-linuxkit-aarch64-with-glibc2.41`; 12 logical CPUs, four compiler domains, Dune default development profile. One unmeasured warm-up and five measured samples per scenario and annotation mode. Annotation settings were interleaved in alternating order. The compiler and executable SHA-256 values and all fixed settings are in [metadata](baseline-2026-09-30.json); all 165 measured requests are in [CSV](baseline-2026-09-30.csv). + +Each sample used a fresh project copy. Clean, no-op, implementation edit, shared-interface edit, GenType, identity PPX, and restart use the focused fixtures. The `wide-*` cases use the 201-module immutable-interface fixture. No-op is a new build process over unchanged artifacts. Restart is a new process after a completed build and source edit; it follows the same CLI compilation path as edit, and is recorded separately to make process restart explicit. PPX uses a file-copying external executable, so it measures the legacy AST protocol and process boundary without a transformation. + +Wall time includes process startup. CPU time and peak RSS come from Linux `wait4`; allocation is the embedded OCaml process total from `REWATCH_GC_STATS_FILE` and excludes external PPX allocation. Artifact counts and bytes include generated AST, CMI, CMJ, annotations, JavaScript, maps, and TypeScript, excluding files present before the build. Every table value is the median of five samples. These are same-host baselines for subsequent checkpoints, not portable latency targets. + +| Scenario | Bin annot | Wall ms | CPU ms | Alloc MB | Peak RSS MiB | Files | Artifact KiB | +| --- | ---: | ---: | ---: | ---: | ---: | ---: | ---: | +| clean | 1 | 32.5 | 28.4 | 3.1 | 36.5 | 44 | 42.3 | +| clean | 0 | 33.3 | 25.9 | 2.8 | 36.2 | 30 | 8.1 | +| clean | unset | 31.6 | 25.8 | 2.8 | 36.2 | 30 | 8.1 | +| noop | 1 | 21.7 | 16.2 | 2.7 | 23.2 | 44 | 42.2 | +| noop | 0 | 22.3 | 16.3 | 2.7 | 23.2 | 30 | 8.1 | +| noop | unset | 21.2 | 15.4 | 2.7 | 23.2 | 30 | 8.1 | +| edit | 1 | 31.8 | 20.0 | 3.1 | 31.3 | 44 | 42.2 | +| edit | 0 | 32.6 | 19.3 | 3.0 | 31.3 | 30 | 8.1 | +| edit | unset | 32.6 | 20.5 | 3.0 | 31.3 | 30 | 8.1 | +| shared-interface | 1 | 33.6 | 27.1 | 3.8 | 29.1 | 24 | 27.8 | +| shared-interface | 0 | 34.1 | 23.8 | 3.2 | 29.0 | 16 | 5.5 | +| shared-interface | unset | 33.4 | 24.2 | 3.2 | 29.1 | 16 | 5.5 | +| gentype | 1 | 34.8 | 31.4 | 3.3 | 36.3 | 46 | 47.7 | +| gentype | 0 | 33.6 | 32.3 | 3.2 | 36.3 | 43 | 40.7 | +| gentype | unset | 37.9 | 37.7 | 3.2 | 36.0 | 43 | 40.7 | +| ppx | 1 | 92.5 | 51.8 | 3.2 | 36.7 | 44 | 42.7 | +| ppx | 0 | 86.9 | 46.5 | 2.9 | 36.4 | 30 | 8.1 | +| ppx | unset | 90.2 | 45.8 | 2.9 | 36.6 | 30 | 8.1 | +| restart | 1 | 31.3 | 20.5 | 3.1 | 31.3 | 44 | 42.4 | +| restart | 0 | 32.7 | 20.6 | 3.0 | 31.2 | 30 | 8.2 | +| restart | unset | 32.4 | 20.1 | 3.0 | 31.3 | 30 | 8.2 | +| wide-clean | 1 | 116.6 | 250.8 | 23.3 | 46.3 | 2014 | 3073.3 | +| wide-clean | 0 | 81.0 | 154.6 | 9.4 | 41.1 | 1409 | 814.5 | +| wide-clean | unset | 79.3 | 154.9 | 9.4 | 41.0 | 1409 | 814.5 | +| wide-noop | 1 | 27.4 | 21.5 | 8.8 | 24.0 | 2014 | 3070.2 | +| wide-noop | 0 | 27.0 | 20.9 | 8.2 | 23.8 | 1409 | 813.3 | +| wide-noop | unset | 26.9 | 21.0 | 8.2 | 23.8 | 1409 | 813.3 | +| wide-edit | 1 | 39.0 | 26.4 | 8.9 | 28.2 | 2014 | 3070.2 | +| wide-edit | 0 | 37.8 | 25.0 | 8.2 | 27.9 | 1409 | 813.3 | +| wide-edit | unset | 37.9 | 24.7 | 8.2 | 28.0 | 1409 | 813.3 | +| wide-shared-interface | 1 | 117.8 | 252.5 | 12.4 | 45.1 | 2014 | 3139.0 | +| wide-shared-interface | 0 | 85.4 | 149.1 | 11.2 | 40.0 | 1409 | 828.0 | +| wide-shared-interface | unset | 88.6 | 159.6 | 11.2 | 39.8 | 1409 | 828.0 | + +On the wide clean fixture, enabling annotations increased median wall time from 79.3 to 116.6 ms, embedded allocation from 9.4 to 23.3 MB, and generated files from 1,409 to 2,014. The `0` and unset settings were both measured; GenType currently retains annotation-related work in both modes. The follow-on checkpoints will remeasure this exact fixture and use the full integration suites for artifact and diagnostic parity. diff --git a/rewatch-ocaml/bench/checkpoint-10-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-10-2026-09-30.md new file mode 100644 index 00000000000..78293b694ac --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-10-2026-09-30.md @@ -0,0 +1,67 @@ +# Checkpoint 10: frozen GenType parity + +Status: validated for opt-in frozen lookup in projects that use GenType. +GenType requests use classic disk lookup; other requests in the same project +use frozen lookup. Frozen lookup remains opt-in until final promotion. + +## Cause and request policy + +Forcing frozen lookup on a GenType request changed imported TypeScript names +(`It as ILeaf_t` became `t as Leaf_t`) and could omit `Pair.gen.ts` when its +interface summary was read before the dependency CMI reached disk. GenType +resolves interface precedence and validates versioned dependency summaries +against disk artifacts. A project-wide classic fallback preserved output but +kept unrelated compile requests off the frozen path. + +The embedded compiler now chooses lookup per request. Rewatch marks GenType +parse requests with `-bs-gentype`, so they retain the disk AST path; GenType +compile requests retain classic interface lookup. Non-GenType requests use +frozen lookup, including a dependency of a GenType package and a consumer of +one. When any package enables GenType, Rewatch publishes compiler artifacts to +disk before releasing dependents. The project metadata records that publication +policy and increments its format version, so switching policies invalidates +dependent caches. + +## Parity gate + +`frozen_gentype_parity.py` passed for three fixtures: recursive GenType +imports, a non-GenType dependency imported by a GenType package, and a +non-GenType consumer importing a GenType dependency. Each ran with +`REWATCH_BIN_ANNOT` unset, `0`, and `1`, under classic and frozen policies. +The gate checked clean, edit, restart, and policy-switch-back builds, complete +TypeScript/JavaScript/CMI/CMJ/GenType-summary file sets and hashes, request +traces, and identical interface-mismatch diagnostics. With annotations enabled, +it checked the annotation file set and semantic CMT/CMTI parity using +`cmt_compare`. The port integration suite also verifies the two mixed import +directions explicitly. + +The final `make test`, `make test-gentype` with one and default compiler-domain +counts, `make test-analysis`, the OCaml Rewatch port suite, focused OUnit +(114 tests), and `make checkformat` passed. `make test` ran before the final +Rewatch publication change; the other final runs covered that change. + +## Equal-work GenType build comparison + +Five interleaved pairs used Linux 7.0.12-linuxkit on aarch64, `/tmp` on +overlayfs, the Dune `dev` profile, four compiler domains, and +`REWATCH_BIN_ANNOT=0`. Before every build, the runner removed generated `lib` +directories for Belt, the React dependency, and the TypeScript React example. +Each sample compiled 141 modules and produced the same digest for 89 generated +TypeScript and JavaScript files. Earlier runs that did not clear all three +package outputs had unequal compiler work and are excluded. + +| Policy | Median wall | Median CPU | Median peak RSS | +| --- | ---: | ---: | ---: | +| Classic lookup | 996.51 ms | 1194.76 ms | 87,768 KiB | +| Frozen request split | 960.13 ms | 1143.13 ms | 103,612 KiB | + +The frozen policy reduced median wall time by 3.6% and raised median sampled +peak RSS by 18%. The memory increase is below the performance gate's 125% +limit, but it remains a cost to monitor at promotion. Raw samples are in +`/tmp/rewatch-step10-large-benchmark-equal/samples.csv` in this workspace. +The Rewatch executable SHA-256 was +`9118570390f7ee149a429a14965e8aad916a4a5d5754588a1990ba8a032d3b3f`; +the standalone compiler SHA-256 was +`ebd81fd8175862b41a76c70e0dd534a86cd137e095960c075d56d3b49bfc4408`. + +Next: checkpoint 11, the legacy PPX adapter boundary. diff --git a/rewatch-ocaml/bench/checkpoint-11-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-11-2026-09-30.md new file mode 100644 index 00000000000..f8f3c5d167a --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-11-2026-09-30.md @@ -0,0 +1,56 @@ +# Checkpoint 11: legacy PPX boundary + +Status: the frozen AST 0 adapter is isolated and validated. Persistent AST 0 +workers and a newer protocol remain separate PPX goals; external PPXs still +run as interruptible child processes. + +`compiler/core/legacy_ppx_adapter.ml` owns the frozen AST 0 file protocol: +conversion to AST 0, Marshal serialization, file writes, external execution, +file reads, deserialization, and result conversion back. `cmd_ppx_apply.ml` +calls the adapter only when `-ppx` arguments are present. The no-PPX branch +returns the input tree unchanged, except for the existing explicit AST +conversion test mode. A completed input write propagates close/flush errors. +`Parsetree0` and the bridge mappings are unchanged. + +The five-run gate used Linux 7.0.12-linuxkit on aarch64, `/tmp` on overlayfs, +the Dune `dev` profile, one compiler domain, `REWATCH_BIN_ANNOT=0`, and frozen +lookup. It alternated a plain build and an identity-PPX build of the same +four-module project; one module has an interface, so the PPX handled five ASTs +per build. Both modes compiled four modules on every run and generated the +same 20 JavaScript, CMI, and CMJ artifacts by SHA-256. The no-PPX traces had +zero `ppx.*` phases; identity-PPX traces had all seven expected phases. + +| Phase | Median worker time | Median OCaml allocation | Calls per build | +| --- | ---: | ---: | ---: | +| AST 0 conversion | 0.024 ms | 19.7 KiB | 5 | +| Serialization | 0.021 ms | 5.3 KiB | 10 | +| File writes | 0.120 ms | 1.5 KiB | 5 | +| External execution | 27.762 ms | 697.7 KiB | 5 | +| File reads | 0.071 ms | 6.8 KiB | 10 | +| Deserialization | 0.034 ms | 15.3 KiB | 5 | +| AST 0 conversion back | 0.027 ms | 23.8 KiB | 5 | + +Median elapsed build time was 33.721 ms without a PPX and 82.591 ms with the +identity PPX. Worker-phase timings exclude Rewatch scheduling and other build +work; external execution includes process startup and the identity PPX's file +copy. The adapter's conversion, serialization, file I/O, and deserialization +were small compared with external execution. Raw CSV and per-request traces +are in `/tmp/rewatch-step11-close-gate` in this workspace. The Rewatch executable +SHA-256 was +`0cc5624db1e3868293fec57cdb38a00b3375c57fcd9f4cf2e413007d2e3dfb20`; +the standalone compiler SHA-256 was +`f10eea6f60ed87b055abdb8f5104a434aa3430fe7b0c9d5caa87038de503b827`. + +The existing `sury-ppx` fixture also built successfully through the adapter: +the generated JavaScript included the transformed schema declaration. Its +single PPX execution took 22.547 ms, versus 0.166 ms across the conversion, +serialization, file I/O, and deserialization phases. This is one traced build, +so it is a functional check and cost example rather than a repeatable +performance comparison. + +`make test-syntax` passed the existing AST 0 mapping fixtures; `make test` +passed the compiler, standard-library, and JavaScript suites; the OCaml +Rewatch port suite passed; and the identity-PPX gate passed. The PPX adapter +does not change the frozen AST 0 shape or add conversions to non-PPX requests. + +Next: checkpoint 12, core promotion and final gates. diff --git a/rewatch-ocaml/bench/checkpoint-12-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-12-2026-09-30.md new file mode 100644 index 00000000000..be5a100c610 --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-12-2026-09-30.md @@ -0,0 +1,80 @@ +# Checkpoint 12: core promotion gate + +Status: local Linux validation passed; promotion is pending macOS and Windows +results for these commits. The branch has not been pushed. + +## Default and retained paths + +OCaml Rewatch already creates sessions with frozen lookup enabled and turns on +owned AST and compiler-artifact handoff. Checkpoints 7–11 validated those +defaults, including mixed GenType packages. Standalone `bsc` keeps its normal +disk-reader default. No further default toggle is needed for this branch. + +The remaining alternate paths serve active contracts, so none can safely be +removed as superseded: GenType requests need classic lookup and disk AST/CMI +publication; restarted builds and cache eviction need persistent artifacts; +prebuilt GenType dependencies need the legacy CMT reader; editor consumers +need annotation files and compatibility copies when enabled; and existing +external PPXs need the frozen AST 0 protocol. The opt-out settings remain +useful for comparing the classic compiler path and diagnosing regressions. + +## Final local gates + +The final local runs used Linux 7.0.12-linuxkit on aarch64, `/tmp` on +overlayfs, and the Dune `dev` profile: + +| Gate | Result | +| --- | --- | +| `make test-all` | Passed: compiler (345 OUnit cases), standard library, GenType, analysis, tools, and OCaml Rewatch canonical integration suites | +| Focused OCaml Rewatch integration | Passed with 1, 4, and 12 compiler domains | +| Frozen GenType parity | Passed both mixed-import directions and recursive imports with annotations unset, `0`, and `1`; clean, edit, restart, and policy switches | +| Legacy PPX gate | Passed five interleaved pairs with identical 20 generated artifacts and zero AST 0 conversion on no-PPX requests | +| Syntax and formatting | `make test-syntax` passed at checkpoint 11; `make checkformat` passed for the final local tree | + +The Linux CI-style Dune `static` profile also built the standalone compiler, +OCaml Rewatch, and the CMT comparison tool. `file` identified both compiler +executables as statically linked aarch64 ELF binaries. The focused OCaml +Rewatch suite passed with four compiler domains on those binaries, and the +mixed GenType and five-run PPX parity gates passed again. The static Rewatch +SHA-256 was +`8d8fa0e7384e5b6545c79439ab661a75d114eb88a4719b79c5086df48bd6f72d`; +the static standalone compiler SHA-256 was +`7bbde9ef70d42b784ba9b706efd004a5f7ca98175ff1b9fc9be47e642172662f`. + +The first `make test-all` attempt stopped in the tools suite because a nested +test command's `git` rejected this workspace's ownership. Re-running with a +process-local `safe.directory` setting passed all suites. This setting did not +change repository configuration or test code. The full suite passed again +after the final PPX write-close fix. + +An exact-revision four-domain focused run initially failed in the symlink +target replacement case. The test created its temporary replacement in +`/tmp` on overlayfs, then moved it over a target in this FUSE workspace; +that cross-filesystem `mv` was a copy, not the atomic rename the test intended. +The fixture now creates the temporary file beside the target. The focused +suite then passed with 1, 4, and 12 domains. The failed run remains recorded +at `/tmp/rewatch-step12-close-port-4-repro.log`; the passing corrected runs +are in `/tmp/rewatch-step12-close-port-*-atomic.log`. + +The five-run checkpoint 10 equal-work GenType comparison found a 3.6% median +wall-time improvement and 18% higher sampled peak RSS for frozen request +splitting. The five-run checkpoint 11 gate isolated PPX adapter costs: the +median five-request AST 0 conversion took 0.024/0.027 ms to/from the frozen +representation, while external execution took 27.762 ms. These are +the most relevant final performance and memory observations; raw samples and +their executable identities are in the checkpoint 10 and 11 reports. + +## CI and remaining gate + +The CI matrix already runs compiler and OCaml Rewatch tests on Linux, +macOS, and Windows. It now runs the focused OCaml Rewatch suite with fixed +one-domain and four-domain settings as well as its normal default, and the +Linux ARM job runs the mixed GenType and legacy PPX parity gates. Those +commands passed locally. The macOS and Windows jobs cannot run against +unpublished local commits from this Linux checkout, so the plan's explicit +cross-platform promotion requirement is still open. The changelog records +the user-facing mixed GenType improvement under the existing Rewatch PR. + +Next: after the local commits are published by the repository owner, inspect +the Linux, macOS, and Windows matrix results for this exact revision. If they +pass, check off checkpoint 12 and record those links. diff --git a/rewatch-ocaml/bench/checkpoint-2-2026-09-30.csv b/rewatch-ocaml/bench/checkpoint-2-2026-09-30.csv new file mode 100644 index 00000000000..b40027ccdac --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-2-2026-09-30.csv @@ -0,0 +1,57 @@ +scenario,annotation,iteration,revision,elapsed_ms,user_s,system_s,allocated_bytes,peak_rss_kib,artifact_files,artifact_bytes +wide-clean,0,1,old,75.519,0.092554,0.086314,9430032,41812,1409,835232 +wide-clean,0,1,new,73.127,0.108107,0.066969,9431192,44024,1409,835232 +wide-clean,1,1,old,123.337,0.159062,0.123176,23280672,48200,2014,3150296 +wide-clean,1,1,new,111.063,0.121662,0.149036,23282904,50068,2014,3150296 +wide-clean,1,2,new,108.618,0.151021,0.127709,23282320,50324,2014,3150296 +wide-clean,1,2,old,114.662,0.128889,0.148063,23279456,47436,2014,3150296 +wide-clean,0,2,new,72.898,0.085516,0.085516,9427280,44860,1409,835232 +wide-clean,0,2,old,68.601,0.082611,0.077042,9425952,42540,1409,835232 +wide-clean,0,3,old,68.933,0.082751,0.073668,9430536,42100,1409,835232 +wide-clean,0,3,new,72.363,0.087458,0.083139,9431576,44272,1409,835232 +wide-clean,1,3,old,108.554,0.147983,0.117575,23280120,47936,2014,3150296 +wide-clean,1,3,new,109.344,0.158247,0.115642,23279568,50940,2014,3150296 +wide-clean,1,4,new,114.46,0.143932,0.13481,23278920,50216,2014,3150296 +wide-clean,1,4,old,113.278,0.131844,0.130745,23279216,48316,2014,3150296 +wide-clean,0,4,new,67.999,0.07269,0.093938,9431280,44156,1409,835232 +wide-clean,0,4,old,78.106,0.083395,0.085506,9427752,41492,1409,835232 +wide-clean,0,5,old,70.359,0.068308,0.096953,9430352,42184,1409,835232 +wide-clean,0,5,new,76.434,0.102756,0.075613,9429976,44540,1409,835232 +wide-clean,1,5,old,110.5,0.137189,0.125172,23278360,48780,2014,3150296 +wide-clean,1,5,new,107.968,0.13563,0.127347,23279064,50412,2014,3150296 +wide-clean,1,6,new,107.627,0.145104,0.11705,23280464,50484,2014,3150296 +wide-clean,1,6,old,120.252,0.145663,0.138865,23278632,48212,2014,3150296 +wide-clean,0,6,new,75.223,0.101941,0.07886,9430176,44512,1409,835232 +wide-clean,0,6,old,74.606,0.083968,0.086016,9431032,41956,1409,835232 +wide-clean,0,7,old,71.278,0.103842,0.062101,9428552,42520,1409,835232 +wide-clean,0,7,new,72.391,0.080254,0.092143,9429696,44020,1409,835232 +wide-clean,1,7,old,119.191,0.131547,0.142941,23280032,47896,2014,3150296 +wide-clean,1,7,new,102.038,0.114245,0.142305,23280208,50408,2014,3150296 +wide-shared-interface,0,1,old,70.879,0.084403,0.069681,11226080,41092,1409,849119 +wide-shared-interface,0,1,new,69.777,0.085255,0.067793,11229224,42448,1409,849119 +wide-shared-interface,1,1,old,98.763,0.137853,0.121143,12426240,45524,2014,3217958 +wide-shared-interface,1,1,new,98.382,0.126167,0.123992,12423848,46992,2014,3217958 +wide-shared-interface,1,2,new,97.455,0.141773,0.114625,12425248,47596,2014,3217958 +wide-shared-interface,1,2,old,97.599,0.133126,0.114405,12423224,45696,2014,3217958 +wide-shared-interface,0,2,new,70.605,0.092863,0.059389,11227224,42276,1409,849119 +wide-shared-interface,0,2,old,70.078,0.095301,0.057966,11227080,40816,1409,849119 +wide-shared-interface,0,3,old,68.264,0.072288,0.075573,11227480,41368,1409,849119 +wide-shared-interface,0,3,new,73.744,0.080438,0.076313,11228320,42960,1409,849119 +wide-shared-interface,1,3,old,103.813,0.127784,0.125689,12422400,45612,2014,3217958 +wide-shared-interface,1,3,new,96.855,0.133808,0.121644,12423168,47636,2014,3217958 +wide-shared-interface,1,4,new,94.491,0.120451,0.122622,12423712,48328,2014,3217958 +wide-shared-interface,1,4,old,99.414,0.130041,0.123749,12426064,47808,2014,3217958 +wide-shared-interface,0,4,new,69.199,0.083945,0.065612,11230624,41836,1409,849119 +wide-shared-interface,0,4,old,69.109,0.091362,0.056707,11229680,40952,1409,849119 +wide-shared-interface,0,5,old,98.542,0.08516,0.060476,11233160,40948,1409,849119 +wide-shared-interface,0,5,new,71.113,0.074419,0.073274,11228824,42772,1409,849119 +wide-shared-interface,1,5,old,107.676,0.152744,0.127785,12424120,45540,2014,3217958 +wide-shared-interface,1,5,new,97.757,0.126008,0.124024,12424968,47608,2014,3217958 +wide-shared-interface,1,6,new,104.324,0.141775,0.118671,12425424,47536,2014,3217958 +wide-shared-interface,1,6,old,103.896,0.13725,0.126466,12422376,45824,2014,3217958 +wide-shared-interface,0,6,new,69.617,0.094594,0.055452,11230024,42348,1409,849119 +wide-shared-interface,0,6,old,71.299,0.098808,0.052626,11227080,41144,1409,849119 +wide-shared-interface,0,7,old,68.343,0.086618,0.059153,11228880,41136,1409,849119 +wide-shared-interface,0,7,new,69.033,0.088629,0.06204,11229424,42304,1409,849119 +wide-shared-interface,1,7,old,97.824,0.134341,0.119647,12422984,46380,2014,3217958 +wide-shared-interface,1,7,new,106.537,0.138973,0.127392,12427680,47284,2014,3217958 diff --git a/rewatch-ocaml/bench/checkpoint-2-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-2-2026-09-30.md new file mode 100644 index 00000000000..aea1eed9be5 --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-2-2026-09-30.md @@ -0,0 +1,18 @@ +# Typed request comparison: 2026-09-30 + +Compared checkpoint 1 (`c0a00b942`) with the checkpoint 2 implementation on Linux aarch64, 12 logical CPUs, Dune default development profile. Both OCaml Rewatch executables were in the same directory. Their SHA-256 values were `4c91d882d32ebe9ff95d37e446bbe55ce1a2dfd97fd0e8a878858b28ce503531` (checkpoint 1) and `dcf6d7777f52c7714e88209d5b88f7744696b85ed2fdfed6ae16cb6d31dc21e9` (checkpoint 2). The latter was built before the final test and documentation edits, which do not affect the driver behavior. + +The [raw seven-run, interleaved samples](checkpoint-2-2026-09-30.csv) use four compiler domains and the 201-module fixture. `REWATCH_BIN_ANNOT` was explicitly `0` or `1`. Each sample used a fresh fixture and one unmeasured warm-up preceded sampling. `wait4` supplied CPU and RSS; the embedded runtime supplied allocation. The table shows median wall time and RSS, plus generated file counts. Artifact byte counts matched exactly between revisions in every paired scenario. + +| Scenario | Annotation | Old wall ms | New wall ms | Old RSS MiB | New RSS MiB | Files | +| --- | ---: | ---: | ---: | ---: | ---: | ---: | +| Wide clean | 0 | 71.3 | 72.9 | 41.1 | 43.2 | 1,409 | +| Wide clean | 1 | 114.7 | 108.6 | 47.1 | 49.2 | 2,014 | +| Wide shared interface | 0 | 70.1 | 69.8 | 40.1 | 41.4 | 1,409 | +| Wide shared interface | 1 | 99.4 | 97.8 | 44.6 | 46.5 | 2,014 | + +Median embedded allocation was unchanged to two decimal places in every row: 9.43, 23.28, 11.23, and 12.42 MB respectively. + +The full testrepo `performance_gate.sh` also ran five interleaved samples per scenario with one compiler domain. Old/new median wall times were 1,658/1,667 ms for clean, 42/43 ms for unchanged, and 43/42 ms for edit. Median sampled peak tree RSS was 179,308/192,596 KiB for clean. Both revisions issued the same 1,031 clean, 4 unchanged, and 6 edit logical compiler requests. The gate passed its time and memory thresholds and found identical complete file sets and byte-identical generated artifacts. + +The four-domain full testrepo artifact comparison found differing WebAPI CMI files. Repeating the same clean build twice with the unchanged checkpoint 1 executable and four domains produced 203 differing WebAPI CMIs; one-domain repeats produced zero differences. Inspection showed that a changed CMI can have an identical serialized signature but differing imported dependency checksums. This existing parallel-build nondeterminism prevents a byte-parity conclusion from that four-domain fixture. The one-domain comparison above isolates the checkpoint 2 option change; resolving parallel CMI determinism remains necessary before final promotion. diff --git a/rewatch-ocaml/bench/checkpoint-3-2026-09-30.csv b/rewatch-ocaml/bench/checkpoint-3-2026-09-30.csv new file mode 100644 index 00000000000..6fbdddd6da6 --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-3-2026-09-30.csv @@ -0,0 +1,31 @@ +scenario,annotation,iteration,revision,elapsed_ms,user_s,system_s,allocated_bytes,peak_rss_kib,artifact_files,artifact_bytes +gentype,unset,1,old,20.714,0.006153,0.009229,3207656,28364,43,42481 +gentype,unset,1,new,19.566,0.00995,0.004422,3231744,30032,43,42481 +gentype,unset,2,new,18.85,0.009583,0.004791,3231728,29760,43,42481 +gentype,unset,2,old,18.974,0.007625,0.006536,3207656,28344,43,42481 +gentype,unset,3,old,19.598,0.011909,0.002381,3207656,28360,43,42481 +gentype,unset,3,new,19.073,0.008266,0.005904,3231728,30040,43,42481 +gentype,unset,4,new,19.252,0.00696,0.007954,3231728,30124,43,42481 +gentype,unset,4,old,19.002,0.010802,0.0036,3207656,28236,43,42481 +gentype,unset,5,old,19.42,0.007036,0.007036,3207656,28364,43,42481 +gentype,unset,5,new,19.651,0.008877,0.005073,3231728,30128,43,42481 +gentype,0,1,old,19.319,0.00843,0.006022,3208272,28364,43,42481 +gentype,0,1,new,20.572,0.008379,0.005985,3232488,30116,43,42481 +gentype,0,2,new,18.998,0.00912,0.005066,3232488,30160,43,42481 +gentype,0,2,old,19.629,0.007432,0.007432,3208256,28368,43,42481 +gentype,0,3,old,19.35,0.008359,0.005572,3208256,28232,43,42481 +gentype,0,3,new,19.902,0.009426,0.004713,3232488,29652,43,42481 +gentype,0,4,new,17.937,0.008749,0.004999,3232488,29780,43,42481 +gentype,0,4,old,20.773,0.008496,0.005664,3208256,27760,43,42481 +gentype,0,5,old,20.261,0.010967,0.00329,3208272,28364,43,42481 +gentype,0,5,new,21.451,0.009524,0.004762,3232504,29756,43,42481 +gentype,1,1,old,19.511,0.004857,0.010686,3274456,28364,46,49823 +gentype,1,1,new,24.656,0.004348,0.010871,3298768,30136,46,49823 +gentype,1,2,new,19.551,0.009999,0.005555,3298672,30160,46,49823 +gentype,1,2,old,20.25,0.007524,0.007524,3274472,28360,46,49823 +gentype,1,3,old,18.523,0.010449,0.004644,3274472,28368,46,49823 +gentype,1,3,new,19.091,0.009874,0.005485,3298672,30192,46,49823 +gentype,1,4,new,21.586,0.005696,0.009114,3298672,29776,46,49823 +gentype,1,4,old,19.089,0.010419,0.004736,3274456,28352,46,49823 +gentype,1,5,old,20.489,0.006018,0.009028,3274456,28368,46,49823 +gentype,1,5,new,21.176,0.009244,0.005777,3298688,29784,46,49823 diff --git a/rewatch-ocaml/bench/checkpoint-3-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-3-2026-09-30.md new file mode 100644 index 00000000000..cf032e51531 --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-3-2026-09-30.md @@ -0,0 +1,15 @@ +# Independent policy comparison: 2026-09-30 + +Compared checkpoint 2 (`af8881afa`) with checkpoint 3 on Linux aarch64, 12 logical CPUs, the Dune default development profile, and one compiler domain. Both OCaml Rewatch executables were in the same directory. Their SHA-256 values were `dcf6d7777f52c7714e88209d5b88f7744696b85ed2fdfed6ae16cb6d31dc21e9` and `e6549bdc2bf187c4a599795f517a8024b844589f2e29ea5e99b0fb9d35f01b1a` respectively. The standalone compiler and runtime were identical in both runs. + +The five-run, interleaved full testrepo gate passed. Median clean wall time was 1,686 ms before and 1,703 ms after; unchanged was 46/44 ms and edit was 43/42 ms. The clean median sampled process-tree RSS was 181,488/195,948 KiB, below the gate's 125% limit. Compiler request counts matched exactly: 1,031 clean, 4 unchanged, and 6 edit. The complete post-build file sets and all generated artifact bytes matched. + +The [raw GenType samples](checkpoint-3-2026-09-30.csv) use five interleaved runs for each annotation setting with one unmeasured warm-up per executable and setting. Each sample uses a fresh fixture. The monotonic clock supplies wall time, `wait4` supplies CPU and peak RSS, and the embedded runtime supplies allocation. + +| `REWATCH_BIN_ANNOT` | Old wall ms | New wall ms | Old allocation MB | New allocation MB | Old RSS MiB | New RSS MiB | Files | +| --- | ---: | ---: | ---: | ---: | ---: | ---: | ---: | +| unset | 19.4 | 19.3 | 3.21 | 3.23 | 27.7 | 29.3 | 43 | +| `0` | 19.6 | 19.9 | 3.21 | 3.23 | 27.7 | 29.1 | 43 | +| `1` | 19.5 | 21.2 | 3.27 | 3.30 | 27.7 | 29.4 | 46 | + +In a separate fixed-path GenType comparison, all 43 generated artifacts with annotations unset or `0`, and all 46 with annotations `1`, matched byte for byte across revisions. This includes TypeScript, JavaScript, CMI, CMJ, CMT, and CMTI files. Classic lookup keeps the disk AST roundtrip and publishes an interface to disk before releasing dependents; capture of compiled CMI and CMJ remains available in the session. This preserves the existing GenType and editor output while the policies are separated. diff --git a/rewatch-ocaml/bench/checkpoint-4-2026-09-30.csv b/rewatch-ocaml/bench/checkpoint-4-2026-09-30.csv new file mode 100644 index 00000000000..64cb7572b65 --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-4-2026-09-30.csv @@ -0,0 +1,31 @@ +revision,elapsed_ms,user_s,system_s,allocated_bytes,peak_rss_kib,artifact_files,artifact_bytes,scenario,annotation,iteration +old,19.905,0.010821,0.005902,3231728,26348,43,42481,gentype,unset,1 +new,24.493,0.010426,0.006255,3232160,28708,43,42481,gentype,unset,1 +new,19.577,0.009504,0.006652,3232080,28876,43,42481,gentype,unset,2 +old,19.682,0.007483,0.007483,3231728,28120,43,42481,gentype,unset,2 +old,18.878,0.008594,0.006684,3231728,27676,43,42481,gentype,unset,3 +new,19.884,0.009121,0.006081,3232064,28820,43,42481,gentype,unset,3 +new,19.143,0.006879,0.008026,3232064,28816,43,42481,gentype,unset,4 +old,19.006,0.008935,0.006949,3231728,27080,43,42481,gentype,unset,4 +old,19.07,0.007933,0.0068,3231728,26936,43,42481,gentype,unset,5 +new,19.415,0.009705,0.004852,3232064,29164,43,42481,gentype,unset,5 +old,19.124,0.013348,0.002053,3232488,27132,43,42481,gentype,0,1 +new,18.898,0.006083,0.009125,3232824,28616,43,42481,gentype,0,1 +new,19.259,0.008103,0.006077,3232840,29168,43,42481,gentype,0,2 +old,19.232,0.007092,0.008274,3232504,26252,43,42481,gentype,0,2 +old,19.155,0.007151,0.007151,3232488,27316,43,42481,gentype,0,3 +new,19.343,0.007799,0.007799,3232824,27992,43,42481,gentype,0,3 +new,20.417,0.007846,0.008967,3232824,27480,43,42481,gentype,0,4 +old,25.015,0.008603,0.007647,3232584,26168,43,42481,gentype,0,4 +old,21.401,0.002645,0.013225,3232488,26040,43,42481,gentype,0,5 +new,18.975,0.011978,0.002994,3232824,27608,43,42481,gentype,0,5 +old,20.365,0.008321,0.008321,3298688,25544,46,49823,gentype,1,1 +new,24.648,0.005849,0.010724,3299104,27272,46,49823,gentype,1,1 +new,19.858,0.007878,0.007878,3299008,27224,46,49823,gentype,1,2 +old,19.817,0.008492,0.00743,3298672,25428,46,49823,gentype,1,2 +old,18.986,0.006159,0.009239,3298672,25424,46,49823,gentype,1,3 +new,18.899,0.009462,0.006021,3299008,29164,46,49823,gentype,1,3 +new,19.34,0.01043,0.005215,3299008,26932,46,49823,gentype,1,4 +old,20.975,0.007092,0.009119,3298688,25400,46,49823,gentype,1,4 +old,24.786,0.008973,0.006979,3298768,25400,46,49823,gentype,1,5 +new,23.845,0.011817,0.003545,3299104,27148,46,49823,gentype,1,5 diff --git a/rewatch-ocaml/bench/checkpoint-4-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-4-2026-09-30.md new file mode 100644 index 00000000000..f09f786b07d --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-4-2026-09-30.md @@ -0,0 +1,46 @@ +# Owned GenType semantic inputs: 2026-09-30 + +Compared checkpoint 3 (`97186f45a`) with checkpoint 4 on Linux aarch64, +12 logical CPUs, the Dune default development profile, and one compiler +domain. Both OCaml Rewatch executables were in the same directory. Their +SHA-256 values were +`e6549bdc2bf187c4a599795f517a8024b844589f2e29ea5e99b0fb9d35f01b1a` +and `d9696e1dea3e831cf23f7a2fb0d5ac8c15a854489bb367f90f38c428695982ed`. +The standalone compiler and runtime were identical in both runs. + +The five-run, interleaved testrepo gate passed. Median clean wall time was +3,434/3,401 ms before/after, with sampled peak process-tree RSS of +191,516/188,752 KiB. Unchanged medians were 216/224 ms and edit medians were +269/266 ms. Compiler request counts matched exactly: 1,031 clean, 4 unchanged, +and 6 edit. Complete post-build file sets and artifact bytes matched. The gate +used a temporary directory on the workspace filesystem because the container's +`/tmp` filesystem lacked space for the final comparison. Compare these times +only within this interleaved run. + +The [raw GenType samples](checkpoint-4-2026-09-30.csv) use five interleaved +runs per annotation setting, with one unmeasured warm-up per executable and +setting. Each sample starts with a fresh fixture. The monotonic clock supplies +wall time, `wait4` supplies CPU and peak RSS, and the embedded runtime supplies +allocation. + +| `REWATCH_BIN_ANNOT` | Old/new wall ms | Old/new CPU ms | Old/new allocation MB | Old/new RSS MiB | Files | +| --- | ---: | ---: | ---: | ---: | ---: | +| unset | 19.1/19.6 | 15.3/15.2 | 3.23/3.23 | 26.4/28.1 | 43 | +| `0` | 19.2/19.3 | 15.4/15.2 | 3.23/3.23 | 25.6/27.3 | 43 | +| `1` | 20.4/19.9 | 16.0/15.6 | 3.30/3.30 | 24.8/26.6 | 46 | + +In a separate fixed-path comparison, all 43 generated artifacts with +annotations unset or `0`, and all 46 with annotations `1`, matched byte for +byte. This includes +TypeScript, JavaScript, CMI, CMJ, CMT, and CMTI files. + +A one-domain type-check trace of the clean GenType fixture recorded one +`dependency.gentype_cmt_read` on checkpoint 3 and none on checkpoint 4. +Checkpoint 4 recorded one request-owned semantic lookup for the matching +interface. The new focused test feeds implementation and interface semantics +after removing both annotation files and checks normal interface precedence +and `@genType.ignoreInterface` precedence. Session lookup returns isolated +copies and validates both source and published file identities; misses retain +the disk reader. Recursive dependency reads remain for checkpoint 5. +The OCaml Rewatch port's integration suite also passed, including its GenType +trace assertions for implementation and interface semantic results. diff --git a/rewatch-ocaml/bench/checkpoint-5-2026-09-30.csv b/rewatch-ocaml/bench/checkpoint-5-2026-09-30.csv new file mode 100644 index 00000000000..892a99733f5 --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-5-2026-09-30.csv @@ -0,0 +1,91 @@ +revision,elapsed_ms,user_s,system_s,allocated_bytes,peak_rss_kib,artifact_files,artifact_bytes,scenario,annotation,iteration,summary_files,summary_bytes +old,18.765,0.005326,0.009587,3774248,28592,33,32289,clean,unset,1,0,0 +new,36.902,0.0064,0.012801,3909072,28896,33,32289,clean,unset,1,6,21774 +new,30.625,0.010881,0.006696,3908976,28788,33,32289,clean,unset,2,6,21774 +old,18.883,0.010075,0.00403,3774248,26596,33,32289,clean,unset,2,0,0 +old,18.504,0.008341,0.004766,3774248,27252,33,32289,clean,unset,3,0,0 +new,30.432,0.010555,0.007037,3908976,27604,33,32289,clean,unset,3,6,21774 +new,28.722,0.008019,0.009356,3908960,28568,33,32289,clean,unset,4,6,21774 +old,18.954,0.005849,0.007798,3774248,26268,33,32289,clean,unset,4,0,0 +old,18.789,0.009012,0.004096,3774248,27236,33,32289,clean,unset,5,0,0 +new,29.83,0.011017,0.009014,3908960,27920,33,32289,clean,unset,5,6,21774 +old,7.664,0.003775,0.003775,2672888,22968,33,32289,unchanged,unset,1,0,0 +new,7.019,0.004579,0.002289,2676536,25576,33,32289,unchanged,unset,1,6,21774 +new,7.199,0.003022,0.00403,2676536,24952,33,32289,unchanged,unset,2,6,21774 +old,8.296,0.002024,0.006074,2672888,22972,33,32289,unchanged,unset,2,0,0 +old,6.952,0.003877,0.002907,2672888,23848,33,32289,unchanged,unset,3,0,0 +new,7.243,0.003044,0.004058,2676536,25880,33,32289,unchanged,unset,3,6,21774 +new,7.4,0.001815,0.005445,2676536,24628,33,32289,unchanged,unset,4,6,21774 +old,7.03,0.002964,0.003952,2672888,23832,33,32289,unchanged,unset,4,0,0 +old,7.046,0.002973,0.003964,2672888,23852,33,32289,unchanged,unset,5,0,0 +new,7.001,0.004905,0.001962,2676536,25560,33,32289,unchanged,unset,5,6,21774 +old,17.504,0.006794,0.004246,2759728,26256,33,32289,restart-edit,unset,1,0,0 +new,24.095,0.008003,0.006225,2763672,27756,33,32289,restart-edit,unset,1,6,21774 +new,27.398,0.011287,0.003386,2763688,26904,33,32289,restart-edit,unset,2,6,21774 +old,20.06,0.006273,0.005376,2759728,25524,33,32289,restart-edit,unset,2,0,0 +old,19.873,0.007063,0.004709,2759744,25512,33,32289,restart-edit,unset,3,0,0 +new,25.745,0.008033,0.005738,2763472,27152,33,32289,restart-edit,unset,3,6,21774 +new,24.775,0.009154,0.005085,2763672,27184,33,32289,restart-edit,unset,4,6,21774 +old,18.55,0.003391,0.007912,2759728,25384,33,32289,restart-edit,unset,4,0,0 +old,19.928,0.006133,0.005111,2759728,25524,33,32289,restart-edit,unset,5,0,0 +new,24.038,0.010697,0.00382,2763688,27200,33,32289,restart-edit,unset,5,6,21774 +old,19.248,0.009442,0.004721,3774840,26372,33,32289,clean,0,1,0,0 +new,29.259,0.011134,0.008097,3909536,27756,33,32289,clean,0,1,6,21774 +new,33.636,0.008285,0.009469,3909536,27888,33,32289,clean,0,2,6,21774 +old,19.179,0.007107,0.007107,3774840,26404,33,32289,clean,0,2,0,0 +old,18.486,0.008379,0.005586,3774824,26372,33,32289,clean,0,3,0,0 +new,28.732,0.009555,0.008599,3909536,27640,33,32289,clean,0,3,6,21774 +new,34.072,0.012927,0.006463,3909536,27736,33,32289,clean,0,4,6,21774 +old,18.695,0.009679,0.003226,3774824,28504,33,32289,clean,0,4,0,0 +old,18.792,0.007308,0.006264,3774824,28348,33,32289,clean,0,5,0,0 +new,36.087,0.016204,0.003472,3909632,28568,33,32289,clean,0,5,6,21774 +old,7.604,0.002808,0.00468,2673232,22972,33,32289,unchanged,0,1,0,0 +new,7.972,0.002942,0.004903,2676896,24696,33,32289,unchanged,0,1,6,21774 +new,7.967,0.00391,0.00391,2676880,24880,33,32289,unchanged,0,2,6,21774 +old,8.018,0.003951,0.003951,2673232,22972,33,32289,unchanged,0,2,0,0 +old,7.87,0.006732,0.000961,2673232,22968,33,32289,unchanged,0,3,0,0 +new,7.427,0.003629,0.003629,2676880,24892,33,32289,unchanged,0,3,6,21774 +new,7.652,0.001867,0.005603,2676880,24696,33,32289,unchanged,0,4,6,21774 +old,7.09,0.003982,0.002986,2673232,22972,33,32289,unchanged,0,4,0,0 +old,7.434,0.005195,0.002078,2673232,22952,33,32289,unchanged,0,5,0,0 +new,7.536,0.00464,0.002784,2676880,24668,33,32289,unchanged,0,5,6,21774 +old,18.876,0.007685,0.003293,2760112,25660,33,32289,restart-edit,0,1,0,0 +new,26.138,0.009305,0.004652,2764072,27012,33,32289,restart-edit,0,1,6,21774 +new,25.948,0.006593,0.007535,2764056,26956,33,32289,restart-edit,0,2,6,21774 +old,18.191,0.008795,0.002931,2760112,25532,33,32289,restart-edit,0,2,0,0 +old,19.179,0.004604,0.006445,2760112,25524,33,32289,restart-edit,0,3,0,0 +new,23.633,0.004597,0.009195,2764056,26780,33,32289,restart-edit,0,3,6,21774 +new,24.246,0.006735,0.006735,2764056,26952,33,32289,restart-edit,0,4,6,21774 +old,17.537,0.009437,0.001887,2760112,25516,33,32289,restart-edit,0,4,0,0 +old,21.481,0.007107,0.004061,2760112,26288,33,32289,restart-edit,0,5,0,0 +new,24.062,0.007211,0.006009,2764056,29252,33,32289,restart-edit,0,5,6,21774 +old,18.619,0.007201,0.006172,3774824,28500,33,32289,clean,1,1,0,0 +new,31.288,0.012119,0.007791,3909536,29652,33,32289,clean,1,1,6,21774 +new,31.873,0.009657,0.008584,3909552,28404,33,32289,clean,1,2,6,21774 +old,19.275,0.009556,0.004778,3774824,26372,33,32289,clean,1,2,0,0 +old,19.129,0.008416,0.004809,3774824,26404,33,32289,clean,1,3,0,0 +new,28.649,0.008413,0.009465,3909536,27472,33,32289,clean,1,3,6,21774 +new,30.338,0.008837,0.009942,3909552,27788,33,32289,clean,1,4,6,21774 +old,18.195,0.008091,0.006068,3774824,26372,33,32289,clean,1,4,0,0 +old,19.721,0.007307,0.006263,3774840,26352,33,32289,clean,1,5,0,0 +new,28.867,0.008446,0.009653,3909536,28040,33,32289,clean,1,5,6,21774 +old,7.67,0.004314,0.003236,2673232,22960,33,32289,unchanged,1,1,0,0 +new,7.323,0.003083,0.00411,2676880,24888,33,32289,unchanged,1,1,6,21774 +new,7.52,0.00368,0.00368,2676880,24872,33,32289,unchanged,1,2,6,21774 +old,7.58,0.004662,0.002797,2673232,22972,33,32289,unchanged,1,2,0,0 +old,7.771,0.003819,0.003819,2673232,22972,33,32289,unchanged,1,3,0,0 +new,7.515,0.005263,0.002105,2676880,24872,33,32289,unchanged,1,3,6,21774 +new,7.386,0.00545,0.001816,2676880,24948,33,32289,unchanged,1,4,6,21774 +old,7.41,0.004153,0.003114,2673232,22956,33,32289,unchanged,1,4,0,0 +old,7.549,0.002781,0.004636,2673248,22968,33,32289,unchanged,1,5,0,0 +new,7.379,0.004138,0.003103,2676880,24680,33,32289,unchanged,1,5,6,21774 +old,19.264,0.006139,0.004911,2760112,25524,33,32289,restart-edit,1,1,0,0 +new,24.345,0.005171,0.008274,2764056,27004,33,32289,restart-edit,1,1,6,21774 +new,25.808,0.011508,0.00177,2764056,26880,33,32289,restart-edit,1,2,6,21774 +old,20.713,0.004355,0.006968,2760112,25396,33,32289,restart-edit,1,2,0,0 +old,18.79,0.006675,0.00445,2760128,25396,33,32289,restart-edit,1,3,0,0 +new,25.94,0.006642,0.006642,2764056,26624,33,32289,restart-edit,1,3,6,21774 +new,25.681,0.008228,0.005485,2764056,26840,33,32289,restart-edit,1,4,6,21774 +old,20.732,0.008802,0.002934,2760112,25524,33,32289,restart-edit,1,4,0,0 +old,18.707,0.004234,0.007409,2760112,25396,33,32289,restart-edit,1,5,0,0 +new,26.091,0.008095,0.005059,2764056,27072,33,32289,restart-edit,1,5,6,21774 diff --git a/rewatch-ocaml/bench/checkpoint-5-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-5-2026-09-30.md new file mode 100644 index 00000000000..e6b978a25fc --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-5-2026-09-30.md @@ -0,0 +1,53 @@ +# Versioned GenType dependency summaries: 2026-09-30 + +Compared checkpoint 4 (`d820f2242`) with checkpoint 5 on Linux aarch64, 12 +logical CPUs, the Dune default development profile, and one compiler domain. +Both OCaml Rewatch executables were in the same directory. Their SHA-256 values +were `d9696e1dea3e831cf23f7a2fb0d5ac8c15a854489bb367f90f38c428695982ed` +and `d1354dbf27c56f12ff9a87924e7cc5301b9f723a6ca33bf8aac13ca8becfea01`. +The standalone compiler and runtime were identical in both runs. + +The five-run interleaved testrepo gate passed. Clean medians were 3,208/3,157 +ms before/after, with sampled peak process-tree RSS of 190,316/195,412 KiB. +Unchanged medians were 266/241 ms and edit medians were 219/250 ms. Compiler +request counts matched exactly: 1,031 clean, 4 unchanged, and 6 edit. Complete +post-build file sets and artifact bytes matched. This fixture has no GenType +package, so this gate checks that other packages remain unchanged. + +The [raw GenType samples](checkpoint-5-2026-09-30.csv) use five interleaved +runs per annotation setting and scenario. Each sample starts with a fresh copy +of the three-module recursive-import fixture. `unchanged` and `restart-edit` +start from a completed preparation build in a separate process. The monotonic +clock measures wall time, `wait4` measures CPU and peak RSS, and the embedded +runtime reports allocation. The two executables use the same fixture path. + +| `REWATCH_BIN_ANNOT` | Scenario | Old/new wall ms | Old/new allocation MB | Old/new RSS MiB | +| --- | --- | ---: | ---: | ---: | +| unset | clean | 18.8/30.4 | 3.77/3.91 | 26.6/27.9 | +| unset | unchanged | 7.0/7.2 | 2.67/2.68 | 23.3/25.0 | +| unset | restart edit | 19.9/24.8 | 2.76/2.76 | 24.9/26.5 | +| `0` | clean | 18.8/33.6 | 3.77/3.91 | 25.8/27.1 | +| `0` | unchanged | 7.6/7.7 | 2.67/2.68 | 22.4/24.1 | +| `0` | restart edit | 18.9/24.2 | 2.76/2.76 | 24.9/26.3 | +| `1` | clean | 19.1/30.3 | 3.77/3.91 | 25.8/27.4 | +| `1` | unchanged | 7.6/7.4 | 2.67/2.68 | 22.4/24.3 | +| `1` | restart edit | 19.3/25.8 | 2.76/2.76 | 24.8/26.2 | + +Each new clean build writes three summaries in the working tree and three +published copies, totaling 21,774 bytes. This preparatory checkpoint adds +repeatable latency to clean and restarted GenType builds on the small fixture. +Checkpoint 6 will remove the forced CMT/CMTI work, which is the intended +payoff; this checkpoint should not be described as a standalone speedup. + +The parity runner compared three TypeScript files on clean, edit, and restart +builds for annotations unset, `0`, and `1`: all nine comparisons matched byte +for byte. The new compiler used validated summaries for recursive imports, +without falling back to dependency CMT reads. A separate fixed-path comparison +matched all 41 legacy generated artifacts byte for byte in each annotation +mode; the six summaries are the only new artifacts. Removing dependency +summaries forced the legacy CMT reader and preserved TypeScript output. +The focused validation test rejects changed source, CMI dependency, compiler +identity, GenType configuration, and damaged summary headers. The OCaml +Rewatch port integration suite checks summary publication, restart reuse, +fallback, and stale cleanup. `make test-all`, focused OUnit (108 tests), the +port integration suite, and `make checkformat` passed. diff --git a/rewatch-ocaml/bench/checkpoint-6-2026-09-30.csv b/rewatch-ocaml/bench/checkpoint-6-2026-09-30.csv new file mode 100644 index 00000000000..3048b80c2c8 --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-6-2026-09-30.csv @@ -0,0 +1,31 @@ +revision,elapsed_ms,user_s,system_s,allocated_bytes,peak_rss_kib,artifact_files,artifact_bytes,scenario,annotation,iteration +old,30.612,0.008526,0.010421,3236360,25512,43,43321,gentype,unset,1 +new,30.715,0.00768,0.012069,2971584,28068,32,9778,gentype,unset,1 +new,30.253,0.008954,0.008954,2971584,27968,32,9778,gentype,unset,2 +old,31.956,0.007908,0.011297,3236376,25656,43,43321,gentype,unset,2 +old,29.41,0.011639,0.006983,3236376,25656,43,43321,gentype,unset,3 +new,29.465,0.013309,0.005119,2971600,27920,32,9778,gentype,unset,3 +new,29.074,0.011197,0.007125,2971584,27668,32,9778,gentype,unset,4 +old,28.667,0.008009,0.010297,3236376,25528,43,43321,gentype,unset,4 +old,30.321,0.012359,0.006179,3236360,25656,43,43321,gentype,unset,5 +new,31.585,0.01266,0.00633,2971584,27584,32,9778,gentype,unset,5 +old,31.025,0.010144,0.009016,3237120,25652,43,43321,gentype,0,1 +new,31.229,0.008106,0.010808,2972360,27960,32,9778,gentype,0,1 +new,30.33,0.010037,0.008029,2972344,28352,32,9778,gentype,0,2 +old,29.84,0.011882,0.007129,3237136,25528,43,43321,gentype,0,2 +old,30.014,0.011261,0.007796,3237120,25784,43,43321,gentype,0,3 +new,31.796,0.008173,0.011443,2972344,27720,32,9778,gentype,0,3 +new,30.16,0.005304,0.012731,2972344,27520,32,9778,gentype,0,4 +old,30.342,0.010584,0.009408,3237136,25784,43,43321,gentype,0,4 +old,29.734,0.011765,0.006863,3237120,25656,43,43321,gentype,0,5 +new,29.896,0.00927,0.00927,2972344,27696,32,9778,gentype,0,5 +old,30.862,0.009826,0.01072,3303328,26900,46,50763,gentype,1,1 +new,29.809,0.010112,0.008273,3303344,28256,46,50763,gentype,1,1 +new,29.406,0.011408,0.007605,3303328,27668,46,50763,gentype,1,2 +old,30.277,0.009645,0.011398,3303328,25784,46,50763,gentype,1,2 +old,30.166,0.010324,0.009034,3303328,25784,46,50763,gentype,1,3 +new,29.526,0.010641,0.008513,3303360,27260,46,50763,gentype,1,3 +new,30.161,0.011605,0.007385,3303328,27404,46,50763,gentype,1,4 +old,31.294,0.012554,0.008691,3303328,25528,46,50763,gentype,1,4 +old,31.981,0.013861,0.006064,3303328,25784,46,50763,gentype,1,5 +new,31.595,0.009526,0.01299,3303328,27448,46,50763,gentype,1,5 diff --git a/rewatch-ocaml/bench/checkpoint-6-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-6-2026-09-30.md new file mode 100644 index 00000000000..95c6c974211 --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-6-2026-09-30.md @@ -0,0 +1,61 @@ +# Editor-only binary annotations: 2026-09-30 + +Compared checkpoint 5 (`c1015c37b`) with checkpoint 6 on Linux aarch64, 12 +logical CPUs, the Dune default development profile, and one compiler domain. +Both OCaml Rewatch executables were in the same directory. Their SHA-256 values +were `d1354dbf27c56f12ff9a87924e7cc5301b9f723a6ca33bf8aac13ca8becfea01` +and `5ab862d426507bef0fe98ccedc8a0da3424e494f036073babf9ebc51af21ce6d`. +The standalone compiler and runtime were identical in both runs. + +The five-run interleaved testrepo gate passed. Clean medians were 3,175/3,119 +ms before/after, with sampled peak process-tree RSS of 188,844/194,664 KiB. +Unchanged medians were 226/230 ms and edit medians were 233/246 ms. Compiler +request counts matched exactly: 1,031 clean, 4 unchanged, and 6 edit. Complete +post-build file sets and artifact bytes matched. This fixture has no GenType +package, so it also checks that disabling editor collection preserves ordinary +build output. + +The [interface fixture samples](checkpoint-6-2026-09-30.csv) and [recursive +import samples](checkpoint-6-recursive-2026-09-30.csv) each use five interleaved +runs per annotation setting. The old and new executables use the same fixture +path. The monotonic clock measures wall time, `wait4` measures CPU and peak +RSS, and the embedded runtime reports allocation. The recursive fixture +prepares unchanged and restarted edit builds in a separate process. + +| Fixture | `REWATCH_BIN_ANNOT` | Old/new clean wall ms | Old/new CPU ms | Old/new allocation MB | Old/new RSS MiB | +| --- | --- | ---: | ---: | ---: | ---: | +| Interface | unset | 30.3/30.3 | 18.6/18.4 | 3.24/2.97 | 25.1/27.3 | +| Interface | `0` | 30.0/30.3 | 19.1/18.5 | 3.24/2.97 | 25.1/27.1 | +| Interface | `1` | 30.9/29.8 | 20.5/19.0 | 3.30/3.30 | 25.2/26.8 | +| Recursive | unset | 31.2/30.9 | 20.3/19.3 | 3.91/3.18 | 25.8/27.4 | +| Recursive | `0` | 30.0/29.4 | 19.0/18.5 | 3.91/3.18 | 25.9/27.2 | +| Recursive | `1` | 30.5/30.2 | 19.6/18.5 | 3.91/3.91 | 25.8/27.3 | + +For the recursive fixture with annotations unset, unchanged medians were +7.8/8.2 ms and restarted edit medians were 23.8/24.4 ms. The `0` and `1` +samples showed similar small differences; see the raw CSV. When annotations +are disabled, measured allocation falls 8% on the interface fixture and 19% +on the recursive fixture. Clean wall time is approximately level. The small +fixtures show higher process RSS in the new executable, including with +annotations enabled; those samples do not establish a memory improvement. + +The recursive fixture's ordinary generated files (excluding `.gts` summaries) +fell from 33 files and 32,769 bytes to 24 files and 7,753 bytes when annotations +were unset. Both versions wrote six summary copies; including them, generated +bytes fell from 54,783 to 30,667. With `REWATCH_BIN_ANNOT=1`, the ordinary +artifact file count and bytes matched exactly across versions. + +The recursive-import parity runner matched three TypeScript files on clean, +edit, and restart builds in all three annotation modes. The interface parity +runner matched five TypeScript/JavaScript files in those nine scenarios and +matched diagnostics from a type error in each mode. With annotations enabled, +all 28 editor artifacts, including CMT/CMTI, matched byte for byte. The OCaml +Rewatch port integration suite checked an `0 → 1 → 0` setting change, absent +CMT/CMTI and source copies in disabled mode, interface-summary reuse, legacy +CMT fallback when enabled, and stale cleanup. A focused test checked complete +and partial CMT preservation when enabled and no CMT on GenType type errors +when disabled. `make test-all`, focused OUnit (109 tests), the port suite, and +`make checkformat` passed. + +The optional browser playground build was unavailable in this environment: +`js_of_ocaml` and its compiler are not installed. diff --git a/rewatch-ocaml/bench/checkpoint-6-recursive-2026-09-30.csv b/rewatch-ocaml/bench/checkpoint-6-recursive-2026-09-30.csv new file mode 100644 index 00000000000..32a52c301b2 --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-6-recursive-2026-09-30.csv @@ -0,0 +1,91 @@ +revision,elapsed_ms,user_s,system_s,allocated_bytes,peak_rss_kib,artifact_files,artifact_bytes,scenario,annotation,iteration,summary_files,summary_bytes +old,33.299,0.011633,0.009694,3911800,28444,33,32769,clean,unset,1,6,22014 +new,37.416,0.009429,0.012572,3177184,29856,24,7753,clean,unset,1,6,22914 +new,29.422,0.012987,0.005903,3176888,28876,24,7753,clean,unset,2,6,22914 +old,32.865,0.013331,0.00857,3911784,26424,33,32769,clean,unset,2,6,22014 +old,30.36,0.010143,0.010143,3911784,26460,33,32769,clean,unset,3,6,22014 +new,30.457,0.011593,0.007729,3176888,27952,24,7753,clean,unset,3,6,22914 +new,30.932,0.010954,0.008216,3176888,27888,24,7753,clean,unset,4,6,22914 +old,29.462,0.012864,0.007351,3911784,26424,33,32769,clean,unset,4,6,22014 +old,31.184,0.012897,0.006448,3911784,26408,33,32769,clean,unset,5,6,22014 +new,35.005,0.016339,0.004299,3177184,28048,24,7753,clean,unset,5,6,22914 +old,7.482,0.004595,0.002757,2678088,22888,33,32769,unchanged,unset,1,6,22014 +new,8.514,0.005592,0.002796,2669632,24588,24,7753,unchanged,unset,1,6,22914 +new,8.241,0.006063,0.002021,2669616,24872,24,7753,unchanged,unset,2,6,22914 +old,7.747,0.004341,0.003255,2678088,22888,33,32769,unchanged,unset,2,6,22014 +old,7.823,0.005766,0.001922,2678088,22888,33,32769,unchanged,unset,3,6,22014 +new,8.417,0.005158,0.003095,2669616,24988,24,7753,unchanged,unset,3,6,22914 +new,7.586,0.004256,0.003192,2669616,24688,24,7753,unchanged,unset,4,6,22914 +old,8.075,0.003948,0.003948,2678088,22872,33,32769,unchanged,unset,4,6,22014 +old,8.079,0.004939,0.002963,2678088,22888,33,32769,unchanged,unset,5,6,22014 +new,7.578,0.00464,0.002784,2669616,24980,24,7753,unchanged,unset,5,6,22914 +old,23.848,0.008922,0.004956,2765392,25576,33,32769,restart-edit,unset,1,6,22014 +new,24.365,0.006062,0.008083,2690728,27020,24,7753,restart-edit,unset,1,6,22914 +new,24.054,0.005215,0.008344,2690728,27040,24,7753,restart-edit,unset,2,6,22914 +old,23.812,0.011609,0.002321,2765392,25448,33,32769,restart-edit,unset,2,6,22014 +old,23.804,0.010257,0.003729,2765392,25448,33,32769,restart-edit,unset,3,6,22014 +new,24.906,0.009815,0.004362,2690728,27232,24,7753,restart-edit,unset,3,6,22914 +new,23.898,0.0051,0.0102,2690728,27180,24,7753,restart-edit,unset,4,6,22914 +old,24.826,0.009342,0.004671,2765392,25576,33,32769,restart-edit,unset,4,6,22014 +old,24.233,0.006355,0.008473,2765392,25448,33,32769,restart-edit,unset,5,6,22014 +new,24.593,0.008945,0.004879,2690728,27032,24,7753,restart-edit,unset,5,6,22914 +old,36.34,0.011304,0.010277,3912448,26424,33,32769,clean,0,1,6,22014 +new,29.046,0.011254,0.007162,3177520,27692,24,7753,clean,0,1,6,22914 +new,29.177,0.012646,0.005836,3177520,27824,24,7753,clean,0,2,6,22914 +old,30.089,0.009981,0.008983,3912352,26424,33,32769,clean,0,2,6,22014 +old,29.98,0.009525,0.010716,3912352,26544,33,32769,clean,0,3,6,22014 +new,31.19,0.010115,0.010115,3177520,28144,24,7753,clean,0,3,6,22914 +new,30.446,0.007748,0.011623,3177536,27904,24,7753,clean,0,4,6,22914 +old,29.184,0.011642,0.006985,3912352,26552,33,32769,clean,0,4,6,22014 +old,28.52,0.011423,0.007269,3912352,26552,33,32769,clean,0,5,6,22014 +new,29.402,0.010084,0.007843,3177536,27936,24,7753,clean,0,5,6,22914 +old,7.773,0.003257,0.004343,2678456,22888,33,32769,unchanged,0,1,6,22014 +new,8.277,0.003047,0.005078,2669968,24732,24,7753,unchanged,0,1,6,22914 +new,7.263,0.004069,0.003052,2669968,24980,24,7753,unchanged,0,2,6,22914 +old,7.765,0.003812,0.003812,2678440,22888,33,32769,unchanged,0,2,6,22014 +old,7.974,0.00392,0.00392,2678440,22888,33,32769,unchanged,0,3,6,22014 +new,7.874,0.002181,0.005453,2669968,24788,24,7753,unchanged,0,3,6,22914 +new,8.224,0.004031,0.004031,2669968,24732,24,7753,unchanged,0,4,6,22914 +old,7.594,0.003726,0.003726,2678440,22888,33,32769,unchanged,0,4,6,22014 +old,7.412,0.003623,0.003623,2678440,22884,33,32769,unchanged,0,5,6,22014 +new,7.367,0.003619,0.003619,2669968,24908,24,7753,unchanged,0,5,6,22914 +old,23.79,0.009431,0.004715,2765776,25432,33,32769,restart-edit,0,1,6,22014 +new,24.531,0.006474,0.007399,2691112,27104,24,7753,restart-edit,0,1,6,22914 +new,25.181,0.007819,0.005585,2691112,27092,24,7753,restart-edit,0,2,6,22914 +old,23.759,0.00744,0.008267,2765776,25576,33,32769,restart-edit,0,2,6,22014 +old,24.314,0.006582,0.007679,2765776,25576,33,32769,restart-edit,0,3,6,22014 +new,25.406,0.004674,0.009348,2691112,26864,24,7753,restart-edit,0,3,6,22914 +new,23.728,0.009529,0.004235,2691112,27184,24,7753,restart-edit,0,4,6,22914 +old,24.628,0.009052,0.005029,2765776,25440,33,32769,restart-edit,0,4,6,22014 +old,23.913,0.008956,0.005374,2765776,25448,33,32769,restart-edit,0,5,6,22014 +new,24.381,0.009379,0.00521,2691128,27004,24,7753,restart-edit,0,5,6,22914 +old,31.026,0.010603,0.008482,3912344,26424,33,32769,clean,1,1,6,22014 +new,34.655,0.008837,0.011047,3913072,27952,33,32769,clean,1,1,6,22914 +new,34.271,0.012157,0.008683,3913072,27952,33,32769,clean,1,2,6,22914 +old,31.2,0.010877,0.009323,3912344,26552,33,32769,clean,1,2,6,22014 +old,29.296,0.010625,0.007438,3912344,26424,33,32769,clean,1,3,6,22014 +new,28.366,0.011198,0.007126,3912776,27952,33,32769,clean,1,3,6,22914 +new,30.196,0.008226,0.010282,3912776,27504,33,32769,clean,1,4,6,22914 +old,29.959,0.011462,0.008336,3912344,26424,33,32769,clean,1,4,6,22014 +old,30.474,0.009227,0.01038,3912360,26424,33,32769,clean,1,5,6,22014 +new,28.998,0.011999,0.006545,3912776,27796,33,32769,clean,1,5,6,22914 +old,7.813,0.004353,0.003265,2678440,22888,33,32769,unchanged,1,1,6,22014 +new,7.967,0.001925,0.005775,2678456,24976,33,32769,unchanged,1,1,6,22914 +new,7.99,0.003916,0.003916,2678440,24664,33,32769,unchanged,1,2,6,22914 +old,7.554,0.003706,0.003706,2678440,22872,33,32769,unchanged,1,2,6,22014 +old,7.546,0.003702,0.003702,2678440,22888,33,32769,unchanged,1,3,6,22014 +new,7.278,0.004079,0.003059,2678440,24980,33,32769,unchanged,1,3,6,22914 +new,7.413,0.003639,0.003639,2678440,24988,33,32769,unchanged,1,4,6,22914 +old,7.856,0.002888,0.004813,2678440,22888,33,32769,unchanged,1,4,6,22014 +old,7.597,0.003714,0.003714,2678440,22888,33,32769,unchanged,1,5,6,22014 +new,7.767,0.003251,0.004335,2678440,24936,33,32769,unchanged,1,5,6,22914 +old,25.155,0.009779,0.004889,2765776,25320,33,32769,restart-edit,1,1,6,22014 +new,25.035,0.008314,0.006235,2765776,27056,33,32769,restart-edit,1,1,6,22914 +new,24.183,0.009373,0.006248,2765776,26864,33,32769,restart-edit,1,2,6,22914 +old,23.385,0.009127,0.005215,2765776,25572,33,32769,restart-edit,1,2,6,22014 +old,23.604,0.008422,0.006316,2765776,25580,33,32769,restart-edit,1,3,6,22014 +new,24.481,0.008659,0.006061,2765776,26944,33,32769,restart-edit,1,3,6,22914 +new,23.941,0.00768,0.006827,2765776,26780,33,32769,restart-edit,1,4,6,22914 +old,24.56,0.009517,0.00571,2765776,25320,33,32769,restart-edit,1,4,6,22014 +old,24.349,0.008745,0.005247,2765776,25440,33,32769,restart-edit,1,5,6,22014 +new,24.019,0.00543,0.008688,2765792,26828,33,32769,restart-edit,1,5,6,22914 diff --git a/rewatch-ocaml/bench/checkpoint-7-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-7-2026-09-30.md new file mode 100644 index 00000000000..7cf42100cbf --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-7-2026-09-30.md @@ -0,0 +1,43 @@ +# Owned AST handoff: 2026-09-30 + +Compared checkpoint 6 (`e477c3426`) with checkpoint 7 on Linux aarch64, +12 logical CPUs, the Dune default development profile, and one compiler +domain. Both OCaml Rewatch executables were in the same directory. Their +SHA-256 values were `5ab862d426507bef0fe98ccedc8a0da3424e494f036073babf9ebc51af21ce6d` +and `129d2cbdafec7a6ec4a3585d137e7536b5b9db56776b2ff5afa9f148ac20e94a`. +The standalone compiler and runtime were identical in both runs. + +The five-run interleaved testrepo gate passed. Its labels `rust` and `ocaml` +mean the old and new embedded executables for this comparison. + +| Scenario | Old/new median wall ms | Old/new sampled peak tree RSS KiB | +| --- | ---: | ---: | +| Clean | 3,136 / 3,140 | 196,304 / 198,708 | +| Unchanged | 229 / 227 | 29,240 / 33,480 | +| Single edit | 245 / 262 | 29,412 / 31,196 | + +The clean wall median was level. The edit median increased 7% in this run; +the five samples overlap and do not establish a repeatable change. The clean +peak RSS median increased 1%. Unchanged and edit RSS samples were higher in +the new executable, by 14% and 6% respectively; the one-domain full-build +gate remained below its 125% memory threshold. Compiler request counts matched +exactly: 1,031 clean, 4 unchanged, and 6 edit. Complete post-build file sets +and artifact bytes matched. + +The parser now captures the AST and dependencies before writing a staging +file. A successful frozen-lookup request serializes the AST once and hands it +to the session; an export worker writes that byte image to the staging and +persistent cache paths while compilation can consume the owned AST. Source +identity and the parser request generation validate the handoff. Once the +staging file exists, its disk identity is also checked. Serialized buffers +are released after export. Classic lookup and `REWATCH_OWNED_AST=0` retain +synchronous staging writes. + +Focused tests checked exact AST byte parity with standalone `bsc`, compilation +before the staging file exists, dependency replacement on a newer parse, +source invalidation, changed disk identity, and deferred export timestamps. +The OCaml Rewatch port suite checked persistent cache reuse, restart, parse +publication failure, and retry in its existing integration scenarios. The +full `make test-all` run passed before the final buffer-retention cleanup; +the final `make test`, focused OUnit (111 tests), port suite, and +`make checkformat` passed afterward. diff --git a/rewatch-ocaml/bench/checkpoint-8-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-8-2026-09-30.md new file mode 100644 index 00000000000..122cc14cb4a --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-8-2026-09-30.md @@ -0,0 +1,65 @@ +# Owned compiler artifacts: 2026-09-30 + +Compared checkpoint 7 (`71e77b46b`) with checkpoint 8 on Linux aarch64, +12 logical CPUs, the Dune default development profile, and one compiler +domain. Both OCaml Rewatch executables were in the same directory. Their +SHA-256 values for the five-run measurement were +`129d2cbdafec7a6ec4a3585d137e7536b5b9db56776b2ff5afa9f148ac20e94a` +and `f23bc1d8b31e37c580a9e5f58964c07294efdf51bfab8c8e296940affc63f837`. +The standalone compiler and runtime were identical in both runs. + +The five-run interleaved testrepo gate passed with annotations unset and with +`REWATCH_BIN_ANNOT=1`. Its `rust` and `ocaml` labels mean the old and new +embedded executables in this comparison. + +| Annotation mode | Scenario | Old/new median wall ms | Old/new sampled peak tree RSS KiB | +| --- | --- | ---: | ---: | +| Unset | Clean | 3,155 / 3,228 | 197,892 / 208,852 | +| Unset | Unchanged | 227 / 234 | 29,316 / 31,152 | +| Unset | Single edit | 239 / 260 | 29,480 / 31,156 | +| `1` | Clean | 4,700 / 4,720 | 253,916 / 259,152 | +| `1` | Unchanged | 280 / 265 | 29,780 / 31,528 | +| `1` | Single edit | 216 / 282 | 33,072 / 33,464 | + +Compiler request counts matched exactly in each mode: 1,031 clean, 4 +unchanged, and 6 edit. Complete post-build file sets and artifact bytes +matched. Clean medians were close, while sampled peak RSS rose 6% without +annotations and 2% with them. Edit medians were higher in the new executable, +especially with annotations, although the five old and new samples overlap. +This checkpoint does not establish a repeatable speedup; edit latency needs +continued measurement during the later promotion gate. + +The compiler serializes changed CMI and CMJ results once into owned byte +images. When annotations are enabled, complete CMT/CMTI results use the same +handoff; partial annotations continue to be written during failed requests. +The publisher checks the source identity and request generation, writes the +staging artifacts, and hands the existing frozen dependency values to the +session. Later export copies the exact staged bytes to the persistent cache. +The retained byte images have a 32 MiB session budget, with immediate disk +persistence when it fills. Editor staging and published files use atomic +replacement. Existing disk readers remain the fallback after session eviction +or restart, and environment switches can disable each owned artifact type. +When a source changes before the owned AST reaches disk, the driver also writes +the captured AST for the disk reader while the watcher schedules a fresh parse. + +Focused tests checked CMI/CMJ and CMT/CMTI byte parity with standalone +compilation, dependent access after persistence, partial CMT on a type error, +stale-source rejection, atomic editor copy failure recovery, file permissions, +and the AST source-change window. The GenType interface parity runner matched five generated +TypeScript/JavaScript files and error diagnostics in clean, edit, and restart +builds for annotation modes unset, `0`, and `1`; all 28 enabled editor files +matched byte for byte. The recursive summary runner matched three TypeScript +files in each mode and scenario. `make test-all` passed before the final AST +source-change fallback; afterward, `make test`, focused OUnit (114 tests), +two OCaml Rewatch port suite runs, and `make checkformat` passed. One earlier +port run hit a missing AST during a symlink target replacement, which prompted +the fallback and its regression test. + +The final binary SHA-256 is +`b9f02cbe3bae147c8de85137329e25e2227987996374f2ad152f7a2130b6a4b7`. +One-run correctness comparisons on that binary passed in both annotation modes +with equal compiler work, complete file sets, and byte-identical artifacts. +Those one-run results are smoke checks, not the five-run performance measurement. + +Next: checkpoint 9, measure imported-type graph copying and migrate immutable +values in validated stages. diff --git a/rewatch-ocaml/bench/checkpoint-9-2026-09-30.md b/rewatch-ocaml/bench/checkpoint-9-2026-09-30.md new file mode 100644 index 00000000000..f95dfc0322d --- /dev/null +++ b/rewatch-ocaml/bench/checkpoint-9-2026-09-30.md @@ -0,0 +1,125 @@ +# Checkpoint 9: imported type graphs + +Status: validated for opt-in frozen lookup. The frozen lookup policy remains +opt-in until GenType parity and final promotion. + +The final gate used Linux 7.0.12-linuxkit on aarch64, `/tmp` on overlayfs, +the Dune `dev` profile, one compiler domain, and five interleaved runs. The +Rewatch executable SHA-256 was +`b0fadd657b50fbe218dc785ea570c0dbb916da17f173c3aee1923420ef7b09a3`; +the standalone compiler SHA-256 was +`04a3c758e119ceaab33ac4eb24935807ea7e771812bcfc970f5e106403f2ea41`. + +## Cost model + +The 25,571-byte `Api.cmi` from the values fixture has 403 type roots and 403 +type nodes. The type-graph microprobe ran 1,000 iterations on Linux/aarch64: + +| Operation | Worker time | Allocated | +| --- | ---: | ---: | +| Freeze all roots | 51.2 ms | 147.5 MB | +| Thaw all roots | 46.2 ms | 97.3 MB | +| Thaw one root | 1.3 ms | 4.0 MB | +| Decode full CMI | 116.8 ms | 142.9 MB | +| Copy full signature with `Subst.signature` | 57.3 ms | 196.7 MB | + +The frozen index already materializes values, types, constructors, and record +labels by name. Its view owns all mutable type nodes, layout refs, descriptors, +and member IDs, while the captured image holds immutable data. The trace shows +200 frozen value lookups in 0.28 ms with 0.38 MB allocated on the values fixture; +the analogous constructor lookups took 0.85 ms and 1.15 MB on the variants +fixture. Full signature copying occurred once per build where the implementation +was checked against a separate interface, costing 0.15–0.94 ms and +0.34–0.59 MB across these fixtures. The remaining full-signature path serves +operations that require the complete ordered signature, including inclusion. + +## Module declarations and paths + +Simple module aliases and module-type identifiers now use frozen path records +and direct binder-context mapping in both module and module-type declarations. +Abstract module types materialize directly. Simple declarations no longer +retain a duplicate serialized full declaration. Path-only lookups leave the +request-local type graph unmaterialized; value, type, and constructor lookups +force it when needed. OUnit checks attributes, alias presence, cached identity, +independent views, lazy graph creation, nested module-type paths, and distinct +binder contexts when a module type is instantiated twice. + +Explicit traces distinguish the remaining compatibility paths. In a traced +one-run build, complete signature copying was invoked once for the explicit +interface, taking 0.26 ms and allocating 0.34 MB. Complex functor declarations +were materialized 200 times in each module fixture, taking 0.67 ms/1.20 MB +without an interface and 0.43 ms/1.12 MB with one. No fixture invoked legacy +generic component expansion of a frozen root signature. Full-signature +inclusion needs an ordered, mutable signature with freshly renamed binders; +complex functor types need nested binder substitution. These two paths remain +request-local. Their measured total is below 1 ms per build in the fixtures, +so replacing them with another complete-structure materializer has no +demonstrated benefit. The direct frozen path handles common name-based lookups. + +## End-to-end comparison + +`immutable_interface_gate.py` generated six 201-module fixtures and alternated +classic and frozen one-domain clean builds five times. It checked complete +generated-file sets and SHA-256 hashes after every pair. All pairs matched. +These medians are from the final isolated run after the lazy view change; +elapsed time includes process startup and build-system work. + +| Fixture | Classic wall | Frozen wall | Classic CPU | Frozen CPU | Classic RSS | Frozen RSS | +| --- | ---: | ---: | ---: | ---: | ---: | ---: | +| Values | 234.8 ms | 171.2 ms | 243.6 ms | 189.0 ms | 33,988 KiB | 35,516 KiB | +| Types | 299.0 ms | 168.2 ms | 318.9 ms | 186.3 ms | 33,616 KiB | 33,828 KiB | +| Variants | 314.8 ms | 177.6 ms | 337.2 ms | 191.4 ms | 33,792 KiB | 36,716 KiB | +| Modules | 254.1 ms | 175.8 ms | 261.5 ms | 194.4 ms | 33,056 KiB | 34,900 KiB | +| Open | 262.2 ms | 182.6 ms | 271.4 ms | 196.9 ms | 33,052 KiB | 34,528 KiB | +| Inclusion | 253.4 ms | 183.3 ms | 259.6 ms | 201.8 ms | 33,072 KiB | 34,792 KiB | + +The new module paths showed no robust incremental wall-time gain beyond the +existing frozen index. The opt-in frozen path stayed faster than classic across +all fixtures, while sampled peak RSS varied by fixture and was higher for +several frozen fixtures. The full signature and complex module fallbacks remain +for a later validated change. + +The inclusion fixture has an explicit interface, an abstract module type, +module aliases, a functor, and 200 dependent modules. An implementation edit +produced identical compiler work and artifact bytes under both policies, and +the restart build did not change those artifacts. Changing one interface +declaration to create an inclusion error produced identical diagnostics and +failed under both policies. + +## Editor annotation parity + +With `REWATCH_BIN_ANNOT=1`, the five-run gate again passed all six fixtures. +It compared generated non-annotation bytes, typedtree text, value-dependency +types and locations, and other CMT metadata across policies. It also checked +raw CMT/CMTI byte stability over five clean builds within each policy. Raw +annotation bytes differed across policies because frozen lookup avoided eager +type-node creation: for example, the first `Api.cmt` value type had internal +ID 267 in classic lookup and 44 in frozen lookup. The binding stamps, printed +typedtree, and editor results matched. Hover, references, completion, and +incomplete-source completion returned byte-identical responses in the values +fixture. The inclusion edit, restart, and mismatch diagnostic checks also +passed with annotations enabled. + +| Fixture | Classic wall | Frozen wall | Classic RSS | Frozen RSS | +| --- | ---: | ---: | ---: | ---: | +| Values | 311.2 ms | 233.3 ms | 36,488 KiB | 37,060 KiB | +| Types | 350.6 ms | 250.2 ms | 37,828 KiB | 36,704 KiB | +| Variants | 360.7 ms | 238.8 ms | 38,032 KiB | 38,672 KiB | +| Modules | 322.6 ms | 247.1 ms | 35,552 KiB | 37,644 KiB | +| Open | 321.2 ms | 244.3 ms | 37,456 KiB | 37,944 KiB | +| Inclusion | 351.5 ms | 264.8 ms | 37,996 KiB | 38,560 KiB | + +The annotation run used Rewatch SHA-256 +`06d1dcfe17c420da64ff314b643a91e8051c625bf3dbbda076a512b1c022acb7` +and standalone compiler SHA-256 +`7bf33f9bb0e131c0dbbb87ec3a0ea11e4b8af3645aef7094a0350f09e9ccec1f`. + +Final `make test` (including 345 OUnit cases), the OCaml Rewatch port suite, +`make test-analysis`, and `make checkformat` passed. One earlier port run +stopped at a CMJ change assertion; the same two-step build changed the CMJ +when isolated. The complete suite passed on rerun. A later benchmark attempt +ran out of space in +`/tmp` after four fixtures; generated benchmark projects were removed and the +full six-fixture gate passed on rerun. + +Next: checkpoint 10, GenType parity with frozen lookup. diff --git a/rewatch-ocaml/bench/cmt_compare.ml b/rewatch-ocaml/bench/cmt_compare.ml new file mode 100644 index 00000000000..982cc4564ca --- /dev/null +++ b/rewatch-ocaml/bench/cmt_compare.ml @@ -0,0 +1,219 @@ +let summary value = + try + let bytes = Marshal.to_string value [] in + Printf.sprintf "%d %s" (String.length bytes) + (Digest.to_hex (Digest.string bytes)) + with Invalid_argument reason -> "unmarshalable: " ^ reason + +let compare_field label first second = + let first = summary first in + let second = summary second in + if first <> second then Printf.printf "%s\t%s\t%s\n" label first second + +let annotation_text = function + | Cmt_format.Interface signature -> + Format.asprintf "%a" Printtyped.interface signature + | Cmt_format.Implementation structure -> + Format.asprintf "%a" Printtyped.implementation structure + | Cmt_format.Packed _ | Cmt_format.Partial_implementation _ + | Cmt_format.Partial_interface _ -> + "unsupported annotation kind" + +let type_text typ = + Printtyp.reset_and_mark_loops typ; + Format.asprintf "%a" Printtyp.type_sch typ + +let value_description_equal first second = + summary first.Types.val_kind = summary second.Types.val_kind + && summary first.val_loc = summary second.val_loc + && summary first.val_attributes = summary second.val_attributes + && type_text first.val_type = type_text second.val_type + +let value_dependencies_equal first second = + List.length first = List.length second + && List.for_all2 + (fun (first_from, first_to) (second_from, second_to) -> + value_description_equal first_from second_from + && value_description_equal first_to second_to) + first second + +let report_value_dependency_differences first second = + Printf.printf "value dependencies semantically equal: %b\n" + (value_dependencies_equal first second); + List.iteri + (fun index ((first_from, first_to), (second_from, second_to)) -> + if + not + (value_description_equal first_from second_from + && value_description_equal first_to second_to) + then + Printf.printf "value dependency %d: %s -> %s | %s -> %s\n" index + (type_text first_from.val_type) + (type_text first_to.val_type) + (type_text second_from.val_type) + (type_text second_to.val_type)) + (List.combine first second) + +let report_text_difference first second = + let rec first_difference index first second = + match (first, second) with + | left :: left_tail, right :: right_tail when left = right -> + first_difference (index + 1) left_tail right_tail + | left :: _, right :: _ -> + Printf.printf + "printed first difference at line %d\nclassic: %s\nfrozen: %s\n" index + left right + | [], [] -> () + | [], _ | _, [] -> + Printf.printf "printed annotations have different lengths\n" + in + first_difference 1 + (String.split_on_char '\n' first) + (String.split_on_char '\n' second) + +let report_item_differences label first second summarize = + let differences = + List.combine first second + |> List.mapi (fun index (left, right) -> + if summary (summarize left) = summary (summarize right) then None + else Some index) + |> List.filter_map Fun.id + in + match differences with + | [] -> () + | _ -> + Printf.printf "%s: %d differing items; first: %s\n" label + (List.length differences) + (String.concat ", " + (List.map string_of_int + (List.filteri (fun index _ -> index < 5) differences))) + +let compare_annotations first second = + match (first, second) with + | Cmt_format.Interface first, Cmt_format.Interface second -> + compare_field "sig_type" first.sig_type second.sig_type; + compare_field "sig_final_env" first.sig_final_env second.sig_final_env; + report_item_differences "sig_desc" first.sig_items second.sig_items + (fun item -> item.sig_desc); + report_item_differences "sig_env" first.sig_items second.sig_items + (fun item -> item.sig_env); + let describe = function + | Types.Sig_value (id, value) -> + Printf.sprintf "value %s stamp=%d type_id=%d" id.Ident.name + id.Ident.stamp value.val_type.id + | Types.Sig_type (id, _, _) -> + Printf.sprintf "type %s stamp=%d" id.Ident.name id.Ident.stamp + | Types.Sig_module (id, _, _) -> + Printf.sprintf "module %s stamp=%d" id.Ident.name id.Ident.stamp + | Types.Sig_modtype (id, _) -> + Printf.sprintf "modtype %s stamp=%d" id.Ident.name id.Ident.stamp + | Types.Sig_typext (id, _, _) -> + Printf.sprintf "extension %s stamp=%d" id.Ident.name id.Ident.stamp + in + List.iteri + (fun index (left, right) -> + if index < 3 then + Printf.printf "sig_type[%d]\t%s\t%s\n" index (describe left) + (describe right)) + (List.combine first.sig_type second.sig_type) + | Cmt_format.Implementation first, Cmt_format.Implementation second -> ( + compare_field "str_type" first.str_type second.str_type; + compare_field "str_final_env" first.str_final_env second.str_final_env; + report_item_differences "str_desc" first.str_items second.str_items + (fun item -> item.str_desc); + report_item_differences "str_env" first.str_items second.str_items + (fun item -> item.str_env); + match (first.str_type, second.str_type) with + | ( Types.Sig_value (left_id, left) :: _, + Types.Sig_value (right_id, right) :: _ ) -> + Printf.printf "first str_type value\t%s/%d type=%d\t%s/%d type=%d\n" + left_id.Ident.name left_id.Ident.stamp left.val_type.id + right_id.Ident.name right_id.Ident.stamp right.val_type.id + | _ -> ()) + | _ -> () + +let semantic_equal first second = + let same left right = summary left = summary right in + let supported = + match (first.Cmt_format.cmt_annots, second.Cmt_format.cmt_annots) with + | Cmt_format.Interface _, Cmt_format.Interface _ + | Cmt_format.Implementation _, Cmt_format.Implementation _ -> + true + | _ -> false + in + supported + && annotation_text first.cmt_annots = annotation_text second.cmt_annots + && same first.cmt_modname second.cmt_modname + && value_dependencies_equal first.cmt_value_dependencies + second.cmt_value_dependencies + && same first.cmt_comments second.cmt_comments + && same first.cmt_args second.cmt_args + && same first.cmt_sourcefile second.cmt_sourcefile + && same first.cmt_builddir second.cmt_builddir + && same first.cmt_loadpath second.cmt_loadpath + && same first.cmt_source_digest second.cmt_source_digest + && same first.cmt_initial_env second.cmt_initial_env + && same first.cmt_imports second.cmt_imports + && same first.cmt_interface_digest second.cmt_interface_digest + && same first.cmt_use_summaries second.cmt_use_summaries + && same first.cmt_extra_info second.cmt_extra_info + +let () = + if Array.length Sys.argv = 5 && Sys.argv.(1) = "--semantic-tree" then ( + let first_root = Sys.argv.(2) in + let second_root = Sys.argv.(3) in + let paths = open_in Sys.argv.(4) in + Fun.protect + (fun () -> + try + while true do + let path = input_line paths in + let first = Cmt_format.read_cmt (Filename.concat first_root path) in + let second = + Cmt_format.read_cmt (Filename.concat second_root path) + in + if not (semantic_equal first second) then ( + Printf.eprintf "annotation semantics differ: %s\n" path; + exit 1) + done + with End_of_file -> ()) + ~finally:(fun () -> close_in paths); + exit 0); + let semantic, first_path, second_path = + match Array.to_list Sys.argv with + | [_; first; second] -> (false, first, second) + | [_; "--semantic"; first; second] -> (true, first, second) + | _ -> + prerr_endline "Usage: cmt_compare [--semantic] FIRST.cmt SECOND.cmt"; + exit 2 + in + let first = Cmt_format.read_cmt first_path in + let second = Cmt_format.read_cmt second_path in + if semantic then ( + if not (semantic_equal first second) then ( + Printf.eprintf "annotation semantics differ: %s %s\n" first_path + second_path; + exit 1); + exit 0); + compare_field "modname" first.cmt_modname second.cmt_modname; + compare_field "annots" first.cmt_annots second.cmt_annots; + compare_annotations first.cmt_annots second.cmt_annots; + report_text_difference + (annotation_text first.cmt_annots) + (annotation_text second.cmt_annots); + compare_field "value_dependencies" first.cmt_value_dependencies + second.cmt_value_dependencies; + report_value_dependency_differences first.cmt_value_dependencies + second.cmt_value_dependencies; + compare_field "comments" first.cmt_comments second.cmt_comments; + compare_field "args" first.cmt_args second.cmt_args; + compare_field "sourcefile" first.cmt_sourcefile second.cmt_sourcefile; + compare_field "builddir" first.cmt_builddir second.cmt_builddir; + compare_field "loadpath" first.cmt_loadpath second.cmt_loadpath; + compare_field "source_digest" first.cmt_source_digest second.cmt_source_digest; + compare_field "initial_env" first.cmt_initial_env second.cmt_initial_env; + compare_field "imports" first.cmt_imports second.cmt_imports; + compare_field "interface_digest" first.cmt_interface_digest + second.cmt_interface_digest; + compare_field "use_summaries" first.cmt_use_summaries second.cmt_use_summaries; + compare_field "extra_info" first.cmt_extra_info second.cmt_extra_info diff --git a/rewatch-ocaml/bench/dune b/rewatch-ocaml/bench/dune new file mode 100644 index 00000000000..8a45fe40555 --- /dev/null +++ b/rewatch-ocaml/bench/dune @@ -0,0 +1,7 @@ +(executable + (name frozen_type_graph_probe) + (libraries ml unix)) + +(executable + (name cmt_compare) + (libraries ml)) diff --git a/rewatch-ocaml/bench/embedded_baseline.py b/rewatch-ocaml/bench/embedded_baseline.py new file mode 100644 index 00000000000..e720c283e00 --- /dev/null +++ b/rewatch-ocaml/bench/embedded_baseline.py @@ -0,0 +1,252 @@ +#!/usr/bin/env python3 +"""Interleaved, fixed-setting baseline for the embedded compiler. + +Run on Linux. Each sample gets a fresh project copy. Preparation for no-op and +edit builds is outside the timed command. +""" + +import argparse +import csv +import hashlib +import json +import os +from pathlib import Path +import platform +import shutil +import subprocess +import sys +import time + + +ROOT = Path(__file__).resolve().parents[2] +WORD_BYTES = (sys.maxsize.bit_length() + 1) // 8 +SCENARIOS = ( + "clean", + "noop", + "edit", + "shared-interface", + "gentype", + "ppx", + "restart", + "wide-clean", + "wide-noop", + "wide-edit", + "wide-shared-interface", +) +ANNOTATIONS = ("unset", "0", "1") + + +def digest(path): + value = hashlib.sha256() + with path.open("rb") as source: + for chunk in iter(lambda: source.read(1024 * 1024), b""): + value.update(chunk) + return value.hexdigest() + + +def fixture(scenario, destination): + if scenario.startswith("wide-"): + subprocess.run( + [ + sys.executable, + str(ROOT / "rewatch-ocaml/bench/make_immutable_interface_fixture.py"), + str(destination), + ], + check=True, + stdout=subprocess.DEVNULL, + ) + if scenario == "wide-shared-interface": + with (destination / "src/Api.res").open("a") as source: + source.write("\nlet extra = 1\n") + return + name = { + "shared-interface": "session-interface", + "gentype": "gentype", + }.get(scenario, "basic") + shutil.copytree(ROOT / "rewatch-ocaml/tests" / name, destination) + if scenario == "gentype": + modules = destination / "node_modules" + modules.mkdir() + shutil.copytree(ROOT / "rewatch-ocaml/tests/shared-dep", modules / "dep") + if scenario == "shared-interface": + with (destination / "src/Api.res").open("a") as source: + source.write("\nlet extra = 1\n") + if scenario == "ppx": + ppx = destination / "identity-ppx.sh" + ppx.write_text('#!/bin/sh\nset -eu\ncp "$1" "$2"\n') + ppx.chmod(0o755) + config = json.loads((destination / "rescript.json").read_text()) + config["ppx-flags"] = [str(ppx)] + (destination / "rescript.json").write_text(json.dumps(config) + "\n") + + +def generated_files(project, original_files): + suffixes = ( + ".ast", ".iast", ".cmi", ".cmj", ".cmt", ".cmti", + ".ts", ".js", ".mjs", ".map", + ) + paths = [ + p + for p in project.rglob("*") + if p.is_file() + and p.suffix in suffixes + and p.relative_to(project) not in original_files + ] + return len(paths), sum(p.stat().st_size for p in paths) + + +def command(executable, project, env, output, measured, original_files=frozenset()): + stdout = output.with_suffix(".stdout") + stderr = output.with_suffix(".stderr") + argv = [str(executable), "build", str(project)] + if measured: + env["REWATCH_GC_STATS_FILE"] = str(output.with_suffix(".gc.json")) + else: + env.pop("REWATCH_GC_STATS_FILE", None) + started = time.perf_counter_ns() + with stdout.open("wb") as out, stderr.open("wb") as err: + process = subprocess.Popen(argv, cwd=ROOT, env=env, stdout=out, stderr=err) + _, status, usage = os.wait4(process.pid, 0) + process.returncode = os.waitstatus_to_exitcode(status) + elapsed_ms = (time.perf_counter_ns() - started) / 1_000_000 + if process.returncode: + raise RuntimeError( + f"build failed ({process.returncode}): {stderr}\n{stderr.read_text()}" + ) + if not measured: + return None + gc = json.loads(output.with_suffix(".gc.json").read_text()) + files, artifact_bytes = generated_files(project, original_files) + return { + "elapsed_ms": round(elapsed_ms, 3), + "user_s": round(usage.ru_utime, 6), + "system_s": round(usage.ru_stime, 6), + "allocated_bytes": int(gc["allocated_words"]) * WORD_BYTES, + "peak_rss_kib": usage.ru_maxrss, + "artifact_files": files, + "artifact_bytes": artifact_bytes, + } + + +def sample(scenario, annotation, iteration, output, executable, base_env): + project = output / f"{scenario}-{ANNOTATIONS.index(annotation)}-{iteration:02d}" + fixture(scenario, project) + original_files = { + p.relative_to(project) for p in project.rglob("*") if p.is_file() + } + env = base_env.copy() + if annotation == "unset": + env.pop("REWATCH_BIN_ANNOT", None) + else: + env["REWATCH_BIN_ANNOT"] = annotation + prefix = output / f"{scenario}-{annotation}-{iteration}" + if scenario in ( + "noop", "edit", "shared-interface", "restart", + "wide-noop", "wide-edit", "wide-shared-interface", + ): + command(executable, project, env, output / f"{prefix.name}-prepare", False) + if scenario == "edit": + with (project / "src/B.res").open("a") as source: + source.write("\n// measured implementation edit\n") + elif scenario == "shared-interface": + with (project / "src/Api.resi").open("a") as source: + source.write("\nlet extra: int\n") + elif scenario == "restart": + # The preparation build exits. This measured request starts a new + # process against its persisted artifacts after a source change. + with (project / "src/B.res").open("a") as source: + source.write("\n// edit after process restart\n") + elif scenario == "wide-edit": + with (project / "src/Consumer0.res").open("a") as source: + source.write("\n// measured leaf edit\n") + elif scenario == "wide-shared-interface": + with (project / "src/Api.resi").open("a") as source: + source.write("\nlet extra: int\n") + result = command(executable, project, env, prefix, True, original_files) + result.update(scenario=scenario, annotation=annotation, iteration=iteration) + shutil.rmtree(project) + return result + + +def main(): + parser = argparse.ArgumentParser(description=__doc__) + parser.add_argument( + "output", type=Path, help="new directory for raw data and results" + ) + parser.add_argument("--runs", type=int, default=5) + parser.add_argument("--domains", type=int, default=4) + parser.add_argument( + "--executable", type=Path, + default=ROOT / "_build/default/rewatch-ocaml/rescript_ocaml.exe", + ) + parser.add_argument("--scenarios", nargs="+", choices=SCENARIOS, default=SCENARIOS) + args = parser.parse_args() + if args.runs < 3 or args.runs % 2 == 0 or args.domains < 1: + parser.error("--runs must be odd and at least 3; --domains must be positive") + output = args.output.resolve() + output.mkdir(parents=True, exist_ok=False) + executable = args.executable.resolve() + compiler = Path( + os.environ.get( + "RESCRIPT_BSC_EXE", + ROOT / "_build/default/compiler/bsc/rescript_compiler_main.exe", + ) + ).resolve() + runtime = Path( + os.environ.get("RESCRIPT_RUNTIME", ROOT / "packages/@rescript/runtime") + ).resolve() + if not hasattr(os, "wait4") or not executable.is_file() or not compiler.is_file(): + parser.error("Linux wait4, the compiler, and the executable are required") + env = os.environ.copy() + env.update( + RESCRIPT_BSC_EXE=str(compiler), + RESCRIPT_RUNTIME=str(runtime), + REWATCH_COMPILER_DOMAINS=str(args.domains), + ) + metadata = { + "host": platform.platform(), + "python": platform.python_version(), + "word_bytes": WORD_BYTES, + "commit": subprocess.check_output( + ["git", "-c", f"safe.directory={ROOT}", "rev-parse", "HEAD"], + cwd=ROOT, + text=True, + ).strip(), + "executable_sha256": digest(executable), + "compiler_sha256": digest(compiler), + "runtime": str(runtime), + "domains": args.domains, + "runs": args.runs, + "scenarios": args.scenarios, + "annotation_modes": ANNOTATIONS, + } + (output / "metadata.json").write_text(json.dumps(metadata, indent=2) + "\n") + fields = ( + "scenario", "annotation", "iteration", "elapsed_ms", "user_s", + "system_s", "allocated_bytes", "peak_rss_kib", "artifact_files", + "artifact_bytes", + ) + with (output / "results.csv").open("w", newline="") as source: + writer = csv.DictWriter(source, fieldnames=fields, lineterminator="\n") + writer.writeheader() + for scenario in args.scenarios: + for iteration in range(args.runs + 1): + order = ( + ANNOTATIONS + if iteration % 2 == 0 + else tuple(reversed(ANNOTATIONS)) + ) + for annotation in order: + result = sample(scenario, annotation, iteration, output, executable, env) + if iteration: + writer.writerow(result) + source.flush() + print( + f"{scenario:16} {annotation:5} {iteration}: " + f"{result['elapsed_ms']:8.1f} ms", + flush=True, + ) + + +if __name__ == "__main__": + main() diff --git a/rewatch-ocaml/bench/filesystem_audit.sh b/rewatch-ocaml/bench/filesystem_audit.sh index 19a1ffc92b3..e896dd6176b 100755 --- a/rewatch-ocaml/bench/filesystem_audit.sh +++ b/rewatch-ocaml/bench/filesystem_audit.sh @@ -44,6 +44,8 @@ prepare_fixture() { cp -a --reflink=auto "$dependency_tree" "$destination/$relative_tree" done < <(find "$repo_root/rewatch/testrepo" -type d -name node_modules \ -prune -print) + node "$repo_root/rewatch/tests/add-belt-dependencies.mjs" \ + "$destination/rewatch/testrepo" } if [[ -z ${RESCRIPT_BSC_EXE:-} || -z ${RESCRIPT_RUNTIME:-} ]]; then diff --git a/rewatch-ocaml/bench/frozen_gentype_parity.py b/rewatch-ocaml/bench/frozen_gentype_parity.py new file mode 100644 index 00000000000..64248c2deed --- /dev/null +++ b/rewatch-ocaml/bench/frozen_gentype_parity.py @@ -0,0 +1,241 @@ +#!/usr/bin/env python3 +"""Check GenType and mixed-package imports under both lookup policies. + +Run from the repository root with a new output directory. Each policy builds +the same project path, so artifact paths and source digests are comparable. +""" + +import hashlib +import json +import os +from pathlib import Path +import shutil +import subprocess +import sys + + +ROOT = Path(__file__).resolve().parents[2] +REWATCH = ROOT / "_build/default/rewatch-ocaml/rescript_ocaml.exe" +BSC = ROOT / "_build/default/compiler/bsc/rescript_compiler_main.exe" +RUNTIME = ROOT / "packages/@rescript/runtime" +CMT_COMPARE = ROOT / "_build/default/rewatch-ocaml/bench/cmt_compare.exe" +FIXTURES = ROOT / "rewatch-ocaml/tests" +SETTINGS = ("unset", "0", "1") +MODES = ("summary", "pair", "inverse") +POLICIES = ("classic", "frozen") +GENERATED_SUFFIXES = (".gen.ts", ".js", ".mjs", ".cmi", ".cmj", ".gts") + + +def create_project(mode: str, project: Path): + if mode == "summary": + shutil.copytree(FIXTURES / "gentype-summary", project) + return project / "src/Main.res" + if mode == "pair": + shutil.copytree(FIXTURES / "gentype", project) + shutil.copytree(FIXTURES / "shared-dep", project / "node_modules/dep") + return project / "src/Pair.res" + (project / "src").mkdir(parents=True) + dependency = project / "node_modules/dep" + (dependency / "src").mkdir(parents=True) + (project / "rescript.json").write_text( + json.dumps( + { + "name": "frozen-gentype-inverse", + "sources": "src", + "dependencies": ["dep"], + "package-specs": {"module": "esmodule", "in-source": True}, + } + ) + ) + (project / "src/Consumer.res").write_text("let result = Dep.value\n") + (dependency / "rescript.json").write_text( + json.dumps( + { + "name": "dep", + "sources": "src", + "gentypeconfig": { + "module": "esmodule", + "generatedFileExtension": ".gen.ts", + }, + } + ) + ) + (dependency / "src/Dep.res").write_text("@genType let value = 42\n") + return project / "src/Consumer.res" + + +def environment(policy: str, annotation: str): + env = os.environ.copy() + env.update( + { + "RESCRIPT_BSC_EXE": str(BSC), + "RESCRIPT_RUNTIME": str(RUNTIME), + "REWATCH_COMPILER_DOMAINS": "1", + "REWATCH_FROZEN_VALUES": "1" if policy == "frozen" else "0", + } + ) + if annotation == "unset": + env.pop("REWATCH_BIN_ANNOT", None) + else: + env["REWATCH_BIN_ANNOT"] = annotation + return env + + +def build(output: Path, project: Path, mode: str, annotation: str, policy: str, phase: str): + prefix = output / f"{mode}-{annotation}-{policy}-{phase}" + env = environment(policy, annotation) + env["REWATCH_TYPECHECK_TRACE"] = str(prefix.with_suffix(".trace.tsv")) + result = subprocess.run( + [str(REWATCH), "build", str(project)], + cwd=ROOT, + env=env, + capture_output=True, + ) + prefix.with_suffix(".stdout").write_bytes(result.stdout) + prefix.with_suffix(".stderr").write_bytes(result.stderr) + if result.returncode: + raise AssertionError(f"{mode}/{annotation}/{policy}/{phase} failed: {result.stderr.decode(errors='replace')}") + trace_file = prefix.with_suffix(".trace.tsv") + return result.stdout, trace_file.read_text() if trace_file.exists() else "" + + +def build_error(output: Path, project: Path, annotation: str, policy: str): + prefix = output / f"pair-{annotation}-{policy}-error" + result = subprocess.run( + [str(REWATCH), "build", str(project)], + cwd=ROOT, + env=environment(policy, annotation), + capture_output=True, + ) + prefix.with_suffix(".stdout").write_bytes(result.stdout) + prefix.with_suffix(".stderr").write_bytes(result.stderr) + if result.returncode == 0 or not result.stderr: + raise AssertionError(f"pair/{annotation}/{policy} accepted a type error") + return result.stderr + + +def manifest(project: Path): + return { + str(path.relative_to(project)): hashlib.sha256(path.read_bytes()).hexdigest() + for path in project.rglob("*") + if path.is_file() and path.name.endswith(GENERATED_SUFFIXES) + } + + +def public_manifest(files): + return {path: digest for path, digest in files.items() if not path.endswith(".gts")} + + +def check_annotations(output: Path, project: Path, mode: str, files, policy: str): + snapshot = output / f"{mode}-annotation-classic" + paths = sorted(str(path.relative_to(project)) for path in files) + if policy == "classic": + for relative in paths: + destination = snapshot / relative + destination.parent.mkdir(parents=True, exist_ok=True) + shutil.copyfile(project / relative, destination) + (output / f"{mode}-annotation-paths.txt").write_text("\n".join(paths) + "\n") + else: + previous = (output / f"{mode}-annotation-paths.txt").read_text().splitlines() + if paths != previous: + raise AssertionError(f"{mode} annotation file sets differ") + subprocess.run( + [ + str(CMT_COMPARE), + "--semantic-tree", + str(snapshot), + str(project), + str(output / f"{mode}-annotation-paths.txt"), + ], + cwd=ROOT, + check=True, + ) + shutil.rmtree(snapshot) + + +def check_trace(mode: str, policy: str, trace: str): + frozen_lines = [line for line in trace.splitlines() if "dependency.frozen_open" in line] + if policy == "classic" and frozen_lines: + raise AssertionError(f"{mode} classic lookup used frozen imports") + if policy == "frozen": + if mode == "pair": + if not any("src/Dep.ast" in line for line in frozen_lines): + raise AssertionError("non-GenType dependency did not use frozen imports") + if any("src/Pair.ast" in line for line in frozen_lines): + raise AssertionError("GenType Pair request used frozen imports") + elif mode == "inverse": + if not any("src/Consumer.ast" in line for line in frozen_lines): + raise AssertionError("non-GenType consumer did not use frozen imports") + if any("src/Dep.ast" in line for line in frozen_lines): + raise AssertionError("GenType dependency used frozen imports") + elif frozen_lines: + raise AssertionError("GenType summary request used frozen imports") + + +def main(): + if len(sys.argv) != 2: + raise SystemExit(f"Usage: {sys.argv[0]} OUTPUT_DIRECTORY") + output = Path(sys.argv[1]).resolve() + output.mkdir(parents=True, exist_ok=False) + if not CMT_COMPARE.exists(): + raise SystemExit(f"Build the annotation comparison tool: {CMT_COMPARE}") + results = {} + for annotation in SETTINGS: + for mode in MODES: + project = output / f"{mode}-{annotation}" / "project" + source = create_project(mode, project) + original = source.read_text() + baseline = None + baseline_error = None + for policy in POLICIES: + source.write_text(original) + stdout, trace = build(output, project, mode, annotation, policy, "clean") + if policy == "frozen" and b"Cleaned previous build due to compiler update" not in stdout: + raise AssertionError(f"{mode}/{annotation} policy switch did not invalidate build metadata") + check_trace(mode, policy, trace) + clean = manifest(project) + if not any(path.endswith(".gen.ts") for path in clean): + raise AssertionError(f"{mode}/{annotation}/{policy} emitted no TypeScript") + annotation_files = [ + path + for path in project.rglob("*") + if path.is_file() and path.name.endswith((".cmt", ".cmti")) + ] + if bool(annotation_files) != (annotation == "1"): + raise AssertionError( + f"{mode}/{annotation}/{policy} editor annotation policy differs" + ) + if annotation == "1": + check_annotations(output, project, mode, annotation_files, policy) + source.write_text(original + "\n// same exported types\n") + build(output, project, mode, annotation, policy, "edit") + edited = manifest(project) + if public_manifest(edited) != public_manifest(clean): + raise AssertionError(f"{mode}/{annotation}/{policy} edit changed generated outputs") + build(output, project, mode, annotation, policy, "restart") + if manifest(project) != edited: + raise AssertionError(f"{mode}/{annotation}/{policy} restart changed generated outputs") + if baseline is not None and clean != baseline: + changed = sorted(path for path in clean.keys() | baseline.keys() if clean.get(path) != baseline.get(path)) + raise AssertionError(f"{mode}/{annotation} policies differ: {changed[:8]}") + baseline = clean + if mode == "pair": + source.write_text(original + '\nlet wrong: int = "wrong"\n') + diagnostic = build_error(output, project, annotation, policy) + if baseline_error is not None and diagnostic != baseline_error: + raise AssertionError(f"pair/{annotation} diagnostics differ") + baseline_error = diagnostic + results[f"{mode}/{annotation}/{policy}"] = clean + print(mode, annotation, policy, len(clean), "generated files match", flush=True) + source.write_text(original) + stdout, _ = build(output, project, mode, annotation, "classic", "switch-back") + if b"Cleaned previous build due to compiler update" not in stdout: + raise AssertionError(f"{mode}/{annotation} reverse policy switch did not invalidate build metadata") + if manifest(project) != baseline: + raise AssertionError(f"{mode}/{annotation} reverse policy switch changed outputs") + shutil.rmtree(project) + (output / "results.json").write_text(json.dumps(results, indent=2, sort_keys=True) + "\n") + + +if __name__ == "__main__": + main() diff --git a/rewatch-ocaml/bench/frozen_type_graph_probe.ml b/rewatch-ocaml/bench/frozen_type_graph_probe.ml new file mode 100644 index 00000000000..3ba7f90dc9a --- /dev/null +++ b/rewatch-ocaml/bench/frozen_type_graph_probe.ml @@ -0,0 +1,58 @@ +(* Diagnostic microprobe for the type-graph slice of an imported CMI. It does + not model signature records or Env component construction. *) + +let roots_of_signature signature = + let roots = ref [] in + let original = Btype.type_iterators in + let iterator = + {original with it_type_expr = (fun _ ty -> roots := ty :: !roots)} + in + iterator.it_signature iterator signature; + List.rev !roots + +let measure ~iterations name action = + Gc.full_major (); + let started = Unix.gettimeofday () in + let before = Gc.allocated_bytes () in + let consumed = ref 0 in + for _ = 1 to iterations do + consumed := !consumed + action () + done; + let seconds = Unix.gettimeofday () -. started in + let bytes = Gc.allocated_bytes () -. before in + Printf.printf "%s\t%d\t%.3f\t%.1f\t%d\n" name iterations (seconds *. 1000.) + (bytes /. 1e6) !consumed + +let () = + if Array.length Sys.argv <> 3 then ( + prerr_endline "Usage: frozen_type_graph_probe CMI ITERATIONS"; + exit 2); + let filename = Sys.argv.(1) in + let iterations = int_of_string Sys.argv.(2) in + if iterations <= 0 then invalid_arg "iterations must be positive"; + let cmi = Cmi_format.read_cmi filename in + let roots = roots_of_signature cmi.cmi_sign in + let image = + match Frozen_type_graph.freeze roots with + | Ok image -> image + | Error reason -> failwith reason + in + let bytes = Marshal.to_bytes cmi [] in + Printf.printf "cmi_bytes=%d type_roots=%d type_nodes=%d image_words=%d\n" + (Bytes.length bytes) (List.length roots) + (Frozen_type_graph.node_count image) + (Obj.reachable_words (Obj.repr image)); + Printf.printf "operation\titerations\tworker_ms\tallocated_MB\tchecksum\n"; + measure ~iterations "freeze_type_graph" (fun () -> + match Frozen_type_graph.freeze roots with + | Ok image -> Frozen_type_graph.node_count image + | Error reason -> failwith reason); + measure ~iterations "thaw_type_graph" (fun () -> + List.length (Frozen_type_graph.thaw image)); + measure ~iterations "thaw_first_root" (fun () -> + (Frozen_type_graph.thaw_root image 0).Types.id); + measure ~iterations "marshal_cmi_decode" (fun () -> + let copy : Cmi_format.cmi_infos = Marshal.from_bytes bytes 0 in + List.length copy.cmi_sign); + measure ~iterations "subst_signature" (fun () -> + List.length (Subst.signature Subst.identity cmi.cmi_sign)) diff --git a/rewatch-ocaml/bench/gentype_editor_policy_parity.py b/rewatch-ocaml/bench/gentype_editor_policy_parity.py new file mode 100644 index 00000000000..0acae8100c0 --- /dev/null +++ b/rewatch-ocaml/bench/gentype_editor_policy_parity.py @@ -0,0 +1,158 @@ +#!/usr/bin/env python3 +"""Compare GenType output while changing the editor annotation policy. + +Run from the repository root with the checkpoint-before and checkpoint-after +OCaml Rewatch executables and a new output directory. +""" + +import argparse +import hashlib +import json +import os +from pathlib import Path +import shutil +import subprocess + + +ROOT = Path(__file__).resolve().parents[2] +FIXTURE = ROOT / "rewatch-ocaml/tests/gentype" +SHARED_DEP = ROOT / "rewatch-ocaml/tests/shared-dep" +SETTINGS = ("unset", "0", "1") +SCENARIOS = ("clean", "edit", "restart") + + +def digest(path): + return hashlib.sha256(path.read_bytes()).hexdigest() + + +def manifest(project, suffixes): + return { + str(path.relative_to(project)): digest(path) + for path in project.rglob("*") + if path.is_file() and path.name.endswith(suffixes) + } + + +def run(executable, project, trace, annotation, revision, scenario, *, expect_failure=False): + env = os.environ.copy() + env["RESCRIPT_BSC_EXE"] = str( + ROOT / "_build/default/compiler/bsc/rescript_compiler_main.exe" + ) + env["RESCRIPT_RUNTIME"] = str(ROOT / "packages/@rescript/runtime") + env["REWATCH_COMPILER_DOMAINS"] = "1" + env["REWATCH_TYPECHECK_TRACE"] = str(trace) + if annotation == "unset": + env.pop("REWATCH_BIN_ANNOT", None) + else: + env["REWATCH_BIN_ANNOT"] = annotation + result = subprocess.run( + [str(executable), "build", str(project)], + cwd=ROOT, + env=env, + capture_output=True, + text=True, + check=False, + ) + if expect_failure: + if result.returncode == 0 or not result.stderr: + raise AssertionError(f"expected a diagnostic: {annotation}/{revision}") + return result.stderr + if result.returncode: + raise RuntimeError( + f"{annotation}/{revision}/{scenario} failed:\n" + f"{result.stdout}\n{result.stderr}" + ) + cmt = project / "lib/bs/src/Pair.cmti" + summary = project / "lib/bs/src/Pair.cmti.gts" + copied_source = project / "lib/ocaml/Pair.resi" + if not summary.is_file(): + raise AssertionError("interface summary is missing") + if revision == "new": + editor_enabled = annotation == "1" + if cmt.is_file() != editor_enabled or copied_source.is_file() != editor_enabled: + raise AssertionError(f"editor artifacts differ: {annotation}/{scenario}") + if not editor_enabled: + trace_text = trace.read_text() + if "dependency.gentype_interface_summary_read" not in trace_text: + raise AssertionError("implementation did not read the interface input") + return manifest(project / "src", (".gen.ts", ".js")) + + +def main(): + parser = argparse.ArgumentParser(description=__doc__) + parser.add_argument("old", type=Path) + parser.add_argument("new", type=Path) + parser.add_argument("output", type=Path) + args = parser.parse_args() + old = args.old.resolve(strict=True) + new = args.new.resolve(strict=True) + output = args.output.resolve() + output.mkdir(parents=True, exist_ok=False) + project = output / "project" + results = {} + editor_manifests = {} + diagnostics = {} + for annotation in SETTINGS: + for revision, executable in (("old", old), ("new", new)): + if project.exists(): + shutil.rmtree(project) + shutil.copytree(FIXTURE, project) + (project / "node_modules").mkdir() + shutil.copytree(SHARED_DEP, project / "node_modules/dep") + previous = None + for scenario in SCENARIOS: + if scenario != "clean": + with (project / "src/Pair.res").open("a") as source: + source.write(f"\n// {scenario} with unchanged exports\n") + trace = output / f"{annotation}-{revision}-{scenario}.tsv" + generated = run( + executable, project, trace, annotation, revision, scenario + ) + if previous is not None and generated != previous: + raise AssertionError( + f"generated code changed: {annotation}/{revision}/{scenario}" + ) + previous = generated + results[(annotation, revision, scenario)] = generated + if annotation == "1" and scenario == "clean": + editor_manifests[revision] = manifest( + project / "lib", (".ast", ".iast", ".cmi", ".cmj", ".cmt", ".cmti") + ) + with (project / "src/Pair.res").open("a") as source: + source.write('\nlet wrong: int = "wrong"\n') + trace = output / f"{annotation}-{revision}-error.tsv" + diagnostics[(annotation, revision)] = run( + executable, project, trace, annotation, revision, "error", + expect_failure=True, + ) + for scenario in SCENARIOS: + before = results[(annotation, "old", scenario)] + after = results[(annotation, "new", scenario)] + if before != after: + raise AssertionError(f"generated code differs: {annotation}/{scenario}") + print(annotation, scenario, len(after), "TypeScript/JavaScript files identical") + if annotation == "1": + if editor_manifests["old"] != editor_manifests["new"]: + raise AssertionError("enabled editor artifacts differ") + print("1", "clean", len(editor_manifests["new"]), "editor files identical") + if diagnostics[(annotation, "old")] != diagnostics[(annotation, "new")]: + raise AssertionError(f"diagnostics differ: {annotation}") + print(annotation, "error", "diagnostics identical") + (output / "results.json").write_text( + json.dumps( + { + **{"/".join(key): value for key, value in sorted(results.items())}, + **{ + f"{annotation}/{revision}/error": hashlib.sha256(message.encode()).hexdigest() + for (annotation, revision), message in sorted(diagnostics.items()) + }, + }, + indent=2, + sort_keys=True, + ) + + "\n" + ) + + +if __name__ == "__main__": + main() diff --git a/rewatch-ocaml/bench/gentype_summary_benchmark.py b/rewatch-ocaml/bench/gentype_summary_benchmark.py new file mode 100644 index 00000000000..2f3a842ca6e --- /dev/null +++ b/rewatch-ocaml/bench/gentype_summary_benchmark.py @@ -0,0 +1,98 @@ +#!/usr/bin/env python3 +"""Interleaved GenType summary cost across annotation modes. + +Run from the repository root with old/new OCaml Rewatch binaries in the same +directory. Each sample uses the same project path and a fresh fixture copy. +""" + +import argparse +import csv +import hashlib +import os +from pathlib import Path +import shutil + +import embedded_baseline as baseline + + +ROOT = Path(__file__).resolve().parents[2] +FIXTURE = ROOT / "rewatch-ocaml/tests/gentype-summary" +SCENARIOS = ("clean", "unchanged", "restart-edit") +ANNOTATIONS = ("unset", "0", "1") + + +def sample(executable, project, output, annotation, scenario, iteration): + if project.exists(): + shutil.rmtree(project) + shutil.copytree(FIXTURE, project) + original_files = { + path.relative_to(project) for path in project.rglob("*") if path.is_file() + } + env = os.environ.copy() + env.update( + RESCRIPT_BSC_EXE=str( + ROOT / "_build/default/compiler/bsc/rescript_compiler_main.exe" + ), + RESCRIPT_RUNTIME=str(ROOT / "packages/@rescript/runtime"), + REWATCH_COMPILER_DOMAINS="1", + ) + if annotation == "unset": + env.pop("REWATCH_BIN_ANNOT", None) + else: + env["REWATCH_BIN_ANNOT"] = annotation + if scenario != "clean": + baseline.command(executable, project, env, output.with_name(output.name + "-prepare"), False) + if scenario == "restart-edit": + with (project / "src/Main.res").open("a") as source: + source.write("\n// measured edit after process restart\n") + result = baseline.command(executable, project, env, output, True, original_files) + summary_files = list(project.rglob("*.gts")) + result.update( + scenario=scenario, + annotation=annotation, + iteration=iteration, + summary_files=len(summary_files), + summary_bytes=sum(path.stat().st_size for path in summary_files), + ) + return result + + +def main(): + parser = argparse.ArgumentParser(description=__doc__) + parser.add_argument("old", type=Path) + parser.add_argument("new", type=Path) + parser.add_argument("output", type=Path) + parser.add_argument("--runs", type=int, default=5) + args = parser.parse_args() + if args.runs < 5 or args.runs % 2 != 1: + parser.error("--runs must be odd and at least five") + old = args.old.resolve(strict=True) + new = args.new.resolve(strict=True) + if old.parent != new.parent: + parser.error("put both binaries in the same directory") + output = args.output.resolve() + output.mkdir(parents=True, exist_ok=False) + project = output / "project" + rows = [] + for annotation in ANNOTATIONS: + for scenario in SCENARIOS: + for iteration in range(1, args.runs + 1): + order = (("old", old), ("new", new)) + if iteration % 2 == 0: + order = tuple(reversed(order)) + for revision, executable in order: + prefix = output / f"{annotation}-{scenario}-{iteration}-{revision}" + result = sample(executable, project, prefix, annotation, scenario, iteration) + rows.append({"revision": revision, **result}) + print(annotation, scenario, iteration, revision, result["elapsed_ms"]) + with (output / "results.csv").open("w", newline="") as target: + writer = csv.DictWriter(target, fieldnames=rows[0].keys()) + writer.writeheader() + writer.writerows(rows) + with (output / "binaries.sha256").open("w") as target: + for revision, executable in (("old", old), ("new", new)): + target.write(f"{revision} {hashlib.sha256(executable.read_bytes()).hexdigest()}\n") + + +if __name__ == "__main__": + main() diff --git a/rewatch-ocaml/bench/gentype_summary_parity.py b/rewatch-ocaml/bench/gentype_summary_parity.py new file mode 100644 index 00000000000..411c0309cce --- /dev/null +++ b/rewatch-ocaml/bench/gentype_summary_parity.py @@ -0,0 +1,121 @@ +#!/usr/bin/env python3 +"""Compare GenType TypeScript across clean, edit, and restart builds. + +Run from the repository root with the checkpoint-before and checkpoint-after +OCaml Rewatch executables and a new output directory. Both revisions use the +same project path, standalone compiler, runtime, and worker count. +""" + +import argparse +import hashlib +import json +import os +from pathlib import Path +import shutil +import subprocess + + +ROOT = Path(__file__).resolve().parents[2] +FIXTURE = ROOT / "rewatch-ocaml/tests/gentype-summary" +SETTINGS = ("unset", "0", "1") +SCENARIOS = ("clean", "edit", "restart") + + +def digest(path): + return hashlib.sha256(path.read_bytes()).hexdigest() + + +def run(executable, project, trace, annotation, scenario): + env = os.environ.copy() + env["RESCRIPT_BSC_EXE"] = str( + ROOT / "_build/default/compiler/bsc/rescript_compiler_main.exe" + ) + env["RESCRIPT_RUNTIME"] = str(ROOT / "packages/@rescript/runtime") + env["REWATCH_COMPILER_DOMAINS"] = "1" + env["REWATCH_TYPECHECK_TRACE"] = str(trace) + if annotation == "unset": + env.pop("REWATCH_BIN_ANNOT", None) + else: + env["REWATCH_BIN_ANNOT"] = annotation + result = subprocess.run( + [str(executable), "build", str(project)], + cwd=ROOT, + env=env, + capture_output=True, + text=True, + check=False, + ) + if result.returncode: + raise RuntimeError( + f"{annotation}/{scenario} failed with {executable}:\n" + f"{result.stdout}\n{result.stderr}" + ) + return { + str(path.relative_to(project)): digest(path) + for path in (project / "src").glob("*.gen.ts") + } + + +def main(): + parser = argparse.ArgumentParser(description=__doc__) + parser.add_argument("old", type=Path) + parser.add_argument("new", type=Path) + parser.add_argument("output", type=Path) + args = parser.parse_args() + old = args.old.resolve(strict=True) + new = args.new.resolve(strict=True) + output = args.output.resolve() + output.mkdir(parents=True, exist_ok=False) + project = output / "project" + results = {} + for annotation in SETTINGS: + for revision, executable in (("old", old), ("new", new)): + if project.exists(): + shutil.rmtree(project) + shutil.copytree(FIXTURE, project) + previous = None + for scenario in SCENARIOS: + if scenario != "clean": + with (project / "src/Main.res").open("a") as source: + source.write(f"\n// {scenario} with unchanged types\n") + trace = output / f"{annotation}-{revision}-{scenario}.tsv" + manifest = run(executable, project, trace, annotation, scenario) + if previous is not None and manifest != previous: + raise AssertionError( + f"TypeScript changed on {scenario}: {annotation}/{revision}" + ) + previous = manifest + if revision == "new": + trace_text = trace.read_text() + if ( + "src/Main.ast" not in trace_text + or "dependency.gentype_summary_read" not in trace_text + or "dependency.gentype_dependency_cmt_read" in trace_text + ): + raise AssertionError( + f"summary lookup missing or fell back: {annotation}/{scenario}" + ) + if not (project / "lib/bs/src/Middle.cmt.gts").is_file(): + raise AssertionError("dependency summary was not produced") + results[(annotation, revision, scenario)] = manifest + for scenario in SCENARIOS: + before = results[(annotation, "old", scenario)] + after = results[(annotation, "new", scenario)] + if before != after: + raise AssertionError(f"TypeScript differs: {annotation}/{scenario}") + print(annotation, scenario, len(after), "TypeScript files identical") + (output / "results.json").write_text( + json.dumps( + { + "/".join(key): value + for key, value in sorted(results.items()) + }, + indent=2, + sort_keys=True, + ) + + "\n" + ) + + +if __name__ == "__main__": + main() diff --git a/rewatch-ocaml/bench/immutable_interface_gate.py b/rewatch-ocaml/bench/immutable_interface_gate.py new file mode 100644 index 00000000000..6760c38974a --- /dev/null +++ b/rewatch-ocaml/bench/immutable_interface_gate.py @@ -0,0 +1,379 @@ +#!/usr/bin/env python3 +"""Measure classic and frozen imported interfaces on focused 201-module projects. + +Run from the repository root with OUTPUT_DIRECTORY [ODD_RUN_COUNT]. The runner +requires a POSIX host with os.wait4 and the built OCaml Rewatch executable. +""" + +import csv +import hashlib +import json +import os +from pathlib import Path +import re +import shutil +import statistics +import subprocess +import sys +import time + + +ROOT = Path(__file__).resolve().parents[2] +GENERATOR = ROOT / "rewatch-ocaml/bench/make_immutable_interface_fixture.py" +REWATCH = ROOT / "_build/default/rewatch-ocaml/rescript_ocaml.exe" +BSC = ROOT / "_build/default/compiler/bsc/rescript_compiler_main.exe" +ANALYSIS = ROOT / "_build/default/analysis/bin/main.exe" +CMT_COMPARE = ROOT / "_build/default/rewatch-ocaml/bench/cmt_compare.exe" +RUNTIME = ROOT / "packages/@rescript/runtime" +MODES = ("values", "types", "variants", "modules", "open", "inclusion") +ANNOTATION_SUFFIXES = (".cmt", ".cmti") +GENERATED_SUFFIXES = ( + ".ast", + ".iast", + ".cmi", + ".cmj", + ".cmt", + ".cmti", + ".mjs", + ".js", + ".map", + ".gts", +) + + +def run(command: list[str], env: dict[str, str], log: Path): + started = time.perf_counter_ns() + with log.open("wb") as output: + process = subprocess.Popen( + command, cwd=ROOT, env=env, stdout=output, stderr=subprocess.STDOUT + ) + _, status, usage = os.wait4(process.pid, 0) + process.returncode = os.waitstatus_to_exitcode(status) + wall_ms = (time.perf_counter_ns() - started) / 1e6 + if process.returncode: + raise RuntimeError(f"{' '.join(command)} failed; see {log}") + return wall_ms, (usage.ru_utime + usage.ru_stime) * 1000, usage.ru_maxrss + + +def manifest(project: Path): + return { + str(path.relative_to(project)): hashlib.sha256(path.read_bytes()).hexdigest() + for parent in (project / "src", project / "lib") + if parent.exists() + for path in parent.rglob("*") + if path.is_file() and path.name.endswith(GENERATED_SUFFIXES) + } + + +def is_annotation(path: str): + return path.endswith(ANNOTATION_SUFFIXES) + + +def snapshot_annotations(project: Path, destination: Path, files): + for relative in files: + if is_annotation(relative): + target = destination / relative + target.parent.mkdir(parents=True, exist_ok=True) + shutil.copyfile(project / relative, target) + + +def compare_artifacts(output, project, first, second, snapshot, label, annotations): + missing = sorted(set(first) ^ set(second)) + changed = sorted( + path + for path in set(first) & set(second) + if first[path] != second[path] and not (annotations and is_annotation(path)) + ) + if missing or changed: + raise AssertionError( + f"{label} differs: missing={missing[:5]}, changed={changed[:5]}" + ) + if annotations: + paths = sorted(path for path in first if is_annotation(path)) + if not paths: + raise AssertionError(f"{label} produced no editor annotations") + path_list = output / f"{label}.annotation-paths.txt" + path_list.write_text("\n".join(paths) + "\n") + subprocess.run( + [str(CMT_COMPARE), "--semantic-tree", str(snapshot), str(project), str(path_list)], + cwd=ROOT, + check=True, + ) + shutil.rmtree(snapshot) + + +def policy_environment(policy: str): + env = os.environ.copy() + env.update( + { + "REWATCH_FROZEN_VALUES": "1" if policy == "frozen" else "0", + "REWATCH_COMPILER_DOMAINS": "1", + "RESCRIPT_BSC_EXE": str(BSC), + "RESCRIPT_RUNTIME": str(RUNTIME), + } + ) + return env + + +def build(output: Path, project: Path, mode: str, policy: str, iteration: int): + env = policy_environment(policy) + env.update( + { + "REWATCH_TYPECHECK_TRACE": str( + output / f"{mode}-{policy}-{iteration}.trace.tsv" + ) + } + ) + run( + [str(REWATCH), "clean", str(project)], + env, + output / f"{mode}-{policy}-{iteration}.clean.log", + ) + wall_ms, cpu_ms, rss_kib = run( + [str(REWATCH), "build", str(project)], + env, + output / f"{mode}-{policy}-{iteration}.build.log", + ) + return { + "mode": mode, + "policy": policy, + "iteration": iteration, + "wall_ms": round(wall_ms, 3), + "cpu_ms": round(cpu_ms, 3), + "rss_kib": rss_kib, + "trace": env["REWATCH_TYPECHECK_TRACE"], + }, manifest(project) + + +def check_inclusion_edit(output: Path, project: Path, annotations: bool): + implementation = project / "src/Api.res" + source = implementation.read_text() + updated = source.replace("let answer = 1", "let answer = 2", 1) + if updated == source: + raise AssertionError("inclusion fixture has no module answer") + edited_manifests = {} + edited_work = {} + snapshot = output / "inclusion-edit-annotations" + for policy in ("classic", "frozen"): + implementation.write_text(source) + env = policy_environment(policy) + prefix = output / f"inclusion-edit-{policy}" + run([str(REWATCH), "clean", str(project)], env, Path(f"{prefix}.clean.log")) + run([str(REWATCH), "build", str(project)], env, Path(f"{prefix}.base.log")) + implementation.write_text(updated) + edit_log = Path(f"{prefix}.build.log") + run([str(REWATCH), "build", str(project)], env, edit_log) + edited_manifests[policy] = manifest(project) + if policy == "classic" and annotations: + snapshot_annotations(project, snapshot, edited_manifests[policy]) + edited_work[policy] = re.findall( + rb"(?:Parsed|Compiled) \d+ (?:source files|modules)", + edit_log.read_bytes(), + ) + run( + [str(REWATCH), "build", str(project)], + env, + Path(f"{prefix}.restart.log"), + ) + if manifest(project) != edited_manifests[policy]: + raise AssertionError(f"{policy} restart changed edited artifacts") + implementation.write_text(source) + compare_artifacts( + output, + project, + edited_manifests["classic"], + edited_manifests["frozen"], + snapshot, + "inclusion-edit", + annotations, + ) + if edited_work["classic"] != edited_work["frozen"]: + raise AssertionError("inclusion edit compiler work differs") + if not edited_work["classic"]: + raise AssertionError("inclusion edit performed no compiler work") + + +def check_inclusion_error(output: Path, project: Path): + interface = project / "src/Api.resi" + source = interface.read_text() + updated = source.replace("let value0: int", "let value0: string", 1) + if updated == source: + raise AssertionError("inclusion fixture has no value0 declaration") + interface.write_text(updated) + diagnostics = {} + for policy in ("classic", "frozen"): + env = policy_environment(policy) + run( + [str(REWATCH), "clean", str(project)], + env, + output / f"inclusion-error-{policy}.clean.log", + ) + result = subprocess.run( + [str(REWATCH), "build", str(project)], + cwd=ROOT, + env=env, + capture_output=True, + ) + diagnostics[policy] = result.stdout + result.stderr + (output / f"inclusion-error-{policy}.build.log").write_bytes( + diagnostics[policy] + ) + if result.returncode == 0: + raise AssertionError(f"{policy} accepted a mismatched interface") + if diagnostics["classic"] != diagnostics["frozen"]: + raise AssertionError("inclusion error diagnostics differ") + + +def check_editor_queries(output: Path, project: Path): + source = project / "src/Consumer0.res" + incomplete = output / "values-incomplete.res" + incomplete.write_text("let result = Api.\n") + queries = ( + ("hover", ["hover", str(source), "0", "20", str(source), "true"]), + ("references", ["references", str(source), "0", "20"]), + ("completion", ["completion", str(source), "0", "17", str(source)]), + ( + "incomplete-completion", + ["completion", str(source), "0", "17", str(incomplete)], + ), + ) + responses = {} + for policy in ("classic", "frozen"): + env = policy_environment(policy) + run( + [str(REWATCH), "clean", str(project)], + env, + output / f"values-editor-{policy}.clean.log", + ) + run( + [str(REWATCH), "build", str(project)], + env, + output / f"values-editor-{policy}.build.log", + ) + for name, arguments in queries: + result = subprocess.run( + [str(ANALYSIS), *arguments], cwd=ROOT, env=env, capture_output=True + ) + responses[policy, name] = ( + result.returncode, + result.stdout, + result.stderr, + ) + (output / f"values-editor-{policy}-{name}.stdout").write_bytes( + result.stdout + ) + (output / f"values-editor-{policy}-{name}.stderr").write_bytes( + result.stderr + ) + if result.returncode: + raise AssertionError(f"{policy} {name} editor query failed") + for name, _ in queries: + if responses["classic", name] != responses["frozen", name]: + raise AssertionError(f"{name} editor response differs") + expected = { + "hover": b"int", + "references": b'"range"', + "completion": b'"value0"', + "incomplete-completion": b'"value0"', + } + for name, marker in expected.items(): + if marker not in responses["classic", name][1]: + raise AssertionError(f"{name} editor response is missing {marker!r}") + + +def main(): + if len(sys.argv) not in (2, 3): + raise SystemExit(f"Usage: {sys.argv[0]} OUTPUT_DIRECTORY [ODD_RUN_COUNT]") + count = int(sys.argv[2]) if len(sys.argv) == 3 else 5 + if count < 1 or count % 2 == 0: + raise SystemExit("Run count must be a positive odd integer") + annotations = os.getenv("REWATCH_BIN_ANNOT") == "1" + if annotations: + for required in (CMT_COMPARE, ANALYSIS): + if not required.exists(): + raise SystemExit(f"Build the annotation gate tool first: {required}") + output = Path(sys.argv[1]).resolve() + output.mkdir(parents=True, exist_ok=False) + samples = [] + for mode in MODES: + project = output / mode / "project" + subprocess.run( + [sys.executable, str(GENERATOR), str(project), f"--{mode}-only"], + cwd=ROOT, + check=True, + ) + # Warm both paths before the interleaved samples. + for policy in ("classic", "frozen"): + build(output, project, mode, policy, 0) + annotation_baselines = {} + for iteration in range(1, count + 1): + order = ("classic", "frozen") if iteration % 2 else ("frozen", "classic") + manifests = {} + snapshot = output / f"{mode}-{iteration}.annotation-snapshot" + for policy in order: + sample, manifests[policy] = build( + output, project, mode, policy, iteration + ) + if annotations: + current_annotations = { + path: digest + for path, digest in manifests[policy].items() + if is_annotation(path) + } + previous = annotation_baselines.setdefault(policy, current_annotations) + if previous != current_annotations: + raise AssertionError( + f"{mode} {policy} annotation bytes changed across clean builds" + ) + if policy == order[0]: + snapshot_annotations(project, snapshot, manifests[policy]) + samples.append(sample) + print( + f"{mode:8} {policy:7} {iteration}: " + f"{sample['wall_ms']:.1f} ms, {sample['cpu_ms']:.1f} CPU ms, " + f"{sample['rss_kib']} KiB RSS", + flush=True, + ) + compare_artifacts( + output, + project, + manifests[order[0]], + manifests[order[1]], + snapshot, + f"{mode}-{iteration}", + annotations, + ) + for policy in ("classic", "frozen"): + matching = [ + sample for sample in samples if sample["mode"] == mode and sample["policy"] == policy + ] + print( + f"{mode:8} {policy:7} median: " + f"{statistics.median(sample['wall_ms'] for sample in matching):.1f} ms", + flush=True, + ) + for policy in (("classic", "frozen") if annotations else ("classic",)): + suffix = f"-{policy}" if annotations else "" + (output / f"{mode}{suffix}.manifest.json").write_text( + json.dumps(manifests[policy], indent=2, sort_keys=True) + "\n" + ) + if mode == "values" and annotations: + check_editor_queries(output, project) + if mode == "inclusion": + check_inclusion_edit(output, project, annotations) + check_inclusion_error(output, project) + if os.getenv("KEEP_REWATCH_IMMUTABLE_PROJECTS") != "1": + shutil.rmtree(project) + with (output / "samples.csv").open("w", newline="") as file: + writer = csv.DictWriter(file, fieldnames=samples[0].keys()) + writer.writeheader() + writer.writerows(samples) + (output / "metadata.txt").write_text( + f"rewatch_sha256={hashlib.sha256(REWATCH.read_bytes()).hexdigest()}\n" + f"bsc_sha256={hashlib.sha256(BSC.read_bytes()).hexdigest()}\n" + f"domains=1\nruns={count}\nannotations={int(annotations)}\n" + ) + + +if __name__ == "__main__": + main() diff --git a/rewatch-ocaml/bench/legacy_ppx_gate.py b/rewatch-ocaml/bench/legacy_ppx_gate.py new file mode 100644 index 00000000000..33ea7f10401 --- /dev/null +++ b/rewatch-ocaml/bench/legacy_ppx_gate.py @@ -0,0 +1,139 @@ +#!/usr/bin/env python3 +"""Measure the frozen AST 0 boundary and check its no-PPX bypass. + +Run from the repository root with a new output directory. The identity PPX +copies the frozen AST 0 file, preserving the exact external wire protocol. +""" + +import csv +import hashlib +import json +import os +from pathlib import Path +import shutil +import subprocess +import sys +import time + + +ROOT = Path(__file__).resolve().parents[2] +REWATCH = ROOT / "_build/default/rewatch-ocaml/rescript_ocaml.exe" +BSC = ROOT / "_build/default/compiler/bsc/rescript_compiler_main.exe" +RUNTIME = ROOT / "packages/@rescript/runtime" +PHASES = ( + "ppx.convert.to0", + "ppx.serialize", + "ppx.write", + "ppx.execute", + "ppx.read", + "ppx.deserialize", + "ppx.convert.from0", +) + + +def manifest(project: Path): + return { + str(path.relative_to(project)): hashlib.sha256(path.read_bytes()).hexdigest() + for path in project.rglob("*") + if path.is_file() + and ( + path.name.endswith(".mjs") + or ("lib" in path.relative_to(project).parts and path.name.endswith((".cmi", ".cmj"))) + ) + } + + +def phases(path: Path): + result = {} + for line in path.read_text().splitlines(): + columns = line.split("\t") + name = columns[2] + if name.startswith("ppx."): + seconds, bytes_allocated, calls = result.get(name, (0.0, 0.0, 0)) + result[name] = ( + seconds + float(columns[3]), + bytes_allocated + float(columns[4]), + calls + int(columns[5]), + ) + return result + + +def run(output: Path, project: Path, ppx: Path, iteration: int, mode: str): + config_path = project / "rescript.json" + config = json.loads(config_path.read_text()) + if mode == "identity": + config["ppx-flags"] = [str(ppx)] + else: + config.pop("ppx-flags", None) + config_path.write_text(json.dumps(config) + "\n") + shutil.rmtree(project / "lib", ignore_errors=True) + prefix = output / f"{iteration}-{mode}" + env = os.environ.copy() + env.update( + { + "RESCRIPT_BSC_EXE": str(BSC), + "RESCRIPT_RUNTIME": str(RUNTIME), + "REWATCH_COMPILER_DOMAINS": "1", + "REWATCH_FROZEN_VALUES": "1", + "REWATCH_BIN_ANNOT": "0", + "REWATCH_TYPECHECK_TRACE": str(prefix.with_suffix(".trace.tsv")), + } + ) + started = time.perf_counter() + result = subprocess.run( + [str(REWATCH), "build", str(project)], + cwd=ROOT, + env=env, + capture_output=True, + ) + wall_ms = (time.perf_counter() - started) * 1000 + prefix.with_suffix(".stdout").write_bytes(result.stdout) + prefix.with_suffix(".stderr").write_bytes(result.stderr) + if result.returncode: + raise AssertionError(f"{iteration}/{mode} failed: {result.stderr.decode(errors='replace')}") + if b"Compiled 4 modules" not in result.stdout: + raise AssertionError(f"{iteration}/{mode} did not compile all four modules") + trace = phases(prefix.with_suffix(".trace.tsv")) + if mode == "plain" and trace: + raise AssertionError("AST 0 conversion ran without an external PPX") + if mode == "identity" and set(trace) != set(PHASES): + raise AssertionError(f"missing AST 0 boundary phases: {set(PHASES) - set(trace)}") + return wall_ms, trace, manifest(project) + + +def main(): + if len(sys.argv) != 3: + raise SystemExit(f"Usage: {sys.argv[0]} OUTPUT_DIRECTORY ODD_RUN_COUNT") + count = int(sys.argv[2]) + if count < 5 or count % 2 != 1: + raise SystemExit("Run count must be odd and at least five") + output = Path(sys.argv[1]).resolve() + output.mkdir(parents=True, exist_ok=False) + project = output / "project" + shutil.copytree(ROOT / "rewatch-ocaml/tests/basic", project) + ppx = output / "identity-ppx.sh" + ppx.write_text('#!/bin/sh\nset -eu\ncp "$1" "$2"\n') + ppx.chmod(0o755) + with (output / "samples.csv").open("w", newline="") as channel: + writer = csv.writer(channel) + writer.writerow(["iteration", "mode", "wall_ms", *[f"{name}_ms" for name in PHASES]]) + for iteration in range(1, count + 1): + baseline = None + for mode in (("plain", "identity") if iteration % 2 else ("identity", "plain")): + wall_ms, trace, files = run(output, project, ppx, iteration, mode) + if baseline is not None and files != baseline: + changed = sorted( + path for path in baseline.keys() | files.keys() + if baseline.get(path) != files.get(path) + ) + raise AssertionError(f"{iteration} generated artifacts differ: {changed}") + baseline = files + writer.writerow( + [iteration, mode, f"{wall_ms:.3f}"] + + [f"{trace.get(name, (0.0, 0.0, 0))[0] * 1000:.3f}" for name in PHASES] + ) + print(iteration, mode, f"{wall_ms:.1f} ms", len(files), "artifacts", flush=True) + + +if __name__ == "__main__": + main() diff --git a/rewatch-ocaml/bench/make_immutable_interface_fixture.py b/rewatch-ocaml/bench/make_immutable_interface_fixture.py new file mode 100644 index 00000000000..ba3bc385fcc --- /dev/null +++ b/rewatch-ocaml/bench/make_immutable_interface_fixture.py @@ -0,0 +1,135 @@ +#!/usr/bin/env python3 +"""Create synthetic projects for frozen-interface benchmarks.""" + +import json +import sys +from pathlib import Path + + +def main() -> None: + if len(sys.argv) not in (2, 3) or ( + len(sys.argv) == 3 + and sys.argv[2] + not in ( + "--values-only", + "--types-only", + "--variants-only", + "--modules-only", + "--open-only", + "--inclusion-only", + ) + ): + raise SystemExit( + f"Usage: {sys.argv[0]} OUTPUT_DIRECTORY " + "[--values-only|--types-only|--variants-only|--modules-only|--open-only|--inclusion-only]" + ) + mode = sys.argv[2] if len(sys.argv) == 3 else "default" + root = Path(sys.argv[1]).resolve() + if root.exists(): + raise SystemExit(f"Output directory already exists: {root}") + source = root / "src" + source.mkdir(parents=True) + (root / "rescript.json").write_text( + json.dumps( + { + "name": "immutable-interface-probe", + "sources": {"dir": "src", "subdirs": True}, + "package-specs": {"module": "esmodule", "in-source": True}, + "suffix": ".mjs", + }, + indent=2, + ) + + "\n" + ) + if mode == "--inclusion-only": + (source / "Api.resi").write_text( + "".join(f"let value{i}: int\n" for i in range(400)) + + "module type S = {type t; let answer: int}\n" + + "module A: S\nmodule Alias: S\n" + + "module F: (X: S) => {let same: int}\n" + ) + (source / "Api.res").write_text( + "".join(f"let value{i} = {i}\n" for i in range(400)) + + "module type S = {type t; let answer: int}\n" + + "module A: S = {type t = int; let answer = 1}\n" + + "module Alias = A\n" + + "module F = (X: S) => {let same = X.answer}\n" + ) + elif mode == "--modules-only": + (source / "Api.res").write_text( + "".join(f"let value{i} = {i}\n" for i in range(400)) + + "module type S = {type t; let answer: int}\n" + + "module A: S = {type t = int; let answer = 1}\n" + + 'module B: S = {type t = string; let answer = 2}\n' + + "module Alias = A\n" + + "module F = (X: S) => {let same = X.answer}\n" + ) + elif mode == "--types-only": + (source / "Api.resi").write_text( + "".join(f"type opaque{i}\ntype alias{i} = opaque{i}\n" for i in range(200)) + ) + (source / "Api.res").write_text( + "".join( + f"type opaque{i} = int\ntype alias{i} = opaque{i}\n" + for i in range(200) + ) + ) + elif mode == "--variants-only": + variants = "".join( + f"type choice{i} = A{i} | B{i}(int)\n" for i in range(200) + ) + (source / "Api.resi").write_text(variants) + (source / "Api.res").write_text(variants) + else: + (source / "Api.resi").write_text( + "".join(f"let value{i}: int\n" for i in range(400)) + + "let id: 'a => 'a\n" + + "type box<'a> = {value: 'a}\n" + ) + (source / "Api.res").write_text( + "".join(f"let value{i} = {i}\n" for i in range(400)) + + "let id = x => x\n" + + "type box<'a> = {value: 'a}\n" + ) + for i in range(200): + if mode == "--inclusion-only": + text = ( + "module Applied = Api.F(Api.A)\n" + f"let result = Api.value{i} + Api.A.answer " + "+ Api.Alias.answer + Applied.same\n" + ) + elif mode == "--modules-only": + text = ( + "module Applied = Api.F(Api.A)\n" + f"let result = Api.value{i} + Api.A.answer + Api.B.answer " + "+ Api.Alias.answer + Applied.same\n" + ) + elif mode == "--open-only": + text = ( + "open Api\n" + f"let result = value{i} + id({i})\n" + "let box: box = {value: result}\n" + ) + elif mode == "--types-only": + text = ( + f"let opaque = (x: Api.opaque{i}) => x\n" + f"let alias = (x: Api.alias{i}) => x\n" + ) + elif mode == "--variants-only": + text = ( + f"let selected = Api.B{i}({i})\n" + f"let result = switch selected {{\n" + f"| Api.A{i} => 0\n" + f"| Api.B{i}(value) => value\n" + f"}}\n" + ) + else: + text = f"let result = Api.value{i} + Api.id({i})\n" + ( + "" if mode == "--values-only" else "let box: Api.box = {value: result}\n" + ) + (source / f"Consumer{i}.res").write_text(text) + print(root) + + +if __name__ == "__main__": + main() diff --git a/rewatch-ocaml/bench/performance_gate.sh b/rewatch-ocaml/bench/performance_gate.sh index b9aa48e9421..13c42017c51 100755 --- a/rewatch-ocaml/bench/performance_gate.sh +++ b/rewatch-ocaml/bench/performance_gate.sh @@ -16,6 +16,11 @@ if [[ ! -x "$rust_executable" || ! -x "$ocaml_executable" ]]; then echo "Both rewatch executables must exist and be executable." >&2 exit 2 fi +if [[ ${REWATCH_FIRST_EMBEDDED:-0} == 1 && + $(dirname "$rust_executable") != $(dirname "$ocaml_executable") ]]; then + echo "Place both embedded executables in the same directory to avoid startup-path bias." >&2 + exit 2 +fi if [[ ! "$runs" =~ ^[1-9][0-9]*$ || $((runs % 2)) -eq 0 ]]; then echo "RUNS must be a positive odd integer so the median is unambiguous." >&2 exit 2 @@ -62,6 +67,8 @@ prepare_fixture() { cp -a --reflink=auto "$dependency_tree" "$destination/$relative_tree" done < <(find "$repo_root/rewatch/testrepo" -type d -name node_modules \ -prune -print) + node "$repo_root/rewatch/tests/add-belt-dependencies.mjs" \ + "$destination/rewatch/testrepo" } rust_root="$work_root/rust" @@ -77,8 +84,12 @@ fi export RESCRIPT_BSC_EXE RESCRIPT_RUNTIME results="$work_root/results.csv" -echo "implementation,iteration,wall_ms,peak_tree_rss_kib,peak_tree_tasks" \ +echo "scenario,implementation,iteration,wall_ms,peak_tree_rss_kib,peak_tree_tasks" \ >"$results" +edit_source_relative=packages/watch-warnings/src/B.res +edit_baseline="$work_root/B.res.baseline" +cp "$rust_fixture/$edit_source_relative" "$edit_baseline" +cmp "$edit_baseline" "$ocaml_fixture/$edit_source_relative" tree_resources() { local root_pid=$1 @@ -105,35 +116,59 @@ clean_and_build() { } measure() { - local implementation=$1 executable=$2 fixture=$3 iteration=$4 - local output="$work_root/${implementation}-${iteration}" - "$executable" clean "$fixture" >/dev/null 2>&1 - local start_ns root_pid peak_rss=0 peak_tasks=0 rss tasks end_ns wall_ms + local scenario=$1 implementation=$2 executable=$3 fixture=$4 iteration=$5 + local output="$work_root/${scenario}-${implementation}-${iteration}" + case "$scenario" in + clean) "$executable" clean "$fixture" >/dev/null 2>&1 ;; + unchanged) ;; + edit) + printf '\n// timed single edit %d\n' "$iteration" \ + >>"$fixture/$edit_source_relative" ;; + *) echo "Unknown benchmark scenario: $scenario" >&2; exit 2 ;; + esac + local start_ns root_pid sampler_pid peak_rss peak_tasks end_ns wall_ms + local resource_file="$output.resources" start_ns=$(date +%s%N) "$executable" build "$fixture" >"$output" 2>"$output.stderr" & root_pid=$! - while kill -0 "$root_pid" 2>/dev/null; do - read -r rss tasks < <(tree_resources "$root_pid") - if ((rss > peak_rss)); then - peak_rss=$rss - fi - if ((tasks > peak_tasks)); then - peak_tasks=$tasks - fi - sleep 0.02 - done + ( + peak_rss=0 + peak_tasks=0 + while kill -0 "$root_pid" 2>/dev/null; do + read -r rss tasks < <(tree_resources "$root_pid") + if ((rss > peak_rss)); then + peak_rss=$rss + fi + if ((tasks > peak_tasks)); then + peak_tasks=$tasks + fi + sleep 0.02 + done + printf '%d %d\n' "$peak_rss" "$peak_tasks" >"$resource_file" + ) & + sampler_pid=$! wait "$root_pid" end_ns=$(date +%s%N) + wait "$sampler_pid" + read -r peak_rss peak_tasks <"$resource_file" wall_ms=$(((end_ns - start_ns) / 1000000)) - echo "$implementation,$iteration,$wall_ms,$peak_rss,$peak_tasks" >>"$results" - printf '%-5s run %d: %6d ms %8d KiB %4d tasks\n' \ - "$implementation" "$iteration" "$wall_ms" "$peak_rss" "$peak_tasks" + echo "$scenario,$implementation,$iteration,$wall_ms,$peak_rss,$peak_tasks" \ + >>"$results" + printf '%-9s %-5s run %d: %6d ms %8d KiB %4d tasks\n' \ + "$scenario" "$implementation" "$iteration" "$wall_ms" "$peak_rss" \ + "$peak_tasks" + if [[ $scenario == edit ]]; then + # Return to the same compiled baseline before the next timed edit. + cp "$edit_baseline" "$fixture/$edit_source_relative" + "$executable" build "$fixture" >"$output.restore" \ + 2>"$output.restore.stderr" + fi } median_column() { - local implementation=$1 column=$2 middle=$((runs / 2 + 1)) - awk -F, -v implementation="$implementation" \ - '$1 == implementation { print $'"$column"' }' "$results" \ + local scenario=$1 implementation=$2 column=$3 middle=$((runs / 2 + 1)) + awk -F, -v scenario="$scenario" -v implementation="$implementation" \ + '$1 == scenario && $2 == implementation { print $'"$column"' }' "$results" \ | sort -n | sed -n "${middle}p" } @@ -141,44 +176,75 @@ echo "Rewatch clean-build performance gate" echo "commit: $(git -C "$repo_root" rev-parse HEAD)" echo "host: $(uname -a)" echo "cpus: $(getconf _NPROCESSORS_ONLN 2>/dev/null || echo unknown)" +echo "runtime: $RESCRIPT_RUNTIME" +echo "compiler domains: ${REWATCH_COMPILER_DOMAINS:-default}" +echo "Rust Rayon threads: ${RAYON_NUM_THREADS:-default}" +echo "executable and compiler SHA-256:" +sha256sum "$rust_executable" "$ocaml_executable" "$RESCRIPT_BSC_EXE" echo "runs: $runs (interleaved after one warm-up each)" -echo "threshold: ${threshold_percent}% of Rust median wall and RSS" +echo "clean threshold: ${threshold_percent}% of Rust median wall and RSS" +if [[ ${REWATCH_FIRST_EMBEDDED:-0} == 1 ]]; then + echo "first executable uses embedded compiler tracing; 'Rust' labels mean baseline" +fi clean_and_build "$rust_executable" "$rust_fixture" "$work_root/rust-warmup" clean_and_build "$ocaml_executable" "$ocaml_fixture" "$work_root/ocaml-warmup" for ((iteration = 1; iteration <= runs; iteration++)); do if ((iteration % 2 == 1)); then - measure rust "$rust_executable" "$rust_fixture" "$iteration" - measure ocaml "$ocaml_executable" "$ocaml_fixture" "$iteration" + measure clean rust "$rust_executable" "$rust_fixture" "$iteration" + measure clean ocaml "$ocaml_executable" "$ocaml_fixture" "$iteration" else - measure ocaml "$ocaml_executable" "$ocaml_fixture" "$iteration" - measure rust "$rust_executable" "$rust_fixture" "$iteration" + measure clean ocaml "$ocaml_executable" "$ocaml_fixture" "$iteration" + measure clean rust "$rust_executable" "$rust_fixture" "$iteration" fi done -rust_wall=$(median_column rust 3) -ocaml_wall=$(median_column ocaml 3) -rust_rss=$(median_column rust 4) -ocaml_rss=$(median_column ocaml 4) -rust_tasks=$(median_column rust 5) -ocaml_tasks=$(median_column ocaml 5) -printf 'median Rust: %6d ms %8d KiB %4d peak tasks\n' \ +rust_wall=$(median_column clean rust 4) +ocaml_wall=$(median_column clean ocaml 4) +rust_rss=$(median_column clean rust 5) +ocaml_rss=$(median_column clean ocaml 5) +rust_tasks=$(median_column clean rust 6) +ocaml_tasks=$(median_column clean ocaml 6) +printf 'clean median Rust: %6d ms %8d KiB %4d peak tasks\n' \ "$rust_wall" "$rust_rss" "$rust_tasks" -printf 'median OCaml: %6d ms %8d KiB %4d peak tasks\n' \ +printf 'clean median OCaml: %6d ms %8d KiB %4d peak tasks\n' \ "$ocaml_wall" "$ocaml_rss" "$ocaml_tasks" +for scenario in unchanged edit; do + for ((iteration = 1; iteration <= runs; iteration++)); do + if ((iteration % 2 == 1)); then + measure "$scenario" rust "$rust_executable" "$rust_fixture" "$iteration" + measure "$scenario" ocaml "$ocaml_executable" "$ocaml_fixture" "$iteration" + else + measure "$scenario" ocaml "$ocaml_executable" "$ocaml_fixture" "$iteration" + measure "$scenario" rust "$rust_executable" "$rust_fixture" "$iteration" + fi + done + printf '%s median Rust: %6d ms %8d KiB peak tree RSS\n' \ + "$scenario" "$(median_column "$scenario" rust 4)" \ + "$(median_column "$scenario" rust 5)" + printf '%s median OCaml: %6d ms %8d KiB peak tree RSS\n' \ + "$scenario" "$(median_column "$scenario" ocaml 4)" \ + "$(median_column "$scenario" ocaml 5)" +done + trace_and_classify() { local implementation=$1 scenario=$2 executable=$3 fixture=$4 manifest=$5 local clean_first=$6 + local embedded=0 + if [[ $implementation == ocaml || ${REWATCH_FIRST_EMBEDDED:-0} == 1 ]]; then + embedded=1 + fi 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 - if [[ $implementation == ocaml ]]; then + if ((embedded)); then # Embedded requests have no compiler execve. Record them at their shared # logical boundary while tracing PPXs as external processes. + : >"$call_log" strace -f -ff -qq -s 4096 -e trace=execve,chdir -o "$trace_prefix" \ env REWATCH_COMPILER_CALL_LOG="$call_log" \ "$executable" build "$fixture" \ @@ -195,7 +261,7 @@ trace_and_classify() { local trace_file exec_line argv cwd_line cwd phase input identity : >"$manifest.unsorted" for trace_file in "${trace_files[@]}"; do - if [[ $implementation == ocaml ]]; then + if ((embedded)); then exec_line=$(grep -m1 -E 'execve\("[^"]*sury-ppx' "$trace_file" || true) else exec_line=$(grep -m1 -F "execve(\"$RESCRIPT_BSC_EXE\"" "$trace_file" \ @@ -228,7 +294,7 @@ trace_and_classify() { | sed "s#$implementation_root##g" >>"$manifest.unsorted" done local invocations parse namespace compile interface ppx - if [[ $implementation == ocaml ]]; then + if ((embedded)); 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" \ @@ -378,6 +444,7 @@ if ((file_set_equivalence == 0)); then fi if ((artifact_equivalence == 0)); then echo "FAIL: Rust and OCaml generated different artifacts." >&2 + echo "Check that standalone bsc and OCaml rewatch use the same Dune profile." >&2 failed=1 fi @@ -387,5 +454,5 @@ fi if ((runs < 5)); then echo "PASS: correctness smoke checks passed; performance gate not evaluated." else - echo "PASS: timing, memory, compiler-work, and artifact-equivalence gates passed." + echo "PASS: clean timing and memory, compiler-work, and artifact-equivalence gates passed." fi diff --git a/rewatch-ocaml/bench/typecheck_breakdown.sh b/rewatch-ocaml/bench/typecheck_breakdown.sh new file mode 100644 index 00000000000..80e1fd5b8ce --- /dev/null +++ b/rewatch-ocaml/bench/typecheck_breakdown.sh @@ -0,0 +1,85 @@ +#!/usr/bin/env bash +set -euo pipefail + +if [[ $# -lt 1 || $# -gt 2 ]]; then + echo "Usage: $0 OUTPUT_DIRECTORY [ODD_RUN_COUNT]" >&2 + exit 2 +fi + +repo_root=$(cd "$(dirname "$0")/../.." && pwd) +results=$(mkdir -p "$1" && cd "$1" && pwd) +runs=${2:-5} +if [[ ! $runs =~ ^[1-9][0-9]*$ || $((runs % 2)) -eq 0 ]]; then + echo "Run count must be positive and odd." >&2 + exit 2 +fi + +fixture_root="$results/fixture" +if [[ -e "$fixture_root" ]]; then + echo "Output directory already contains a fixture: $fixture_root" >&2 + exit 2 +fi +mkdir -p "$fixture_root" +git -c "safe.directory=$repo_root" -C "$repo_root" archive HEAD \ + rewatch/testrepo packages/@rescript/belt packages/@rescript/runtime \ + | tar -x -C "$fixture_root" +while IFS= read -r dependency_tree; do + relative_tree=${dependency_tree#"$repo_root/"} + mkdir -p "$(dirname "$fixture_root/$relative_tree")" + cp -a --reflink=auto "$dependency_tree" "$fixture_root/$relative_tree" +done < <(find "$repo_root/rewatch/testrepo" -type d -name node_modules -prune -print) +node "$repo_root/rewatch/tests/add-belt-dependencies.mjs" \ + "$fixture_root/rewatch/testrepo" + +export RESCRIPT_RUNTIME="$repo_root/packages/@rescript/runtime" +export REWATCH_COMPILER_DOMAINS=${REWATCH_COMPILER_DOMAINS:-8} +plain_executable=${REWATCH_PLAIN_EXECUTABLE:-"$repo_root/_build/default/rewatch-ocaml/rescript_ocaml.exe"} +plain_bsc=${REWATCH_PLAIN_BSC:-"$repo_root/_build/default/compiler/bsc/rescript_compiler_main.exe"} +traced_executable="$repo_root/_build/default/rewatch-ocaml/rescript_ocaml.exe" +traced_bsc="$repo_root/_build/default/compiler/bsc/rescript_compiler_main.exe" +mkdir -p "$results/bin" +cp "$plain_executable" "$results/bin/rewatch-plain" +cp "$plain_bsc" "$results/bin/bsc-plain" +cp "$traced_executable" "$results/bin/rewatch-traced" +cp "$traced_bsc" "$results/bin/bsc-traced" +fixture="$fixture_root/rewatch/testrepo" + +{ + printf 'fixture_commit=%s\n' "$(git -c "safe.directory=$repo_root" -C "$repo_root" rev-parse HEAD)" + printf 'host=%s\n' "$(uname -a)" + printf 'workers=%s\n' "$REWATCH_COMPILER_DOMAINS" + printf 'runtime=%s\n' "$RESCRIPT_RUNTIME" + sha256sum "$results/bin/rewatch-plain" "$results/bin/rewatch-traced" \ + "$results/bin/bsc-plain" "$results/bin/bsc-traced" +} >"$results/metadata.txt" + +for ((iteration = 1; iteration <= runs; iteration++)); do + for slot in 0 1; do + if (((iteration + slot) % 2 == 0)); then + mode=traced + else + mode=plain + fi + executable="$results/bin/rewatch-$mode" + export RESCRIPT_BSC_EXE="$results/bin/bsc-$mode" + # Belt lives outside testrepo and is not removed by cleaning that project. + # Clean it explicitly so every sample recompiles the same 1,031 requests. + "$executable" clean "$fixture_root/packages/@rescript/belt" \ + >"$results/$mode-$iteration.belt-clean.log" 2>&1 + "$executable" clean "$fixture" >"$results/$mode-$iteration.clean.log" 2>&1 + trace="$results/$mode-$iteration.trace.tsv" + if [[ $mode == traced ]]; then + REWATCH_TYPECHECK_TRACE="$trace" /usr/bin/time \ + -f 'elapsed_s=%e user_s=%U sys_s=%S peak_rss_kib=%M' \ + -o "$results/$mode-$iteration.time" \ + "$executable" build "$fixture" >"$results/$mode-$iteration.build.log" 2>&1 + else + env -u REWATCH_TYPECHECK_TRACE /usr/bin/time \ + -f 'elapsed_s=%e user_s=%U sys_s=%S peak_rss_kib=%M' \ + -o "$results/$mode-$iteration.time" \ + "$executable" build "$fixture" >"$results/$mode-$iteration.build.log" 2>&1 + fi + printf '%s run %d: ' "$mode" "$iteration" + cat "$results/$mode-$iteration.time" + done +done diff --git a/rewatch-ocaml/bench/watch_performance_gate.sh b/rewatch-ocaml/bench/watch_performance_gate.sh index 58dbf7737be..8234ef888d5 100755 --- a/rewatch-ocaml/bench/watch_performance_gate.sh +++ b/rewatch-ocaml/bench/watch_performance_gate.sh @@ -16,7 +16,8 @@ if ((runs < 5 || runs % 2 == 0)); then echo "RUNS must be an odd number of at least five." >&2 exit 2 fi -for command in awk cat cmp cp date find grep mktemp node sed seq setsid sleep sort tail wc; do +for command in awk cat cmp cp date find git grep mktemp node sed seq setsid \ + sha256sum sleep sort tail wc; do command -v "$command" >/dev/null || { echo "Missing required command: $command" >&2 exit 2 @@ -38,6 +39,14 @@ real_bsc=$RESCRIPT_BSC_EXE runtime=$RESCRIPT_RUNTIME counting_bsc="$repo_root/_build/default/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.exe" +echo "Rewatch retained-watch performance gate" +echo "commit: $(git -C "$repo_root" rev-parse HEAD)" +echo "runtime: $runtime" +echo "compiler domains: ${REWATCH_WATCH_COMPILER_DOMAINS:-default}" +echo "executable and compiler SHA-256:" +sha256sum "$rust_executable" "$ocaml_executable" "$real_bsc" +echo "runs: $runs (interleaved after one warm-up edit each)" + work_root=$(mktemp -d "${TMPDIR:-/tmp}/rewatch-watch-performance.XXXXXX") declare -A pids=() terminate_group() { @@ -135,12 +144,12 @@ resource_value() { } start_watcher() { - local implementation=$1 executable=$2 fixture + local implementation=$1 executable=$2 count_external=${3:-0} fixture fixture="$work_root/$implementation" cp -R "$repo_root/rewatch-ocaml/tests/basic" "$fixture" : >"$work_root/$implementation.bsc" : >"$work_root/$implementation.compiler" - if [[ $implementation == ocaml ]]; then + if [[ $implementation == ocaml || ${REWATCH_FIRST_EMBEDDED:-0} == 1 ]]; then local -a domain_count_env=() if [[ ${REWATCH_WATCH_COMPILER_DOMAINS+x} ]]; then domain_count_env=(REWATCH_COMPILER_DOMAINS="$REWATCH_WATCH_COMPILER_DOMAINS") @@ -154,7 +163,7 @@ start_watcher() { "$executable" watch --after-build "node $marker_script" "$fixture" \ >"$work_root/$implementation.stdout" \ 2>"$work_root/$implementation.stderr" & - else + elif [[ $count_external == 1 ]]; then setsid env \ RESCRIPT_BSC_EXE="$counting_bsc" \ REWATCH_BSC_PROXY_MODE=counting \ @@ -165,6 +174,14 @@ start_watcher() { "$executable" watch --after-build "node $marker_script" "$fixture" \ >"$work_root/$implementation.stdout" \ 2>"$work_root/$implementation.stderr" & + else + setsid env \ + RESCRIPT_BSC_EXE="$real_bsc" \ + RESCRIPT_RUNTIME="$runtime" \ + 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 @@ -187,6 +204,8 @@ for implementation in rust ocaml; do wait_for_idle "${pids[$implementation]}" : >"$work_root/$implementation.bsc" : >"$work_root/$implementation.compiler" + cp "$work_root/$implementation/src/B.mjs" \ + "$work_root/$implementation.prior.mjs" done declare -A baseline_fd baseline_tasks baseline_rss max_fd max_tasks max_rss @@ -205,7 +224,8 @@ measure_edit() { local implementation=$1 round=$2 expected=$((round + 2)) local started finished latency pid value started=$(date +%s%3N) - printf 'let answer = A.value + 1\n// retained edit %d\n' "$round" \ + printf 'let answer = A.value + %d\n// retained edit %d\n' \ + "$((round + 1))" "$round" \ >"$work_root/$implementation/src/B.res" wait_for_lines "$work_root/$implementation.marker" "$expected" finished=$(tail -n 1 "$work_root/$implementation.marker") @@ -214,6 +234,13 @@ measure_edit() { wait_for_text_count "$work_root/$implementation.stdout" \ "Finished incremental compilation" "$((round + 1))" wait_for_idle "${pids[$implementation]}" + if cmp -s "$work_root/$implementation.prior.mjs" \ + "$work_root/$implementation/src/B.mjs"; then + echo "$implementation output did not change after retained edit $round." >&2 + exit 1 + fi + cp "$work_root/$implementation/src/B.mjs" \ + "$work_root/$implementation.prior.mjs" pid=${pids[$implementation]} for kind in fd tasks rss; do value=$(resource_value "$pid" "$kind") @@ -237,25 +264,69 @@ for round in $(seq 1 "$runs"); do echo "Generated output differs after retained edit $round." >&2 exit 1 fi + cp "$work_root/rust/src/B.mjs" "$work_root/rust-round-$round.mjs" done +if [[ ${REWATCH_FIRST_EMBEDDED:-0} != 1 ]]; then + # Count external compiler requests in an untimed replay. A proxy in the + # timed watcher would add a process launch to every parse and compile. + start_watcher rust_work "$rust_executable" 1 + printf 'let answer = A.value + 1\n// warm retained edit\n' \ + >"$work_root/rust_work/src/B.res" + wait_for_lines "$work_root/rust_work.marker" 2 + wait_for_text_count "$work_root/rust_work.stdout" \ + "Finished incremental compilation" 1 + wait_for_idle "${pids[rust_work]}" + : >"$work_root/rust_work.bsc" + cp "$work_root/rust_work/src/B.mjs" "$work_root/rust_work.prior.mjs" + for round in $(seq 1 "$runs"); do + printf 'let answer = A.value + %d\n// retained edit %d\n' \ + "$((round + 1))" "$round" \ + >"$work_root/rust_work/src/B.res" + wait_for_lines "$work_root/rust_work.marker" "$((round + 2))" + wait_for_text_count "$work_root/rust_work.stdout" \ + "Finished incremental compilation" "$((round + 1))" + wait_for_idle "${pids[rust_work]}" + if cmp -s "$work_root/rust_work.prior.mjs" \ + "$work_root/rust_work/src/B.mjs"; then + echo "Replay output did not change after retained edit $round." >&2 + exit 1 + fi + cp "$work_root/rust_work/src/B.mjs" "$work_root/rust_work.prior.mjs" + cmp "$work_root/rust_work/src/B.mjs" \ + "$work_root/rust-round-$round.mjs" + done + rm -f "$work_root/rust_work/lib/watch.lock" + wait "${pids[rust_work]}" + unset 'pids[rust_work]' +fi + median() { sort -n "$1" | sed -n "$((runs / 2 + 1))p" } rust_median=$(median "$work_root/rust.latencies") ocaml_median=$(median "$work_root/ocaml.latencies") -rust_parse_count=$(grep -cF -- '-bs-ast' "$work_root/rust.bsc" || true) -rust_total_count=$(wc -l <"$work_root/rust.bsc") +if [[ ${REWATCH_FIRST_EMBEDDED:-0} == 1 ]]; then + rust_parse_count=$(grep -c '^parse' "$work_root/rust.compiler" || true) + rust_compile_count=$(grep -c '^implementation' \ + "$work_root/rust.compiler" || true) + rust_total_count=$(wc -l <"$work_root/rust.compiler") +else + rust_parse_count=$(grep -cF -- '-bs-ast' "$work_root/rust_work.bsc" || true) + rust_total_count=$(wc -l <"$work_root/rust_work.bsc") + rust_compile_count=$((rust_total_count - rust_parse_count)) +fi 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 || +if ((rust_parse_count != runs || rust_compile_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" \ + printf 'retained work mismatch: first executable %d parser / %d compiler / %d total; embedded OCaml %d parser / %d compiler / %d total; expected %d / %d.\n' \ + "$rust_parse_count" "$rust_compile_count" "$rust_total_count" "$ocaml_parse_count" \ "$ocaml_compile_count" "$ocaml_total_count" "$runs" "$((runs * 2))" >&2 exit 1 fi diff --git a/rewatch-ocaml/build.ml b/rewatch-ocaml/build.ml index 5bf7e766128..47540efb595 100644 --- a/rewatch-ocaml/build.ml +++ b/rewatch-ocaml/build.ml @@ -86,10 +86,32 @@ type incremental_source = { let run_scheduled_modules (attempt : Build_attempt.t) (prepared : Build_session.prepared) ~compile_step ~namespace_count = - Compiler_scheduler.run ~poll:attempt.process_poll + let candidates = Build_attempt.take_compile_candidates attempt in + let ready = + List.filter Compiler_scheduler.candidate_requires_compile candidates + in + let ready_keys = Hashtbl.create (List.length ready) in + List.iter + (fun candidate -> + Hashtbl.replace ready_keys (Compiler_scheduler.candidate_key candidate) ()) + ready; + let has_dirty_dependency = + List.exists + (fun candidate -> + List.exists (Hashtbl.mem ready_keys) + (Compiler_scheduler.candidate_dependencies candidate)) + candidates + in + Rescript_compiler_driver.set_frozen_for_compile + (Build_session.compiler_session attempt.session) + (List.length ready >= 4 || has_dirty_dependency); + Compiler_scheduler.run + ~on_ast_invalidation:(fun path -> + Build_attempt.invalidate_parse_export attempt ~path) + ~poll:attempt.process_poll ~warning_state:(Build_session.warning_state attempt.session) ~compile_assets:prepared.compile_assets ~build_state:prepared.build_state - ~candidates:(Build_attempt.take_compile_candidates attempt) + ~candidates ~mark_compiled:(fun () -> attempt.compiled <- attempt.compiled + 1) ~mark_had_warnings:(fun () -> attempt.had_warnings <- true) ~progress:attempt.progress ~compile_step ~namespace_count @@ -196,8 +218,9 @@ let prepare_incremental previous changes (attempt : Build_attempt.t) |> List.map (fun source -> Compiler_process.parse_job ~bsc ~build_dir:source.package.build_dir ~config:source.package.compile_config source.source.relative_path) - |> Compiler_process.run_jobs ?poll:attempt.process_poll - ~on_complete:parse_completed + |> Compiler_process.run_jobs + ~session:(Build_session.compiler_session attempt.session) + ?poll:attempt.process_poll ~on_complete:parse_completed in let affected_modules = Hashtbl.create (List.length sources) in let dependency_updates = ref [] in @@ -228,6 +251,7 @@ let prepare_incremental previous changes (attempt : Build_attempt.t) if not changed_parse_failed then let dependencies path = Compiler_process.ast_dependencies + ~session:(Build_session.compiler_session attempt.session) ~build_dir:package.Package_plan.build_dir (Source.ast_path path) in let raw_dependencies = @@ -319,9 +343,17 @@ let run_with_warning_state ~poll ~warning_state ~request ~no_timing ~verbosity | Some previous -> Build_attempt.create_retained ~session:previous.session ~process_poll ~progress ~verbosity - | None -> - Build_attempt.create_full ~warning_state ~process_poll ~progress - ~verbosity + | None -> ( + match request with + | Full_watch_attempt (Some previous) -> + Build_attempt.create_full_with_compiler_session + ~compiler_session:(Build_session.compiler_session previous.session) + ~warning_state ~process_poll ~progress ~verbosity + | One_shot_attempt | Initial_watch_attempt + | Full_watch_attempt None + | Retained_watch_attempt _ -> + Build_attempt.create_full ~warning_state ~process_poll ~progress + ~verbosity) in let parse_messages () = List.rev attempt.parse_messages in let parse_output messages = @@ -445,10 +477,15 @@ let run_with_warning_state ~poll ~warning_state ~request ~no_timing ~verbosity in Package_build.prepare_tree ~seen:visited ~package:root_package ~prepared ~watch ~attempt; + Build_attempt.start_parse_exports attempt; + if Sys.getenv_opt "REWATCH_ASYNC_AST_EXPORT" = Some "0" then + Build_attempt.finish_parse_exports attempt; Build_session.mark_freshness_initialized attempt.session; let parse_messages = parse_messages () in let parse_output = parse_output parse_messages in - if parse_failed parse_messages then raise (Parse_failure parse_output); + if parse_failed parse_messages then ( + Build_attempt.finish_parse_exports attempt; + raise (Parse_failure parse_output)); poll (); let namespace_count = try run_namespace_jobs attempt @@ -471,6 +508,15 @@ let run_with_warning_state ~poll ~warning_state ~request ~no_timing ~verbosity None with Build_failure output -> Some output in + let compile_failure = + try + Build_attempt.finish_parse_exports attempt; + compile_failure + with error -> + Some + ("Failed to publish parser artifacts: " ^ Printexc.to_string error + ^ "\n") + in Output.Progress.finish progress; let compile_seconds = phase_seconds (Unix.gettimeofday () -. compile_started) diff --git a/rewatch-ocaml/build_artifacts.ml b/rewatch-ocaml/build_artifacts.ml index 9c309eba8b8..24ef863c5f0 100644 --- a/rewatch-ocaml/build_artifacts.ml +++ b/rewatch-ocaml/build_artifacts.ml @@ -213,8 +213,8 @@ let cleanup_stale ?ocaml_files ?ast_sources ?source_files ?present_source_files add_expected source_base [".ast"; ".res"]; if Option.is_some module_.Source.interface then ( add_expected source_base [".iast"; ".resi"]; - add_expected compiler_base [".cmti"]); - add_expected compiler_base [".cmi"; ".cmj"; ".cmt"]) + add_expected compiler_base [".cmti"; ".cmti.gts"]); + add_expected compiler_base [".cmi"; ".cmj"; ".cmt"; ".cmt.gts"]) modules; Config.namespace_compiler_name config.namespace |> Option.iter (fun namespace -> @@ -253,8 +253,12 @@ let cleanup_stale ?ocaml_files ?ast_sources ?source_files ?present_source_files let extension = Filename.extension basename in if extension = ".mlmap" then [Filename.concat build_dir basename] else - Hashtbl.find_opt mapped_source_directories - (Filename.remove_extension basename) + let compiler_base = + if extension = ".gts" then + basename |> Filename.remove_extension |> Filename.remove_extension + else Filename.remove_extension basename + in + Hashtbl.find_opt mapped_source_directories compiler_base |> Option.value ~default:[] |> List.map (fun directory -> Filename.concat build_dir (Filename.concat directory basename)) diff --git a/rewatch-ocaml/build_attempt.ml b/rewatch-ocaml/build_attempt.ml index da09f9bc188..4d2a890a612 100644 --- a/rewatch-ocaml/build_attempt.ml +++ b/rewatch-ocaml/build_attempt.ml @@ -27,6 +27,14 @@ let preliminary_parse result = type cleanup_batch = {actions: (unit -> unit) list; artifacts: string list} type namespace_job = {task: Process.task; finish: Process.result -> unit} +type parse_export = { + staged_ast: string; + published_ast: string; + source: string; + compile_assets: Compile_assets.t; + mutable owned_ast: (string * float) option; +} + type pending_work = { mutable namespace_jobs: namespace_job list; mutable compile_candidates: Compiler_scheduler.candidate list; @@ -56,6 +64,10 @@ type t = { blocked_modules: (string, unit) Hashtbl.t; namespace_freshness: (string, float option) Hashtbl.t; pending_work: pending_work; + mutable parse_exports: parse_export list; + mutable parse_export_worker: unit Domain.t option; + parse_export_lock: Mutex.t; + invalidated_parse_exports: (string, unit) Hashtbl.t; finalization: finalization_state; mutable compiler_cleaned: bool; mutable had_warnings: bool; @@ -88,6 +100,10 @@ let create ~freshness_mode ~session ~process_poll ~progress ~verbosity = blocked_modules = Hashtbl.create 16; namespace_freshness = Hashtbl.create 16; pending_work = {namespace_jobs = []; compile_candidates = []}; + parse_exports = []; + parse_export_worker = None; + parse_export_lock = Mutex.create (); + invalidated_parse_exports = Hashtbl.create 16; finalization = { results = cleanup_results; @@ -104,6 +120,14 @@ let create ~freshness_mode ~session ~process_poll ~progress ~verbosity = verbosity; } +let create_full_with_compiler_session ~compiler_session ~warning_state + ~process_poll ~progress ~verbosity = + create ~freshness_mode:Initialize_freshness + ~session: + (Build_session.create_with_compiler_session ~compiler_session + ~warning_state) + ~process_poll ~progress ~verbosity + let create_full ~warning_state ~process_poll ~progress ~verbosity = create ~freshness_mode:Initialize_freshness ~session:(Build_session.create ~warning_state) @@ -119,6 +143,85 @@ let create_retained ~session ~process_poll ~progress ~verbosity = let register_cleanup attempt action = attempt.finalization.actions <- action :: attempt.finalization.actions +let add_parse_export ?owned_ast attempt ~staged_ast ~published_ast ~source + ~compile_assets = + attempt.parse_exports <- + {staged_ast; published_ast; source; compile_assets; owned_ast} + :: attempt.parse_exports + +let with_parse_export_lock attempt action = + Mutex.lock attempt.parse_export_lock; + Fun.protect action ~finally:(fun () -> Mutex.unlock attempt.parse_export_lock) + +let start_parse_exports attempt = + if attempt.parse_exports <> [] && Option.is_none attempt.parse_export_worker + then + let exports = List.rev attempt.parse_exports in + attempt.parse_export_worker <- + Some + (Domain.spawn (fun () -> + List.iter + (fun export -> + with_parse_export_lock attempt (fun () -> + if + not + (Hashtbl.mem attempt.invalidated_parse_exports + export.published_ast) + then ( + Option.iter + (fun (contents, parsed_at) -> + File_util.write_file_atomic ~ensure_parent:false + export.staged_ast contents; + Unix.utimes export.staged_ast parsed_at parsed_at; + Rescript_compiler_driver + .record_session_ast_persistence + (Build_session.compiler_session attempt.session) + ~path:export.staged_ast; + export.owned_ast <- None) + export.owned_ast; + File_util.copy_existing_file ~ensure_parent:false + export.staged_ast export.published_ast; + (* Compilation can finish before this copy. Keep the + parser's time so the next build sees it as older than + the CMT. The scheduler cannot invalidate this AST + between the copy and timestamp update. *) + let stats = Unix.stat export.staged_ast in + Unix.utimes export.published_ast stats.st_atime + stats.st_mtime))) + exports)) + +let invalidate_parse_export attempt ~path = + with_parse_export_lock attempt (fun () -> + Hashtbl.replace attempt.invalidated_parse_exports path ()) + +let finish_parse_exports attempt = + start_parse_exports attempt; + Option.iter + (fun worker -> + attempt.parse_export_worker <- None; + let error = + try + Domain.join worker; + None + with error -> Some error + in + List.iter + (fun export -> + if + Option.is_some error + || Hashtbl.mem attempt.invalidated_parse_exports + export.published_ast + then File_util.remove_file export.published_ast; + Compile_assets.refresh_ast export.compile_assets ~source:export.source + ~path:export.published_ast; + if Option.is_some error then + Build_session.mark_parse_pending attempt.session + (Platform.normalize_path_for_comparison export.source)) + attempt.parse_exports; + attempt.parse_exports <- []; + Option.iter raise error) + attempt.parse_export_worker + let defer_artifact_cleanup attempt paths = attempt.finalization.artifacts <- paths @ attempt.finalization.artifacts @@ -199,7 +302,11 @@ let finalize_logs attempt = let finish_attempt attempt = run_all - [(fun () -> cleanup_artifacts attempt); (fun () -> finalize_logs attempt)] + [ + (fun () -> finish_parse_exports attempt); + (fun () -> cleanup_artifacts attempt); + (fun () -> finalize_logs attempt); + ] let protect attempt action = match action () with diff --git a/rewatch-ocaml/build_attempt.mli b/rewatch-ocaml/build_attempt.mli index 25e9746e807..19fc6eb1b15 100644 --- a/rewatch-ocaml/build_attempt.mli +++ b/rewatch-ocaml/build_attempt.mli @@ -27,6 +27,7 @@ type preliminary_parse = val preliminary_parse : Process.result -> preliminary_parse type namespace_job = {task: Process.task; finish: Process.result -> unit} +type parse_export type pending_work type finalization_state @@ -45,6 +46,10 @@ type t = { blocked_modules: (string, unit) Hashtbl.t; namespace_freshness: (string, float option) Hashtbl.t; pending_work: pending_work; + mutable parse_exports: parse_export list; + mutable parse_export_worker: unit Domain.t option; + parse_export_lock: Mutex.t; + invalidated_parse_exports: (string, unit) Hashtbl.t; finalization: finalization_state; mutable compiler_cleaned: bool; mutable had_warnings: bool; @@ -60,6 +65,14 @@ val create_full : verbosity:int -> t +val create_full_with_compiler_session : + compiler_session:Rescript_compiler_driver.session -> + warning_state:Warning_state.t -> + process_poll:(unit -> unit) option -> + progress:Output.Progress.t -> + verbosity:int -> + t + val create_retained : session:Build_session.t -> process_poll:(unit -> unit) option -> @@ -68,6 +81,17 @@ val create_retained : t val register_cleanup : t -> (unit -> unit) -> unit +val add_parse_export : + ?owned_ast:string * float -> + t -> + staged_ast:string -> + published_ast:string -> + source:string -> + compile_assets:Compile_assets.t -> + unit +val start_parse_exports : t -> unit +val invalidate_parse_export : t -> path:string -> unit +val finish_parse_exports : t -> unit val defer_artifact_cleanup : t -> string list -> unit val set_cleanup_result : t -> string -> Build_artifacts.cleanup_result -> unit val find_cleanup_result : t -> string -> Build_artifacts.cleanup_result option diff --git a/rewatch-ocaml/build_preparation.ml b/rewatch-ocaml/build_preparation.ml index 586e96636df..9eb0ddd27e1 100644 --- a/rewatch-ocaml/build_preparation.ml +++ b/rewatch-ocaml/build_preparation.ml @@ -18,6 +18,12 @@ let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch Package_graph.discover ~root_config ~prod ~features ~warn_error ~filter ~attempt in + let gentype_disk_publication = + List.exists + (fun (package : Package_plan.t) -> + Compiler_args.gentype_enabled package.compile_config) + package_plans + in Module_graph.validate_visible_namespaces ~root_config package_plans; let runtime = runtime_path root_config.root in let source_map_args = Compiler_args.source_map_args root_config ~watch in @@ -27,6 +33,18 @@ let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch ~source_map_args ~inherited_compiler_args: (root_config.jsx_args @ root_config.experimental_args) + ~editor_artifacts:(Compiler_args.editor_artifacts_enabled ()) + ~gentype_inputs:(Compiler_args.gentype_inputs_enabled root_config) + ~gentype_disk_publication + ~binary_annotations:(Compiler_args.binary_annotations_enabled root_config) + ~compatibility_copies: + (Compiler_args.compatibility_copies_enabled root_config) + ~session_handoff: + (Rescript_compiler_driver.session_handoff_enabled + (Build_session.compiler_session attempt.session)) + ~frozen_values: + (Rescript_compiler_driver.session_frozen_lookup_enabled + (Build_session.compiler_session attempt.session)) ~package_output_specs:(Compiler_info.package_output_specs root_config) in let previous_compile_assets = @@ -180,8 +198,9 @@ let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch |> List.map (fun ((package : Package_plan.t), path, _) -> Compiler_process.parse_job ~bsc ~build_dir:package.build_dir ~config:package.compile_config path) - |> Compiler_process.run_jobs ?poll:attempt.process_poll - ~on_complete:parse_completed + |> Compiler_process.run_jobs + ~session:(Build_session.compiler_session attempt.session) + ?poll:attempt.process_poll ~on_complete:parse_completed in let failed_parse_paths = Hashtbl.create 8 in List.iter2 @@ -196,8 +215,9 @@ let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch ()) parse_entries parse_results; let graph = - Module_graph.initialize ~root_config ~package_plans ~compile_assets - ~failed_parse_paths + Module_graph.initialize ~root_config + ~compiler_session:(Build_session.compiler_session attempt.session) + ~package_plans ~compile_assets ~failed_parse_paths in List.iter (fun path -> diff --git a/rewatch-ocaml/build_session.ml b/rewatch-ocaml/build_session.ml index d5ec0aa55ce..62537bbf68d 100644 --- a/rewatch-ocaml/build_session.ml +++ b/rewatch-ocaml/build_session.ml @@ -23,6 +23,7 @@ type cycle_cache = | Known_cycle of Module_graph.cycle_info option type t = { + compiler_session: Rescript_compiler_driver.session; global_modules: (string, Module_graph.module_node) Hashtbl.t; namespace_maps: (string, Module_graph.namespace_map) Hashtbl.t; namespace_maps_by_name: (string, Module_graph.namespace_map list) Hashtbl.t; @@ -37,8 +38,12 @@ type t = { warning_state: Warning_state.t; } -let create ~warning_state = +let create_with_compiler_session ~compiler_session ~warning_state = + Rescript_compiler_driver.set_session_owned_ast_enabled compiler_session true; + Rescript_compiler_driver.set_session_owned_artifacts_enabled compiler_session + true; { + compiler_session; global_modules = Hashtbl.create 64; namespace_maps = Hashtbl.create 16; namespace_maps_by_name = Hashtbl.create 16; @@ -53,6 +58,11 @@ let create ~warning_state = warning_state; } +let create ~warning_state = + create_with_compiler_session + ~compiler_session:(Rescript_compiler_driver.create_session ()) + ~warning_state + let is_ready session = match session.readiness with | Ready _ -> true @@ -146,3 +156,4 @@ let set_public_outputs session root outputs = let iter_public_outputs session f = Hashtbl.iter f session.public_outputs let warning_state session = session.warning_state +let compiler_session session = session.compiler_session diff --git a/rewatch-ocaml/build_session.mli b/rewatch-ocaml/build_session.mli index 847532a5193..9ba81d1f9a3 100644 --- a/rewatch-ocaml/build_session.mli +++ b/rewatch-ocaml/build_session.mli @@ -26,6 +26,10 @@ type cycle_cache = | Known_cycle of Module_graph.cycle_info option val create : warning_state:Warning_state.t -> t +val create_with_compiler_session : + compiler_session:Rescript_compiler_driver.session -> + warning_state:Warning_state.t -> + t val is_ready : t -> bool val prepared : t -> prepared option val install_prepared : t -> prepared -> unit @@ -58,3 +62,4 @@ val iter_public_outputs : t -> (string -> (string, unit) Hashtbl.t -> unit) -> unit val warning_state : t -> Warning_state.t +val compiler_session : t -> Rescript_compiler_driver.session diff --git a/rewatch-ocaml/build_state.ml b/rewatch-ocaml/build_state.ml index 853f5b8e0ac..8b3f4136b25 100644 --- a/rewatch-ocaml/build_state.ml +++ b/rewatch-ocaml/build_state.ml @@ -114,9 +114,14 @@ let record_published_cmi ?dirty_propagation state ~compile_assets module_ ~path Compile_assets.cmi compile_assets module_.key |> Option.map (fun entry -> entry.Compile_assets.modified) +let record_published_optimization ?dirty_propagation state module_ ~changed = + if changed then + mark_dependents_compile_dirty ?visited:dirty_propagation state module_ + let record_successful_compile ~compile_assets module_ ~cmt_path = - Compile_assets.refresh_cmt compile_assets ~key:module_.key ~path:cmt_path; + Compile_assets.refresh_compile_marker compile_assets ~key:module_.key + ~cmt_path; module_.last_compiled_cmt <- - Compile_assets.cmt compile_assets module_.key + Compile_assets.compile_marker compile_assets module_.key |> Option.map (fun entry -> entry.Compile_assets.modified); module_.compile_dirty <- false diff --git a/rewatch-ocaml/build_state.mli b/rewatch-ocaml/build_state.mli index d3cc853e012..7edb623f818 100644 --- a/rewatch-ocaml/build_state.mli +++ b/rewatch-ocaml/build_state.mli @@ -58,5 +58,14 @@ val record_published_cmi : cmi_change -> unit +val record_published_optimization : + ?dirty_propagation:(string, unit) Hashtbl.t -> + t -> + module_ -> + changed:bool -> + unit +(** An optimization-metadata change can alter downstream JavaScript without + changing the exported interface. *) + val record_successful_compile : compile_assets:Compile_assets.t -> module_ -> cmt_path:string -> unit diff --git a/rewatch-ocaml/compile_assets.ml b/rewatch-ocaml/compile_assets.ml index 20d8bc6c9ca..a519eb1f0b5 100644 --- a/rewatch-ocaml/compile_assets.ml +++ b/rewatch-ocaml/compile_assets.ml @@ -7,6 +7,7 @@ type t = { ast_dependencies: (string, string list) Hashtbl.t; ast_by_source: (string, entry) Hashtbl.t; cmi_by_module: (string, entry) Hashtbl.t; + cmj_by_module: (string, entry) Hashtbl.t; cmt_by_module: (string, entry) Hashtbl.t; } @@ -15,13 +16,24 @@ let ast_header path = with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> None let cleanup_extensions = - [".cmi"; ".cmj"; ".cmt"; ".cmti"; ".ast"; ".iast"; ".res"; ".resi"; ".mlmap"] + [ + ".cmi"; + ".cmj"; + ".cmt"; + ".cmti"; + ".gts"; + ".ast"; + ".iast"; + ".res"; + ".resi"; + ".mlmap"; + ] let is_managed_basename basename = List.exists (Filename.check_suffix basename) cleanup_extensions let state_extension = function - | ".ast" | ".iast" | ".cmi" | ".cmt" -> true + | ".ast" | ".iast" | ".cmi" | ".cmj" | ".cmt" -> true | _ -> false let read_directory directory = @@ -57,6 +69,7 @@ let source_key = Platform.normalize_path_for_comparison let add_module_artifact state (entry, name) = match Filename.extension name with | ".cmi" -> Hashtbl.replace state.cmi_by_module (module_key name) entry + | ".cmj" -> Hashtbl.replace state.cmj_by_module (module_key name) entry | ".cmt" -> Hashtbl.replace state.cmt_by_module (module_key name) entry | _ -> () @@ -68,6 +81,7 @@ let create directories = ast_dependencies = Hashtbl.create 64; ast_by_source = Hashtbl.create 64; cmi_by_module = Hashtbl.create 64; + cmj_by_module = Hashtbl.create 64; cmt_by_module = Hashtbl.create 64; } in @@ -117,6 +131,10 @@ let ast state source = Hashtbl.find_opt state.ast_by_source (source_key source) let cmi state key = Hashtbl.find_opt state.cmi_by_module key let cmt state key = Hashtbl.find_opt state.cmt_by_module key +let compile_marker state key = + match cmt state key with + | Some _ as cmt -> cmt + | None -> Hashtbl.find_opt state.cmj_by_module key let replace_from_path table key path = try @@ -130,5 +148,10 @@ let refresh_cmi state ~key ~path = let refresh_cmt state ~key ~path = replace_from_path state.cmt_by_module key path +let refresh_compile_marker state ~key ~cmt_path = + refresh_cmt state ~key ~path:cmt_path; + replace_from_path state.cmj_by_module key + (Filename.remove_extension cmt_path ^ ".cmj") + let refresh_ast state ~source ~path = replace_from_path state.ast_by_source (source_key source) path diff --git a/rewatch-ocaml/compile_assets.mli b/rewatch-ocaml/compile_assets.mli index 53180ff4d62..adbec7724ef 100644 --- a/rewatch-ocaml/compile_assets.mli +++ b/rewatch-ocaml/compile_assets.mli @@ -14,6 +14,11 @@ val ast_dependencies : t -> string -> string list val ast : t -> string -> entry option val cmi : t -> string -> entry option val cmt : t -> string -> entry option + +(* Prefer a CMT when present; use the mandatory CMJ when binary annotations + are disabled for the module. *) +val compile_marker : t -> string -> entry option val refresh_cmi : t -> key:string -> path:string -> unit val refresh_cmt : t -> key:string -> path:string -> unit +val refresh_compile_marker : t -> key:string -> cmt_path:string -> unit val refresh_ast : t -> source:string -> path:string -> unit diff --git a/rewatch-ocaml/compiler_args.ml b/rewatch-ocaml/compiler_args.ml index a0bec78e953..30c29e46813 100644 --- a/rewatch-ocaml/compiler_args.ml +++ b/rewatch-ocaml/compiler_args.ml @@ -81,6 +81,20 @@ let gentype_dependency_args_from_paths (config : Config.t) dependencies = | None -> [] | Some path -> ["-bs-gentype-dep-path"; dependency.name ^ "=" ^ path]) +let gentype_enabled (config : Config.t) = + config.gentype_args <> [] || List.mem "-bs-gentype" config.compiler_flags + +let editor_artifacts_enabled () = Sys.getenv_opt "REWATCH_BIN_ANNOT" = Some "1" + +let gentype_inputs_enabled = gentype_enabled + +let binary_annotations_enabled (_config : Config.t) = + editor_artifacts_enabled () + +let compatibility_copies_enabled config = + binary_annotations_enabled config + || Sys.getenv_opt "REWATCH_COMPAT_COPIES" = Some "1" + let namespace_args (config : Config.t) module_name = match config.namespace with | Config.No_namespace -> [] @@ -93,6 +107,8 @@ let parser_arguments ~(config : Config.t) ~contents ~path = compiler_flags ~ppx_flags:(filter_ppx_flags config.ppx_flags contents) ~source_maps:false ~watch:false ~gentype:false config + (* The marker keeps GenType parse requests on the disk AST path. *) + @ (if gentype_enabled config then ["-bs-gentype"] else []) @ [ "-absname"; "-bs-ast"; @@ -110,6 +126,7 @@ let compiler_common_arguments ~(config : Config.t) ~runtime ~dependency_dirs @ List.concat_map (fun directory -> ["-I"; directory]) dependency_dirs @ compiler_flags ~source_maps:true ~watch ~gentype:true config @ gentype_dependency_args + @ (if binary_annotations_enabled config then [] else ["-bs-no-bin-annot"]) @ ["-bs-package-name"; config.name; "-bs-project-root"; config.root] let compiler_arguments_with_common ~(config : Config.t) ~common_args diff --git a/rewatch-ocaml/compiler_args.mli b/rewatch-ocaml/compiler_args.mli index df45b4a802f..0444df57fc6 100644 --- a/rewatch-ocaml/compiler_args.mli +++ b/rewatch-ocaml/compiler_args.mli @@ -14,6 +14,11 @@ val compiler_flags : val with_local_warning_policy : is_local:bool -> Config.t -> Config.t val gentype_dependency_args_from_paths : Config.t -> (Config.dependency * string) list -> string list +val editor_artifacts_enabled : unit -> bool +val gentype_inputs_enabled : Config.t -> bool +val binary_annotations_enabled : Config.t -> bool +val compatibility_copies_enabled : Config.t -> bool +val gentype_enabled : Config.t -> bool val parser_arguments : config:Config.t -> contents:string -> path:string -> string list diff --git a/rewatch-ocaml/compiler_info.ml b/rewatch-ocaml/compiler_info.ml index 063aec87568..e20e00cb10e 100644 --- a/rewatch-ocaml/compiler_info.ml +++ b/rewatch-ocaml/compiler_info.ml @@ -5,6 +5,13 @@ type context = { runtime_path: string; source_map_args: string list; inherited_compiler_args: string list; + editor_artifacts: bool; + gentype_inputs: bool; + gentype_disk_publication: bool; + binary_annotations: bool; + compatibility_copies: bool; + session_handoff: bool; + frozen_values: bool; package_output_specs: package_output_spec list; } @@ -14,7 +21,7 @@ and package_output_spec = { suffix: string; } -let format_version = "4" +let format_version = "10" let package_output_specs (config : Config.t) = List.map @@ -26,8 +33,10 @@ let package_output_specs (config : Config.t) = }) config.package_specs -let make_context ~build_root ~compiler_path ~compiler_identity ~runtime_path - ~source_map_args ~inherited_compiler_args ~package_output_specs = +let make_context ~editor_artifacts ~gentype_inputs ~gentype_disk_publication + ~session_handoff ~compatibility_copies ~build_root ~compiler_path + ~compiler_identity ~runtime_path ~source_map_args ~inherited_compiler_args + ~binary_annotations ~frozen_values ~package_output_specs = { build_root; bsc_path = compiler_path; @@ -35,11 +44,26 @@ let make_context ~build_root ~compiler_path ~compiler_identity ~runtime_path runtime_path; source_map_args; inherited_compiler_args; + editor_artifacts; + gentype_inputs; + gentype_disk_publication; + binary_annotations; + compatibility_copies; + session_handoff; + frozen_values; package_output_specs; } let for_package context ~build_root config = - {context with build_root; package_output_specs = package_output_specs config} + { + context with + build_root; + editor_artifacts = Compiler_args.editor_artifacts_enabled (); + gentype_inputs = Compiler_args.gentype_inputs_enabled config; + binary_annotations = Compiler_args.binary_annotations_enabled config; + compatibility_copies = Compiler_args.compatibility_copies_enabled config; + package_output_specs = package_output_specs config; + } let path root = File_util.path_of_parts root ["lib"; "bs"; "compiler-info.json"] @@ -103,6 +127,13 @@ let json context (config : Config.t) = (List.map (fun value -> `String value) context.inherited_compiler_args) ); + ("editor_artifacts", `Bool context.editor_artifacts); + ("gentype_inputs", `Bool context.gentype_inputs); + ("gentype_disk_publication", `Bool context.gentype_disk_publication); + ("binary_annotations", `Bool context.binary_annotations); + ("compatibility_copies", `Bool context.compatibility_copies); + ("session_handoff", `Bool context.session_handoff); + ("frozen_values", `Bool context.frozen_values); ( "package_output_specs", `List (List.map package_output_spec_json context.package_output_specs) ); diff --git a/rewatch-ocaml/compiler_info.mli b/rewatch-ocaml/compiler_info.mli index e96b3faa331..68d7566c2af 100644 --- a/rewatch-ocaml/compiler_info.mli +++ b/rewatch-ocaml/compiler_info.mli @@ -5,12 +5,20 @@ type context = { runtime_path: string; source_map_args: string list; inherited_compiler_args: string list; + editor_artifacts: bool; + gentype_inputs: bool; + gentype_disk_publication: bool; + binary_annotations: bool; + compatibility_copies: bool; + session_handoff: bool; + frozen_values: bool; package_output_specs: package_output_spec list; } (** Compiler information fingerprints effective inputs rather than only the package's own JSON. Root-level JSX, experimental options, runtime identity, - and output layout can all change dependency output without changing a - dependency configuration file. *) + output layout, and independent editor, GenType, and session policies can + all change dependency output without changing a dependency configuration + file. *) and package_output_spec = { module_format: Config.module_format; @@ -21,12 +29,19 @@ and package_output_spec = { val package_output_specs : Config.t -> package_output_spec list val make_context : + editor_artifacts:bool -> + gentype_inputs:bool -> + gentype_disk_publication:bool -> + session_handoff:bool -> + compatibility_copies:bool -> build_root:string -> compiler_path:string -> compiler_identity:string -> runtime_path:string -> source_map_args:string list -> inherited_compiler_args:string list -> + binary_annotations:bool -> + frozen_values:bool -> package_output_specs:package_output_spec list -> context diff --git a/rewatch-ocaml/compiler_process.ml b/rewatch-ocaml/compiler_process.ml index 9d447949cf7..44a2d779fa1 100644 --- a/rewatch-ocaml/compiler_process.ml +++ b/rewatch-ocaml/compiler_process.ml @@ -24,23 +24,56 @@ let compiler_phase args = in (phase, input) +let log_lock = Mutex.create () + +let append_log path line = + Mutex.lock log_lock; + Fun.protect + ~finally:(fun () -> Mutex.unlock log_lock) + (fun () -> + let channel = + open_out_gen [Open_creat; Open_append; Open_text] 0o644 path + in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> output_string channel line)) + let log_compiler_request (job : Process.job) = match Sys.getenv_opt "REWATCH_COMPILER_CALL_LOG" with | None -> () | Some path -> let phase, input = compiler_phase job.args in - let channel = - open_out_gen [Open_creat; Open_append; Open_text] 0o644 path - in + append_log path (Printf.sprintf "%s\t%s\t%s\n" phase job.cwd input) + +let compiler_timing_log = Sys.getenv_opt "REWATCH_COMPILER_TIMING_LOG" +let artifact_export_log = Sys.getenv_opt "REWATCH_ARTIFACT_EXPORT_LOG" + +let log_artifact_export event path = + Option.iter + (fun log -> + append_log log + (Printf.sprintf "%s\t%s\t%.9f\n" event path (Unix.gettimeofday ()))) + artifact_export_log + +let time_compiler_request (job : Process.job) run = + match compiler_timing_log with + | None -> run () + | Some path -> + let started = Unix.gettimeofday () in Fun.protect - ~finally:(fun () -> close_out_noerr channel) - (fun () -> Printf.fprintf channel "%s\t%s\t%s\n" phase job.cwd input) + ~finally:(fun () -> + let finished = Unix.gettimeofday () in + let phase, input = compiler_phase job.args in + append_log path + (Printf.sprintf "%s\t%s\t%s\t%.9f\t%.9f\n" phase job.cwd input started + finished)) + run let exit_code = function | Unix.WEXITED code -> code | Unix.WSIGNALED signal | Unix.WSTOPPED signal -> 128 + signal -let run_in_process ?poll (job : Process.job) = +let run_in_process ?session ?poll (job : Process.job) = log_compiler_request job; match List.rev job.args with | [] -> @@ -51,19 +84,28 @@ let run_in_process ?poll (job : Process.job) = } | input :: reversed_argv -> let result = - Rescript_compiler_driver.run_request ~cwd:job.cwd - ~argv:(List.rev reversed_argv) ~input - ~run_external: - (Some - (fun command -> - let command = Platform.shell_command command in - (* Signal handlers are process-wide; domain workers launch PPXs - without replacing the scheduler domain's handlers. *) - let result = - Process.run ?poll ~defer_signals:false ~cwd:job.cwd - command.program command.args - in - (exit_code result.status, result.stdout, result.stderr))) + time_compiler_request job (fun () -> + Env.with_expanded_snapshot_cache (fun () -> + let run_external = + Some + (fun command -> + let command = Platform.shell_command command in + (* Signal handlers are process-wide; domain workers launch + PPXs without replacing the scheduler domain's handlers. *) + let result = + Process.run ?poll ~defer_signals:false ~cwd:job.cwd + command.program command.args + in + (exit_code result.status, result.stdout, result.stderr)) + in + match session with + | None -> + Rescript_compiler_driver.run_request ~cwd:job.cwd + ~argv:(List.rev reversed_argv) ~input ~run_external + | Some session -> + Rescript_compiler_driver.run_request_in_session session + ~cwd:job.cwd ~argv:(List.rev reversed_argv) ~input + ~run_external)) in { Process.status = Unix.WEXITED result.exit_code; @@ -71,24 +113,25 @@ let run_in_process ?poll (job : Process.job) = stderr = result.stderr; } -let run ?poll job = +let run ?session ?poll job = Option.iter (fun poll -> poll ()) poll; - let result = run_in_process ?poll job in + let result = run_in_process ?session ?poll job in Option.iter (fun poll -> poll ()) poll; result -let task job = +let task ?session job = let cancelled = Atomic.make false in Process.concurrent_task ~cancel:(fun () -> Atomic.set cancelled true) (fun () -> - run_in_process + run_in_process ?session ~poll:(fun () -> if Atomic.get cancelled then raise (Process.Interrupted 15)) job) -let run_jobs ?poll ?on_complete jobs = - jobs |> List.map task +let run_jobs ?session ?poll ?on_complete jobs = + jobs + |> List.map (task ?session) |> Process.run_tasks ~max_jobs:(Compiler_execution_mode.configured_count ()) ?poll ?on_complete @@ -103,13 +146,54 @@ let parse_job ~bsc ~build_dir ~(config : Config.t) path = let args = Compiler_args.parser_arguments ~config ~contents ~path in Process.{program = bsc; args; cwd = build_dir} -let ast_dependencies ~build_dir ast = - (Ast_header.read (Filename.concat build_dir ast)).dependencies +let ast_dependencies ?session ~build_dir ast = + let path = Filename.concat build_dir ast in + match + Option.bind session (fun session -> + Rescript_compiler_driver.staged_ast_dependencies session ~path) + with + | Some dependencies -> dependencies + | None -> (Ast_header.read path).dependencies type compiler_artifact = Cmi | Required of string | Optional of string +type artifact_changes = { + cmi_change: Compiler_scheduler.cmi_change; + optimization_changed: bool; +} + +let session_fingerprint session kind filename = + Option.bind session (fun session -> + Rescript_compiler_driver.published_fingerprint session ~kind ~filename) + +let changes_from_fingerprints ~previous_interface ~previous_optimization + ~interface_file ~optimization_file ~session changes = + let current_interface = + session_fingerprint session Rescript_compiler_driver.Interface + interface_file + in + let current_optimization = + Option.bind optimization_file (fun filename -> + session_fingerprint session Rescript_compiler_driver.Optimization + filename) + in + let cmi_change = + match (previous_interface, current_interface) with + | Some previous, Some current -> + if previous = current then Compiler_scheduler.Cmi_unchanged + else Compiler_scheduler.Cmi_changed + | _ -> changes.cmi_change + in + let optimization_changed = + match (previous_optimization, current_optimization) with + | Some previous, Some current -> previous <> current + | _ -> changes.optimization_changed + in + {cmi_change; optimization_changed} -let publish_compiler_artifacts ~artifact_dir ~ocaml_dir ~basename artifacts = +let publish_compiler_artifacts ?(preserve_source_mtime = false) ~artifact_dir + ~ocaml_dir ~basename artifacts = let cmi_change = ref Compiler_scheduler.Cmi_change_unknown in + let optimization_changed = ref false in try List.iter (fun artifact -> @@ -126,24 +210,44 @@ let publish_compiler_artifacts ~artifact_dir ~ocaml_dir ~basename artifacts = in match artifact with | Cmi -> + let changed = + File_util.copy_file_if_different ~ensure_parent:false source + destination + in cmi_change := - if - File_util.copy_file_if_different ~ensure_parent:false source - destination - then Compiler_scheduler.Cmi_changed - else Compiler_scheduler.Cmi_unchanged + if changed then Compiler_scheduler.Cmi_changed + else Compiler_scheduler.Cmi_unchanged; + if preserve_source_mtime && changed then + let stats = Unix.stat source in + Unix.utimes destination stats.st_atime stats.st_mtime + | Required "cmj" -> + let changed = + File_util.copy_file_if_different ~ensure_parent:false source + destination + in + optimization_changed := changed; + if preserve_source_mtime && changed then + let stats = Unix.stat source in + Unix.utimes destination stats.st_atime stats.st_mtime | Required _ -> File_util.copy_existing_file ~ensure_parent:false source destination + | Optional ("cmt" | "cmti") -> + File_util.copy_optional_existing_file_atomic ~ensure_parent:false + source destination | Optional _ -> File_util.copy_optional_existing_file ~ensure_parent:false source destination) artifacts; - !cmi_change + {cmi_change = !cmi_change; optimization_changed = !optimization_changed} with error -> - raise (Compiler_scheduler.Publication_failure (error, !cmi_change)) + raise + (Compiler_scheduler.Publication_failure + ( error, + if !optimization_changed then Compiler_scheduler.Cmi_change_unknown + else !cmi_change )) -let namespace_task ~bsc ~runtime ~build_dir ~ocaml_dir ~entry ~package_dirty - ~force namespace modules = +let namespace_task ?session ~bsc ~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 @@ -186,7 +290,7 @@ let namespace_task ~bsc ~runtime ~build_dir ~ocaml_dir ~entry ~package_dirty Compiler_scheduler. { task = - task + task ?session Process. { program = bsc; @@ -209,12 +313,67 @@ let namespace_task ~bsc ~runtime ~build_dir ~ocaml_dir ~entry ~package_dirty raise (Compiler_scheduler.Build_failure (result.Process.stderr ^ result.stdout)); - let cmi_change = + let interface_file = + Filename.concat ocaml_dir (namespace ^ ".cmi") + in + let optimization_file = + Filename.concat ocaml_dir (namespace ^ ".cmj") + in + let previous_interface = + session_fingerprint session Rescript_compiler_driver.Interface + interface_file + in + let previous_optimization = + session_fingerprint session + Rescript_compiler_driver.Optimization optimization_file + in + let changes = publish_compiler_artifacts ~artifact_dir:build_dir ~ocaml_dir ~basename:namespace [Cmi; Required "cmj"; Required "cmt"; Required "mlmap"] in - Compiler_scheduler.{stderr = result.stderr; cmi_change}); + Option.iter + (fun session -> + Rescript_compiler_driver.publish_session_cmi session + ~retain:true + ~source:(Filename.concat build_dir (namespace ^ ".cmi")) + ~destination: + (Filename.concat ocaml_dir (namespace ^ ".cmi")); + Rescript_compiler_driver.publish_session_cmj session + ~retain:true + ~source:(Filename.concat build_dir (namespace ^ ".cmj")) + ~destination: + (Filename.concat ocaml_dir (namespace ^ ".cmj")); + Rescript_compiler_driver.publish_session_semantic session + ~retain:false + ~source:(Filename.concat build_dir (namespace ^ ".cmt")) + ~destination: + (Filename.concat ocaml_dir (namespace ^ ".cmt")); + Rescript_compiler_driver.publish_module_result session + ~input:mlmap ~interface_file + ~optimization_file:(Some optimization_file) + ~semantic_file:None ~dependencies:[] + ~generated_outputs: + (List.map + (fun extension -> + Filename.concat ocaml_dir + (namespace ^ "." ^ extension)) + ["cmi"; "cmj"; "cmt"; "mlmap"])) + session; + let changes = + changes_from_fingerprints ~previous_interface + ~previous_optimization ~interface_file + ~optimization_file:(Some optimization_file) ~session changes + in + Compiler_scheduler. + { + stderr = result.stderr; + cmi_change = changes.cmi_change; + optimization_changed = changes.optimization_changed; + deferred_export = None; + cancel_export = None; + staged_cmi_path = None; + }); } let post_build_tasks (config : Config.t) path = @@ -249,38 +408,93 @@ let compile_job ~bsc ~build_dir ~(config : Config.t) ~common_args in Process.{program = bsc; args; cwd = build_dir} -let publish ~build_dir ~ocaml_dir ~is_local ~(config : Config.t) ~source_kind - path result = +let publish_immediate ?session ~preserve_source_mtime ~retain_interface + ~dependencies ~build_dir ~ocaml_dir ~is_local ~(config : Config.t) + ~source_kind ~compiled_at path result = let stderr = if is_local then result.Process.stderr else retain_critical_external_warnings result.stderr in let basename = Source.compiler_asset_basename config path in let artifact_dir = Filename.concat build_dir (Filename.dirname path) in + let editor_artifacts = Compiler_args.binary_annotations_enabled config in + let gentype_inputs = Compiler_args.gentype_inputs_enabled config in + let interface_file = Filename.concat ocaml_dir (basename ^ ".cmi") in + let optimization_file = + match source_kind with + | Source.Interface -> None + | Source.Implementation -> + Some (Filename.concat ocaml_dir (basename ^ ".cmj")) + in + let previous_interface = + session_fingerprint session Rescript_compiler_driver.Interface + interface_file + in + let previous_optimization = + Option.bind optimization_file (fun filename -> + session_fingerprint session Rescript_compiler_driver.Optimization + filename) + in let cmi_change = ref Compiler_scheduler.Cmi_change_unknown in + let optimization_changed = ref false in try - cmi_change := - publish_compiler_artifacts ~artifact_dir ~ocaml_dir ~basename - (match source_kind with - | Source.Interface -> [Cmi; Optional "cmti"] - | Source.Implementation -> [Cmi; Required "cmj"; Optional "cmt"]); - let source = Filename.concat config.root path in - let build_source = Filename.concat build_dir path in - File_util.ensure_dir (Filename.dirname build_source); - File_util.copy_existing_file ~ensure_parent:false source build_source; - File_util.copy_existing_file ~ensure_parent:false source - (Filename.concat ocaml_dir (Filename.basename path)); + let required_artifacts = + match source_kind with + | Source.Interface -> [Cmi] + | Source.Implementation -> [Cmi; Required "cmj"] + in + let optional_editor_artifacts = + if editor_artifacts then + match source_kind with + | Source.Interface -> [Optional "cmti"] + | Source.Implementation -> [Optional "cmt"] + else [] + in + let optional_gentype_inputs = + if gentype_inputs then + match source_kind with + | Source.Interface -> [Optional "cmti.gts"] + | Source.Implementation -> [Optional "cmt.gts"] + else [] + in + let changes = + publish_compiler_artifacts ~preserve_source_mtime ~artifact_dir ~ocaml_dir + ~basename + (required_artifacts @ optional_editor_artifacts + @ optional_gentype_inputs) + in + cmi_change := changes.cmi_change; + optimization_changed := changes.optimization_changed; (match source_kind with | Source.Interface -> () | Source.Implementation -> + if + not + (File_util.is_regular_file + (Filename.concat artifact_dir (basename ^ ".cmt"))) + then + Option.iter + (fun filename -> Unix.utimes filename compiled_at compiled_at) + optimization_file); + if Compiler_args.compatibility_copies_enabled config then ( + let source = Filename.concat config.root path in + let build_source = Filename.concat build_dir path in + File_util.ensure_dir (Filename.dirname build_source); + File_util.copy_existing_file ~ensure_parent:false source build_source; + File_util.copy_existing_file ~ensure_parent:false source + (Filename.concat ocaml_dir (Filename.basename path))); + (match source_kind with + | Source.Interface -> () + | Source.Implementation + when Compiler_args.compatibility_copies_enabled config -> List.iter (fun spec -> if spec.Config.in_source then ( - let output = Build_artifacts.generated_js_path config path spec in let build_output = Build_artifacts.generated_build_js_path ~build_dir config path spec in + let output = Build_artifacts.generated_js_path config path spec in File_util.ensure_dir (Filename.dirname build_output); if File_util.exists output then File_util.copy_existing_file ~ensure_parent:false output @@ -289,8 +503,285 @@ let publish ~build_dir ~ocaml_dir ~is_local ~(config : Config.t) ~source_kind File_util.copy_existing_file ~ensure_parent:false (output ^ ".map") (build_output ^ ".map") else File_util.remove_file (build_output ^ ".map"))) - config.package_specs); - Compiler_scheduler.{stderr; cmi_change = !cmi_change} + config.package_specs + | Source.Implementation -> ()); + Option.iter + (fun session -> + Rescript_compiler_driver.publish_session_cmi session + ~retain:retain_interface + ~source:(Filename.concat artifact_dir (basename ^ ".cmi")) + ~destination:(Filename.concat ocaml_dir (basename ^ ".cmi")); + (match source_kind with + | Source.Interface -> () + | Source.Implementation -> + Rescript_compiler_driver.publish_session_cmj session + ~retain:retain_interface + ~source:(Filename.concat artifact_dir (basename ^ ".cmj")) + ~destination:(Filename.concat ocaml_dir (basename ^ ".cmj"))); + let cmt_extension = + match source_kind with + | Source.Interface -> ".cmti" + | Source.Implementation -> ".cmt" + in + if editor_artifacts then + Rescript_compiler_driver.publish_session_semantic session + ~retain:is_local + ~source:(Filename.concat artifact_dir (basename ^ cmt_extension)) + ~destination:(Filename.concat ocaml_dir (basename ^ cmt_extension)); + let semantic_file = + if editor_artifacts then + let filename = + Filename.concat ocaml_dir (basename ^ cmt_extension) + in + if File_util.is_regular_file filename then Some filename else None + else None + in + let generated_outputs = + let compiler_outputs = + List.map + (fun extension -> + Filename.concat ocaml_dir (basename ^ extension)) + ([".cmi"; ".cmj"] + @ (if editor_artifacts then [".cmt"; ".cmti"] else []) + @ if gentype_inputs then [".cmt.gts"; ".cmti.gts"] else []) + @ [Build_artifacts.published_ast_path ~ocaml_dir path] + in + let js_outputs = + match source_kind with + | Source.Interface -> [] + | Source.Implementation -> + List.concat_map + (fun spec -> + let path = + Build_artifacts.generated_js_path config path spec + in + [path; path ^ ".map"]) + config.package_specs + in + List.filter File_util.is_regular_file (compiler_outputs @ js_outputs) + in + Rescript_compiler_driver.publish_module_result session + ~input:(Filename.concat build_dir (Source.ast_path path)) + ~interface_file ~optimization_file ~semantic_file ~dependencies + ~generated_outputs) + session; + let changes = + changes_from_fingerprints ~previous_interface ~previous_optimization + ~interface_file ~optimization_file ~session changes + in + Compiler_scheduler. + { + stderr; + cmi_change = changes.cmi_change; + optimization_changed = changes.optimization_changed; + deferred_export = None; + cancel_export = None; + staged_cmi_path = None; + } with | Compiler_scheduler.Publication_failure _ as error -> raise error - | error -> raise (Compiler_scheduler.Publication_failure (error, !cmi_change)) + | error -> + raise + (Compiler_scheduler.Publication_failure + ( error, + if !optimization_changed then Compiler_scheduler.Cmi_change_unknown + else !cmi_change )) + +let publish ?session ~force_disk_publication ~retain_interface ~dependencies + ~build_dir ~ocaml_dir ~is_local ~(config : Config.t) ~source_kind path + result = + Option.iter + (fun session -> + let basename = Source.compiler_asset_basename config path in + let artifact_dir = Filename.concat build_dir (Filename.dirname path) in + Rescript_compiler_driver.persist_owned_cmi session + ~path:(Filename.concat artifact_dir (basename ^ ".cmi")); + Rescript_compiler_driver.persist_owned_cmj session + ~path:(Filename.concat artifact_dir (basename ^ ".cmj")); + Rescript_compiler_driver.persist_owned_cmt session + ~path: + (Filename.concat artifact_dir + (basename + ^ + match source_kind with + | Source.Interface -> ".cmti" + | Source.Implementation -> ".cmt"))) + session; + (* This is the producer completion time, before its dependents can start. + A no-CMT build uses it as the CMJ freshness marker even if CMJ bytes did + not change and the compiler reused its old staging file. *) + let compiled_at = Unix.gettimeofday () in + let immediate preserve_source_mtime = + publish_immediate ?session ~preserve_source_mtime ~retain_interface + ~dependencies ~build_dir ~ocaml_dir ~is_local ~config ~source_kind + ~compiled_at path result + in + (* Classic lookup cannot resolve a staged virtual CMI. GenType also needs + disk ASTs and dependency CMIs to validate its interface summaries. + Publish these artifacts before releasing dependents. *) + match session with + | None -> immediate false + | Some session + when (not retain_interface) || force_disk_publication + || (not (Rescript_compiler_driver.session_handoff_enabled session)) + || not (Rescript_compiler_driver.session_frozen_lookup_enabled session) + -> + immediate false + | Some session -> + let basename = Source.compiler_asset_basename config path in + let artifact_dir = Filename.concat build_dir (Filename.dirname path) in + let source extension = + Filename.concat artifact_dir (basename ^ "." ^ extension) + in + let destination extension = + Filename.concat ocaml_dir (basename ^ "." ^ extension) + in + let interface_file = destination "cmi" in + let optimization_file = + match source_kind with + | Source.Interface -> None + | Source.Implementation -> Some (destination "cmj") + in + let previous_interface = + session_fingerprint (Some session) Rescript_compiler_driver.Interface + interface_file + in + let previous_optimization = + Option.bind optimization_file (fun filename -> + session_fingerprint (Some session) + Rescript_compiler_driver.Optimization filename) + in + let staged_interface = + Rescript_compiler_driver.stage_session_cmi session ~source:(source "cmi") + ~destination:interface_file + in + let staged_optimization = + match optimization_file with + | None -> true + | Some filename -> + Rescript_compiler_driver.stage_session_cmj session + ~source:(source "cmj") ~destination:filename + in + let interface_available = + staged_interface + || Option.is_some + (session_fingerprint (Some session) + Rescript_compiler_driver.Interface interface_file) + in + if (not interface_available) || not staged_optimization then immediate false + else + let current_interface = + session_fingerprint (Some session) Rescript_compiler_driver.Interface + interface_file + in + let current_optimization = + Option.bind optimization_file (fun filename -> + session_fingerprint (Some session) + Rescript_compiler_driver.Optimization filename) + in + let cmi_change = + match (previous_interface, current_interface) with + | Some old, Some current -> + if old = current then Compiler_scheduler.Cmi_unchanged + else Compiler_scheduler.Cmi_changed + | _ -> + if File_util.files_equal (source "cmi") interface_file then + Compiler_scheduler.Cmi_unchanged + else Compiler_scheduler.Cmi_changed + in + let optimization_changed = + match + (optimization_file, previous_optimization, current_optimization) + with + | None, _, _ -> false + | Some _, Some old, Some current -> old <> current + | Some filename, _, _ -> + not (File_util.files_equal (source "cmj") filename) + in + let cancel () = + Rescript_compiler_driver.discard_pending_session_artifacts session + ~interface_file ~optimization_file + in + let generated_outputs = + let compiler_outputs = + [destination "cmi"; destination "cmj"] + @ (if Compiler_args.binary_annotations_enabled config then + [destination "cmt"; destination "cmti"] + else []) + @ (if Compiler_args.gentype_inputs_enabled config then + [destination "cmt.gts"; destination "cmti.gts"] + else []) + @ [Build_artifacts.published_ast_path ~ocaml_dir path] + in + let js_outputs = + match source_kind with + | Source.Interface -> [] + | Source.Implementation -> + List.concat_map + (fun spec -> + let output = + Build_artifacts.generated_js_path config path spec + in + [output; output ^ ".map"]) + config.package_specs + in + compiler_outputs @ js_outputs + in + (try + Rescript_compiler_driver.stage_module_result session + ~input:(Filename.concat build_dir (Source.ast_path path)) + ~interface_source:(source "cmi") ~interface_file + ~optimization_source: + (Option.map (fun _ -> source "cmj") optimization_file) + ~optimization_file + ~semantic_source: + (if Compiler_args.binary_annotations_enabled config then + Some + (source + (match source_kind with + | Source.Interface -> "cmti" + | Source.Implementation -> "cmt")) + else None) + ~dependencies ~generated_outputs + with error -> + cancel (); + raise error); + let export () = + log_artifact_export "start" path; + Fun.protect + ~finally:(fun () -> log_artifact_export "end" path) + (fun () -> + let optimization_changed = + match optimization_file with + | Some filename -> + Option.is_none current_optimization + || session_fingerprint (Some session) + Rescript_compiler_driver.Optimization filename + <> current_optimization + | None -> false + in + if + Option.is_none current_interface + || session_fingerprint (Some session) + Rescript_compiler_driver.Interface interface_file + <> current_interface + || optimization_changed + then + failwith + ("compiler result changed before artifact export: " ^ path); + ignore (immediate true); + cancel ()) + in + let stderr = + if is_local then result.Process.stderr + else retain_critical_external_warnings result.stderr + in + Compiler_scheduler. + { + stderr; + cmi_change; + optimization_changed; + deferred_export = Some export; + cancel_export = Some cancel; + staged_cmi_path = Some (source "cmi"); + } diff --git a/rewatch-ocaml/compiler_process.mli b/rewatch-ocaml/compiler_process.mli index 7a7b575ee42..fbc5ee0f214 100644 --- a/rewatch-ocaml/compiler_process.mli +++ b/rewatch-ocaml/compiler_process.mli @@ -2,16 +2,27 @@ val retain_critical_external_warnings : string -> string val build_identity : string val parse_job : bsc:string -> build_dir:string -> config:Config.t -> string -> Process.job -val ast_dependencies : build_dir:string -> string -> string list -val run : ?poll:(unit -> unit) -> Process.job -> Process.result +val ast_dependencies : + ?session:Rescript_compiler_driver.session -> + build_dir:string -> + string -> + string list +val run : + ?session:Rescript_compiler_driver.session -> + ?poll:(unit -> unit) -> + Process.job -> + Process.result val run_jobs : + ?session:Rescript_compiler_driver.session -> ?poll:(unit -> unit) -> ?on_complete:(int -> unit) -> Process.job list -> Process.result list -val task : Process.job -> Process.task +val task : + ?session:Rescript_compiler_driver.session -> Process.job -> Process.task val namespace_task : + ?session:Rescript_compiler_driver.session -> bsc:string -> runtime:string -> build_dir:string -> @@ -37,6 +48,10 @@ val post_build_tasks : Config.t -> string -> Compiler_scheduler.post_build_task list val publish : + ?session:Rescript_compiler_driver.session -> + force_disk_publication:bool -> + retain_interface:bool -> + dependencies:string list -> build_dir:string -> ocaml_dir:string -> is_local:bool -> diff --git a/rewatch-ocaml/compiler_scheduler.ml b/rewatch-ocaml/compiler_scheduler.ml index 7a9f7a94094..8a0c578a9ce 100644 --- a/rewatch-ocaml/compiler_scheduler.ml +++ b/rewatch-ocaml/compiler_scheduler.ml @@ -6,7 +6,14 @@ type cmi_change = Build_state.cmi_change = | Cmi_change_unknown exception Publication_failure of exn * cmi_change -type publish_result = {stderr: string; cmi_change: cmi_change} +type publish_result = { + stderr: string; + cmi_change: cmi_change; + optimization_changed: bool; + deferred_export: (unit -> unit) option; + cancel_export: (unit -> unit) option; + staged_cmi_path: string option; +} type namespace_task = { task: Process.task; publish: Process.result -> publish_result; @@ -54,6 +61,7 @@ type scheduled_module = { mark_warning: string -> unit; mutable messages: string list; mutable phase: phase; + mutable staged_cmi_path: string option; } type candidate = { @@ -63,6 +71,9 @@ type candidate = { make: unit -> scheduled_module; } +let candidate_key candidate = candidate.key +let candidate_dependencies candidate = candidate.state.dependencies + type scheduled_item = Module of scheduled_module | Namespace_barrier let create ~key ~dependencies ~source ~state ~cmi_path ~prepare ~compile @@ -85,6 +96,7 @@ let create ~key ~dependencies ~source ~state ~cmi_path ~prepare ~compile mark_warning; messages = []; phase = Start; + staged_cmi_path = None; } let candidate ~key ~state ~warning_paths ~make = @@ -92,16 +104,87 @@ let candidate ~key ~state ~warning_paths ~make = let candidate_requires_compile candidate = candidate.state.compile_dirty -let run ~poll ~warning_state ~compile_assets ~build_state ~candidates - ~mark_compiled ~mark_had_warnings ~progress ~compile_step ~namespace_count - ~verbosity = +let run ~on_ast_invalidation ~poll ~warning_state ~compile_assets ~build_state + ~candidates ~mark_compiled ~mark_had_warnings ~progress ~compile_step + ~namespace_count ~verbosity = let dirty_propagation = Hashtbl.create 16 in - let refresh_published_cmi (scheduled : scheduled_module) cmi_change = + let deferred_exports = ref [] in + let async_exports = Queue.create () in + let async_lock = Mutex.create () in + let async_ready = Condition.create () in + let async_closed = ref false in + let async_aborted = ref false in + let async_results = ref [] in + let async_worker = ref None in + (* Export ordinary implementation artifacts while other compiler jobs run. + The scheduler still owns build-state commits after the worker is joined. *) + let rec export_loop () = + let next = + Mutex.lock async_lock; + Fun.protect + (fun () -> + while Queue.is_empty async_exports && not !async_closed do + Condition.wait async_ready async_lock + done; + if !async_aborted || Queue.is_empty async_exports then None + else Some (Queue.take async_exports)) + ~finally:(fun () -> Mutex.unlock async_lock) + in + match next with + | None -> () + | Some (key, export) -> + let result = try Ok (export ()) with error -> Error error in + async_results := (key, result) :: !async_results; + export_loop () + in + let enqueue_async_export key export = + if Option.is_none !async_worker then + async_worker := Some (Domain.spawn export_loop); + Mutex.lock async_lock; + Fun.protect + (fun () -> + Queue.add (key, export) async_exports; + Condition.signal async_ready) + ~finally:(fun () -> Mutex.unlock async_lock) + in + let finish_async_exports ~abort = + Option.iter + (fun worker -> + Mutex.lock async_lock; + Fun.protect + (fun () -> + async_closed := true; + async_aborted := abort; + Condition.broadcast async_ready) + ~finally:(fun () -> Mutex.unlock async_lock); + Domain.join worker) + !async_worker; + let results = Hashtbl.create (List.length !async_results) in + List.iter + (fun (key, result) -> Hashtbl.replace results key result) + !async_results; + results + in + let is_async_export (scheduled : scheduled_module) source_kind = + (* An explicit interface and a JS post-build hook have their own ordered + publication phases, so only independent implementations use this path. *) + source_kind = Source.Implementation + && Option.is_none scheduled.source.Source.interface + && scheduled.post_build scheduled.source.Source.implementation = [] + in + let refresh_published_cmi (scheduled : scheduled_module) ~path cmi_change = Build_state.record_published_cmi ~dirty_propagation build_state - ~compile_assets scheduled.state ~path:scheduled.cmi_path cmi_change + ~compile_assets scheduled.state ~path cmi_change + in + let refresh_published_optimization (scheduled : scheduled_module) changed = + Build_state.record_published_optimization ~dirty_propagation build_state + scheduled.state ~changed in let finish_successful_compile (scheduled : scheduled_module) = - let cmt_path = Filename.remove_extension scheduled.cmi_path ^ ".cmt" in + let cmi_path = + Option.value scheduled.staged_cmi_path ~default:scheduled.cmi_path + in + let cmt_path = Filename.remove_extension cmi_path ^ ".cmt" in Build_state.record_successful_compile ~compile_assets scheduled.state ~cmt_path in @@ -192,30 +275,51 @@ let run ~poll ~warning_state ~compile_assets ~build_state ~candidates let record_publication (scheduled : scheduled_module) ~source_kind path = let publication = Atomic.exchange scheduled.publication None in match publication with - | Some (Published {stderr; cmi_change}) -> - refresh_published_cmi scheduled cmi_change; + | Some + (Published + { + stderr; + cmi_change; + optimization_changed; + deferred_export; + cancel_export; + staged_cmi_path; + }) -> + let cmi_path = Option.value staged_cmi_path ~default:scheduled.cmi_path in + scheduled.staged_cmi_path <- staged_cmi_path; + refresh_published_cmi scheduled ~path:cmi_path cmi_change; + refresh_published_optimization scheduled optimization_changed; + (match (deferred_export, cancel_export) with + | Some export, Some cancel -> + deferred_exports := + (scheduled, source_kind, export, cancel) :: !deferred_exports; + if is_async_export scheduled source_kind then + enqueue_async_export scheduled.key export + | None, None -> () + | Some _, None | None, Some _ -> + raise (Project_context.Error "incomplete deferred export")); scheduled.record_published_outputs ~source_kind path; Publication_succeeded stderr | Some (Failed_after_cmi_publication {error; cmi_change}) -> - refresh_published_cmi scheduled cmi_change; + refresh_published_cmi scheduled ~path:scheduled.cmi_path cmi_change; scheduled.record_published_outputs ~source_kind path; 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 + if Process.succeeded result then + let publication = + capture_publication (fun () -> + scheduled.publish ~source_kind path result) + in + Atomic.set scheduled.publication (Some publication) in let record_result (scheduled : scheduled_module) ~source_kind path result = - (* Domain tasks only compile. Publication and build-state updates remain on - this scheduler domain after their result has been collected. *) - let result = publish_compilation scheduled ~source_kind path result in + (* Keep publication on the scheduler for modules that unlock dependents. + Leaf publication runs on the compiler worker instead. *) + if not (Build_state.String_set.is_empty scheduled.state.dependents) then + publish_compilation scheduled ~source_kind path result; let result, publication_error = match record_publication scheduled ~source_kind path with | Publication_succeeded stderr -> ({result with Process.stderr}, None) @@ -254,7 +358,11 @@ let run ~poll ~warning_state ~compile_assets ~build_state ~candidates let compilation_task (scheduled : scheduled_module) ~source_kind path = let task = scheduled.compile ~source_kind path in Atomic.set scheduled.publication None; - task + if Build_state.String_set.is_empty scheduled.state.dependents then + Process.map_result task (fun result -> + publish_compilation scheduled ~source_kind path result; + result) + else task in let record_post_build_result (scheduled : scheduled_module) output result = if Process.succeeded result then ( @@ -276,6 +384,7 @@ let run ~poll ~warning_state ~compile_assets ~build_state ~candidates :: Option.to_list scheduled.source.Source.interface |> List.iter (fun source -> let path = Build_artifacts.published_ast_path ~ocaml_dir source in + on_ast_invalidation path; File_util.remove_file path; Compile_assets.refresh_ast compile_assets ~source:(Filename.concat scheduled.package_root source) @@ -403,8 +512,41 @@ let run ~poll ~warning_state ~compile_assets ~build_state ~candidates reconcile_unconsumed_publications (); match exn with | Module_failed -> true - | _ -> raise exn) + | _ -> + ignore (finish_async_exports ~abort:true); + List.iter + (fun ((scheduled : scheduled_module), _, _, cancel) -> + cancel (); + scheduled.state.compile_dirty <- true; + invalidate_persistent_freshness scheduled) + !deferred_exports; + raise exn) in + let async_export_results = finish_async_exports ~abort:false in + List.rev !deferred_exports + |> List.iter (fun (scheduled, source_kind, export, cancel) -> + try + if is_async_export scheduled source_kind then + match Hashtbl.find_opt async_export_results scheduled.key with + | Some (Ok ()) -> () + | Some (Error error) -> raise error + | None -> + raise + (Project_context.Error + ("missing artifact export for " ^ scheduled.key)) + else export (); + refresh_published_cmi scheduled ~path:scheduled.cmi_path Cmi_unchanged; + if + source_kind = Source.Implementation + && scheduled.phase = Done && scheduled.messages = [] + then + Build_state.record_successful_compile ~compile_assets scheduled.state + ~cmt_path:(Filename.remove_extension scheduled.cmi_path ^ ".cmt") + with error -> + cancel (); + scheduled.state.compile_dirty <- true; + invalidate_persistent_freshness scheduled; + scheduled.messages <- Printexc.to_string error :: scheduled.messages); Output.Progress.finish progress; Output.trace ~verbosity (Printf.sprintf "Compiled %d out of %d in the universe" !completed_modules diff --git a/rewatch-ocaml/compiler_scheduler.mli b/rewatch-ocaml/compiler_scheduler.mli index 3038a5b2b21..cade00b4fcd 100644 --- a/rewatch-ocaml/compiler_scheduler.mli +++ b/rewatch-ocaml/compiler_scheduler.mli @@ -10,7 +10,14 @@ type cmi_change = Build_state.cmi_change = | Cmi_change_unknown exception Publication_failure of exn * cmi_change -type publish_result = {stderr: string; cmi_change: cmi_change} +type publish_result = { + stderr: string; + cmi_change: cmi_change; + optimization_changed: bool; + deferred_export: (unit -> unit) option; + cancel_export: (unit -> unit) option; + staged_cmi_path: string option; +} type namespace_task = { task: Process.task; publish: Process.result -> publish_result; @@ -57,8 +64,11 @@ val candidate : candidate val candidate_requires_compile : candidate -> bool +val candidate_key : candidate -> string +val candidate_dependencies : candidate -> string list val run : + on_ast_invalidation:(string -> unit) -> poll:(unit -> unit) option -> warning_state:Warning_state.t -> compile_assets:Compile_assets.t -> diff --git a/rewatch-ocaml/file_util.ml b/rewatch-ocaml/file_util.ml index f91f1956c90..475bd31a7b7 100644 --- a/rewatch-ocaml/file_util.ml +++ b/rewatch-ocaml/file_util.ml @@ -159,6 +159,46 @@ let copy_optional_existing_file ?(ensure_parent = true) source destination = try Unix.unlink destination with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> ()) +let copy_existing_file_atomic ~ensure_parent source destination = + if ensure_parent then ensure_dir (Filename.dirname destination); + let signals = Signal_restore.create ~defer:true in + let temporary = ref None in + let remove_temporary path = + try Unix.unlink path with Sys_error _ | Unix.Unix_error _ -> () + in + Fun.protect + ~finally:(fun () -> Option.iter remove_temporary !temporary) + (fun () -> + let candidate = + Signal_restore.protect signals (fun () -> + let candidate = + Filename.temp_file + ~temp_dir:(Filename.dirname destination) + ".rewatch-copy-" ".tmp" + in + temporary := Some candidate; + candidate) + in + let permissions = + match Unix.stat destination with + | metadata -> metadata.Unix.st_perm + | exception Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> + (Unix.stat source).Unix.st_perm + in + Unix.chmod candidate permissions; + copy_existing_file ~ensure_parent:false source candidate; + let publish_signals = Signal_restore.create ~defer:true in + Signal_restore.protect publish_signals (fun () -> + Sys.rename candidate destination; + temporary := None)) + +let copy_optional_existing_file_atomic ?(ensure_parent = true) source + destination = + try copy_existing_file_atomic ~ensure_parent source destination + with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> ( + try Unix.unlink destination + with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> ()) + let stat_opt path = try Some (Unix.stat path) with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> None diff --git a/rewatch-ocaml/file_util.mli b/rewatch-ocaml/file_util.mli index 1a98e579200..06f615c5ed1 100644 --- a/rewatch-ocaml/file_util.mli +++ b/rewatch-ocaml/file_util.mli @@ -16,6 +16,9 @@ val copy_existing_file : ensure_parent:bool -> string -> string -> unit val copy_optional_existing_file : ?ensure_parent:bool -> string -> string -> unit +val copy_optional_existing_file_atomic : + ?ensure_parent:bool -> string -> string -> unit + val exists : string -> bool val files_equal : string -> string -> bool val copy_file_if_different : ?ensure_parent:bool -> string -> string -> bool diff --git a/rewatch-ocaml/module_graph.ml b/rewatch-ocaml/module_graph.ml index 8c55185428c..849cae38ddd 100644 --- a/rewatch-ocaml/module_graph.ml +++ b/rewatch-ocaml/module_graph.ml @@ -161,8 +161,8 @@ type initialized = { use_existing_ast_paths: string list; } -let initialize ~(root_config : Config.t) ~package_plans ~compile_assets - ~failed_parse_paths = +let initialize ~(root_config : Config.t) ~compiler_session ~package_plans + ~compile_assets ~failed_parse_paths = let nodes = ref [] in let use_existing_ast_paths = ref [] in List.iter @@ -182,8 +182,8 @@ let initialize ~(root_config : Config.t) ~package_plans ~compile_assets Hashtbl.mem failed_parse_paths (Filename.concat package.root path) then [] else - Compiler_process.ast_dependencies ~build_dir:package.build_dir - (Source.ast_path path) + Compiler_process.ast_dependencies ~session:compiler_session + ~build_dir:package.build_dir (Source.ast_path path) in let raw_dependencies = List.sort_uniq String.compare @@ -196,7 +196,9 @@ let initialize ~(root_config : Config.t) ~package_plans ~compile_assets let compiler_base = Source.compiler_basename package.compile_config module_.Source.name in - if Option.is_none (Compile_assets.cmt compile_assets compiler_base) + if + Option.is_none + (Compile_assets.compile_marker compile_assets compiler_base) then use_existing_ast_paths := Filename.concat package.root module_.Source.implementation @@ -291,7 +293,7 @@ let initialize ~(root_config : Config.t) ~package_plans ~compile_assets ~last_compiled_cmi: (Compile_assets.cmi compile_assets node.key |> modified) ~last_compiled_cmt: - (Compile_assets.cmt compile_assets node.key |> modified)) + (Compile_assets.compile_marker compile_assets node.key |> modified)) source_graph_nodes; List.iter (fun (namespace_map : namespace_map) -> @@ -301,7 +303,8 @@ let initialize ~(root_config : Config.t) ~package_plans ~compile_assets (Compile_assets.cmi compile_assets namespace_map.compiler_name |> modified) ~last_compiled_cmt: - (Compile_assets.cmt compile_assets namespace_map.compiler_name + (Compile_assets.compile_marker compile_assets + namespace_map.compiler_name |> modified)) namespace_maps; List.iter diff --git a/rewatch-ocaml/module_graph.mli b/rewatch-ocaml/module_graph.mli index e1e904029c0..214eff6225e 100644 --- a/rewatch-ocaml/module_graph.mli +++ b/rewatch-ocaml/module_graph.mli @@ -55,6 +55,7 @@ type initialized = { val initialize : root_config:Config.t -> + compiler_session:Rescript_compiler_driver.session -> package_plans:Package_plan.t list -> compile_assets:Compile_assets.t -> failed_parse_paths:(string, unit) Hashtbl.t -> diff --git a/rewatch-ocaml/package_compilation.ml b/rewatch-ocaml/package_compilation.ml index 2712cce9d64..df3e631824a 100644 --- a/rewatch-ocaml/package_compilation.ml +++ b/rewatch-ocaml/package_compilation.ml @@ -91,6 +91,7 @@ let prepare ~(package : Package_plan.t) ~(prepared : Build_session.prepared) else prepared_package.regular_common_args) module_ ~source_kind path |> Compiler_process.task + ~session:(Build_session.compiler_session attempt.session) in let record_published_outputs ~source_kind path = match source_kind with @@ -130,8 +131,14 @@ let prepare ~(package : Package_plan.t) ~(prepared : Build_session.prepared) ~compile:(fun ~source_kind path -> compile_process module_ ~source_kind path) ~publish:(fun ~source_kind path result -> - Compiler_process.publish ~build_dir ~ocaml_dir ~is_local - ~config ~source_kind path result) + Compiler_process.publish + ~session:(Build_session.compiler_session attempt.session) + ~force_disk_publication: + prepared.compiler_context.gentype_disk_publication + ~retain_interface: + (not (Build_state.String_set.is_empty state.dependents)) + ~dependencies:state.dependencies ~build_dir ~ocaml_dir + ~is_local ~config ~source_kind path result) ~record_published_outputs ~post_build:(Compiler_process.post_build_tasks config) ~package_root:config.root ~is_local @@ -163,6 +170,7 @@ let prepare ~(package : Package_plan.t) ~(prepared : Build_session.prepared) || attempt.freshness_mode = Build_attempt.Initialize_freshness then Compiler_process.namespace_task + ~session:(Build_session.compiler_session attempt.session) ~bsc:prepared.compiler_context.bsc_path ~runtime:prepared.compiler_context.runtime_path ~build_dir ~ocaml_dir @@ -182,9 +190,12 @@ let prepare ~(package : Package_plan.t) ~(prepared : Build_session.prepared) Compiler_scheduler.capture_publication (fun () -> namespace_task.Compiler_scheduler.publish result) with - | Compiler_scheduler.Published {cmi_change; _} -> + | Compiler_scheduler.Published + {cmi_change; optimization_changed; _} -> Build_state.record_published_cmi build_state ~compile_assets namespace_state ~path:cmi_path cmi_change; + Build_state.record_published_optimization build_state + namespace_state ~changed:optimization_changed; let cmt_path = Filename.concat ocaml_dir (compiler_name ^ ".cmt") in diff --git a/rewatch-ocaml/package_parse.ml b/rewatch-ocaml/package_parse.ml index f26ceea9da3..d723b9907ef 100644 --- a/rewatch-ocaml/package_parse.ml +++ b/rewatch-ocaml/package_parse.ml @@ -56,7 +56,9 @@ let run ~(package : Package_plan.t) ~(prepared : Build_session.prepared) Compiler_process.parse_job ~bsc:prepared.compiler_context.bsc_path ~build_dir ~config path) parse_paths_to_run - |> Compiler_process.run_jobs ?poll:attempt.process_poll) + |> Compiler_process.run_jobs + ~session:(Build_session.compiler_session attempt.session) + ?poll:attempt.process_poll) @ (dirty_parse_paths |> List.filter_map (fun path -> Hashtbl.find_opt attempt.preliminary_parses @@ -87,14 +89,18 @@ let run ~(package : Package_plan.t) ~(prepared : Build_session.prepared) let published_ast = Build_artifacts.published_ast_path ~ocaml_dir path in - File_util.copy_existing_file ~ensure_parent:false - (Filename.concat build_dir ast) - published_ast; - Compile_assets.refresh_ast compile_assets ~source:absolute_path - ~path:published_ast; - File_util.copy_existing_file ~ensure_parent:false - (Filename.concat config.root path) - (Filename.concat ocaml_dir (Filename.basename path)); + if Compiler_args.compatibility_copies_enabled config then + File_util.copy_existing_file ~ensure_parent:false + (Filename.concat config.root path) + (Filename.concat ocaml_dir (Filename.basename path)); + let staged_ast = Filename.concat build_dir ast in + let owned_ast = + Rescript_compiler_driver.publish_session_ast + (Build_session.compiler_session attempt.session) + ~source:staged_ast + in + Build_attempt.add_parse_export ?owned_ast attempt ~staged_ast + ~published_ast ~source:absolute_path ~compile_assets; if is_local && stderr <> "" then Build_session.mark_parse_pending attempt.session pending_path else Build_session.clear_parse_pending attempt.session pending_path diff --git a/rewatch-ocaml/tests/check_command_validation.sh b/rewatch-ocaml/tests/check_command_validation.sh index 9639921b003..46080e21909 100755 --- a/rewatch-ocaml/tests/check_command_validation.sh +++ b/rewatch-ocaml/tests/check_command_validation.sh @@ -1633,12 +1633,22 @@ if [ -e "$work/watch-filter-rust/src/Exclude.js" ]; then exit 1 fi cp "$work/watch-filter-rust/src/Include.js" "$work/watch-filter-rust-initial.js" -printf 'let value = 2\n' >"$work/watch-filter-rust/src/Include.res" +# Let the excluded edit finish before changing the included source so the +# watcher cannot batch the events into one build. printf 'let value = 11\n' >"$work/watch-filter-rust/src/Exclude.res" wait_for_line_count "$rust_filter_marker" 2 if ! cmp -s "$work/watch-filter-rust-initial.js" \ + "$work/watch-filter-rust/src/Include.js" || \ + [ -e "$work/watch-filter-rust/src/Exclude.js" ]; then + echo "Rust changed generated output after an excluded watch-filter edit" >&2 + cat "$work/watch-filter-rust.out" "$work/watch-filter-rust.err" >&2 + exit 1 +fi +printf 'let value = 2\n' >"$work/watch-filter-rust/src/Include.res" +if ! line_count_stays "$rust_filter_marker" 2 || \ + ! cmp -s "$work/watch-filter-rust-initial.js" \ "$work/watch-filter-rust/src/Include.js"; then - echo "Rust no longer reproduces the inverted watch-filter event behavior" >&2 + echo "Rust no longer ignores included watch-filter edits" >&2 cat "$work/watch-filter-rust.out" "$work/watch-filter-rust.err" >&2 exit 1 fi @@ -1785,6 +1795,10 @@ fi printf '{"name":"missing-dependency","sources":["src"]}\n' \ >"$work/missing-dependency/rescript.json" wait_for_file "$work/missing-dependency/src/A.js" +# A.js is published before the watcher releases build.lock. On Windows the +# harness terminates the native process without a graceful cleanup signal, so +# wait for the completed build before intentionally leaving only watch.lock. +wait_for_text "$work/ocaml.out" "Finished compilation" terminate_and_wait "$missing_dependency_watch_pid" \ "missing-dependency watcher" if $windows_posix_shell; then @@ -1805,6 +1819,8 @@ run_cwd_case format-malformed-dependency exit2 exit2 \ if [ -e "$work/missing-dependency/lib/build.lock" ] || \ [ -e "$work/missing-dependency/lib/watch.lock" ]; then echo "OCaml dependency failures left a build or watch lock behind" >&2 + ls -l "$work/missing-dependency/lib/build.lock" \ + "$work/missing-dependency/lib/watch.lock" 2>/dev/null || true exit 1 fi diff --git a/rewatch-ocaml/tests/check_config_acceptance.sh b/rewatch-ocaml/tests/check_config_acceptance.sh index c414fcb1083..54a9c568ca2 100755 --- a/rewatch-ocaml/tests/check_config_acceptance.sh +++ b/rewatch-ocaml/tests/check_config_acceptance.sh @@ -36,7 +36,7 @@ while IFS=$'\t' read -r area name expected json; do set +e "$rust" compiler-args "$work/src/A.res" >"$work/rust.out" 2>"$work/rust.err" rust_status=$? - "$ocaml" compiler-args "$work/src/A.res" >"$work/ocaml.out" 2>"$work/ocaml.err" + REWATCH_BIN_ANNOT=0 "$ocaml" compiler-args "$work/src/A.res" >"$work/ocaml.out" 2>"$work/ocaml.err" ocaml_status=$? set -e @@ -95,10 +95,23 @@ while IFS=$'\t' read -r area name expected json; do ! node -e ' const fs = require("fs"); const assert = require("assert"); - assert.deepStrictEqual( - JSON.parse(fs.readFileSync(process.argv[1], "utf8")), - JSON.parse(fs.readFileSync(process.argv[2], "utf8")), - ); + const rust = JSON.parse(fs.readFileSync(process.argv[1], "utf8")); + const ocaml = JSON.parse(fs.readFileSync(process.argv[2], "utf8")); + // Editor annotations are disabled for every package in this check, + // including GenType packages, which consume independent typed inputs. + const packageName = ocaml.compiler_args.lastIndexOf("-bs-package-name"); + assert.ok(packageName > 0); + assert.strictEqual(ocaml.compiler_args[packageName - 1], "-bs-no-bin-annot"); + ocaml.compiler_args.splice(packageName - 1, 1); + // GenType parse requests carry a marker selecting classic lookup. + // Remove only the injected marker, preserving user-supplied flags. + if (ocaml.compiler_args.includes("-bs-gentype")) { + const absname = ocaml.parser_args.lastIndexOf("-absname"); + assert.ok(absname > 0); + assert.strictEqual(ocaml.parser_args[absname - 1], "-bs-gentype"); + ocaml.parser_args.splice(absname - 1, 1); + } + assert.deepStrictEqual(rust, ocaml); ' "$work/rust.out" "$work/ocaml.out"; then printf 'Config case %s/%s produced different compiler arguments\n' \ "$area" "$name" >&2 diff --git a/rewatch-ocaml/tests/gentype-summary/rescript.json b/rewatch-ocaml/tests/gentype-summary/rescript.json new file mode 100644 index 00000000000..b7833e3c17a --- /dev/null +++ b/rewatch-ocaml/tests/gentype-summary/rescript.json @@ -0,0 +1,11 @@ +{ + "name": "rewatch-gentype-summary", + "sources": "src", + "package-specs": {"module": "esmodule", "in-source": true}, + "gentypeconfig": { + "module": "esmodule", + "moduleResolution": "node", + "generatedFileExtension": ".gen.ts", + "exportInterfaces": true + } +} diff --git a/rewatch-ocaml/tests/gentype-summary/src/Leaf.res b/rewatch-ocaml/tests/gentype-summary/src/Leaf.res new file mode 100644 index 00000000000..ee88bb26dda --- /dev/null +++ b/rewatch-ocaml/tests/gentype-summary/src/Leaf.res @@ -0,0 +1 @@ +@genType type t = {value: int} diff --git a/rewatch-ocaml/tests/gentype-summary/src/Main.res b/rewatch-ocaml/tests/gentype-summary/src/Main.res new file mode 100644 index 00000000000..4ad9787b30b --- /dev/null +++ b/rewatch-ocaml/tests/gentype-summary/src/Main.res @@ -0,0 +1 @@ +@genType let identity = (x: Middle.t) => x diff --git a/rewatch-ocaml/tests/gentype-summary/src/Middle.res b/rewatch-ocaml/tests/gentype-summary/src/Middle.res new file mode 100644 index 00000000000..9beea158a35 --- /dev/null +++ b/rewatch-ocaml/tests/gentype-summary/src/Middle.res @@ -0,0 +1 @@ +@genType type t = {leaf: Leaf.t} diff --git a/rewatch-ocaml/tests/gentype/src/Annotated.res b/rewatch-ocaml/tests/gentype/src/Annotated.res new file mode 100644 index 00000000000..e668d366514 --- /dev/null +++ b/rewatch-ocaml/tests/gentype/src/Annotated.res @@ -0,0 +1 @@ +@gentype let answer = 42 diff --git a/rewatch-ocaml/tests/gentype/src/Pair.res b/rewatch-ocaml/tests/gentype/src/Pair.res new file mode 100644 index 00000000000..cd298427b25 --- /dev/null +++ b/rewatch-ocaml/tests/gentype/src/Pair.res @@ -0,0 +1 @@ +let answer = 42 diff --git a/rewatch-ocaml/tests/gentype/src/Pair.resi b/rewatch-ocaml/tests/gentype/src/Pair.resi new file mode 100644 index 00000000000..c7f8836e914 --- /dev/null +++ b/rewatch-ocaml/tests/gentype/src/Pair.resi @@ -0,0 +1 @@ +@gentype let answer: int diff --git a/rewatch-ocaml/tests/run.sh b/rewatch-ocaml/tests/run.sh index 0a3b596ffb3..7e6e124c8bb 100644 --- a/rewatch-ocaml/tests/run.sh +++ b/rewatch-ocaml/tests/run.sh @@ -62,6 +62,9 @@ cp -R "$root/rewatch-ocaml/tests/failure" "$work/failure" cp -R "$root/rewatch-ocaml/tests/features" "$work/features" cp -R "$root/rewatch-ocaml/tests/feature-dependencies" "$work/feature-dependencies" cp -R "$root/rewatch-ocaml/tests/gentype" "$work/gentype" +cp -R "$root/rewatch-ocaml/tests/gentype-summary" "$work/gentype-summary" +cp -R "$root/rewatch-ocaml/tests/session-interface" \ + "$work/session-interface" cp -R "$root/rewatch-ocaml/tests/dependency" "$work/dependency" cp -R "$root/rewatch-ocaml/tests/package-output-dependency" \ "$work/package-output-dependency" @@ -788,8 +791,33 @@ grep -F "Formatting check failed" "$work/format-check.err" >/dev/null test -f "$no_bin_annot/lib/bs/src/NoBinAnnot.cmi" test -f "$no_bin_annot/lib/bs/src/NoBinAnnot.cmj" test -f "$no_bin_annot/src/NoBinAnnot.js" +test ! -e "$no_bin_annot/lib/bs/src/NoBinAnnot.js" +test ! -e "$no_bin_annot/lib/bs/src/NoBinAnnot.res" +test ! -e "$no_bin_annot/lib/ocaml/NoBinAnnot.res" test ! -e "$no_bin_annot/lib/bs/src/NoBinAnnot.cmt" test ! -e "$no_bin_annot/lib/ocaml/NoBinAnnot.cmt" +"$port" build "$no_bin_annot" >"$work/no-bin-annot-unchanged.log" +grep 'Parsed 0 source files' "$work/no-bin-annot-unchanged.log" >/dev/null +grep 'Compiled 0 modules' "$work/no-bin-annot-unchanged.log" >/dev/null +printf '\nlet changed = value + 1\n' >>"$no_bin_annot/src/NoBinAnnot.res" +REWATCH_COMPAT_COPIES=1 \ + "$port" build "$no_bin_annot" >"$work/no-bin-annot-edit.log" +grep 'Parsed 1 source files' "$work/no-bin-annot-edit.log" >/dev/null +grep 'Compiled 1 modules' "$work/no-bin-annot-edit.log" >/dev/null +test -f "$no_bin_annot/lib/bs/src/NoBinAnnot.js" +test -f "$no_bin_annot/lib/bs/src/NoBinAnnot.res" +test -f "$no_bin_annot/lib/ocaml/NoBinAnnot.res" +printf '// Comment-only edit keeps the CMJ bytes unchanged.\n' \ + >>"$no_bin_annot/src/NoBinAnnot.res" +"$port" build "$no_bin_annot" >"$work/no-bin-annot-comment.log" +grep 'Parsed 1 source files' "$work/no-bin-annot-comment.log" >/dev/null +grep 'Compiled 1 modules' "$work/no-bin-annot-comment.log" >/dev/null +test ! -e "$no_bin_annot/lib/bs/src/NoBinAnnot.js" +test ! -e "$no_bin_annot/lib/bs/src/NoBinAnnot.res" +test ! -e "$no_bin_annot/lib/ocaml/NoBinAnnot.res" +"$port" build "$no_bin_annot" >"$work/no-bin-annot-comment-noop.log" +grep 'Parsed 0 source files' "$work/no-bin-annot-comment-noop.log" >/dev/null +grep 'Compiled 0 modules' "$work/no-bin-annot-comment-noop.log" >/dev/null if (cd "$basic/src" && "$port" format --check) \ >"$work/format-nested.out" 2>"$work/format-nested.err"; then @@ -869,13 +897,31 @@ rm -f "$basic/src/A.mjs" mkdir -p "$basic/lib/bs/other" touch "$basic/lib/bs/other/Authored.js" -"$port" build --after-build 'test -f src/A.mjs' "$basic" +# Windows timestamps can coincide for very short compiler requests, and text +# mode writes CRLF rows. Both still describe valid timing data. +printf 'parse\tfixture\tA.ast\t1.000000000\t1.000000000\r\n' \ + >"$work/short-compiler-timing.tsv" +node "$root/rewatch-ocaml/bench/analyze_compiler_timing.js" \ + "$work/short-compiler-timing.tsv" \ + >"$work/short-compiler-timing.summary" +grep -Eq '^parse,1,0[.]0,0[.]0,0[.]00,' \ + "$work/short-compiler-timing.summary" + +REWATCH_COMPILER_TIMING_LOG=$(native_path "$work/compiler-timing.tsv") \ + "$port" build --after-build 'test -f src/A.mjs' "$basic" +test -s "$work/compiler-timing.tsv" +node "$root/rewatch-ocaml/bench/analyze_compiler_timing.js" \ + "$work/compiler-timing.tsv" >"$work/compiler-timing.summary" +grep -Eq '^parse,[1-9][0-9]*,' "$work/compiler-timing.summary" +grep -Eq '^compile,[1-9][0-9]*,' "$work/compiler-timing.summary" test -f "$basic/lib/bs/build.ninja" test -f "$basic/src/A.mjs" test -f "$basic/src/Authored.js" test -f "$basic/src/B.mjs" test -f "$basic/src/WithInterface.mjs" test -f "$basic/lib/ocaml/A.cmi" +test ! -e "$basic/lib/ocaml/WithInterface.cmti" +REWATCH_BIN_ANNOT=1 "$port" build "$basic" >/dev/null test -f "$basic/lib/ocaml/WithInterface.cmti" printf '\nlet streamedAfterBuild = 1\n' >>"$basic/src/A.res" @@ -1196,7 +1242,8 @@ if $file_symlinks_supported; then cat "$symlink_source/watch.log" >&2 exit 1 fi - symlink_replacement=$(mktemp "${TMPDIR:-/tmp}/rewatch-symlink-target.XXXXXX") + # Keep the temporary target on the same filesystem for an atomic rename. + symlink_replacement=$(mktemp "$symlink_source/shared/Source.js.XXXXXX") printf 'let value = 3\n' >"$symlink_replacement" mv "$symlink_replacement" "$symlink_source/shared/Source.js" if ! wait_for_text "$symlink_source/src/Linked.mjs" 'value = 3'; then @@ -1281,7 +1328,7 @@ if ! grep 'value = 1' "$moved_source/src/nested/A.mjs" >/dev/null; then exit 1 fi -"$port" watch "$parse_publication" \ +REWATCH_COMPAT_COPIES=1 "$port" watch "$parse_publication" \ >"$parse_publication/watch.log" 2>&1 & parse_publication_pid=$! background_pids="$background_pids $parse_publication_pid" @@ -1319,7 +1366,7 @@ fi kill -TERM "$parse_publication_pid" wait "$parse_publication_pid" 2>/dev/null || true -"$port" watch "$multi_package_pending" \ +REWATCH_COMPAT_COPIES=1 "$port" watch "$multi_package_pending" \ >"$multi_package_pending/watch.log" 2>&1 & multi_package_pending_pid=$! background_pids="$background_pids $multi_package_pending_pid" @@ -1350,7 +1397,7 @@ fi kill -TERM "$multi_package_pending_pid" wait "$multi_package_pending_pid" 2>/dev/null || true -"$port" watch "$full_watch_recovery" \ +REWATCH_COMPAT_COPIES=1 "$port" watch "$full_watch_recovery" \ >"$full_watch_recovery/watch.log" 2>&1 & full_watch_recovery_pid=$! background_pids="$background_pids $full_watch_recovery_pid" @@ -1609,12 +1656,242 @@ test -f "$unlinked_dependency/packages/dep/lib/ocaml/marker" "$port" clean "$feature_dependencies" "$port" build --prod "$feature_dependencies" -test -f "$feature_dependencies/packages/dep-union/native/UnionNative.js" -test -f "$feature_dependencies/packages/dep-union/web/UnionWeb.js" -test ! -f "$feature_dependencies/packages/dep-union/extra/UnionExtra.js" +native_output="$feature_dependencies/packages/dep-union/native/UnionNative.js" +web_output="$feature_dependencies/packages/dep-union/web/UnionWeb.js" +extra_output="$feature_dependencies/packages/dep-union/extra/UnionExtra.js" +if [ ! -f "$native_output" ] || [ ! -f "$web_output" ] || \ + [ -f "$extra_output" ]; then + echo "production feature outputs did not match the requested dependency features" >&2 + for output in "$native_output" "$web_output" "$extra_output"; do + if [ -f "$output" ]; then + echo "present: $output" >&2 + else + echo "missing: $output" >&2 + fi + done + exit 1 +fi -"$port" build "$gentype" -test -f "$gentype/src/Main.js" +REWATCH_FROZEN_VALUES=1 \ +REWATCH_TYPECHECK_TRACE="$(native_path "$work/gentype-trace.tsv")" \ + "$port" build "$gentype" +for output in "$gentype/src/Main.js" "$gentype/src/Annotated.gen.ts" \ + "$gentype/src/Pair.gen.ts" "$gentype/lib/bs/src/Pair.cmti.gts" \ + "$work/gentype-trace.tsv"; do + if [ ! -f "$output" ]; then + echo "genType build did not produce $output" >&2 + find "$gentype/src" -maxdepth 1 -type f -print >&2 + exit 1 + fi +done +tr '\\' '/' <"$work/gentype-trace.tsv" >"$work/gentype-trace.normalized.tsv" +grep 'src/Dep.ast.*dependency.frozen_open' \ + "$work/gentype-trace.normalized.tsv" >/dev/null +if grep 'src/Pair.ast.*dependency.frozen_open' \ + "$work/gentype-trace.normalized.tsv" >/dev/null; then + echo "genType request used frozen dependency lookup" >&2 + exit 1 +fi +if ! grep 'src/Annotated.ast.*dependency.gentype_semantic_result' \ + "$work/gentype-trace.normalized.tsv" >/dev/null || \ + ! grep 'src/Pair.ast.*dependency.gentype_semantic_result' \ + "$work/gentype-trace.normalized.tsv" >/dev/null; then + echo "genType did not reuse the in-session semantic result" >&2 + cat "$work/gentype-trace.normalized.tsv" >&2 + exit 1 +fi +if grep 'src/Annotated.ast.*dependency.gentype_cmt_read' \ + "$work/gentype-trace.normalized.tsv" >/dev/null; then + echo "genType reread the newly written implementation CMT" >&2 + exit 1 +fi +grep 'src/Pair.ast.*dependency.gentype_interface_summary_read' \ + "$work/gentype-trace.normalized.tsv" >/dev/null +test ! -e "$gentype/lib/bs/src/Pair.cmti" +test ! -e "$gentype/lib/ocaml/Pair.cmti" +test ! -e "$gentype/lib/ocaml/Pair.resi" +REWATCH_BIN_ANNOT=1 "$port" build "$gentype" +test -f "$gentype/lib/bs/src/Pair.cmti" +test -f "$gentype/lib/ocaml/Pair.cmti" +test -f "$gentype/lib/ocaml/Pair.resi" +REWATCH_BIN_ANNOT=0 "$port" build "$gentype" +test ! -e "$gentype/lib/bs/src/Pair.cmti" +test ! -e "$gentype/lib/ocaml/Pair.cmti" +test ! -e "$gentype/lib/ocaml/Pair.resi" + +inverse_gentype="$work/inverse-gentype" +mkdir -p "$inverse_gentype/src" "$inverse_gentype/node_modules/dep/src" +printf '%s\n' \ + '{"name":"inverse-gentype","sources":"src","dependencies":["dep"],"package-specs":{"module":"esmodule","in-source":true}}' \ + >"$inverse_gentype/rescript.json" +printf 'let result = Dep.value\n' >"$inverse_gentype/src/Consumer.res" +printf '%s\n' \ + '{"name":"dep","sources":"src","gentypeconfig":{"module":"esmodule","generatedFileExtension":".gen.ts"}}' \ + >"$inverse_gentype/node_modules/dep/rescript.json" +printf '@genType let value = 42\n' \ + >"$inverse_gentype/node_modules/dep/src/Dep.res" +REWATCH_FROZEN_VALUES=1 \ +REWATCH_TYPECHECK_TRACE="$(native_path "$work/inverse-gentype-trace.tsv")" \ + "$port" build "$inverse_gentype" +test -f "$inverse_gentype/node_modules/dep/src/Dep.gen.ts" +grep 'let result = Dep.value;' "$inverse_gentype/src/Consumer.js" >/dev/null +tr '\\' '/' <"$work/inverse-gentype-trace.tsv" \ + >"$work/inverse-gentype-trace.normalized.tsv" +grep 'src/Consumer.ast.*dependency.frozen_value_lookup' \ + "$work/inverse-gentype-trace.normalized.tsv" >/dev/null +if grep 'src/Dep.ast.*dependency.frozen_open' \ + "$work/inverse-gentype-trace.normalized.tsv" >/dev/null; then + echo "genType dependency used frozen lookup" >&2 + exit 1 +fi + +summary_project="$work/gentype-summary" +summary_trace="$work/gentype-summary-trace.tsv" +REWATCH_TYPECHECK_TRACE="$(native_path "$summary_trace")" \ + "$port" build "$summary_project" +for module_name in Leaf Middle Main; do + test -f "$summary_project/lib/bs/src/$module_name.cmt.gts" + test -f "$summary_project/src/$module_name.gen.ts" + test ! -e "$summary_project/lib/bs/src/$module_name.cmt" + test ! -e "$summary_project/lib/ocaml/$module_name.cmt" +done +tr '\\' '/' <"$summary_trace" >"$work/gentype-summary-trace.normalized.tsv" +if ! grep 'src/Main.ast.*dependency.gentype_summary_read' \ + "$work/gentype-summary-trace.normalized.tsv" >/dev/null || \ + grep 'src/Main.ast.*dependency.gentype_dependency_cmt_read' \ + "$work/gentype-summary-trace.normalized.tsv" >/dev/null; then + echo "genType did not use validated dependency summaries" >&2 + exit 1 +fi +cp "$summary_project/src/Main.gen.ts" "$work/gentype-summary-clean.ts" +printf '\n// unchanged type after edit\n' >>"$summary_project/src/Main.res" +REWATCH_TYPECHECK_TRACE="$(native_path "$work/gentype-summary-edit.tsv")" \ + "$port" build "$summary_project" +cmp "$work/gentype-summary-clean.ts" "$summary_project/src/Main.gen.ts" +tr '\\' '/' <"$work/gentype-summary-edit.tsv" \ + >"$work/gentype-summary-edit.normalized.tsv" +grep 'src/Main.ast.*dependency.gentype_summary_read' \ + "$work/gentype-summary-edit.normalized.tsv" >/dev/null +printf '\n// unchanged type after restart\n' >>"$summary_project/src/Main.res" +REWATCH_TYPECHECK_TRACE="$(native_path "$work/gentype-summary-restart.tsv")" \ + "$port" build "$summary_project" +cmp "$work/gentype-summary-clean.ts" "$summary_project/src/Main.gen.ts" +tr '\\' '/' <"$work/gentype-summary-restart.tsv" \ + >"$work/gentype-summary-restart.normalized.tsv" +grep 'src/Main.ast.*dependency.gentype_summary_read' \ + "$work/gentype-summary-restart.normalized.tsv" >/dev/null +REWATCH_BIN_ANNOT=1 "$port" build "$summary_project" +for module_name in Leaf Middle Main; do + test -f "$summary_project/lib/bs/src/$module_name.cmt" + test -f "$summary_project/lib/ocaml/$module_name.cmt" +done +rm -f "$summary_project/lib/bs/src/Leaf.cmt.gts" \ + "$summary_project/lib/bs/src/Middle.cmt.gts" +printf '\n// use legacy dependency inputs\n' >>"$summary_project/src/Main.res" +REWATCH_BIN_ANNOT=1 \ +REWATCH_TYPECHECK_TRACE="$(native_path "$work/gentype-summary-fallback.tsv")" \ + "$port" build "$summary_project" +cmp "$work/gentype-summary-clean.ts" "$summary_project/src/Main.gen.ts" +tr '\\' '/' <"$work/gentype-summary-fallback.tsv" \ + >"$work/gentype-summary-fallback.normalized.tsv" +grep 'src/Main.ast.*dependency.gentype_dependency_cmt_read' \ + "$work/gentype-summary-fallback.normalized.tsv" >/dev/null +rm "$summary_project/src/Main.res" +REWATCH_BIN_ANNOT=1 "$port" build "$summary_project" +test ! -e "$summary_project/lib/bs/src/Main.cmt.gts" +test ! -e "$summary_project/lib/ocaml/Main.cmt.gts" + +REWATCH_FROZEN_VALUES=1 REWATCH_SESSION_CMI=1 \ + REWATCH_TYPECHECK_TRACE="$(native_path "$work/session-interface-trace.tsv")" \ + REWATCH_COMPILER_TIMING_LOG="$(native_path "$work/session-interface-timing.tsv")" \ + REWATCH_ARTIFACT_EXPORT_LOG="$(native_path "$work/session-interface-export.tsv")" \ + "$port" build "$work/session-interface" +tr '\\' '/' <"$work/session-interface-trace.tsv" \ + >"$work/session-interface-trace.normalized.tsv" +if ! grep 'src/Api.ast.*dependency.session_cmi_lookup' \ + "$work/session-interface-trace.normalized.tsv" >/dev/null || \ + ! grep 'src/Consumer.ast.*dependency.session_cmi_lookup' \ + "$work/session-interface-trace.normalized.tsv" >/dev/null; then + echo "session interface lookup was missing from the typecheck trace" >&2 + cat "$work/session-interface-trace.normalized.tsv" >&2 + exit 1 +fi +if grep 'src/Consumer.ast.*dependency.search_open:Api' \ + "$work/session-interface-trace.normalized.tsv" >/dev/null; then + echo "consumer reopened the freshly published Api CMI" >&2 + exit 1 +fi +tr '\\' '/' <"$work/session-interface-timing.tsv" \ + >"$work/session-interface-timing.normalized.tsv" +tr '\\' '/' <"$work/session-interface-export.tsv" \ + >"$work/session-interface-export.normalized.tsv" +consumer_start=$(awk -F '\t' \ + '$1 == "implementation" && $3 == "src/Consumer.ast" {print $4; exit}' \ + "$work/session-interface-timing.normalized.tsv") +interface_export=$(awk -F '\t' \ + '$1 == "start" && $2 == "src/Api.resi" {print $3; exit}' \ + "$work/session-interface-export.normalized.tsv") +if [ -z "$consumer_start" ] || [ -z "$interface_export" ] || \ + ! awk -v consumer="$consumer_start" -v export_time="$interface_export" \ + 'BEGIN {exit !(consumer < export_time)}'; then + echo "consumer waited for Api artifact export" >&2 + exit 1 +fi +session_interface="$work/session-interface" +cp "$session_interface/lib/ocaml/Api.cmi" "$work/session-api-before.cmi" +cp "$session_interface/lib/ocaml/Api.cmj" "$work/session-api-before.cmj" +printf 'let inc = x => x + 2\n' >"$session_interface/src/Api.res" +REWATCH_FROZEN_VALUES=1 REWATCH_SESSION_CMI=1 REWATCH_SESSION_CMJ=1 \ + "$port" build "$session_interface" +cmp -s "$work/session-api-before.cmi" "$session_interface/lib/ocaml/Api.cmi" +if cmp -s "$work/session-api-before.cmj" \ + "$session_interface/lib/ocaml/Api.cmj"; then + echo "implementation edit did not change Api optimization metadata" >&2 + exit 1 +fi +grep 'let answer = 3;' "$session_interface/src/Consumer.mjs" >/dev/null + +# An unchanged explicit interface still governs the implementation's result. +# A failed deferred CMJ export must fail the build and allow a retry. +obstruct_file_with_directory "$session_interface/lib/ocaml/Api.cmj" +printf 'let inc = x => x + 3\n' >"$session_interface/src/Api.res" +if REWATCH_FROZEN_VALUES=1 \ + REWATCH_ARTIFACT_EXPORT_LOG="$(native_path "$work/failed-export-timing.tsv")" \ + "$port" build "$session_interface" \ + >"$session_interface/failed-export.log" 2>&1; then + echo "deferred optimization export failure unexpectedly succeeded" >&2 + exit 1 +fi +tr '\\' '/' <"$work/failed-export-timing.tsv" | \ + grep 'start.*src/Api.res' >/dev/null +remove_obstruction_directory "$session_interface/lib/ocaml/Api.cmj" +REWATCH_FROZEN_VALUES=1 "$port" build "$session_interface" +grep 'let answer = 4;' "$session_interface/src/Consumer.mjs" >/dev/null +obstruct_file_with_directory "$session_interface/lib/ocaml/Api.cmi" +printf 'let inc = x => x + 4\n' >"$session_interface/src/Api.res" +if REWATCH_FROZEN_VALUES=1 \ + REWATCH_ARTIFACT_EXPORT_LOG="$(native_path "$work/failed-interface-export-timing.tsv")" \ + "$port" build "$session_interface" \ + >"$session_interface/failed-interface-export.log" 2>&1; then + echo "deferred interface export failure unexpectedly succeeded" >&2 + exit 1 +fi +tr '\\' '/' <"$work/failed-interface-export-timing.tsv" | \ + grep 'start.*src/Api.resi' >/dev/null +remove_obstruction_directory "$session_interface/lib/ocaml/Api.cmi" +REWATCH_FROZEN_VALUES=1 "$port" build "$session_interface" +grep 'let answer = 5;' "$session_interface/src/Consumer.mjs" >/dev/null +REWATCH_FROZEN_VALUES=0 REWATCH_BIN_ANNOT=1 \ + "$port" build "$session_interface" >"$work/session-classic-mode.log" +grep 'Cleaned previous build due to compiler update' \ + "$work/session-classic-mode.log" >/dev/null +test -f "$session_interface/lib/ocaml/Consumer.cmt" +REWATCH_FROZEN_VALUES=1 REWATCH_BIN_ANNOT=0 \ + "$port" build "$session_interface" >"$work/session-fast-mode.log" +grep 'Cleaned previous build due to compiler update' \ + "$work/session-fast-mode.log" >/dev/null +test ! -e "$session_interface/lib/ocaml/Consumer.cmt" +grep 'let answer = 5;' "$session_interface/src/Consumer.mjs" >/dev/null "$port" build "$dependency" test -f "$dependency/src/Main.js" diff --git a/rewatch-ocaml/tests/session-interface/rescript.json b/rewatch-ocaml/tests/session-interface/rescript.json new file mode 100644 index 00000000000..2ce513bb814 --- /dev/null +++ b/rewatch-ocaml/tests/session-interface/rescript.json @@ -0,0 +1,7 @@ +{ + "name": "rewatch-ocaml-session-interface", + "sources": "src", + "compiler-flags": ["-bs-cross-module-opt"], + "package-specs": {"module": "esmodule", "in-source": true}, + "suffix": ".mjs" +} diff --git a/rewatch-ocaml/tests/session-interface/src/Api.res b/rewatch-ocaml/tests/session-interface/src/Api.res new file mode 100644 index 00000000000..4339661d2a5 --- /dev/null +++ b/rewatch-ocaml/tests/session-interface/src/Api.res @@ -0,0 +1 @@ +let inc = x => x + 1 diff --git a/rewatch-ocaml/tests/session-interface/src/Api.resi b/rewatch-ocaml/tests/session-interface/src/Api.resi new file mode 100644 index 00000000000..b12cd315e3f --- /dev/null +++ b/rewatch-ocaml/tests/session-interface/src/Api.resi @@ -0,0 +1 @@ +let inc: int => int diff --git a/rewatch-ocaml/tests/session-interface/src/Consumer.res b/rewatch-ocaml/tests/session-interface/src/Consumer.res new file mode 100644 index 00000000000..e0716d0bfc5 --- /dev/null +++ b/rewatch-ocaml/tests/session-interface/src/Consumer.res @@ -0,0 +1 @@ +let answer = Api.inc(1) diff --git a/rewatch/tests/add-belt-dependencies.mjs b/rewatch/tests/add-belt-dependencies.mjs index a50502a34ab..418d2c7d1e5 100644 --- a/rewatch/tests/add-belt-dependencies.mjs +++ b/rewatch/tests/add-belt-dependencies.mjs @@ -3,7 +3,7 @@ import * as fs from "node:fs/promises"; import * as path from "node:path"; -const testrepo = path.join(import.meta.dirname, "..", "testrepo"); +const testrepo = process.argv[2] ?? path.join(import.meta.dirname, "..", "testrepo"); const configs = [ path.join(testrepo, "node_modules", "rescript-nodejs", "rescript.json"), path.join( diff --git a/rewatch/tests/suffix/01-custom-suffix.sh b/rewatch/tests/suffix/01-custom-suffix.sh index 0485d49c2ab..ce47f4da899 100755 --- a/rewatch/tests/suffix/01-custom-suffix.sh +++ b/rewatch/tests/suffix/01-custom-suffix.sh @@ -29,14 +29,15 @@ else exit 1 fi -# Count files with new extension -file_count=$(find ./packages -name *.res.js | wc -l) +# Count generated source outputs. The lib/bs mirrors are optional in OCaml +# Rewatch's default mode, so they do not determine suffix correctness. +file_count=$(find ./packages -type f -name '*.res.js' ! -path '*/lib/bs/*' | wc -l) -if [ "$file_count" -eq 146 ]; +if [ "$file_count" -eq 73 ]; then - success "Found files with correct suffix" + success "Found generated files with correct suffix" else - error "Suffix not correctly used, got $file_count files" + error "Suffix not correctly used, got $file_count generated files" exit 1 fi diff --git a/rewatch/tests/watch/07-changed-interface-after-failed-implementation.sh b/rewatch/tests/watch/07-changed-interface-after-failed-implementation.sh index 34744e68fb5..cd7e3c2a904 100755 --- a/rewatch/tests/watch/07-changed-interface-after-failed-implementation.sh +++ b/rewatch/tests/watch/07-changed-interface-after-failed-implementation.sh @@ -83,8 +83,15 @@ cp "$compiler_log" failed.compiler.log # Keep timestamp-based freshness from masking a lost dirty bit. Both watcher # implementations must remember that Consumer was blocked by Provider's failed # implementation when the next rebuild reconstructs the build state. -test -f lib/ocaml/Consumer.cmt -node -e 'const fs = require("fs"); const future = new Date(Date.now() + 60000); fs.utimesSync("lib/ocaml/Consumer.cmt", future, future)' +freshness_marker=lib/ocaml/Consumer.cmt +if [ ! -f "$freshness_marker" ]; then + freshness_marker=lib/ocaml/Consumer.cmj +fi +if [ ! -f "$freshness_marker" ]; then + error "Consumer has no compiled freshness marker" + exit 1 +fi +node -e 'const fs = require("fs"); const future = new Date(Date.now() + 60000); fs.utimesSync(process.argv[1], future, future)' "$freshness_marker" || exit 1 # An atomic replacement makes the watcher reinitialize its build state. The # blocked dependent must remain dirty through that full rebuild as well. diff --git a/scripts/test.js b/scripts/test.js index f7f945b7d76..240f9355bb1 100644 --- a/scripts/test.js +++ b/scripts/test.js @@ -91,6 +91,13 @@ if (mochaTest) { cwd: commonjsTestDir, stdio: "inherit", }); + // Runtime annotation tests can rebuild its implicit interfaces after this + // project was last compiled. Rebuild the test project's own CMI files before + // it consumes the current runtime and Belt artifacts. + await execClean([], { + cwd: beltTestDir, + stdio: "inherit", + }); await execClean([], { cwd: beltPackageDir, stdio: "inherit", @@ -146,6 +153,9 @@ if (mochaTest) { if (buildTest) { console.log("Doing build_tests"); + // Artifact layout fixtures inspect the private lib/bs JavaScript and source + // mirrors. Ordinary compiler projects use the faster default layout. + const compatibilityEnv = { ...process.env, REWATCH_COMPAT_COPIES: "1" }; const files = fs.readdirSync(buildTestDir); let hasError = false; @@ -159,7 +169,10 @@ if (buildTest) { console.warn(`input.js does not exist in ${testDir}`); } else { // note existsSync test already ensure that it is a directory - const out = await node("input.js", [], { cwd: testDir }); + const out = await node("input.js", [], { + cwd: testDir, + env: compatibilityEnv, + }); process.stdout.write(out.stdout); if (out.status === 0) { @@ -185,6 +198,18 @@ if (runtimeDocstrings) { } else { console.log("Running runtime docstrings tests"); + // The extractor reads binary annotations from runtime and Belt. Ordinary + // OCaml Rewatch builds omit them, so build these inputs in annotation mode + // before extracting examples. + const annotationEnv = { ...process.env, REWATCH_BIN_ANNOT: "1" }; + for (const packageName of ["runtime", "belt"]) { + await execBuild([], { + cwd: path.join(projectDir, "packages", "@rescript", packageName), + env: annotationEnv, + stdio: "inherit", + }); + } + const generated_mocha_test_res = path.join( docstringTestDir, "generated_mocha_test.res", @@ -201,6 +226,7 @@ if (runtimeDocstrings) { await execBuild([], { cwd: docstringTestDir, + env: annotationEnv, stdio: "inherit", }); @@ -213,6 +239,7 @@ if (runtimeDocstrings) { // Build again to check if generated_mocha_test.res has syntax or type erros await execBuild([], { cwd: docstringTestDir, + env: annotationEnv, stdio: "inherit", }); diff --git a/tests/ounit_tests/ounit_frozen_type_graph_tests.ml b/tests/ounit_tests/ounit_frozen_type_graph_tests.ml new file mode 100644 index 00000000000..7d974b0c5b6 --- /dev/null +++ b/tests/ounit_tests/ounit_frozen_type_graph_tests.ml @@ -0,0 +1,276 @@ +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) +let assert_bool = OUnit.assert_bool + +let freeze roots = + match Frozen_type_graph.freeze roots with + | Ok image -> image + | Error reason -> OUnit.assert_failure reason + +let test_root_sharing_and_instantiation _ = + let variable = Btype.newgenty (Types.Tvar (Some "a")) in + let scheme = + Btype.newgenty + (Types.Tarrow ([Types.{lbl = Asttypes.Nolabel; typ = variable}], variable)) + in + let image = freeze [scheme; scheme] in + OUnit.assert_equal 2 (Frozen_type_graph.node_count image); + match Frozen_type_graph.thaw image with + | [first; second] -> ( + assert_bool "two roots keep the same scheme identity" (first == second); + let first_use = Ctype.instance Env.empty first in + let second_use = Ctype.instance Env.empty first in + assert_bool "each use has its own mutable inference graph" + (first_use != second_use); + match (first_use.desc, second_use.desc, first.desc) with + | ( Types.Tarrow ([{typ = first_arg}], first_result), + Types.Tarrow ([{typ = second_arg}], second_result), + Types.Tarrow ([{typ = scheme_arg}], scheme_result) ) -> + assert_bool "an instance preserves type-variable identity" + (first_arg == first_result && second_arg == second_result); + assert_bool "separate uses do not share inference variables" + (first_arg != second_arg); + assert_bool "instantiation did not change the thawed scheme" + (scheme_arg == scheme_result && scheme_arg != first_arg) + | _ -> OUnit.assert_failure "expected three function types") + | _ -> OUnit.assert_failure "expected two roots" + +let field_cell ty = + match ty.Types.desc with + | Types.Tfield {mutability; _} -> mutability + | _ -> OUnit.assert_failure "expected an object field" + +let test_mutability_classes_are_local _ = + let cell = ref (Types.Mutability_value Asttypes.Immutable) in + let rest = Btype.newgenty (Types.Tvar None) in + let field name = + Btype.newgenty + (Types.Tfield {name; mutability = cell; typ = Predef.type_int (); rest}) + in + let image = freeze [field "x"; field "y"] in + let first = Frozen_type_graph.thaw image in + let second = Frozen_type_graph.thaw image in + match (first, second) with + | [a; b], [c; d] -> + let a_cell = field_cell a in + assert_bool "a thaw preserves aliasing inside the image" + (a_cell == field_cell b); + assert_bool "separate thaws own separate mutability classes" + (a_cell != field_cell c && field_cell c == field_cell d); + a_cell := Types.Mutability_value Asttypes.Mutable; + assert_bool "a thaw cannot mutate the shared image or another thaw" + (Btype.mutability_repr (field_cell c) = Asttypes.Immutable + && Btype.mutability_repr cell = Asttypes.Immutable) + | _ -> OUnit.assert_failure "expected two fields per thaw" + +let test_poly_quantifiers_instantiate_independently _ = + let universal = Btype.newgenty (Types.Tunivar (Some "a")) in + let body = + Btype.newgenty + (Types.Tarrow + ([Types.{lbl = Asttypes.Nolabel; typ = universal}], universal)) + in + let image = freeze [Btype.newgenty (Types.Tpoly (body, [universal]))] in + let scheme = Frozen_type_graph.thaw_root image 0 in + match scheme.Types.desc with + | Types.Tpoly (body, [universal]) -> ( + let first_variables, first = + Ctype.instance_poly ~fixed:false [universal] body + in + let second_variables, second = + Ctype.instance_poly ~fixed:false [universal] body + in + let first_variable, second_variable = + match (first_variables, second_variables) with + | [first_variable], [second_variable] -> (first_variable, second_variable) + | _ -> OUnit.assert_failure "expected one instance variable per use" + in + assert_bool "quantified variables are fresh for each use" + (first_variable != second_variable); + match (first.desc, second.desc, body.desc) with + | ( Types.Tarrow ([{typ = first_arg}], first_result), + Types.Tarrow ([{typ = second_arg}], second_result), + Types.Tarrow ([{typ = original_arg}], original_result) ) -> + assert_bool "each body uses its own quantified variable" + (first_arg == first_result + && first_arg == first_variable + && second_arg == second_result + && second_arg == second_variable); + assert_bool "the frozen scheme's thaw stays quantified" + (original_arg == universal && original_result == universal) + | _ -> OUnit.assert_failure "expected two instantiated functions") + | _ -> OUnit.assert_failure "expected a quantified function" + +let test_cycles_and_identifier_sharing _ = + let recursive = Btype.newgenty (Types.Tvar None) in + recursive.desc <- Types.Ttuple [recursive]; + let ident = Ident.create "local" in + let first = + Btype.newgenty (Types.Tconstr (Path.Pident ident, [], ref Types.Mnil)) + in + let second = + Btype.newgenty (Types.Tconstr (Path.Pident ident, [], ref Types.Mnil)) + in + let image = freeze [recursive; first; second] in + let thaw () = Frozen_type_graph.thaw image in + let left = Domain.spawn thaw in + let right = Domain.spawn thaw in + match (Domain.join left, Domain.join right) with + | [cycle_a; a; b], [cycle_b; c; d] -> + (match (cycle_a.desc, cycle_b.desc) with + | Types.Ttuple [back_a], Types.Ttuple [back_b] -> + assert_bool "cycles preserve their own identity" + (back_a == cycle_a && back_b == cycle_b && cycle_a != cycle_b) + | _ -> OUnit.assert_failure "expected recursive tuples"); + let path_ident ty = + match ty.Types.desc with + | Types.Tconstr (Path.Pident id, _, _) -> id + | _ -> OUnit.assert_failure "expected a constructor path" + in + assert_bool "identifiers share within a thaw" + (path_ident a == path_ident b && path_ident c == path_ident d); + assert_bool "identifiers belong to one thaw" (path_ident a != path_ident c) + | _ -> OUnit.assert_failure "expected three roots per thaw" + +let test_variant_row_references_are_local _ = + let row_reference = ref None in + let field = Types.Reither (true, [], false, row_reference) in + let source = + Btype.newgenty + (Types.Tvariant + { + row_fields = [("A", field); ("B", field)]; + row_more = Btype.newgenty Types.Tnil; + row_closed = true; + row_fixed = false; + row_name = None; + }) + in + let image = freeze [source] in + let row_refs ty = + match ty.Types.desc with + | Types.Tvariant + { + row_fields = + [ + ("A", Types.Reither (_, _, _, a)); + ("B", Types.Reither (_, _, _, b)); + ]; + _; + } -> + (a, b) + | _ -> OUnit.assert_failure "expected two variant rows" + in + match (Frozen_type_graph.thaw image, Frozen_type_graph.thaw image) with + | [first], [second] -> + let a, b = row_refs first in + let c, d = row_refs second in + assert_bool "row references share within an image" (a == b && c == d); + assert_bool "row references are request-local" (a != c); + a := Some Types.Rabsent; + assert_bool "a row update does not change the image or another thaw" + (!c = None && !row_reference = None) + | _ -> OUnit.assert_failure "expected one variant per thaw" + +let test_rejects_transient_state _ = + let variable = Btype.newgenty (Types.Tvar None) in + let marked = Btype.newgenty (Types.Tsubst variable) in + let memo = ref (Types.Mlink (ref Types.Mnil)) in + let abbreviated = + Btype.newgenty + (Types.Tconstr (Path.Pident (Ident.create_persistent "Alias"), [], memo)) + in + assert_bool "copy marks cannot enter the immutable image" + (Result.is_error (Frozen_type_graph.freeze [marked])); + assert_bool "abbreviation memo state cannot enter the immutable image" + (Result.is_error (Frozen_type_graph.freeze [abbreviated])) + +let test_selective_thaw _ = + let unused = Btype.newgenty (Types.Ttuple [Predef.type_int ()]) in + let chosen = Btype.newgenty (Types.Tvar (Some "chosen")) in + let image = freeze [unused; chosen] in + OUnit.assert_equal 2 (Frozen_type_graph.root_count image); + let first = Frozen_type_graph.thaw_root image 1 in + let second = Frozen_type_graph.thaw_root image 1 in + assert_bool "one root can be materialized without sharing mutable nodes" + (first != second && first != chosen); + first.desc <- Types.Tvar (Some "changed"); + match (second.desc, chosen.desc) with + | Types.Tvar (Some "chosen"), Types.Tvar (Some "chosen") -> () + | _ -> OUnit.assert_failure "selective thaw changed another graph" + +let test_registered_identifier_matches_path _ = + let binder = Ident.create "t" in + let root = + Btype.newgenty (Types.Tconstr (Path.Pident binder, [], ref Types.Mnil)) + in + let image = Frozen_type_graph.freeze ~identifiers:[binder] [root] in + let image = + match image with + | Ok image -> image + | Error reason -> OUnit.assert_failure reason + in + let view = Frozen_type_graph.create_view image in + let materialized_binder = Frozen_type_graph.identifier_at view 0 in + match (Frozen_type_graph.type_at view 0).Types.desc with + | Types.Tconstr (Path.Pident path_ident, _, _) -> + assert_bool "signature binder and type path use the same local object" + (materialized_binder == path_ident && materialized_binder != binder) + | _ -> OUnit.assert_failure "expected a constructor path" + +let test_packed_edges_labels_and_paths _ = + let module_id = Ident.create_persistent "Module" in + let argument_id = Ident.create_persistent "Argument" in + let path = + Path.Papply + (Path.Pdot (Path.Pident module_id, "Nested", 7), Path.Pident argument_id) + in + let labelled = Asttypes.Labelled (Location.mkloc "first" Location.none) in + let optional = Asttypes.Optional (Location.mkloc "second" Location.none) in + let constructor = Btype.newgenty (Types.Tconstr (path, [], ref Types.Mnil)) in + let arrow = + Btype.newgenty + (Types.Tarrow + ( [ + Types.{lbl = labelled; typ = constructor}; + Types.{lbl = optional; typ = constructor}; + ], + constructor )) + in + let image = freeze [arrow] in + match (Frozen_type_graph.thaw_root image 0).Types.desc with + | Types.Tarrow + ( [{lbl = first; typ = first_type}; {lbl = second; typ = second_type}], + result ) -> ( + assert_bool "packed arguments retain labels and shared type nodes" + (first = labelled && second = optional && first_type == second_type + && second_type == result); + match result.Types.desc with + | Types.Tconstr + ( Path.Papply + ( Path.Pdot (Path.Pident module_id, name, position), + Path.Pident argument_id ), + [], + _ ) -> + assert_bool "indexed paths retain their names and positions" + (Ident.name module_id = "Module" + && name = "Nested" && position = 7 + && Ident.name argument_id = "Argument") + | _ -> OUnit.assert_failure "expected an applied nested path") + | _ -> OUnit.assert_failure "expected a labelled arrow" + +let suites = + __FILE__ + >::: [ + "root_sharing_and_instantiation" >:: test_root_sharing_and_instantiation; + "mutability_classes_are_local" >:: test_mutability_classes_are_local; + "poly_quantifiers_instantiate_independently" + >:: test_poly_quantifiers_instantiate_independently; + "cycles_and_identifier_sharing" >:: test_cycles_and_identifier_sharing; + "variant_row_references_are_local" + >:: test_variant_row_references_are_local; + "rejects_transient_state" >:: test_rejects_transient_state; + "selective_thaw" >:: test_selective_thaw; + "registered_identifier_matches_path" + >:: test_registered_identifier_matches_path; + "packed_edges_labels_and_paths" >:: test_packed_edges_labels_and_paths; + ] diff --git a/tests/ounit_tests/ounit_frozen_values_tests.ml b/tests/ounit_tests/ounit_frozen_values_tests.ml new file mode 100644 index 00000000000..eff0c06ea9c --- /dev/null +++ b/tests/ounit_tests/ounit_frozen_values_tests.ml @@ -0,0 +1,830 @@ +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) +let assert_bool = OUnit.assert_bool + +let abstract_type : Types.type_declaration = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + type_variance = []; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + type_immediate = false; + type_representation = Boxed; + type_inlined_types = []; + } + +let value ?(attributes = []) ty : Types.value_description = + { + val_type = ty; + val_kind = Val_reg; + val_loc = Location.none; + val_attributes = attributes; + } + +let freeze signature = + let cmi : Cmi_format.cmi_infos = + {cmi_name = "Api"; cmi_sign = signature; cmi_crcs = []; cmi_flags = []} + in + match Frozen_values.freeze cmi with + | Ok image -> image + | Error reason -> OUnit.assert_failure reason + +let test_prefixed_type_identity_and_positions _ = + let type_id = Ident.create "t" in + let value_type = + Btype.newgenty (Types.Tconstr (Path.Pident type_id, [], ref Types.Mnil)) + in + let image = + freeze + [ + Types.Sig_type (type_id, abstract_type, Types.Trec_not); + Types.Sig_value (Ident.create "first", value value_type); + Types.Sig_module + ( Ident.create "Nested", + { + Types.md_type = Mty_signature []; + md_attributes = []; + md_loc = Location.none; + }, + Types.Trec_not ); + Types.Sig_value (Ident.create "second", value value_type); + ] + in + OUnit.assert_equal 2 (Frozen_values.value_count image); + let view = Frozen_values.create_view image in + match (Frozen_values.find view "first", Frozen_values.find view "second") with + | Some (first, first_pos), Some (second, second_pos) -> ( + OUnit.assert_equal 0 first_pos; + OUnit.assert_equal 2 second_pos; + assert_bool "one request view preserves value type sharing" + (first.val_type == second.val_type); + (match Frozen_values.find view "first" with + | Some (again, _) -> + assert_bool "one view reuses its materialized declaration" (again == first) + | None -> OUnit.assert_failure "expected first value again"); + match first.val_type.desc with + | Types.Tconstr (path, [], _) -> + let expected = + Path.Pdot (Path.Pident (Ident.create_persistent "Api"), "t", Path.nopos) + in + assert_bool "local type identity is prefixed by the importing module" + (Path.same path expected) + | _ -> OUnit.assert_failure "expected a named type") + | _ -> OUnit.assert_failure "expected two exported values" + +let test_views_are_independent _ = + let source = Btype.newgenty (Types.Tvar (Some "a")) in + let image = freeze [Types.Sig_value (Ident.create "value", value source)] in + let get () = + match Frozen_values.find (Frozen_values.create_view image) "value" with + | Some (description, _) -> description.val_type + | None -> OUnit.assert_failure "missing value" + in + let first = Domain.spawn get in + let second = Domain.spawn get in + let first = Domain.join first in + let second = Domain.join second in + assert_bool "domain views own their type nodes" (first != second); + first.desc <- Types.Tvar (Some "changed"); + match (second.desc, source.desc) with + | Types.Tvar (Some "a"), Types.Tvar (Some "a") -> () + | _ -> OUnit.assert_failure "a view changed another graph" + +let test_attributes_are_copied _ = + let attributes = [(Location.mknoloc "tag", Parsetree.PStr [])] in + let image = + freeze + [ + Types.Sig_value + ( Ident.create "value", + value ~attributes (Btype.newgenty (Types.Tvar None)) ); + ] + in + let get () = + match Frozen_values.find (Frozen_values.create_view image) "value" with + | Some (description, _) -> description.val_attributes + | None -> OUnit.assert_failure "missing value" + in + let first = get () in + let second = get () in + assert_bool "metadata does not expose the source or another view" + (first != attributes && first != second); + OUnit.assert_equal attributes first; + OUnit.assert_equal attributes second + +let test_abstract_type_manifest_is_local_and_prefixed _ = + let other_id = Ident.create "other" in + let type_id = Ident.create "t" in + let parameter = Btype.newgenty (Types.Tvar (Some "a")) in + let manifest = + Btype.newgenty + (Types.Tconstr (Path.Pident other_id, [parameter], ref Types.Mnil)) + in + let declaration = + { + abstract_type with + type_params = [parameter]; + type_arity = 1; + type_manifest = Some manifest; + } + in + let image = + freeze + [ + Types.Sig_type (other_id, abstract_type, Types.Trec_not); + Types.Sig_type (type_id, declaration, Types.Trec_not); + ] + in + OUnit.assert_equal 2 (Frozen_values.type_count image); + let first_view = Frozen_values.create_view image in + let second_view = Frozen_values.create_view image in + match + ( Frozen_values.find_type first_view "t", + Frozen_values.find_type second_view "t" ) + with + | Some (first, _), Some (second, _) -> ( + assert_bool "type declaration is cached within one view" + (match Frozen_values.find_type first_view "t" with + | Some (again, _) -> again == first + | None -> false); + assert_bool "type parameters are independent across views" + (List.hd first.type_params != List.hd second.type_params); + match first.type_manifest with + | Some {desc = Types.Tconstr (path, [argument], _)} -> + let expected = + Path.Pdot + (Path.Pident (Ident.create_persistent "Api"), "other", Path.nopos) + in + assert_bool "manifest path is prefixed" (Path.same path expected); + assert_bool "manifest shares its parameter within a view" + (argument == List.hd first.type_params) + | _ -> OUnit.assert_failure "expected a parameterized manifest") + | _ -> OUnit.assert_failure "expected abstract type declarations" + +let test_record_labels_are_local _ = + let field_type = Btype.newgenty (Types.Tvar None) in + let label : Types.label_declaration = + { + ld_id = Ident.create "value"; + ld_runtime_name = None; + ld_mutable = Immutable; + ld_optional = false; + ld_type = field_type; + ld_loc = Location.none; + ld_attributes = []; + } + in + let image = + freeze + [ + Types.Sig_type + ( Ident.create "box", + { + abstract_type with + type_kind = Type_record ([label], Record_regular); + }, + Types.Trec_not ); + ] + in + let first = Frozen_values.create_view image in + let second = Frozen_values.create_view image in + let identifier_time = Ident.current_time () in + match + ( Frozen_values.find_labels first "value", + Frozen_values.find_labels second "value" ) + with + | Some [first_label], Some [second_label] -> ( + OUnit.assert_equal identifier_time (Ident.current_time ()); + assert_bool "label descriptors are request-local" + (first_label != second_label + && first_label.lbl_arg != second_label.lbl_arg + && first_label.lbl_all != second_label.lbl_all); + (match + ( Frozen_values.find_type first "box", + Frozen_values.find_type second "box" ) + with + | ( Some ({type_kind = Types.Type_record ([left], _)}, _), + Some ({type_kind = Types.Type_record ([right], _)}, _) ) -> + assert_bool "label identifiers receive fresh stamps" + (not (Ident.same left.ld_id right.ld_id)) + | _ -> OUnit.assert_failure "expected two record declarations"); + assert_bool "one view reuses its label descriptor" + (match Frozen_values.find_labels first "value" with + | Some [again] -> again == first_label + | _ -> false); + match Frozen_values.find_type first "box" with + | Some (declaration, (_, [type_label])) -> ( + assert_bool "label lookup and type lookup share one description" + (first_label == type_label); + match declaration.type_kind with + | Types.Type_record ([materialized], Types.Record_regular) -> + assert_bool "label type belongs to the same view" + (materialized.ld_type == first_label.lbl_arg) + | _ -> OUnit.assert_failure "expected record type") + | _ -> OUnit.assert_failure "expected a record declaration") + | _ -> OUnit.assert_failure "expected record labels" + +let test_shadowed_record_labels_fall_back _ = + let field_type = Btype.newgenty (Types.Tvar None) in + let label : Types.label_declaration = + { + ld_id = Ident.create "value"; + ld_runtime_name = None; + ld_mutable = Immutable; + ld_optional = false; + ld_type = field_type; + ld_loc = Location.none; + ld_attributes = []; + } + in + let record = + {abstract_type with type_kind = Type_record ([label], Record_regular)} + in + let image = + freeze + [ + Types.Sig_type (Ident.create "box", record, Types.Trec_not); + Types.Sig_type (Ident.create "box", record, Types.Trec_not); + ] + in + match Frozen_values.find_labels (Frozen_values.create_view image) "value" with + | None -> () + | Some _ -> OUnit.assert_failure "shadowed records need component lookup" + +let test_variant_constructors_are_local _ = + let constructor name args : Types.constructor_declaration = + { + cd_id = Ident.create name; + cd_runtime_tag = None; + cd_args = Cstr_tuple args; + cd_res = None; + cd_loc = Location.none; + cd_attributes = []; + } + in + let argument = Btype.newgenty (Types.Tvar None) in + let layout = Variant_runtime.plain_layout [("A", false); ("B", true)] in + let variant = + { + abstract_type with + type_kind = + Type_variant ([constructor "A" []; constructor "B" [argument]], layout); + } + in + let image = + freeze [Types.Sig_type (Ident.create "choice", variant, Types.Trec_not)] + in + let first = Frozen_values.create_view image in + let second = Frozen_values.create_view image in + let identifier_time = Ident.current_time () in + match + ( Frozen_values.find_constructors first "B", + Frozen_values.find_constructors second "B" ) + with + | Some [left], Some [right] -> ( + OUnit.assert_equal identifier_time (Ident.current_time ()); + assert_bool "constructor descriptors and types are request-local" + (left != right && List.hd left.cstr_args != List.hd right.cstr_args); + (match (left.cstr_kind, right.cstr_kind) with + | Types.Ordinary_constructor left_ref, Types.Ordinary_constructor right_ref + -> + assert_bool "runtime layouts are request-local" + (left_ref.variant != right_ref.variant) + | _ -> OUnit.assert_failure "expected ordinary constructors"); + match Frozen_values.find_type first "choice" with + | Some (_, ([first_a; first_b], _)) -> + assert_bool "constructor lookup reuses the type description" + (first_b == left && first_a.cstr_name = "A") + | _ -> OUnit.assert_failure "expected two constructors") + | _ -> OUnit.assert_failure "expected constructor B" + +let test_extension_constructors_are_local _ = + let payload = Btype.newgenty (Types.Tvar None) in + let extension : Types.extension_constructor = + { + ext_type_path = Predef.path_exn; + ext_type_params = []; + ext_args = Cstr_tuple [payload]; + ext_ret_type = None; + ext_private = Public; + ext_loc = Location.none; + ext_attributes = []; + ext_is_exception = true; + } + in + let image = + freeze [Types.Sig_typext (Ident.create "Boom", extension, Text_exception)] + in + let first = Frozen_values.create_view image in + let second = Frozen_values.create_view image in + let identifier_time = Ident.current_time () in + match + ( Frozen_values.find_extension first "Boom", + Frozen_values.find_constructors first "Boom", + Frozen_values.find_extension second "Boom" ) + with + | Some left, Some [again], Some right -> ( + OUnit.assert_equal identifier_time (Ident.current_time ()); + assert_bool "extension lookup reuses the constructor" (left == again); + assert_bool "extension payloads belong to each request" + (List.hd left.cstr_args != List.hd right.cstr_args); + match left.cstr_kind with + | Types.Extension_constructor path -> + assert_bool "extension path includes its signature position" + (Path.same path + (Path.Pdot (Path.Pident (Ident.create_persistent "Api"), "Boom", 0))) + | _ -> OUnit.assert_failure "expected an extension constructor") + | _ -> OUnit.assert_failure "expected a frozen extension constructor" + +let test_nested_scope_paths_and_sharing _ = + let outer_id = Ident.create "outer" in + let inner_id = Ident.create "inner" in + let inner_type = + Btype.newgenty (Types.Tconstr (Path.Pident inner_id, [], ref Types.Mnil)) + in + let outer_type = + Btype.newgenty (Types.Tconstr (Path.Pident outer_id, [], ref Types.Mnil)) + in + let module_decl signature : Types.module_declaration = + { + md_type = Mty_signature signature; + md_attributes = []; + md_loc = Location.none; + } + in + let image = + freeze + [ + Types.Sig_type (outer_id, abstract_type, Trec_not); + Types.Sig_module + ( Ident.create "Nested", + module_decl + [ + Types.Sig_type + ( inner_id, + {abstract_type with type_manifest = Some outer_type}, + Trec_not ); + Types.Sig_value (Ident.create "value", value inner_type); + Types.Sig_module + ( Ident.create "Deep", + module_decl + [Types.Sig_value (Ident.create "value", value inner_type)], + Trec_not ); + ], + Trec_not ); + ] + in + let view = Frozen_values.create_view image in + match Frozen_values.find_module (Frozen_values.root_scope view) "Nested" with + | Some (nested, nested_pos, _, _) -> ( + OUnit.assert_equal 0 nested_pos; + match + ( Frozen_values.find_type_in_scope view nested "inner", + Frozen_values.find_in_scope view nested "value", + Frozen_values.find_module nested "Deep" ) + with + | Some (declaration, _), Some (value, value_pos), Some (deep, deep_pos, _, _) + -> ( + OUnit.assert_equal 0 value_pos; + OUnit.assert_equal 1 deep_pos; + (match declaration.type_manifest with + | Some {desc = Types.Tconstr (path, _, _)} -> + assert_bool "nested manifest resolves an outer binder" + (Path.same path + (Path.Pdot + ( Path.Pident (Ident.create_persistent "Api"), + "outer", + Path.nopos ))) + | _ -> OUnit.assert_failure "expected an outer type manifest"); + match + (value.val_type.desc, Frozen_values.find_in_scope view deep "value") + with + | Types.Tconstr (path, _, _), Some (deep_value, 0) -> + assert_bool "nested binder has a qualified path" + (Path.same path + (Path.Pdot + ( Path.Pdot + (Path.Pident (Ident.create_persistent "Api"), "Nested", 0), + "inner", + Path.nopos ))); + assert_bool "one arena shares types across scopes" + (value.val_type == deep_value.val_type) + | _ -> OUnit.assert_failure "expected a deep value") + | _ -> OUnit.assert_failure "expected nested declarations") + | None -> OUnit.assert_failure "expected a nested frozen signature" + +let test_reused_module_type_has_distinct_binders _ = + let signature_id = Ident.create "S" in + let type_id = Ident.create "t" in + let nested_id = Ident.create "Nested" in + let nested_modtype_id = Ident.create "T" in + let value_type = + Btype.newgenty (Types.Tconstr (Path.Pident type_id, [], ref Types.Mnil)) + in + let signature = + [ + Types.Sig_type (type_id, abstract_type, Trec_not); + Types.Sig_value (Ident.create "value", value value_type); + Types.Sig_module + ( nested_id, + { + md_type = Mty_signature []; + md_attributes = []; + md_loc = Location.none; + }, + Trec_not ); + Types.Sig_module + ( Ident.create "Alias", + { + md_type = Mty_alias (Mta_present, Path.Pident nested_id); + md_attributes = []; + md_loc = Location.none; + }, + Trec_not ); + Types.Sig_modtype + ( nested_modtype_id, + {mtd_type = None; mtd_attributes = []; mtd_loc = Location.none} ); + Types.Sig_modtype + ( Ident.create "AliasT", + { + mtd_type = Some (Mty_ident (Path.Pident nested_modtype_id)); + mtd_attributes = []; + mtd_loc = Location.none; + } ); + ] + in + let module_decl : Types.module_declaration = + { + md_type = Mty_ident (Path.Pident signature_id); + md_attributes = []; + md_loc = Location.none; + } + in + let image = + freeze + [ + Types.Sig_modtype + ( signature_id, + { + mtd_type = Some (Mty_signature signature); + mtd_attributes = []; + mtd_loc = Location.none; + } ); + Types.Sig_module (Ident.create "A", module_decl, Trec_not); + Types.Sig_module (Ident.create "B", module_decl, Trec_not); + ] + in + let view = Frozen_values.create_view image in + let root = Frozen_values.root_scope view in + match + (Frozen_values.find_module root "A", Frozen_values.find_module root "B") + with + | Some (a, 0, _, _), Some (b, 1, _, _) -> ( + match + ( Frozen_values.find_in_scope view a "value", + Frozen_values.find_in_scope view b "value", + Frozen_values.find_module_declaration view root "A", + Frozen_values.find_modtype_declaration view root "S" ) + with + | ( Some (a_value, 0), + Some (b_value, 0), + Some ({md_type = Types.Mty_ident module_type_path}, 0), + Some {mtd_type = Some (Types.Mty_signature _)} ) -> ( + assert_bool "reuse gets independent mutable type graphs" + (a_value.val_type != b_value.val_type); + assert_bool "module type path is prefixed" + (Path.same module_type_path + (Path.Pdot + (Path.Pident (Ident.create_persistent "Api"), "S", Path.nopos))); + let check_alias scope module_name position = + match + ( Frozen_values.find_module_alias view scope "Alias", + Frozen_values.find_module_declaration view scope "Alias" ) + with + | ( Some path, + Some ({md_type = Mty_alias (Mta_present, declaration_path)}, _) ) -> + let expected = + Path.Pdot + ( Path.Pdot + ( Path.Pident (Ident.create_persistent "Api"), + module_name, + position ), + "Nested", + 1 ) + in + assert_bool "reused module type aliases retain their own context" + (Path.same path expected && Path.same declaration_path expected) + | _ -> OUnit.assert_failure "expected a nested module alias" + in + check_alias a "A" 0; + check_alias b "B" 1; + let check_modtype scope module_name position = + match + ( Frozen_values.find_modtype_declaration view scope "T", + Frozen_values.find_modtype_declaration view scope "AliasT" ) + with + | Some {mtd_type = None}, Some {mtd_type = Some (Mty_ident path)} -> + let expected = + Path.Pdot + ( Path.Pdot + ( Path.Pident (Ident.create_persistent "Api"), + module_name, + position ), + "T", + Path.nopos ) + in + assert_bool "reused module type references retain their own context" + (Path.same path expected) + | _ -> OUnit.assert_failure "expected abstract and alias module types" + in + check_modtype a "A" 0; + check_modtype b "B" 1; + match (a_value.val_type.desc, b_value.val_type.desc) with + | Types.Tconstr (a_path, _, _), Types.Tconstr (b_path, _, _) -> + assert_bool "A uses its own abstract type" + (Path.same a_path + (Path.Pdot + ( Path.Pdot (Path.Pident (Ident.create_persistent "Api"), "A", 0), + "t", + Path.nopos ))); + assert_bool "B uses its own abstract type" + (Path.same b_path + (Path.Pdot + ( Path.Pdot (Path.Pident (Ident.create_persistent "Api"), "B", 1), + "t", + Path.nopos ))) + | _ -> OUnit.assert_failure "expected two abstract type paths") + | _ -> OUnit.assert_failure "expected reusable module type entries") + | _ -> OUnit.assert_failure "expected two module type instantiations" + +let test_open_and_inline_record_types _ = + let label : Types.label_declaration = + { + ld_id = Ident.create "field"; + ld_runtime_name = None; + ld_mutable = Immutable; + ld_optional = false; + ld_type = Predef.type_int (); + ld_loc = Location.none; + ld_attributes = []; + } + in + let layout = Variant_runtime.plain_layout [("Case", true)] in + let constructor : Types.constructor_declaration = + { + cd_id = Ident.create "Case"; + cd_runtime_tag = None; + cd_args = Cstr_record [label]; + cd_res = None; + cd_loc = Location.none; + cd_attributes = []; + } + in + let inline_types = [Types.Record {type_name = "payload"; labels = [label]}] in + let image = + freeze + [ + Types.Sig_type + ( Ident.create "open_type", + {abstract_type with type_kind = Type_open}, + Trec_not ); + Types.Sig_type + ( Ident.create "choice", + { + abstract_type with + type_kind = Type_variant ([constructor], layout); + type_inlined_types = inline_types; + }, + Trec_not ); + Types.Sig_type + ( Ident.create "payload", + { + abstract_type with + type_kind = + Type_record + ( [label], + Record_inlined + { + name = "Case"; + representation = {variant = layout; position = 0}; + } ); + type_inlined_types = inline_types; + }, + Trec_not ); + ] + in + let view = Frozen_values.create_view image in + match + ( Frozen_values.find_type view "open_type", + Frozen_values.find_type view "choice", + Frozen_values.find_type view "payload" ) + with + | ( Some ({type_kind = Types.Type_open}, _), + Some ({type_kind = Types.Type_variant (_, variant_layout)}, _), + Some + ( { + type_kind = + Types.Type_record + (_, Types.Record_inlined {representation = inline_ref}); + type_inlined_types = [Types.Record {labels = [inline_label]}]; + }, + _ ) ) -> + assert_bool "inline record shares its variant layout" + (variant_layout == inline_ref.variant); + assert_bool "inline metadata is request-owned" + (inline_label.ld_id != label.ld_id) + | _ -> OUnit.assert_failure "expected open and inline-record types" + +let test_full_signature_copies_are_independent _ = + let source = Btype.newgenty (Types.Tvar (Some "a")) in + let image = freeze [Types.Sig_value (Ident.create "value", value source)] in + let copy () = + match Frozen_values.copy_signature (Frozen_values.create_view image) with + | [Types.Sig_value (_, description)] -> description.val_type + | _ -> OUnit.assert_failure "expected one copied value" + in + let first = copy () in + let second = copy () in + assert_bool "full signature copies have independent type graphs" + (first != second); + first.desc <- Types.Tvar (Some "changed"); + match (second.desc, source.desc) with + | Types.Tvar (Some "a"), Types.Tvar (Some "a") -> () + | _ -> OUnit.assert_failure "a full signature copy leaked into another" + +let test_module_alias_declarations_are_local_and_prefixed _ = + let target = Ident.create "Target" in + let attributes = [(Location.mknoloc "tag", Parsetree.PStr [])] in + let module_decl md_type md_attributes : Types.module_declaration = + {md_type; md_attributes; md_loc = Location.none} + in + let image = + freeze + [ + Types.Sig_module (target, module_decl (Mty_signature []) [], Trec_not); + Types.Sig_module + ( Ident.create "Present", + module_decl (Mty_alias (Mta_present, Path.Pident target)) attributes, + Trec_not ); + Types.Sig_module + ( Ident.create "Absent", + module_decl (Mty_alias (Mta_absent, Path.Pident target)) [], + Trec_not ); + Types.Sig_value + (Ident.create "value", value (Btype.newgenty (Types.Tvar None))); + ] + in + let first = Frozen_values.create_view image in + let second = Frozen_values.create_view image in + assert_bool "module paths do not materialize the type graph" + (not (Frozen_values.has_materialized_type_graph first)); + let lookup view name = + match + Frozen_values.find_module_declaration view + (Frozen_values.root_scope view) + name + with + | Some declaration -> declaration + | None -> OUnit.assert_failure ("missing module alias " ^ name) + in + let present, position = lookup first "Present" in + OUnit.assert_equal 1 position; + assert_bool "alias lookup keeps the type graph lazy" + (not (Frozen_values.has_materialized_type_graph first)); + OUnit.assert_equal attributes present.md_attributes; + let second_present, _ = lookup second "Present" in + assert_bool "alias attributes belong to each request" + (present.md_attributes != second_present.md_attributes); + assert_bool "one request reuses the alias declaration" + (match lookup first "Present" with + | again, _ -> again == present); + let expected = + Path.Pdot (Path.Pident (Ident.create_persistent "Api"), "Target", 0) + in + (match present.md_type with + | Mty_alias (Mta_present, path) -> + assert_bool "alias target is prefixed" (Path.same path expected) + | _ -> OUnit.assert_failure "expected a present alias"); + let absent, _ = lookup first "Absent" in + (match absent.md_type with + | Mty_alias (Mta_absent, path) -> + assert_bool "absent alias target is prefixed" (Path.same path expected) + | _ -> OUnit.assert_failure "expected an absent alias"); + ignore (Frozen_values.find first "value"); + assert_bool "value lookup materializes the type graph" + (Frozen_values.has_materialized_type_graph first) + +let test_module_type_path_qualifies_nested_module _ = + let outer = Ident.create "Outer" in + let module_decl md_type : Types.module_declaration = + {md_type; md_attributes = []; md_loc = Location.none} + in + let image = + freeze + [ + Types.Sig_module + ( outer, + module_decl + (Mty_signature + [ + Types.Sig_modtype + ( Ident.create "S", + { + mtd_type = Some (Mty_signature []); + mtd_attributes = []; + mtd_loc = Location.none; + } ); + ]), + Trec_not ); + Types.Sig_module + ( Ident.create "Uses", + module_decl + (Mty_ident (Path.Pdot (Path.Pident outer, "S", Path.nopos))), + Trec_not ); + ] + in + let view = Frozen_values.create_view image in + match + Frozen_values.find_module_declaration view + (Frozen_values.root_scope view) + "Uses" + with + | Some ({md_type = Mty_ident path}, 1) -> + let expected = + Path.Pdot + ( Path.Pdot (Path.Pident (Ident.create_persistent "Api"), "Outer", 0), + "S", + Path.nopos ) + in + assert_bool "module type path qualifies its local module" + (Path.same path expected) + | _ -> OUnit.assert_failure "expected a qualified module type" + +let test_abstract_module_type_attributes_are_request_local _ = + let attributes = [(Location.mknoloc "tag", Parsetree.PStr [])] in + let image = + freeze + [ + Types.Sig_modtype + ( Ident.create "S", + { + mtd_type = None; + mtd_attributes = attributes; + mtd_loc = Location.none; + } ); + ] + in + let first = Frozen_values.create_view image in + let second = Frozen_values.create_view image in + let find view = + match + Frozen_values.find_modtype_declaration view + (Frozen_values.root_scope view) + "S" + with + | Some declaration -> declaration + | None -> OUnit.assert_failure "expected an abstract module type" + in + let first_declaration = find first in + let second_declaration = find second in + assert_bool "abstract module type is cached within one request" + (find first == first_declaration); + assert_bool "module type attributes belong to each request" + (first_declaration.mtd_attributes != second_declaration.mtd_attributes); + OUnit.assert_equal attributes first_declaration.mtd_attributes; + OUnit.assert_equal None first_declaration.mtd_type + +let suites = + __FILE__ + >::: [ + "prefixed_type_identity_and_positions" + >:: test_prefixed_type_identity_and_positions; + "views_are_independent" >:: test_views_are_independent; + "attributes_are_copied" >:: test_attributes_are_copied; + "abstract_type_manifest_is_local_and_prefixed" + >:: test_abstract_type_manifest_is_local_and_prefixed; + "record_labels_are_local" >:: test_record_labels_are_local; + "shadowed_record_labels_fall_back" + >:: test_shadowed_record_labels_fall_back; + "variant_constructors_are_local" + >:: test_variant_constructors_are_local; + "extension_constructors_are_local" + >:: test_extension_constructors_are_local; + "nested_scope_paths_and_sharing" + >:: test_nested_scope_paths_and_sharing; + "reused_module_type_has_distinct_binders" + >:: test_reused_module_type_has_distinct_binders; + "open_and_inline_record_types" >:: test_open_and_inline_record_types; + "full_signature_copies_are_independent" + >:: test_full_signature_copies_are_independent; + "module_alias_declarations_are_local_and_prefixed" + >:: test_module_alias_declarations_are_local_and_prefixed; + "module_type_path_qualifies_nested_module" + >:: test_module_type_path_qualifies_nested_module; + "abstract_module_type_attributes_are_request_local" + >:: test_abstract_module_type_attributes_are_request_local; + ] diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index 8dad3e6f038..79b59cea351 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -27,6 +27,8 @@ let suites = Ounit_ast_mapper0_tests.suites; Ounit_constructor_arguments_tests.suites; Ounit_object_mutability_tests.suites; + Ounit_frozen_type_graph_tests.suites; + Ounit_frozen_values_tests.suites; Ounit_pattern_printer_tests.suites; Ounit_js_analyzer_tests.suites; Ounit_flow_parser_tests.suites; diff --git a/tests/rewatch_ounit_tests/build_attempt_tests.ml b/tests/rewatch_ounit_tests/build_attempt_tests.ml index 43ec16b62e4..b2adfeafe3a 100644 --- a/tests/rewatch_ounit_tests/build_attempt_tests.ml +++ b/tests/rewatch_ounit_tests/build_attempt_tests.ml @@ -23,6 +23,22 @@ let retained_attempts_start_with_fresh_attempt_state _context = Build_attempt.cleanup_artifacts first; assert_equal 1 !cleanup_count +let full_rebuild_keeps_project_compiler_session _context = + let first = create_full () in + Build_session.mark_parse_pending first.session "Old.res"; + let compiler_session = Build_session.compiler_session first.session in + let second = + Build_attempt.create_full_with_compiler_session ~compiler_session + ~warning_state:(Warning_state.create ()) ~process_poll:None + ~progress:(Output.Progress.create ~enabled:false ~color:false) + ~verbosity:0 + in + assert_bool "a full rebuild retains the compiler dependency session" + (Build_session.compiler_session second.session == compiler_session); + assert_bool "a full rebuild reconstructs the build graph" + (first.session != second.session); + assert_equal [] (Build_session.pending_parse_paths second.session) + let output_inventory_survives_without_cleanup_work _context = let first = create_full () in let outputs = Hashtbl.create 1 in @@ -84,13 +100,141 @@ let log_finalization_runs_once _context = in assert_equal 1 (List.length done_lines)) +let parse_export_preserves_parser_time _context = + Test_support.with_temp_dir "rewatch-parse-export" (fun root -> + let attempt = create_full () in + let source = Test_support.path root "src/A.res" in + let staged_ast = Test_support.path root "lib/bs/src/A.ast" in + let published_ast = Test_support.path root "lib/ocaml/A.ast" in + Test_support.write_file source "let value = 1\n"; + Test_support.write_file staged_ast "parsed AST"; + File_util.ensure_dir (Filename.dirname published_ast); + Unix.utimes staged_ast 1000. 1000.; + let compile_assets = + Compile_assets.create [Filename.dirname published_ast] + in + Build_attempt.add_parse_export attempt ~staged_ast ~published_ast ~source + ~compile_assets; + Build_attempt.start_parse_exports attempt; + Build_attempt.finish_parse_exports attempt; + assert_equal "parsed AST" (File_util.read_file published_ast); + assert_equal 1000. (Unix.stat published_ast).Unix.st_mtime; + assert_equal (Some 1000.) + (Option.map + (fun entry -> entry.Compile_assets.modified) + (Compile_assets.ast compile_assets source)); + Build_attempt.finish_parse_exports attempt) + +let owned_parse_export_persists_after_handoff _context = + Test_support.with_temp_dir "rewatch-owned-parse-export" (fun root -> + let attempt = create_full () in + let source = Test_support.path root "src/A.res" in + let staged_ast = Test_support.path root "lib/bs/src/A.ast" in + let published_ast = Test_support.path root "lib/ocaml/A.ast" in + Test_support.write_file source "let value = 1\n"; + File_util.ensure_dir (Filename.dirname staged_ast); + File_util.ensure_dir (Filename.dirname published_ast); + let compile_assets = + Compile_assets.create [Filename.dirname published_ast] + in + Build_attempt.add_parse_export attempt ~owned_ast:("owned AST", 1000.) + ~staged_ast ~published_ast ~source ~compile_assets; + assert_bool "the parser has not written a staging file" + (not (File_util.exists staged_ast)); + Build_attempt.start_parse_exports attempt; + Build_attempt.finish_parse_exports attempt; + assert_equal "owned AST" (File_util.read_file staged_ast); + assert_equal "owned AST" (File_util.read_file published_ast); + assert_equal 1000. (Unix.stat published_ast).Unix.st_mtime) + +let invalidated_parse_export_is_removed _context = + Test_support.with_temp_dir "rewatch-parse-invalidation" (fun root -> + let attempt = create_full () in + let source = Test_support.path root "src/A.res" in + let staged_ast = Test_support.path root "lib/bs/src/A.ast" in + let published_ast = Test_support.path root "lib/ocaml/A.ast" in + Test_support.write_file source "let value = 1\n"; + Test_support.write_file staged_ast "parsed AST"; + File_util.ensure_dir (Filename.dirname published_ast); + let compile_assets = + Compile_assets.create [Filename.dirname published_ast] + in + Build_attempt.add_parse_export attempt ~staged_ast ~published_ast ~source + ~compile_assets; + Build_attempt.start_parse_exports attempt; + Build_attempt.invalidate_parse_export attempt ~path:published_ast; + Build_attempt.finish_parse_exports attempt; + assert_bool "failed compile must remove a concurrent AST export" + (not (File_util.exists published_ast)); + assert_equal None (Compile_assets.ast compile_assets source)) + +let invalidated_parse_export_skips_pending_copy _context = + Test_support.with_temp_dir "rewatch-invalidated-parse-export" (fun root -> + let attempt = create_full () in + let source = Test_support.path root "src/A.res" in + let staged_ast = Test_support.path root "lib/bs/src/A.ast" in + let published_ast = Test_support.path root "lib/ocaml/A.ast" in + Test_support.write_file source "let value = 1\n"; + File_util.ensure_dir (Filename.dirname published_ast); + let compile_assets = + Compile_assets.create [Filename.dirname published_ast] + in + Test_support.write_file published_ast "old AST"; + Build_attempt.add_parse_export attempt ~staged_ast ~published_ast ~source + ~compile_assets; + Build_attempt.invalidate_parse_export attempt ~path:published_ast; + File_util.remove_file published_ast; + Build_attempt.start_parse_exports attempt; + Build_attempt.finish_parse_exports attempt; + assert_bool "invalidated AST must stay absent" + (not (File_util.exists published_ast)); + assert_equal None (Compile_assets.ast compile_assets source)) + +let failed_parse_export_forces_reparse _context = + Test_support.with_temp_dir "rewatch-parse-export-failure" (fun root -> + let attempt = create_full () in + let source = Test_support.path root "src/A.res" in + let staged_ast = Test_support.path root "lib/bs/src/A.ast" in + let published_ast = Test_support.path root "lib/ocaml/A.ast" in + Test_support.write_file source "let value = 1\n"; + File_util.ensure_dir (Filename.dirname published_ast); + let compile_assets = + Compile_assets.create [Filename.dirname published_ast] + in + Test_support.write_file published_ast "old AST"; + Build_attempt.add_parse_export attempt ~staged_ast ~published_ast ~source + ~compile_assets; + Build_attempt.start_parse_exports attempt; + assert_raises + (Unix.Unix_error (Unix.ENOENT, "open", staged_ast)) + (fun () -> Build_attempt.finish_parse_exports attempt); + assert_bool "failed export must remove the old AST" + (not (File_util.exists published_ast)); + assert_equal None (Compile_assets.ast compile_assets source); + assert_bool "failed export must retry parsing in the retained session" + (List.mem + (Platform.normalize_path_for_comparison source) + (Build_session.pending_parse_paths attempt.session))) + let tests = "build_attempt_tests" >::: [ "retained attempts start with fresh attempt state" >:: retained_attempts_start_with_fresh_attempt_state; + "full rebuild keeps project compiler session" + >:: full_rebuild_keeps_project_compiler_session; "output inventory survives without cleanup work" >:: output_inventory_survives_without_cleanup_work; "pending work is drained once" >:: pending_work_is_drained_once; "log finalization runs once" >:: log_finalization_runs_once; + "parse export preserves parser time" + >:: parse_export_preserves_parser_time; + "owned parse export persists after handoff" + >:: owned_parse_export_persists_after_handoff; + "invalidated parse export is removed" + >:: invalidated_parse_export_is_removed; + "invalidated parse export skips pending copy" + >:: invalidated_parse_export_skips_pending_copy; + "failed parse export forces reparse" + >:: failed_parse_export_forces_reparse; ] diff --git a/tests/rewatch_ounit_tests/compiler_args_tests.ml b/tests/rewatch_ounit_tests/compiler_args_tests.ml index c0c6bd521ed..cfe0cd166fd 100644 --- a/tests/rewatch_ounit_tests/compiler_args_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_args_tests.ml @@ -95,6 +95,26 @@ let tests = "source directory matching respects path-component boundaries"; let config = Config.load_root root in let gentype_config = {config with gentype_args = ["-bs-gentype"]} in + let previous_annotations = Sys.getenv_opt "REWATCH_BIN_ANNOT" in + Fun.protect + ~finally:(fun () -> + match previous_annotations with + | Some value -> Unix.putenv "REWATCH_BIN_ANNOT" value + | None -> Test_support.unsetenv "REWATCH_BIN_ANNOT") + (fun () -> + Unix.putenv "REWATCH_BIN_ANNOT" "0"; + check + ((not (Compiler_args.editor_artifacts_enabled ())) + && Compiler_args.gentype_inputs_enabled gentype_config + && (not (Compiler_args.binary_annotations_enabled gentype_config)) + && not (Compiler_args.compatibility_copies_enabled gentype_config)) + "GenType inputs do not force editor artifacts or copies"; + Unix.putenv "REWATCH_BIN_ANNOT" "1"; + check + (Compiler_args.editor_artifacts_enabled () + && (not (Compiler_args.gentype_inputs_enabled config)) + && Compiler_args.binary_annotations_enabled config) + "editor policy enables annotations without GenType inputs"); let selected_regular = Filename.concat root "selected/regular" in check (Compiler_args.gentype_dependency_args_from_paths gentype_config diff --git a/tests/rewatch_ounit_tests/compiler_driver_tests.ml b/tests/rewatch_ounit_tests/compiler_driver_tests.ml index b04b1cf2bfc..4ca548a43c6 100644 --- a/tests/rewatch_ounit_tests/compiler_driver_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_driver_tests.ml @@ -69,6 +69,31 @@ let gentype_output_capture_tests _context = "GenType warnings use the request-owned stdout formatter"; assert_equal "" stderr +let structured_diagnostic_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let capture label ready other_ready = + Domain.spawn (fun () -> + let buffer = Buffer.create 128 in + let formatter = Stdlib.Format.formatter_of_buffer buffer in + let (), diagnostics = + Location.with_diagnostic_capture (fun () -> + Atomic.set ready true; + while not (Atomic.get other_ready) do + Domain.cpu_relax () + done; + Location.report_error formatter + (Location.error ~loc:Location.none label)) + in + List.map + (fun (diagnostic : Location.diagnostic) -> diagnostic.message) + diagnostics) + in + let left = capture "left" left_ready right_ready in + let right = capture "right" right_ready left_ready in + assert_equal ["left"] (Domain.join left); + assert_equal ["right"] (Domain.join right) + let used_attributes_isolation_tests _context = let loc = {Location.none with loc_ghost = false} in let name = Asttypes.{txt = "as"; loc} in @@ -349,6 +374,32 @@ let output_capture_isolation_tests _context = (Compiler_request_output.stdout_channel () == Stdlib.stdout) "capture scopes restore the host stream" +let output_capture_channel_tests _context = + let (), stdout, stderr = + Compiler_request_output.with_capture (fun () -> + Compiler_request_output.write_stdout "before"; + Stdlib.Format.pp_print_string + (Compiler_request_output.stdout_formatter ()) + "formatted"; + output_value (Compiler_request_output.stdout_channel ()) 42; + Compiler_request_output.write_stdout "after"; + Compiler_request_output.write_stderr "error"; + output_string (Compiler_request_output.stderr_channel ()) " channel") + in + assert_equal ("beforeformatted" ^ Marshal.to_string 42 [] ^ "after") stdout; + assert_equal "error channel" stderr; + (try + ignore + (Compiler_request_output.with_capture (fun () -> + output_string (Compiler_request_output.stdout_channel ()) "x"; + failwith "capture failure")) + with + | Failure _ -> () + | exn -> raise exn); + check + (Compiler_request_output.stdout_channel () == Stdlib.stdout) + "a failed capture restores the host stream" + let annotation_isolation_tests _context = let left_ready = Atomic.make false in let right_ready = Atomic.make false in @@ -505,6 +556,7 @@ let cmt_accumulator_isolation_tests _context = let right_ready = Atomic.make false in let left = Domain.spawn (fun () -> + Clflags.reset (); Cmt_format.clear (); Cmt_format.set_args [|"bsc"; "First.res"|]; Cmt_format.add_saved_type (Cmt_format.Partial_class_expr ()); @@ -516,6 +568,7 @@ let cmt_accumulator_isolation_tests _context = let right = Domain.spawn (fun () -> wait_for_atomic left_ready; + Clflags.reset (); Cmt_format.clear (); Cmt_format.set_args [|"bsc"; "Second.res"|]; Cmt_format.add_saved_type (Cmt_format.Partial_class_expr ()); @@ -684,7 +737,7 @@ let type_node_id_isolation_tests _context = let write root name contents = Test_support.write_file (Filename.concat root name) contents -let run root ?(package = "driver-test") ?(extra = []) input = +let run ?session root ?(package = "driver-test") ?(extra = []) input = let argv = [ "-nostdlib"; @@ -699,14 +752,457 @@ let run root ?(package = "driver-test") ?(extra = []) input = ] @ extra in - ( argv, - Rescript_compiler_driver.run_request ~run_external:None ~cwd:root ~argv - ~input ) + let result = + match session with + | None -> + Rescript_compiler_driver.run_request ~run_external:None ~cwd:root ~argv + ~input + | Some session -> + Env.with_expanded_snapshot_cache (fun () -> + Rescript_compiler_driver.run_request_in_session session + ~run_external:None ~cwd:root ~argv ~input) + in + (argv, result) let expect_code expected result = assert_equal ~printer:string_of_int expected result.Rescript_compiler_driver.exit_code +let semantic_result_isolation_tests _context = + Test_support.with_temp_dir "rewatch-semantic-result-" (fun root -> + write root "Api.res" "let answer = 42\n"; + let session = Rescript_compiler_driver.create_session () in + expect_code 0 (snd (run ~session root "Api.res")); + let path = Filename.concat root "Api.cmt" in + Rescript_compiler_driver.publish_session_semantic session ~retain:true + ~source:path ~destination:path; + let read () = + match + Rescript_compiler_driver.semantic_result session ~filename:path + with + | Some result -> result + | None -> assert_failure "published semantic result was unavailable" + in + let first = read () in + let second = read () in + check (first != second) "semantic views belong to separate requests"; + (match first.Cmt_format.cmt_annots with + | Cmt_format.Implementation _ -> () + | _ -> assert_failure "expected implementation semantics"); + let channel = open_out_gen [Open_append] 0o644 path in + output_char channel '\n'; + close_out channel; + check + (Option.is_none + (Rescript_compiler_driver.semantic_result session ~filename:path)) + "changed CMT invalidates the semantic result") + +let semantic_source_alias_tests _context = + Test_support.with_temp_dir "rewatch-semantic-alias-" (fun root -> + write root "Api.res" "let answer = 42\n"; + let session = Rescript_compiler_driver.create_session () in + expect_code 0 (snd (run ~session root "Api.res")); + let source = Filename.concat root "Api.cmt" in + let destination = Filename.concat root "published.cmt" in + write root "published.cmt" (File_util.read_file source); + Rescript_compiler_driver.publish_session_semantic session ~retain:true + ~source ~destination; + let lookup filename = + Rescript_compiler_driver.semantic_result session ~filename + in + check (Option.is_some (lookup source)) "source alias resolves semantics"; + check + (Option.is_some (lookup destination)) + "published path resolves semantics"; + let channel = open_out_gen [Open_append] 0o644 source in + output_char channel '\n'; + close_out channel; + check + (Option.is_none (lookup source)) + "changed staging source invalidates its alias"; + check + (Option.is_some (lookup destination)) + "published semantics remain valid after source changes") + +let gentype_owned_inputs_tests _context = + Test_support.with_temp_dir "rewatch-gentype-inputs-" (fun root -> + let check_inputs name interface_text implementation_text expected = + write root (name ^ ".resi") interface_text; + write root (name ^ ".res") implementation_text; + expect_code 0 (snd (run root (name ^ ".resi"))); + expect_code 0 + (snd (run root ~extra:["-I"; root; "-bs-read-cmi"] (name ^ ".res"))); + let interface_path = Filename.concat root (name ^ ".cmti") in + let implementation_path = Filename.concat root (name ^ ".cmt") in + let interface = Cmt_format.read_cmt interface_path in + let implementation = Cmt_format.read_cmt implementation_path in + Sys.remove interface_path; + Sys.remove implementation_path; + let inputs = + Gentype_main. + {interface = Some interface; implementation = Some implementation} + in + let selected, has_annotations = + Gentype_main.read_input_cmt ~inputs true interface_path + in + check + (selected == expected ~interface ~implementation) + "GenType selects the supplied semantic input without CMT files"; + check has_annotations "selected GenType input retains annotations" + in + check_inputs "Api" "@genType type t\n" "type t = int\n" + (fun ~interface ~implementation:_ -> interface); + check_inputs "Ignore" "@@genType.ignoreInterface\ntype t\n" + "@genType type t = int\n" (fun ~interface:_ ~implementation -> + implementation)) + +let gentype_summary_validation_tests _context = + Test_support.with_temp_dir "rewatch-gentype-summary-" (fun root -> + let source = "@genType type t = {value: int}\n" in + write root "rescript.json" "{}\n"; + write root "Leaf.res" source; + expect_code 0 (snd (run root ~extra:["-bs-gentype"] "Leaf.res")); + let cmt_file = Filename.concat root "Leaf.cmt" in + let cmi_file = Filename.concat root "Leaf.cmi" in + let summary_file = Gentype_summary.summary_file cmt_file in + check + (Sys.file_exists summary_file) + "GenType writes a declaration summary"; + let read ?(identity = Rescript_compiler_driver.build_identity) + ?(module_ = None) ?(project_root = root) () = + Gentype_summary.with_compiler_identity identity (fun () -> + Gentype_config.with_fresh_flags (fun () -> + Gentype_config.project_root () := project_root; + Gentype_config.module_flag () := module_; + Gentype_summary.read ~cmt_file)) + in + check (Option.is_some (read ())) "matching summary is accepted"; + let summary_contents = File_util.read_file summary_file in + let invalid_summary = Bytes.of_string summary_contents in + Bytes.set invalid_summary 0 'X'; + write root "Leaf.cmt.gts" (Bytes.to_string invalid_summary); + check (Option.is_none (read ())) "invalid summary header falls back"; + write root "Leaf.cmt.gts" summary_contents; + check + (Option.is_none (read ~identity:"other compiler" ())) + "compiler identity invalidates the summary"; + check + (Option.is_none (read ~module_:(Some Gentype_config.CommonJS) ())) + "GenType configuration invalidates the summary"; + check + (Option.is_some (read ~project_root:(root ^ "/consumer") ())) + "another package can use a validated producer summary"; + write root "rescript.json" "{\"name\":\"changed\"}\n"; + check + (Option.is_none (read ~project_root:(root ^ "/consumer") ())) + "producer configuration contents invalidate cross-package summaries"; + write root "rescript.json" "{}\n"; + write root "Leaf.res" (source ^ "\n"); + check (Option.is_none (read ())) "source contents invalidate the summary"; + write root "Leaf.res" source; + let cmi_contents = File_util.read_file cmi_file in + write root "Leaf.cmi" (cmi_contents ^ "\n"); + check + (Option.is_none (read ())) + "dependency contents invalidate the summary"; + write root "Leaf.cmi" cmi_contents; + Sys.remove cmt_file; + check + (Option.is_some (read ())) + "summary supplies declarations without the original CMT") + +let gentype_without_editor_annotations_tests _context = + Test_support.with_temp_dir "rewatch-gentype-no-editor-" (fun root -> + write root "Api.resi" "@genType let answer: int\n"; + write root "Api.res" "let answer = 42\n"; + let no_editor = ["-bs-gentype"; "-bs-no-bin-annot"] in + expect_code 0 (snd (run root ~extra:no_editor "Api.resi")); + check + (not (Sys.file_exists (Filename.concat root "Api.cmti"))) + "GenType interface skips editor annotations"; + check + (Sys.file_exists (Filename.concat root "Api.cmti.gts")) + "GenType interface retains its own semantic input"; + expect_code 0 + (snd + (run root + ~extra:(["-I"; root; "-bs-read-cmi"] @ no_editor) + "Api.res")); + check + (not (Sys.file_exists (Filename.concat root "Api.cmt"))) + "GenType implementation skips editor annotations"; + check + (Sys.file_exists (Filename.concat root "Api.cmt.gts")) + "GenType implementation retains a dependency summary"; + check + (Sys.file_exists (Filename.concat root "Api.gen.tsx")) + "GenType uses the interface summary without a CMTI"; + write root "Bad.res" "@genType let answer: int = \"wrong\"\n"; + let bad = snd (run root ~extra:no_editor "Bad.res") in + check (bad.exit_code <> 0) "invalid GenType source reports a type error"; + check + (not (Sys.file_exists (Filename.concat root "Bad.cmt"))) + "disabled editor annotations skip partial CMTs"; + check + (not (Sys.file_exists (Filename.concat root "Bad.cmt.gts"))) + "failed GenType source has no summary"; + let enabled = snd (run root ~extra:["-bs-gentype"] "Bad.res") in + check (enabled.exit_code <> 0) "enabled editor annotations report errors"; + check + (match + (Cmt_format.read_cmt (Filename.concat root "Bad.cmt")).cmt_annots + with + | Partial_implementation _ -> true + | _ -> false) + "enabled editor annotations retain partial CMTs") + +let published_module_result_tests _context = + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + Test_support.with_temp_dir "rewatch-module-result-" (fun root -> + write root "Api.res" "let answer = 42\n"; + let session = Rescript_compiler_driver.create_session () in + let _, compiled = run ~session root "Api.res" in + expect_code 0 compiled; + let path extension = Filename.concat root ("Api." ^ extension) in + Rescript_compiler_driver.publish_session_cmi session ~retain:true + ~source:(path "cmi") ~destination:(path "cmi"); + Rescript_compiler_driver.publish_session_cmj session ~retain:true + ~source:(path "cmj") ~destination:(path "cmj"); + Rescript_compiler_driver.publish_session_semantic session ~retain:true + ~source:(path "cmt") ~destination:(path "cmt"); + Rescript_compiler_driver.publish_module_result session + ~input:(path "res") ~interface_file:(path "cmi") + ~optimization_file:(Some (path "cmj")) + ~semantic_file:(Some (path "cmt")) + ~dependencies:["Dep"] + ~generated_outputs:[path "js"]; + let result = + match + Rescript_compiler_driver.module_result session + ~interface_file:(path "cmi") + with + | Some result -> result + | None -> assert_failure "published module result unavailable" + in + let open Rescript_compiler_driver in + check + (Option.is_some (interface_fingerprint result)) + "interface fingerprint published"; + check + (Option.is_some (optimization_fingerprint result)) + "optimization fingerprint published"; + check + (Option.is_some (interface_signature result)) + "immutable interface provides a request-owned view"; + check + (Option.is_some (optimization_metadata result)) + "optimization metadata provides a request-owned view"; + check + (Option.is_some (typed_semantic result)) + "typed semantic result is available"; + assert_equal ["Dep"] (result_dependencies result); + assert_equal [path "js"] (result_generated_outputs result); + assert_equal [] (result_diagnostics result); + let channel = open_out_gen [Open_append] 0o644 (path "cmi") in + output_char channel '\n'; + close_out channel; + check + (Option.is_none + (module_result session ~interface_file:(path "cmi"))) + "changed interface invalidates the published result"; + check + (Option.is_none (interface_signature result)) + "a held result cannot expose a changed interface")) + +let virtual_module_artifact_lookup_tests _context = + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + let previous_trace = Sys.getenv_opt "REWATCH_TYPECHECK_TRACE" in + Fun.protect + ~finally:(fun () -> + (match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES"); + match previous_trace with + | Some value -> Unix.putenv "REWATCH_TYPECHECK_TRACE" value + | None -> Test_support.unsetenv "REWATCH_TYPECHECK_TRACE") + (fun () -> + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + Test_support.with_temp_dir "rewatch-virtual-module-" (fun root -> + let producer = Filename.concat root "producer" in + let consumer = Filename.concat root "consumer" in + let published = Filename.concat consumer "lib/ocaml" in + List.iter File_util.ensure_dir [producer; consumer; published]; + let trace = Filename.concat root "trace.tsv" in + Unix.putenv "REWATCH_TYPECHECK_TRACE" trace; + write producer "Api.res" "let identity = x => x\n"; + write consumer "Consumer.res" "let result = Api.identity(42)\n"; + let session = Rescript_compiler_driver.create_session () in + expect_code 0 (snd (run ~session producer "Api.res")); + let source extension = + Filename.concat producer ("Api." ^ extension) + in + let destination extension = + Filename.concat published ("Api." ^ extension) + in + check + (Rescript_compiler_driver.stage_session_cmi session + ~source:(source "cmi") ~destination:(destination "cmi")) + "producer CMI can be staged before export"; + check + (Rescript_compiler_driver.stage_session_cmj session + ~source:(source "cmj") ~destination:(destination "cmj")) + "producer CMJ can be staged before export"; + check + ((not (Sys.file_exists (destination "cmi"))) + && not (Sys.file_exists (destination "cmj"))) + "published paths are absent while the consumer compiles"; + Rescript_compiler_driver.stage_module_result session + ~input:(source "res") ~interface_source:(source "cmi") + ~interface_file:(destination "cmi") + ~optimization_source:(Some (source "cmj")) + ~optimization_file:(Some (destination "cmj")) + ~semantic_source:(Some (source "cmt")) + ~dependencies:["Base"] + ~generated_outputs:[destination "cmi"; destination "cmj"]; + let pending = + match + Rescript_compiler_driver.module_result session + ~interface_file:(destination "cmi") + with + | Some result -> result + | None -> assert_failure "staged module result is unavailable" + in + check + (Option.is_some + (Rescript_compiler_driver.interface_signature pending)) + "the staged result exposes the immutable interface"; + check + (Option.is_some + (Rescript_compiler_driver.optimization_metadata pending)) + "the staged result exposes optimization metadata"; + check + (Option.is_some (Rescript_compiler_driver.typed_semantic pending)) + "the staged result exposes typed semantics"; + assert_equal ["Base"] + (Rescript_compiler_driver.result_dependencies pending); + assert_equal + [destination "cmi"; destination "cmj"] + (Rescript_compiler_driver.result_generated_outputs pending); + let _, compiled = + run ~session consumer ~extra:["-I"; published] "Consumer.res" + in + assert_equal ~msg:compiled.stderr ~printer:string_of_int 0 + compiled.exit_code; + check + (String_util.contains + (File_util.read_file trace) + "dependency.session_cmi_lookup") + "the consumer resolves a CMI through the virtual session path"; + check + (String_util.contains + (File_util.read_file trace) + "dependency.session_cmj_lookup") + "the consumer resolves a CMJ through the virtual session path"; + check + ((not (Sys.file_exists (destination "cmi"))) + && not (Sys.file_exists (destination "cmj"))) + "consumer compilation does not require artifact export"; + Rescript_compiler_driver.discard_pending_session_artifacts session + ~interface_file:(destination "cmi") + ~optimization_file:(Some (destination "cmj")); + check + (Option.is_none + (Rescript_compiler_driver.module_result session + ~interface_file:(destination "cmi"))) + "cancellation withdraws the staged module result")) + +let failed_request_discards_staging_tests _context = + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + Test_support.with_temp_dir "rewatch-staging-failure-" (fun root -> + let session = Rescript_compiler_driver.create_session () in + write root "Api.res" "let answer = 1\n"; + expect_code 0 (snd (run ~session root "Api.res")); + write root "Api.res" "let answer =\n"; + let _, failed = run ~session root "Api.res" in + expect_code 1 failed; + let cmi = Filename.concat root "Api.cmi" in + Rescript_compiler_driver.publish_session_cmi session ~retain:true + ~source:cmi ~destination:cmi; + check + (Option.is_none + (Rescript_compiler_driver.published_fingerprint session + ~kind:Rescript_compiler_driver.Interface ~filename:cmi)) + "a failed replacement cannot publish the previous staged CMI")) + +let superseded_artifact_tests _context = + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + Test_support.with_temp_dir "rewatch-superseded-artifact-" (fun root -> + let session = Rescript_compiler_driver.create_session () in + write root "Api.res" "let answer = 1\n"; + expect_code 0 (snd (run ~session root "Api.res")); + let cmi = Filename.concat root "Api.cmi" in + let channel = open_out_gen [Open_append] 0o644 cmi in + output_char channel '\n'; + close_out channel; + Rescript_compiler_driver.publish_session_cmi session ~retain:true + ~source:cmi ~destination:cmi; + check + (Option.is_none + (Rescript_compiler_driver.published_fingerprint session + ~kind:Rescript_compiler_driver.Interface ~filename:cmi)) + "superseded artifact cannot publish its older image")) + +let gentype_generated_output_result_tests _context = + Test_support.with_temp_dir "rewatch-gentype-result-" (fun root -> + write root "Annotated.res" "@gentype let answer = 42\n"; + let session = Rescript_compiler_driver.create_session () in + let _, compiled = + run ~session root ~extra:["-bs-gentype"] "Annotated.res" + in + expect_code 0 compiled; + let path extension = Filename.concat root ("Annotated." ^ extension) in + Rescript_compiler_driver.publish_session_semantic session ~retain:true + ~source:(path "cmt") ~destination:(path "cmt"); + Rescript_compiler_driver.publish_module_result session ~input:(path "res") + ~interface_file:(path "cmi") + ~optimization_file:(Some (path "cmj")) + ~semantic_file:(Some (path "cmt")) + ~dependencies:[] ~generated_outputs:[]; + let result = + match + Rescript_compiler_driver.module_result session + ~interface_file:(path "cmi") + with + | Some result -> result + | None -> assert_failure "GenType module result unavailable" + in + check + (List.exists + (fun output -> String_util.contains output "Annotated.gen.tsx") + (Rescript_compiler_driver.result_generated_outputs result)) + "generated TypeScript is listed in the module result") + let recovery_tests _context = Test_support.with_temp_dir "rewatch-driver-recovery-" (fun root -> write root "Parse.res" "let value = 1\n"; @@ -718,6 +1214,14 @@ let recovery_tests _context = check (Test_support.contains_text failed.stderr "Syntax error") "parse diagnostics are returned to the host"; + check + (List.exists + (fun (diagnostic : Location.diagnostic) -> + diagnostic.severity = `Error + && diagnostic.location.loc_start.pos_fname <> "" + && diagnostic.message <> "") + failed.diagnostics) + "parse diagnostics have a structured location and message"; write root "Parse.res" "let value = 2\n"; let _, repaired = run root "Parse.res" in expect_code 0 repaired; @@ -728,6 +1232,7 @@ let recovery_tests _context = (Test_support.contains_text failed.stderr "int" && Test_support.contains_text failed.stderr "string") "type diagnostics are returned to the host"; + check (failed.diagnostics <> []) "type diagnostics are structured"; write root "Typed.res" {|let value: string = "repaired"|}; let _, repaired = run root "Typed.res" in expect_code 0 repaired) @@ -883,6 +1388,352 @@ let state_boundary_tests _context = && !(Gentype_config.module_flag ()) = None) "JSX, experimental, and GenType state is restored after the request") +let typed_request_options_tests _context = + Test_support.with_temp_dir "rewatch-typed-options-" (fun root -> + let warning_source = + "let rec notActuallyRecursive = () => 42\n\n\ + let answer = notActuallyRecursive()\n" + in + write root "Override.res" + ("@@config({flags: [\"-warn-error\", \"+39\"]})\n" ^ warning_source); + write root "Plain.res" warning_source; + let session = Rescript_compiler_driver.create_session () in + let common = + [ + "-warn-error"; + "-39"; + "-bs-source-map"; + "linked"; + "-bs-source-map"; + "false"; + ] + in + let compile ?session ?(extra = []) input = + run ?session root ~extra:(common @ extra) input + in + let _, overridden = compile ~session "Override.res" in + expect_code 2 overridden; + let plain_args, plain = compile ~session "Plain.res" in + expect_code 0 plain; + check + (Test_support.contains_text plain.stderr "Warning number 39") + "source warning override does not mutate the cached options"; + check + (not (Sys.file_exists (Filename.concat root "Plain.js.map"))) + "the last source-map option wins"; + let cmt = Cmt_format.read_cmt (Filename.concat root "Plain.cmt") in + assert_equal + (("bsc" :: plain_args) @ ["Plain.res"]) + (Array.to_list cmt.cmt_args); + let session_js = File_util.read_file (Filename.concat root "Plain.js") in + let _, direct = compile "Plain.res" in + expect_code 0 direct; + assert_equal plain.stderr direct.stderr; + assert_equal session_js + (File_util.read_file (Filename.concat root "Plain.js")); + let _, linked = + compile ~session ~extra:["-bs-source-map"; "linked"] "Plain.res" + in + expect_code 0 linked; + check + (Sys.file_exists (Filename.concat root "Plain.js.map")) + "a later option overrides the reusable configuration"; + let _, overridden_again = compile ~session "Override.res" in + expect_code 2 overridden_again; + let _, invalid = + compile ~session ~extra:["-unknown-typed-option"] "Plain.res" + in + expect_code 2 invalid; + check + (Test_support.contains_text invalid.stderr + "Unknown option \"-unknown-typed-option\"") + "invalid options preserve standalone diagnostics"; + let _, version = compile ~session ~extra:["-version"] "Plain.res" in + expect_code 0 version; + check + (Test_support.contains_text version.stdout "ReScript") + "effectful version requests retain standalone dispatch"; + let parallel_session = Rescript_compiler_driver.create_session () in + let left = + Domain.spawn (fun () -> + snd (compile ~session:parallel_session "Override.res")) + in + let right = + Domain.spawn (fun () -> + snd (compile ~session:parallel_session "Plain.res")) + in + expect_code 2 (Domain.join left); + expect_code 0 (Domain.join right)) + +let session_policy_isolation_tests _context = + Test_support.with_temp_dir "rewatch-session-policy-" (fun root -> + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + let session = Rescript_compiler_driver.create_session () in + Rescript_compiler_driver.set_session_frozen_lookup_enabled session + false; + check + (Rescript_compiler_driver.session_handoff_enabled session + && not + (Rescript_compiler_driver.session_frozen_lookup_enabled session) + ) + "classic lookup leaves session handoff enabled"; + write root "Api.resi" "let value: int\n"; + expect_code 0 (snd (run ~session root "Api.resi")); + let source = Filename.concat root "Api.cmi" in + let destination = Filename.concat root "published/Api.cmi" in + File_util.ensure_dir (Filename.dirname destination); + check + (Rescript_compiler_driver.stage_session_cmi session ~source + ~destination) + "classic lookup still captures and stages interfaces"; + check + (Option.is_some + (Rescript_compiler_driver.published_fingerprint session + ~kind:Rescript_compiler_driver.Interface ~filename:destination)) + "staged interface has a session fingerprint"; + Rescript_compiler_driver.set_session_frozen_lookup_enabled session + true; + check + (Option.is_none + (Rescript_compiler_driver.published_fingerprint session + ~kind:Rescript_compiler_driver.Interface ~filename:destination)) + "changing lookup policy discards retained fingerprints"; + write root "Additional.resi" "let additional: int\n"; + expect_code 0 (snd (run ~session root "Additional.resi")); + let additional = Filename.concat root "Additional.cmi" in + check + (Rescript_compiler_driver.stage_session_cmi session + ~source:additional ~destination:additional) + "handoff remains available after lookup policy changes"; + Rescript_compiler_driver.set_session_handoff_enabled session false; + check + (not (Rescript_compiler_driver.session_handoff_enabled session)) + "handoff can be disabled independently"; + check + (Option.is_none + (Rescript_compiler_driver.published_fingerprint session + ~kind:Rescript_compiler_driver.Interface ~filename:additional)) + "changing handoff policy discards retained fingerprints"; + write root "Other.resi" "let other: int\n"; + expect_code 0 (snd (run ~session root "Other.resi")); + let other = Filename.concat root "Other.cmi" in + check + (not + (Rescript_compiler_driver.stage_session_cmi session ~source:other + ~destination:other)) + "disabled handoff does not stage new interfaces")) + +let owned_ast_result_tests _context = + Test_support.with_temp_dir "rewatch-owned-ast-" (fun root -> + let ast_path = Filename.concat root "A.ast" in + write root "A.res" "let value = 1\n"; + expect_code 0 + (snd (run root ~extra:["-bs-ast"; "-o"; "Reference.ast"] "A.res")); + let expected = + File_util.read_file (Filename.concat root "Reference.ast") + in + let session = Rescript_compiler_driver.create_session () in + Rescript_compiler_driver.set_session_owned_ast_enabled session true; + expect_code 0 + (snd (run ~session root ~extra:["-bs-ast"; "-o"; "A.ast"] "A.res")); + check + (not (Sys.file_exists ast_path)) + "owned parser result precedes disk persistence"; + assert_equal (Some []) + (Rescript_compiler_driver.staged_ast_dependencies session ~path:ast_path); + let contents, parsed_at = + match + Rescript_compiler_driver.publish_session_ast session ~source:ast_path + with + | Some owned_ast -> owned_ast + | None -> assert_failure "owned parser result was not published" + in + assert_equal expected contents; + expect_code 0 (snd (run ~session root "A.ast")); + let session_js = File_util.read_file (Filename.concat root "A.js") in + File_util.write_file ast_path contents; + Unix.utimes ast_path parsed_at parsed_at; + expect_code 0 (snd (run root "A.ast")); + assert_equal session_js + (File_util.read_file (Filename.concat root "A.js")); + expect_code 0 + (snd (run ~session root ~extra:["-bs-ast"; "-o"; "A.ast"] "A.res")); + let contents, _ = + match + Rescript_compiler_driver.publish_session_ast session ~source:ast_path + with + | Some owned_ast -> owned_ast + | None -> assert_failure "second owned parser result was not published" + in + File_util.write_file ast_path contents; + Rescript_compiler_driver.record_session_ast_persistence session + ~path:ast_path; + write root "Different.res" "let value = 2\n"; + expect_code 0 + (snd + (run root ~extra:["-bs-ast"; "-o"; "Different.ast"] "Different.res")); + Test_support.rewrite_file ast_path + (File_util.read_file (Filename.concat root "Different.ast")); + expect_code 0 (snd (run ~session root "A.ast")); + check + (File_util.read_file (Filename.concat root "A.js") <> session_js) + "a changed AST file rejects its retained session result"; + write root "A.res" "let value = B.value\n"; + expect_code 0 + (snd (run ~session root ~extra:["-bs-ast"; "-o"; "A.ast"] "A.res")); + assert_equal (Some ["B"]) + (Rescript_compiler_driver.staged_ast_dependencies session ~path:ast_path); + Test_support.rewrite_file + (Filename.concat root "A.res") + "let value = C.value\n"; + assert_equal None + (Rescript_compiler_driver.staged_ast_dependencies session ~path:ast_path); + expect_code 0 + (snd (run ~session root ~extra:["-bs-ast"; "-o"; "A.ast"] "A.res")); + assert_equal (Some ["C"]) + (Rescript_compiler_driver.staged_ast_dependencies session ~path:ast_path)) + +let owned_ast_source_change_fallback_tests _context = + Test_support.with_temp_dir "rewatch-owned-ast-source-change-" (fun root -> + let session = Rescript_compiler_driver.create_session () in + Rescript_compiler_driver.set_session_owned_ast_enabled session true; + let parse name = + let source = name ^ ".res" in + let ast = name ^ ".ast" in + write root source "let value = 1\n"; + expect_code 0 + (snd + (run root ~extra:["-bs-ast"; "-o"; name ^ "Reference.ast"] source)); + let reference = + File_util.read_file (Filename.concat root (name ^ "Reference.ast")) + in + expect_code 0 + (snd (run ~session root ~extra:["-bs-ast"; "-o"; ast] source)); + let path = Filename.concat root ast in + check + (not (Sys.file_exists path)) + "the current AST is still owned before a source change"; + (source, ast, path, reference) + in + let source, _, path, reference = parse "Before" in + write root source "let value = 1000\n"; + assert_equal None + (Rescript_compiler_driver.publish_session_ast session ~source:path); + assert_equal reference (File_util.read_file path); + let source, ast, path, reference = parse "After" in + check + (Option.is_some + (Rescript_compiler_driver.publish_session_ast session ~source:path)) + "the parser hands off its AST before the source changes"; + write root source "let value = 1000\n"; + expect_code 0 (snd (run ~session root ast)); + assert_equal reference (File_util.read_file path)) + +let owned_compiler_artifact_result_tests _context = + Test_support.with_temp_dir "rewatch-owned-artifacts-" (fun root -> + write root "A.res" "let value = 1\n"; + expect_code 0 (snd (run root ~extra:["-bs-ast"; "-o"; "A.ast"] "A.res")); + let session = Rescript_compiler_driver.create_session () in + Rescript_compiler_driver.set_session_owned_artifacts_enabled session true; + expect_code 0 (snd (run ~session root "A.ast")); + let staged_cmi = Filename.concat root "A.cmi" in + let staged_cmj = Filename.concat root "A.cmj" in + check + (not (Sys.file_exists staged_cmi)) + "owned CMI result precedes its staging write"; + check + (not (Sys.file_exists staged_cmj)) + "owned CMJ result precedes its staging write"; + Rescript_compiler_driver.persist_owned_cmi session ~path:staged_cmi; + Rescript_compiler_driver.persist_owned_cmj session ~path:staged_cmj; + check (Sys.file_exists staged_cmi) "the owner persists the captured CMI"; + check (Sys.file_exists staged_cmj) "the owner persists the captured CMJ"; + let owned_bytes = File_util.read_file staged_cmi in + let owned_cmj_bytes = File_util.read_file staged_cmj in + let destination = Filename.concat root "published/A.cmi" in + File_util.ensure_dir (Filename.dirname destination); + check + (Rescript_compiler_driver.stage_session_cmi session ~source:staged_cmi + ~destination) + "the persisted CMI remains available to dependent requests"; + check + (Rescript_compiler_driver.stage_session_cmj session ~source:staged_cmj + ~destination:(Filename.concat root "published/A.cmj")) + "the persisted CMJ remains available to dependent requests"; + expect_code 0 (snd (run root "A.ast")); + assert_equal owned_bytes (File_util.read_file staged_cmi); + assert_equal owned_cmj_bytes (File_util.read_file staged_cmj)) + +let owned_editor_artifact_result_tests _context = + Test_support.with_temp_dir "rewatch-owned-editor-artifacts-" (fun root -> + let session = Rescript_compiler_driver.create_session () in + Rescript_compiler_driver.set_session_owned_artifacts_enabled session true; + let check_artifact name extension source = + let ast = name ^ if extension = ".cmti" then ".iast" else ".ast" in + write root source + (if extension = ".cmti" then "type value = int\n" + else "let value = 1\n"); + expect_code 0 (snd (run root ~extra:["-bs-ast"; "-o"; ast] source)); + let path = Filename.concat root (name ^ extension) in + expect_code 0 (snd (run ~session root ast)); + check + (not (Sys.file_exists path)) + "owned editor output precedes its staging write"; + Rescript_compiler_driver.persist_owned_cmi session + ~path:(Filename.concat root (name ^ ".cmi")); + Rescript_compiler_driver.persist_owned_cmj session + ~path:(Filename.concat root (name ^ ".cmj")); + Rescript_compiler_driver.persist_owned_cmt session ~path; + check (Sys.file_exists path) "the owner persists the editor artifact"; + let owned_bytes = File_util.read_file path in + expect_code 0 (snd (run root ast)); + assert_equal + ~printer:(fun _ -> "") + owned_bytes (File_util.read_file path) + in + check_artifact "Implementation" ".cmt" "Implementation.res"; + check_artifact "Interface" ".cmti" "Interface.resi"; + write root "Broken.res" "let value: string = 1\n"; + expect_code 0 + (snd (run root ~extra:["-bs-ast"; "-o"; "Broken.ast"] "Broken.res")); + expect_code 2 (snd (run ~session root "Broken.ast")); + let partial = Filename.concat root "Broken.cmt" in + check (Sys.file_exists partial) + "failed requests retain their partial editor artifact"; + (match (Cmt_format.read_cmt partial).Cmt_format.cmt_annots with + | Partial_implementation _ -> () + | _ -> assert_failure "failed request should publish partial annotations"); + write root "Stale.res" "let value = 1\n"; + expect_code 0 + (snd (run root ~extra:["-bs-ast"; "-o"; "Stale.ast"] "Stale.res")); + expect_code 0 (snd (run ~session root "Stale.ast")); + write root "Stale.res" "let value = 1000\n"; + [ + (".cmi", Rescript_compiler_driver.persist_owned_cmi); + (".cmj", Rescript_compiler_driver.persist_owned_cmj); + (".cmt", Rescript_compiler_driver.persist_owned_cmt); + ] + |> List.iter (fun (extension, persist) -> + let path = Filename.concat root ("Stale" ^ extension) in + let stale_is_rejected = + try + persist session ~path; + false + with Failure _ -> true + in + check stale_is_rejected + "changed sources reject owned artifact publication"; + check + (not (Sys.file_exists path)) + "stale owned artifact bytes do not reach disk")) + let package_and_load_path_isolation_tests _context = Test_support.with_temp_dir "rewatch-driver-load-roots-" (fun root -> let first = Filename.concat root "first" in @@ -981,6 +1832,713 @@ let interface_namespace_and_load_path_tests _context = ("namespace output is retained: " ^ extension)) ["cmi"; "cmj"; "cmt"]) +let combined_dependency_cache_tests _context = + Test_support.with_temp_dir "rewatch-combined-dependency-" (fun root -> + let previous_cache = Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" in + let previous_trace = Sys.getenv_opt "REWATCH_TYPECHECK_TRACE" in + let previous_frozen = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + (fun () -> + Unix.putenv "REWATCH_FROZEN_VALUES" "0"; + Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" "force"; + let trace = Filename.concat root "dependency-trace.tsv" in + Unix.putenv "REWATCH_TYPECHECK_TRACE" trace; + let compile ?(extra = []) input = + let _, result = run root ~extra:(["-I"; root] @ extra) input in + expect_code 0 result + in + let compile_dependency () = + compile ~extra:["-bs-ns"; "Shapes"] "Circle.resi"; + compile ~extra:["-bs-ns"; "Shapes"; "-bs-read-cmi"] "Circle.res"; + compile ~extra:["-no-alias-deps"] "Shapes.mlmap" + in + write root "Shapes.mlmap" "randjbuildsystem\nCircle\n"; + write root "Circle.resi" "let value: int\n"; + write root "Circle.res" "let value = 1\n"; + compile ~extra:["-no-alias-deps"] "Shapes.mlmap"; + compile_dependency (); + write root "Consumer.res" + "open Shapes.Circle\nlet result: int = value\n"; + compile "Consumer.res"; + let first_cmi = + File_util.read_file (Filename.concat root "Consumer.cmi") + in + let first_cmt = + File_util.read_file (Filename.concat root "Consumer.cmt") + in + compile "Consumer.res"; + check + (Test_support.contains_text + (File_util.read_file trace) + "dependency.snapshot_restore") + "a repeated namespace open copies the combined snapshot"; + Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" "0"; + compile "Consumer.res"; + assert_equal + ~printer:(fun _ -> "") + first_cmi + (File_util.read_file (Filename.concat root "Consumer.cmi")); + assert_equal + ~printer:(fun _ -> "") + first_cmt + (File_util.read_file (Filename.concat root "Consumer.cmt")); + Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" "force"; + let value_path = + let module_path = + Path.Pdot + ( Path.Pident (Ident.create_persistent "Shapes"), + "Circle", + Path.nopos ) + in + Path.Pdot (module_path, "value", Path.nopos) + in + let with_loaded_type ?(load_path = [root]) action = + Fun.protect + (fun () -> + Compiler_request_state.with_fresh ~cwd:root (fun () -> + Env.with_fresh (fun () -> + (Compiler_request_state.current ()).load_path <- + load_path; + action + (Env.find_value value_path Env.empty).Types.val_type))) + ~finally:Env.finalize_expanded_snapshot_cache + in + let loaded_type () = with_loaded_type Fun.id in + let first = loaded_type () in + let second = loaded_type () in + check (first != second) + "cached dependency types belong to each request"; + first.Types.desc <- Types.Tvar (Some "changed"); + check + (match second.Types.desc with + | Types.Tvar (Some "changed") -> false + | _ -> true) + "mutating one request's dependency graph does not affect another"; + Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" "force_typed"; + compile "Consumer.res"; + compile "Consumer.res"; + let reused_first = loaded_type () in + let reused_second = loaded_type () in + check + (reused_first == reused_second) + "one compiler domain reuses its verified-clean dependency graph"; + let project_cache = Env.create_dependency_cache () in + let project_loaded_type () = + Env.with_dependency_cache project_cache loaded_type + in + ignore (project_loaded_type ()); + let project_first = project_loaded_type () in + let project_second = + Domain.spawn project_loaded_type |> Domain.join + in + check + (project_first == project_second) + "a project session reuses its expanded graph on a later domain"; + let compiler_session = Rescript_compiler_driver.create_session () in + let compile_in_session () = + let _, result = + run ~session:compiler_session root ~extra:["-I"; root] + "Consumer.res" + in + expect_code 0 result + in + compile_in_session (); + Domain.spawn compile_in_session |> Domain.join; + assert_equal + ~printer:(fun _ -> "") + first_cmi + (File_util.read_file (Filename.concat root "Consumer.cmi")); + assert_equal + ~printer:(fun _ -> "") + first_cmt + (File_util.read_file (Filename.concat root "Consumer.cmt")); + let other_domain_type = Domain.join (Domain.spawn loaded_type) in + check + (reused_second != other_domain_type) + "different compiler domains have separate dependency graphs"; + with_loaded_type (fun ty -> + ty.Types.desc <- Types.Tvar (Some "changed")); + let restored = loaded_type () in + check (restored != reused_first) + "a changed dependency graph is restored before reuse"; + check + (match restored.Types.desc with + | Types.Tvar (Some "changed") -> false + | _ -> true) + "the restored dependency graph keeps the original type"; + let extra_load_directory = Filename.concat root "extra-load-path" in + File_util.ensure_dir extra_load_directory; + let alternate = + with_loaded_type ~load_path:[extra_load_directory; root] Fun.id + in + check + (alternate != loaded_type ()) + "a different load path does not reuse the prepared dependency graph"; + write root "Circle.resi" "let value: string\n"; + write root "Circle.res" {|let value = "updated"|}; + compile_dependency (); + write root "ConsumerString.res" + "open Shapes.Circle\nlet result: string = value\n"; + compile "ConsumerString.res"; + let _, stale = run root ~extra:["-I"; root] "Consumer.res" in + expect_code 2 stale; + let updated_on_another_domain = + Domain.spawn loaded_type |> Domain.join + in + check + (match updated_on_another_domain.Types.desc with + | Types.Tconstr (path, _, _) -> Path.name path = "string" + | _ -> false) + "a new domain sees the updated dependency interface"; + let updated_in_session = + Domain.spawn project_loaded_type |> Domain.join + in + check + (match updated_in_session.Types.desc with + | Types.Tconstr (path, _, _) -> Path.name path = "string" + | _ -> false) + "a project session invalidates its expanded graph after an edit") + ~finally:(fun () -> + (match previous_trace with + | Some value -> Unix.putenv "REWATCH_TYPECHECK_TRACE" value + | None -> Test_support.unsetenv "REWATCH_TYPECHECK_TRACE"); + (match previous_frozen with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES"); + match previous_cache with + | Some value -> Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" value + | None -> Test_support.unsetenv "REWATCH_COMBINED_SIGNATURE_CACHE")) + +let frozen_overrides_combined_snapshot_tests _context = + Test_support.with_temp_dir "rewatch-frozen-namespace-" (fun root -> + let previous_cache = Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" in + let previous_trace = Sys.getenv_opt "REWATCH_TYPECHECK_TRACE" in + let previous_frozen = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + (match previous_cache with + | Some value -> Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" value + | None -> Test_support.unsetenv "REWATCH_COMBINED_SIGNATURE_CACHE"); + (match previous_trace with + | Some value -> Unix.putenv "REWATCH_TYPECHECK_TRACE" value + | None -> Test_support.unsetenv "REWATCH_TYPECHECK_TRACE"); + match previous_frozen with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + Unix.putenv "REWATCH_FROZEN_VALUES" "0"; + Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" "0"; + write root "Shapes.mlmap" "randjbuildsystem\nCircle\n"; + write root "Circle.resi" "let value: int\n"; + write root "Circle.res" "let value = 1\n"; + let compile ?(extra = []) input = + let result = snd (run root ~extra:(["-I"; root] @ extra) input) in + assert_equal ~msg:result.stderr 0 result.exit_code + in + compile ~extra:["-no-alias-deps"] "Shapes.mlmap"; + compile ~extra:["-bs-ns"; "Shapes"] "Circle.resi"; + compile ~extra:["-bs-ns"; "Shapes"; "-bs-read-cmi"] "Circle.res"; + compile ~extra:["-no-alias-deps"] "Shapes.mlmap"; + write root "Consumer.res" + "open Shapes.Circle\nlet result: int = value\n"; + compile "Consumer.res"; + let output = Filename.concat root "Consumer.js" in + let cmi = Filename.concat root "Consumer.cmi" in + let baseline_js = File_util.read_file output in + let baseline_cmi_info = Cmi_format.read_cmi cmi in + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" "force"; + let trace = Filename.concat root "frozen-trace.tsv" in + Unix.putenv "REWATCH_TYPECHECK_TRACE" trace; + let session = Rescript_compiler_driver.create_session () in + for _ = 1 to 2 do + let result = + snd (run ~session root ~extra:["-I"; root] "Consumer.res") + in + assert_equal ~msg:result.stderr 0 result.exit_code + done; + assert_equal baseline_js (File_util.read_file output); + let frozen_cmi_info = Cmi_format.read_cmi cmi in + let exported_value cmi = + match cmi.Cmi_format.cmi_sign with + | [Types.Sig_value (id, value)] -> + ( Ident.name id, + Stdlib.Format.asprintf "%a" Printtyp.type_expr value.val_type ) + | _ -> assert_failure "Consumer exports one value" + in + assert_equal + (exported_value baseline_cmi_info) + (exported_value frozen_cmi_info); + assert_equal baseline_cmi_info.cmi_flags frozen_cmi_info.cmi_flags; + let external_crcs cmi = + match cmi.Cmi_format.cmi_crcs with + | _self :: dependencies -> dependencies + | [] -> assert_failure "Consumer CMI contains its own CRC" + in + assert_equal + (external_crcs baseline_cmi_info) + (external_crcs frozen_cmi_info); + let trace = File_util.read_file trace in + check + (Test_support.contains_text trace "dependency.frozen_open") + "the forced legacy cache still takes the frozen open path"; + check + (not (Test_support.contains_text trace "dependency.snapshot_reuse")) + "the frozen flag skips the mutable combined snapshot")) + +let runtime_cmi_cache_tests _context = + Test_support.with_temp_dir "rewatch-runtime-cmi-cache-" (fun root -> + let first = Filename.concat root "first" in + let second = Filename.concat root "second" in + File_util.ensure_dir first; + File_util.ensure_dir second; + let install directory kind = + write directory "Api.resi" ("let value: " ^ kind ^ "\n"); + expect_code 0 (snd (run directory "Api.resi")); + let cmi = Cmi_format.read_cmi (Filename.concat directory "Api.cmi") in + ignore + (Cmi_format.create_cmi + (Filename.concat directory "Stdlib.cmi") + {cmi with cmi_name = "Stdlib"; cmi_crcs = []}) + in + install second "int"; + let path = + Path.Pdot + (Path.Pident (Ident.create_persistent "Stdlib"), "value", Path.nopos) + in + let load ?(mutate = false) directories = + Env.with_expanded_snapshot_cache (fun () -> + Fun.protect + (fun () -> + Compiler_request_state.with_fresh ~cwd:root (fun () -> + Env.with_fresh (fun () -> + (Compiler_request_state.current ()).load_path <- + directories; + let value = Env.find_value path Env.empty in + let type_name = + match value.Types.val_type.desc with + | Types.Tconstr (type_path, _, _) -> + Path.name type_path + | _ -> assert_failure "expected a named value type" + in + if mutate then + value.Types.val_type.desc <- + Types.Tvar (Some "changed"); + type_name))) + ~finally:Env.finalize_expanded_snapshot_cache) + in + assert_equal "int" (load [first; second]); + assert_equal "int" (load [first; second]); + assert_equal "int" (load ~mutate:true [first; second]); + assert_equal "int" (load [first; second]); + assert_equal "int" + (Domain.spawn (fun () -> load [first; second]) |> Domain.join); + install first "string"; + assert_equal "string" (load [first; second]); + install first "int"; + assert_equal "int" (load [first; second]); + install second "string"; + assert_equal "string" (load [second; first])) + +let project_cmi_cache_tests _context = + Test_support.with_temp_dir "rewatch-project-cmi-cache-" (fun root -> + write root "Api.resi" "let value: int\n"; + expect_code 0 (snd (run root "Api.resi")); + let first = Env.create_dependency_cache () in + let second = Env.create_dependency_cache () in + let original_loader = !Env.Persistent_signature.load in + let loads = ref 0 in + (Env.Persistent_signature.load := + fun ~unit_name -> + if unit_name = "Api" then incr loads; + original_loader ~unit_name); + Fun.protect + ~finally:(fun () -> Env.Persistent_signature.load := original_loader) + (fun () -> + let path = + Path.Pdot + (Path.Pident (Ident.create_persistent "Api"), "value", Path.nopos) + in + let load cache ?(mutate = false) () = + Env.with_dependency_cache cache (fun () -> + Env.with_expanded_snapshot_cache (fun () -> + Fun.protect + (fun () -> + Compiler_request_state.with_fresh ~cwd:root (fun () -> + Env.with_fresh (fun () -> + (Compiler_request_state.current ()).load_path <- + [root]; + let value = Env.find_value path Env.empty in + let ty = value.Types.val_type in + if mutate then + ty.desc <- Types.Tvar (Some "changed"); + ty))) + ~finally:Env.finalize_expanded_snapshot_cache)) + in + ignore (load first ()); + assert_equal 1 !loads; + ignore (load first ()); + assert_equal ~msg:"one project reuses its loaded interface" 1 !loads; + Domain.spawn (fun () -> ignore (load first ())) |> Domain.join; + assert_equal + ~msg:"a later worker domain reuses the project's interface" 1 !loads; + ignore (load second ()); + assert_equal ~msg:"another project loads its own interface" 2 !loads; + write root "Api.res" "let value = 1\n"; + expect_code 0 (snd (run root "Api.res")); + write root "First.res" "let result = Api.value\n"; + write root "Second.res" "let result = Api.value\n"; + let compiler_session = Rescript_compiler_driver.create_session () in + let first_result = + snd + (run ~session:compiler_session root ~extra:["-I"; root] + "First.res") + in + assert_equal ~msg:first_result.stderr 0 first_result.exit_code; + let after_first_job = !loads in + let second_result = + Domain.spawn (fun () -> + snd + (run ~session:compiler_session root ~extra:["-I"; root] + "Second.res")) + |> Domain.join + in + assert_equal ~msg:second_result.stderr 0 second_result.exit_code; + assert_equal + ~msg:"module jobs in one compiler session reuse the interface" + after_first_job !loads; + ignore (load first ~mutate:true ()); + (match (load first ()).Types.desc with + | Types.Tconstr (type_path, _, _) -> + assert_equal "int" (Path.name type_path) + | _ -> assert_failure "expected the original interface type"); + write root "Api.resi" "let value: string\n"; + expect_code 0 (snd (run root "Api.resi")); + let before_update = !loads in + let updated = load first () in + match updated.Types.desc with + | Types.Tconstr (type_path, _, _) -> + assert_equal "string" (Path.name type_path); + assert_equal ~msg:"an updated interface is loaded again" + (before_update + 1) !loads + | _ -> assert_failure "expected the updated interface type")) + +let frozen_values_tests _context = + Test_support.with_temp_dir "rewatch-frozen-values-" (fun root -> + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + write root "Api.resi" + "type t\n\ + type u = t\n\ + type box = {value: int}\n\ + type choice = A | B(int)\n\ + exception Boom(int)\n\ + module Nested: {\n\ + type item = {value: int}\n\ + let answer: int\n\ + module Deep: {let answer: int}\n\ + exception Oops(int)\n\ + }\n\ + let value: int\n\ + let make: unit => t\n\ + let use: t => int\n"; + expect_code 0 (snd (run root "Api.resi")); + write root "Api.res" + "type t = int\n\ + type u = t\n\ + type box = {value: int}\n\ + type choice = A | B(int)\n\ + exception Boom(int)\n\ + module Nested = {\n\ + type item = {value: int}\n\ + let answer = 2\n\ + module Deep = {let answer = 3}\n\ + exception Oops(int)\n\ + }\n\ + let value = 1\n\ + let make = () => 2\n\ + let use = x => x\n"; + expect_code 0 (snd (run root "Api.res")); + write root "Consumer.res" + "let typed: Api.u = Api.make()\n\ + let result = Api.use(typed)\n\ + let box: Api.box = {value: Api.value}\n\ + let selected = Api.B(2)\n\ + let selectedValue = switch selected {\n\ + | Api.A => 0\n\ + | Api.B(value) => value\n\ + }\n\ + let raised = Api.Boom(3)\n\ + let nested = Api.Nested.answer\n\ + let deep = Api.Nested.Deep.answer\n\ + let boxed: Api.Nested.item = {value: deep}\n\ + let nestedError = Api.Nested.Oops(nested)\n\ + let other = Api.value\n"; + let baseline = snd (run root ~extra:["-I"; root] "Consumer.res") in + assert_equal ~msg:baseline.stderr 0 baseline.exit_code; + let output = Filename.concat root "Consumer.js" in + let baseline_js = File_util.read_file output in + write root "Shadow.res" + "module Api = {let value = 9}\nlet result = Api.value\n"; + let shadow_baseline = + snd (run root ~extra:["-I"; root] "Shadow.res") + in + assert_equal ~msg:shadow_baseline.stderr 0 shadow_baseline.exit_code; + let shadow_output = Filename.concat root "Shadow.js" in + let shadow_baseline_js = File_util.read_file shadow_output in + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + let session = Rescript_compiler_driver.create_session () in + let frozen = + snd (run ~session root ~extra:["-I"; root] "Consumer.res") + in + expect_code 0 frozen; + assert_equal baseline_js (File_util.read_file output); + expect_code 0 + (snd (run ~session root ~extra:["-I"; root] "Shadow.res")); + assert_equal shadow_baseline_js (File_util.read_file shadow_output); + let cache = Env.create_dependency_cache () in + let load ?(mutate = false) ?(load_path = [root]) () = + Env.with_dependency_cache cache (fun () -> + Compiler_request_state.with_fresh ~cwd:root (fun () -> + Env.with_fresh (fun () -> + (Compiler_request_state.current ()).load_path <- + load_path; + let _, description = + Env.lookup_value + (Longident.Ldot (Longident.Lident "Api", "value")) + Env.empty + in + let typ = description.Types.val_type in + let name = + match typ.desc with + | Types.Tconstr (path, _, _) -> Path.name path + | _ -> assert_failure "expected a named type" + in + if mutate then typ.desc <- Types.Tvar None; + (name, typ)))) + in + let constructors name = + Env.with_dependency_cache cache (fun () -> + Compiler_request_state.with_fresh ~cwd:root (fun () -> + Env.with_fresh (fun () -> + (Compiler_request_state.current ()).load_path <- [root]; + Env.lookup_all_constructors + (Longident.Ldot (Longident.Lident "Api", name)) + Env.empty + |> List.map (fun (description, _) -> + description.Types.cstr_name)))) + in + assert_equal "int" (fst (load ~mutate:true ())); + assert_equal "int" (fst (load ())); + let trace_file = Filename.concat root "frozen-cache-hit.tsv" in + let previous_trace = Sys.getenv_opt "REWATCH_TYPECHECK_TRACE" in + Fun.protect + ~finally:(fun () -> + match previous_trace with + | Some path -> Unix.putenv "REWATCH_TYPECHECK_TRACE" path + | None -> Test_support.unsetenv "REWATCH_TYPECHECK_TRACE") + (fun () -> + Unix.putenv "REWATCH_TYPECHECK_TRACE" trace_file; + ignore + (Compiler_phase_trace.request ~cwd:root ~input:"Cache.ast" load)); + let cached_phase = + File_util.read_file trace_file + |> String.split_on_char '\n' + |> List.exists (fun line -> + match String.split_on_char '\t' line with + | _cwd :: _input :: "dependency.frozen_cmi_lookup" :: _ -> true + | _ -> false) + in + check cached_phase "a later request reuses the frozen CMI image"; + let shadow = Filename.concat root "shadow" in + File_util.ensure_dir shadow; + write shadow "Api.resi" "let value: string\n"; + expect_code 0 (snd (run shadow "Api.resi")); + assert_equal "string" (fst (load ~load_path:[shadow; root] ())); + assert_equal "int" (fst (load ())); + assert_equal ["B"] (constructors "B"); + assert_equal ["Boom"] (constructors "Boom"); + let first = Domain.spawn load in + let second = Domain.spawn load in + let first_name, first_type = Domain.join first in + let second_name, second_type = Domain.join second in + assert_equal "int" first_name; + assert_equal "int" second_name; + check + (first_type != second_type) + "workers materialize independent value types"; + write root "Api.resi" + "type t\n\ + type u = t\n\ + type box = {value: int}\n\ + type choice = A | C(int)\n\ + exception Bang(int)\n\ + module Nested: {\n\ + type item = {value: int}\n\ + let answer: int\n\ + module Deep: {let answer: int}\n\ + exception Oops(int)\n\ + }\n\ + let value: string\n\ + let make: unit => t\n\ + let use: t => int\n"; + expect_code 0 (snd (run root "Api.resi")); + write root "Api.res" + "type t = string\n\ + type u = t\n\ + type box = {value: int}\n\ + type choice = A | C(int)\n\ + exception Bang(int)\n\ + module Nested = {\n\ + type item = {value: int}\n\ + let answer = 2\n\ + module Deep = {let answer = 3}\n\ + exception Oops(int)\n\ + }\n\ + let value = \"updated\"\n\ + let make = () => \"updated\"\n\ + let use = x => 1\n"; + expect_code 0 (snd (run root "Api.res")); + assert_equal "string" (fst (load ())); + assert_equal [] (constructors "B"); + assert_equal ["C"] (constructors "C"); + assert_equal [] (constructors "Boom"); + assert_equal ["Bang"] (constructors "Bang"))) + +let frozen_module_forms_tests _context = + Test_support.with_temp_dir "rewatch-frozen-modules-" (fun root -> + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + write root "Other.res" "let value = 7\n"; + expect_code 0 (snd (run root "Other.res")); + write root "Api.res" + "module type S = {type t; let value: t}\n\ + module A: S = {type t = int; let value = 1}\n\ + module B: S = {type t = string; let value = \"b\"}\n\ + module Alias = A\n\ + module External = Other\n\ + module F = (X: S) => {let same: X.t = X.value}\n"; + expect_code 0 (snd (run root ~extra:["-I"; root] "Api.res")); + write root "Consumer.res" + "let a: Api.A.t = Api.A.value\n\ + let b: Api.B.t = Api.B.value\n\ + let aliased: Api.A.t = Api.Alias.value\n\ + let externalValue = Api.External.value\n\ + module Applied = Api.F(Api.A)\n\ + let c = Applied.same\n"; + let baseline = snd (run root ~extra:["-I"; root] "Consumer.res") in + assert_equal ~msg:baseline.stderr 0 baseline.exit_code; + let output = Filename.concat root "Consumer.js" in + let baseline_js = File_util.read_file output in + write root "Bad.res" "let wrong: Api.A.t = Api.B.value\n"; + let baseline_error = snd (run root ~extra:["-I"; root] "Bad.res") in + expect_code 2 baseline_error; + write root "Include.res" + "include Api\nlet fromInclude = External.value\n"; + let included_baseline = + snd (run root ~extra:["-I"; root] "Include.res") + in + assert_equal ~msg:included_baseline.stderr 0 + included_baseline.exit_code; + let include_output = Filename.concat root "Include.js" in + let include_cmi = Filename.concat root "Include.cmi" in + let baseline_include_js = File_util.read_file include_output in + let baseline_include_cmi = File_util.read_file include_cmi in + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + let session = Rescript_compiler_driver.create_session () in + let frozen = + snd (run ~session root ~extra:["-I"; root] "Consumer.res") + in + assert_equal ~msg:frozen.stderr 0 frozen.exit_code; + assert_equal baseline_js (File_util.read_file output); + let frozen_error = + snd (run ~session root ~extra:["-I"; root] "Bad.res") + in + expect_code 2 frozen_error; + assert_equal baseline_error.stderr frozen_error.stderr; + let included_frozen = + snd (run ~session root ~extra:["-I"; root] "Include.res") + in + assert_equal ~msg:included_frozen.stderr 0 included_frozen.exit_code; + assert_equal baseline_include_js (File_util.read_file include_output); + assert_equal baseline_include_cmi (File_util.read_file include_cmi))) + +let frozen_inline_records_tests _context = + Test_support.with_temp_dir "rewatch-frozen-inline-records-" (fun root -> + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + write root "Api.res" + "type choice = Case({field: int})\n\ + type extensible = ..\n\ + type extensible += More({value: int})\n"; + expect_code 0 (snd (run root "Api.res")); + write root "Consumer.res" + "let selected = Api.Case({field: 3})\n\ + let field = switch selected {\n\ + | Api.Case({field}) => field\n\ + }\n\ + let extended = Api.More({value: field})\n"; + let baseline = snd (run root ~extra:["-I"; root] "Consumer.res") in + assert_equal ~msg:baseline.stderr 0 baseline.exit_code; + let output = Filename.concat root "Consumer.js" in + let baseline_js = File_util.read_file output in + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + let session = Rescript_compiler_driver.create_session () in + let frozen = + snd (run ~session root ~extra:["-I"; root] "Consumer.res") + in + assert_equal ~msg:frozen.stderr 0 frozen.exit_code; + assert_equal baseline_js (File_util.read_file output))) + +let frozen_open_tests _context = + Test_support.with_temp_dir "rewatch-frozen-open-" (fun root -> + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Test_support.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + write root "Api.res" + "type choice = A | B(int)\n\ + type box = {value: int}\n\ + exception Boom(int)\n\ + module Nested = {let answer = 2}\n\ + let value = 1\n"; + expect_code 0 (snd (run root "Api.res")); + write root "Consumer.res" + "open Api\n\ + let selected = B(value)\n\ + let boxed: box = {value: value}\n\ + let raised = Boom(value)\n\ + let nested = Nested.answer\n"; + let baseline = snd (run root ~extra:["-I"; root] "Consumer.res") in + assert_equal ~msg:baseline.stderr 0 baseline.exit_code; + let output = Filename.concat root "Consumer.js" in + let baseline_js = File_util.read_file output in + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + let session = Rescript_compiler_driver.create_session () in + let frozen = + snd (run ~session root ~extra:["-I"; root] "Consumer.res") + in + assert_equal ~msg:frozen.stderr 0 frozen.exit_code; + assert_equal baseline_js (File_util.read_file output))) + let concurrent_diagnostic_recovery_tests _context = Test_support.with_temp_dir "rewatch-driver-errors-" (fun root -> let first = Filename.concat root "first" in @@ -1227,6 +2785,22 @@ let tests = "dependency_extraction_isolation" >:: dependency_extraction_isolation_tests; "gentype_output_capture" >:: gentype_output_capture_tests; + "structured_diagnostic_isolation" + >:: structured_diagnostic_isolation_tests; + "semantic_result_isolation" >:: semantic_result_isolation_tests; + "semantic_source_alias" >:: semantic_source_alias_tests; + "gentype_owned_inputs" >:: gentype_owned_inputs_tests; + "gentype_summary_validation" >:: gentype_summary_validation_tests; + "gentype_without_editor_annotations" + >:: gentype_without_editor_annotations_tests; + "published_module_result" >:: published_module_result_tests; + "virtual_module_artifact_lookup" + >:: virtual_module_artifact_lookup_tests; + "failed_request_discards_staging" + >:: failed_request_discards_staging_tests; + "superseded_artifact" >:: superseded_artifact_tests; + "gentype_generated_output_result" + >:: gentype_generated_output_result_tests; "used_attributes_isolation" >:: used_attributes_isolation_tests; "delayed_checks_isolation" >:: delayed_checks_isolation_tests; "gentype_flags_isolation" >:: gentype_flags_isolation_tests; @@ -1238,6 +2812,7 @@ let tests = "env_cache_isolation" >:: env_cache_isolation_tests; "identifier_stamp_isolation" >:: identifier_stamp_isolation_tests; "output_capture_isolation" >:: output_capture_isolation_tests; + "output_capture_channel" >:: output_capture_channel_tests; "annotation_isolation" >:: annotation_isolation_tests; "backend_module_cache_isolation" >:: backend_module_cache_isolation_tests; @@ -1252,11 +2827,28 @@ let tests = "ppx_recovery" >:: ppx_recovery_tests; "control_flow_and_output" >:: control_flow_and_output_tests; "state_boundary" >:: state_boundary_tests; + "typed_request_options" >:: typed_request_options_tests; + "session_policy_isolation" >:: session_policy_isolation_tests; + "owned_ast_result" >:: owned_ast_result_tests; + "owned_ast_source_change_fallback" + >:: owned_ast_source_change_fallback_tests; + "owned_compiler_artifact_result" + >:: owned_compiler_artifact_result_tests; + "owned_editor_artifact_result" >:: owned_editor_artifact_result_tests; "package_and_load_path_isolation" >:: package_and_load_path_isolation_tests; "generated_name_isolation" >:: generated_name_isolation_tests; "interfaces_namespaces_load_paths" >:: interface_namespace_and_load_path_tests; + "combined_dependency_cache" >:: combined_dependency_cache_tests; + "frozen_overrides_combined_snapshot" + >:: frozen_overrides_combined_snapshot_tests; + "runtime_cmi_cache" >:: runtime_cmi_cache_tests; + "project_cmi_cache" >:: project_cmi_cache_tests; + "frozen_values" >:: frozen_values_tests; + "frozen_module_forms" >:: frozen_module_forms_tests; + "frozen_inline_records" >:: frozen_inline_records_tests; + "frozen_open" >:: frozen_open_tests; "concurrent_diagnostic_recovery" >:: concurrent_diagnostic_recovery_tests; "concurrent_jsx_diagnostic" >:: concurrent_jsx_diagnostic_tests; diff --git a/tests/rewatch_ounit_tests/compiler_info_tests.ml b/tests/rewatch_ounit_tests/compiler_info_tests.ml index 43be502ffa9..2fb2cd5c8d7 100644 --- a/tests/rewatch_ounit_tests/compiler_info_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_info_tests.ml @@ -13,14 +13,24 @@ let config root = Unix.mkdir (Filename.concat root "src") 0o755; Config.load_root root -let context ?(inherited_compiler_args = []) root config source_map_args = +let context ?(inherited_compiler_args = []) ?(binary_annotations = true) + ?compatibility_copies ?editor_artifacts ?(gentype_inputs = false) + ?(gentype_disk_publication = false) ?(session_handoff = true) + ?(frozen_values = true) root config source_map_args = let bsc = Filename.concat root "bsc.exe" in 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 ~build_root:root ~compiler_path:bsc + Compiler_info.make_context + ~compatibility_copies: + (Option.value compatibility_copies ~default:binary_annotations) + ~build_root:root ~compiler_path:bsc ~compiler_identity:(Digest.file bsc |> Digest.to_hex) ~runtime_path:runtime ~source_map_args ~inherited_compiler_args + ~binary_annotations + ~editor_artifacts: + (Option.value editor_artifacts ~default:binary_annotations) + ~gentype_inputs ~gentype_disk_publication ~session_handoff ~frozen_values ~package_output_specs:(Compiler_info.package_output_specs config) let tests = @@ -50,6 +60,51 @@ let tests = check (Compiler_info.needs_clean changed config) "changed source-map arguments invalidate artifacts"; + let changed_annotations = + context ~binary_annotations:false root config + ["-bs-source-map"; "linked"] + in + check + (Compiler_info.needs_clean changed_annotations config) + "changed binary annotation mode invalidates artifacts"; + let changed_editor = + context ~editor_artifacts:false root config ["-bs-source-map"; "linked"] + in + check + (Compiler_info.needs_clean changed_editor config) + "editor-artifact policy invalidates artifacts even with annotations on"; + let changed_gentype = + context ~gentype_inputs:true root config ["-bs-source-map"; "linked"] + in + check + (Compiler_info.needs_clean changed_gentype config) + "GenType input policy invalidates artifacts independently"; + let changed_disk_publication = + context ~gentype_disk_publication:true root config + ["-bs-source-map"; "linked"] + in + check + (Compiler_info.needs_clean changed_disk_publication config) + "GenType disk publication policy invalidates artifacts"; + let changed_copies = + context ~compatibility_copies:false root config + ["-bs-source-map"; "linked"] + in + check + (Compiler_info.needs_clean changed_copies config) + "changed compatibility copy mode invalidates artifacts"; + let changed_frozen = + context ~frozen_values:false root config ["-bs-source-map"; "linked"] + in + check + (Compiler_info.needs_clean changed_frozen config) + "changed frozen interface mode invalidates artifacts"; + let changed_handoff = + context ~session_handoff:false root config ["-bs-source-map"; "linked"] + in + check + (Compiler_info.needs_clean changed_handoff config) + "changed session handoff policy invalidates artifacts"; Compiler_info.clean_package config; check (not (Sys.file_exists marker)) "mismatched artifacts are removed"); with_temp_dir (fun root -> @@ -124,19 +179,25 @@ let tests = ] in let initial = - Compiler_info.make_context ~build_root:root ~compiler_path:bsc + Compiler_info.make_context ~editor_artifacts:true ~gentype_inputs:false + ~gentype_disk_publication:false ~session_handoff:true + ~compatibility_copies:true ~build_root:root ~compiler_path:bsc ~compiler_identity:(Digest.file bsc |> Digest.to_hex) ~runtime_path:runtime ~source_map_args:[] ~inherited_compiler_args:[] - ~package_output_specs:commonjs + ~binary_annotations:true ~package_output_specs:commonjs + ~frozen_values:true 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 ~build_root:root ~compiler_path:bsc + Compiler_info.make_context ~editor_artifacts:true ~gentype_inputs:false + ~gentype_disk_publication:false ~session_handoff:true + ~compatibility_copies:true ~build_root:root ~compiler_path:bsc ~compiler_identity:"changed-compiler" ~runtime_path:runtime ~source_map_args:[] ~inherited_compiler_args:[] - ~package_output_specs:esmodule + ~binary_annotations:true ~package_output_specs:esmodule + ~frozen_values:true in check (Compiler_info.needs_clean changed dependency) @@ -154,10 +215,13 @@ let tests = write bsc "compiler-v1"; File_util.ensure_dir runtime; let standalone = - Compiler_info.make_context ~build_root:dependency_root + Compiler_info.make_context ~editor_artifacts:true ~gentype_inputs:false + ~gentype_disk_publication:false ~session_handoff:true + ~compatibility_copies:true ~build_root:dependency_root ~compiler_path:bsc ~compiler_identity:(Digest.file bsc |> Digest.to_hex) ~runtime_path:runtime ~source_map_args:[] ~inherited_compiler_args:[] + ~binary_annotations:true ~frozen_values:true ~package_output_specs:(Compiler_info.package_output_specs dependency) in Compiler_info.write_package standalone dependency; @@ -173,10 +237,14 @@ let tests = ] in let consumer = - Compiler_info.make_context ~build_root:consumer_root ~compiler_path:bsc + Compiler_info.make_context ~editor_artifacts:true ~gentype_inputs:false + ~gentype_disk_publication:false ~session_handoff:true + ~compatibility_copies:true ~build_root:consumer_root + ~compiler_path:bsc ~compiler_identity:(Digest.file bsc |> Digest.to_hex) ~runtime_path:runtime ~source_map_args:[] ~inherited_compiler_args:[] - ~package_output_specs:consumer_specs + ~binary_annotations:true ~package_output_specs:consumer_specs + ~frozen_values:true in check (Compiler_info.owns_outputs dependency) diff --git a/tests/rewatch_ounit_tests/compiler_process_tests.ml b/tests/rewatch_ounit_tests/compiler_process_tests.ml index 51d45d6ee82..779070a2aae 100644 --- a/tests/rewatch_ounit_tests/compiler_process_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_process_tests.ml @@ -180,6 +180,7 @@ let domain_execution_test _context = in let ppx_result = Compiler_process.run + ~session:(Rescript_compiler_driver.create_session ()) Process. { program = ""; @@ -221,10 +222,67 @@ let domain_execution_test _context = with Invalid_argument _ -> true) "domain counts must honor the scheduler bound")) +let project_cache_survives_worker_batches_test _context = + Test_support.with_temp_dir "rewatch-project-worker-cache-" (fun root -> + let write name contents = + Test_support.write_file (Filename.concat root name) contents + in + write "Api.resi" "let value: int\n"; + write "Api.res" "let value = 1\n"; + write "First.res" "let result = Api.value\n"; + write "Second.res" "let result = Api.value\n"; + let job input = + Process. + { + program = ""; + cwd = root; + args = + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + root; + "-bs-package-name"; + "project-worker-cache"; + "-bs-package-output"; + "commonjs:.:.js"; + "-I"; + root; + input; + ]; + } + in + let succeeds result = check (Process.succeeded result) result.stderr in + succeeds (Compiler_process.run (job "Api.resi")); + succeeds (Compiler_process.run (job "Api.res")); + let session = + Build_session.create ~warning_state:(Warning_state.create ()) + |> Build_session.compiler_session + in + let original_loader = !Env.Persistent_signature.load in + let loads = Atomic.make 0 in + (Env.Persistent_signature.load := + fun ~unit_name -> + if unit_name = "Api" then ignore (Atomic.fetch_and_add loads 1); + original_loader ~unit_name); + Fun.protect + ~finally:(fun () -> Env.Persistent_signature.load := original_loader) + (fun () -> + let compile input = + Compiler_process.run_jobs ~session [job input] |> List.iter succeeds + in + compile "First.res"; + assert_equal 1 (Atomic.get loads); + compile "Second.res"; + assert_equal ~msg:"a new worker batch reuses the project cache" 1 + (Atomic.get loads))) + let tests = "compiler_process_tests" >::: [ "publication" >:: publication_tests; "domain_ppx_cancellation" >:: domain_ppx_cancellation_test; "domain_execution" >:: domain_execution_test; + "project_cache_survives_worker_batches" + >:: project_cache_survives_worker_batches_test; ] diff --git a/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml b/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml index 5c6adb73cfc..4d429a23a82 100644 --- a/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml @@ -35,7 +35,7 @@ let source name = is_dev = false; } -let tests = +let existing_tests = "compiler_scheduler_tests" >:: fun _context -> with_single_domain (fun () -> with_temp_dir (fun root -> @@ -86,6 +86,12 @@ let tests = incr c_compilations); Process.task (process_job ())) ~publish:(fun ~source_kind:_ _path _result -> + let on_scheduler = + Thread.id (Thread.self ()) = scheduler_thread + in + check + (on_scheduler = (key = "A")) + "only modules with dependents publish on the scheduler"; write_file cmi_path (if key = "A" then "new interface" else "dependent interface"); if key = "A" && !fail_a_publication then ( @@ -96,6 +102,10 @@ let tests = stderr = ""; cmi_change = (if key = "A" then Cmi_changed else Cmi_unchanged); + optimization_changed = false; + deferred_export = None; + cancel_export = None; + staged_cmi_path = None; }) ~record_published_outputs:(fun ~source_kind:_ _path -> check @@ -127,9 +137,10 @@ let tests = 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 + Compiler_scheduler.run + ~on_ast_invalidation:(fun _ -> ()) + ~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) @@ -188,7 +199,15 @@ let tests = Process.task (process_job ())) ~publish:(fun ~source_kind:_ _path _result -> write_file interrupted_cmi "published CMI"; - Compiler_scheduler.{stderr = ""; cmi_change = Cmi_changed}) + Compiler_scheduler. + { + stderr = ""; + cmi_change = Cmi_changed; + optimization_changed = false; + deferred_export = None; + cancel_export = None; + staged_cmi_path = None; + }) ~record_published_outputs:(fun ~source_kind:_ _path -> ()) ~post_build:(fun output -> [ @@ -206,6 +225,7 @@ let tests = let hook_interrupted = try Compiler_scheduler.run + ~on_ast_invalidation:(fun _ -> ()) ~poll: (Some (fun () -> @@ -244,3 +264,129 @@ let tests = assert_failure "publication capture must retain a CMI change across later copy \ failure")) + +let async_export_tests _context = + 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; + Compiler_log.initialize root; + let build_state = Build_state.create 2 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"]; + 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 + 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 + write_file a_cmi "old interface"; + write_file b_cmi "dependent interface"; + let consumer_started = Atomic.make false in + let exported = Atomic.make false in + let cancelled = Atomic.make false in + let fail_export = ref false in + let successful_task () = + Process.in_process_task (fun () -> + Process.{status = Unix.WEXITED 0; stdout = ""; stderr = ""}) + in + let make key state cmi_path = + Compiler_scheduler.create ~key + ~dependencies:state.Build_state.dependencies ~source:(source key) + ~state ~cmi_path + ~prepare:(fun () -> ()) + ~compile:(fun ~source_kind:_ _path -> + if key = "B" then + Process.in_process_task (fun () -> + check + (not (Atomic.get exported)) + "the dependent starts before export finishes"; + Atomic.set consumer_started true; + Process. + {status = Unix.WEXITED 0; stdout = ""; stderr = ""}) + else successful_task ()) + ~publish:(fun ~source_kind:_ _path _result -> + Compiler_scheduler. + { + stderr = ""; + cmi_change = + (if key = "A" then Cmi_changed else Cmi_unchanged); + optimization_changed = false; + deferred_export = + (if key = "A" then + Some + (fun () -> + let deadline = Unix.gettimeofday () +. 2. in + while + (not (Atomic.get consumer_started)) + && Unix.gettimeofday () < deadline + do + Domain.cpu_relax () + done; + if not (Atomic.get consumer_started) then + failwith "export blocked the dependent"; + if !fail_export then failwith "async export failed"; + write_file a_cmi "new interface"; + Atomic.set exported true) + else None); + cancel_export = + (if key = "A" then + Some (fun () -> Atomic.set cancelled true) + else None); + staged_cmi_path = None; + }) + ~record_published_outputs:(fun ~source_kind:_ _path -> ()) + ~post_build:(fun _ -> []) + ~package_root:root ~is_local:true + ~mark_warning:(fun _ -> ()) + in + let candidates = + [("A", a_state, a_cmi); ("B", b_state, b_cmi)] + |> List.map (fun (key, state, cmi_path) -> + Compiler_scheduler.candidate ~key ~state ~warning_paths:[] + ~make:(fun () -> make key state cmi_path)) + in + let run () = + Compiler_scheduler.run + ~on_ast_invalidation:(fun _ -> ()) + ~poll:None ~warning_state:(Warning_state.create ()) + ~compile_assets:(Compile_assets.create [ocaml_dir]) + ~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 + run (); + check (Atomic.get consumer_started) "the dependent compiled"; + check (Atomic.get exported) "the export completed"; + check + (not (Atomic.get cancelled)) + "a successful export was not cancelled"; + Atomic.set consumer_started false; + Atomic.set exported false; + fail_export := true; + a_state.compile_dirty <- true; + let a_ast = Filename.concat ocaml_dir "A.ast" in + Test_support.write_ast_header a_ast ~dependencies:[] + ~source:"src/A.res"; + let failed = + try + run (); + false + with Compiler_scheduler.Build_failure message -> + Test_support.contains_text message "async export failed" + in + check failed "an asynchronous export error fails the build"; + check (Atomic.get cancelled) "the failed staged result was cancelled"; + check a_state.compile_dirty "the failed producer remains dirty"; + check + (not (Sys.file_exists a_ast)) + "a failed export invalidates persistent freshness")) + +let tests = + "compiler_scheduler_tests" + >::: [existing_tests; "async_export" >:: async_export_tests] diff --git a/tests/rewatch_ounit_tests/file_util_tests.ml b/tests/rewatch_ounit_tests/file_util_tests.ml index 85593542141..797b63e4a72 100644 --- a/tests/rewatch_ounit_tests/file_util_tests.ml +++ b/tests/rewatch_ounit_tests/file_util_tests.ml @@ -173,6 +173,35 @@ let tests = |> List.for_all (fun name -> not (String.starts_with ~prefix:".rewatch-write-" name))) "successful atomic writes should not leave temporary files"; + let atomic_copy = Filename.concat root "atomic-copy" in + File_util.copy_optional_existing_file_atomic first atomic_copy; + check + (File_util.read_file atomic_copy = "same") + "atomic copies publish the complete source"; + if not Sys.win32 then + check + ((Unix.stat atomic_copy).Unix.st_perm = (Unix.stat first).Unix.st_perm) + "new atomic copies retain source permissions"; + let failed_copy = + try + File_util.copy_optional_existing_file_atomic ~ensure_parent:false root + atomic_copy; + false + with Sys_error _ | Unix.Unix_error _ -> true + in + check failed_copy "atomic copies report source read errors"; + check + (File_util.read_file atomic_copy = "same") + "failed atomic copies preserve the previous destination"; + check + (Sys.readdir root |> Array.to_list + |> List.for_all (fun name -> + not (String.starts_with ~prefix:".rewatch-copy-" name))) + "failed atomic copies clean up temporary files"; + File_util.copy_optional_existing_file_atomic missing atomic_copy; + check + (not (Sys.file_exists atomic_copy)) + "missing optional editor artifacts remove old published copies"; if (not Sys.win32) && Sys.file_exists "/dev/full" then check (try diff --git a/tests/rewatch_ounit_tests/test_support.ml b/tests/rewatch_ounit_tests/test_support.ml index 3ccaa3202f8..f37a7e0e23c 100644 --- a/tests/rewatch_ounit_tests/test_support.ml +++ b/tests/rewatch_ounit_tests/test_support.ml @@ -9,6 +9,13 @@ let write_file path contents = ~finally:(fun () -> close_out_noerr channel) (fun () -> output_string channel contents) +let rewrite_file path contents = + let previous = Unix.stat path in + write_file path contents; + (* Rapid same-size writes can retain their timestamp on Windows. Tests of + metadata invalidation need a distinct identity without waiting on a clock. *) + Unix.utimes path previous.Unix.st_atime (previous.Unix.st_mtime +. 1.) + let write_ast_header path ~dependencies ~source = File_util.ensure_dir (Filename.dirname path); let channel = open_out_bin path in diff --git a/tests/rewatch_ounit_tests/watcher_tests.ml b/tests/rewatch_ounit_tests/watcher_tests.ml index 11252d91ff3..5ab66798dca 100644 --- a/tests/rewatch_ounit_tests/watcher_tests.ml +++ b/tests/rewatch_ounit_tests/watcher_tests.ml @@ -232,9 +232,7 @@ let tests = incr builds; match (!builds, changes) with | 1, None -> - let channel = open_out source in - output_string channel "let value = 2\n"; - close_out channel; + Test_support.rewrite_file source "let value = 2\n"; Watcher.Succeeded | 2, Some [Watcher.{path; kind = Modified}] when path = source -> raise Exit