diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7826ca538d..94d3ee4a72 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -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' diff --git a/CHANGELOG.md b/CHANGELOG.md index 311d5eee7f..6d7dc9e407 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -18,6 +18,8 @@ #### :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 @@ -26,10 +28,16 @@ #### :nail_care: Polish +- Speed up OCaml rewatch builds that repeatedly open large signatures by reusing verified expanded signature graphs per compiler worker. https://github.com/rescript-lang/rescript/pull/8673 +- Reuse decoded standard-library interfaces and share prepared signature images across OCaml rewatch workers for faster clean builds. https://github.com/rescript-lang/rescript/pull/8673 +- Keep imported interfaces and expanded signature graphs in a project-owned compiler session across module jobs and watch edits in OCaml rewatch. https://github.com/rescript-lang/rescript/pull/8675 +- Capture text output in memory during OCaml rewatch compiler jobs and use typed graph checks for cached interfaces to reduce clean-build overhead. https://github.com/rescript-lang/rescript/pull/8675 - 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 +- Add an opt-in immutable representation of compiled interfaces for OCaml rewatch experiments (`REWATCH_FROZEN_VALUES=1`), allowing selective lookup without eagerly expanding imported signatures. https://github.com/rescript-lang/rescript/pull/8676 + # 13.0.0-alpha.6 #### :boom: Breaking Change diff --git a/Makefile b/Makefile index f0fda0191d..6760bc2717 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 f2b6cd152f..801a86d3e6 100644 --- a/compiler/bsc/rescript_compiler_driver.ml +++ b/compiler/bsc/rescript_compiler_driver.ml @@ -55,48 +55,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 +546,176 @@ 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 published_cmj = { + filename: string; + source: string option; + stats: Unix.stats; + fingerprint: Digest.t; + image: Js_cmj_format.frozen; +} +type published_ast = {stats: Unix.stats; result: Binary_ast.result} +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 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 = { + dependencies: Env.dependency_cache; + frozen_enabled: bool Atomic.t; + use_frozen_for_compile: bool Atomic.t; + staging_lock: Mutex.t; + staged_cmis: + (string, (Digest.t * Cmi_format.cmi_infos) staged_artifact) Hashtbl.t; + staged_cmjs: (string, (Digest.t * Js_cmj_format.t) staged_artifact) 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, Binary_ast.result staged_artifact) Hashtbl.t; + published_asts: (string, published_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; + mutable semantic_bytes: int; + mutable semantic_generation: int; +} + +let create_session () = + { + dependencies = Env.create_dependency_cache (); + frozen_enabled = Atomic.make true; + use_frozen_for_compile = Atomic.make true; + staging_lock = Mutex.create (); + staged_cmis = Hashtbl.create 32; + staged_cmjs = 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; + semantic_bytes = 0; + semantic_generation = 0; + } + +let set_frozen_for_compile session enabled = + Atomic.set session.use_frozen_for_compile enabled + +let set_session_frozen_enabled session enabled = + Atomic.set session.frozen_enabled enabled + +let session_frozen_enabled session = + Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "0" + && Atomic.get session.frozen_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 staged_ast_dependencies session ~path = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + Hashtbl.find_opt session.staged_asts path + |> Option.map (fun (staged : Binary_ast.result staged_artifact) -> + Binary_ast.dependencies staged.value)) + ~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; + entry) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + match entry with + | None -> None + | Some entry -> ( + try + if same_file_stats (Unix.stat path) entry.stats then Some entry.result + else None + with Sys_error _ | Unix.Unix_error _ -> None) let build_identity = Rescript_compiler_build_identity.value @@ -596,55 +769,761 @@ let with_fresh_request_states ~cwd action = 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 +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 run_argv ?run_external ?frozen_override ~cwd argv = + let input = argv.(Array.length argv - 1) in + 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 + 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); + 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 ~frozen_override ~run_external ~cwd ~argv ~input = + let logical_argv = Array.of_list ("bsc" :: (argv @ [input])) in + run_argv ?run_external ~frozen_override ~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 run_request_in_session session ~run_external ~cwd ~argv ~input = + 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; + Hashtbl.remove session.staged_cmjs path; + 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 frozen_enabled = session_frozen_enabled session in + let cmi_enabled = + frozen_enabled && Sys.getenv_opt "REWATCH_SESSION_CMI" <> Some "0" 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 + let cmj_enabled = + frozen_enabled && Sys.getenv_opt "REWATCH_SESSION_CMJ" <> Some "0" + in + let ast_enabled = + frozen_enabled && Sys.getenv_opt "REWATCH_SESSION_AST" <> Some "0" + in + let use_session_cmj_lookup = + cmj_enabled && Atomic.get session.use_frozen_for_compile + in + let compiled_cmi = ref None in + let compiled_cmj = ref None in + let parsed_ast = ref None in + let semantic = ref None in + let generated_outputs = ref [] in + let run () = + let use_frozen = + frozen_enabled + && (List.mem "-bs-ast" argv + || Atomic.get session.use_frozen_for_compile) + in + run_request_with_frozen ~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 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 ast_enabled then + Binary_ast.with_capture + (fun filename ast -> + parsed_ast := + Some (Compiler_request_state.resolve_path filename, ast)) + run + else run () + in + let run () = + Cmt_format.with_capture + (fun filename cmt -> + semantic := Some (Compiler_request_state.resolve_path filename, cmt)) + 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 + if ast_enabled then + Binary_ast.with_lookup (take_session_ast session) run + else run () + in + (match result.exit_code with + | code when code <> 0 -> () + | _ -> + 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 + 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, fingerprint, cmj) -> + stage session.staged_cmjs filename (fingerprint, cmj)) + !compiled_cmj; + Option.iter + (fun (filename, ast) -> stage session.staged_asts filename ast) + !parsed_ast; + Option.iter + (fun (filename, cmt) -> + if stage_semantic session filename cmt then record filename) + !semantic; + Hashtbl.replace session.staged_request_files input_path !files)) + ~finally:(fun () -> Mutex.unlock session.staging_lock)); + result) + +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 - let exit_code, stdout, stderr = + 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 () -> - 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 + 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 - {exit_code; stdout; stderr}) + 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)) -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 +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 = + let staged = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + let staged = Hashtbl.find_opt session.staged_asts source in + Hashtbl.remove session.staged_asts source; + staged) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + Option.bind staged (validated_stage source) + |> Option.iter (fun result -> + let stats = Unix.stat source in + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> + if Hashtbl.length session.published_asts >= 2048 then + Hashtbl.clear session.published_asts; + Hashtbl.replace session.published_asts source {stats; result}) + ~finally:(fun () -> Mutex.unlock session.staging_lock)) + +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.iter (fun value -> + 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; + session.semantic_generation <- session.semantic_generation + 1; + Hashtbl.replace session.published_semantics destination + {stats; generation = session.semantic_generation; value}; + 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 + done) + ~finally:(fun () -> Mutex.unlock session.staging_lock))) + +let semantic_result session ~filename = + let entry = + Mutex.lock session.staging_lock; + Fun.protect + (fun () -> Hashtbl.find_opt session.published_semantics filename) + ~finally:(fun () -> Mutex.unlock session.staging_lock) + in + match entry with + | None -> None + | Some entry -> ( + try + if same_file_stats (Unix.stat filename) 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 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 diff --git a/compiler/bsc/rescript_compiler_driver.mli b/compiler/bsc/rescript_compiler_driver.mli index e84ef7f944..0750b9caf0 100644 --- a/compiler/bsc/rescript_compiler_driver.mli +++ b/compiler/bsc/rescript_compiler_driver.mli @@ -1,4 +1,24 @@ -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_frozen_enabled : session -> bool -> unit + +val session_frozen_enabled : session -> bool +(** GenType projects retain the classic interface lookup while their typed + output is being checked for frozen-lookup equivalence. The environment + override can also disable this mode for an entire build. *) + +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 +33,114 @@ 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. *) + +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 -> unit +(** Transfer a successful parse result to one later compiler request. + [source] is the absolute staging path; persistent export may run later. *) + +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/core/bs_cmi_load.ml b/compiler/core/bs_cmi_load.ml index 4e1d5e56c8..a0df4ee6b7 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/js_cmj_format.ml b/compiler/core/js_cmj_format.ml index 088f9e1436..f7dbe4ccfa 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -63,6 +63,77 @@ 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 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 make ~(values : cmj_value Map_string.t) ~hoisted_exports ~effect_ ~package_spec ~case : t = { @@ -81,11 +152,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 @@ -108,7 +181,10 @@ let to_file name ~check_exists (v : t) = let oc = open_out_bin (Compiler_request_state.resolve_path name) in output_string oc header; output_string oc s; - close_out oc) + 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 a6a9cf29b7..eca1cd340d 100644 --- a/compiler/core/js_cmj_format.mli +++ b/compiler/core/js_cmj_format.mli @@ -79,6 +79,16 @@ 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 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 97ef444349..e5b196732b 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 08da39f4e7..121dfb37b2 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 3eaab34b99..3d3984580f 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -32,7 +32,9 @@ 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 + Gentype_main.process_cmt_file + ?compiled_cmt:(Cmt_format.last_saved_cmt ()) + cmt_file let after_parsing_sig ppf outputprefix ast = if !((Clflags.current ()).only_parse) = false then ( @@ -54,13 +56,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 +82,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 +92,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 +176,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 +187,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/res_compmisc.ml b/compiler/core/res_compmisc.ml index 7f117a2ad2..9da31a2eff 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 fd46501a03..5dd14d9f28 100644 --- a/compiler/depends/binary_ast.ml +++ b/compiler/depends/binary_ast.ml @@ -29,15 +29,61 @@ 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' @@ -49,18 +95,28 @@ 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 dependencies = + Set_string.elements output_set + |> List.filter (fun s -> s <> "" && s.[0] <> '*') + 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; + 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 + close_out oc; + Option.iter + (fun capture -> + let result = + match kind with + | Ml -> Implementation {sourcefile; dependencies; ast = pt} + | Mli -> Interface {sourcefile; dependencies; ast = pt} + in + capture output result) + (Domain.DLS.get capture_key) diff --git a/compiler/depends/binary_ast.mli b/compiler/depends/binary_ast.mli index 97c98cb12b..fd530278c3 100644 --- a/compiler/depends/binary_ast.mli +++ b/compiler/depends/binary_ast.mli @@ -24,6 +24,25 @@ 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 -> unit) -> (unit -> 'a) -> 'a + +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 0000000000..54aabad268 --- /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 427161961e..f583a21993 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 dde0185c59..6809575cd0 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 926b15c3a2..ff0bd46d3f 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 a2daf826b7..178c998060 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 c496fbae3f..ad49efb0c0 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 d33b6a35a1..55d343b957 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/gentype/gentype_main.ml b/compiler/gentype/gentype_main.ml index 55e02a0693..1cd97f832b 100644 --- a/compiler/gentype/gentype_main.ml +++ b/compiler/gentype/gentype_main.ml @@ -69,6 +69,14 @@ 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 = @@ -80,18 +88,32 @@ let emit_translation ~config ~file_name ~output_file ~output_file_relative 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 +let read_input_cmt ?compiled_cmt is_interface cmt_file = + let implementation_cmt () = + match compiled_cmt with + | Some cmt -> + Compiler_phase_trace.dependency "dependency.gentype_semantic_result" + (fun () -> cmt) + | None -> read_cmt cmt_file + in + let input_cmt = + if is_interface then read_cmt cmt_file else implementation_cmt () + in let ignore_interface = ref false in let check_annotation ~loc:_ attributes = if @@ -112,7 +134,13 @@ 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 compiled_cmt with + | Some cmt -> + Compiler_phase_trace.dependency "dependency.gentype_semantic_result" + (fun () -> 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,7 +161,7 @@ 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 @@ -141,7 +169,7 @@ let process_cmt_file cmt = let file_name = cmt |> Paths.get_module_name in let is_interface = Filename.check_suffix cmt_file ".cmti" in let input_cmt, has_gentype_annotations = - read_input_cmt is_interface cmt_file + read_input_cmt ?compiled_cmt is_interface cmt_file in let source_file = match input_cmt.cmt_annots |> Find_source_file.cmt with diff --git a/compiler/ml/IMMUTABLE_INTERFACES.md b/compiler/ml/IMMUTABLE_INTERFACES.md new file mode 100644 index 0000000000..469aaeffd6 --- /dev/null +++ b/compiler/ml/IMMUTABLE_INTERFACES.md @@ -0,0 +1,448 @@ +# Immutable compiled interfaces: experiment + +## Same-session module results (Goal 3) + +By default, the embedded OCaml Rewatch compiler captures a successful +module's CMI, CMJ, and parser AST before the request ends. It also captures +CMT when binary annotations are enabled. Rewatch stages +the interface and optimization metadata, then publishes an in-memory module +result before scheduling dependent compiler jobs. One export domain copies +independent implementation artifacts while compiler jobs continue. Interface +pairs and modules with JS post-build hooks export in their ordered scheduler +phase. All exports finish before build success. The result API in +`Rescript_compiler_driver` exposes separate interface and +optimization fingerprints, request-owned interface and CMJ views, a cloned +typed semantic result, located diagnostics, dependencies, and generated output +paths. The regular files remain available to standalone tools and new build +sessions. + +The parser hands its AST and dependency list directly to the compiler and +module graph in the same session. The AST is transferred once; a later +request or a cold build reads the file. Type checking resolves a staged CMI to +a frozen interface image; JavaScript compilation resolves a staged CMJ to +frozen optimization metadata. Both lookups validate the selected source +identity and load-path order, including namespace paths and shadowing. A +`.resi` publishes the governing CMI before its `.res` is checked; the +implementation retains that interface and publishes its own CMJ. GenType +consumes the typed implementation result that was just produced, while an +explicit `.cmti` remains a disk input for its separate interface. +The session loader checks actual directory entries before allowing a +lower-case file path to shadow a staged artifact; this also avoids stale +case aliases on case-insensitive filesystems after a failed export. + +Each worker request has independent inference, identifiers, and diagnostics. +The shared images contain no request-owned mutable nodes; callers receive new +views. A later request for the same input removes unfinished staged values, +and a generation check prevents an older, superseded request from staging its +result. Failed and cancelled jobs leave no pending publication. Artifact +publication errors still fail the build. A changed staged fingerprint before +export also fails the build. Rewatch compares the interface CRC and CMJ digest +separately to propagate dependency changes, falling back to artifact byte +comparison when a session fingerprint is unavailable. Deferred CMI and CMJ +exports preserve their producer timestamps when contents change, so a fresh +build process does not mistake them for newer than their compiled consumers. + +When binary annotations are enabled, typed results are retained only for local +modules and only up to 4 MiB each, +64 results, and 16 MiB of total CMT file size. The oldest entries are evicted; +graph accessors return independent values and return `None` after their backing +file changes. +The existing editor/LSP disk-CMT path requires `REWATCH_BIN_ANNOT=1` with OCaml +Rewatch; GenType packages enable binary annotations automatically. Parser jobs +still write ASTs, but publish them to the session before the persistent-cache +copy. One export domain copies ASTs while compilation runs. It preserves the +parser timestamp so the next build does not see an AST newer than its compiled +module. Failed compiler jobs invalidate any concurrent AST export before the +attempt finishes. `REWATCH_ASYNC_AST_EXPORT=0` disables the overlap. +External dependencies, cold starts, CLI +invocations, namespace map exports, leaf artifacts, and other artifact +consumers still use files. PPXs remain external processes. + +The session compiler path is on by default for OCaml Rewatch; set +`REWATCH_FROZEN_VALUES=0` to compare the prior path. Binary annotations are +omitted by default when GenType is absent, saving CMT/CMTI preparation and +serialization. Rewatch then uses the mandatory CMJ as the compiled freshness +marker. `REWATCH_BIN_ANNOT=1` restores CMT/CMTI output and typed-result +retention. GenType projects retain the classic interface lookup: the full +GenType suite found changed TypeScript output with frozen lookup, so those +projects use the checked legacy path until that difference is resolved. +Standalone `bsc` keeps its previous annotation default. +When an implementation has no CMT, publication sets its CMJ modification time +to the compiler completion time even if its CMJ bytes did not change. This +keeps a comment-only edit's newly parsed AST older than the compiled marker, +so the following no-op build stays clean. Deferred exports use the completion +time captured before dependent compilation starts. + +Twenty-one interleaved pairs on 2026-09-26 used four compiler domains and two +synthetic 201-module projects. Each project has a 400-value API with 200 +consumers; the second also stresses nested module signatures and a functor. +Two further 21-pair runs used the repository's 634-module `tests/tests` +project with its React dependency already built. Wall-time medians include +process launch, parse, compile, and artifact export. The classic column is the +former default with binary annotations enabled; the session column also kept +binary annotations enabled for a like-for-like comparison: + +| Workload | Classic | Session | Delta | +| --- | ---: | ---: | ---: | +| Values, clean | 175.05 ms | 152.23 ms | −22.82 ms (−13.04%) | +| Values, one consumer edit | 39.87 ms | 39.45 ms | −0.42 ms (−1.06%) | +| Modules, clean | 175.74 ms | 151.26 ms | −24.48 ms (−13.93%) | +| Modules, one consumer edit | 39.46 ms | 40.57 ms | +1.11 ms (+2.82%) | +| `tests/tests`, clean (42 pairs) | 1569.79 ms | 1521.18 ms | −48.61 ms (−3.10%) | +| `tests/tests`, one file edit (42 pairs) | 114.86 ms | 113.30 ms | −1.57 ms (−1.37%) | + +Two follow-up comparisons used the same 201-module values fixture and four +workers. With binary annotations enabled, 21 measured interleaved pairs gave +153.41 ms median clean builds when AST export finished before compilation and +149.21 ms when it overlapped compilation. One-consumer edits were 39.86 ms +and 39.52 ms. In a separate 11-pair clean comparison with overlapping AST +export, binary annotations took 140.49 ms and omitting them took 129.28 ms. +These are separate runs; their absolute times should not be compared across +experiments. A no-annotation no-op build parsed and compiled zero modules, and +an edited consumer parsed and compiled one module. + +Nine measured interleaved pairs on a copied 634-module `tests/tests` project +compared the old compatible settings (`REWATCH_FROZEN_VALUES=0`, +`REWATCH_BIN_ANNOT=1`, `REWATCH_ASYNC_AST_EXPORT=0`) with the new defaults. +With four workers, clean-build medians were 1320.75 ms and 1226.81 ms, +respectively, a 93.94 ms (7.11%) reduction. Comment-only single-file edits +were 65.10 ms and 62.94 ms; both modes compiled one module and the following +no-op compiled none. The small edit difference is within the range where +earlier runs changed sign, so the clean-build gain is the more reliable result. + +The scheduler skips frozen dependency lookup for fewer than four initially +ready modules unless they depend on each other. This removed a small-edit +regression found in an earlier benchmark. The larger workload initially +regressed by 9.6% on clean builds; +reading the frozen feature setting once per request and memoizing successful +type lookups removed that regression. A traced real-project build reduced +frozen type lookup calls from 934,662 to 761 and their measured allocation +from 271.2 MB to 2.2 MB. In a traced clean values build, 202 AST lookups, +201 CMI lookups, and 200 CMJ lookups used session data; there were no newly +produced AST, CMI, or CMJ file reads in those categories. Four CMI reads +remained for cold standard-library inputs. An integration trace shows the +consumer compiler request starting before its producer's deferred interface +export. A same-path comparison found all 1,206 +selected CMI, CMJ, and JavaScript artifacts byte-identical, with identical +stdout and stderr. The synthetic workloads stress shared imports and gain +13–14% on clean builds. The larger project has fewer shared imports; copying +its independent artifacts after all compiler jobs initially made clean builds +1–2% slower. Overlapping those exports with compiler work removed that +regression. Reusing the staged CMJ image and avoiding repeated path +canonicalization also removed work. The small-edit differences vary in sign +between runs: the two `tests/tests` edit medians were +2.48 ms and −2.15 ms. +These numbers do not predict every project or edit pattern. + +A follow-up tested avoiding the second CMI/CMJ byte write by moving completed +staging files into `lib/ocaml` during asynchronous export. Eleven interleaved +clean-build pairs on the copied 634-module `tests/tests` project, with four +workers, measured 1393.96 ms median for the existing copy path and 1400.54 ms +for the move path. A separate seven-pair trial that waited until all compiler +jobs finished before moving files was also slower (1405.16 ms versus +1413.88 ms). The move implementation was dropped: the copy already overlaps +compiler jobs, and removing it did not improve this workload. This experiment +only measured publication copies; it did not eliminate serialization or the +initial staging-file write inside the compiler. + +Compatibility copies proved more expensive. The compiler writes in-source +JavaScript at its final path; Rewatch also copied it back into `lib/bs` and +copied each parsed source into `lib/ocaml`, then copied it into both `lib/bs` +and `lib/ocaml` after compilation. An eleven-pair isolated comparison on the +copied `tests/tests` project measured 1402.14 ms median clean builds with the +two compiler source copies and 1366.69 ms without them, while retaining the +parser copy and JavaScript mirror in both modes. A separate eleven-pair trial +without the JavaScript mirror measured 1405.42 ms with it and 1345.41 ms +without it. A repeat that included stale-mirror removal reversed the median +difference by 15 ms. The final +default omits all four copies for packages without binary annotations; +`REWATCH_COMPAT_COPIES=1` restores them. These trial medians are from separate +runs and do not establish an additive total gain. + +The final combined mode was measured in 21 interleaved clean-build pairs on +the same copied project with four workers. Compatibility copies took 1395.78 +ms median; the default took 1297.46 ms median, a 98.32 ms (7.04%) reduction. +The median paired saving was 103.10 ms. Final JavaScript, CMI, CMJ, and AST +outputs were still written. This measures one workload and does not establish +the benefit of eliminating compiler staging files themselves. + +## Current boundary + +`Env` borrows decoded CMI graphs from a project cache, one request at a time. +The cache verifies their mutable fields at request end and restores a saved +marshaled image after a change. This avoids most repeated decoding, but it +cannot share a graph with concurrent compiler domains. The large alias cache +similarly shares a marshaled prepared image and gives each domain its own +decoded graph. + +The exposed `Types.type_expr` graph is unsuitable for direct sharing. Its +`desc`, `level`, and `id` fields are mutable. `Ctype.instance` temporarily +installs `Tsubst` marks in source nodes; `Subst` does the same while copying +signatures and component declarations. Abbreviation memos, polymorphic +variant row references, object-field mutability classes, `Ident` stamps, and +record layout references are also mutable. A caller can receive declarations +or component descriptions that refer back into the imported graph. + +## First measurement + +A local synthetic project used a 26 KiB `Api.cmi` with 400 exported integer +values, a polymorphic identity function, and a parameterized record. Two +hundred implementation modules each import it. Four compiler domains built +201 modules. The probe used the retained project cache and the exclusive +`REWATCH_TYPECHECK_TRACE` phase timer. The numbers below are **summed worker +time**, not wall-time savings, from one traced clean build on 2026-09-25. + +| Implementation-request work | Cached | Cache disabled | +| --- | ---: | ---: | +| CMI read and decode | 3.7 ms, 1.0 MB, 11 calls | 175.0 ms, 46.3 MB, 603 calls | +| Imported `Subst.signature` copies | 18.5 ms, 39.6 MB, 201 calls | 16.2 ms, 39.6 MB, 201 calls | +| Component-item construction, including `Subst` copies | 65.9 ms, 111.3 MB, 602 calls | 82.8 ms, 111.3 MB, 602 calls | +| CMI cache validation, capture, and verification | 26.2 ms, 6.0 MB | absent | + +The two consumer phases still allocate about 151 MB across the cached build. +Their time varies between runs, but their allocation is stable. The current +cache eliminates most decoding and does **not** eliminate those copies. A +representation that merely freezes and then fully thaws every interface for +each request would give much of the decoding cost back. The first version +should preserve these phase labels and add materialized-node counts so the +comparison is direct. + +The `frozen_type_graph_probe` microprobe used the same `Api.cmi` for 200 +operations in one process. The arena had 403 type roots and 403 type nodes. +Freezing those roots took 12.8 ms and 18.7 MB; thawing all of them took 7.8 +ms and 11.7 MB. Materializing only the first root 200 times took 0.14 ms and +0.7 MB. Decoding a marshaled **whole CMI** 200 times took 20.2 ms and 28.6 +MB; `Subst.signature` took 11.6 ms and 39.3 MB. For `Stdlib.cmi` (30 roots, +73 nodes), 200 full thaws took 0.45 ms and 2.4 MB. These are diagnostic +single-run measurements, not equivalent operations: the arena probe omits +signature metadata and component tables. They show that selective +materialization can be cheap, while full materialization leaves substantial +consumer work. + +The same probe on the larger `JsxDOMStyle.cmi` (505 roots, 1,010 nodes) took +1.5 ms and 2.9 MB for 20 full thaws; `Subst.signature` took 1.8 ms and 5.5 +MB. Another run measured 2.0 versus 1.7 ms, respectively. Whole-graph thaw +is in the same time range as the existing signature copy before metadata and +component work. This favors direct frozen lookups and per-use instantiation +over whole-interface thawing. + +This fixture stresses repeated flat value exports. It says little about +functors, recursive modules, large variants, deeply nested signatures, or +watch invalidation. Its trace cannot be extrapolated to the testrepo or a +production project. The testrepo's installed PPX in this workspace is a +macOS binary, so the local testrepo build failed before compiler measurements. + +## Proposed representation + +A project owns an `interface_image` assembled once from each accepted CMI: + +```text +interface_image + file identity + content digest + immutable identifier table (name, original stamp, flags, binder token) + immutable path table (identifier and path indices) + immutable type arena (indexed graph, levels, descriptor payloads) + immutable signature and declaration tables (indices into the same arenas) + immutable name/component indexes (values, types, constructors, labels, + modules, module types) +``` + +The arena uses integer edges rather than `type_expr` pointers, so it can +represent sharing and cycles without linkable source nodes. Every reference +in the image must lead to another immutable value; in particular, a `ref`, +array, mutable identifier, or mutable layout cannot be reachable through a +public accessor. The image is published to the project's workers only after +validation and complete construction. Its cache key includes the resolved +path and CMI identity; a changed or newly shadowing CMI gets a new image. +Existing CMI file format and digest semantics stay unchanged. + +Each compile request owns a small view over an image. The view maps image +binder tokens to request-local `Ident.t`s and applies module and type path +substitutions without copying the image. Ordinary value lookup returns a +scheme handle. Instantiation walks that frozen scheme with a **request-local** +memo from arena index to fresh `type_expr`, preserving aliases within one use +while giving sibling uses independent inference variables. `Tpoly` bound +variables and row references need the same rule. Object-field mutability +classes become fresh cells per generalized instance, preserving class +sharing inside that instance; non-generalized occurrences instead share a +request-local cell. Abbreviation expansions and speculative trail state live +in the request view, keyed by arena index, and never write into the image. + +Type constructor identity must come from the image's binder token plus its +instantiation context, rather than from a copied node's physical address. +Functor application creates a fresh request-local context; aliases that point +to the same exported constructor retain one token. This must be verified with +module inclusion, GADTs, recursive types, and polymorphic variants. Imported +record labels and constructor descriptions can be indexed immutably, but +their current mutable `lbl_all` and layout behavior needs request-local +overlays or an explicit immutable replacement before direct publication. + +The checker should keep `Types.type_expr` for local inference and typed-tree +output while imported schemes use a separate immutable type. The boundary is +an API, not a convention to refrain from writing to an ordinary `type_expr`. +Any operation that genuinely needs a mutable imported graph can materialize +only the reached subgraph in the request view and count those nodes. That +fallback preserves behavior while revealing whether consumers force costly +copying. + +## Prototype and integrated experiments + +`Frozen_type_graph` is an initial arena for type expressions. It +snapshots identifier and path data, object-field mutability equivalence +classes, and polymorphic-variant row references; it rejects active `Tsubst` +and abbreviation memo state. A request-local view lazily materializes roots +while preserving cycles and sharing. Unit tests exercise polymorphic +instantiation, aliasing, class independence, cycles, concurrent views, and +rejection of transient state. + +`Frozen_values` adds immutable indexes for exported values, all completed type +kinds, record labels, variant and extension constructors, modules, and module +types in nested signatures. It snapshots runtime layouts and inline-record +metadata. A module typed by a locally declared module type gets a separate +path-substitution context over the same immutable type arena, so repeated +uses retain distinct abstract type identities. Module aliases can traverse +to the target image, including another compilation unit. When +`REWATCH_FROZEN_VALUES=1`, `Env` builds the image once for each accepted CMI +in a project dependency cache and shares it between domains. + +Each compile request gets its own view and materializes reached declarations +and type nodes. Opened imports use on-demand name sources in `Env` instead of +building every component. Module and module-type declarations are decoded and +substituted one at a time; functor applications use a request-owned component +for the reached functor. Full-signature consumers and legacy component +expansion decode private copies from immutable signature bytes. Mutable label +and constructor descriptions, runtime layout references, and attribute +payloads belong to the view. Imported member identifiers use a reserved +stamp range, so materialization does not renumber identifiers emitted by the +compiling module. A failed arena snapshot or a shape that needs contextual +substitution still uses request-owned fallback structures. The CMI format is +unchanged and the flag remains off by default. + +The flag takes precedence over `REWATCH_COMBINED_SIGNATURE_CACHE`, including +its `force` setting. A namespace-open regression test confirms that the older +mutable combined snapshot is skipped. Avoiding eager expansion can change an +internal identifier stamp in a consumer's CMI, and therefore its self CRC, +even when the exported value, type, dependency CRCs, and JavaScript agree. +This can cause downstream rebuilds when switching flag settings. + +A values-only variant of the same synthetic fixture used 200 consumers and +four compiler domains. Each consumer accessed two `Api` values. With the +retained CMI cache active in both configurations, one traced clean build on +2026-09-25 gave the following **summed worker time and allocation**: + +| Implementation-request work | Existing path | Frozen values | +| --- | ---: | ---: | +| Component construction | 64.4 ms, 111.3 MB, 602 calls | 25.0 ms, 40.8 MB, 402 calls | +| `Api` component expansion | 200 calls | 0 calls | +| `Api` signature copy | 0.1 ms, 0.2 MB, 1 call | 0.1 ms, 0.2 MB, 1 call | +| Frozen image preparation | absent | 0.1 ms, 0.4 MB, 1 call | +| Direct frozen value lookup | absent | 1.4 ms, 0.3 MB, 600 calls | + +The signature-copy count reflects a separate path-normalization improvement: +normalizing a persistent compilation-unit root now validates its CMI without +copying the whole signature. Before that change, both configurations copied +`Api`'s signature 201 times, allocating 39.6 MB. The remaining copy checks +the implementation against `Api.resi`. + +Across all 201 implementation requests, summed worker time fell from 208.6 +to 176.0 ms and allocation from 174.8 to 107.1 MB. All 1,610 selected CMI, +CMJ, JavaScript, and AST artifacts in the two builds were byte-identical. In +11 interleaved clean-build pairs, median wall time +was 165.38 ms with the existing path and 161.07 ms with frozen values; eight +pairs favored frozen values. This is a small directional result for a +synthetic, flat interface, not a general speed estimate. The large residual +component work comes from dependencies outside the direct `Api` lookup path. +This was the first flat-interface measurement, before the nested, extension, +and opened-name work below. + +The next fixture exported 200 abstract types and 200 manifest aliases, with +each consumer mentioning one of each. On one traced clean build, 200 `Api` +component expansions disappeared. Component construction fell from 172.1 to +40.8 MB; allocation across all implementation requests fell from 287.8 to +107.3 MB. Summed worker time fell from 280.7 to 165.1 ms. The direct type +lookup phase took 1.3 ms and 0.9 MB for 2,600 calls. All 805 selected +artifacts were byte-identical. + +A mixed fixture with exported values and a record type exercises record-label +lookup too. Direct record and label lookup removed its 200 `Api` expansions: +component construction fell from 111.3 to 40.8 MB, total implementation +allocation from 182.2 to 109.4 MB, and summed worker time from 220.2 to +197.5 ms. Its 805 selected artifacts were also byte-identical. These are +single traced runs, not stable wall-time estimates. + +A variant fixture exported 200 variant types and had consumers construct and +match their constructors. Direct constructor lookup removed its 200 `Api` +expansions: component construction fell from 194.3 to 40.8 MB, total +implementation allocation from 281.6 to 109.5 MB, and summed worker time +from 298.7 to 175.8 ms. Its 805 selected artifacts were byte-identical. + +Interleaved clean-build pairs, with tracing disabled and four compiler +domains, measured the complete Rewatch build process (11 pairs for the first +three fixtures, 17 for the last two): + +| Fixture | Existing median wall time | Frozen median wall time | Frozen faster | +| --- | ---: | ---: | ---: | +| Abstract types and aliases | 184.54 ms | 165.14 ms | 11/11 pairs | +| Values and record | 170.75 ms | 165.17 ms | 7/11 pairs | +| Variants and constructors | 192.54 ms | 162.64 ms | 11/11 pairs | +| Modules, aliases, and functor use | 169.22 ms | 144.67 ms | 17/17 pairs | +| Opened values and record | 174.07 ms | 151.84 ms | 17/17 pairs | + +These are short synthetic builds on one machine. The larger gains occur when +the fixture's main dependency has many declarations that the old path copied +for every consumer; the mixed fixture shows a smaller wall-time gain despite +removing the same expansion count. + +The last two fixtures exercise broader interface shapes. The module fixture +exports 400 values, a module type, two modules ascribed to that type, an +alias, and a functor. Every consumer reads the modules and alias and applies +the functor. The opened fixture exports 400 values, an identity function, and +a record type; every consumer uses `open Api`. In one traced clean build with +201 implementation requests and four compiler domains: + +| Fixture | Existing implementation allocation | Frozen allocation | Existing component construction | Frozen component construction | `Api` expansions | +| --- | ---: | ---: | ---: | ---: | ---: | +| Modules | 193.6 MB | 74.8 MB | 113.3 MB, 1,403 calls | 0.2 MB, 201 calls | 200 → 0 | +| Opened interface | 183.6 MB | 71.9 MB | 111.5 MB, 602 calls | 0, 0 calls | 200 → 0 | + +Summed implementation worker time in those traced builds was 204.1 → +167.6 ms for modules and 248.5 → 148.6 ms for opened imports. The 17 +interleaved wall-time pairs above had tracing disabled. All 1,608 selected +module-fixture artifacts and all 1,610 opened-fixture artifacts matched byte +for byte across flag settings. These synthetic builds provide directional +evidence, not a production-project speed estimate. + +An initial type-image view eagerly built a substitution map for all 400 +binders in every request. It added about 64 MB across the fixture and kept +the component expansions. Replacing that with immutable binder indexes and +lazy path substitution removed that view-construction cost. A separate path +normalization probe showed that asking whether `Api.opaque` is a module +forced the entire `Api` component table; the immutable top-level type-name +index now answers that check without expanding the module. These two failures +illustrate why selective materialization has to include consumers outside +ordinary type lookup. + +To repeat the type-only microprobe after building the compiler, run +`opam exec -- dune build rewatch-ocaml/bench/frozen_type_graph_probe.exe` +and then invoke that executable with a CMI path and iteration count. The +synthetic project can be recreated with +`python3 rewatch-ocaml/bench/make_immutable_interface_fixture.py OUTPUT_DIRECTORY`. +It has `Api.resi` with 400 integer values, `id: 'a => 'a`, and +`type box<'a> = {value: 'a}`. Its 200 consumers each access one value and +call `Api.id`; `--values-only` omits the record use, `--types-only` generates +the abstract-type and alias fixture, `--variants-only` generates the variant +fixture, `--modules-only` exercises module types, aliases, and a functor, and +`--open-only` exercises an opened interface. +Build it with the embedded OCaml +Rewatch executable, four domains, and `REWATCH_TYPECHECK_TRACE` set to an +absolute TSV path; compare clean builds with `REWATCH_FROZEN_VALUES=0` and +its default setting. Analyze both files with +`rewatch-ocaml/bench/analyze_typecheck_trace.js`. + +Direct indexing still stops where the module shape depends on a functor +application or on a module-type identifier that cannot be resolved within the +same CMI. Those cases materialize request-owned declarations or components +from the image. Signature inclusion still requests a full copied signature. +The next validation should measure edit workloads, larger real projects, and +fallback frequency before enabling the flag by default. The goal remains to +remove repeated interface preparation without moving that cost into per-use +materialization. diff --git a/compiler/ml/README.md b/compiler/ml/README.md index 717e44fcd9..4b3c7febe1 100644 --- a/compiler/ml/README.md +++ b/compiler/ml/README.md @@ -59,6 +59,13 @@ For module inclusion and signature compatibility, start with : Substitution and copying across environments and persistence boundaries. `for_saving` has stronger independence requirements than an ordinary copy. +[`IMMUTABLE_INTERFACES.md`](IMMUTABLE_INTERFACES.md) +: Design and measurements for sharing compiled interfaces across compiler + domains. `Frozen_type_graph` is an experimental type arena; `Frozen_values` + indexes values, types, constructors, labels, modules, and module types in + nested signatures. `Env` uses its request-local views and lazy opened-name + tables when `REWATCH_FROZEN_VALUES=1`. + ## Polymorphic value positions A `Tpoly` node represents a type scheme, so the operation depends on whether diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index db7532c087..a9152925fb 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 6f9b51cc75..1c654aa4f4 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/cmi_format.ml b/compiler/ml/cmi_format.ml index 805b6fb14e..3c4bb76749 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 @@ -76,39 +79,48 @@ let output_cmi filename oc cmi = 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 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/cmt_format.ml b/compiler/ml/cmt_format.ml index e904605abf..578cd87bfd 100644 --- a/compiler/ml/cmt_format.ml +++ b/compiler/ml/cmt_format.ml @@ -2,7 +2,25 @@ 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 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 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 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 5472a22b31..b02adcd0f3 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -103,6 +103,15 @@ 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. *) + (* Miscellaneous functions *) val read_magic_number : in_channel -> string diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 48af05a901..d184cfd560 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,17 @@ 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 = 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 +654,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 +746,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 +757,228 @@ 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; +} + +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}; + Some image) + else 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 +999,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 +1033,79 @@ 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} + match lookup_published_cmi modname filename 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 +1115,43 @@ 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 -> ( + 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 +1196,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 +1221,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 +1258,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 +1302,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 +1394,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 +1433,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 +1479,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 +1617,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 +1693,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 +1763,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 +2217,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 +2966,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 +3324,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 +3505,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 +3676,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 04411ac872..694608f499 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/frozen_type_graph.ml b/compiler/ml/frozen_type_graph.ml new file mode 100644 index 0000000000..bec7943b31 --- /dev/null +++ b/compiler/ml/frozen_type_graph.ml @@ -0,0 +1,329 @@ +open Types + +type frozen_ident = {name: string; stamp: int; flags: int} + +type frozen_path = + | Fident of int + | Fdot of frozen_path * string * int + | Fapply of frozen_path * frozen_path + +type frozen_row_field = + | Fpresent of int option + | Feither of bool * int list * bool * int + | Fabsent + +type frozen_desc = + | Fvar of string option + | Farrow of (Asttypes.arg_label * int) list * int + | Ftuple of int list + | Fconstr of frozen_path * int list + | Fobject of int + | Ffield of string * int * int * int + | Fnil + | Fvariant of + (string * frozen_row_field) list + * int + * bool + * bool + * (frozen_path * int list) option + | Funivar of string option + | Fpoly of int * int list + | Fpackage of frozen_path * Longident.t list * int list + +type frozen_node = {level: int; desc: frozen_desc} + +type t = { + roots: int list; + requested_identifiers: int list; + nodes: frozen_node array; + identifiers: frozen_ident array; + mutabilities: Asttypes.mutable_flag array; + row_references: frozen_row_field option array; +} + +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 requested = identifiers in + 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 nodes = ref [] in + let identifiers = ref [] in + let mutabilities = ref [] in + let row_references = ref [] in + let type_count = ref 0 in + let ident_count = ref 0 in + let mutability_count = ref 0 in + let row_reference_count = ref 0 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; + identifiers := + ( index, + { + name = id.Ident.name; + stamp = id.Ident.stamp; + flags = id.Ident.flags; + } ) + :: !identifiers; + index + in + let rec freeze_path = function + | Path.Pident id -> Fident (index_ident id) + | Path.Pdot (path, name, position) -> + Fdot (freeze_path path, name, position) + | Path.Papply (first, second) -> + Fapply (freeze_path first, freeze_path second) + 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 = !type_count in + incr type_count; + Physical_type.add seen_types ty index; + let desc = + match ty.desc with + | Tvar name -> Fvar name + | Tarrow (arguments, result) -> + Farrow + ( List.map + (fun argument -> (argument.lbl, freeze_type argument.typ)) + arguments, + freeze_type result ) + | Ttuple types -> Ftuple (List.map freeze_type types) + | Tconstr (path, parameters, memo) -> + (match !memo with + | Mnil -> () + | Mcons _ | Mlink _ -> + raise (Unsupported "an active abbreviation memo")); + Fconstr (freeze_path path, List.map freeze_type parameters) + | Tobject fields -> Fobject (freeze_type fields) + | Tfield {name; mutability; typ; rest} -> + Ffield + ( name, + index_mutability mutability, + freeze_type typ, + freeze_type rest ) + | Tnil -> Fnil + | Tvariant row -> + Fvariant + ( List.map + (fun (label, field) -> (label, freeze_row_field field)) + row.row_fields, + freeze_type row.row_more, + row.row_closed, + row.row_fixed, + Option.map + (fun (path, parameters) -> + (freeze_path path, List.map freeze_type parameters)) + row.row_name ) + | Tunivar name -> Funivar name + | Tpoly (body, variables) -> + Fpoly (freeze_type body, List.map freeze_type variables) + | Tpackage (path, names, types) -> + Fpackage (freeze_path path, names, List.map freeze_type types) + | Tlink _ -> raise (Unsupported "a linked type node") + | Tsubst _ -> raise (Unsupported "an active type copy mark") + in + nodes := (index, {level = ty.level; desc}) :: !nodes; + index + 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 = List.map index_ident requested in + let roots = List.map freeze_type roots in + let array count entries empty = + let result = Array.make count empty in + List.iter (fun (index, value) -> result.(index) <- value) entries; + result + in + Ok + { + roots; + requested_identifiers; + nodes = array !type_count !nodes {level = 0; desc = Fnil}; + identifiers = + array !ident_count !identifiers {name = ""; stamp = 0; flags = 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.identifiers) 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 (Array.length image.nodes) None in + let get_ident index = + match identifiers.(index) with + | Some id -> id + | None -> + let {name; stamp; flags} : frozen_ident = image.identifiers.(index) in + let id = {Ident.name; stamp; flags} in + identifiers.(index) <- Some id; + id + in + let rec thaw_path = function + | Fident index -> Path.Pident (get_ident index) + | Fdot (path, name, position) -> Path.Pdot (thaw_path path, name, position) + | Fapply (first, second) -> Path.Papply (thaw_path first, thaw_path second) + 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 {level; desc} = image.nodes.(index) in + let ty = Btype.newty2 level (Tvar None) in + nodes.(index) <- Some ty; + ty.desc <- thaw_desc desc; + ty + and thaw_desc = function + | Fvar name -> Tvar name + | Farrow (arguments, result) -> + Tarrow + ( List.map (fun (lbl, typ) -> Types.{lbl; typ = get typ}) arguments, + get result ) + | Ftuple types -> Ttuple (List.map get types) + | Fconstr (path, parameters) -> + Tconstr (map_type_path (thaw_path path), List.map get parameters, ref Mnil) + | Fobject fields -> Tobject (get fields) + | Ffield (name, mutability, typ, rest) -> + Tfield + { + name; + mutability = get_mutability mutability; + typ = get typ; + rest = get rest; + } + | Fnil -> Tnil + | Fvariant (fields, more, closed, fixed, name) -> + Tvariant + { + row_fields = + List.map + (fun (label, field) -> (label, thaw_row_field field)) + fields; + row_more = get more; + row_closed = closed; + row_fixed = fixed; + row_name = + Option.map + (fun (path, parameters) -> + (map_type_path (thaw_path path), List.map get parameters)) + name; + } + | Funivar name -> Tunivar name + | Fpoly (body, variables) -> Tpoly (get body, List.map get variables) + | Fpackage (path, names, types) -> + Tpackage (map_modtype_path (thaw_path path), names, List.map get types) + 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 -> + match List.nth_opt image.roots root with + | Some index -> get index + | None -> invalid_arg "Frozen_type_graph.type_at"); + identifier_at = + (fun requested -> + match List.nth_opt image.requested_identifiers requested with + | Some index -> get_ident index + | None -> invalid_arg "Frozen_type_graph.identifier_at"); + } + +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 (List.length image.roots) (type_at view) + +let thaw_root image root = type_at (create_view image) root + +let root_count image = List.length image.roots + +let node_count image = Array.length image.nodes diff --git a/compiler/ml/frozen_type_graph.mli b/compiler/ml/frozen_type_graph.mli new file mode 100644 index 0000000000..42ffe15992 --- /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 0000000000..b574aab0b7 --- /dev/null +++ b/compiler/ml/frozen_values.ml @@ -0,0 +1,996 @@ +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 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: string String_map.t; + duplicate_modtype_names: String_set.t; +} + +and module_entry = { + position: int; + loc: Location.t; + deprecated: string option; + nested: scope option; + alias_path: string option; + declaration: string; +} + +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 view = { + image: t; + graph: Frozen_type_graph.view; + 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, Frozen_type_graph.view * (Path.t -> Path.t)) Hashtbl.t; + materialized_layouts: + (int option * int, Variant_runtime.layout_ref) Hashtbl.t; + map_type_path: Path.t -> Path.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; + alias_path = + (match declaration.md_type with + | Mty_alias (_, path) -> Some (Marshal.to_string path []) + | Mty_ident _ | Mty_signature _ | Mty_functor _ -> None); + declaration = Marshal.to_string declaration []; + } + !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 (Marshal.to_string declaration []) !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_view 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 + let graph = + Frozen_type_graph.create_view ~map_type_path ~map_modtype_path image.graph + in + (graph, map_type_path) + +let create_view image = + let graph, map_type_path = create_graph_view image None in + { + image; + graph; + 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; + map_type_path; + } + +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_graph view (scope : scope) = + match scope.context_id with + | None -> (view.graph, view.map_type_path) + | Some context_id -> ( + match Hashtbl.find_opt view.context_graphs context_id with + | Some graph -> graph + | None -> + let graph = create_graph_view view.image (Some context_id) in + Hashtbl.add view.context_graphs context_id graph; + graph) + +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 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 source = Marshal.from_string entry.declaration 0 in + let declaration = + Subst.module_declaration (scope_substitution view scope) source + 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 bytes -> ( + let key = (scope.id, name) in + match Hashtbl.find_opt view.materialized_modtypes key with + | Some declaration -> Some declaration + | None -> + let source = Marshal.from_string bytes 0 in + let declaration = + Subst.modtype_declaration (scope_substitution view scope) source + 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 {alias_path = Some bytes} -> + let path = Marshal.from_string bytes 0 in + Some (Subst.module_path (scope_substitution view scope) path) + | Some {alias_path = None} | 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 0000000000..f6fe3560e4 --- /dev/null +++ b/compiler/ml/frozen_values.mli @@ -0,0 +1,110 @@ +(** 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 copy_signature : view -> Types.signature +(** Materialize and prefix 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 +(** Decode and substitute one module declaration in the request view. *) + +val find_modtype_declaration : + view -> scope -> string -> Types.modtype_declaration option +(** Decode and substitute one module-type declaration in the request view. *) + +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 d33acc9bd6..20b4560f2a 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 fcefcd3ef6..5b5238dc5e 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 5289b8c1f0..f0a77c16f3 100644 --- a/compiler/ml/platform/native/cmt_format_persistence.ml +++ b/compiler/ml/platform/native/cmt_format_persistence.ml @@ -23,36 +23,46 @@ let output_cmt output_channel cmt = let save_cmt 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 = - match cmi with - | None -> None - | Some cmi -> - Some (Cmi_format.output_cmi temp_file_name output_channel cmi) - 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 ()}; - } - in - output_cmt output_channel cmt) + Compiler_phase_trace.section "artifact.cmt_persist" (fun () -> + let saved = ref None in + Misc.output_to_bin_file_directly filename + (fun temp_file_name output_channel -> + let interface_digest = + match cmi with + | None -> None + | Some cmi -> + Some (Cmi_format.output_cmi temp_file_name output_channel cmi) + in + let cmt = + 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 + Compiler_phase_trace.section "artifact.cmt_serialize" (fun () -> + output_cmt output_channel cmt); + saved := Some cmt); + !saved) + else None diff --git a/compiler/ml/platform/playground/cmt_format_persistence.ml b/compiler/ml/platform/playground/cmt_format_persistence.ml index e1dd676b61..d2f9861baf 100644 --- a/compiler/ml/platform/playground/cmt_format_persistence.ml +++ b/compiler/ml/platform/playground/cmt_format_persistence.ml @@ -1,4 +1,4 @@ let set_args _value = () let save_cmt _filename _modname _binary_annots _sourcefile _initial_env _cmi = - () + None diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index 6f603c1170..09fa9b803e 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 = @@ -1730,67 +1731,73 @@ 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 -> + 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 94147e9034..318bfcc950 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 47c2aaf147..ed8102235d 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 5f11bab500..53eb042dd1 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/README.md b/rewatch-ocaml/README.md index cc8a9d961e..b69fde2cbb 100644 --- a/rewatch-ocaml/README.md +++ b/rewatch-ocaml/README.md @@ -64,11 +64,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 @@ -128,9 +130,39 @@ 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. The current implementation and benchmark results are +documented in +[`compiler/ml/IMMUTABLE_INTERFACES.md`](../compiler/ml/IMMUTABLE_INTERFACES.md). +Set `REWATCH_FROZEN_VALUES=0` to compare the previous compiler path. +Sessions containing GenType packages currently use the classic interface +lookup because frozen lookup changed generated TypeScript in that suite. +Parser AST cache copies run on a separate domain while compilation proceeds; +`REWATCH_ASYNC_AST_EXPORT=0` makes those copies finish before compilation. +OCaml Rewatch omits CMT and CMTI binary annotations by default for packages +without GenType. It uses CMJ modification time as the compiled freshness +marker in that case. Set `REWATCH_BIN_ANNOT=1` to produce binary annotations +for editor tools and other consumers. GenType packages keep them automatically. +Compiler metadata records both annotation and frozen-lookup settings, so +switching either mode 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 or GenType retain them automatically. 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, @@ -148,7 +180,20 @@ 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` diff --git a/rewatch-ocaml/bench/README.md b/rewatch-ocaml/bench/README.md index f28b755e93..ffaac33fa2 100644 --- a/rewatch-ocaml/bench/README.md +++ b/rewatch-ocaml/bench/README.md @@ -5,7 +5,9 @@ The OCaml rewatch now uses parallel in-process compiler domains by default. 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. +build and the same Dune profile when comparing them. The profile affects +serialized AST and CMI bytes for at least one testrepo dependency, even when +compiler request arguments are identical. ## Domain baseline @@ -43,6 +45,837 @@ 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. +## Direct before-and-after comparison + +Revision `95467b2bf` is the parent of the parallel in-process compiler change. +It still launches standalone `bsc` requests. On the same 12-CPU Linux ARM64 +host, five interleaved testrepo runs compared its release executable with +revision `7494d76ece1f33e8a808c26206194b7a20158766`. Both used the +current lockfile-pinned fixture, release-profile `bsc`, and local runtime. +Compiler source files did not change between these revisions: + +| scenario | before median wall | after median wall | before peak tree RSS | after peak tree RSS | +| --- | ---: | ---: | ---: | ---: | +| Clean | 4,045 ms | 1,420 ms | 302,984 KiB | 365,916 KiB | +| Unchanged | 187 ms | 71 ms | 42,336 KiB | 26,080 KiB | +| One source edit | 185 ms | 70 ms | 53,052 KiB | 26,152 KiB | + +The clean build became 2.85x faster with 1.21x sampled peak tree RSS. Both +revisions made the same 1,031 clean compiler requests and the same unchanged +and edit requests. Complete post-build file sets and selected stable artifact +bytes matched. The before/after gate passed its 125% clean RSS limit in this +comparison. The first executable is labeled `Rust` by the reusable benchmark +script below, but it is the older OCaml build system; its external compiler +calls are observed by the same `bsc` proxy. This comparison measures the +revision range, including the in-process compiler and parallel scheduling, +not an isolated compiler micro-optimization. + +In a separate seven-edit retained-watch comparison, median latency fell from +161 to 83 ms. Both revisions made seven parser and seven compiler requests +and produced identical edited JavaScript. The older watcher's RSS rose from +10,960 to 11,736 KiB and the current watcher's from 26,800 to 27,932 KiB; +both held stable file descriptor and task counts. +That older watch gate timed the external-compiler side through its counting +proxy, which added process launches to its latency samples. + +A filesystem-controlled follow-up at revision +`9fa158aee436b0804ae7f6d0bb5d72144e038053` put both release Rewatch +executables and the byte-identical release `bsc` on `/tmp` (`overlay`) instead +of launching `bsc` from the workspace's `virtiofs` mount. The older executable +was rebuilt from `95467b2bfab9d6edd8fd00a8897a5308794a211d`; both used +the same current `bsc` and runtime. Five interleaved runs after one warm-up +each measured: + +| scenario | before median wall | after median wall | before peak tree RSS | after peak tree RSS | +| --- | ---: | ---: | ---: | ---: | +| Clean | 1,717 ms | 1,374 ms | 365,952 KiB | 361,164 KiB | +| Unchanged | 145 ms | 45 ms | 29,480 KiB | 25,848 KiB | +| One source edit | 148 ms | 47 ms | 52,456 KiB | 25,220 KiB | + +The clean gain was 1.25x under this compiler placement, compared with 2.85x +when `bsc` launched from the slower workspace mount. This supports compiler +launch location as a large part of the earlier measured gain on this host. +The unchanged and single-edit medians still fell by about 3x. Each timed edit +started from the same restored source and compiled baseline. The gate passed +its clean time and memory limits; both versions made the same 1,031 clean, +four unchanged, and six edit compiler requests, and produced identical +complete file sets and stable artifact bytes. The first executable is the +older OCaml Rewatch, despite the gate's `Rust` label. + +The revised retained-watch gate times both executables with the real `bsc` +and replays the external side through a counting proxy only after timing. In +a separate seven-edit run with the same `/tmp` compiler, the older OCaml +watcher measured 143 ms median versus 83 ms for current OCaml. Both made seven +parse and seven compile requests and generated identical edited JavaScript; +file descriptors, task counts, and retained RSS stayed within the gate's +limits. Each edit changed the generated JavaScript, proving that the timed +watchers rebuilt the edited module. These medians replace the proxy-influenced +161 versus 83 ms comparison above for latency purposes. + +After creating the older worktree and building both release executables as +shown below, reproduce this placement with: + +```sh +mkdir -p /tmp/rewatch-before-after-fast +cp /tmp/rewatch-before-954/_build/default/rewatch-ocaml/rescript_ocaml.exe \ + /tmp/rewatch-before-after-fast/before +cp _build/default/rewatch-ocaml/rescript_ocaml.exe \ + /tmp/rewatch-before-after-fast/after +cp _build/default/compiler/bsc/rescript_compiler_main.exe \ + /tmp/rewatch-before-after-fast/bsc +export RESCRIPT_BSC_EXE=/tmp/rewatch-before-after-fast/bsc +export RESCRIPT_RUNTIME="$PWD/packages/@rescript/runtime" +REWATCH_COMPILER_DOMAINS=8 rewatch-ocaml/bench/performance_gate.sh \ + /tmp/rewatch-before-after-fast/before \ + /tmp/rewatch-before-after-fast/after 5 +REWATCH_WATCH_COMPILER_DOMAINS=8 \ + rewatch-ocaml/bench/watch_performance_gate.sh \ + /tmp/rewatch-before-after-fast/before \ + /tmp/rewatch-before-after-fast/after 7 +``` + +To reproduce the before/after gate after preparing the dependencies and +release compiler/runtime as described below: + +```sh +git worktree add --detach /tmp/rewatch-before-954 95467b2bf +(cd /tmp/rewatch-before-954 && \ + opam exec -- dune build --profile release 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_COMPILER_DOMAINS=8 rewatch-ocaml/bench/performance_gate.sh \ + /tmp/rewatch-before-954/_build/default/rewatch-ocaml/rescript_ocaml.exe \ + _build/default/rewatch-ocaml/rescript_ocaml.exe 5 +REWATCH_WATCH_COMPILER_DOMAINS=8 \ + rewatch-ocaml/bench/watch_performance_gate.sh \ + /tmp/rewatch-before-954/_build/default/rewatch-ocaml/rescript_ocaml.exe \ + _build/default/rewatch-ocaml/rescript_ocaml.exe 7 +``` + +## Native Linux testrepo checkpoint + +At revision `7688129cd0bd6d8b66fec797327db3455398a4a1`, five +interleaved runs on a 12-CPU Linux ARM64 host with OCaml 5.5.1 measured the +472-module testrepo fixture. Standalone `bsc` and the embedded compiler were +built with the same Dune `release` profile; Rust Rewatch was a Cargo release +build. Both implementations used the same local runtime. The fixture includes +installed, lockfile-pinned dependencies; the benchmark copies them into +isolated roots and applies the canonical test-suite Belt-dependency correction +to those copies. No company-project source was used. Earlier measurements at +`49951ac49f78be57f8f7ae347bf577a2839f90ca` did not pin both compiler +executables to the same Dune profile and are superseded by this checkpoint. + +| scenario | Rust median wall | OCaml median wall | Rust median peak tree RSS | OCaml median peak tree RSS | +| --- | ---: | ---: | ---: | ---: | +| Clean, 8 OCaml workers | 3,585 ms | 1,413 ms | 252,464 KiB | 368,032 KiB | +| Unchanged after clean, 8 workers | 142 ms | 71 ms | 30,056 KiB | 26,072 KiB | +| One source edit, 8 workers | 140 ms | 72 ms | 28,648 KiB | 26,156 KiB | +| Clean, 7 OCaml workers | 3,712 ms | 1,527 ms | 260,280 KiB | 334,112 KiB | +| Clean, 6 OCaml workers | 3,617 ms | 1,574 ms | 275,592 KiB | 289,640 KiB | + +Eight workers gave a 2.54x clean-build wall-time gain and a 1.46x sampled +peak-tree-RSS ratio relative to Rust. Seven workers gave a 2.43x gain but +still failed the existing 125% clean-memory gate in its comparison. Six +workers passed the complete gate, at a 2.30x gain and a 1.05x sampled RSS +ratio. These are separate runs, so compare ratios within a row. Peak tree RSS +is sampled every 20 ms and can miss short-lived compiler-child peaks; Rust's +sampled clean peak varied substantially across runs. The memory gate gives a +directional constraint, especially near its threshold, rather than a precise +cross-architecture memory ratio. + +In one clean build, GNU `/usr/bin/time -v` reported 49,644 KiB maximum RSS +for Rust and 385,944 KiB for OCaml. Rust launches many compiler children, +whereas OCaml compiles mostly in-process. GNU time's maximum RSS does not sum +the concurrent process tree, so those two values are not a total-build memory +comparison. Keep the sampled tree figure alongside any per-executable GNU +time reading. + +All three worker counts matched Rust's clean, unchanged, and edit compiler +work. The clean build made 1,031 logical compiler requests in each +implementation: 512 parse, seven namespace, and 512 compile requests. The +unchanged build made four requests because the warning in the testrepo's +`ModuleA` deliberately invalidates its AST for diagnostic replay. Every +comparison matched the complete post-build file set and the selected stable +artifact bytes. + +In a separate seven-edit retained-watch run at the default eight workers, +Rust's median edit-to-hook latency was 142 ms and OCaml's was 83 ms. Both made +seven parser and seven compiler requests, produced identical edited JavaScript, +and held stable file descriptor, task, and RSS counts. Watch-mode samples use +a small one-module fixture, so they do not establish scaling on a large +dependency graph. + +The later per-request timing trace measured an OCaml compile span of 1.17 s. +A 5x clean gain over the aligned Rust median would require the entire build +to finish in about 0.72 s. The compiler work alone exceeds that budget on +this fixture; faster parsing or orchestration alone cannot reach it. + +The aligned filesystem audit counted 6,604 Rust versus 9,042 OCaml project-local +metadata calls on clean builds, with nearly equal open counts (17,636 and +17,633). The high-count missing CMI lookups, including 313 opens of the +fixture's `Pervasives.cmi` path, were identical in both implementations. The +extra metadata checks merit investigation on slower filesystems, but the +shared CMI lookup pattern does not identify an OCaml-specific optimization. +Exploratory lower GC space-overhead settings reduced OCaml RSS in individual +runs, but did not establish a validated advantage over six default-GC +workers. The default GC setting is unchanged. + +An opt-in per-request timing trace resolves the OCaml compile phase further. +On one eight-worker clean build of the same fixture, 512 parse requests +spanned 95 ms and 512 implementation/interface requests spanned 1,172 ms. +The compiler workers were active for virtually the entire compile span, with +7.39 of eight workers active on average and all eight active at peak. The compile +requests summed to 8,666 ms of worker time; the 95th percentile request took +48 ms. `DOMAPI.ast`, `Net.ast`, and `Http.ast` were among the slowest requests. +This is a single diagnostic run with logging enabled, not a benchmark median. +It indicates that the clean-build limit is largely compiler work rather than +idle scheduler time on this fixture. At eight workers, the summed work alone +has a 1.08 s lower bound without faster individual requests. + +To collect another trace, set `REWATCH_COMPILER_TIMING_LOG` to an absolute +path for an OCaml build and analyze the resulting tab-separated file: + +```sh +export RESCRIPT_BSC_EXE="$PWD/_build/default/compiler/bsc/rescript_compiler_main.exe" +export RESCRIPT_RUNTIME="$PWD/packages/@rescript/runtime" +_build/default/rewatch-ocaml/rescript_ocaml.exe clean rewatch/testrepo +rm -f /tmp/rewatch-compiler-timing.tsv +REWATCH_COMPILER_TIMING_LOG=/tmp/rewatch-compiler-timing.tsv \ + _build/default/rewatch-ocaml/rescript_ocaml.exe build rewatch/testrepo +node rewatch-ocaml/bench/analyze_compiler_timing.js \ + /tmp/rewatch-compiler-timing.tsv +``` + +Each row records phase, working directory, input, start time, and end time. +Request time includes any PPX command that the compiler invokes. +The analyzer reports elapsed phase span, summed compiler time, average and +peak active requests, idle time inside each phase, and the longest compile +requests. Remove an old trace before a new run; the compiler appends rows. + +A temporary compiler-core trace split 479 implementation requests from one +instrumented clean build. These are summed concurrent-worker times, not elapsed +build time: + +| compiler-core phase | summed worker time | +| --- | ---: | +| Initial environment setup | 1,837 ms | +| Implementation typing and persistence (split below) | 6,736 ms | +| Lambda translation | 30 ms | +| Lambda compilation | 135 ms | +| JavaScript emission | 46 ms | + +The remaining 33 interface requests and outer request setup are outside this +pipeline split. The instrumented build's 512 compile requests spanned 1,253 +ms, so do not compare that span directly with the uninstrumented benchmark +median. + +A second instrumented clean build split the implementation typing and +persistence phase for the same 479 implementation requests: + +| work inside `Typemod.type_implementation_more` | summed worker time | +| --- | ---: | +| Structure typing, including imported CMI and signature work (`type_structure`) | 5,253 ms | +| Interface inclusion and delayed checks | 820 ms | +| CMI saving | 267 ms | +| CMT saving | 443 ms | +| Signature simplification and reset | under 3 ms | + +This second run totals about 6,783 ms, rather than the first run's 6,736 ms; +the rows are a breakdown of the same phase on a different run, not an exact +subtraction from 6,736 ms. `type_structure` includes import loading and +signature expansion, so its 5,253 ms is not a measurement of source typing +alone. Eliminating CMI/CMT saves alone has a limited bound. + +A third instrumented clean build measured imported CMI work across **all 512 +compile requests**, including the 33 interface requests excluded from the +tables above: + +| imported CMI operation | summed worker time | +| --- | ---: | +| 2,952 successful persistent-module lookups, including path search and failed candidate opens | 2,711 ms | +| 2,992 CMI decodes, including 40 through other CMI call sites | 1,511 ms | + +CMI decoding overlaps the lookup row, and CMI loading overlaps structure +typing and possibly other phases. These rows came from a separate run and +cover more requests, so 2,711 / 6,736 (about 40%) is only a numerical ratio, +not the measured lookup share of the typing phase. The remaining source typing +time was not isolated. A disjoint split requires nested timers in the same +run. The CMI trace decoded 194 MB of repeated input; its measurements include +tracing overhead and are not wall-time savings. Even eliminating all 2,711 ms +of lookup work would have an ideal eight-worker bound of about 0.34 s, short +of closing the 5x gap. A raw-byte cache would still pay most decoding cost, +while reusing decoded type graphs across fresh compiler requests would need +safe copying and CMI invalidation to preserve dependency correctness. + +Environment setup and implementation typing account for nearly all measured +implementation work. Reusing a prepared environment across requests would +have to preserve the compiler's fresh per-request type and identifier state; +it is an architectural change with correctness and memory risks. Faster +JavaScript emission alone has little headroom on this fixture. The temporary +instrumentation was removed after each measurement. + +An exploratory change deferred construction of `Env.initial_safe_string` for +`-bs-ast` requests while keeping it eager for type-checking requests. Fifteen +interleaved clean testrepo builds of matched release executables on `/tmp` +measured 1,374 ms before versus 1,372 ms after; unchanged and edit medians +were 46 ms in both versions. Sampled clean peak tree RSS was 364,392 versus +368,052 KiB. Compiler requests, complete file sets, and stable artifact bytes +matched. The extra lazy-state handling had no useful measured gain, so it was +reverted. This probe does not split the cost of opening the implicit modules +from the rest of initial-environment setup. + +A further temporary single-worker trace separated module lookup from opening +the resolved signature. Across 1,897 opens, lookup used about 360 ms of +process CPU time and signature opening about 2,063 ms. The 137 opens of +`WebAPI.DOMAPI` alone used about 230 ms for lookup and 1,687 ms for signature +opening. Its CMI is roughly 987 kB, and expanding its large signature is +repeated in fresh compiler requests. A separate structure-item trace counted +429 source `open` items using about 1,784 ms of process CPU time, including +those `DOMAPI` opens; these two traces are separate runs and their times are +not additive. The one-worker timings are diagnostic, include tracing overhead +and some build-system CPU activity, and cannot be read as eight-worker wall +time savings. Even an ideal eight-way division of all `DOMAPI` opening work +would save only about 0.21 s. Reusing expanded components would need to keep +the mutable type graphs isolated and invalidate them when a CMI changes. The +temporary instrumentation was removed after these measurements. + +## Exclusive type-checking and artifact breakdown + +An opt-in trace now times nested compiler phases in one clean build. Its rows +are exclusive, so they add to the request total. This resolves the overlap in +the temporary measurements above. Set `REWATCH_TYPECHECK_TRACE` to an absolute +TSV path to enable it; otherwise the trace is disabled. + +Five interleaved pairs used eight workers, OCaml 5.5.1, and Dune's development +profile on Linux ARM64. Both executables were copied to the same `/tmp` +directory. The plain executable was built from `80eb95963` without tracing +hooks; the traced executable differed only by the diagnostic instrumentation. +Each sample cleaned Belt and testrepo in an isolated fixture. All traced +samples made 512 parse, 40 interface, 472 implementation, and seven namespace +implementation requests (1,031 total). +An additional clean baseline/traced comparison produced the same 10,029 +paths and SHA-256 hashes for files ending in `.ast`, `.iast`, `.cmi`, `.cmj`, +`.cmt`, `.cmti`, `.mjs`, `.cjs`, `.js`, or `.map`. + +`traced-3.trace.tsv` gives the following **summed worker times** in +milliseconds. The 519 compile requests sum to 8,106 ms. Parse requests add +678 ms, including 452 ms of outer setup. Elapsed build time was 1.37 s; +worker sums are not elapsed time or directly achievable wall-time savings. + +| Exclusive phase | Interfaces (40) | Implementations (472) | Namespace (7) | Compile total | +| --- | ---: | ---: | ---: | ---: | +| Request setup and initial environment | 18.1 | 553.2 | 1.5 | 572.9 | +| Obtain dependency interfaces | 70.8 | 2,511.7 | 2.2 | 2,584.7 | +| Check source and open signatures | 23.9 | 3,885.6 | 1.9 | 3,911.4 | +| Prepare CMI/CMT data | 2.4 | 60.8 | 0.3 | 63.5 | +| Serialize, hash, and write artifacts | 30.4 | 647.5 | 1.0 | 678.8 | +| AST reading, backend, and other work | 5.5 | 287.9 | 1.3 | 294.7 | +| **Total** | **151.1** | **7,946.7** | **8.2** | **8,106.0** | + +Source checking comprises 2,152 ms typing, inclusion, delayed checks, and +typed-tree construction, plus 1,759 ms opening signatures and making names +available. Nested CMI file work is charged only to dependencies. Setup +includes fresh request state, include paths, and 332 ms opening implicit and +configured modules, excluding CMI work. The outer-request timer also covers +argument parsing, output capture, and teardown. + +The dependency row comprises 1,155 ms finding and opening CMI paths, 2 ms +finding and opening the current module's explicit interface, 1,406 ms in +buffered reading and Marshal decoding, 19 ms in CRC consistency checks, +and 3 ms registering decoded persistent structures. The trace counted 2,966 +successful loader searches and 3,006 decodes; the extra 40 are explicit +interface reads. `Pervasives` and `Stdlib` were each loaded 519 times, once per +compile request, and `WebAPI` 312 times. Fresh request state repeats this work. +The current `input_value` reader interleaves I/O and decoding, so their costs +cannot be separated without changing that reader. Lazy expansion during +source `open` appears in the source row, separate from CMI file loading. + +CMI preparation copies the exported signature into saved form and registers +it for later checking; it is needed to make dependency types available. CMT +and CMTI preparation clears typed-tree environments and packages metadata for +editor tooling. The 679 ms persistence row includes 106 ms standalone CMI +serialization, 53 ms CMI hashing, 85 ms remaining standalone CMI file work, +212 ms CMT serialization, 19 ms source hashing, and 203 ms remaining CMT/CMTI +file work. The last component includes the CMI prefix embedded in CMT files. +These subtimers are exclusive and do not double-count one another. + +The compile requests allocated 4,218 MB in OCaml heaps: 2,848 MB during +source checking, 671 MB obtaining dependencies, 458 MB in setup, 75 MB in +artifact preparation, 22 MB in persistence, and 144 MB elsewhere. Parse +requests allocated another 234 MB. The largest sampled `Gc.quick_stat` +top heap was 34.5 million words (about 263 MiB). Summing request-boundary +GC counter deltas gave 3,437 minor and 355 major collections, with no +compactions; overlapping requests may observe the same global collection, +so these sums are diagnostic rather than exact build-wide counts. Allocation +counters cover OCaml allocations on worker domains, not native allocations or +retained memory. + +Across the five pairs, median elapsed build time was 1.37 s for both plain +and traced; median process user-plus-system time was 6.59 s for both. Median +GNU `time` peak RSS was 368,196 KiB plain and 352,324 KiB traced, with broad +per-run overlap (338,644–386,256 KiB across both modes). The trace showed no +resolvable wall-time, CPU, or memory penalty here. GNU `time` records the +build process's maximum RSS, not the sum +of concurrently live process trees. Each nested timer reads a clock and an +allocation counter, so tiny phase timings remain directional. + +Reproduce the comparison with the instrumented branch checked out: + +```sh +opam exec -- dune build rewatch-ocaml/rescript_ocaml.exe compiler/bsc/rescript_compiler_main.exe +git -c "safe.directory=$PWD" worktree add --detach /tmp/rescript-typecheck-base 80eb95963 +(cd /tmp/rescript-typecheck-base && opam exec -- dune build \ + rewatch-ocaml/rescript_ocaml.exe compiler/bsc/rescript_compiler_main.exe) +REWATCH_PLAIN_EXECUTABLE=/tmp/rescript-typecheck-base/_build/default/rewatch-ocaml/rescript_ocaml.exe \ +REWATCH_PLAIN_BSC=/tmp/rescript-typecheck-base/_build/default/compiler/bsc/rescript_compiler_main.exe \ + bash rewatch-ocaml/bench/typecheck_breakdown.sh /tmp/rescript-typecheck-data 5 +node rewatch-ocaml/bench/analyze_typecheck_trace.js \ + /tmp/rescript-typecheck-data/traced-1.trace.tsv +``` + +The runner records host details, binary hashes, GNU `time` results, build +output, and raw traces. Omit `REWATCH_PLAIN_*` to compare trace enabled and +disabled in the same binary. The analyzer checks that exclusive phases account +for every request. Keep worker count and fixture filesystem fixed when +comparing results. + +A separate 64 MiB raw CMI byte-cache prototype kept file bytes across +requests, checked file metadata before reuse, and decoded a fresh signature +on every read. Three interleaved eight-worker clean-build pairs gave median +elapsed times of 1.46 s without the cache and 1.42 s with it; median peak +RSS was 363,916 and 355,588 KiB, respectively, within the run-to-run +spread. It left path lookup, Marshal decoding, and signature opening in place, +so this gain was too small to justify another cache and invalidation path. +The prototype was removed. The combined experiment below tested CMI loading +and expansion together while preserving fresh mutable type graphs. + +### Expanded WebAPI component cache experiment + +A later release-profile experiment tried caching the expanded +`WebAPI.DOMAPI` alias and its forced `DOMAPI-WebAPI` signature. The cache +serialized one expanded graph, then deserialized and relocated its generated +type and identifier IDs for each fresh compiler request. It did not share +mutable type nodes between requests. The snapshot was 1.74 MB. Tracing +`components_of_module_maker` with the +`dependency.expand_components::alias=` phase found 137 +`WebAPI.DOMAPI` expansions in the +isolated testrepo clean build, taking 1.724 s and allocating 1.034 GB of +summed worker work. Preparing the snapshot took about 29 ms once; 136 copies +took 0.780 s and allocated 785 MB. These phase totals include tracing and +do not predict elapsed build savings by themselves. + +Three interleaved eight-worker clean builds with the same fixture and +release-profile executable gave median elapsed times of 1.57 s without the +cache and 1.52 s with it. Median peak process RSS rose from 344,176 to +466,916 KiB. Two single-worker pairs gave 4.30 and 4.27 s without the cache, +versus 3.73 and 3.75 s with it; peak RSS rose from about 91 to 118 MiB. +In one retained watcher edit, the cached compiler request took 8.78 ms versus +11.32 ms without the cache. The build-level gain with eight workers was too +small for the memory cost and the extra type-graph relocation machinery, so +the prototype was removed. + +A follow-up replaced the graph-wide ID search with allocation capture while +expanding the alias. It prepared the snapshot in about 17 ms, but the 136 +copies still took 885 ms of summed worker time. Three eight-worker pairs had +the same 1.46 s median elapsed time with and without this cache; median peak +RSS was 489,628 KiB with it and 347,792 KiB without it. Lowering the OCaml +major-heap space overhead to 10% reduced some peaks but did not produce a +consistent elapsed-time gain. Its 14,739 selected artifacts matched the +same-binary uncached build byte for byte. This simpler implementation was +also removed. + +The experiment also checked correctness. An isolated compiler-driver fixture +confirmed that fresh requests received distinct mutable type nodes and that +rebuilding `DOMAPI-WebAPI.cmi` from an `int` signature to a `string` signature +invalidated the cache. All 14,739 selected generated artifacts in the full +clean build had identical SHA-256 hashes with and without caching. The target +CMI was already loaded before every alias expansion in this fixture, so this +cache did not avoid its per-request CMI decode. + +### Combined CMI and expansion snapshot experiment + +A further prototype stored the raw target CMI signature, its expanded +signature, and the target and `WebAPI.DOMAPI` component tables in one 2.58 MB +snapshot. Each request deserialized the snapshot into a fresh graph and +relocated generated IDs when each lazy stage was first forced. The target and +namespace CMI paths and file identity, size, modification time, and change +time guarded reuse. A separate prototype hashed both files on every hit, but +that validation alone cost 0.71 s of summed worker time across 134 hits; file +metadata checks took about 0.01 s. A focused compiler-driver test passed +request graph isolation and target-CMI invalidation, and all 14,739 selected +artifacts matched the same-binary uncached build byte for byte. + +The snapshot clone itself took about 1.45 s and allocated 1.30 GB of summed +worker work across 134 hits. One traced eight-worker clean build took 1.48 s +and peaked at 578,340 KiB RSS, versus roughly 1.46 s and 350,000 KiB in the +uncached runs. Two interleaved single-worker pairs took 4.45 and 4.58 s +uncached versus 3.64 and 3.68 s cached; peak RSS rose from about 92 to 145 +MiB. A retained watcher edit took 10.94 ms of compiler request time cached +versus 11.29 ms uncached. Splitting the target components into a separate +lazy clone raised eight-worker peak RSS to 765,876 KiB and elapsed time to +1.78 s, though its artifacts still matched. These are small samples and the +watcher comparison is one edit per mode. + +The combined cache made the single-worker clean build about 19% faster, but +it did not improve the default eight-worker build and substantially increased +its peak memory. It was removed. Further work needs to reduce the allocation +cost of fresh mutable graphs or shorten the build's critical path, rather than +only eliminating summed worker work. + +A later two-pair sweep of the same opt-in prototype across worker counts showed +where the gain disappears. Each pair cleaned the same fixture and interleaved +uncached and cached builds with the same release executable. Elapsed times and +peak RSS (KiB) were: + +| workers | uncached elapsed | cached elapsed | uncached RSS | cached RSS | +| ---: | ---: | ---: | ---: | ---: | +| 2 | 3.90 / 3.74 s | 2.83 / 2.86 s | 134,436 / 135,312 | 214,708 / 240,496 | +| 4 | 2.16 / 2.15 s | 1.98 / 1.92 s | 203,464 / 205,520 | 328,904 / 346,148 | +| 6 | 1.65 / 1.66 s | 1.58 / 1.57 s | 281,580 / 280,672 | 469,440 / 476,992 | +| 8 | 1.61 / 1.44 s | 1.50 / 1.45 s | 344,468 / 356,152 | 633,676 / 600,740 | + +The two-worker gain is substantial, but this implementation hard-codes one +WebAPI alias and is not suitable as a general compiler cache. The eight-worker +elapsed differences remain within the observed uncached spread. + +### Per-domain in-memory graph reuse + +The retained implementation keeps one expanded alias graph per compiler domain. A +domain never compiles two requests at once, so the graph is exclusive while a +request runs. The cache relocates generated type and identifier IDs when +the graph enters each request, then checks that mutable graph state is +restored before the next request. A full serialization check on one eight-worker +clean build found no retained mutation across 129 reuses. A cheaper typed +check covered type nodes, captured identifiers, abbreviation and object-field +references, row-field references, variant layouts, label arrays, and component +tables; an audit mode compared it with the full serialization check on every +reuse without a disagreement in that fixture. Cache entries still checked the +target and namespace CMI paths and file metadata before use. + +Three interleaved eight-worker pairs with the typed check took 1.48, 1.49, +and 1.51 s uncached versus 1.31, 1.27, and 1.25 s cached. Peak RSS ranged from +347–357 MiB uncached and 520–541 MiB cached. All 14,739 selected artifacts +matched byte for byte in a same-binary cached/uncached comparison. An +upper-bound trial without the request-boundary check took 1.19–1.26 s cached +versus 1.45–1.52 s uncached. That unchecked mode was removed. The checked +cache is enabled by default for Rewatch compiler workers. It reuses mutable +nodes sequentially on one domain after verifying that the previous request +left the graph clean. A dirty graph is restored from the saved snapshot. + +A first same-binary release-profile comparison used three interleaved +eight-worker clean testrepo pairs. Setting +`REWATCH_COMBINED_SIGNATURE_CACHE=0` disabled the cache for the baseline. +Elapsed times were 1.64, 1.54, and 1.51 s without the cache versus 1.35, +1.27, and 1.30 s with it: medians of 1.54 and 1.30 s. A cold two-module +incremental build was slower with eager snapshot preparation, however: +0.16 s cached versus 0.09 s uncached. It compiled one WebAPI source that +opened the large DOMAPI signature only once. + +The retained cache waits until two distinct compiler requests have expanded +the same large alias before preparing a snapshot. A small process-wide table +tracks that first encounter; expanded graphs remain private to each domain. +Six further interleaved eight-worker clean pairs took 1.48, 1.43, 1.43, +1.46, 1.43, and 1.46 s uncached versus 1.23, 1.27, 1.21, 1.28, 1.27, and +1.26 s cached. Median elapsed time fell from 1.45 to 1.27 s, about 12%. +Median peak RSS rose from 349 to 523 MiB. Both selected-artifact comparisons +matched all 14,741 files byte for byte. Three cold incremental pairs after +this change took 0.08–0.09 s uncached and 0.09 s cached, rebuilt the same +two modules, and produced identical selected artifacts. The compiler test +suite, Rewatch integration suite, and a focused test for sequential reuse, +cross-domain separation, dirty-graph recovery, and CMI invalidation passed. +A final audit build checked 128 cached request boundaries against full graph +serialization without a disagreement. + +### Reusing decoded runtime interfaces + +An eight-worker release-profile trace with the expanded WebAPI cache enabled +showed that the 519 compile requests each decoded `Stdlib.cmi` and +`Pervasives.cmi`. Those two files cost 477 ms of summed worker time in CMI +reading and decoding, plus 695 ms searching and opening their paths. The +remaining implementation requests spent about 1,071 ms searching and opening +all CMIs and 849 ms reading and decoding them, including these two runtime +interfaces. Source checking took 1,183 ms; expanded `WebAPI.DOMAPI` work still +accounted for 434 ms. These are exclusive traced worker totals from one build, +not expected elapsed savings. The temporary per-file decode labels used for +this diagnosis were removed afterward. + +The retained compiler cache keeps the decoded `Stdlib` and `Pervasives` CMI +graphs private to each worker domain. Each hit resolves the current load path +and checks the file's identity, size, modification time, and change time. At +the end of a request it compares the graph with a saved serialized image and +restores the image if the request changed it. The nested fresh request used to +prepare an expanded WebAPI snapshot bypasses this cache, so the two caches do +not share mutable input graphs. The cache is active only with the existing +Rewatch signature cache; `REWATCH_COMBINED_SIGNATURE_CACHE=0` disables both. + +A follow-up traced build decoded each runtime CMI nine times rather than 519 +times. Path re-resolution across 1,020 hits took 31 ms of summed worker time, and +1,038 request-boundary graph checks took 64 ms. The one-run trace includes +instrumentation overhead. A focused test changes and shadows `Stdlib.cmi` +between requests, mutates a loaded type, and loads it from another domain. +Another traced clean build found no changed cached runtime CMI graph among +1,038 request-boundary checks. This observation covers these two interfaces +in this fixture; it is not a proof that arbitrary imported type graphs can be +shared concurrently between compiler domains. + +The same testrepo fixture, standalone `bsc`, runtime, and release-profile +toolchain were used for each pair of executables, placed in one directory. +After a warm-up, the gate interleaved the default eight-worker builds. Its +20 ms process-tree sampler measured memory; wall time stopped when each build +process exited. The first seven pairs had clean medians of 1,184 ms before +versus 1,118 ms after. Eleven further pairs, after the nested-request guard +and final code cleanup, had clean medians of 1,203 versus 1,154 ms. Ten of +those eleven paired runs favored the change. Median sampled peak tree RSS was +557,196 KiB before and 566,480 KiB after in the final run, within the +run-to-run spread. Unchanged medians were 44 ms in both versions; single-edit +medians were 45 and 44 ms. Both builds made the same 1,031 clean, four +unchanged, and six edit compiler requests. Complete post-build file sets and +stable generated artifact bytes matched exactly. + +A broader prototype cached frequently loaded CMIs up to 64 KiB, with 32 entries +per domain. Seven pairs found a 26 ms clean median gain beyond the narrow +cache; fifteen further pairs found 19 ms, with overlapping samples and a 1 ms +slower single-edit median. That extra gain was within benchmark variation, so +the broader prototype was removed. The retained change avoids roughly 4–6% +of clean-build wall time on this host and fixture; it does not establish the +same gain for other projects. `make test`, `make test-rewatch`, the OCaml +Rewatch integration script, and the focused Rewatch OUnit suite passed. + +A later project-session implementation retains tables of up to 32 decoded CMIs +of at most 64 KiB each and one expanded signature graph. A module request +borrows one table exclusively and returns it after graph verification, so a +later worker domain can reuse it across build phases and watch edits while +creating fresh inference state. On +this host, nine interleaved clean-build pairs of a synthetic 1,201-module +project measured 839.4 ms for the runtime-only cache and 843.4 ms for the +project cache after the table-lease change; that difference is within run +variation. A seven-edit retained-watch gate on a small fixture measured 77 ms +for each mode, with matching compiler work and output. The available testrepo +dependencies came from a Linux container, so the larger testrepo gate was not +run on macOS. The performance benefit of cross-edit decoded interface and +expanded-signature reuse on larger projects remains unmeasured. + +The request driver now captures ordinary text output in memory, opening a +temporary file only if a job requests an output channel for binary ASTs or +channel-based printing. The same synthetic clean build's summed parse-request +setup time fell from 1,211 ms to 11 ms across 1,202 requests; a traced build +fell from about 0.74 s to 0.62 s. Typed integrity checks on decoded CMIs +replaced repeated full serialization, reducing summed CMI verification from +about 170 ms to 8 ms across 1,201 implementation jobs. An audit mode that also +serialized the CMIs found no missed mutation on this fixture. Nine untraced +interleaved clean-build pairs with both changes gave medians of 696.2 ms for +the runtime-only CMI cache and 695.5 ms for the broader project cache, still +within run variation. These fixtures establish the request-overhead reduction +but no separate wall-time win from caching project CMIs. + +One more temporary trace split the remaining WebAPI cache-hit work. Across 128 +hits, forcing the cached target signature took under 1 ms, alias-ID relocation +took 17 ms, and target-signature-ID relocation took 11 ms in summed worker +time. The larger `WebAPI.DOMAPI` phase also contains the uncached expansions +and snapshot preparation on each domain. Optimizing hit relocation alone has +little elapsed-time headroom. The temporary subtimers were removed. + +To repeat the gate, build the parent revision and this revision with Dune's +`release` profile, copy both embedded executables into one directory, and set +`REWATCH_FIRST_EMBEDDED=1` when invoking `performance_gate.sh`. Use the same +`RESCRIPT_BSC_EXE` and `RESCRIPT_RUNTIME` for both and retain the default eight +compiler domains. The gate archives the same committed testrepo fixture for +each executable and compares work counts and all generated artifact bytes. + +### Sharing a prepared signature image across workers + +The expanded WebAPI snapshot previously had to be prepared separately by each +compiler domain. The compiler now publishes one immutable marshaled image after +the first preparation. Other domains decode private graphs from that image; +fresh inference variables and request-local type and identifier IDs remain +private to each compile job. A mutex serializes the first preparation, while +the existing per-domain graph verifier continues to check for mutations after +each job. The shared image is keyed by the alias, both CMI paths and file +metadata, and the resolved load path. The per-domain cache also checks the +resolved load path, so a job with different import resolution prepares its own +graph. `REWATCH_COMBINED_SIGNATURE_CACHE=0` disables this reuse. + +One traced clean build restored the shared image on seven domains and captured +eight private graph integrity snapshots. It made the same 128 expanded-snapshot +cache hits as the previous implementation. Decoding the seven private graphs +took 72 ms of summed worker time in that trace. The trace is diagnostic and +includes instrumentation overhead. + +Eleven interleaved release-profile pairs compared the decoded-runtime-CMI +version with and without cross-domain image sharing. Clean median wall time +fell from 1,145 to 1,051 ms, and all eleven pairs favored sharing. Median +sampled peak tree RSS fell from 543,976 to 472,236 KiB. Unchanged and +single-edit medians were 44 versus 45 ms and 44 versus 45 ms, respectively. + +A separate eleven-pair gate compared the complete change directly with the +original per-worker WebAPI cache at revision `d1c43a0c0`: + +| scenario | original median wall | new median wall | original peak tree RSS | new peak tree RSS | +| --- | ---: | ---: | ---: | ---: | +| Clean, eight workers | 1,199 ms | 1,014 ms | 545,312 KiB | 457,660 KiB | +| Unchanged | 45 ms | 44 ms | 26,744 KiB | 26,888 KiB | +| One source edit | 44 ms | 45 ms | 26,796 KiB | 27,076 KiB | + +The clean median improved by 15% and all eleven paired runs favored the +change. An earlier eleven-pair comparison of the same source change measured +1,190 versus 1,032 ms; ten pairs favored the change and one new-build run was +an outlier at 1,485 ms. Both executables in the final gate used +the same release-profile standalone `bsc`, runtime, fixture, and eight-worker +setting. They made identical 1,031 clean, four unchanged, and six edit compiler +requests. Complete post-build file sets and generated artifact bytes matched. +The 20 ms process-tree memory sampler is directional. The load-path guard was +included in this final gate. +An additional clean build with full graph-integrity auditing checked all 128 +reused snapshots, restored the shared image on seven domains, and reported no +dirty snapshots. +`make test`, `make test-rewatch`, the OCaml Rewatch integration script, the +focused Rewatch OUnit suite, and `make checkformat` passed. + +## Bulk label table checkpoint + +Revision `56164c19e3b0cc751301e4344cc0e4ecff46df20` builds the opened +signature's record-label table once per distinct label name. The previous +revision was `8d1fa55ed0f88bfdebef17bbde797109dfa1e52f`. A temporary +single-worker trace of the testrepo's `WebAPI.DOMAPI` signature found 6,133 +label entries under 991 names in each of 137 expansions. Insertion into the +persistent table took about 461 ms summed across those expansions. The new +builder retains the first-seen insertion order, latest key, and per-name +declaration order; the temporary trace code was removed. + +On the same 12-CPU Linux ARM64 host, five interleaved eight-worker testrepo +runs used release-profile executables placed in the same directory, the same +standalone `bsc` and runtime, and one warm-up per executable. The benchmark +gate, updated at `719e4bd231bf59b21029dfff7584267550fb1799`, times process +completion separately from its 20 ms process-tree resource sampler: + +| scenario | before median wall | after median wall | before peak tree RSS | after peak tree RSS | +| --- | ---: | ---: | ---: | ---: | +| Clean | 1,424 ms | 1,414 ms | 373,612 KiB | 365,252 KiB | +| Unchanged | 45 ms | 44 ms | 26,892 KiB | 26,540 KiB | +| One source edit | 45 ms | 46 ms | 26,980 KiB | 26,628 KiB | + +The five-run clean difference is small beside run-to-run variation. A separate +ten-pair, high-resolution interleaved clean comparison without the resource +sampler measured 1,457 ms before and 1,430 ms after (1.9% faster). Twenty +warmed unchanged builds on isolated fixtures measured 45.10 and 45.01 ms; +there was no measurable incremental gain. These direct timings used +`process.hrtime.bigint()` around each child build, after cleaning before each +clean sample. The resource figures above are sampled peaks, not exact maximum +RSS, and do not establish a memory reduction. + +One exploratory five-pair single-worker comparison had isolated long clean +builds in both versions (15 s before and 52 s after). Five later traced clean +builds per version did not reproduce those outliers and made the expected 512 +compile requests each. The cause is unknown, so these single-worker samples +are not evidence for or against a stable tail-latency change. + +Both versions made the same 1,031 clean, four unchanged, and six edit compiler +requests. The complete post-build file sets and stable artifact bytes matched. +The clean time and memory gate passed. A seven-edit retained-watch comparison +measured 84 ms before and 82 ms after, with seven parse and seven compile +requests each, identical edited JavaScript, and stable watcher resources. +The small watch fixture cannot establish a latency gain. `make test`, +`make test-rewatch`, the OCaml Rewatch integration script, and the Rewatch +unit tests passed with the new compiler. No company-project performance is +inferred from these repository measurements. + +To reproduce the before/after gates after installing the dependencies shown +below, build both revisions with the Dune `release` profile and put their +executables in the same directory. For two embedded compiler executables, +`REWATCH_FIRST_EMBEDDED=1` makes the first argument use the logical request +trace; the harness still labels that first executable `Rust` in its output: + +```sh +git worktree add --detach /tmp/rewatch-before-bulk 8d1fa55ed +(cd /tmp/rewatch-before-bulk && opam exec -- dune build --profile release \ + compiler/bsc/rescript_compiler_main.exe rewatch-ocaml/rescript_ocaml.exe) +opam exec -- dune build --profile release \ + compiler/bsc/rescript_compiler_main.exe rewatch-ocaml/rescript_ocaml.exe +mkdir -p /tmp/rewatch-bulk-binaries +cp /tmp/rewatch-before-bulk/_build/default/rewatch-ocaml/rescript_ocaml.exe \ + /tmp/rewatch-bulk-binaries/before +cp _build/default/rewatch-ocaml/rescript_ocaml.exe \ + /tmp/rewatch-bulk-binaries/after +export RESCRIPT_BSC_EXE=/tmp/rewatch-before-bulk/_build/default/compiler/bsc/rescript_compiler_main.exe +export RESCRIPT_RUNTIME="$PWD/packages/@rescript/runtime" +REWATCH_FIRST_EMBEDDED=1 REWATCH_COMPILER_DOMAINS=8 \ + rewatch-ocaml/bench/performance_gate.sh \ + /tmp/rewatch-bulk-binaries/before /tmp/rewatch-bulk-binaries/after 5 +REWATCH_FIRST_EMBEDDED=1 REWATCH_WATCH_COMPILER_DOMAINS=8 \ + rewatch-ocaml/bench/watch_performance_gate.sh \ + /tmp/rewatch-bulk-binaries/before /tmp/rewatch-bulk-binaries/after 7 +``` + +## Current Rust comparison and compiler placement + +At revision `f8c60996fbb50a1f3678723f4910549e9fe3994d`, five interleaved +clean, unchanged, and edit runs used the Cargo release Rust executable, the +Dune release standalone `bsc` from `_build/default`, the Dune release OCaml +executable, and the same local runtime. This used the gate's independent wall +timer and 20 ms process-tree RSS sampler: + +| scenario | Rust median wall | OCaml median wall | Rust sampled peak tree RSS | OCaml sampled peak tree RSS | +| --- | ---: | ---: | ---: | ---: | +| Clean, 8 OCaml workers | 3,377 ms | 1,368 ms | 272,316 KiB | 361,520 KiB | +| Unchanged, 8 workers | 125 ms | 57 ms | 28,976 KiB | 26,320 KiB | +| One source edit, 8 workers | 126 ms | 56 ms | 38,784 KiB | 26,400 KiB | +| Clean, 6 OCaml workers | 3,626 ms | 1,572 ms | 263,240 KiB | 303,368 KiB | +| Unchanged, 6 workers | 131 ms | 57 ms | 29,880 KiB | 26,276 KiB | +| One source edit, 6 workers | 132 ms | 58 ms | 32,536 KiB | 26,268 KiB | + +Eight workers gave a 2.47x clean wall-time gain but exceeded the gate's 125% +sampled-memory limit. Six workers gave a 2.31x gain and passed that limit. +Both counts matched the 1,031 clean, four unchanged, and six edit logical +compiler requests, complete post-build file sets, and stable artifact bytes. +These are separate runs; compare ratios within the same worker-count group. +The memory sampler can miss brief child-process peaks, so treat its ratios as +directional. This refreshes the earlier native Linux checkpoint above; no +company-project performance is implied. + +The standalone compiler's filesystem location materially affects the Rust +baseline on this host. The workspace's Dune build directory is on `virtiofs`; +`/tmp` is on `overlay`. A copied release `bsc` had the same SHA-256 digest +(`cfefc4fe91cd78b7906fde1f546026d971f29775557654269d7a34415d15dfa9`) +as the Dune-path executable. Thirty interleaved `bsc -version` launches +measured about 5 ms median from `/tmp` versus 15 ms from the Dune path. This +is consistent with executable loading from the different mounts; it does not +show a compiler-code difference. + +With that byte-identical compiler on `/tmp`, a separate five-run eight-worker +comparison measured 1,483 ms Rust versus 1,358 ms OCaml clean wall time, with +sampled peak tree RSS of 336,308 versus 353,276 KiB. Unchanged medians were +84 versus 59 ms and single-edit medians 83 versus 59 ms. Work counts, complete +file sets, and stable artifact bytes matched, and the clean time and memory +gate passed. The clean OCaml gain was only 1.09x under this placement, versus +2.47x with the compiler on the workspace mount. Compare each pair only within +its run. The gate now prints executable and compiler hashes, runtime path, and +worker settings, so a benchmark can be reproduced with its actual compiler +storage layout. Neither layout predicts the closed-source company project. + +After the gate began restoring the source between timed edit samples, a +five-run repeat at `9fa158aee436b0804ae7f6d0bb5d72144e038053` with the +same `/tmp` compiler measured 1,482 ms Rust versus 1,398 ms OCaml clean wall +time, and 339,716 versus 359,656 KiB sampled peak tree RSS. Unchanged +medians were 80 versus 59 ms; edit medians were 77 versus 57 ms. Equal +compiler work, complete file sets, and stable artifact bytes passed the gate. +The clean gain in this repeat was 1.06x. The older fast-placement results +above used cumulative comment edits; compare medians only within each run. + +With the fast-placement Rust median as the reference, a 5x clean-build gain +would require about 297 ms total. The separate instrumented OCaml compile +span was 1,172 ms on this fixture, before accounting for the rest of the +build. That trace has overhead and is not a same-run lower bound, but it shows +why scheduling and startup changes alone are unlikely to reach the target; +compiler work would need a several-fold reduction as well. + +The earlier 142 versus 83 ms Rust/OCaml retained-watch comparison timed Rust +through the counting compiler proxy. With the revised gate and the same real +`bsc` on `/tmp` for both implementations, seven retained edits measured 92 +ms Rust versus 81 ms OCaml median. Each made seven parse and seven compile +requests; edited JavaScript changed and matched, and file descriptor, task, +and RSS growth stayed within the gate's limits. This small watch fixture measures +single-module edits only. + ## AST I/O checkpoint Temporary counters on the same host and eight-domain fixture measured 917 @@ -62,27 +895,40 @@ 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, +Build the local runtime, lockfile-pinned testrepo dependencies, and both +release executables. Then run the Linux clean, unchanged, edit, work, resource, and artifact comparison: ```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 ``` -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 harness isolates dependency trees, interleaves timed clean, unchanged, +and single-edit builds, and samples process-tree RSS and task counts. It then +traces Rust `bsc` requests and OCaml's logical compiler-request log, compares +work in all three scenarios, and compares complete file sets and stable +artifact bytes at the same absolute path. Each timed source edit adds a +comment to `packages/watch-warnings/src/B.res` in an isolated fixture. The +harness then restores the original source and completes an untimed build, so +every edit sample starts from the same compiled baseline. + +The incremental figures recorded above used the earlier cumulative-comment +procedure; the clean-build figures are unaffected by this harness change. +The unchanged workload replays the fixture's local `ModuleA` warning, so four +compiler requests there are expected. `KEEP_REWATCH_BENCHMARK_WORKDIR=1` +retains raw outputs and `results.csv`. The 125% wall-time and memory limits +currently apply to the clean scenario; the other scenarios are measured and +checked for equivalent work and artifacts. ## Filesystem-work audit @@ -131,6 +977,12 @@ 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. +On the small `basic` fixture, one retained-watch edit produced 19 Rust versus +26 OCaml project-local metadata calls and 43 versus 42 opens. The most +repeated source and compiler-artifact opens were similar in both versions. +This one-edit trace does not indicate a large OCaml-specific filesystem cost +on the watch path; it says little about larger dependency graphs. + The retained-watch performance and resource gate exercises several ordinary edits through the same long-lived watcher: @@ -144,18 +996,22 @@ rewatch-ocaml/bench/watch_performance_gate.sh \ 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. +It warms both implementations, interleaves an odd number of timed edits with +the real `bsc` path, requires byte-identical generated JavaScript and equal +logical parser/compiler work counts, and samples file descriptors, tasks, and +RSS after every build. External compiler work is counted in a separate, +untimed replay through the `bsc` proxy; embedded OCaml work is observed at the +shared logical compiler-request boundary during the timed run. Every edit +changes `B.res`'s generated JavaScript; the gate verifies each timed result +changed and compares both implementations and the replay. The proxy therefore +adds no launch overhead to the measured edits. 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 +The build gate's 125% clean-build wall-time limit remains the general latency +criterion; unchanged and single-edit builds are measured separately. 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`. diff --git a/rewatch-ocaml/bench/analyze_compiler_timing.js b/rewatch-ocaml/bench/analyze_compiler_timing.js new file mode 100644 index 0000000000..2184444e04 --- /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("\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}`); + } + 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), + (summed / span).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 0000000000..007ae49773 --- /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/dune b/rewatch-ocaml/bench/dune new file mode 100644 index 0000000000..b314dec24a --- /dev/null +++ b/rewatch-ocaml/bench/dune @@ -0,0 +1,3 @@ +(executable + (name frozen_type_graph_probe) + (libraries ml unix)) diff --git a/rewatch-ocaml/bench/filesystem_audit.sh b/rewatch-ocaml/bench/filesystem_audit.sh index 19a1ffc92b..e896dd6176 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_type_graph_probe.ml b/rewatch-ocaml/bench/frozen_type_graph_probe.ml new file mode 100644 index 0000000000..a7b2d57b85 --- /dev/null +++ b/rewatch-ocaml/bench/frozen_type_graph_probe.ml @@ -0,0 +1,57 @@ +(* 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\n" + (Bytes.length bytes) (List.length roots) + (Frozen_type_graph.node_count 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/make_immutable_interface_fixture.py b/rewatch-ocaml/bench/make_immutable_interface_fixture.py new file mode 100644 index 0000000000..3c6ba7720c --- /dev/null +++ b/rewatch-ocaml/bench/make_immutable_interface_fixture.py @@ -0,0 +1,114 @@ +#!/usr/bin/env python3 +"""Create the flat-CMI workload used by IMMUTABLE_INTERFACES.md.""" + +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", + ) + ): + raise SystemExit( + f"Usage: {sys.argv[0]} OUTPUT_DIRECTORY " + "[--values-only|--types-only|--variants-only|--modules-only|--open-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 == "--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 == "--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 b9aa48e942..13c42017c5 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 0000000000..80e1fd5b8c --- /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 58dbf7737b..8234ef888d 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 5bf7e76612..47540efb59 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_attempt.ml b/rewatch-ocaml/build_attempt.ml index da09f9bc18..0fd00a87c7 100644 --- a/rewatch-ocaml/build_attempt.ml +++ b/rewatch-ocaml/build_attempt.ml @@ -27,6 +27,13 @@ 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; +} + type pending_work = { mutable namespace_jobs: namespace_job list; mutable compile_candidates: Compiler_scheduler.candidate list; @@ -56,6 +63,9 @@ 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; + invalidated_parse_exports: (string, unit) Hashtbl.t; finalization: finalization_state; mutable compiler_cleaned: bool; mutable had_warnings: bool; @@ -88,6 +98,9 @@ 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; + invalidated_parse_exports = Hashtbl.create 16; finalization = { results = cleanup_results; @@ -104,6 +117,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 +140,59 @@ let create_retained ~session ~process_poll ~progress ~verbosity = let register_cleanup attempt action = attempt.finalization.actions <- action :: attempt.finalization.actions +let add_parse_export attempt ~staged_ast ~published_ast ~source ~compile_assets + = + attempt.parse_exports <- + {staged_ast; published_ast; source; compile_assets} :: attempt.parse_exports + +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 -> + 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. *) + 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 = + 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 +273,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 25e9746e80..71312ff55f 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,9 @@ 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; + invalidated_parse_exports: (string, unit) Hashtbl.t; finalization: finalization_state; mutable compiler_cleaned: bool; mutable had_warnings: bool; @@ -60,6 +64,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 +80,16 @@ val create_retained : t val register_cleanup : t -> (unit -> unit) -> unit +val add_parse_export : + 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 586e96636d..94ba238063 100644 --- a/rewatch-ocaml/build_preparation.ml +++ b/rewatch-ocaml/build_preparation.ml @@ -18,6 +18,13 @@ let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch Package_graph.discover ~root_config ~prod ~features ~warn_error ~filter ~attempt in + Rescript_compiler_driver.set_session_frozen_enabled + (Build_session.compiler_session attempt.session) + (not + (List.exists + (fun (package : Package_plan.t) -> + Compiler_args.gentype_enabled package.compile_config) + package_plans)); 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 +34,12 @@ 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) + ~binary_annotations:(Compiler_args.binary_annotations_enabled root_config) + ~compatibility_copies: + (Compiler_args.compatibility_copies_enabled root_config) + ~frozen_values: + (Rescript_compiler_driver.session_frozen_enabled + (Build_session.compiler_session attempt.session)) ~package_output_specs:(Compiler_info.package_output_specs root_config) in let previous_compile_assets = @@ -180,8 +193,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 +210,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 d5ec0aa55c..cb21474f19 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,9 @@ type t = { warning_state: Warning_state.t; } -let create ~warning_state = +let create_with_compiler_session ~compiler_session ~warning_state = { + compiler_session; global_modules = Hashtbl.create 64; namespace_maps = Hashtbl.create 16; namespace_maps_by_name = Hashtbl.create 16; @@ -53,6 +55,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 +153,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 847532a519..9ba81d1f9a 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 853f5b8e0a..8b3f4136b2 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 d3cc853e01..7edb623f81 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 20d8bc6c9c..70ea0a5cc4 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; } @@ -21,7 +22,7 @@ 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 +58,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 +70,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 +120,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 +137,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 53180ff4d6..adbec7724e 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 a0bec78e95..a885869b9c 100644 --- a/rewatch-ocaml/compiler_args.ml +++ b/rewatch-ocaml/compiler_args.ml @@ -81,6 +81,16 @@ 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 binary_annotations_enabled (config : Config.t) = + Sys.getenv_opt "REWATCH_BIN_ANNOT" = Some "1" || gentype_enabled config + +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 -> [] @@ -110,6 +120,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 df45b4a802..574aefe609 100644 --- a/rewatch-ocaml/compiler_args.mli +++ b/rewatch-ocaml/compiler_args.mli @@ -14,6 +14,9 @@ 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 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 063aec8756..5b3d9d337e 100644 --- a/rewatch-ocaml/compiler_info.ml +++ b/rewatch-ocaml/compiler_info.ml @@ -5,6 +5,9 @@ type context = { runtime_path: string; source_map_args: string list; inherited_compiler_args: string list; + binary_annotations: bool; + compatibility_copies: bool; + frozen_values: bool; package_output_specs: package_output_spec list; } @@ -14,7 +17,7 @@ and package_output_spec = { suffix: string; } -let format_version = "4" +let format_version = "7" let package_output_specs (config : Config.t) = List.map @@ -26,8 +29,9 @@ 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 ~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 +39,20 @@ let make_context ~build_root ~compiler_path ~compiler_identity ~runtime_path runtime_path; source_map_args; inherited_compiler_args; + binary_annotations; + compatibility_copies; + 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; + 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 +116,9 @@ let json context (config : Config.t) = (List.map (fun value -> `String value) context.inherited_compiler_args) ); + ("binary_annotations", `Bool context.binary_annotations); + ("compatibility_copies", `Bool context.compatibility_copies); + ("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 e96b3faa33..ff99ad3402 100644 --- a/rewatch-ocaml/compiler_info.mli +++ b/rewatch-ocaml/compiler_info.mli @@ -5,6 +5,9 @@ type context = { runtime_path: string; source_map_args: string list; inherited_compiler_args: string list; + binary_annotations: bool; + compatibility_copies: bool; + frozen_values: bool; package_output_specs: package_output_spec list; } (** Compiler information fingerprints effective inputs rather than only the @@ -21,12 +24,15 @@ and package_output_spec = { val package_output_specs : Config.t -> package_output_spec list val make_context : + 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 9d447949cf..e94af56a99 100644 --- a/rewatch-ocaml/compiler_process.ml +++ b/rewatch-ocaml/compiler_process.ml @@ -24,23 +24,48 @@ let compiler_phase args = in (phase, input) +let append_log path line = + 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 +76,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 +105,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 +138,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 +202,41 @@ 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 _ -> 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 +279,7 @@ let namespace_task ~bsc ~runtime ~build_dir ~ocaml_dir ~entry ~package_dirty Compiler_scheduler. { task = - task + task ?session Process. { program = bsc; @@ -209,12 +302,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 +397,73 @@ 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 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 + let changes = + publish_compiler_artifacts ~preserve_source_mtime ~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)); + | Source.Implementation -> [Cmi; Required "cmj"; Optional "cmt"]) + 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 +472,252 @@ 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 + 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 = + let filename = Filename.concat ocaml_dir (basename ^ cmt_extension) in + if File_util.is_regular_file filename then Some filename else None + in + let generated_outputs = + let compiler_outputs = + List.map + (fun extension -> + Filename.concat ocaml_dir (basename ^ extension)) + [".cmi"; ".cmj"; ".cmt"; ".cmti"] + @ [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 ~retain_interface ~dependencies ~build_dir ~ocaml_dir + ~is_local ~(config : Config.t) ~source_kind path result = + (* 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 + match session with + | None -> immediate false + | Some session + when (not retain_interface) + || not (Rescript_compiler_driver.session_frozen_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"; + destination "cmt"; + destination "cmti"; + 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: + (Some + (source + (match source_kind with + | Source.Interface -> "cmti" + | Source.Implementation -> "cmt"))) + ~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 7a7b575ee4..3c512e0e28 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,9 @@ val post_build_tasks : Config.t -> string -> Compiler_scheduler.post_build_task list val publish : + ?session:Rescript_compiler_driver.session -> + 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 7a9f7a9409..9076c004c5 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,12 +275,33 @@ 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 @@ -276,6 +380,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 +508,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 3038a5b2b2..cade00b4fc 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/module_graph.ml b/rewatch-ocaml/module_graph.ml index 8c55185428..849cae38dd 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 e1e904029c..214eff6225 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 2712cce9d6..044c325b87 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,12 @@ 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) + ~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 +168,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 +188,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 f26ceea9da..17262d6db7 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,16 @@ 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 + Rescript_compiler_driver.publish_session_ast + (Build_session.compiler_session attempt.session) + ~source:staged_ast; + Build_attempt.add_parse_export 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 9639921b00..f40cf683c4 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 diff --git a/rewatch-ocaml/tests/check_config_acceptance.sh b/rewatch-ocaml/tests/check_config_acceptance.sh index c414fcb108..a50df09f4d 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,17 @@ 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")); + // OCaml Rewatch skips optional binary annotations by default. GenType + // still needs them, so only ordinary packages add this compiler flag. + if (!ocaml.compiler_args.includes("-bs-gentype")) { + const packageName = ocaml.compiler_args.indexOf("-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); + } + 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/src/Annotated.res b/rewatch-ocaml/tests/gentype/src/Annotated.res new file mode 100644 index 0000000000..e668d36651 --- /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 0000000000..cd298427b2 --- /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 0000000000..c7f8836e91 --- /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 0a3b596ffb..f43731da80 100644 --- a/rewatch-ocaml/tests/run.sh +++ b/rewatch-ocaml/tests/run.sh @@ -62,6 +62,8 @@ 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/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 +790,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 +896,21 @@ 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" +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" @@ -1281,7 +1316,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 +1354,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 +1385,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" @@ -1613,8 +1648,100 @@ 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" -"$port" build "$gentype" +REWATCH_TYPECHECK_TRACE="$work/gentype-trace.tsv" "$port" build "$gentype" test -f "$gentype/src/Main.js" +test -f "$gentype/src/Annotated.gen.ts" +test -f "$gentype/src/Pair.gen.ts" +grep 'src/Annotated.ast.*dependency.gentype_semantic_result' \ + "$work/gentype-trace.tsv" >/dev/null +grep 'src/Pair.ast.*dependency.gentype_semantic_result' \ + "$work/gentype-trace.tsv" >/dev/null +if grep 'src/Annotated.ast.*dependency.gentype_cmt_read' \ + "$work/gentype-trace.tsv" >/dev/null; then + echo "genType reread the newly written implementation CMT" >&2 + exit 1 +fi + +REWATCH_FROZEN_VALUES=1 REWATCH_SESSION_CMI=1 \ + REWATCH_TYPECHECK_TRACE="$work/session-interface-trace.tsv" \ + REWATCH_COMPILER_TIMING_LOG="$work/session-interface-timing.tsv" \ + REWATCH_ARTIFACT_EXPORT_LOG="$work/session-interface-export.tsv" \ + "$port" build "$work/session-interface" +grep 'src/Api.ast.*dependency.session_cmi_lookup' \ + "$work/session-interface-trace.tsv" >/dev/null +grep 'src/Consumer.ast.*dependency.session_cmi_lookup' \ + "$work/session-interface-trace.tsv" >/dev/null +if grep 'src/Consumer.ast.*dependency.search_open:Api' \ + "$work/session-interface-trace.tsv" >/dev/null; then + echo "consumer reopened the freshly published Api CMI" >&2 + exit 1 +fi +consumer_start=$(awk -F '\t' \ + '$1 == "implementation" && $3 == "src/Consumer.ast" {print $4; exit}' \ + "$work/session-interface-timing.tsv") +interface_export=$(awk -F '\t' \ + '$1 == "start" && $2 == "src/Api.resi" {print $3; exit}' \ + "$work/session-interface-export.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="$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 +grep 'start.*src/Api.res' "$work/failed-export-timing.tsv" >/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="$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 +grep 'start.*src/Api.resi' \ + "$work/failed-interface-export-timing.tsv" >/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 0000000000..2ce513bb81 --- /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 0000000000..4339661d2a --- /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 0000000000..b12cd315e3 --- /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 0000000000..e0716d0bfc --- /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 a50502a34a..418d2c7d1e 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 0485d49c2a..ce47f4da89 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 34744e68fb..cd7e3c2a90 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 f7f945b7d7..240f9355bb 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 0000000000..66e621a088 --- /dev/null +++ b/tests/ounit_tests/ounit_frozen_type_graph_tests.ml @@ -0,0 +1,234 @@ +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 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; + ] 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 0000000000..6f9565f59a --- /dev/null +++ b/tests/ounit_tests/ounit_frozen_values_tests.ml @@ -0,0 +1,611 @@ +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 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); + ] + 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))); + 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 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; + ] diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index 8dad3e6f03..79b59cea35 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 43ec16b62e..d5ee9f393b 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,93 @@ 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 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 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; + "invalidated parse export is removed" + >:: invalidated_parse_export_is_removed; + "failed parse export forces reparse" + >:: failed_parse_export_forces_reparse; ] diff --git a/tests/rewatch_ounit_tests/compiler_driver_tests.ml b/tests/rewatch_ounit_tests/compiler_driver_tests.ml index b04b1cf2bf..0b6f36189f 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 @@ -684,7 +735,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 +750,298 @@ 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 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 +1053,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 +1071,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) @@ -981,6 +1325,686 @@ 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) () = + 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]; + 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 ())); + 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 +2251,17 @@ 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; + "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 +2273,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; @@ -1257,6 +2293,15 @@ let 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 43be502ffa..5f9fb035af 100644 --- a/tests/rewatch_ounit_tests/compiler_info_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_info_tests.ml @@ -13,14 +13,19 @@ 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 ?(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 ~frozen_values ~package_output_specs:(Compiler_info.package_output_specs config) let tests = @@ -50,6 +55,26 @@ 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_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"; Compiler_info.clean_package config; check (not (Sys.file_exists marker)) "mismatched artifacts are removed"); with_temp_dir (fun root -> @@ -124,19 +149,22 @@ let tests = ] in let initial = - Compiler_info.make_context ~build_root:root ~compiler_path:bsc + Compiler_info.make_context ~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_identity:"changed-compiler" ~runtime_path:runtime - ~source_map_args:[] ~inherited_compiler_args:[] - ~package_output_specs:esmodule + Compiler_info.make_context ~compatibility_copies:true ~build_root:root + ~compiler_path:bsc ~compiler_identity:"changed-compiler" + ~runtime_path:runtime ~source_map_args:[] ~inherited_compiler_args:[] + ~binary_annotations:true ~package_output_specs:esmodule + ~frozen_values:true in check (Compiler_info.needs_clean changed dependency) @@ -154,10 +182,11 @@ let tests = write bsc "compiler-v1"; File_util.ensure_dir runtime; let standalone = - Compiler_info.make_context ~build_root:dependency_root - ~compiler_path:bsc + Compiler_info.make_context ~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 +202,12 @@ let tests = ] in let consumer = - Compiler_info.make_context ~build_root:consumer_root ~compiler_path:bsc + Compiler_info.make_context ~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 51d45d6ee8..779070a2aa 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 5c6adb73cf..ec9f9585e2 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 -> @@ -96,6 +96,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 +131,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 +193,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 +219,7 @@ let tests = let hook_interrupted = try Compiler_scheduler.run + ~on_ast_invalidation:(fun _ -> ()) ~poll: (Some (fun () -> @@ -244,3 +258,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]