diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index df46576551d..1630f95b8bc 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -284,14 +284,14 @@ npm link rescript #### Use Local BSC with Existing ReScript Installation -Alternatively, you can set the `RESCRIPT_BSC_EXE` environment variable to point to your locally compiled `bsc.exe`. +The `rescript` build system has the compiler built in, so to test a local compiler change, link the local package as shown above. + +The Rust build system, `rescript-rust`, still runs `bsc.exe` and accepts the `RESCRIPT_BSC_EXE` environment variable pointing to your locally compiled `bsc.exe`: ```sh -RESCRIPT_BSC_EXE=your-rescript-repo/packages/@rescript/darwin-arm64/bin/bsc.exe npx rescript +RESCRIPT_BSC_EXE=your-rescript-repo/packages/@rescript/darwin-arm64/bin/bsc.exe npx rescript-rust ``` -This will test the local compiler while still using the build system from the installed Node module. - ### Running Automatic Tests We provide different test suites for different levels of the compiler and build system infrastructure. Always make sure to locally build your compiler before running any tests. diff --git a/analysis/src/completion_back_end.ml b/analysis/src/completion_back_end.ml index c8df30f8020..62e11faabb7 100644 --- a/analysis/src/completion_back_end.ml +++ b/analysis/src/completion_back_end.ml @@ -967,16 +967,28 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos match context_path with | CPString -> if Debug.verbose () then print_endline "[ctx_path]--> CPString"; - [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_string)] + [ + Completion.create "dummy" ~env + ~kind:(Completion.Value (Predef.type_string ())); + ] | CPBool -> if Debug.verbose () then print_endline "[ctx_path]--> CPBool"; - [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_bool)] + [ + Completion.create "dummy" ~env + ~kind:(Completion.Value (Predef.type_bool ())); + ] | CPInt -> if Debug.verbose () then print_endline "[ctx_path]--> CPInt"; - [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_int)] + [ + Completion.create "dummy" ~env + ~kind:(Completion.Value (Predef.type_int ())); + ] | CPFloat -> if Debug.verbose () then print_endline "[ctx_path]--> CPFloat"; - [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_float)] + [ + Completion.create "dummy" ~env + ~kind:(Completion.Value (Predef.type_float ())); + ] | CPArray None -> if Debug.verbose () then print_endline "[ctx_path]--> CPArray (no payload)"; [ @@ -1984,7 +1996,9 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) if prefix = "" then [ create "\"\"" ~includes_snippets:true ~insert_text:"\"$0\"" - ~sort_text:"A" ~kind:(Value Predef.type_string) ~env; + ~sort_text:"A" + ~kind:(Value (Predef.type_string ())) + ~env; ] else [] | Tfunction {env; typ; args; return_type} diff --git a/analysis/src/module_resolution.ml b/analysis/src/module_resolution.ml index 622fc83227f..459ae3f69f9 100644 --- a/analysis/src/module_resolution.ml +++ b/analysis/src/module_resolution.ml @@ -3,7 +3,7 @@ let ( /+ ) = Filename.concat let rec resolve_node_module_path ~start_path name = if name = "@rescript/runtime" then (* Hack: we need a reliable way to resolve modules in monorepos. *) - Some !Runtime_package.path + Some (Runtime_package.get_path ()) else let scope = Filename.dirname name in let name = Filename.basename name in diff --git a/changes/in-process-compilation.polish.md b/changes/in-process-compilation.polish.md new file mode 100644 index 00000000000..431ec8657cd --- /dev/null +++ b/changes/in-process-compilation.polish.md @@ -0,0 +1 @@ +- Speed up `rescript` builds by compiling modules inside the build system on several CPU cores, instead of starting `bsc` for every file. https://github.com/rescript-lang/rescript/pull/8781 diff --git a/changes/ppx-temp-file-cleanup.fix.md b/changes/ppx-temp-file-cleanup.fix.md new file mode 100644 index 00000000000..54cc0a98afc --- /dev/null +++ b/changes/ppx-temp-file-cleanup.fix.md @@ -0,0 +1 @@ +- Remove the temporary PPX files when a PPX fails or a build is interrupted. https://github.com/rescript-lang/rescript/pull/8781 diff --git a/compiler/bsc/build_identity_gen.ml b/compiler/bsc/build_identity_gen.ml new file mode 100644 index 00000000000..41b7debf315 --- /dev/null +++ b/compiler/bsc/build_identity_gen.ml @@ -0,0 +1,38 @@ +let () = + let relevant file = + Filename.basename file = "dune" + || List.exists (Filename.check_suffix file) [".ml"; ".mli"; ".c"; ".h"] + in + let files = + Array.to_list Sys.argv |> List.tl |> List.filter relevant + |> List.sort String.compare + in + let normalize path = + String.map + (function + | '\\' -> '/' + | character -> character) + path + in + let has_suffix suffix = + List.exists + (fun file -> Filename.check_suffix (normalize file) suffix) + files + in + [ + "/flow_parser/parser/expression_parser.ml"; + "/ext/ext_platform_primitives_stubs.c"; + "/ext/platform/native/ext_platform_primitives.ml"; + "/core/platform/native/js_name_of_module_id.ml"; + "/syntax/src/res_driver.ml"; + "/syntax/src/dune"; + ] + |> List.iter (fun suffix -> + if not (has_suffix suffix) then + failwith ("compiler identity is missing required input " ^ suffix)); + let digest = + files + |> List.map (fun file -> file ^ "\000" ^ Digest.file file) + |> String.concat "\000" |> Digest.string + in + Printf.printf "let value = %S\n" (Digest.to_hex digest) diff --git a/compiler/bsc/dune b/compiler/bsc/dune index 04520ffe793..dc80556b3c9 100644 --- a/compiler/bsc/dune +++ b/compiler/bsc/dune @@ -3,10 +3,46 @@ (flags (:standard -ccopt -static)))) +(executable + (name build_identity_gen) + (modules build_identity_gen)) + +(rule + (target rescript_compiler_build_identity.ml) + (deps + build_identity_gen.ml + dune + rescript_compiler_driver.ml + rescript_compiler_driver.mli + rescript_compiler_main.ml + rescript_compiler_main.mli + (source_tree ../common) + (source_tree ../core) + (source_tree ../depends) + (source_tree ../ext) + (source_tree ../flow_parser) + (source_tree ../frontend) + (source_tree ../gentype) + (source_tree ../ml) + (source_tree ../syntax)) + (action + (with-stdout-to + %{target} + (run ./build_identity_gen.exe %{deps})))) + +(library + (name rescript_compiler_driver) + (wrapped false) + (modules rescript_compiler_driver rescript_compiler_build_identity) + (instrumentation + (backend bisect_ppx)) + (libraries common core depends flow_parser gentype syntax unix)) + (executable (name rescript_compiler_main) + (modules rescript_compiler_main) (public_name bsc) (package rescript) (instrumentation (backend bisect_ppx)) - (libraries common core depends flow_parser gentype syntax)) + (libraries rescript_compiler_driver)) diff --git a/compiler/bsc/rescript_compiler_driver.ml b/compiler/bsc/rescript_compiler_driver.ml new file mode 100644 index 00000000000..b99e94b21c9 --- /dev/null +++ b/compiler/bsc/rescript_compiler_driver.ml @@ -0,0 +1,625 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +let absname_key = Request_local.new_key (fun () -> ref false) +let absname () = Domain.DLS.get absname_key +exception Request_exit of int + +module Error_message_utils_support = struct + external to_comment : Res_comment.t -> Error_message_utils.Parser.comment + = "%identity" + external from_comment : Error_message_utils.Parser.comment -> Res_comment.t + = "%identity" + + (* The parser hooks are installed once, before worker domains start. *) + let install_parser () = + (Error_message_utils.Parser.parse_source := + fun source -> + let res = + Res_driver.parse_implementation_from_source + ~display_filename:"" ~source + in + (res.parsetree, res.comments |> List.map to_comment)); + + Error_message_utils.Parser.reprint_source := + fun parsetree comments -> + Res_printer.print_implementation parsetree + ~comments:(comments |> List.map from_comment) + ~width:80 + + let setup () = + Error_message_utils.configured_jsx_module () + := Some + (match !((Js_config.current ()).jsx_module) with + | React -> "React" + | Generic {module_name} -> module_name) +end + +let set_abs_input_name sourcefile = + let sourcefile = + if !(absname ()) && Filename.is_relative sourcefile then + Ext_path.absolute_cwd_path sourcefile + else sourcefile + in + Location.set_input_name sourcefile; + sourcefile +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 + 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 + +let reprint_source_file sourcefile = + let kind = + Ext_file_extensions.classify_input + (Ext_filename.get_extension_maybe sourcefile) + in + let sourcefile = set_abs_input_name sourcefile in + let res = + match kind with + | Res -> + let parse_result = + Res_driver.parsing_engine.parse_implementation ~filename:sourcefile + in + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics + parse_result.source; + raise_notrace (Request_exit 1)); + Res_compmisc.init_path (); + parse_result.parsetree + |> Cmd_ppx_apply.apply_rewriters ~restore:false + ~tool_name:Js_config.tool_name Ml + |> Ppx_entry.rewrite_implementation + |> Res_printer.print_implementation ~width:100 + ~comments:parse_result.comments + |> Compiler_request_output.print_stdout + | Resi -> + let parse_result = + Res_driver.parsing_engine.parse_interface ~filename:sourcefile + in + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics + parse_result.source; + raise_notrace (Request_exit 1)); + Res_compmisc.init_path (); + parse_result.parsetree + |> Cmd_ppx_apply.apply_rewriters ~restore:false + ~tool_name:Js_config.tool_name Mli + |> Ppx_entry.rewrite_signature + |> Res_printer.print_interface ~width:100 ~comments:parse_result.comments + |> Compiler_request_output.print_stdout + | _ -> + Compiler_request_output.print_stdout + ("Invalid input for reprinting ReScript source. Must be a ReScript \ + file: " ^ sourcefile); + raise_notrace (Request_exit 2) + in + res + +let usage = "Usage: bsc \nOptions are:" + +let ppf () = Compiler_request_output.stderr_formatter () + +(* Error messages to standard error formatter *) + +let anonymous ~(rev_args : string list) = + match rev_args with + | [filename] -> process_file filename (ppf ()) + | [] -> () + | _ -> + if !((Js_config.current ()).syntax_only) then + Ext_list.rev_iter rev_args (fun filename -> + Clflags.reset_dump_state (); + Warnings.reset (); + process_file filename (ppf ())) + else Bsc_args.bad_arg "can not handle multiple files" + +let format_file input = + let ext = + Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe input) + in + (match ext with + | Res | Resi -> () + | _ -> Bsc_args.bad_arg ("don't know what to do with " ^ input)); + let formatted = + Res_multi_printer.print + ~ignore_parse_errors:!((Clflags.current ()).ignore_parse_errors) + input + in + match !((Clflags.current ()).output_name) with + | None -> Compiler_request_output.write_stdout formatted + | Some fname -> Ext_io.write_file fname formatted + +let set_color_option option = + match Clflags.parse_color_setting option with + | None -> () + | Some setting -> (Clflags.current ()).color := Some setting + +let eval (s : string) ~suffix = + let tmpfile = Filename.temp_file "eval" suffix in + Ext_io.write_file tmpfile s; + anonymous ~rev_args:[tmpfile]; + if not !((Clflags.current ()).verbose) then + try Sys.remove tmpfile with _ -> () + +(* let (//) = Filename.concat *) + +let bs_version_string = "ReScript " ^ Bs_version.version + +let print_version_string () = + Compiler_request_output.print_stdout bs_version_string; + raise_notrace (Request_exit 0) + +let[@inline] set s : Bsc_args.spec = Unit (Unit_set s) +let[@inline] clear s : Bsc_args.spec = Unit (Unit_clear s) +let[@inline] string_call s : Bsc_args.spec = String (String_call s) +let[@inline] string_optional_set s : Bsc_args.spec = + String (String_optional_set s) + +let[@inline] unit_call s : Bsc_args.spec = Unit (Unit_call s) +let[@inline] string_list_add s : Bsc_args.spec = String (String_list_add s) + +let parse_source_map value = + (Js_config.current ()).source_map := + match String.lowercase_ascii value with + | "linked" -> Linked + | "inline" -> Inline + | "hidden" -> Hidden + | "false" | "none" -> No_source_map + | value -> + Bsc_args.bad_arg + ("Unsupported sourceMap value: " ^ value + ^ ". Expected linked, inline, hidden, false, or none") + +let parse_bool_ref target value = + target := + match String.lowercase_ascii value with + | "true" -> true + | "false" -> false + | value -> Bsc_args.bad_arg ("Expected true or false, got: " ^ value) + +(* mostly common used to list in the beginning to make search fast +*) +let command_line_flags () : (string * Bsc_args.spec * string) array = + [| + ( "-I", + string_list_add (Clflags.current ()).include_dirs, + "*internal* Add to the list of include directories" ); + ( "-w", + string_call (Warnings.parse_options false), + " Enable or disable warnings according to :\n\ + + enable warnings in \n\ + - disable warnings in \n\ + @ enable warnings in and treat them as errors\n\ + can be:\n\ + a single warning number\n\ + .. a range of consecutive warning numbers\n\ + default setting is " ^ Bsc_warnings.defaults_w ); + ( "-o", + string_optional_set (Clflags.current ()).output_name, + "*internal* set output file name to " ); + ( "-bs-read-cmi", + unit_call (fun _ -> (Clflags.current ()).assume_no_mli := Mli_exists), + "*internal* Assume mli always exist " ); + ( "-ppx", + string_list_add (Clflags.current ()).all_ppx, + "*internal* Pipe abstract syntax trees through preprocessor \ + " ); + ( "-open", + string_list_add (Clflags.current ()).open_modules, + "*internal* Opens the module before typing" ); + ( "-bs-jsx", + string_call (fun i -> + if i <> "4" then Bsc_args.bad_arg ("Unsupported jsx version: " ^ i); + (Js_config.current ()).jsx_version := + Js_config.jsx_version_of_int @@ int_of_string i), + "*internal* Set jsx version" ); + ( "-bs-jsx-module", + string_call (fun i -> + let is_generic = + match i |> String.lowercase_ascii with + | "react" -> false + | _ -> true + in + (Js_config.current ()).jsx_module := Js_config.jsx_module_of_string i; + if is_generic then (Js_config.current ()).jsx_version := Some Jsx_v4), + "*internal* Set jsx module" ); + ( "-bs-jsx-mode", + string_call ignore, + "*internal* Set jsx mode, this is no longer used and is a no-op." ); + ( "-bs-jsx-preserve", + set (Clflags.current ()).jsx_preserve, + "*internal* Preserve jsx" ); + ( "-bs-source-map", + string_call parse_source_map, + "*internal* Configure source map output" ); + ( "-bs-source-map-sources-content", + string_call + (parse_bool_ref (Js_config.current ()).source_map_sources_content), + "*internal* Include original source text in source maps" ); + ( "-bs-source-map-root", + string_call (fun value -> (Js_config.current ()).source_map_root := value), + "*internal* Set sourceRoot in source maps" ); + ( "-bs-package-output", + string_call Js_packages_state.update_npm_package_path, + "*internal* Set npm-output-path: [opt_module]:path, for example: \ + 'lib/cjs', 'amdjs:lib/amdjs', 'es6:lib/es6' " ); + ( "-bs-project-root", + string_call (fun s -> + Ext_path.set_project_root s; + Gentype_config.project_root () := s), + "*internal* Set the project root directory" ); + ( "-bs-ast", + unit_call (fun _ -> + (Js_config.current ()).binary_ast := true; + (Js_config.current ()).syntax_only := true), + "*internal* Generate binary .mli_ast and ml_ast and stop" ); + ( "-bs-test-ast-conversion", + set (Js_config.current ()).test_ast_conversion, + "*internal* Roundtrip the parsed AST through Parsetree0 before continuing" + ); + ( "-bs-syntax-only", + set (Js_config.current ()).syntax_only, + "*internal* Only check syntax" ); + ("-bs-g", set (Js_config.current ()).debug, "Debug mode"); + ( "-bs-package-name", + string_call Js_packages_state.set_package_name, + "*internal* Set package name, useful when you want to produce npm \ + packages" ); + ( "-bs-ns", + string_call Js_packages_state.set_package_map, + "*internal* Set package map, not only set package name but also use it \ + as a namespace" ); + ( "-as-pp", + unit_call (fun _ -> + (Js_config.current ()).as_pp := true; + (Js_config.current ()).syntax_only := true), + "*internal*As pp to interact with native tools" ); + ( "-no-alias-deps", + set (Clflags.current ()).transparent_modules, + "*internal*Do not record dependencies for module aliases" ); + ( "-bs-gentype", + set (Clflags.current ()).bs_gentype, + "*internal* Pass gentype command" ); + ( "-bs-gentype-module", + string_call (fun s -> + Gentype_config.module_flag () := Gentype_config.module_of_string s), + "*internal* Set gentype module system: commonjs|esmodule" ); + ( "-bs-gentype-module-resolution", + string_call (fun s -> + Gentype_config.module_resolution_flag () + := Gentype_config.module_resolution_of_string s), + "*internal* Set gentype module resolution strategy: node|node16|bundler" + ); + ( "-bs-gentype-export-interfaces", + set (Gentype_config.export_interfaces_flag ()), + "*internal* Emit gentype interface files" ); + ( "-bs-gentype-generated-extension", + string_call (fun s -> + Gentype_config.generated_file_extension_flag () := Some s), + "*internal* Set gentype generated-file extension (e.g. .gen.tsx)" ); + ( "-bs-gentype-suffix", + string_call (fun s -> Gentype_config.suffix_flag () := Some s), + "*internal* Set gentype import-path suffix (e.g. .bs.js, .mjs)" ); + ( "-bs-gentype-shim", + string_call Gentype_config.add_shim, + "*internal* Register a gentype shim mapping: From=To (repeatable)" ); + ( "-bs-gentype-debug", + string_call Debug.set_item, + "*internal* Enable a gentype debug category (repeatable): \ + all|basic|codeItems|config|converter|dependencies|moduleResolution|notImplemented|translation|typeEnv|typeResolution" + ); + ( "-bs-gentype-dep", + string_call Gentype_config.add_bs_dependency, + "*internal* Register a gentype bsb dependency (repeatable)" ); + ( "-bs-gentype-source-dir", + string_call Gentype_config.add_source_dir, + "*internal* Register a gentype source directory relative to the project \ + root (repeatable)" ); + ( "-bs-gentype-dep-path", + string_call Gentype_config.add_dep_path, + "*internal* Register a gentype dependency install path: \ + = (repeatable)" ); + ( "-bs-gentype-bsb-project-root", + string_call (fun s -> Gentype_config.bsb_project_root () := s), + "*internal* Set gentype bsb project root (workspace root containing \ + .sourcedirs.json)" ); + (******************************************************************************) + ( "-nostdlib", + set (Js_config.current ()).no_stdlib, + "*internal* Don't use stdlib" ); + ( "-color", + string_call set_color_option, + "*internal* Enable or disable colors in compiler messages\n\ + The following settings are supported:\n\ + auto use heuristics to enable colors only if supported\n\ + always enable colors\n\ + never disable colors\n\ + The default setting is 'always'\n\ + The current heuristic for 'auto'\n\ + checks that the TERM environment variable exists and is\n\ + not empty or \"dumb\", and that isatty(stderr) holds." ); + ( "-e", + string_call (fun s -> eval s ~suffix:Literals.suffix_res), + "(experimental) set the string to be evaluated in ReScript syntax" ); + ( "-bs-cmi-only", + set (Js_config.current ()).cmi_only, + "*internal* Stop after generating cmi file" ); + ( "-bs-cmi", + set (Js_config.current ()).force_cmi, + "*internal* Not using cached cmi, always generate cmi" ); + ( "-bs-cmj", + set (Js_config.current ()).force_cmj, + "*internal* Not using cached cmj, always generate cmj" ); + ( "-bs-no-version-header", + set (Js_config.current ()).no_version_header, + "*internal*Don't print version header" ); + ( "-bs-no-builtin-ppx", + set (Js_config.current ()).no_builtin_ppx, + "*internal* Disable built-in ppx" ); + ( "-bs-cross-module-opt", + set (Js_config.current ()).cross_module_inline, + "*internal* Enable cross module inlining(experimental), default(false)" ); + ( "-bs-no-cross-module-opt", + clear (Js_config.current ()).cross_module_inline, + "*internal* Disable cross module inlining(experimental)" ); + ( "-debug-ir", + set (Js_config.current ()).debug_ir, + "*internal* Dump compiler IR and enable Lambda invariant checks" ); + ( "-check-lam", + set (Js_config.current ()).check_lam, + "*internal* Check Lambda invariants after optimization passes" ); + ( "-bs-no-check-div-by-zero", + clear (Js_config.current ()).check_div_by_zero, + "*internal* unsafe mode, don't check div by zero and mod by zero" ); + ( "-bs-noassertfalse", + set (Clflags.current ()).no_assert_false, + "*internal* no code for assert false" ); + ( "-noassert", + set (Clflags.current ()).noassert, + "*internal* Do not compile assertion checks" ); + ( "-bs-loc", + set (Clflags.current ()).dump_location, + "*internal* dont display location with -dtypedtree, -dparsetree" ); + ( "-dtypedtree", + set (Clflags.current ()).dump_typedtree, + "*internal* debug typedtree" ); + ( "-dparsetree", + set (Clflags.current ()).dump_parsetree, + "*internal* debug parsetree" ); + ( "-drawlambda", + set (Clflags.current ()).dump_rawlambda, + "*internal* debug raw lambda" ); + ( "-draw-coercions", + set (Clflags.current ()).dump_coercions, + "*internal* debug module coercions with raw internal types" ); + ("-dsource", set (Clflags.current ()).dump_source, "*internal* print source"); + ( "-reprint-source", + string_call reprint_source_file, + "*internal* transform the target ReScript file using PPXes provided, and \ + print the transformed ReScript code to stdout" ); + ("-format", string_call format_file, "*internal* Format as Res syntax"); + ( "-only-parse", + set (Clflags.current ()).only_parse, + "*internal* stop after parsing" ); + ( "-editor-mode", + unit_call (fun () -> + (Clflags.current ()).ignore_parse_errors := true; + (Js_config.current ()).cmi_only := true), + "*internal* Enable editor mode." ); + ( "-ignore-parse-errors", + set (Clflags.current ()).ignore_parse_errors, + "*internal* continue after parse errors" ); + ( "-verbose", + set (Clflags.current ()).verbose, + "*internal* Print calls to external commands" ); + ( "-keep-locs", + set (Clflags.current ()).keep_locs, + "*internal* Keep locations in .cmi files" ); + ( "-no-keep-locs", + clear (Clflags.current ()).keep_locs, + "*internal* Do not keep locations in .cmi files" ); + ("-nopervasives", set (Clflags.current ()).nopervasives, "*internal*"); + ( "-v", + unit_call print_version_string, + "Print compiler version and location of standard library and exit" ); + ("-version", unit_call print_version_string, "Print version and exit"); + ( "-absname", + set (absname ()), + "*internal* Show absolute filenames in error messages" ); + ( "-enable-experimental", + string_call Experimental_features.enable_from_string, + "Enable experimental features: repeatable, e.g. -enable-experimental \ + LetUnwrap" ); + (* Not used, the build system did the expansion *) + ( "-bs-no-bin-annot", + clear (Clflags.current ()).binary_annotations, + "*internal* Disable binary annotations (by default on)" ); + ( "-short-paths", + clear (Clflags.current ()).real_paths, + "*internal* Shorten paths in types" ); + ("-unsafe", Unit_dummy, "*internal* No longer used and is a no-op."); + ( "-runtime-path", + string_call setup_runtime_path, + "*internal* Set the path of the runtime package (@rescript/runtime)" ); + ( "-warn-help", + unit_call (fun () -> + Warnings.help_warnings (); + raise_notrace (Request_exit 0)), + "Show description of warning numbers" ); + ( "-warn-error", + string_call (Warnings.parse_options true), + " Enable or disable error status for warnings according\n\ + to . See option -w for the syntax of .\n\ + Default setting is " ^ Bsc_warnings.defaults_warn_error ); + ( "-make-runtime", + unit_call Js_packages_state.make_runtime, + "*internal* make runtime library" ); + |] + +(** parse flags in config *) +let file_level_flags_handler (e : Parsetree.expression option) = + match e with + | None -> () + | Some {pexp_desc = Pexp_array args; pexp_loc} -> ( + let args = + Array.of_list + (Ext_list.map args (fun e -> + match Ast_payload.semantic_string_of_expression e with + | Some name -> name + | _ -> + Location.raise_errorf ~loc:e.pexp_loc "string literal expected")) + in + try + Bsc_args.parse_exn ~start:0 ~argv:args (command_line_flags ()) + (fun ~rev_args:_ -> ()) + ~usage + with _ -> + Location.prerr_warning pexp_loc (Preprocessor "invalid flags for bsc")) + | Some e -> Location.raise_errorf ~loc:e.pexp_loc "string array expected" + +(* These shared hooks are installed when the driver module loads, before any + request can start on another domain. Concurrent Lazy.force calls would race + on a first request. *) +let () = + Bs_conditional_initial.setup_env (); + setup_outcome_printer (); + Error_message_utils_support.install_parser (); + let flags = "flags" in + Ast_config.add_structure flags file_level_flags_handler; + Ast_config.add_signature flags file_level_flags_handler; + Ident.capture_request_baseline () + +type result = {exit_code: int; stdout: string; stderr: string} + +let build_identity = Rescript_compiler_build_identity.value + +(* Request_local gives every request the state of a new compiler process. + On top of that, a request needs bsc's own defaults and the type-id baseline, + and allocates the shared predefined type graphs in a fixed order: lazy first + use on different worker domains would otherwise shift serialized type IDs. *) +let start_request () = + Clflags.reset (); + Btype.reinit (); + Predef.reset_for_request (); + Env.reset_initial_for_request () + +let with_fresh_request_states ~cwd action = + Predef.with_fresh (fun () -> + Env.with_fresh_initial (fun () -> + Ident.with_fresh (fun () -> + Request_local.with_fresh (fun () -> + Compiler_request_state.with_fresh ~cwd action)))) + +let run_argv ?run_external ~capture ~cwd argv = + with_fresh_request_states ~cwd (fun () -> + start_request (); + Cmt_format.set_args argv; + let execute () = + try + Bsc_args.parse_exn ~argv (command_line_flags ()) anonymous ~usage; + 0 + with + | Request_exit code -> code + | Bsc_args.Help message -> + Compiler_request_output.write_stdout message; + 0 + | Res_driver.Already_reported -> 1 + | Bsc_args.Bad msg -> + Format.fprintf (ppf ()) "%s@." msg; + 2 + | x -> + Location.report_exception (ppf ()) x; + 2 + in + let run_with_external_owner action = + match run_external with + | None -> action () + | Some run_external -> + Ccomp.with_command_runner + (fun command -> + let status, stdout, stderr = run_external command in + Compiler_request_output.write_stdout stdout; + Format.pp_print_string (ppf ()) stderr; + status) + action + in + if capture then + let exit_code, stdout, stderr = + 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) + in + {exit_code; stdout; stderr} + else + (* A bsc process streams to its own stdout and stderr. *) + let exit_code = + Fun.protect + (fun () -> run_with_external_owner execute) + ~finally:(fun () -> + Format.pp_print_flush Format.std_formatter (); + Format.pp_print_flush Format.err_formatter (); + flush stdout; + flush stderr) + in + {exit_code; stdout = ""; stderr = ""}) + +let run_request ~run_external ~cwd ~argv ~input = + let logical_argv = Array.of_list ("bsc" :: (argv @ [input])) in + run_argv ?run_external ~capture:true ~cwd logical_argv + +let run argv = (run_argv ~capture:false ~cwd:(Sys.getcwd ()) argv).exit_code diff --git a/compiler/bsc/rescript_compiler_driver.mli b/compiler/bsc/rescript_compiler_driver.mli new file mode 100644 index 00000000000..5b53537deee --- /dev/null +++ b/compiler/bsc/rescript_compiler_driver.mli @@ -0,0 +1,28 @@ +type result = {exit_code: int; stdout: string; stderr: string} + +val build_identity : string +(** A digest of the compiler implementation linked into this driver. The + standalone compiler and embedded callers therefore use the same identity + without fingerprinting a separately installed executable. *) + +val run_request : + run_external:(string -> int * string * string) option -> + cwd:string -> + argv:string list -> + input:string -> + 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 may + run concurrently on different domains: their compiler state is + request-local. 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; anything + else raises {!Compiler_request_output.Failed} with the output so far. The request resolves file + I/O against [cwd] without changing the process working directory. Request + state is restored on success and failure. *) + +val run : string array -> int +(** Command-line entry point of the standalone [bsc]. It writes to the process's + stdout and stderr as it goes. *) diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 949d42f6c5f..d88bb959d99 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -1,525 +1 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -let absname = ref false - -module Error_message_utils_support = struct - external to_comment : Res_comment.t -> Error_message_utils.Parser.comment - = "%identity" - external from_comment : Error_message_utils.Parser.comment -> Res_comment.t - = "%identity" - - let setup () = - (Error_message_utils.Parser.parse_source := - fun source -> - let res = - Res_driver.parse_implementation_from_source - ~display_filename:"" ~source - in - (res.parsetree, res.comments |> List.map to_comment)); - - (Error_message_utils.Parser.reprint_source := - fun parsetree comments -> - Res_printer.print_implementation parsetree - ~comments:(comments |> List.map from_comment) - ~width:80); - - Error_message_utils.configured_jsx_module := - Some - (match !Js_config.jsx_module with - | React -> "React" - | Generic {module_name} -> module_name) -end - -let set_abs_input_name sourcefile = - let sourcefile = - if !absname && Filename.is_relative sourcefile then - Ext_path.absolute_cwd_path sourcefile - else sourcefile - in - Location.set_input_name sourcefile; - sourcefile -let setup_outcome_printer () = Lazy.force Res_outcome_printer.setup - -let setup_runtime_path path = Runtime_package.path := path - -let process_file sourcefile ?kind ppf = - (* This is a better default then "", it will be changed later - The {!Location.input_name} relies on that we write the binary ast - properly - *) - 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.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.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 - Printtyp.signature Format.std_formatter cmi_sign; - Format.pp_print_newline Format.std_formatter () - | Unknown -> Bsc_args.bad_arg ("don't know what to do with " ^ sourcefile) - in - res - -let reprint_source_file sourcefile = - let kind = - Ext_file_extensions.classify_input - (Ext_filename.get_extension_maybe sourcefile) - in - let sourcefile = set_abs_input_name sourcefile in - let res = - match kind with - | Res -> - let parse_result = - Res_driver.parsing_engine.parse_implementation ~filename:sourcefile - in - if parse_result.invalid then ( - Res_diagnostics.print_report parse_result.diagnostics - parse_result.source; - exit 1); - Res_compmisc.init_path (); - parse_result.parsetree - |> Cmd_ppx_apply.apply_rewriters ~restore:false - ~tool_name:Js_config.tool_name Ml - |> Ppx_entry.rewrite_implementation - |> Res_printer.print_implementation ~width:100 - ~comments:parse_result.comments - |> print_endline - | Resi -> - let parse_result = - Res_driver.parsing_engine.parse_interface ~filename:sourcefile - in - if parse_result.invalid then ( - Res_diagnostics.print_report parse_result.diagnostics - parse_result.source; - exit 1); - Res_compmisc.init_path (); - parse_result.parsetree - |> Cmd_ppx_apply.apply_rewriters ~restore:false - ~tool_name:Js_config.tool_name Mli - |> Ppx_entry.rewrite_signature - |> Res_printer.print_interface ~width:100 ~comments:parse_result.comments - |> print_endline - | _ -> - print_endline - ("Invalid input for reprinting ReScript source. Must be a ReScript \ - file: " ^ sourcefile); - exit 2 - in - res - -let usage = "Usage: bsc \nOptions are:" - -let ppf = Format.err_formatter - -(* Error messages to standard error formatter *) - -let anonymous ~(rev_args : string list) = - match rev_args with - | [filename] -> process_file filename ppf - | [] -> () - | _ -> - if !Js_config.syntax_only then - Ext_list.rev_iter rev_args (fun filename -> - Clflags.reset_dump_state (); - Warnings.reset (); - process_file filename ppf) - else Bsc_args.bad_arg "can not handle multiple files" - -let format_file input = - let ext = - Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe input) - in - (match ext with - | Res | Resi -> () - | _ -> Bsc_args.bad_arg ("don't know what to do with " ^ input)); - let formatted = - Res_multi_printer.print - ~ignore_parse_errors:!Clflags.ignore_parse_errors - input - in - match !Clflags.output_name with - | None -> output_string stdout formatted - | Some fname -> Ext_io.write_file fname formatted - -let set_color_option option = - match Clflags.parse_color_setting option with - | None -> () - | Some setting -> Clflags.color := Some setting - -let eval (s : string) ~suffix = - let tmpfile = Filename.temp_file "eval" suffix in - Ext_io.write_file tmpfile s; - anonymous ~rev_args:[tmpfile]; - if not !Clflags.verbose then try Sys.remove tmpfile with _ -> () - -(* let (//) = Filename.concat *) - -let bs_version_string = "ReScript " ^ Bs_version.version - -let print_version_string () = - print_endline bs_version_string; - exit 0 - -let[@inline] set s : Bsc_args.spec = Unit (Unit_set s) -let[@inline] clear s : Bsc_args.spec = Unit (Unit_clear s) -let[@inline] string_call s : Bsc_args.spec = String (String_call s) -let[@inline] string_optional_set s : Bsc_args.spec = - String (String_optional_set s) - -let[@inline] unit_call s : Bsc_args.spec = Unit (Unit_call s) -let[@inline] string_list_add s : Bsc_args.spec = String (String_list_add s) - -let parse_source_map value = - Js_config.source_map := - match String.lowercase_ascii value with - | "linked" -> Linked - | "inline" -> Inline - | "hidden" -> Hidden - | "false" | "none" -> No_source_map - | value -> - Bsc_args.bad_arg - ("Unsupported sourceMap value: " ^ value - ^ ". Expected linked, inline, hidden, false, or none") - -let parse_bool_ref target value = - target := - match String.lowercase_ascii value with - | "true" -> true - | "false" -> false - | value -> Bsc_args.bad_arg ("Expected true or false, got: " ^ value) - -(* mostly common used to list in the beginning to make search fast -*) -let command_line_flags : (string * Bsc_args.spec * string) array = - [| - ( "-I", - string_list_add Clflags.include_dirs, - "*internal* Add to the list of include directories" ); - ( "-w", - string_call (Warnings.parse_options false), - " Enable or disable warnings according to :\n\ - + enable warnings in \n\ - - disable warnings in \n\ - @ enable warnings in and treat them as errors\n\ - can be:\n\ - a single warning number\n\ - .. a range of consecutive warning numbers\n\ - default setting is " ^ Bsc_warnings.defaults_w ); - ( "-o", - string_optional_set Clflags.output_name, - "*internal* set output file name to " ); - ( "-bs-read-cmi", - unit_call (fun _ -> Clflags.assume_no_mli := Mli_exists), - "*internal* Assume mli always exist " ); - ( "-ppx", - string_list_add Clflags.all_ppx, - "*internal* Pipe abstract syntax trees through preprocessor \ - " ); - ( "-open", - string_list_add Clflags.open_modules, - "*internal* Opens the module before typing" ); - ( "-bs-jsx", - string_call (fun i -> - if i <> "4" then Bsc_args.bad_arg ("Unsupported jsx version: " ^ i); - Js_config.jsx_version := - Js_config.jsx_version_of_int @@ int_of_string i), - "*internal* Set jsx version" ); - ( "-bs-jsx-module", - string_call (fun i -> - let is_generic = - match i |> String.lowercase_ascii with - | "react" -> false - | _ -> true - in - Js_config.jsx_module := Js_config.jsx_module_of_string i; - if is_generic then Js_config.jsx_version := Some Jsx_v4), - "*internal* Set jsx module" ); - ( "-bs-jsx-mode", - string_call ignore, - "*internal* Set jsx mode, this is no longer used and is a no-op." ); - ("-bs-jsx-preserve", set Js_config.jsx_preserve, "*internal* Preserve jsx"); - ( "-bs-source-map", - string_call parse_source_map, - "*internal* Configure source map output" ); - ( "-bs-source-map-sources-content", - string_call (parse_bool_ref Js_config.source_map_sources_content), - "*internal* Include original source text in source maps" ); - ( "-bs-source-map-root", - string_call (fun value -> Js_config.source_map_root := value), - "*internal* Set sourceRoot in source maps" ); - ( "-bs-package-output", - string_call Js_packages_state.update_npm_package_path, - "*internal* Set npm-output-path: [opt_module]:path, for example: \ - 'lib/cjs', 'amdjs:lib/amdjs', 'es6:lib/es6' " ); - ( "-bs-project-root", - string_call (fun s -> - Ext_path.project_root := Some s; - Gentype_config.project_root := s), - "*internal* Set the project root directory" ); - ( "-bs-ast", - unit_call (fun _ -> - Js_config.binary_ast := true; - Js_config.syntax_only := true), - "*internal* Generate binary .mli_ast and ml_ast and stop" ); - ( "-bs-test-ast-conversion", - set Js_config.test_ast_conversion, - "*internal* Roundtrip the parsed AST through Parsetree0 before continuing" - ); - ( "-bs-syntax-only", - set Js_config.syntax_only, - "*internal* Only check syntax" ); - ("-bs-g", set Js_config.debug, "Debug mode"); - ( "-bs-package-name", - string_call Js_packages_state.set_package_name, - "*internal* Set package name, useful when you want to produce npm \ - packages" ); - ( "-bs-ns", - string_call Js_packages_state.set_package_map, - "*internal* Set package map, not only set package name but also use it \ - as a namespace" ); - ( "-as-pp", - unit_call (fun _ -> - Js_config.as_pp := true; - Js_config.syntax_only := true), - "*internal*As pp to interact with native tools" ); - ( "-no-alias-deps", - set Clflags.transparent_modules, - "*internal*Do not record dependencies for module aliases" ); - ("-bs-gentype", set Clflags.bs_gentype, "*internal* Pass gentype command"); - ( "-bs-gentype-module", - string_call (fun s -> - Gentype_config.module_flag := Gentype_config.module_of_string s), - "*internal* Set gentype module system: commonjs|esmodule" ); - ( "-bs-gentype-module-resolution", - string_call (fun s -> - Gentype_config.module_resolution_flag := - Gentype_config.module_resolution_of_string s), - "*internal* Set gentype module resolution strategy: node|node16|bundler" - ); - ( "-bs-gentype-export-interfaces", - set Gentype_config.export_interfaces_flag, - "*internal* Emit gentype interface files" ); - ( "-bs-gentype-generated-extension", - string_call (fun s -> - Gentype_config.generated_file_extension_flag := Some s), - "*internal* Set gentype generated-file extension (e.g. .gen.tsx)" ); - ( "-bs-gentype-suffix", - string_call (fun s -> Gentype_config.suffix_flag := Some s), - "*internal* Set gentype import-path suffix (e.g. .bs.js, .mjs)" ); - ( "-bs-gentype-shim", - string_call Gentype_config.add_shim, - "*internal* Register a gentype shim mapping: From=To (repeatable)" ); - ( "-bs-gentype-debug", - string_call Debug.set_item, - "*internal* Enable a gentype debug category (repeatable): \ - all|basic|codeItems|config|converter|dependencies|moduleResolution|notImplemented|translation|typeEnv|typeResolution" - ); - ( "-bs-gentype-dep", - string_call Gentype_config.add_bs_dependency, - "*internal* Register a gentype bsb dependency (repeatable)" ); - ( "-bs-gentype-source-dir", - string_call Gentype_config.add_source_dir, - "*internal* Register a gentype source directory relative to the project \ - root (repeatable)" ); - ( "-bs-gentype-dep-path", - string_call Gentype_config.add_dep_path, - "*internal* Register a gentype dependency install path: \ - = (repeatable)" ); - ( "-bs-gentype-bsb-project-root", - string_call (fun s -> Gentype_config.bsb_project_root := s), - "*internal* Set gentype bsb project root (workspace root containing \ - .sourcedirs.json)" ); - (******************************************************************************) - ("-nostdlib", set Js_config.no_stdlib, "*internal* Don't use stdlib"); - ( "-color", - string_call set_color_option, - "*internal* Enable or disable colors in compiler messages\n\ - The following settings are supported:\n\ - auto use heuristics to enable colors only if supported\n\ - always enable colors\n\ - never disable colors\n\ - The default setting is 'always'\n\ - The current heuristic for 'auto'\n\ - checks that the TERM environment variable exists and is\n\ - not empty or \"dumb\", and that isatty(stderr) holds." ); - ( "-e", - string_call (fun s -> eval s ~suffix:Literals.suffix_res), - "(experimental) set the string to be evaluated in ReScript syntax" ); - ( "-bs-cmi-only", - set Js_config.cmi_only, - "*internal* Stop after generating cmi file" ); - ( "-bs-cmi", - set Js_config.force_cmi, - "*internal* Not using cached cmi, always generate cmi" ); - ( "-bs-cmj", - set Js_config.force_cmj, - "*internal* Not using cached cmj, always generate cmj" ); - ( "-bs-no-version-header", - set Js_config.no_version_header, - "*internal*Don't print version header" ); - ( "-bs-no-builtin-ppx", - set Js_config.no_builtin_ppx, - "*internal* Disable built-in ppx" ); - ( "-bs-cross-module-opt", - set Js_config.cross_module_inline, - "*internal* Enable cross module inlining(experimental), default(false)" ); - ( "-bs-no-cross-module-opt", - clear Js_config.cross_module_inline, - "*internal* Disable cross module inlining(experimental)" ); - ( "-debug-ir", - set Js_config.debug_ir, - "*internal* Dump compiler IR and enable Lambda invariant checks" ); - ( "-check-lam", - set Js_config.check_lam, - "*internal* Check Lambda invariants after optimization passes" ); - ( "-bs-no-check-div-by-zero", - clear Js_config.check_div_by_zero, - "*internal* unsafe mode, don't check div by zero and mod by zero" ); - ( "-bs-noassertfalse", - set Clflags.no_assert_false, - "*internal* no code for assert false" ); - ( "-noassert", - set Clflags.noassert, - "*internal* Do not compile assertion checks" ); - ( "-bs-loc", - set Clflags.dump_location, - "*internal* dont display location with -dtypedtree, -dparsetree" ); - ("-dtypedtree", set Clflags.dump_typedtree, "*internal* debug typedtree"); - ("-dparsetree", set Clflags.dump_parsetree, "*internal* debug parsetree"); - ("-drawlambda", set Clflags.dump_rawlambda, "*internal* debug raw lambda"); - ( "-draw-coercions", - set Clflags.dump_coercions, - "*internal* debug module coercions with raw internal types" ); - ("-dsource", set Clflags.dump_source, "*internal* print source"); - ( "-reprint-source", - string_call reprint_source_file, - "*internal* transform the target ReScript file using PPXes provided, and \ - print the transformed ReScript code to stdout" ); - ("-format", string_call format_file, "*internal* Format as Res syntax"); - ("-only-parse", set Clflags.only_parse, "*internal* stop after parsing"); - ( "-editor-mode", - unit_call (fun () -> - Clflags.ignore_parse_errors := true; - Js_config.cmi_only := true), - "*internal* Enable editor mode." ); - ( "-ignore-parse-errors", - set Clflags.ignore_parse_errors, - "*internal* continue after parse errors" ); - ( "-verbose", - set Clflags.verbose, - "*internal* Print calls to external commands" ); - ( "-keep-locs", - set Clflags.keep_locs, - "*internal* Keep locations in .cmi files" ); - ( "-no-keep-locs", - clear Clflags.keep_locs, - "*internal* Do not keep locations in .cmi files" ); - ("-nopervasives", set Clflags.nopervasives, "*internal*"); - ( "-v", - unit_call print_version_string, - "Print compiler version and location of standard library and exit" ); - ("-version", unit_call print_version_string, "Print version and exit"); - ( "-absname", - set absname, - "*internal* Show absolute filenames in error messages" ); - ( "-enable-experimental", - string_call Experimental_features.enable_from_string, - "Enable experimental features: repeatable, e.g. -enable-experimental \ - LetUnwrap" ); - (* Not used, the build system did the expansion *) - ( "-bs-no-bin-annot", - clear Clflags.binary_annotations, - "*internal* Disable binary annotations (by default on)" ); - ( "-short-paths", - clear Clflags.real_paths, - "*internal* Shorten paths in types" ); - ("-unsafe", Unit_dummy, "*internal* No longer used and is a no-op."); - ( "-runtime-path", - string_call setup_runtime_path, - "*internal* Set the path of the runtime package (@rescript/runtime)" ); - ( "-warn-help", - unit_call Warnings.help_warnings, - "Show description of warning numbers" ); - ( "-warn-error", - string_call (Warnings.parse_options true), - " Enable or disable error status for warnings according\n\ - to . See option -w for the syntax of .\n\ - Default setting is " ^ Bsc_warnings.defaults_warn_error ); - ( "-make-runtime", - unit_call Js_packages_state.make_runtime, - "*internal* make runtime library" ); - |] - -(** parse flags in config *) -let file_level_flags_handler (e : Parsetree.expression option) = - match e with - | None -> () - | Some {pexp_desc = Pexp_array args; pexp_loc} -> ( - let args = - Array.of_list - (Ext_list.map args (fun e -> - match Ast_payload.semantic_string_of_expression e with - | Some name -> name - | _ -> - Location.raise_errorf ~loc:e.pexp_loc "string literal expected")) - in - try - Bsc_args.parse_exn ~start:0 ~argv:args command_line_flags - (fun ~rev_args:_ -> ()) - ~usage - with _ -> - Location.prerr_warning pexp_loc (Preprocessor "invalid flags for bsc")) - | Some e -> Location.raise_errorf ~loc:e.pexp_loc "string array expected" - -let _ : unit = - Bs_conditional_initial.setup_env (); - Clflags.color := Some Always; - - let flags = "flags" in - Ast_config.add_structure flags file_level_flags_handler; - Ast_config.add_signature flags file_level_flags_handler; - try Bsc_args.parse_exn ~argv:Sys.argv command_line_flags anonymous ~usage with - | Bsc_args.Bad msg -> - Format.eprintf "%s@." msg; - exit 2 - | x -> - Location.report_exception ppf x; - exit 2 +let () = exit (Rescript_compiler_driver.run Sys.argv) diff --git a/compiler/common/ext_log.ml b/compiler/common/ext_log.ml index 2ae128d6ad3..05a6c986e1a 100644 --- a/compiler/common/ext_log.ml +++ b/compiler/common/ext_log.ml @@ -26,11 +26,10 @@ type 'a logging = ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a (* TODO: add {[@.]} later for all *) let dwarn ?(__POS__ : (string * int * int * int) option) f = - if !Js_config.debug_ir then + let output = Compiler_request_output.stderr_formatter () in + if !((Js_config.current ()).debug_ir) then match __POS__ with - | None -> Format.fprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.") + | None -> Format.fprintf output ("WARN: " ^^ f ^^ "@.") | Some (file, line, _, _) -> - Format.fprintf Format.err_formatter - ("WARN: %s,%d " ^^ f ^^ "@.") - file line - else Format.ifprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.") + Format.fprintf output ("WARN: %s,%d " ^^ f ^^ "@.") file line + else Format.ifprintf output ("WARN: " ^^ f ^^ "@.") diff --git a/compiler/common/js_config.ml b/compiler/common/js_config.ml index c53e101b433..486aeb23514 100644 --- a/compiler/common/js_config.ml +++ b/compiler/common/js_config.ml @@ -26,34 +26,72 @@ type jsx_version = Jsx_v4 type jsx_module = React | Generic of {module_name: string} type source_map = No_source_map | Linked | Inline | Hidden -let no_version_header = ref false +let tool_name = "ReScript" -let directives = ref [] -let cross_module_inline = ref false -let debug_ir = ref false -let check_lam = ref false +type t = { + no_version_header: bool ref; + directives: string list ref; + cross_module_inline: bool ref; + debug_ir: bool ref; + check_lam: bool ref; + no_builtin_ppx: bool ref; + check_div_by_zero: bool ref; + syntax_only: bool ref; + binary_ast: bool ref; + test_ast_conversion: bool ref; + debug: bool ref; + cmi_only: bool ref; + cmj_only: bool ref; + force_cmi: bool ref; + force_cmj: bool ref; + jsx_version: jsx_version option ref; + jsx_module: jsx_module ref; + js_stdout: bool ref; + source_map: source_map ref; + source_map_sources_content: bool ref; + source_map_root: string ref; + all_module_aliases: bool ref; + no_stdlib: bool ref; + no_export: bool ref; + as_pp: bool ref; + self_stack: string Stack.t; +} + +let create () = + { + no_version_header = ref false; + directives = ref []; + cross_module_inline = ref false; + debug_ir = ref false; + check_lam = ref false; + no_builtin_ppx = ref false; + check_div_by_zero = ref true; + syntax_only = ref false; + binary_ast = ref false; + test_ast_conversion = ref false; + debug = ref false; + cmi_only = ref false; + cmj_only = ref false; + force_cmi = ref false; + force_cmj = ref false; + jsx_version = ref None; + jsx_module = ref React; + js_stdout = ref true; + source_map = ref No_source_map; + source_map_sources_content = ref false; + source_map_root = ref ""; + all_module_aliases = ref false; + no_stdlib = ref false; + no_export = ref false; + as_pp = ref false; + self_stack = Stack.create (); + } + +(* Every option, including the stack used by the uncurry transform, belongs to + the request's domain. *) +let key = Request_local.new_key create +let current () = Domain.DLS.get key -let no_builtin_ppx = ref false -let tool_name = "ReScript" -let check_div_by_zero = ref true -let syntax_only = ref false -let binary_ast = ref false -let test_ast_conversion = ref false -let debug = ref false -let cmi_only = ref false -let cmj_only = ref false -let force_cmi = ref false -let force_cmj = ref false -let jsx_version = ref None -let jsx_module = ref React -let jsx_preserve = Clflags.jsx_preserve -let js_stdout = ref true -let source_map = ref No_source_map -let source_map_sources_content = ref false -let source_map_root = ref "" -let all_module_aliases = ref false -let no_stdlib = ref false -let no_export = ref false let int_of_jsx_version = function | Jsx_v4 -> 4 @@ -68,6 +106,3 @@ let jsx_version_of_int = function let jsx_module_of_string = function | "react" -> React | module_name -> Generic {module_name} - -let as_pp = ref false -let self_stack : string Stack.t = Stack.create () diff --git a/compiler/common/js_config.mli b/compiler/common/js_config.mli index 6510961705f..b98000c078a 100644 --- a/compiler/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -26,66 +26,43 @@ type jsx_version = Jsx_v4 type jsx_module = React | Generic of {module_name: string} type source_map = No_source_map | Linked | Inline | Hidden -val no_version_header : bool ref -(** set/get header *) - -val directives : string list ref -(** directives printed verbatims just after the version header *) - -val cross_module_inline : bool ref -(** cross module inline option *) - -val debug_ir : bool ref -(** dump intermediate representations and related diagnostics *) - -val check_lam : bool ref -(** check Lambda invariants after optimization passes *) - -val no_builtin_ppx : bool ref -(** options for builtin ppx *) - -val check_div_by_zero : bool ref -(** check-div-by-zero option *) +type t = { + no_version_header: bool ref; (** Suppress the version header. *) + directives: string list ref; + (** Directives printed verbatim just after the version header. *) + cross_module_inline: bool ref; (** Cross-module inlining option. *) + debug_ir: bool ref; + (** Dump intermediate representations and related diagnostics. *) + check_lam: bool ref; + (** Check Lambda invariants after optimization passes. *) + no_builtin_ppx: bool ref; + check_div_by_zero: bool ref; + syntax_only: bool ref; + binary_ast: bool ref; + test_ast_conversion: bool ref; + debug: bool ref; + cmi_only: bool ref; + cmj_only: bool ref; + force_cmi: bool ref; + force_cmj: bool ref; + jsx_version: jsx_version option ref; + jsx_module: jsx_module ref; + js_stdout: bool ref; + source_map: source_map ref; + source_map_sources_content: bool ref; + source_map_root: string ref; + all_module_aliases: bool ref; + no_stdlib: bool ref; + no_export: bool ref; + as_pp: bool ref; + self_stack: string Stack.t; +} + +val current : unit -> t +(* Mutable settings for the current domain's compiler request. *) val tool_name : string -val syntax_only : bool ref - -val binary_ast : bool ref - -val test_ast_conversion : bool ref - -val debug : bool ref - -val cmi_only : bool ref - -val cmj_only : bool ref - -(* stopped after generating cmj *) -val force_cmi : bool ref - -val force_cmj : bool ref - -val jsx_version : jsx_version option ref - -val jsx_module : jsx_module ref - -val jsx_preserve : bool ref - -val js_stdout : bool ref - -val source_map : source_map ref - -val source_map_sources_content : bool ref - -val source_map_root : string ref - -val all_module_aliases : bool ref - -val no_stdlib : bool ref - -val no_export : bool ref - val int_of_jsx_version : jsx_version -> int val string_of_jsx_module : jsx_module -> string @@ -93,7 +70,3 @@ val string_of_jsx_module : jsx_module -> string val jsx_version_of_int : int -> jsx_version option val jsx_module_of_string : string -> jsx_module - -val as_pp : bool ref - -val self_stack : string Stack.t diff --git a/compiler/core/bs_cmi_load.ml b/compiler/core/bs_cmi_load.ml index 0af28ea667d..4e1d5e56c8e 100644 --- a/compiler/core/bs_cmi_load.ml +++ b/compiler/core/bs_cmi_load.ml @@ -23,6 +23,33 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let load_cmi ~unit_name : Env.Persistent_signature.t option = - match Config_util.find_opt (unit_name ^ ".cmi") with - | Some filename -> Some {filename; cmi = Cmi_format.read_cmi filename} - | None -> None + (* 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))) + in + try_names (if lower_name = name then [name] else [lower_name; name]) + in + find (Config.get_load_path ()) diff --git a/compiler/core/bs_conditional_initial.ml b/compiler/core/bs_conditional_initial.ml index b90d96081df..800d5df6e18 100644 --- a/compiler/core/bs_conditional_initial.ml +++ b/compiler/core/bs_conditional_initial.ml @@ -31,13 +31,9 @@ let setup_env () = Matching.call_switcher_variant_constr := Polyvar_pattern_match.call_switcher_variant_constr; Ctype.variant_is_subtype := Matching_polyfill.variant_is_subtype; - Clflags.dump_location := false; + (* bsc's defaults, which differ from OCaml's in [Clflags.create]. *) + Clflags.reset (); Parmatch.print_res_pat := Pattern_printer.print_pattern; - (* default true - otherwise [bsc -I sc src/hello.ml ] will include current directory to search path - *) - Clflags.debug := true; - Clflags.binary_annotations := true; Printtyp.print_res_poly_identifier := Res_printer.polyvar_ident_to_string (*; Switch.cut := 100*) (* tweakable but not very useful *) diff --git a/compiler/core/cmd_ppx_apply.ml b/compiler/core/cmd_ppx_apply.ml index 111eae078d2..7e1d38e7e50 100644 --- a/compiler/core/cmd_ppx_apply.ml +++ b/compiler/core/cmd_ppx_apply.ml @@ -27,18 +27,17 @@ let write_ast fn (ast0 : Ml_binary.ast0) = let oc = open_out_bin fn in output_string oc (Ml_binary.magic_of_ast0 ast0); - output_value oc (!Location.input_name : string); + output_value oc (Location.get_input_name () : string); (match ast0 with | Ml_binary.Impl ast -> output_value oc (ast : Parsetree0.structure) | Ml_binary.Intf ast -> output_value oc (ast : Parsetree0.signature)); close_out oc let temp_ppx_file () = - Filename.temp_file "ppx" (Filename.basename !Location.input_name) + Filename.temp_file "ppx" (Filename.basename (Location.get_input_name ())) -let apply_rewriter kind fn_in ppx = +let apply_rewriter kind fn_in ppx fn_out = let magic = Ml_binary.magic_of_kind kind in - let fn_out = temp_ppx_file () in let comm = Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out) in @@ -51,8 +50,7 @@ let apply_rewriter kind fn_in ppx = try really_input_string ic (String.length magic) with End_of_file -> "" in close_in ic; - if buffer <> magic then Cmd_ast_exception.wrong_magic buffer; - fn_out + if buffer <> magic then Cmd_ast_exception.wrong_magic buffer (* This is a fatal error, no need to protect it *) let read_ast (type a) (kind : a Ml_binary.kind) fn : Ml_binary.ast0 = @@ -75,28 +73,33 @@ let read_ast (type a) (kind : a Ml_binary.kind) fn : Ml_binary.ast0 = are stored as [-ppx3; -ppx2; -ppx1] [fold_right] happens to process the first one *) let rewrite kind ppxs ast = - let fn_in = temp_ppx_file () in - let ast0 = Ml_binary.to_ast0 kind ast in - write_ast fn_in ast0; - let temp_files = - List.fold_right - (fun ppx fns -> - match fns with - | [] -> assert false - | fn_in :: _ -> apply_rewriter kind fn_in ppx :: fns) - ppxs [fn_in] + (* Remove the temporary files also when a PPX fails or the build is + interrupted, since the compiler can run inside a long-lived process. *) + let temp_files = ref [] in + let new_temp_file () = + let fn = temp_ppx_file () in + temp_files := fn :: !temp_files; + fn in - match temp_files with - | last_fn :: _ -> - let out = read_ast kind last_fn in - Ext_list.iter temp_files Misc.remove_file; - out - | _ -> assert false + Fun.protect + ~finally:(fun () -> Ext_list.iter !temp_files Misc.remove_file) + (fun () -> + let fn_in = new_temp_file () in + write_ast fn_in (Ml_binary.to_ast0 kind ast); + let last_fn = + List.fold_right + (fun ppx fn_in -> + let fn_out = new_temp_file () in + apply_rewriter kind fn_in ppx fn_out; + fn_out) + ppxs fn_in + in + read_ast kind last_fn) let apply_rewriters_str ?(restore = true) ~tool_name ast = - match !Clflags.all_ppx with + match !((Clflags.current ()).all_ppx) with | [] -> - if !Js_config.test_ast_conversion then + if !((Js_config.current ()).test_ast_conversion) then Ml_binary.ast0_roundtrip Ml_binary.Ml ast else ast | ppxs -> @@ -106,9 +109,9 @@ let apply_rewriters_str ?(restore = true) ~tool_name ast = |> Ast_mapper.drop_ppx_context_str ~restore let apply_rewriters_sig ?(restore = true) ~tool_name ast = - match !Clflags.all_ppx with + match !((Clflags.current ()).all_ppx) with | [] -> - if !Js_config.test_ast_conversion then + if !((Js_config.current ()).test_ast_conversion) then Ml_binary.ast0_roundtrip Ml_binary.Mli ast else ast | ppxs -> diff --git a/compiler/core/config_util.ml b/compiler/core/config_util.ml index e957cf9d181..0956eb243d7 100644 --- a/compiler/core/config_util.ml +++ b/compiler/core/config_util.ml @@ -28,20 +28,23 @@ let find_in_path_uncap path name = | [] -> None | dir :: rem -> let ufullname = Filename.concat dir uname in - if Sys.file_exists ufullname then Some ufullname + if Sys.file_exists (Compiler_request_state.resolve_path ufullname) then + Some ufullname else let fullname = Filename.concat dir name in - if Sys.file_exists fullname then Some fullname else try_dir rem + if Sys.file_exists (Compiler_request_state.resolve_path fullname) then + Some fullname + else try_dir rem in try_dir path -(* ATTENTION: lazy to wait [Config.load_path] populated *) -let find_opt file = find_in_path_uncap !Config.load_path file +(* ATTENTION: read the load path after request options have populated it. *) +let find_opt file = find_in_path_uncap (Config.get_load_path ()) file let output_prefix name = - match !Clflags.output_name with + match !((Clflags.current ()).output_name) with | None -> Ext_namespace_encode.make (Filename.remove_extension name) - ?ns:!Clflags.dont_record_crc_unit + ?ns:!((Clflags.current ()).dont_record_crc_unit) | Some oname -> Filename.remove_extension oname diff --git a/compiler/core/dune b/compiler/core/dune index 2765afc0713..030cfce6792 100644 --- a/compiler/core/dune +++ b/compiler/core/dune @@ -19,4 +19,4 @@ (wrapped false) (instrumentation (backend bisect_ppx)) - (libraries depends ext flow_parser frontend gentype yojson)) + (libraries depends ext flow_parser frontend gentype yojson unix)) diff --git a/compiler/core/ir_diagnostics.ml b/compiler/core/ir_diagnostics.ml index 2bcce68f0e9..5eb695b5e2e 100644 --- a/compiler/core/ir_diagnostics.ml +++ b/compiler/core/ir_diagnostics.ml @@ -13,11 +13,12 @@ let remove_stale_artifacts directory = let create ~output_prefix = let directory = output_prefix ^ ".debug-ir" in - if Sys.file_exists directory then ( - if not (Ext_sys.is_directory_no_exn directory) then + let physical_directory = Compiler_request_state.resolve_path directory in + if Sys.file_exists physical_directory then ( + if not (Ext_sys.is_directory_no_exn physical_directory) then failwith (Printf.sprintf "%s exists and is not a directory" directory); - remove_stale_artifacts directory) - else Sys.mkdir directory 0o755; + remove_stale_artifacts physical_directory) + else Sys.mkdir physical_directory 0o755; Ext_log.dwarn ~__POS__ "Writing IR diagnostics to %s" directory; {directory; next_index = 1} @@ -30,19 +31,19 @@ let next_path diagnostics ~kind ~pass ~extension = let dump_lam diagnostics ~pass lam = let path = next_path diagnostics ~kind:"lam" ~pass ~extension:".lam" in Ext_log.dwarn ~__POS__ "Dumping pass %s to %s" pass path; - Printlambda.serialize path lam + Printlambda.serialize (Compiler_request_state.resolve_path path) lam let dump_groups diagnostics groups = let path = next_path diagnostics ~kind:"lam" ~pass:"groups" ~extension:".lambda" in Ext_log.dwarn ~__POS__ "Dumping groups to %s" path; - Ext_fmt.with_file_as_pp path (fun fmt -> + Ext_fmt.with_file_as_pp (Compiler_request_state.resolve_path path) (fun fmt -> Format.pp_print_list ~pp_sep:Format.pp_print_newline Lam_group.pp_group fmt groups) let dump_js diagnostics ~pass program = let path = next_path diagnostics ~kind:"js" ~pass ~extension:".jsx" in Ext_log.dwarn ~__POS__ "Dumping JS pass %s to %s" pass path; - Ext_pervasives.with_file_as_chan path (fun channel -> - Js_dump_program.dump_program program channel) + Ext_pervasives.with_file_as_chan (Compiler_request_state.resolve_path path) + (fun channel -> Js_dump_program.dump_program program channel) diff --git a/compiler/core/js_analyzer.ml b/compiler/core/js_analyzer.ml index 96bd8645ee3..c653d49d4b1 100644 --- a/compiler/core/js_analyzer.ml +++ b/compiler/core/js_analyzer.ml @@ -76,23 +76,20 @@ let free_variables (stats : idents_stats) = | _ -> super.expression self exp); } -let init = {used_idents = Set_ident.empty; defined_idents = Set_ident.empty} - -let obj = free_variables init - -let clean_up init = - init.used_idents <- Set_ident.empty; - init.defined_idents <- Set_ident.empty +(* Each call gets its own accumulator: compiler requests run concurrently on + several domains, and a shared one would mix their identifiers. *) +let free_variables_with walk = + let stats = + {used_idents = Set_ident.empty; defined_idents = Set_ident.empty} + in + walk (free_variables stats); + Set_ident.diff stats.used_idents stats.defined_idents let free_variables_of_statement st = - clean_up init; - obj.statement obj st; - Set_ident.diff init.used_idents init.defined_idents + free_variables_with (fun obj -> obj.statement obj st) let free_variables_of_expression st = - clean_up init; - obj.expression obj st; - Set_ident.diff init.used_idents init.defined_idents + free_variables_with (fun obj -> obj.expression obj st) let is_array_function (e : J.expression) = match e.expression_desc with diff --git a/compiler/core/js_cmj_format.ml b/compiler/core/js_cmj_format.ml index 77c93014dba..636667e347d 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -83,15 +83,15 @@ let make ~(values : cmj_value Map_string.t) ~hoisted_exports ~effect_ (* Serialization .. *) let from_file name : t = - let ic = open_in_bin name in + 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 let for_sure_not_changed (name : string) (header : string) = - if Sys.file_exists name then ( - let ic = open_in_bin name in + if Sys.file_exists (Compiler_request_state.resolve_path name) then ( + let ic = open_in_bin (Compiler_request_state.resolve_path name) in let holder = really_input_string ic Ext_digest.length in close_in ic; holder = header) @@ -105,7 +105,7 @@ let to_file name ~check_exists (v : t) = let cur_digest = Digest.string s in let header = cur_digest in if not (check_exists && for_sure_not_changed name header) then ( - let oc = open_out_bin name in + let oc = open_out_bin (Compiler_request_state.resolve_path name) in output_string oc header; output_string oc s; close_out oc) @@ -123,7 +123,7 @@ let get_result mid_val = | None -> mid_val | Some _ -> - if !Js_config.cross_module_inline then mid_val + if !((Js_config.current ()).cross_module_inline) then mid_val else {mid_val with persistent_closed_lambda = None} let rec binary_search_aux arr lo hi (key : string) = diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index cc865c878c2..4cb360c338a 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -177,7 +177,7 @@ let jsx_printable ~tag ~spread ~props ~(children : J.expression list option) ~key ~multi ~fragment = (* Cross-module inlining can bring an element from a preserve-mode module into one compiled without preserve mode *) - !Js_config.jsx_preserve + !((Clflags.current ()).jsx_preserve) && (is_empty_fragment ~fragment ~spread ~props ~key || is_jsx_tag tag) && List.for_all (fun (name, _) -> @@ -925,7 +925,8 @@ and expression_desc cxt ~(level : int) f x : cxt = | false, 1 -> Js_op.Lit Literals.tl | _ -> Js_op.Lit ("_" ^ string_of_int i)), e )) - (if !Js_config.debug && not_is_cons then [(name_symbol, E.str p.name)] + (if !((Js_config.current ()).debug) && not_is_cons then + [(name_symbol, E.str p.name)] else []) in if not_is_cons = false then tails diff --git a/compiler/core/js_dump_program.ml b/compiler/core/js_dump_program.ml index 7710351610d..bbcbbfa070f 100644 --- a/compiler/core/js_dump_program.ml +++ b/compiler/core/js_dump_program.ml @@ -126,11 +126,11 @@ let esmodule_program ~output_dir fmt f (x : J.deps_program) = let pp_deps_program ~(output_prefix : string) (kind : Js_packages_info.module_system) (program : J.deps_program) (f : Ext_pp.t) = - !Js_config.directives + !((Js_config.current ()).directives) |> List.iter (fun prim -> P.string f prim; P.newline f); - if not !Js_config.no_version_header then ( + if not !((Js_config.current ()).no_version_header) then ( P.string f Bs_version.header; P.newline f); diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index 265adedb2bd..03c3f8670f5 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -21,29 +21,31 @@ let print_if_pipe ppf flag printer arg = let print_if ppf flag printer arg = if !flag then fprintf ppf "%a@." printer arg let process_with_gentype cmt_file = - if !Clflags.bs_gentype then Gentype_main.process_cmt_file cmt_file + if !((Clflags.current ()).bs_gentype) then + Gentype_main.process_cmt_file cmt_file let after_parsing_sig ppf outputprefix ast = - if !Clflags.only_parse = false then ( + if !((Clflags.current ()).only_parse) = false then ( Ast_config.process_sig ast; - (if !Js_config.binary_ast then - let sourcefile = !Location.input_name in + (if !((Js_config.current ()).binary_ast) then + let sourcefile = Location.get_input_name () in Binary_ast.write_ast Mli ~sourcefile ~output:(outputprefix ^ Literals.suffix_iast) (* to support relocate to another directory *) ast); - if !Js_config.as_pp then ( - output_string stdout Config.ast_intf_magic_number; - output_value stdout (!Location.input_name : string); - output_value stdout ast); - if !Js_config.syntax_only then Warnings.check_fatal () + if !((Js_config.current ()).as_pp) then ( + let output = Compiler_request_output.stdout_channel () in + output_string output Config.ast_intf_magic_number; + output_value output (Location.get_input_name () : string); + output_value output ast); + if !((Js_config.current ()).syntax_only) then Warnings.check_fatal () else let modulename = Ext_filename.module_name outputprefix in 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 - if !Clflags.dump_typedtree then + 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); @@ -52,7 +54,8 @@ let after_parsing_sig ppf outputprefix ast = let deprecated = Builtin_attributes.deprecated_of_sig ast in ignore (Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")); - Typemod.save_signature modulename tsg outputprefix !Location.input_name + Typemod.save_signature modulename tsg outputprefix + (Location.get_input_name ()) initial_env; process_with_gentype (outputprefix ^ ".cmti")) @@ -67,15 +70,15 @@ let interface ~parser ppf ?outputprefix fname = |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Mli |> Ppx_entry.rewrite_signature - |> print_if_pipe ppf Clflags.dump_parsetree Printast.interface - |> print_if_pipe ppf Clflags.dump_source Pprintast.signature + |> print_if_pipe ppf (Clflags.current ()).dump_parsetree Printast.interface + |> print_if_pipe ppf (Clflags.current ()).dump_source Pprintast.signature |> after_parsing_sig ppf outputprefix let interface_mliast ppf fname = Res_compmisc.init_path (); Binary_ast.read_ast_exn ~fname Mli - |> print_if_pipe ppf Clflags.dump_parsetree Printast.interface - |> print_if_pipe ppf Clflags.dump_source Pprintast.signature + |> print_if_pipe ppf (Clflags.current ()).dump_parsetree Printast.interface + |> print_if_pipe ppf (Clflags.current ()).dump_source Pprintast.signature |> after_parsing_sig ppf (Config_util.output_prefix fname) let all_module_alias (ast : Parsetree.structure) = @@ -102,21 +105,25 @@ let no_export (rest : Parsetree.structure) : Parsetree.structure = | _ -> rest let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = - if !Clflags.only_parse = false then ( - Js_config.all_module_aliases := - !Clflags.assume_no_mli = Mli_non_exists && all_module_alias ast; + if !((Clflags.current ()).only_parse) = false then ( + (Js_config.current ()).all_module_aliases := + !((Clflags.current ()).assume_no_mli) = Mli_non_exists + && all_module_alias ast; Ast_config.process_str ast; - let ast = if !Js_config.no_export then no_export ast else ast in - (if !Js_config.binary_ast then - let sourcefile = !Location.input_name in + let ast = + if !((Js_config.current ()).no_export) then no_export ast else ast + in + (if !((Js_config.current ()).binary_ast) then + let sourcefile = Location.get_input_name () in Binary_ast.write_ast ~sourcefile Ml ~output:(outputprefix ^ Literals.suffix_ast) ast); - if !Js_config.as_pp then ( - output_string stdout Config.ast_impl_magic_number; - output_value stdout (!Location.input_name : string); - output_value stdout ast); - if !Js_config.syntax_only then Warnings.check_fatal () + if !((Js_config.current ()).as_pp) then ( + let output = Compiler_request_output.stdout_channel () in + output_string output Config.ast_impl_magic_number; + output_value output (Location.get_input_name () : string); + output_value output ast); + if !((Js_config.current ()).syntax_only) then Warnings.check_fatal () else let modulename = Ext_filename.module_name outputprefix in Lam_compile_env.reset (); @@ -124,22 +131,25 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = Env.set_unit_name modulename; let typedtree, coercion, _, _ = Typemod.type_implementation_more - ?check_exists:(if !Js_config.force_cmi then None else Some ()) - !Location.input_name outputprefix modulename env ast + ?check_exists: + (if !((Js_config.current ()).force_cmi) then None else Some ()) + (Location.get_input_name ()) + outputprefix modulename env ast in let typedtree_coercion = (typedtree, coercion) in - print_if ppf Clflags.dump_typedtree + print_if ppf (Clflags.current ()).dump_typedtree Printtyped.implementation_with_coercion typedtree_coercion; - (if !Js_config.cmi_only then Warnings.check_fatal () + (if !((Js_config.current ()).cmi_only) then Warnings.check_fatal () else let {Translmod.lambda; exports; hoisted_functions} = Translmod.transl_implementation modulename typedtree_coercion in let js_program = - print_if_pipe ppf Clflags.dump_rawlambda Printlambda.lambda lambda + print_if_pipe ppf (Clflags.current ()).dump_rawlambda + Printlambda.lambda lambda |> Lam_compile_main.compile outputprefix exports hoisted_functions in - if not !Js_config.cmj_only then + if not !((Js_config.current ()).cmj_only) then Lam_compile_main.lambda_as_module js_program outputprefix); process_with_gentype (outputprefix ^ ".cmt")) @@ -154,15 +164,17 @@ let implementation ~parser ppf ?outputprefix fname = |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Ml |> Ppx_entry.rewrite_implementation - |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation - |> print_if_pipe ppf Clflags.dump_source Pprintast.structure + |> print_if_pipe ppf (Clflags.current ()).dump_parsetree + Printast.implementation + |> print_if_pipe ppf (Clflags.current ()).dump_source Pprintast.structure |> after_parsing_impl ppf outputprefix let implementation_mlast ppf fname = Res_compmisc.init_path (); Binary_ast.read_ast_exn ~fname Ml - |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation - |> print_if_pipe ppf Clflags.dump_source Pprintast.structure + |> print_if_pipe ppf (Clflags.current ()).dump_parsetree + Printast.implementation + |> print_if_pipe ppf (Clflags.current ()).dump_source Pprintast.structure |> after_parsing_impl ppf (Config_util.output_prefix fname) let make_structure_item ~ns cunit : Parsetree.structure_item = @@ -176,8 +188,8 @@ let make_structure_item ~ns cunit : Parsetree.structure_item = keep in sync with [gen_mlmap] in rewatch/src/build/namespaces.rs *) let implementation_map ppf sourcefile = - let () = Js_config.cmj_only := true in - let ichan = open_in_bin sourcefile in + let () = (Js_config.current ()).cmj_only := true in + let ichan = open_in_bin (Compiler_request_state.resolve_path sourcefile) in seek_in ichan (Ext_digest.length + 1); let list_of_modules = Ext_io.rev_lines_of_chann ichan in close_in ichan; @@ -189,6 +201,7 @@ let implementation_map ppf sourcefile = in Res_compmisc.init_path (); ml_ast - |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation - |> print_if_pipe ppf Clflags.dump_source Pprintast.structure + |> print_if_pipe ppf (Clflags.current ()).dump_parsetree + Printast.implementation + |> print_if_pipe ppf (Clflags.current ()).dump_source Pprintast.structure |> after_parsing_impl ppf (Config_util.output_prefix sourcefile) diff --git a/compiler/core/js_packages_state.ml b/compiler/core/js_packages_state.ml index 468b058c890..01c849c39b1 100644 --- a/compiler/core/js_packages_state.ml +++ b/compiler/core/js_packages_state.ml @@ -22,26 +22,40 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let packages_info = ref Js_packages_info.empty -let make_runtime = ref false +type state = { + mutable packages_info: Js_packages_info.t; + mutable making_runtime: bool; +} + +(* Package and output specifications belong to a compiler request. Keep the + record in this module because its type depends on Js_packages_info. *) +let fresh () = {packages_info = Js_packages_info.empty; making_runtime = false} + +let key = Request_local.new_key fresh +let current () = Domain.DLS.get key let set_package_name name = - if Js_packages_info.is_empty !packages_info then - packages_info := Js_packages_info.from_name name - else if not !make_runtime then + let state = current () in + if Js_packages_info.is_empty state.packages_info then + state.packages_info <- Js_packages_info.from_name name + else if not state.making_runtime then Bsc_args.bad_arg "duplicated flag for -bs-package-name" let make_runtime () : unit = - make_runtime := true; - packages_info := Js_packages_info.runtime_package_specs + let state = current () in + state.making_runtime <- true; + state.packages_info <- Js_packages_info.runtime_package_specs let set_package_map module_name = (* set_package_name name ; let module_name = Ext_namespace.namespace_of_package_name name in *) - Clflags.dont_record_crc_unit := Some module_name; - Clflags.open_modules := module_name :: !Clflags.open_modules + (Clflags.current ()).dont_record_crc_unit := Some module_name; + (Clflags.current ()).open_modules := + module_name :: !((Clflags.current ()).open_modules) let update_npm_package_path s = - packages_info := Js_packages_info.add_npm_package_path !packages_info s + let state = current () in + state.packages_info <- + Js_packages_info.add_npm_package_path state.packages_info s -let get_packages_info () = !packages_info +let get_packages_info () = (current ()).packages_info diff --git a/compiler/core/js_source_map.ml b/compiler/core/js_source_map.ml index e834d2c5dab..95595d5e2f9 100644 --- a/compiler/core/js_source_map.ml +++ b/compiler/core/js_source_map.ml @@ -50,15 +50,16 @@ type t = { (* A builder is installed only while source map output is active. When source maps are disabled, source_loc_of_loc returns None, so marker calls return before reading this state. *) -let current : t option ref = ref None +let current = Request_local.new_key (fun () -> ref None) let source_loc_of_loc (loc : Location.t) = - match !Js_config.source_map with + match !((Js_config.current ()).source_map) with | No_source_map -> None | Linked | Inline | Hidden -> if loc.loc_ghost || loc.loc_start.pos_cnum < 0 then None else Some loc let with_builder builder f = + let current = Domain.DLS.get current in let old = !current in current := Some builder; Ext_pervasives.finally () ~clean:(fun () -> current := old) f @@ -72,7 +73,8 @@ let normalize_slashes s = let absolute_path path = if path = "" then path - else if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path + else if Filename.is_relative path then + Filename.concat (Compiler_request_state.cwd ()) path else path let split_path path = @@ -127,7 +129,7 @@ let load_content filename = let add_source builder filename = let filename = match filename with - | "" | "_none_" -> !Location.input_name + | "" | "_none_" -> Location.get_input_name () | filename -> filename in let filename = absolute_path filename in @@ -200,7 +202,7 @@ let add_mapping builder ~generated_line ~generated_column (loc : Location.t) = let mark_source_loc fmt = function | None -> () | Some loc -> ( - match !current with + match !(Domain.DLS.get current) with | None -> () | Some builder -> let generated_line, generated_column = Ext_pp.position fmt in diff --git a/compiler/core/lam_beta_reduce_util.ml b/compiler/core/lam_beta_reduce_util.ml index c32959a0767..9cb8e6fe9a0 100644 --- a/compiler/core/lam_beta_reduce_util.ml +++ b/compiler/core/lam_beta_reduce_util.ml @@ -33,10 +33,8 @@ type value = {mutable used: bool; lambda: Lambda.t} -let param_hash : _ Hash_ident.t = Hash_ident.create 20 - (* Sequence the unused arguments before [body], in parameter order *) -let seq_unused params body = +let seq_unused param_hash params body = List.fold_right (fun param acc -> let {lambda; used} = Hash_ident.find param_hash param in @@ -58,6 +56,9 @@ let seq_unused params body = ]} *) let simple_beta_reduce params body args = + (* Substitutions and their [used] bits belong to this reduction: compiler + requests run concurrently on several domains. *) + let param_hash : value Hash_ident.t = Hash_ident.create 20 in let exception Not_simple_apply in let find_param_exn v opt = match Hash_ident.find_opt param_hash v with @@ -85,13 +86,11 @@ let simple_beta_reduce params body args = try let new_args = aux_exn [] ap_args in let result = - seq_unused params (Lambda.prim ~primitive ~args:new_args ap_loc) + seq_unused param_hash params + (Lambda.prim ~primitive ~args:new_args ap_loc) in - Hash_ident.clear param_hash; Some result - with Not_simple_apply -> - Hash_ident.clear param_hash; - None) + with Not_simple_apply -> None) | Lapply { ap_func = @@ -117,10 +116,9 @@ let simple_beta_reduce params body args = | Lvar fn_name -> find_param_exn fn_name f | _ -> f in - let result = seq_unused params (Lambda.apply f new_args ap_loc) in - Hash_ident.clear param_hash; + let result = + seq_unused param_hash params (Lambda.apply f new_args ap_loc) + in Some result - with Not_simple_apply -> - Hash_ident.clear param_hash; - None) + with Not_simple_apply -> None) | _ -> None diff --git a/compiler/core/lam_check.ml b/compiler/core/lam_check.ml index 490fc6854de..fabd75ee9a0 100644 --- a/compiler/core/lam_check.ml +++ b/compiler/core/lam_check.ml @@ -32,14 +32,16 @@ let check ~file ~pass lam = let success = ref true in let use (id : Ident.t) = if not @@ Hash_set_ident.mem defined_variables id then ( - Format.fprintf Format.err_formatter + Format.fprintf + (Compiler_request_output.stderr_formatter ()) "\n[SANITY after %s]:%s/%d used before defined in %s@." pass id.name id.stamp file; success := false) in let def (id : Ident.t) = if Hash_set_ident.mem defined_variables id then ( - Format.fprintf Format.err_formatter + Format.fprintf + (Compiler_request_output.stderr_formatter ()) "\n[SANITY after %s]:%s/%d bound twice in %s@." pass id.name id.stamp file; success := false) diff --git a/compiler/core/lam_compile_env.ml b/compiler/core/lam_compile_env.ml index 86c1acc3dea..a2ac9610401 100644 --- a/compiler/core/lam_compile_env.ml +++ b/compiler/core/lam_compile_env.ml @@ -40,20 +40,23 @@ type ident_info = Js_cmj_format.keyed_cmj_value = { [ find_in_path_uncap !load_path (name ^ ".cmi")] *) -(** It stores module => env_value mapping -*) -let cached_tbl : env_value Lam_module_ident.Hash.t = - Lam_module_ident.Hash.create 31 +(* Each compilation owns its module-to-env_value cache: reset in one domain + must not erase another domain's imports while it is still compiling. *) +let cached_tbl_key = + Request_local.new_key (fun () : env_value Lam_module_ident.Hash.t -> + Lam_module_ident.Hash.create 31) + +let cached_tbl () = Domain.DLS.get cached_tbl_key -let ( +> ) = Lam_module_ident.Hash.add cached_tbl +let ( +> ) id value = Lam_module_ident.Hash.add (cached_tbl ()) id value (* For each compilation we need reset to make it re-entrant *) let reset () = - Js_config.no_export := false; + (Js_config.current ()).no_export := false; (* This is needed in the playground since one no_export can make it true In the payground, it seems we need reset more states *) - Lam_module_ident.Hash.clear cached_tbl + Lam_module_ident.Hash.clear (cached_tbl ()) (** We should not provide "#moduleid" as output since when we print it in the end, it will @@ -78,7 +81,7 @@ let add_js_module ?import_attributes dynamic_import; } in - match Lam_module_ident.Hash.find_opt cached_tbl lam_module_ident with + match Lam_module_ident.Hash.find_opt (cached_tbl ()) lam_module_ident with | Some (External old_id) -> old_id | Some (Ml _) -> assert false | None -> @@ -87,7 +90,7 @@ let add_js_module ?import_attributes let cmj_table_of_module_id ~dynamic_import (module_id : Ident.t) = let oid = Lam_module_ident.of_ml ~dynamic_import module_id in - match Lam_module_ident.Hash.find_opt cached_tbl oid with + match Lam_module_ident.Hash.find_opt (cached_tbl ()) oid with | None -> let cmj_load_info = Js_cmj_load.load_unit module_id.name in oid +> Ml cmj_load_info; @@ -111,7 +114,7 @@ let find_hoisted_external_export ?(dynamic_import = false) (module_id : Ident.t) let get_package_path_from_cmj (id : Lam_module_ident.t) : string * Js_packages_info.t * Ext_js_file_kind.case = let cmj_load_info = - match Lam_module_ident.Hash.find_opt cached_tbl id with + match Lam_module_ident.Hash.find_opt (cached_tbl ()) id with | Some (Ml cmj_load_info) -> cmj_load_info | Some (External _) -> assert false (* called by {!Js_name_of_module_id.string_of_module_id} @@ -136,7 +139,7 @@ let is_pure_module (oid : Lam_module_ident.t) = | Runtime -> true | External _ -> false | Ml -> ( - match Lam_module_ident.Hash.find_opt cached_tbl oid with + match Lam_module_ident.Hash.find_opt (cached_tbl ()) oid with | None -> ( match Js_cmj_load.load_unit (Lam_module_ident.name oid) with | cmj_load_info -> @@ -150,7 +153,7 @@ let populate_required_modules extras (hard_dependencies : unit Lam_module_ident.Hash_set.t) = Lam_module_ident.Hash.iter (fun id _ -> if not (is_pure_module id) then add hard_dependencies id) - cached_tbl; + (cached_tbl ()); Lam_module_ident.Hash_set.iter (fun id () -> if not (is_pure_module id) then add hard_dependencies id) extras diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 1507bf8140c..cada1a101d8 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -255,7 +255,7 @@ let required_modules (lam : Lambda.t) : unit Lam_module_ident.Hash_set.t = required let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = - let debug_ir = !Js_config.debug_ir in + let debug_ir = !((Js_config.current ()).debug_ir) in let diagnostics = if debug_ir then Some (Ir_diagnostics.create ~output_prefix) else None in @@ -265,8 +265,8 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = Ir_diagnostics.dump_lam diagnostics ~pass lam; Ext_log.dwarn ~__POS__ "START CHECKING PASS %s@." pass | None -> ()); - if !Js_config.check_lam || debug_ir then ( - ignore @@ Lam_check.check ~file:!Location.input_name ~pass lam; + if !((Js_config.current ()).check_lam) || debug_ir then ( + ignore @@ Lam_check.check ~file:(Location.get_input_name ()) ~pass lam; if debug_ir then Ext_log.dwarn ~__POS__ "FINISH CHECKING PASS %s@." pass); lam in @@ -404,7 +404,7 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = |> Js_shake.shake_program |> j "shake" |> fun (program : J.program) -> let external_module_ids : Lam_module_ident.t list = - if !Js_config.all_module_aliases then [] + if !((Js_config.current ()).all_module_aliases) then [] else let hard_deps = Js_fold_basic.calculate_hard_dependencies program.block in Lam_compile_env.populate_required_modules may_required_modules hard_deps; @@ -429,8 +429,9 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = Lam_stats_export.export_to_cmj meta effect_ export_map hoisted_metadata (Ext_filename.case output_prefix) in - if not !Clflags.dont_write_files then - Js_cmj_format.to_file ~check_exists:(not !Js_config.force_cmj) + if not !((Clflags.current ()).dont_write_files) then + Js_cmj_format.to_file + ~check_exists:(not !((Js_config.current ()).force_cmj)) (output_prefix ^ Literals.suffix_cmj) v; {J.program; side_effect = effect_; modules = external_module_ids} @@ -438,20 +439,20 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = let ( // ) = Filename.concat let remove_stale_source_map ?(remove_stale_map = true) target_file = - if remove_stale_map && not !Clflags.dont_write_files then + if remove_stale_map && not !((Clflags.current ()).dont_write_files) then Misc.remove_file (target_file ^ ".map") let dump_deps_program_with_source_map ?(remove_stale_map = true) ~target_file ~output_prefix module_system lambda_output chan = let builder = Js_source_map.make ~generated_file:target_file - ~source_root:!Js_config.source_map_root - ~sources_content:!Js_config.source_map_sources_content + ~source_root:!((Js_config.current ()).source_map_root) + ~sources_content:!((Js_config.current ()).source_map_sources_content) in Js_source_map.with_builder builder (fun () -> Js_dump_program.pp_deps_program ~output_prefix module_system lambda_output (Ext_pp.from_channel ~track_positions:true chan)); - match !Js_config.source_map with + match !((Js_config.current ()).source_map) with | Linked -> let json = Js_source_map.json builder in output_string chan @@ -468,8 +469,11 @@ let dump_deps_program_with_source_map ?(remove_stale_map = true) ~target_file let lambda_as_module (lambda_output : J.deps_program) (output_prefix : string) : unit = let package_info = Js_packages_state.get_packages_info () in - if Js_packages_info.is_empty package_info && !Js_config.js_stdout then - match !Js_config.source_map with + if + Js_packages_info.is_empty package_info + && !((Js_config.current ()).js_stdout) + then + match !((Js_config.current ()).source_map) with | Inline -> let target_file = Ext_namespace.change_ext_ns_suffix @@ -477,10 +481,11 @@ let lambda_as_module (lambda_output : J.deps_program) (output_prefix : string) : Literals.suffix_js in dump_deps_program_with_source_map ~remove_stale_map:false ~target_file - ~output_prefix Commonjs lambda_output stdout + ~output_prefix Commonjs lambda_output + (Compiler_request_output.stdout_channel ()) | _ -> Js_dump_program.dump_deps_program ~output_prefix Commonjs lambda_output - stdout + (Compiler_request_output.stdout_channel ()) else Js_packages_info.iter package_info (fun {module_system; path; suffix} -> let basename = @@ -493,7 +498,7 @@ let lambda_as_module (lambda_output : J.deps_program) (output_prefix : string) : // basename (* #913 only generate little-case js file *) in let output_chan chan = - match !Js_config.source_map with + match !((Js_config.current ()).source_map) with | No_source_map -> Js_dump_program.dump_deps_program ~output_prefix module_system lambda_output chan; @@ -502,7 +507,7 @@ let lambda_as_module (lambda_output : J.deps_program) (output_prefix : string) : dump_deps_program_with_source_map ~target_file ~output_prefix module_system lambda_output chan in - if not !Clflags.dont_write_files then + if not !((Clflags.current ()).dont_write_files) then Ext_pervasives.with_file_as_chan target_file output_chan) (* We can use {!Env.current_unit = "Pervasives"} to tell if it is some specific module, diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 8a1c1189298..e75e62bc89e 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -39,8 +39,10 @@ let ensure_value_unit (st : Lam_compile_context.continuation) e : E.t = let get_module_system () = let package_info = Js_packages_state.get_packages_info () in let module_system = - if Js_packages_info.is_empty package_info && !Js_config.js_stdout then - [Ext_module_system.Commonjs] + if + Js_packages_info.is_empty package_info + && !((Js_config.current ()).js_stdout) + then [Ext_module_system.Commonjs] else Js_packages_info.map package_info (fun {module_system} -> module_system) in @@ -250,19 +252,23 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | _ -> assert false) | Pdivint -> ( match args with - | [e1; e2] -> E.int32_div ~checked:!Js_config.check_div_by_zero e1 e2 + | [e1; e2] -> + E.int32_div ~checked:!((Js_config.current ()).check_div_by_zero) e1 e2 | _ -> assert false) | Pdivbigint -> ( match args with - | [e1; e2] -> E.bigint_div ~checked:!Js_config.check_div_by_zero e1 e2 + | [e1; e2] -> + E.bigint_div ~checked:!((Js_config.current ()).check_div_by_zero) e1 e2 | _ -> assert false) | Pmodint -> ( match args with - | [e1; e2] -> E.int32_mod ~checked:!Js_config.check_div_by_zero e1 e2 + | [e1; e2] -> + E.int32_mod ~checked:!((Js_config.current ()).check_div_by_zero) e1 e2 | _ -> assert false) | Pmodbigint -> ( match args with - | [e1; e2] -> E.bigint_mod ~checked:!Js_config.check_div_by_zero e1 e2 + | [e1; e2] -> + E.bigint_mod ~checked:!((Js_config.current ()).check_div_by_zero) e1 e2 | _ -> assert false) | Ppowint -> ( match args with diff --git a/compiler/core/lam_stats_export.ml b/compiler/core/lam_stats_export.ml index 5ab2d6fde20..b47424a0235 100644 --- a/compiler/core/lam_stats_export.ml +++ b/compiler/core/lam_stats_export.ml @@ -59,7 +59,7 @@ let values_of_export (meta : Lam_stats.t) (export_map : Lambda.t Map_ident.t) : | None -> optlam | Some lambda -> - if not !Js_config.cross_module_inline then None + if not !((Js_config.current ()).cross_module_inline) then None else if Lam_analysis.safe_to_inline lambda (* when inlning a non function, we have to be very careful, diff --git a/compiler/core/res_compmisc.ml b/compiler/core/res_compmisc.ml index 804b3fc7cd9..7f117a2ad26 100644 --- a/compiler/core/res_compmisc.ml +++ b/compiler/core/res_compmisc.ml @@ -25,13 +25,13 @@ let init_path () = let stdlib_dir = let ( // ) = Filename.concat in - !Runtime_package.path // "lib" // "ocaml" + Runtime_package.get_path () // "lib" // "ocaml" in - let dirs = !Clflags.include_dirs in + let dirs = !((Clflags.current ()).include_dirs) in let exp_dirs = List.map (Misc.expand_directory stdlib_dir) dirs in - Config.load_path := - if !Js_config.no_stdlib then exp_dirs - else List.rev_append exp_dirs [stdlib_dir]; + Config.set_load_path + (if !((Js_config.current ()).no_stdlib) then exp_dirs + else List.rev_append exp_dirs [stdlib_dir]); Env.reset_cache () (* Return the initial environment in which compilation proceeds. *) @@ -49,13 +49,14 @@ let initial_env ?modulename () = Ident.reinit (); let open_modules = match modulename with - | None -> !Clflags.open_modules + | None -> !((Clflags.current ()).open_modules) | Some modulename -> - !Clflags.open_modules |> List.filter (fun m -> m <> modulename) + !((Clflags.current ()).open_modules) + |> List.filter (fun m -> m <> modulename) in - let initial = Env.initial_safe_string in + let initial = Env.initial_safe_string () in let env = - if !Clflags.nopervasives then initial + if !((Clflags.current ()).nopervasives) then initial else initial |> open_implicit_module "Pervasives" diff --git a/compiler/depends/ast_extract.ml b/compiler/depends/ast_extract.ml index 036ff98e386..ed64e85dc78 100644 --- a/compiler/depends/ast_extract.ml +++ b/compiler/depends/ast_extract.ml @@ -26,7 +26,7 @@ module Set_string = Depend.String_set -(* FIXME: [Clflags.open_modules] seems not to be properly used *) +(* FIXME: [(Clflags.current ()).open_modules] seems not to be properly used *) module S_map = Depend.String_map let bound_vars = S_map.empty @@ -34,13 +34,13 @@ let bound_vars = S_map.empty type 'a kind = 'a Ml_binary.kind let read_parse_and_extract (type t) (k : t kind) (ast : t) : Set_string.t = - Depend.free_structure_names := Set_string.empty; - Ext_ref.protect Clflags.transparent_modules false (fun _ -> + Depend.free_structure_names () := Set_string.empty; + Ext_ref.protect (Clflags.current ()).transparent_modules false (fun _ -> List.iter (* check *) (fun modname -> ignore @@ Depend.open_module bound_vars (Longident.Lident modname)) - !Clflags.open_modules; + !((Clflags.current ()).open_modules); (match k with | Ml_binary.Ml -> Depend.add_implementation bound_vars ast | Ml_binary.Mli -> Depend.add_signature bound_vars ast); - !Depend.free_structure_names) + !(Depend.free_structure_names ())) diff --git a/compiler/depends/binary_ast.ml b/compiler/depends/binary_ast.ml index 26be9af9af2..3dc27d2895d 100644 --- a/compiler/depends/binary_ast.ml +++ b/compiler/depends/binary_ast.ml @@ -29,7 +29,7 @@ type 'a kind = 'a Ml_binary.kind = | Mli : Parsetree.signature kind let read_ast_exn (type t) ~fname (_ : t kind) : t = - let ic = open_in_bin fname in + 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 @@ -56,7 +56,7 @@ let write_ast (type t) ~(sourcefile : string) ~output (kind : t kind) (pt : t) : (* filter *predef* *) Ext_buffer.add_string_char buf s magic_sep_char) output_set; - let oc = open_out_bin output in + 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; diff --git a/compiler/ext/bsc_args.ml b/compiler/ext/bsc_args.ml index af75700d08d..cbe4c826d70 100644 --- a/compiler/ext/bsc_args.ml +++ b/compiler/ext/bsc_args.ml @@ -37,6 +37,7 @@ type unit_action = type spec = Unit_dummy | Unit of unit_action | String of string_action exception Bad = Arg.Bad +exception Help of string let bad_arg s = raise_notrace (Bad s) @@ -83,8 +84,7 @@ let stop_raise ~usage ~(error : error) (speclist : t) = (match error with | Unknown ("-help" | "--help" | "-h") -> usage_b b ~usage speclist; - Ext_buffer.output_buffer stdout b; - exit 0 + raise_notrace (Help (Ext_buffer.contents b)) | Unknown s -> b +> "Unknown option \""; b +> s; diff --git a/compiler/ext/bsc_args.mli b/compiler/ext/bsc_args.mli index fb09acd479b..508b1d4020d 100644 --- a/compiler/ext/bsc_args.mli +++ b/compiler/ext/bsc_args.mli @@ -39,6 +39,7 @@ type spec = Unit_dummy | Unit of unit_action | String of string_action type t = (string * spec * string) array exception Bad of string +exception Help of string val bad_arg : string -> 'a diff --git a/compiler/ext/compiler_request_output.ml b/compiler/ext/compiler_request_output.ml new file mode 100644 index 00000000000..25d4aed615d --- /dev/null +++ b/compiler/ext/compiler_request_output.ml @@ -0,0 +1,98 @@ +type streams = { + stdout: out_channel; + stderr: out_channel; + stdout_formatter: Format.formatter; + stderr_formatter: Format.formatter; +} + +let key = Domain.DLS.new_key (fun () -> None) +let current () = Domain.DLS.get key +let is_active () = Option.is_some (current ()) + +let stdout_channel () = + match current () with + | Some streams -> streams.stdout + | None -> Stdlib.stdout + +let stderr_channel () = + match current () with + | Some streams -> streams.stderr + | None -> Stdlib.stderr + +let stdout_formatter () = + match current () with + | Some streams -> streams.stdout_formatter + | None -> Format.std_formatter + +let stderr_formatter () = + match current () with + | 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") + +exception Failed of {error: exn; stdout: string; stderr: string} + +(* Captured output is written in text mode, like a bsc process's stdout and + stderr, so on Windows it has the same CRLF line endings. It is read back + unchanged. *) +let with_capture action = + let stdout_path, stdout = + Filename.open_temp_file ~mode:[Open_text] "rescript-compiler-stdout-" ".log" + in + let stderr_path, stderr = + try + Filename.open_temp_file ~mode:[Open_text] "rescript-compiler-stderr-" + ".log" + with exn -> + close_out_noerr stdout; + Sys.remove stdout_path; + raise exn + in + let previous = current () in + let streams = + { + stdout; + stderr; + stdout_formatter = Format.formatter_of_out_channel stdout; + stderr_formatter = Format.formatter_of_out_channel stderr; + } + 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 + let finish () = + 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 + Fun.protect + (fun () -> + match action () with + | result -> + finish (); + (result, read stdout_path, read stderr_path) + | exception error -> + let backtrace = Printexc.get_raw_backtrace () in + finish (); + Printexc.raise_with_backtrace + (Failed {error; stdout = read stdout_path; stderr = read stderr_path}) + backtrace) + ~finally:(fun () -> + remove stdout_path; + remove stderr_path) diff --git a/compiler/ext/compiler_request_output.mli b/compiler/ext/compiler_request_output.mli new file mode 100644 index 00000000000..26c5f1c4d0f --- /dev/null +++ b/compiler/ext/compiler_request_output.mli @@ -0,0 +1,16 @@ +val stdout_channel : unit -> out_channel +val is_active : unit -> bool +val stderr_channel : unit -> out_channel +val stdout_formatter : unit -> Format.formatter +val stderr_formatter : unit -> Format.formatter +val write_stdout : string -> unit +val write_stderr : string -> unit +val print_stdout : string -> unit +val print_stderr : string -> unit + +exception Failed of {error: exn; stdout: string; stderr: string} +(** Raised by {!with_capture} when the action raises [error]; carries the + output written before it. *) + +val with_capture : (unit -> 'a) -> 'a * string * string +(** Capture one domain's compiler output and restore its previous streams. *) diff --git a/compiler/ext/compiler_request_state.ml b/compiler/ext/compiler_request_state.ml new file mode 100644 index 00000000000..fc1262980d0 --- /dev/null +++ b/compiler/ext/compiler_request_state.ml @@ -0,0 +1,61 @@ +type t = { + active: bool; + cwd: string; + mutable input_name: string; + mutable command_runner: string -> int; + mutable cmt_args: string array; + mutable lambda_raise_count: int; + mutable lambda_negative_raise_count: int; + mutable builtin_ppx_local_module_counter: int; + mutable parmatch_name_counter: int; + mutable substitution_saved_id: int; + mutable type_node_id: int; + mutable type_node_reset_id: int option; + mutable type_node_last_snapshot: int; + mutable runtime_path_override: string option; + mutable project_root: string option; + mutable load_path: string list; +} + +let create ~active cwd = + { + active; + cwd; + input_name = "_none_"; + command_runner = Sys.command; + cmt_args = Sys.argv; + lambda_raise_count = 0; + lambda_negative_raise_count = 0; + builtin_ppx_local_module_counter = 0; + parmatch_name_counter = 0; + substitution_saved_id = -1; + type_node_id = -1; + type_node_reset_id = None; + type_node_last_snapshot = 0; + runtime_path_override = None; + project_root = None; + load_path = []; + } + +let key = Domain.DLS.new_key (fun () -> create ~active:false (Sys.getcwd ())) +let current () = Domain.DLS.get key +let cwd () = + let state = current () in + if state.active then state.cwd else Sys.getcwd () + +let resolve_path path = + let state = current () in + if state.active && Filename.is_relative path then + Filename.concat state.cwd path + else path + +let with_fresh ?cwd:requested_cwd action = + let previous = current () in + let cwd = + match requested_cwd with + | None -> cwd () + | Some path when Filename.is_relative path -> Filename.concat (cwd ()) path + | Some path -> path + in + Domain.DLS.set key (create ~active:true cwd); + Fun.protect action ~finally:(fun () -> Domain.DLS.set key previous) diff --git a/compiler/ext/compiler_request_state.mli b/compiler/ext/compiler_request_state.mli new file mode 100644 index 00000000000..21500b76fc9 --- /dev/null +++ b/compiler/ext/compiler_request_state.mli @@ -0,0 +1,32 @@ +type t = { + active: bool; + cwd: string; + mutable input_name: string; + mutable command_runner: string -> int; + mutable cmt_args: string array; + mutable lambda_raise_count: int; + mutable lambda_negative_raise_count: int; + mutable builtin_ppx_local_module_counter: int; + mutable parmatch_name_counter: int; + mutable substitution_saved_id: int; + mutable type_node_id: int; + mutable type_node_reset_id: int option; + mutable type_node_last_snapshot: int; + mutable runtime_path_override: string option; + mutable project_root: string option; + mutable load_path: string list; +} +(** Mutable state owned by one compiler request on one domain. Add fields here + as process-global compiler state is moved behind request-aware accessors. *) + +val current : unit -> t + +val cwd : unit -> string +(** Logical working directory of this request, independent of [Sys.chdir]. *) + +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 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/config.ml b/compiler/ext/config.ml index 432d1e3b25a..ea65a69d406 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -15,4 +15,5 @@ and ast0_intf_magic_number = "Caml1999N022" and cmt_magic_number = "Caml1999T043" -let load_path = ref ([] : string list) +let get_load_path () = (Compiler_request_state.current ()).load_path +let set_load_path path = (Compiler_request_state.current ()).load_path <- path diff --git a/compiler/ext/config.mli b/compiler/ext/config.mli index 46c246d4f07..6aad5e25743 100644 --- a/compiler/ext/config.mli +++ b/compiler/ext/config.mli @@ -16,7 +16,8 @@ (* System configuration *) (* Directories in the search path for .cmi and .cmo files *) -val load_path : string list ref +val get_load_path : unit -> string list +val set_load_path : string list -> unit val cmi_magic_number : string (* Magic number for compiled interface files *) diff --git a/compiler/ext/ext_io.ml b/compiler/ext/ext_io.ml index 0ba82d5fc28..3387f256a0a 100644 --- a/compiler/ext/ext_io.ml +++ b/compiler/ext/ext_io.ml @@ -24,7 +24,10 @@ (** on 32 bit , there are 16M limitation *) let load_file f = - Ext_pervasives.finally (open_in_bin f) ~clean:close_in (fun ic -> + Ext_pervasives.finally + (open_in_bin (Compiler_request_state.resolve_path f)) + ~clean:close_in + (fun ic -> let n = in_channel_length ic in let s = Bytes.create n in really_input ic s 0 n; @@ -41,5 +44,6 @@ let rev_lines_of_chann chan = loop [] chan let write_file f content = - Ext_pervasives.finally ~clean:close_out (open_out_bin f) (fun oc -> - output_string oc content) + Ext_pervasives.finally ~clean:close_out + (open_out_bin (Compiler_request_state.resolve_path f)) + (fun oc -> output_string oc content) diff --git a/compiler/ext/ext_path.ml b/compiler/ext/ext_path.ml index 0e86cc0fb1b..b7790dddd41 100644 --- a/compiler/ext/ext_path.ml +++ b/compiler/ext/ext_path.ml @@ -27,8 +27,6 @@ type t = | Dir of string [@@unboxed] -let cwd = lazy (Sys.getcwd ()) - let split_by_sep_per_os : string -> string list = if Ext_sys.is_windows_or_cygwin then fun x -> (* on Windows, we can still accept -bs-package-output lib/js *) @@ -102,7 +100,7 @@ let absolute_path cwd s = in process s -let absolute_cwd_path s = absolute_path cwd s +let absolute_cwd_path s = absolute_path (lazy (Compiler_request_state.cwd ())) s (* let absolute cwd s = match s with @@ -112,10 +110,13 @@ let absolute_cwd_path s = absolute_path cwd s (** Populated by [-bs-project-root]. The build system (rewatch) or [cli/bsc.js] is responsible for supplying it; the compiler no longer reads [rescript.json] itself. *) -let project_root : string option ref = ref None +let get_project_root () = (Compiler_request_state.current ()).project_root + +let set_project_root root = + (Compiler_request_state.current ()).project_root <- Some root let package_dir () = - match !project_root with + match get_project_root () with | Some dir -> dir | None -> Ext_fmt.failwithf ~loc:__LOC__ diff --git a/compiler/ext/ext_path.mli b/compiler/ext/ext_path.mli index aa8b261c67d..de402870e68 100644 --- a/compiler/ext/ext_path.mli +++ b/compiler/ext/ext_path.mli @@ -29,9 +29,12 @@ val node_rebase_file : from:string -> to_:string -> string -> string val absolute_cwd_path : string -> string -val project_root : string option ref -(** Populated by [-bs-project-root]. Must be set before [package_dir ()] - is called; the compiler does not locate [rescript.json] on its own. *) +val get_project_root : unit -> string option + +val set_project_root : string -> unit +(** Populated by [-bs-project-root] for the current compiler request. Must be + set before [package_dir ()] is called; the compiler does not locate + [rescript.json] on its own. *) val package_dir : unit -> string (** Returns the package root directory. Fails if [project_root] is unset. *) diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml index 27eafa62bab..9944627a533 100644 --- a/compiler/ext/ident.ml +++ b/compiler/ext/ident.ml @@ -23,21 +23,46 @@ let predef_exn_flag = 2 (* A stamp of 0 denotes a persistent identifier *) -let currentstamp = ref 0 +type counter_state = {mutable currentstamp: int; mutable reinit_level: int} + +let counter_key = + Domain.DLS.new_key (fun () -> {currentstamp = 0; reinit_level = -1}) + +let counter () = Domain.DLS.get counter_key + +(* Captured after the compiler's predefined identifiers and static module + values have been initialized. Requests may reuse stamps only within their + isolated environments. *) +let request_baseline = Atomic.make None +let capture_request_baseline () = + Atomic.set request_baseline (Some (counter ()).currentstamp) + +let with_fresh action = + let previous = counter () in + let baseline = + match Atomic.get request_baseline with + | Some baseline -> baseline + | None -> previous.currentstamp + in + Domain.DLS.set counter_key {currentstamp = baseline; reinit_level = baseline}; + Fun.protect action ~finally:(fun () -> Domain.DLS.set counter_key previous) let create s = - incr currentstamp; - {name = s; stamp = !currentstamp; flags = 0} + let state = counter () in + state.currentstamp <- state.currentstamp + 1; + {name = s; stamp = state.currentstamp; flags = 0} let create_predef_exn s = - incr currentstamp; - {name = s; stamp = !currentstamp; flags = predef_exn_flag} + let state = counter () in + state.currentstamp <- state.currentstamp + 1; + {name = s; stamp = state.currentstamp; flags = predef_exn_flag} let create_persistent s = {name = s; stamp = 0; flags = global_flag} let rename i = - incr currentstamp; - {i with stamp = !currentstamp} + let state = counter () in + state.currentstamp <- state.currentstamp + 1; + {i with stamp = state.currentstamp} let name i = i.name @@ -52,14 +77,15 @@ let same ({stamp; name} : t) i2 = let binding_time i = i.stamp -let current_time () = !currentstamp -let set_current_time t = currentstamp := max !currentstamp t - -let reinit_level = ref (-1) +let current_time () = (counter ()).currentstamp +let set_current_time t = + let state = counter () in + state.currentstamp <- max state.currentstamp t let reinit () = - if !reinit_level < 0 then reinit_level := !currentstamp - else currentstamp := !reinit_level + let state = counter () in + if state.reinit_level < 0 then state.reinit_level <- state.currentstamp + else state.currentstamp <- state.reinit_level let hide i = {i with stamp = -1} diff --git a/compiler/ext/ident.mli b/compiler/ext/ident.mli index c13be140f2d..f374f7a232c 100644 --- a/compiler/ext/ident.mli +++ b/compiler/ext/ident.mli @@ -52,6 +52,13 @@ val current_time : unit -> int val set_current_time : int -> unit val reinit : unit -> unit +val capture_request_baseline : unit -> unit +(* Call once after predefined identifiers are initialized, before compiler + requests can overlap. *) + +val with_fresh : (unit -> 'a) -> 'a +(* Give one request its own stamp counter and restore the prior counter. *) + type 'a tbl (* Association tables from identifiers to type 'a. *) diff --git a/compiler/ext/misc.ml b/compiler/ext/misc.ml index 572fd07899b..fd1e1591da2 100644 --- a/compiler/ext/misc.ml +++ b/compiler/ext/misc.ml @@ -18,8 +18,7 @@ exception Fatal_error let fatal_error msg = - prerr_string ">> Fatal error: "; - prerr_endline msg; + Compiler_request_output.print_stderr (">> Fatal error: " ^ msg); raise Fatal_error let try_finally work cleanup = @@ -69,13 +68,16 @@ let find_in_path_uncap path name = | dir :: rem -> let fullname = Filename.concat dir name and ufullname = Filename.concat dir uname in - if Sys.file_exists ufullname then ufullname - else if Sys.file_exists fullname then fullname + if Sys.file_exists (Compiler_request_state.resolve_path ufullname) then + ufullname + else if Sys.file_exists (Compiler_request_state.resolve_path fullname) + then fullname else try_dir rem in try_dir path let remove_file filename = + let filename = Compiler_request_state.resolve_path filename in try if Sys.file_exists filename then Sys.remove filename with Sys_error _msg -> () @@ -98,6 +100,7 @@ let create_hashtable init = (* File copy *) let output_to_bin_file_directly filename fn = + let filename = Compiler_request_state.resolve_path filename in let oc = open_out_bin filename in match fn filename oc with | v -> @@ -274,19 +277,20 @@ module Color = struct | Format.String_tag "filename" -> [FG Cyan] | _ -> raise Not_found - let color_enabled = ref true + let color_key = Request_local.new_key (fun () -> ref true) + let color_enabled () = Domain.DLS.get color_key (* either prints the tag of [s] or delegates to [or_else] *) let mark_open_tag ~or_else s = try let style = style_of_tag s in - if !color_enabled then ansi_of_style_l style else "" + if !(color_enabled ()) then ansi_of_style_l style else "" with Not_found -> or_else s let mark_close_tag ~or_else s = try let _ = style_of_tag s in - if !color_enabled then ansi_of_style_l [Reset] else "" + if !(color_enabled ()) then ansi_of_style_l [Reset] else "" with Not_found -> or_else s (* add color handling to formatter [ppf] *) @@ -316,24 +320,20 @@ module Color = struct type setting = Auto | Always | Never - let setup = - let first = ref true in - (* initialize only once *) - let formatter_l = + (* Install shared formatter hooks during module initialization. Their tag + callbacks read the calling domain's color setting. *) + let () = + Format.set_mark_tags true; + List.iter set_color_tag_handling [Format.std_formatter; Format.err_formatter; Format.str_formatter] - in - fun o -> - if !first then ( - first := false; - Format.set_mark_tags true; - List.iter set_color_tag_handling formatter_l; - color_enabled := - match o with - | Some Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()); - () + + let setup option = + color_enabled () := + match option with + | Some Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color () end let normalise_eol s = diff --git a/compiler/ext/request_local.ml b/compiler/ext/request_local.ml new file mode 100644 index 00000000000..f20ec1adbf0 --- /dev/null +++ b/compiler/ext/request_local.ml @@ -0,0 +1,31 @@ +type 'a key = 'a Domain.DLS.key + +(* Installs a fresh value for one key and returns how to restore the previous + one. Keys are registered while modules initialize, so worker domains only + ever read this list. *) +type entry = unit -> unit -> unit + +let entries : entry list Atomic.t = Atomic.make [] + +let rec register entry = + let current = Atomic.get entries in + if not (Atomic.compare_and_set entries current (entry :: current)) then + register entry + +let new_key init = + let key = Domain.DLS.new_key init in + register (fun () -> + let previous = Domain.DLS.get key in + Domain.DLS.set key (init ()); + fun () -> Domain.DLS.set key previous); + key + +let get = Domain.DLS.get +let set = Domain.DLS.set + +let with_fresh action = + (* Initialize in registration order, which is module initialization order, + so every request allocates its fresh state the same way. *) + let restores = List.rev_map (fun fresh -> fresh ()) (Atomic.get entries) in + Fun.protect action ~finally:(fun () -> + List.iter (fun restore -> restore ()) restores) diff --git a/compiler/ext/request_local.mli b/compiler/ext/request_local.mli new file mode 100644 index 00000000000..633fb848aa0 --- /dev/null +++ b/compiler/ext/request_local.mli @@ -0,0 +1,19 @@ +(** State that belongs to one compiler request. + + A key behaves like a [Domain.DLS] key, and {!with_fresh} gives every key a + new value from its initializer for the duration of a request. A request + therefore starts from the same state as a new compiler process, and no key + can be forgotten when requests run one after another on a domain. *) + +type 'a key = 'a Domain.DLS.key + +val new_key : (unit -> 'a) -> 'a key +(** Create a key during module initialization, before any worker domain + starts. *) + +val get : 'a key -> 'a +val set : 'a key -> 'a -> unit + +val with_fresh : (unit -> 'a) -> 'a +(** Run with a fresh value for every key and restore the previous values + afterwards, also when the action raises, so requests can nest. *) diff --git a/compiler/ext/runtime_package.ml b/compiler/ext/runtime_package.ml index 34d4afd0bdb..9f04f336283 100644 --- a/compiler/ext/runtime_package.ml +++ b/compiler/ext/runtime_package.ml @@ -26,4 +26,10 @@ let default_path = (* To support pnpm and other package managers/layouts, we determine the path on the JS side and pass it in via -runtime-path to override the default. *) -let path = ref default_path +let get_path () = + match (Compiler_request_state.current ()).runtime_path_override with + | Some path -> path + | None -> default_path + +let set_path path = + (Compiler_request_state.current ()).runtime_path_override <- Some path diff --git a/compiler/ext/runtime_package.mli b/compiler/ext/runtime_package.mli index cf7cc9f4d74..87d33325c6b 100644 --- a/compiler/ext/runtime_package.mli +++ b/compiler/ext/runtime_package.mli @@ -1,2 +1,6 @@ val name : string -val path : string ref +val get_path : unit -> string + +val set_path : string -> unit +(** Runtime path configuration belongs to the current compiler request. The + immutable executable-derived default is used when no override is set. *) diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 3bb428d2683..cef394251de 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -168,25 +168,6 @@ let letter = function type state = {active: bool array; error: bool array} -let current = - ref - { - active = Array.make (last_warning_number + 1) true; - error = Array.make (last_warning_number + 1) false; - } - -let disabled = ref false - -let without_warnings f = Misc.protect_refs [Misc.R (disabled, true)] f - -let backup () = !current - -let restore x = current := x - -let is_active x = (not !disabled) && !current.active.(number x) - -let is_error x = (not !disabled) && !current.error.(number x) - let parse_opt error active flags s = let set i = flags.(i) <- true in let clear i = flags.(i) <- false in @@ -245,18 +226,46 @@ let parse_opt error active flags s = in loop 0 +type request_state = {current: state ref; disabled: bool ref; nerrors: int ref} + +let default_state = + let active = Array.make (last_warning_number + 1) true in + let error = Array.make (last_warning_number + 1) false in + parse_opt error active active Bsc_warnings.defaults_w; + parse_opt error active error Bsc_warnings.defaults_warn_error; + {active; error} + +let fresh_state () = + {current = ref default_state; disabled = ref false; nerrors = ref 0} + +(* A compiler request can overlap another request on a different domain. *) +let key = Request_local.new_key fresh_state +let request_state () = Domain.DLS.get key + +let without_warnings f = + Misc.protect_refs [Misc.R ((request_state ()).disabled, true)] f + +let backup () = !((request_state ()).current) +let restore x = (request_state ()).current := x +let is_active x = + let state = request_state () in + (not !(state.disabled)) && !(state.current).active.(number x) + +let is_error x = + let state = request_state () in + (not !(state.disabled)) && !(state.current).error.(number x) + let parse_options errflag s = - let error = Array.copy !current.error in - let active = Array.copy !current.active in + let state = backup () in + let error = Array.copy state.error in + let active = Array.copy state.active in parse_opt error active (if errflag then error else active) s; - current := {error; active} + restore {error; active} let reset () = parse_options false Bsc_warnings.defaults_w; parse_options true Bsc_warnings.defaults_warn_error -let () = reset () - let message = function | Deprecated (s, _, _, can_be_automigrated) -> (* Reduce \r\n to \n: @@ -460,7 +469,7 @@ let sub_locs = function [(def, "Definition"); (use, "Expected signature")] | _ -> [] -let nerrors = ref 0 +let nerrors () = !((request_state ()).nerrors) type reporting_information = { number: int; @@ -473,7 +482,7 @@ let report w = match is_active w with | false -> `Inactive | true -> - if is_error w then incr nerrors; + if is_error w then incr (request_state ()).nerrors; `Active { number = number w; @@ -484,11 +493,11 @@ let report w = exception Errors -let reset_fatal () = nerrors := 0 +let reset_fatal () = (request_state ()).nerrors := 0 let check_fatal () = - if !nerrors > 0 then ( - nerrors := 0; + if nerrors () > 0 then ( + reset_fatal (); raise Errors) let descriptions = @@ -555,19 +564,20 @@ let descriptions = ] let help_warnings () = - List.iter (fun (i, s) -> Printf.printf "%3i %s\n" i s) descriptions; - print_endline " A all warnings"; + let output = Compiler_request_output.stdout_formatter () in + List.iter (fun (i, s) -> Format.fprintf output "%3i %s@." i s) descriptions; + Format.fprintf output " A all warnings@."; for i = Char.code 'b' to Char.code 'z' do let c = Char.chr i in match letter c with | [] -> () | [n] -> - Printf.printf " %c Alias for warning %i.\n" (Char.uppercase_ascii c) n + Format.fprintf output " %c Alias for warning %i.@." + (Char.uppercase_ascii c) n | l -> - Printf.printf " %c warnings %s.\n" (Char.uppercase_ascii c) + Format.fprintf output " %c warnings %s.@." (Char.uppercase_ascii c) (String.concat ", " (List.map string_of_int l)) - done; - exit 0 + done let loc_to_string (loc : loc) : string = Format.sprintf "(%02d,%02d--%02d,%02d)" loc.loc_start.pos_lnum diff --git a/compiler/frontend/ast_config.ml b/compiler/frontend/ast_config.ml index b697ab5121f..9e1c7fd86d6 100644 --- a/compiler/frontend/ast_config.ml +++ b/compiler/frontend/ast_config.ml @@ -27,7 +27,7 @@ type action_table = (Parsetree.expression option -> unit) Map_string.t let structural_config_table : action_table ref = ref (Map_string.singleton "no_export" (fun x -> - Js_config.no_export := + (Js_config.current ()).no_export := match x with | Some e -> Ast_payload.assert_bool_lit e | None -> true)) @@ -41,7 +41,7 @@ let add_signature k v = signature_config_table := Map_string.add k v !signature_config_table let process_directives str = - Js_config.directives := []; + (Js_config.current ()).directives := []; (* Reset: multiple calls possible e.g. with bsc from the command-line *) str |> List.iter (fun (item : Parsetree.structure_item) -> @@ -49,7 +49,9 @@ let process_directives str = | Pstr_attribute ({txt = "directive"}, payload) -> ( Ast_payload.reject_json_literal_payload payload; match Ast_payload.semantic_string_of_payload payload with - | Some d -> Js_config.directives := !Js_config.directives @ [d] + | Some d -> + (Js_config.current ()).directives := + !((Js_config.current ()).directives) @ [d] | None -> Bs_syntaxerr.err item.pstr_loc Expect_string_literal) | _ -> ()) diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index 6779a3926a8..6717e5f332e 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -219,7 +219,7 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string) let bundle = "./" ^ Ext_filename.new_extension - (Filename.basename !Location.input_name) + (Filename.basename (Location.get_input_name ())) ".gen" in ( attr :: attrs, diff --git a/compiler/frontend/ast_uncurry_gen.ml b/compiler/frontend/ast_uncurry_gen.ml index f5fc2a4c40c..ade2b66ece3 100644 --- a/compiler/frontend/ast_uncurry_gen.ml +++ b/compiler/frontend/ast_uncurry_gen.ml @@ -33,7 +33,7 @@ let to_method_callback ~async ~newtypes loc (self : Ast_mapper.mapper) let self_pat = self.pat self self_pat in (match Ast_pat.is_single_variable_pattern_conservative self_pat with | None -> Bs_syntaxerr.err self_pat.ppat_loc Bs_this_simple_pattern - | Some self -> Stack.push self Js_config.self_stack); + | Some self -> Stack.push self (Js_config.current ()).self_stack); Bs_syntaxerr.optional_err loc label; let rest = Ext_list.map rest (fun (p : Parsetree.fun_param) -> @@ -56,7 +56,7 @@ let to_method_callback ~async ~newtypes loc (self : Ast_mapper.mapper) (Ast_helper.Exp.fun_ ~loc ~async ~newtypes mapped_params result) in let arity_s = string_of_int arity in - Stack.pop Js_config.self_stack |> ignore; + Stack.pop (Js_config.current ()).self_stack |> ignore; Parsetree.Pexp_apply { funct = diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml index 21af6c88990..3be882781d2 100644 --- a/compiler/frontend/bs_builtin_ppx.ml +++ b/compiler/frontend/bs_builtin_ppx.ml @@ -690,11 +690,30 @@ let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) : (Ast_tuple_pattern_flatten.value_bindings_mapper self vbs) | _ -> default_mapper.structure_item self str -let local_module_name = - let v = ref 0 in - fun () -> - incr v; - "local_" ^ string_of_int !v +type mapper_context = { + async_context: bool ref; + in_function_def: bool ref; + await_context: (string, string) Hashtbl.t ref; +} + +(* The mapper itself is shared by compiler requests, but its traversal state + belongs to the domain running a request. In particular, another domain's + function body must not change whether an await is accepted here. *) +let mapper_context_key = + Request_local.new_key (fun () -> + { + async_context = ref true; + in_function_def = ref false; + await_context = ref (Hashtbl.create 10); + }) + +let mapper_context () = Domain.DLS.get mapper_context_key + +let local_module_name () = + let state = Compiler_request_state.current () in + state.builtin_ppx_local_module_counter <- + state.builtin_ppx_local_module_counter + 1; + "local_" ^ string_of_int state.builtin_ppx_local_module_counter let expand_reverse (stru : Ast_structure.t) (acc : Ast_structure.t) : Ast_structure.t = @@ -859,12 +878,19 @@ let mapper : mapper = { default_mapper with module_expr = module_expr_mapper; - expr = expr_mapper ~async_context:(ref true) ~in_function_def:(ref false); + expr = + (fun self expression -> + let context = mapper_context () in + expr_mapper ~async_context:context.async_context + ~in_function_def:context.in_function_def self expression); pat = pat_mapper; typ = typ_mapper; signature_item = signature_item_mapper; structure_item = structure_item_mapper; - structure = structure_mapper ~await_context:(ref (Hashtbl.create 10)); + structure = + (fun self structure -> + let context = mapper_context () in + structure_mapper ~await_context:context.await_context self structure); (* Ad-hoc way to internalize stuff *) label_declaration = (fun self lbl -> diff --git a/compiler/frontend/ppx_entry.ml b/compiler/frontend/ppx_entry.ml index 701203f1b18..71b74ed474b 100644 --- a/compiler/frontend/ppx_entry.ml +++ b/compiler/frontend/ppx_entry.ml @@ -50,15 +50,15 @@ let rewrite_signature (ast : Parsetree.signature) : Parsetree.signature = Bs_ast_invariant.iter_warnings_on_sigi ast; Ast_config.process_sig ast; let ast = - match !Js_config.jsx_version with + match !((Js_config.current ()).jsx_version) with | None -> ast | Some jsx_version_ -> let open Js_config in let jsx_version = int_of_jsx_version jsx_version_ in - let jsx_module = string_of_jsx_module !jsx_module in + let jsx_module = string_of_jsx_module !((current ()).jsx_module) in Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module ast in - if !Js_config.no_builtin_ppx then ast + if !((Js_config.current ()).no_builtin_ppx) then ast else let result = unsafe_mapper.signature unsafe_mapper ast in unconsumed_json_iterator.signature unconsumed_json_iterator result; @@ -70,15 +70,15 @@ let rewrite_implementation (ast : Parsetree.structure) : Parsetree.structure = Bs_ast_invariant.iter_warnings_on_stru ast; Ast_config.process_str ast; let ast = - match !Js_config.jsx_version with + match !((Js_config.current ()).jsx_version) with | None -> ast | Some jsx_version_ -> let open Js_config in let jsx_version = int_of_jsx_version jsx_version_ in - let jsx_module = string_of_jsx_module !jsx_module in + let jsx_module = string_of_jsx_module !((current ()).jsx_module) in Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module ast in - if !Js_config.no_builtin_ppx then ast + if !((Js_config.current ()).no_builtin_ppx) then ast else let result = unsafe_mapper.structure unsafe_mapper ast in unconsumed_json_iterator.structure unconsumed_json_iterator result; diff --git a/compiler/gentype/converter.ml b/compiler/gentype/converter.ml index e70fd321678..297f23b974b 100644 --- a/compiler/gentype/converter.ml +++ b/compiler/gentype/converter.ml @@ -83,7 +83,7 @@ let type_get_inlined ~config ~lookup_id ~type_name_is_interface type0 = {a_name; a_type = t_normalized} in let normalized = type0 |> visit ~visited:String_set.empty in - if !Debug.converter then + if !(Debug.converter ()) then Log_.item "type0:%s \n" (type0 |> Emit_type.type_to_string ~config ~type_name_is_interface); normalized diff --git a/compiler/gentype/debug.ml b/compiler/gentype/debug.ml index ce89e792dba..a902f2e671b 100644 --- a/compiler/gentype/debug.ml +++ b/compiler/gentype/debug.ml @@ -1,37 +1,50 @@ -let basic = ref false -let code_items = ref false -let config = ref false -let converter = ref false -let dependencies = ref false -let module_resolution = ref false -let not_implemented = ref false -let translation = ref false -let type_env = ref false -let type_resolution = ref false +(* GenType debug output belongs to the compiler request that enabled it. *) +let new_flag () = Request_local.new_key (fun () -> ref false) + +let basic_key = new_flag () +let basic () = Domain.DLS.get basic_key +let code_items_key = new_flag () +let code_items () = Domain.DLS.get code_items_key +let config_key = new_flag () +let config () = Domain.DLS.get config_key +let converter_key = new_flag () +let converter () = Domain.DLS.get converter_key +let dependencies_key = new_flag () +let dependencies () = Domain.DLS.get dependencies_key +let module_resolution_key = new_flag () +let module_resolution () = Domain.DLS.get module_resolution_key +let not_implemented_key = new_flag () +let not_implemented () = Domain.DLS.get not_implemented_key +let translation_key = new_flag () +let translation () = Domain.DLS.get translation_key +let type_env_key = new_flag () +let type_env () = Domain.DLS.get type_env_key +let type_resolution_key = new_flag () +let type_resolution () = Domain.DLS.get type_resolution_key let set_all () = - basic := true; - code_items := true; - config := true; - converter := true; - dependencies := true; - module_resolution := true; - not_implemented := true; - translation := true; - type_env := true; - type_resolution := true + basic () := true; + code_items () := true; + config () := true; + converter () := true; + dependencies () := true; + module_resolution () := true; + not_implemented () := true; + translation () := true; + type_env () := true; + type_resolution () := true let set_item debug_item = match debug_item with | "all" -> set_all () - | "basic" -> basic := true - | "codeItems" -> code_items := true - | "config" -> config := true - | "converter" -> converter := true - | "dependencies" -> dependencies := true - | "moduleResolution" -> module_resolution := true - | "notImplemented" -> not_implemented := true - | "translation" -> translation := true - | "typeEnv" -> type_env := true - | "typeResolution" -> type_resolution := true + | "basic" -> basic () := true + | "codeItems" -> code_items () := true + | "config" -> config () := true + | "converter" -> converter () := true + | "dependencies" -> dependencies () := true + | "moduleResolution" -> module_resolution () := true + | "notImplemented" -> not_implemented () := true + | "translation" -> translation () := true + | "typeEnv" -> type_env () := true + | "typeResolution" -> type_resolution () := true | _ -> () diff --git a/compiler/gentype/dependencies.ml b/compiler/gentype/dependencies.ml index 3e9ba859ed6..f6af97d5bc2 100644 --- a/compiler/gentype/dependencies.ml +++ b/compiler/gentype/dependencies.ml @@ -50,7 +50,7 @@ let rec is_internal dep = let from_path ~config ~type_env path = let _, dep = path |> from_path1 ~config ~type_env in - if !Debug.type_resolution then + if !(Debug.type_resolution ()) then Log_.item "Dependencies.from_path path:%s type_env:%s %s resolved:%s\n" (path |> Path.name) (type_env |> Type_env.to_string) diff --git a/compiler/gentype/emit_js.ml b/compiler/gentype/emit_js.ml index 31d63cccf6c..bb629148e4b 100644 --- a/compiler/gentype/emit_js.ml +++ b/compiler/gentype/emit_js.ml @@ -26,7 +26,7 @@ let require_module ~import ~env ~import_path module_name = let create_export_type_map ~config ~file ~from_cmt_read_recursively (type_declarations : Code_item.type_declaration list) : Code_item.export_type_map = - if !Debug.code_items then Log_.item "Create Type Map for %s\n" file; + if !(Debug.code_items ()) then Log_.item "Create Type Map for %s\n" file; let update_export_type_map (export_type_map : Code_item.export_type_map) (type_declaration : Code_item.type_declaration) : Code_item.export_type_map = @@ -38,7 +38,7 @@ let create_export_type_map ~config ~file ~from_cmt_read_recursively Annotation.GenType | _ -> annotation in - if !Debug.code_items then + if !(Debug.code_items ()) then Log_.item "Type Map: %s%s%s\n" (resolved_type_name |> Resolved_name.to_string) (match type_vars = [] with @@ -139,7 +139,7 @@ let emit_export_from_type_declarations ~config ~emitters ~env let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name ~output_file_relative ~resolver ~inline_one_level ~type_name_is_interface code_item = - if !Debug.code_items then + if !(Debug.code_items ()) then Log_.item "Code Item: %s\n" (code_item |> code_item_to_string ~config ~type_name_is_interface); match code_item with @@ -564,7 +564,7 @@ let propagate_annotation_to_sub_types ~code_items match type_map |> String_map.find type_name with | {annotation = GenType | GenTypeOpaque} -> () | {type_ = type1; annotation = NoGenType} -> - if !Debug.translation then + if !(Debug.translation ()) then Log_.item "Marking Type As Annotated %s\n" type_name; annotated_set := !annotated_set |> String_set.add type_name; type1 |> visit diff --git a/compiler/gentype/export_module.ml b/compiler/gentype/export_module.ml index 05a03483fad..753bbb6405b 100644 --- a/compiler/gentype/export_module.ml +++ b/compiler/gentype/export_module.ml @@ -113,7 +113,7 @@ let emit_all_module_items ~config ~emitters ~file_name let {type_for_type; doc_string} = M {export_module_item} |> export_module_value_to_type ~config in - if !Debug.code_items then Log_.item "EmitModule %s @." module_name; + if !(Debug.code_items ()) then Log_.item "EmitModule %s @." module_name; let emitted_module_item = Module_name.for_inner_module ~file_name ~inner_module_name:module_name diff --git a/compiler/gentype/find_source_file.ml b/compiler/gentype/find_source_file.ml index b646f077cb5..7bd6bcca8e0 100644 --- a/compiler/gentype/find_source_file.ml +++ b/compiler/gentype/find_source_file.ml @@ -1,7 +1,11 @@ +(* Source paths are relative to the compiler request's working directory, + which differs from the process's when the compiler runs in-process. *) +let exists path = Sys.file_exists (Compiler_request_state.resolve_path path) + let rec interface items = match items with | {Typedtree.sig_loc} :: rest -> ( - match not (Sys.file_exists sig_loc.loc_start.pos_fname) with + match not (exists sig_loc.loc_start.pos_fname) with | true -> interface rest | false -> Some sig_loc.loc_start.pos_fname) | [] -> None @@ -9,14 +13,15 @@ let rec interface items = let rec implementation items = match items with | {Typedtree.str_loc} :: rest -> ( - match not (Sys.file_exists str_loc.loc_start.pos_fname) with + match not (exists str_loc.loc_start.pos_fname) with | true -> implementation rest | false -> Some str_loc.loc_start.pos_fname) | [] -> None let transform_to_absolute_path (path : string option) = let transform path = - if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path + if Filename.is_relative path then + Filename.concat (Compiler_request_state.cwd ()) path else path in Option.map transform path diff --git a/compiler/gentype/generated_files.ml b/compiler/gentype/generated_files.ml index 5cb6acf1545..3bafad47ddd 100644 --- a/compiler/gentype/generated_files.ml +++ b/compiler/gentype/generated_files.ml @@ -7,7 +7,7 @@ type file_action = | Write (* File not present on disk. *) let log_file_action file_action file_name = - if !Debug.basic then + if !(Debug.basic ()) then Log_.item "%s %s\n" (match file_action with | NoMatch -> "NoMatch" diff --git a/compiler/gentype/gentype_common.ml b/compiler/gentype/gentype_common.ml index a1e92e6179e..ff69b6c3543 100644 --- a/compiler/gentype/gentype_common.ml +++ b/compiler/gentype/gentype_common.ml @@ -13,7 +13,7 @@ module Doc_string = struct end let log_not_implemented x = - if !Debug.not_implemented then Log_.item "Not Implemented: %s\n" x + if !(Debug.not_implemented ()) then Log_.item "Not Implemented: %s\n" x type optional = Mandatory | Optional type mutable_ = Immutable | Mutable diff --git a/compiler/gentype/gentype_config.ml b/compiler/gentype/gentype_config.ml index 6ff6adf9ac9..3c490b914db 100644 --- a/compiler/gentype/gentype_config.ml +++ b/compiler/gentype/gentype_config.ml @@ -67,17 +67,50 @@ let get_bs_curry_path ~config = [rescript_compiler_main.ml]). Everything the gentype config used to read from [rescript.json] now comes through here instead. *) -let project_root = ref "" -let bsb_project_root = ref "" -let module_flag : module_ option ref = ref None -let module_resolution_flag : module_resolution option ref = ref None -let export_interfaces_flag = ref false -let generated_file_extension_flag : string option ref = ref None -let suffix_flag : string option ref = ref None -let shims : (string * string) list ref = ref [] -let bs_dependencies_flag : string list ref = ref [] -let source_dirs_flag : string list ref = ref [] -let dep_paths_flag : (string * string) list ref = ref [] +type flag_refs = { + project_root_ref: string ref; + bsb_project_root_ref: string ref; + module_ref: module_ option ref; + module_resolution_ref: module_resolution option ref; + export_interfaces_ref: bool ref; + generated_file_extension_ref: string option ref; + suffix_ref: string option ref; + shims_ref: (string * string) list ref; + bs_dependencies_ref: string list ref; + source_dirs_ref: string list ref; + dep_paths_ref: (string * string) list ref; +} + +(* A request builds its GenType config from these flags. Another request must + not reset them while its CMT or declaration output is being generated. *) +let flag_refs = + Request_local.new_key (fun () -> + { + project_root_ref = ref ""; + bsb_project_root_ref = ref ""; + module_ref = ref None; + module_resolution_ref = ref None; + export_interfaces_ref = ref false; + generated_file_extension_ref = ref None; + suffix_ref = ref None; + shims_ref = ref []; + bs_dependencies_ref = ref []; + source_dirs_ref = ref []; + dep_paths_ref = ref []; + }) + +let project_root () = (Domain.DLS.get flag_refs).project_root_ref +let bsb_project_root () = (Domain.DLS.get flag_refs).bsb_project_root_ref +let module_flag () = (Domain.DLS.get flag_refs).module_ref +let module_resolution_flag () = (Domain.DLS.get flag_refs).module_resolution_ref +let export_interfaces_flag () = (Domain.DLS.get flag_refs).export_interfaces_ref +let generated_file_extension_flag () = + (Domain.DLS.get flag_refs).generated_file_extension_ref +let suffix_flag () = (Domain.DLS.get flag_refs).suffix_ref +let shims () = (Domain.DLS.get flag_refs).shims_ref +let bs_dependencies_flag () = (Domain.DLS.get flag_refs).bs_dependencies_ref +let source_dirs_flag () = (Domain.DLS.get flag_refs).source_dirs_ref +let dep_paths_flag () = (Domain.DLS.get flag_refs).dep_paths_ref let module_of_string = function | "commonjs" -> Some CommonJS @@ -92,24 +125,25 @@ let module_resolution_of_string = function let add_shim raw = match String.split_on_char '=' raw with - | [from_module; to_module] -> shims := (from_module, to_module) :: !shims + | [from_module; to_module] -> + shims () := (from_module, to_module) :: !(shims ()) | _ -> () let add_bs_dependency name = - bs_dependencies_flag := name :: !bs_dependencies_flag + bs_dependencies_flag () := name :: !(bs_dependencies_flag ()) -let add_source_dir dir = source_dirs_flag := dir :: !source_dirs_flag +let add_source_dir dir = source_dirs_flag () := dir :: !(source_dirs_flag ()) let add_dep_path raw = match String.split_on_char '=' raw with - | [name; path] -> dep_paths_flag := (name, path) :: !dep_paths_flag + | [name; path] -> dep_paths_flag () := (name, path) :: !(dep_paths_flag ()) | _ -> () (* ----- Build the Config.t from flags ---------------------------------- *) let build_config ~namespace = let shims_map = - !shims + !(shims ()) |> List.fold_left (fun map (from_module, to_module) -> let module_name = @@ -120,57 +154,59 @@ let build_config ~namespace = Module_name_map.empty in let project_root = - match !project_root with - | "" -> Sys.getcwd () + match !(project_root ()) with + | "" -> Compiler_request_state.cwd () | dir -> dir in let bsb_project_root = - match !bsb_project_root with + match !(bsb_project_root ()) with | "" -> project_root | dir -> dir in let module_ = - match !module_flag with + match !(module_flag ()) with | Some m -> m | None -> default.module_ in let module_resolution = - match !module_resolution_flag with + match !(module_resolution_flag ()) with | Some r -> r | None -> default.module_resolution in let suffix = - match !suffix_flag with + match !(suffix_flag ()) with | Some s -> s | None -> default.suffix in - if !Debug.config then ( + if !(Debug.config ()) then ( Log_.item "Project root: %s\n" project_root; if bsb_project_root <> project_root then Log_.item "bsb project root: %s\n" bsb_project_root; Log_.item "Config shims:%d entries \n" (shims_map |> Module_name_map.cardinal)); let dep_paths = - let tbl = Hashtbl.create (List.length !dep_paths_flag) in - List.iter (fun (name, path) -> Hashtbl.add tbl name path) !dep_paths_flag; + let tbl = Hashtbl.create (List.length !(dep_paths_flag ())) in + List.iter + (fun (name, path) -> Hashtbl.add tbl name path) + !(dep_paths_flag ()); tbl in { bsb_project_root; - bs_dependencies = !bs_dependencies_flag; + bs_dependencies = !(bs_dependencies_flag ()); dep_paths; emit_import_curry = false; emit_import_react = false; emit_type_prop_done = false; everything = false; - export_interfaces = !export_interfaces_flag; - generated_file_extension = !generated_file_extension_flag; + export_interfaces = !(export_interfaces_flag ()); + generated_file_extension = !(generated_file_extension_flag ()); module_; module_resolution; namespace; platform_lib = "rescript"; project_root; shims_map; - sources = !source_dirs_flag; + sources = !(source_dirs_flag ()); suffix; } diff --git a/compiler/gentype/gentype_main.ml b/compiler/gentype/gentype_main.ml index a4c93403391..a9c0d911800 100644 --- a/compiler/gentype/gentype_main.ml +++ b/compiler/gentype/gentype_main.ml @@ -133,7 +133,7 @@ let read_input_cmt is_interface cmt_file = let process_cmt_file cmt = let config = Paths.read_config ~namespace:(cmt |> Paths.find_name_space) in - if !Debug.basic then Log_.item "Cmt %s\n" cmt; + if !(Debug.basic ()) then Log_.item "Cmt %s\n" cmt; let cmt_file = cmt |> Paths.get_cmt_file in if cmt_file <> "" then let file_name = cmt |> Paths.get_module_name in diff --git a/compiler/gentype/log_.ml b/compiler/gentype/log_.ml index 16db5bbff06..669e65d973b 100644 --- a/compiler/gentype/log_.ml +++ b/compiler/gentype/log_.ml @@ -37,8 +37,9 @@ module Color = struct : Format.formatter_stag_functions) let setup () = - Format.pp_set_mark_tags Format.std_formatter true; - Format.pp_set_formatter_stag_functions Format.std_formatter color_functions + let formatter = Compiler_request_output.stdout_formatter () in + Format.pp_set_mark_tags formatter true; + Format.pp_set_formatter_stag_functions formatter color_functions let error ppf s = Format.fprintf ppf "@{%s@}" s [@@dead "Color.error"] let info ppf s = Format.fprintf ppf "@{%s@}" s @@ -91,11 +92,13 @@ module Loc = struct end let item x = - Format.fprintf Format.std_formatter " "; - Format.fprintf Format.std_formatter x + let formatter = Compiler_request_output.stdout_formatter () in + Format.fprintf formatter " "; + Format.fprintf formatter x let log_kind body ~color ~loc ~name = - Format.fprintf Format.std_formatter "@[@,%a@,%a@,%a@]@." color name - Loc.print loc body () + Format.fprintf + (Compiler_request_output.stdout_formatter ()) + "@[@,%a@,%a@,%a@]@." color name Loc.print loc body () let info body ~loc ~name = log_kind body ~color:Color.info ~loc ~name diff --git a/compiler/gentype/module_resolver.ml b/compiler/gentype/module_resolver.ml index fa9b5c3a865..f39da5a3904 100644 --- a/compiler/gentype/module_resolver.ml +++ b/compiler/gentype/module_resolver.ml @@ -166,7 +166,7 @@ let resolve_module ~(config : Config.t) ~import_extension ~output_file_relative let resolve_generated_module ~config ~output_file_relative ~resolver module_name = - if !Debug.module_resolution then + if !(Debug.module_resolution ()) then Log_.item "Resolve Generated Module: %s\n" (module_name |> Module_name.to_string); let import_path = @@ -174,19 +174,19 @@ let resolve_generated_module ~config ~output_file_relative ~resolver module_name ~import_extension:(Module_extension.generated_module_extension ~config) ~output_file_relative ~resolver ~use_bs_dependencies:true module_name in - if !Debug.module_resolution then + if !(Debug.module_resolution ()) then Log_.item "Import Path: %s\n" (import_path |> Import_path.dump); import_path (** Returns the path to import a given Reason module name. *) let import_path_for_reason_module_name ~(config : Config.t) ~output_file_relative ~resolver module_name = - if !Debug.module_resolution then + if !(Debug.module_resolution ()) then Log_.item "Resolve Reason Module: %s\n" (module_name |> Module_name.to_string); match config.shims_map |> Module_name_map.find module_name with | shim_module_name -> - if !Debug.module_resolution then + if !(Debug.module_resolution ()) then Log_.item "ShimModuleName: %s\n" (shim_module_name |> Module_name.to_string); let import_extension = @@ -196,7 +196,7 @@ let import_path_for_reason_module_name ~(config : Config.t) resolve_module ~config ~import_extension ~output_file_relative ~resolver ~use_bs_dependencies:false shim_module_name in - if !Debug.module_resolution then + if !(Debug.module_resolution ()) then Log_.item "Import Path: %s\n" (import_path |> Import_path.dump); import_path | exception Not_found -> diff --git a/compiler/gentype/paths.ml b/compiler/gentype/paths.ml index 2c825165397..4c9bd15c6d2 100644 --- a/compiler/gentype/paths.ml +++ b/compiler/gentype/paths.ml @@ -58,7 +58,8 @@ let get_module_name cmt = let get_cmt_file cmt = let path_cmt = - if Filename.is_relative cmt then Filename.concat (Sys.getcwd ()) cmt + if Filename.is_relative cmt then + Filename.concat (Compiler_request_state.cwd ()) cmt else cmt in let cmt_file = diff --git a/compiler/gentype/translate_core_type.ml b/compiler/gentype/translate_core_type.ml index 514c069b3fb..6a961d32d5f 100644 --- a/compiler/gentype/translate_core_type.ml +++ b/compiler/gentype/translate_core_type.ml @@ -278,7 +278,7 @@ let translate_core_type ~config ~type_env core_type = let translation = core_type |> translateCoreType_ ~config ~type_vars_gen ~type_env in - if !Debug.dependencies then + if !(Debug.dependencies ()) then translation.dependencies |> List.iter (fun dep -> Log_.item "Dependency: %s\n" (dep |> dep_to_string)); diff --git a/compiler/gentype/translate_signature.ml b/compiler/gentype/translate_signature.ml index baea33f1fe6..5e2d6a78e89 100644 --- a/compiler/gentype/translate_signature.ml +++ b/compiler/gentype/translate_signature.ml @@ -5,7 +5,7 @@ let translate_signature_value ~config ~output_file_relative ~resolver ~type_env let {Typedtree.val_attributes; val_desc; val_id; val_loc} = value_description in - if !Debug.translation then + if !(Debug.translation ()) then Log_.item "Translate Signature Value %s\n" (val_id |> Ident.name); let type_expr = val_desc.ctyp_type in let add_annotations_to_function type_ = type_ in @@ -23,7 +23,8 @@ let translate_signature_value ~config ~output_file_relative ~resolver ~type_env let rec translate_module_declaration ~config ~output_file_relative ~resolver ~type_env ({md_id; md_type} : Typedtree.module_declaration) = let name = md_id |> Ident.name in - if !Debug.translation then Log_.item "Translate Module Declaration %s\n" name; + if !(Debug.translation ()) then + Log_.item "Translate Module Declaration %s\n" name; let type_env = type_env |> Type_env.new_module ~name in match md_type.mty_desc with | Tmty_signature signature -> @@ -52,7 +53,7 @@ let rec translate_module_declaration ~config ~output_file_relative ~resolver and translate_module_type_declaration ~config ~output_file_relative ~resolver ~type_env (module_type_declaration : Typedtree.module_type_declaration) = - if !Debug.translation then + if !(Debug.translation ()) then Log_.item "Translate Module Type Declaration %s\n" (module_type_declaration.mtd_id |> Ident.name); match module_type_declaration with @@ -162,7 +163,7 @@ and translate_signature_item ~config ~output_file_relative ~resolver ~type_env and translate_signature ~config ~output_file_relative ~resolver ~type_env signature : Translation.t list = - if !Debug.translation then Log_.item "Translate Signature\n"; + if !(Debug.translation ()) then Log_.item "Translate Signature\n"; signature.Typedtree.sig_items |> List.map (translate_signature_item ~config ~output_file_relative ~resolver diff --git a/compiler/gentype/translate_signature_from_types.ml b/compiler/gentype/translate_signature_from_types.ml index 4a0e91bbf47..9dd5f5db10f 100644 --- a/compiler/gentype/translate_signature_from_types.ml +++ b/compiler/gentype/translate_signature_from_types.ml @@ -15,7 +15,7 @@ let translate_type_declaration_from_types ~config ~output_file_relative type_env |> Type_env.new_type ~name:(id |> Ident.name); let type_name = Ident.name id in let type_vars = type_params |> Type_vars.extract_from_type_expr in - if !Debug.translation then + if !(Debug.translation ()) then Log_.item "Translate Types.type_declaration %s\n" type_name; let declaration_kind = match type_kind with @@ -84,7 +84,7 @@ and translate_signature_item_from_types ~config ~output_file_relative ~resolver ~resolver ~type_env ~id | Types.Sig_value (id, {val_attributes; val_loc; val_type}) -> let name = id |> Ident.name |> Ext_ident.unwrap_uppercase_exotic in - if !Debug.translation then Log_.item "Translate Sig Value %s\n" name; + if !(Debug.translation ()) then Log_.item "Translate Sig Value %s\n" name; let module_item = Runtime.new_module_item ~name in type_env |> Type_env.update_module_item ~module_item; if @@ -108,7 +108,7 @@ and translate_signature_item_from_types ~config ~output_file_relative ~resolver (** Like Translate_signature.translate_signature but from Types not Typedtree *) and translate_signature_from_types ~config ~output_file_relative ~resolver ~type_env (signature : Types.signature_item list) : Translation.t list = - if !Debug.translation then Log_.item "Translate Types.signature\n"; + if !(Debug.translation ()) then Log_.item "Translate Types.signature\n"; signature |> List.map (translate_signature_item_from_types ~config ~output_file_relative diff --git a/compiler/gentype/translate_structure.ml b/compiler/gentype/translate_structure.ml index 2222f96148c..97470feacbd 100644 --- a/compiler/gentype/translate_structure.ml +++ b/compiler/gentype/translate_structure.ml @@ -82,7 +82,8 @@ let translate_value_binding ~config ~output_file_relative ~resolver ~type_env match vb_pat.pat_desc with | Tpat_var (id, _) | Tpat_alias ({pat_desc = Tpat_any}, id, _) -> let name = id |> Ident.name |> Ext_ident.unwrap_uppercase_exotic in - if !Debug.translation then Log_.item "Translate Value Binding %s\n" name; + if !(Debug.translation ()) then + Log_.item "Translate Value Binding %s\n" name; let module_item = Runtime.new_module_item ~name in type_env |> Type_env.update_module_item ~module_item; if @@ -140,7 +141,7 @@ let rec translate_module_binding ~(config : Gentype_config.t) ({mb_id; mb_expr; mb_attributes} : Typedtree.module_binding) : Translation.t = let name = mb_id |> Ident.name in - if !Debug.translation then Log_.item "Translate Module Binding %s\n" name; + if !(Debug.translation ()) then Log_.item "Translate Module Binding %s\n" name; let module_item = Runtime.new_module_item ~name in let config = mb_attributes |> Annotation.update_config_for_module ~config in type_env |> Type_env.update_module_item ~module_item; @@ -335,7 +336,7 @@ and translate_structure_item ~config ~output_file_relative ~resolver ~type_env and translate_structure ~config ~output_file_relative ~resolver ~type_env structure : Translation.t list = - if !Debug.translation then Log_.item "Translate Structure\n"; + if !(Debug.translation ()) then Log_.item "Translate Structure\n"; structure.Typedtree.str_items |> remove_value_binding_duplicates |> List.map (fun struct_item -> struct_item diff --git a/compiler/gentype/translate_type_declarations.ml b/compiler/gentype/translate_type_declarations.ml index c7dfb2f69f7..08a8293a62b 100644 --- a/compiler/gentype/translate_type_declarations.ml +++ b/compiler/gentype/translate_type_declarations.ml @@ -346,7 +346,7 @@ let has_some_gadt_leaf constructor_declarations = let translate_type_declaration ~config ~output_file_relative ~resolver ~type_env ({typ_attributes; typ_id; typ_loc; typ_manifest; typ_params; typ_type} : Typedtree.type_declaration) : Code_item.type_declaration list = - if !Debug.translation then + if !(Debug.translation ()) then Log_.item "Translate Type Declaration %s\n" (typ_id |> Ident.name); let type_name = Ident.name typ_id in diff --git a/compiler/gentype/translate_type_expr_from_types.ml b/compiler/gentype/translate_type_expr_from_types.ml index fb91f0e7fde..1bf3110af1f 100644 --- a/compiler/gentype/translate_type_expr_from_types.ml +++ b/compiler/gentype/translate_type_expr_from_types.ml @@ -691,7 +691,7 @@ let translate_type_expr_from_types ~config ~type_env type_expr = let translation = type_expr |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env in - if !Debug.dependencies then + if !(Debug.dependencies ()) then translation.dependencies |> List.iter (fun dep -> Log_.item "Dependency: %s\n" (dep |> dep_to_string)); @@ -702,7 +702,7 @@ let translate_type_exprs_from_types ~config ~type_env type_exprs = let translations = type_exprs |> translateTypeExprsFromTypes_ ~config ~type_vars_gen ~type_env in - if !Debug.dependencies then + if !(Debug.dependencies ()) then translations |> List.iter (fun translation -> translation.dependencies diff --git a/compiler/gentype/translation.ml b/compiler/gentype/translation.ml index 10fd6225818..1a59c092d49 100644 --- a/compiler/gentype/translation.ml +++ b/compiler/gentype/translation.ml @@ -125,7 +125,7 @@ let translate_value ~attributes ~config ~doc_string ~output_file_relative *) let translate_primitive ~config ~output_file_relative ~resolver ~type_env (value_description : Typedtree.value_description) : t = - if !Debug.translation then Log_.item "Translate Primitive\n"; + if !(Debug.translation ()) then Log_.item "Translate Primitive\n"; let value_name = (* external foo : someType = "abc" -- the extern name is "abc" *) match value_description.val_prim with diff --git a/compiler/gentype/type_env.ml b/compiler/gentype/type_env.ml index ce19564dc25..5f59d81c3bb 100644 --- a/compiler/gentype/type_env.ml +++ b/compiler/gentype/type_env.ml @@ -30,14 +30,14 @@ let root () = None |> create_type_env ~name:"__root__" let to_string type_env = type_env.name let new_module ~name type_env = - if !Debug.type_env then + if !(Debug.type_env ()) then Log_.item "Type_env.new_module %s %s\n" (type_env |> to_string) name; let new_type_env = Some type_env |> create_type_env ~name in type_env.map <- type_env.map |> String_map.add name (Module new_type_env); new_type_env let new_module_type ~name ~signature type_env = - if !Debug.type_env then + if !(Debug.type_env ()) then Log_.item "Type_env.new_module_type %s %s\n" (type_env |> to_string) name; let new_type_env = Some type_env |> create_type_env ~name in type_env.map_module_types <- @@ -45,7 +45,7 @@ let new_module_type ~name ~signature type_env = new_type_env let new_type ~name type_env = - if !Debug.type_env then + if !(Debug.type_env ()) then Log_.item "Type_env.new_type %s %s\n" (type_env |> to_string) name; type_env.map <- type_env.map |> String_map.add name (Type name) @@ -58,14 +58,14 @@ let get_module ~name type_env = let expand_alias_to_external_module ~name type_env = match type_env |> get_module ~name with | Some {module_equation = Some {internal = false; dep}} -> - if !Debug.type_env then + if !(Debug.type_env ()) then Log_.item "Type_env.expand_alias_to_external_module %s %s aliased to %s\n" (type_env |> to_string) name (dep |> dep_to_string); Some dep | _ -> None let add_module_equation ~dep ~internal type_env = - if !Debug.type_env then + if !(Debug.type_env ()) then Log_.item "Type_env.add_module_equation %s %s dep:%s\n" (type_env |> to_string) (match internal with @@ -109,7 +109,7 @@ let apply_type_equations ~config ~path type_env = | Path.Pident id -> ( match type_env.type_equations |> String_map.find (id |> Ident.name) with | type_ -> - if !Debug.type_resolution then + if !(Debug.type_resolution ()) then Log_.item "Type_env.apply_type_equations %s name:%s type_:%s\n" (type_env |> to_string) (id |> Ident.name) (type_ @@ -130,7 +130,7 @@ let rec lookup ~name type_env = let rec lookup_module_type ~path type_env = match path with | [module_type_name] -> ( - if !Debug.type_env then + if !(Debug.type_env ()) then Log_.item "Type_env.lookup_module_type %s module_type_name:%s\n" (type_env |> to_string) module_type_name; match type_env.map_module_types |> String_map.find module_type_name with @@ -140,7 +140,7 @@ let rec lookup_module_type ~path type_env = | None -> None | Some parent -> parent |> lookup_module_type ~path)) | module_name :: path1 -> ( - if !Debug.type_env then + if !(Debug.type_env ()) then Log_.item "Type_env.lookup_module_type %s module_name:%s\n" (type_env |> to_string) module_name; match type_env.map |> String_map.find module_name with @@ -159,7 +159,7 @@ let rec path_to_list path = | Path.Papply _ -> [] let lookup_module_type_signature ~path type_env = - if !Debug.type_env then + if !(Debug.type_env ()) then Log_.item "Type_env.lookup_module_type_signature %s %s\n" (type_env |> to_string) (path |> Path.name); type_env |> lookup_module_type ~path:(path |> path_to_list |> List.rev) diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index 3c3806a3a92..227cf468810 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -235,8 +235,7 @@ end (* One time setup for all relevant modules *) let () = Bs_conditional_initial.setup_env (); - Clflags.binary_annotations := false; - Clflags.color := Some Always; + (Clflags.current ()).binary_annotations := false; Lazy.force Res_outcome_printer.setup let error_of_exn e = @@ -270,7 +269,7 @@ module Res_driver = struct Format.flush_str_formatter () let parse_implementation ~sourcefile ~src = - Location.input_name := sourcefile; + Location.set_input_name sourcefile; let parse_result = let engine = setup ~filename:sourcefile ~src in let structure = Res_core.parse_implementation engine in @@ -504,7 +503,7 @@ module Compile = struct cmt_args = [||]; cmt_sourcefile = Some sourcefile; cmt_builddir = Sys.getcwd (); - cmt_loadpath = !Config.load_path; + cmt_loadpath = Config.get_load_path (); cmt_source_digest = None; cmt_initial_env = env; cmt_imports = []; @@ -637,7 +636,7 @@ module Compile = struct let filename = get_filename ~lang config.filename in let modulename = "Playground" in let impl = rescript_parse ~filename in - Clflags.open_modules := open_modules; + (Clflags.current ()).open_modules := open_modules; (* let env = !Toploop.toplevel_env in *) (* Res_compmisc.init_path (); *) (* let modulename = module_of_filename ppf sourcefile outputprefix in *) @@ -647,11 +646,12 @@ module Compile = struct (* Question ?? *) (* let finalenv = ref Env.empty in *) let types_signature = ref [] in - Js_config.jsx_version := Some Js_config.Jsx_v4; - Js_config.jsx_preserve := jsx_preserve_mode; - Js_config.source_map := source_map_mode; - Js_config.source_map_sources_content := source_map_sources_content; - Js_config.source_map_root := source_map_root; + (Js_config.current ()).jsx_version := Some Js_config.Jsx_v4; + (Clflags.current ()).jsx_preserve := jsx_preserve_mode; + (Js_config.current ()).source_map := source_map_mode; + (Js_config.current ()).source_map_sources_content := + source_map_sources_content; + (Js_config.current ()).source_map_root := source_map_root; experimental_features |> List.iter Experimental_features.enable_from_string; (* default *) @@ -759,7 +759,7 @@ module Compile = struct end (* To add a directory to the load path *) -let dir_directory d = Config.load_path := d :: !Config.load_path +let dir_directory d = Config.set_load_path (d :: Config.get_load_path ()) let () = dir_directory "/static" module Export = struct diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index cc0da9a6325..087b5b3811d 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -617,7 +617,9 @@ module String_map = Map.Make (struct let compare = compare end) -let cookies = ref String_map.empty +(* Cookies exchanged with external PPXs belong to one compiler request. *) +let cookies_key = Request_local.new_key (fun () -> ref String_map.empty) +let cookies () = Domain.DLS.get cookies_key module Ppx_context = struct open Longident @@ -649,7 +651,7 @@ module Ppx_context = struct x = make_list (make_pair make_string (fun x -> x)) - (String_map.bindings !cookies); + (String_map.bindings !(cookies ())); opt = false; } @@ -663,20 +665,24 @@ module Ppx_context = struct {lid = lid "tool_name"; x = make_string tool_name; opt = false}; { lid = lid "include_dirs"; - x = make_list make_string !Clflags.include_dirs; + x = make_list make_string !((Clflags.current ()).include_dirs); opt = false; }; { lid = lid "load_path"; - x = make_list make_string !Config.load_path; + x = make_list make_string (Config.get_load_path ()); opt = false; }; { lid = lid "open_modules"; - x = make_list make_string !Clflags.open_modules; + x = make_list make_string !((Clflags.current ()).open_modules); + opt = false; + }; + { + lid = lid "debug"; + x = make_bool !((Clflags.current ()).debug); opt = false; }; - {lid = lid "debug"; x = make_bool !Clflags.debug; opt = false}; get_cookies (); ] in @@ -737,13 +743,15 @@ module Ppx_context = struct name in match name with - | "include_dirs" -> Clflags.include_dirs := get_list get_string payload - | "load_path" -> Config.load_path := get_list get_string payload - | "open_modules" -> Clflags.open_modules := get_list get_string payload - | "debug" -> Clflags.debug := get_bool payload + | "include_dirs" -> + (Clflags.current ()).include_dirs := get_list get_string payload + | "load_path" -> Config.set_load_path (get_list get_string payload) + | "open_modules" -> + (Clflags.current ()).open_modules := get_list get_string payload + | "debug" -> (Clflags.current ()).debug := get_bool payload | "cookies" -> let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := + cookies () := List.fold_left (fun s (k, v) -> String_map.add k v s) String_map.empty l diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index 3301f0c5456..fd320852eb0 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -38,11 +38,16 @@ let pivot_level = (2 * lowest_level) - 1 (**** Some type creators ****) -let new_id = ref (-1) +let reinit () = + let state = Compiler_request_state.current () in + match state.type_node_reset_id with + | None -> state.type_node_reset_id <- Some state.type_node_id + | Some level -> state.type_node_id <- level let newty2 level desc = - incr new_id; - {desc; level; id = !new_id} + let state = Compiler_request_state.current () in + state.type_node_id <- state.type_node_id + 1; + {desc; level; id = state.type_node_id} let newgenty desc = newty2 generic_level desc let newgenvar ?name () = newgenty (Tvar name) (* @@ -89,9 +94,12 @@ type change = type changes = Change of change * changes ref | Unchanged | Invalid -let trail = Weak.create 1 +(* A type graph and its speculative mutation trail belong to one compiler + request. The trail must follow the domain that owns the graph. *) +let trail = Request_local.new_key (fun () -> Weak.create 1) let log_change ch = + let trail = Domain.DLS.get trail in match Weak.get trail 0 with | None -> () | Some r -> @@ -424,9 +432,10 @@ type type_copy_session = { Several copy calls in one session deliberately share both memo kinds. Session writes are raw writes restored on exit; semantic mutability changes use the backtracking trail instead. *) -let type_copy_sessions = ref [] +let type_copy_sessions = Request_local.new_key (fun () -> ref []) let begin_type_copy_session () = + let type_copy_sessions = Domain.DLS.get type_copy_sessions in type_copy_sessions := { saved_desc = []; @@ -437,11 +446,13 @@ let begin_type_copy_session () = :: !type_copy_sessions let current_type_copy_session () = + let type_copy_sessions = Domain.DLS.get type_copy_sessions in match !type_copy_sessions with | session :: _ -> session | [] -> assert false let end_type_copy_session () = + let type_copy_sessions = Domain.DLS.get type_copy_sessions in match !type_copy_sessions with | session :: rest -> List.iter (fun (ty, desc) -> ty.desc <- desc) session.saved_desc; @@ -625,15 +636,17 @@ let rec find_expans priv p1 = function | _ -> () *) -let memo = ref [] +let memo = Request_local.new_key (fun () -> ref []) (* Contains the list of saved abbreviation expansions. *) let cleanup_abbrev () = + let memo = Domain.DLS.get memo in (* Remove all memorized abbreviation expansions. *) List.iter (fun abbr -> abbr := Mnil) !memo; memo := [] let memorize_abbrev mem priv path v v' = + let memo = Domain.DLS.get memo in (* Memorize the expansion of an abbreviation. *) mem := Mcons (priv, path, v, v', !mem); (* check_expans [] v; *) @@ -712,10 +725,10 @@ let undo_change = function | Ctypeset (r, v) -> r := v type snapshot = changes ref * int -let last_snapshot = ref 0 let log_type ty = - if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) + if ty.id <= (Compiler_request_state.current ()).type_node_last_snapshot then + log_change (Ctype (ty, ty.desc)) let link_type ty ty' = log_type ty; let desc = ty.desc in @@ -739,7 +752,8 @@ let link_type ty ty' = (* ; assert (check_memorized_abbrevs ()) *) (* ; check_expans [] ty' *) let set_level ty level = - if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); + if ty.id <= (Compiler_request_state.current ()).type_node_last_snapshot then + log_change (Clevel (ty, ty.level)); ty.level <- level let set_univar rty ty = log_change (Cuniv (rty, !rty)); @@ -756,8 +770,10 @@ let set_typeset rs s = rs := s let snapshot () = - let old = !last_snapshot in - last_snapshot := !new_id; + let state = Compiler_request_state.current () in + let old = state.type_node_last_snapshot in + state.type_node_last_snapshot <- state.type_node_id; + let trail = Domain.DLS.get trail in match Weak.get trail 0 with | Some r -> (r, old) | None -> @@ -774,16 +790,17 @@ let rec rev_log accu = function rev_log (ch :: accu) d let backtrack (changes, old) = + let state = Compiler_request_state.current () in match !changes with - | Unchanged -> last_snapshot := old + | Unchanged -> state.type_node_last_snapshot <- old | Invalid -> failwith "Btype.backtrack" | Change _ as change -> cleanup_abbrev (); let backlog = rev_log [] change in List.iter undo_change backlog; changes := Unchanged; - last_snapshot := old; - Weak.set trail 0 (Some changes) + state.type_node_last_snapshot <- old; + Weak.set (Domain.DLS.get trail) 0 (Some changes) let rec rev_compress_log log r = match !r with diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index d38d0a6f3f8..b2b3671b16e 100644 --- a/compiler/ml/btype.mli +++ b/compiler/ml/btype.mli @@ -37,6 +37,9 @@ val newgenty : type_desc -> type_expr val newgenvar : ?name:string -> unit -> type_expr (* Return a fresh generic variable *) +val reinit : unit -> unit +(** Restore the type identifier allocator to its post-initialization state. *) + (* Use Tsubst instead val newmarkedvar: int -> type_expr (* Return a fresh marked variable *) diff --git a/compiler/ml/ccomp.ml b/compiler/ml/ccomp.ml index d6fb5f1e53e..b7806f5c00a 100644 --- a/compiler/ml/ccomp.ml +++ b/compiler/ml/ccomp.ml @@ -1,6 +1,11 @@ +let with_command_runner runner action = + let state = Compiler_request_state.current () in + let previous = state.command_runner in + state.command_runner <- runner; + Fun.protect action ~finally:(fun () -> state.command_runner <- previous) + let command cmdline = - if !Clflags.verbose then ( - prerr_string "+ "; - prerr_string cmdline; - prerr_newline ()); - Sys.command cmdline + if !((Clflags.current ()).verbose) then ( + Compiler_request_output.write_stderr "+ "; + Compiler_request_output.print_stderr cmdline); + (Compiler_request_state.current ()).command_runner cmdline diff --git a/compiler/ml/ccomp.mli b/compiler/ml/ccomp.mli index 87678cc1465..c8878747894 100644 --- a/compiler/ml/ccomp.mli +++ b/compiler/ml/ccomp.mli @@ -1 +1,7 @@ val command : string -> int + +val with_command_runner : (string -> int) -> (unit -> 'a) -> 'a +(** Temporarily route external preprocessor commands through a host-owned + runner on the current domain. Long-lived compiler hosts use this to + preserve cancellation and process-tree ownership. Nested scopes restore + their previous runner even when the action raises. *) diff --git a/compiler/ml/clflags.ml b/compiler/ml/clflags.ml index f5da859e5b0..6212a46505b 100644 --- a/compiler/ml/clflags.ml +++ b/compiler/ml/clflags.ml @@ -1,62 +1,107 @@ -let output_name = ref (None : string option) (* -o *) - -and include_dirs = ref ([] : string list) (* -I *) - -and debug = ref false (* -g *) - -and nopervasives = ref false (* -nopervasives *) - -and all_ppx = ref ([] : string list) - -(* -ppx *) -let binary_annotations = ref false (* write .cmt/.cmti; -bs-no-bin-annot *) - -and noassert = ref false (* -noassert *) - -and verbose = ref false (* -verbose *) - -and open_modules = ref [] (* -open *) - -and real_paths = ref true (* -short-paths *) - -and transparent_modules = ref false (* -trans-mod *) -let dump_source = ref false (* -dsource *) -let dump_parsetree = ref false (* -dparsetree *) - -and dump_typedtree = ref false (* -dtypedtree *) - -and dump_rawlambda = ref false (* -drawlambda *) - -and dump_coercions = ref false (* -draw-coercions *) - -and only_parse = ref false (* -only-parse *) - -and ignore_parse_errors = ref false (* -ignore-parse-errors *) +type mli_status = Mli_exists | Mli_non_exists -let dont_write_files = ref false (* set to true under ocamldoc *) +type t = { + output_name: string option ref; + include_dirs: string list ref; + debug: bool ref; + nopervasives: bool ref; + all_ppx: string list ref; + binary_annotations: bool ref; + noassert: bool ref; + verbose: bool ref; + open_modules: string list ref; + real_paths: bool ref; + transparent_modules: bool ref; + dump_source: bool ref; + dump_parsetree: bool ref; + dump_typedtree: bool ref; + dump_rawlambda: bool ref; + dump_coercions: bool ref; + only_parse: bool ref; + ignore_parse_errors: bool ref; + dont_write_files: bool ref; + keep_locs: bool ref; + color: Misc.Color.setting option ref; + assume_no_mli: mli_status ref; + dont_record_crc_unit: string option ref; + bs_gentype: bool ref; + jsx_preserve: bool ref; + no_assert_false: bool ref; + dump_location: bool ref; +} + +let create () = + { + output_name = ref None (* -o *); + include_dirs = ref [] (* -I *); + debug = ref false (* -g *); + nopervasives = ref false (* -nopervasives *); + all_ppx = ref [] (* -ppx *); + binary_annotations = ref false (* write .cmt/.cmti; -bs-no-bin-annot *); + noassert = ref false (* -noassert *); + verbose = ref false (* -verbose *); + open_modules = ref [] (* -open *); + real_paths = ref true (* -short-paths *); + transparent_modules = ref false (* -trans-mod *); + dump_source = ref false (* -dsource *); + dump_parsetree = ref false (* -dparsetree *); + dump_typedtree = ref false (* -dtypedtree *); + dump_rawlambda = ref false (* -drawlambda *); + dump_coercions = ref false (* -draw-coercions *); + only_parse = ref false (* -only-parse *); + ignore_parse_errors = ref false (* -ignore-parse-errors *); + dont_write_files = ref false; + keep_locs = ref true (* -keep-locs *); + color = ref None (* -color *); + assume_no_mli = ref Mli_non_exists; + dont_record_crc_unit = ref None; + bs_gentype = ref false; + jsx_preserve = ref false (* -bs-jsx-preserve *); + no_assert_false = ref false; + dump_location = ref true; + } + +(* Compiler flags are mutable during option parsing and source processing, so + each request must own its refs. *) +let key = Request_local.new_key create +let current () = Domain.DLS.get key let reset_dump_state () = - dump_source := false; - dump_parsetree := false; - dump_typedtree := false; - dump_rawlambda := false; - dump_coercions := false - -let keep_locs = ref true (* -keep-locs *) + let state = current () in + state.dump_source := false; + state.dump_parsetree := false; + state.dump_typedtree := false; + state.dump_rawlambda := false; + state.dump_coercions := false let parse_color_setting = function | "auto" -> Some Misc.Color.Auto | "always" -> Some Misc.Color.Always | "never" -> Some Misc.Color.Never | _ -> None -let color = ref None -(* -color *) - -type mli_status = Mli_exists | Mli_non_exists -let assume_no_mli = ref Mli_non_exists -let dont_record_crc_unit : string option ref = ref None -let bs_gentype = ref false -let jsx_preserve = ref false -let no_assert_false = ref false -let dump_location = ref true +let reset () = + let state = current () in + state.output_name := None; + state.include_dirs := []; + state.debug := true; + state.nopervasives := false; + state.all_ppx := []; + state.binary_annotations := true; + state.noassert := false; + state.verbose := false; + state.open_modules := []; + state.real_paths := true; + state.transparent_modules := false; + reset_dump_state (); + state.only_parse := false; + state.ignore_parse_errors := false; + state.dont_write_files := false; + state.keep_locs := true; + state.color := Some Misc.Color.Always; + state.assume_no_mli := Mli_non_exists; + state.dont_record_crc_unit := None; + state.bs_gentype := false; + state.jsx_preserve := false; + state.no_assert_false := false; + state.dump_location := false diff --git a/compiler/ml/clflags.mli b/compiler/ml/clflags.mli index 3efdf861270..fa01b06fc51 100644 --- a/compiler/ml/clflags.mli +++ b/compiler/ml/clflags.mli @@ -1,38 +1,43 @@ -val output_name : string option ref -val include_dirs : string list ref +type mli_status = Mli_exists | Mli_non_exists -val debug : bool ref +type t = { + output_name: string option ref; + include_dirs: string list ref; + debug: bool ref; + nopervasives: bool ref; + all_ppx: string list ref; + binary_annotations: bool ref; + noassert: bool ref; + verbose: bool ref; + open_modules: string list ref; + real_paths: bool ref; + transparent_modules: bool ref; + dump_source: bool ref; + dump_parsetree: bool ref; + dump_typedtree: bool ref; + dump_rawlambda: bool ref; + dump_coercions: bool ref; + only_parse: bool ref; + ignore_parse_errors: bool ref; + dont_write_files: bool ref; + keep_locs: bool ref; + color: Misc.Color.setting option ref; + assume_no_mli: mli_status ref; + dont_record_crc_unit: string option ref; + bs_gentype: bool ref; + jsx_preserve: bool ref; + (** Keep JSX in the output ([-bs-jsx-preserve]); read by translcore *) + no_assert_false: bool ref; + dump_location: bool ref; +} -val nopervasives : bool ref -val open_modules : string list ref -val all_ppx : string list ref -val binary_annotations : bool ref -val noassert : bool ref -val verbose : bool ref -val real_paths : bool ref -val transparent_modules : bool ref -val dump_source : bool ref -val dump_parsetree : bool ref -val dump_typedtree : bool ref -val dump_rawlambda : bool ref -val dump_coercions : bool ref -val dont_write_files : bool ref -val keep_locs : bool ref -val only_parse : bool ref -val ignore_parse_errors : bool ref +val current : unit -> t +(* Mutable compiler flags for the current domain. *) val parse_color_setting : string -> Misc.Color.setting option -val color : Misc.Color.setting option ref - val reset_dump_state : unit -> unit -type mli_status = Mli_exists | Mli_non_exists -val assume_no_mli : mli_status ref -val dont_record_crc_unit : string option ref -val bs_gentype : bool ref - -val jsx_preserve : bool ref - -(* Keep JSX in the output ([-bs-jsx-preserve]); read by translcore *) -val no_assert_false : bool ref -val dump_location : bool ref +val reset : unit -> unit +(** Sets bsc's defaults: debug information and binary annotations on, colored + diagnostics, and no locations in dumps. Fresh flags start from OCaml's + defaults instead, which editor analysis relies on. *) diff --git a/compiler/ml/cmi_format.ml b/compiler/ml/cmi_format.ml index 1a708b96d9c..805b6fb14e5 100644 --- a/compiler/ml/cmi_format.ml +++ b/compiler/ml/cmi_format.ml @@ -35,41 +35,38 @@ let input_cmi ic = let flags = input_value ic in {cmi_name = name; cmi_sign = sign; cmi_crcs = crcs; cmi_flags = flags} -let read_cmi filename = - let ic = open_in_bin filename in +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 ( - close_in ic; - 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))); + (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 - close_in ic; cmi - with - | End_of_file | Failure _ -> - close_in ic; - raise (Error (Corrupted_interface filename)) - | Error e -> - close_in ic; - raise (Error e) + 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 + Fun.protect + (fun () -> read_cmi_channel filename ic) + ~finally:(fun () -> close_in_noerr ic) let output_cmi filename oc cmi = (* beware: the provided signature must have been substituted for saving *) output_string oc Config.cmi_magic_number; output_value oc (cmi.cmi_name, cmi.cmi_sign); flush oc; - let crc = Digest.file filename in + let crc = Digest.file (Compiler_request_state.resolve_path filename) in let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in output_value oc crcs; output_value oc cmi.cmi_flags; @@ -86,8 +83,10 @@ let create_cmi ?check_exists filename (cmi : cmi_infos) = in let crc = Digest.string content in let cmi_infos = - if check_exists <> None && Sys.file_exists filename then - Some (read_cmi filename) + 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 @@ -104,7 +103,7 @@ let create_cmi ?check_exists filename (cmi : cmi_infos) = crc | _ -> let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in - let oc = open_out_bin filename 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; diff --git a/compiler/ml/cmi_format.mli b/compiler/ml/cmi_format.mli index ca608d3ab81..15273591efc 100644 --- a/compiler/ml/cmi_format.mli +++ b/compiler/ml/cmi_format.mli @@ -32,6 +32,8 @@ val input_cmi : in_channel -> cmi_infos (* read a cmi from a filename, checking the magic *) val read_cmi : string -> cmi_infos +val read_cmi_channel : string -> in_channel -> cmi_infos +(* Parse an already opened CMI. The caller retains ownership of the channel. *) (* Error report *) diff --git a/compiler/ml/cmt_format.ml b/compiler/ml/cmt_format.ml index b47a98c1d48..b8218796f45 100644 --- a/compiler/ml/cmt_format.ml +++ b/compiler/ml/cmt_format.ml @@ -1,5 +1,7 @@ include Cmt_format_common +let set_args = Cmt_format_persistence.set_args + let save_cmt filename modname binary_annots sourcefile initial_env = Cmt_format_persistence.save_cmt filename modname binary_annots sourcefile initial_env; diff --git a/compiler/ml/cmt_format.mli b/compiler/ml/cmt_format.mli index 15abb795704..75953e14641 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -65,6 +65,10 @@ type error = Not_a_typedtree of string exception Error of error +val set_args : string array -> unit +(** Set the logical compiler arguments recorded in subsequently written CMT + files. Long-lived compiler hosts set this at each request boundary. *) + val read_cmt : string -> cmt_infos val read_cmi : string -> Cmi_format.cmi_infos diff --git a/compiler/ml/cmt_format_common.ml b/compiler/ml/cmt_format_common.ml index 797b0bca366..9ad18767174 100644 --- a/compiler/ml/cmt_format_common.ml +++ b/compiler/ml/cmt_format_common.ml @@ -112,7 +112,7 @@ let input_cmt ic = (input_value ic : cmt_infos) *) let read filename = (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) - let ic = open_in_bin filename in + let ic = open_in_bin (Compiler_request_state.resolve_path filename) in try let magic_number = read_magic_number ic in let cmi, cmt = @@ -148,28 +148,41 @@ let read_cmi filename = | None, _ -> raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) | Some cmi, _ -> cmi -let saved_types : binary_part list ref = ref [] - -let value_deps : (Types.value_description * Types.value_description) list ref = - ref [] +(* These typed values cannot live in Compiler_request_state without a module + dependency cycle. Keep their accumulator together in domain-local storage; + the Cmt_utils callback below is shared initialization and only forwards to + this domain's accumulator. *) +type accumulators = { + mutable saved_types: binary_part list; + mutable value_deps: (Types.value_description * Types.value_description) list; + mutable deprecated_used: Cmt_utils.deprecated_used list; +} -let deprecated_used : Cmt_utils.deprecated_used list ref = ref [] +let accumulators = + Request_local.new_key (fun () -> + {saved_types = []; value_deps = []; deprecated_used = []}) -let value_dependencies () = !value_deps -let deprecated_uses () = !deprecated_used +let current_accumulators () = Domain.DLS.get accumulators +let value_dependencies () = (current_accumulators ()).value_deps +let deprecated_uses () = (current_accumulators ()).deprecated_used let clear () = - saved_types := []; - value_deps := []; - deprecated_used := [] + let state = current_accumulators () in + state.saved_types <- []; + state.value_deps <- []; + state.deprecated_used <- [] + +let add_saved_type b = + let state = current_accumulators () in + state.saved_types <- b :: state.saved_types -let add_saved_type b = saved_types := b :: !saved_types -let get_saved_types () = !saved_types -let set_saved_types l = saved_types := l +let get_saved_types () = (current_accumulators ()).saved_types +let set_saved_types l = (current_accumulators ()).saved_types <- l let record_deprecated_used ?deprecated_context ?migration_template ?migration_in_pipe_chain_template source_loc deprecated_text = - deprecated_used := + let state = current_accumulators () in + state.deprecated_used <- { Cmt_utils.source_loc; deprecated_text; @@ -177,10 +190,11 @@ let record_deprecated_used ?deprecated_context ?migration_template migration_in_pipe_chain_template; context = deprecated_context; } - :: !deprecated_used + :: state.deprecated_used let _ = Cmt_utils.record_deprecated_used := record_deprecated_used let record_value_dependency vd1 vd2 = if vd1.Types.val_loc <> vd2.Types.val_loc then - value_deps := (vd1, vd2) :: !value_deps + let state = current_accumulators () in + state.value_deps <- (vd1, vd2) :: state.value_deps diff --git a/compiler/ml/code_frame.ml b/compiler/ml/code_frame.ml index 2054b83c0a5..a3f57c2f3bc 100644 --- a/compiler/ml/code_frame.ml +++ b/compiler/ml/code_frame.ml @@ -94,21 +94,16 @@ module Color = struct let term = try Sys.getenv "TERM" with Not_found -> "" in term <> "dumb" && term <> "" && isatty stderr - let color_enabled = ref true + let color_key = Request_local.new_key (fun () -> ref true) + let color_enabled () = Domain.DLS.get color_key - let setup = - let first = ref true in - (* initialize only once *) - fun o -> - if !first then ( - first := false; - color_enabled := - match o with - | Some Misc.Color.Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()); - () + let setup option = + color_enabled () := + match option with + | Some Misc.Color.Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color () end let setup = Color.setup @@ -227,7 +222,7 @@ let print ~is_warning ~src ~(start_pos : Lexing.position) let add_ch = let last_color = ref NoColor in fun color ch -> - if (not !Color.color_enabled) || !last_color = color then + if (not !(Color.color_enabled ())) || !last_color = color then Buffer.add_char buf ch else let ansi = diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 62672a4a043..624a071fd42 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -96,10 +96,24 @@ exception Cannot_apply (**** Type level management ****) -let current_level = ref 0 -let nongen_level = ref 0 -let global_level = ref 1 -let saved_level = ref [] +type level_refs = { + current: int ref; + nongen: int ref; + global: int ref; + saved: (int * int) list ref; +} + +(* Type inference nests definition levels. The nesting stack must belong to + the domain doing the inference; another request can enter or leave a + definition while this one is still typing. *) +let level_refs = + Request_local.new_key (fun () -> + {current = ref 0; nongen = ref 0; global = ref 1; saved = ref []}) + +let current_level () = (Domain.DLS.get level_refs).current +let nongen_level () = (Domain.DLS.get level_refs).nongen +let global_level () = (Domain.DLS.get level_refs).global +let saved_level () = (Domain.DLS.get level_refs).saved type levels = { current_level: int; @@ -109,37 +123,38 @@ type levels = { } let save_levels () = { - current_level = !current_level; - nongen_level = !nongen_level; - global_level = !global_level; - saved_level = !saved_level; + current_level = !(current_level ()); + nongen_level = !(nongen_level ()); + global_level = !(global_level ()); + saved_level = !(saved_level ()); } let set_levels l = - current_level := l.current_level; - nongen_level := l.nongen_level; - global_level := l.global_level; - saved_level := l.saved_level + current_level () := l.current_level; + nongen_level () := l.nongen_level; + global_level () := l.global_level; + saved_level () := l.saved_level -let get_current_level () = !current_level +let get_current_level () = !(current_level ()) let init_def level = - current_level := level; - nongen_level := level + current_level () := level; + nongen_level () := level let begin_def () = - saved_level := (!current_level, !nongen_level) :: !saved_level; - incr current_level; - nongen_level := !current_level + saved_level () := + (!(current_level ()), !(nongen_level ())) :: !(saved_level ()); + incr (current_level ()); + nongen_level () := !(current_level ()) let end_def () = - let cl, nl = List.hd !saved_level in - saved_level := List.tl !saved_level; - current_level := cl; - nongen_level := nl + let cl, nl = List.hd !(saved_level ()) in + saved_level () := List.tl !(saved_level ()); + current_level () := cl; + nongen_level () := nl -let reset_global_level () = global_level := !current_level + 1 +let reset_global_level () = global_level () := !(current_level ()) + 1 let increase_global_level () = - let gl = !global_level in - global_level := !current_level; + let gl = !(global_level ()) in + global_level () := !(current_level ()); gl -let restore_global_level gl = global_level := gl +let restore_global_level gl = global_level () := gl (**** Whether a path points to an object type (with hidden row variable) ****) let is_object_type path = @@ -153,16 +168,17 @@ let is_object_type path = (**** Control tracing of GADT instances *) -let trace_gadt_instances = ref false +let trace_gadt_instances_key = Request_local.new_key (fun () -> ref false) +let trace_gadt_instances () = Domain.DLS.get trace_gadt_instances_key let check_trace_gadt_instances env = - (not !trace_gadt_instances) + (not !(trace_gadt_instances ())) && Env.has_local_constraints env && - (trace_gadt_instances := true; + (trace_gadt_instances () := true; cleanup_abbrev (); true) -let reset_trace_gadt_instances b = if b then trace_gadt_instances := false +let reset_trace_gadt_instances b = if b then trace_gadt_instances () := false let wrap_trace_gadt_instances env f x = let b = check_trace_gadt_instances env in @@ -173,22 +189,23 @@ let wrap_trace_gadt_instances env f x = (**** Abbreviations without parameters ****) (* Shall reset after generalizing *) -let simple_abbrevs = ref Mnil +let simple_abbrevs_key = Request_local.new_key (fun () -> ref Mnil) +let simple_abbrevs () = Domain.DLS.get simple_abbrevs_key let proper_abbrevs path tl abbrev = - if tl <> [] || !trace_gadt_instances || is_object_type path then abbrev - else simple_abbrevs + if tl <> [] || !(trace_gadt_instances ()) || is_object_type path then abbrev + else simple_abbrevs () (**** Some type creators ****) (* Re-export generic type creators *) let newty2 = Btype.newty2 -let newty desc = newty2 !current_level desc +let newty desc = newty2 !(current_level ()) desc -let newvar ?name () = newty2 !current_level (Tvar name) +let newvar ?name () = newty2 !(current_level ()) (Tvar name) let newvar2 ?name level = newty2 level (Tvar name) -let new_global_var ?name () = newty2 !global_level (Tvar name) +let new_global_var ?name () = newty2 !(global_level ()) (Tvar name) let newobj fields = newty (Tobject fields) @@ -215,27 +232,39 @@ type unification_mode = | Expression (* unification in expression *) | Pattern (* unification in pattern which may add local constraints *) -let umode = ref Expression -let generate_equations = ref false -let assume_injective = ref false +(* These flags are dynamically scoped during pattern unification. A parallel + request must not observe another domain's pattern mode or equations. *) +type unification_settings = { + mode: unification_mode ref; + equations: bool ref; + injective: bool ref; +} + +let unification_settings = + Request_local.new_key (fun () -> + {mode = ref Expression; equations = ref false; injective = ref false}) + +let umode () = (Domain.DLS.get unification_settings).mode +let generate_equations () = (Domain.DLS.get unification_settings).equations +let assume_injective () = (Domain.DLS.get unification_settings).injective let variant_is_subtype = ref (fun _env _row _p1 -> false) let set_mode_pattern ~generate ~injective f = - let old_unification_mode = !umode - and old_gen = !generate_equations - and old_inj = !assume_injective in + let old_unification_mode = !(umode ()) + and old_gen = !(generate_equations ()) + and old_inj = !(assume_injective ()) in try - umode := Pattern; - generate_equations := generate; - assume_injective := injective; + umode () := Pattern; + generate_equations () := generate; + assume_injective () := injective; let ret = f () in - umode := old_unification_mode; - generate_equations := old_gen; - assume_injective := old_inj; + umode () := old_unification_mode; + generate_equations () := old_gen; + assume_injective () := old_inj; ret with e -> - umode := old_unification_mode; - generate_equations := old_gen; - assume_injective := old_inj; + umode () := old_unification_mode; + generate_equations () := old_gen; + assume_injective () := old_inj; raise e (*** Checks for type definitions ***) @@ -248,7 +277,7 @@ let in_pervasives p = in_current_module p && try - ignore (Env.find_type p Env.initial_safe_string); + ignore (Env.find_type p (Env.initial_safe_string ())); true with Not_found -> false @@ -368,20 +397,23 @@ let rec filter_row_fields erase = function exception Non_closed of type_expr * bool -let free_variables = ref [] -let really_closed = ref None +let free_variables_ref_key = Request_local.new_key (fun () -> ref []) +let free_variables_ref () = Domain.DLS.get free_variables_ref_key +let really_closed_key = Request_local.new_key (fun () -> ref None) +let really_closed () = Domain.DLS.get really_closed_key let rec free_vars_rec real ty = let ty = repr ty in if ty.level >= lowest_level then ( ty.level <- pivot_level - ty.level; - match (ty.desc, !really_closed) with - | Tvar _, _ -> free_variables := (ty, real) :: !free_variables + match (ty.desc, !(really_closed ())) with + | Tvar _, _ -> + free_variables_ref () := (ty, real) :: !(free_variables_ref ()) | Tconstr (path, tl, _), Some env -> (try let _, body, _ = Env.find_type_expansion path env in if (repr body).level <> generic_level then - free_variables := (ty, real) :: !free_variables + free_variables_ref () := (ty, real) :: !(free_variables_ref ()) with Not_found -> ()); List.iter (free_vars_rec true) tl | Tobject ty, _ -> free_vars_rec false ty @@ -395,12 +427,12 @@ let rec free_vars_rec real ty = | _ -> iter_type_expr (free_vars_rec true) ty) let free_vars ?env ty = - free_variables := []; - really_closed := env; + free_variables_ref () := []; + really_closed () := env; free_vars_rec true ty; - let res = !free_variables in - free_variables := []; - really_closed := None; + let res = !(free_variables_ref ()) in + free_variables_ref () := []; + really_closed () := None; res let free_variables ?env ty = @@ -483,7 +515,7 @@ let duplicate_type ty = Subst.type_expr Subst.identity ty *) let rec generalize ty = let ty = repr ty in - if ty.level > !current_level && ty.level <> generic_level then ( + if ty.level > !(current_level ()) && ty.level <> generic_level then ( set_level ty generic_level; (match ty.desc with | Tconstr (_, _, abbrev) -> iter_abbrev generalize !abbrev @@ -491,7 +523,7 @@ let rec generalize ty = iter_type_expr generalize ty) let generalize ty = - simple_abbrevs := Mnil; + simple_abbrevs () := Mnil; generalize ty (* Generalize the structure and lower the variables *) @@ -501,7 +533,7 @@ let rec generalize_structure var_level ty = if ty.level <> generic_level then if is_Tvar ty && ty.level > var_level then set_level ty var_level else if - ty.level > !current_level + ty.level > !(current_level ()) && match ty.desc with | Tconstr (p, _, abbrev) -> @@ -515,7 +547,7 @@ let rec generalize_structure var_level ty = iter_type_expr (generalize_structure var_level) ty) let generalize_structure var_level ty = - simple_abbrevs := Mnil; + simple_abbrevs () := Mnil; generalize_structure var_level ty let forward_try_expand_once = @@ -640,11 +672,11 @@ let rec generalize_expansive env var_level visited ty = | _ -> iter_type_expr (generalize_expansive env var_level visited) ty) let generalize_expansive env ty = - simple_abbrevs := Mnil; - try generalize_expansive env !nongen_level (Hashtbl.create 7) ty + simple_abbrevs () := Mnil; + try generalize_expansive env !(nongen_level ()) (Hashtbl.create 7) ty with Unify ([(_, ty')] as tr) -> raise (Unify ((ty, ty') :: tr)) -let generalize_structure ty = generalize_structure !current_level ty +let generalize_structure ty = generalize_structure !(current_level ()) ty (* Correct the levels of type [ty]. *) let correct_levels ty = duplicate_type ty @@ -710,7 +742,8 @@ let rec find_repr p1 = function marks and the temporary mutability links installed by [copy_type_desc]. *) -let abbreviations = ref (ref Mnil) +let abbreviations_key = Request_local.new_key (fun () -> ref (ref Mnil)) +let abbreviations () = Domain.DLS.get abbreviations_key (* Abbreviation memorized. *) (* partial: we may not wish to copy the non generic types @@ -732,7 +765,7 @@ let rec copy ?env ?partial ?keep_names ty = | None -> assert false | Some (free_univars, keep) -> if Type_set.is_empty (free_univars ty) then - if keep then ty.level else !current_level + if keep then ty.level else !(current_level ()) else generic_level in if forget <> generic_level then newty2 forget (Tvar None) @@ -751,7 +784,7 @@ let rec copy ?env ?partial ?keep_names ty = t.desc <- (match desc with | Tconstr (p, tl, _) -> ( - let abbrevs = proper_abbrevs p tl !abbreviations in + let abbrevs = proper_abbrevs p tl !(abbreviations ()) in match find_repr p !abbrevs with | Some ty when repr ty != t -> Tlink ty | _ -> @@ -768,8 +801,8 @@ let rec copy ?env ?partial ?keep_names ty = ( p, List.map copy tl, ref - (match !(!abbreviations) with - | Mcons _ -> Mlink !abbreviations + (match !(!(abbreviations ())) with + | Mcons _ -> Mlink !(abbreviations ()) | abbrev -> abbrev) )) | Tvariant row0 -> ( let row = row_repr row0 in @@ -810,7 +843,9 @@ let rec copy ?env ?partial ?keep_names ty = let more' = if more.id != more'.id then more' else - let lv = if keep then more.level else !current_level in + let lv = + if keep then more.level else !(current_level ()) + in newty2 lv (Tvar None) in let not_reither (_, f) = @@ -865,15 +900,18 @@ let instance_list env schl = let env = gadt_env env in List.map (fun t -> copy ?env t) schl) -let reified_var_counter = ref Vars.empty -let reset_reified_var_counter () = reified_var_counter := Vars.empty +let reified_var_counter_key = Request_local.new_key (fun () -> ref Vars.empty) +let reified_var_counter () = Domain.DLS.get reified_var_counter_key +let reset_reified_var_counter () = reified_var_counter () := Vars.empty (* names given to new type constructors. Used for existential types and local constraints *) let get_new_abstract_name s = - let index = try Vars.find s !reified_var_counter + 1 with Not_found -> 0 in - reified_var_counter := Vars.add s index !reified_var_counter; + let index = + try Vars.find s !(reified_var_counter ()) + 1 with Not_found -> 0 + in + reified_var_counter () := Vars.add s index !(reified_var_counter ()); if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else Printf.sprintf "%s%d" s index @@ -963,7 +1001,8 @@ let conflicts free bound = let bound = List.map repr bound in Type_set.exists (fun t -> List.memq (repr t) bound) free -let delayed_copy = ref [] +let delayed_copy_key = Request_local.new_key (fun () -> ref []) +let delayed_copy () = Domain.DLS.get delayed_copy_key (* copying to do later *) (* Copy without sharing until there are no free univars left *) @@ -975,7 +1014,7 @@ let rec copy_sep fixed free bound visited ty = if ty.level <> generic_level then ty else let t = newvar () in - delayed_copy := lazy (t.desc <- Tlink (copy ty)) :: !delayed_copy; + delayed_copy () := lazy (t.desc <- Tlink (copy ty)) :: !(delayed_copy ()); t) else try @@ -1026,10 +1065,10 @@ let instance_poly ?(keep_names = false) ~fixed univars sch = in let vars = List.map copy_var univars in let pairs = List.map2 (fun u v -> (u, (v, []))) univars vars in - delayed_copy := []; + delayed_copy () := []; let ty = copy_sep fixed (compute_univars sch) [] pairs sch in - List.iter Lazy.force !delayed_copy; - delayed_copy := []; + List.iter Lazy.force !(delayed_copy ()); + delayed_copy () := []; (vars, ty)) let instance_label fixed lbl = @@ -1050,8 +1089,8 @@ let unify' = let subst env level priv abbrev ty params args body = if List.length params <> List.length args then raise (Unify []); - let old_level = !current_level in - current_level := level; + let old_level = !(current_level ()) in + current_level () := level; try let body0 = newvar () in (* Stub *) @@ -1061,15 +1100,15 @@ let subst env level priv abbrev ty params args body = let abbrev = proper_abbrevs path tl abbrev in memorize_abbrev abbrev priv path ty body0 | _ -> assert false); - abbreviations := abbrev; + abbreviations () := abbrev; let params', body' = instance_parameterized_type params body in - abbreviations := ref Mnil; + abbreviations () := ref Mnil; !unify' env body0 body'; List.iter2 (!unify' env) params' args; - current_level := old_level; + current_level () := old_level; body' with Unify _ as exn -> - current_level := old_level; + current_level () := old_level; raise exn (* @@ -1094,14 +1133,15 @@ let () = Subst.ctype_apply_env_empty := apply Env.empty quite pessimistic: it would be enough to flush the cache when a type or module definition is overridden in the environment. *) -let previous_env = ref Env.empty +let previous_env_key = Request_local.new_key (fun () -> ref Env.empty) +let previous_env () = Domain.DLS.get previous_env_key (*let string_of_kind = function Public -> "public" | Private -> "private"*) let check_abbrev_env env = - if env != !previous_env then ( + if env != !(previous_env ()) then ( (* prerr_endline "cleanup expansion cache"; *) cleanup_abbrev (); - previous_env := env) + previous_env () := env) (* Expand an abbreviation. The expansion is memorized. *) (* @@ -1154,7 +1194,7 @@ let expand_abbrev_gen kind find_type_expansion env ty = let ty' = subst env level kind abbrev (Some ty) params args body in (* For gadts, remember type as non exportable *) (* The ambiguous level registered for ty' should be the highest *) - (if !trace_gadt_instances then + (if !(trace_gadt_instances ()) then match Ext_pervasives.max_int_option lv (Env.gadt_instance_level env ty) with @@ -1343,24 +1383,27 @@ let rec occur_rec env allow_recursive visited ty0 = function let visited = Type_set.add ty visited in iter_type_expr (occur_rec env allow_recursive visited ty0) ty) -let type_changed = ref false (* trace possible changes to the studied type *) +let type_changed_key = + Request_local.new_key (fun () -> + ref false (* trace possible changes to the studied type *)) +let type_changed () = Domain.DLS.get type_changed_key let merge r b = if b then r := true let occur env ty0 ty = - let allow_recursive = (*!Clflags.recursive_types ||*) !umode = Pattern in - let old = !type_changed in + let allow_recursive = (*!Clflags.recursive_types ||*) !(umode ()) = Pattern in + let old = !(type_changed ()) in try while - type_changed := false; + type_changed () := false; occur_rec env allow_recursive Type_set.empty ty0 ty; - !type_changed + !(type_changed ()) do () (* prerr_endline "changed" *) done; - merge type_changed old + merge (type_changed ()) old with exn -> - merge type_changed old; + merge (type_changed ()) old; raise (match exn with | Occur -> Unify [] @@ -1555,7 +1598,8 @@ let enter_poly env univar_pairs t1 tl1 t2 tl2 f = univar_pairs := old_univars; raise exn -let univar_pairs = ref [] +let univar_pairs_key = Request_local.new_key (fun () -> ref []) +let current_univar_pairs () = Domain.DLS.get univar_pairs_key (*****************) (* Unification *) @@ -1631,10 +1675,11 @@ let deep_occur t0 ty = information is indeed lost, but it probably does not worth it. *) -let newtype_level = ref None +let newtype_level_key = Request_local.new_key (fun () -> ref None) +let current_newtype_level () = Domain.DLS.get newtype_level_key let get_newtype_level () = - match !newtype_level with + match !(current_newtype_level ()) with | None -> assert false | Some x -> x @@ -1789,8 +1834,10 @@ let rec mcomp type_pairs env t1 t2 = | Tnil, Tnil -> () | Tpoly (t1, []), Tpoly (t2, []) -> mcomp type_pairs env t1 t2 | Tpoly (t1, tl1), Tpoly (t2, tl2) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 (mcomp type_pairs env) - | Tunivar _, Tunivar _ -> unify_univar t1' t2' !univar_pairs + enter_poly env (current_univar_pairs ()) t1 tl1 t2 tl2 + (mcomp type_pairs env) + | Tunivar _, Tunivar _ -> + unify_univar t1' t2' !(current_univar_pairs ()) | _, _ -> raise (Unify []))) and mcomp_list type_pairs env tl1 tl2 = @@ -1928,12 +1975,13 @@ let add_gadt_equation env source destination = env := Env.add_local_constraint source decl newtype_level !env; cleanup_abbrev ()) -let unify_eq_set = Type_pairs.create 11 +let unify_eq_set_key = Request_local.new_key (fun () -> Type_pairs.create 11) +let unify_eq_set () = Domain.DLS.get unify_eq_set_key let order_type_pair t1 t2 = if t1.id <= t2.id then (t1, t2) else (t2, t1) let add_type_equality t1 t2 = - Type_pairs.add unify_eq_set (order_type_pair t1 t2) () + Type_pairs.add (unify_eq_set ()) (order_type_pair t1 t2) () let eq_package_path env p1 p2 = Path.same p1 p2 @@ -1952,10 +2000,10 @@ let nondep_instance env level id ty = let ty = !nondep_type' env id ty in if level = generic_level then duplicate_type ty else - let old = !current_level in - current_level := level; + let old = !(current_level ()) in + current_level () := level; let ty = instance env ty in - current_level := old; + current_level () := old; ty (* Find the type paths nl1 in the module type mty2, and add them to the @@ -2009,33 +2057,35 @@ let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 = else raise Not_found (* force unification in Reither when one side has a non-conjunctive type *) -let rigid_variants = ref false +let rigid_variants_key = Request_local.new_key (fun () -> ref false) +let rigid_variants () = Domain.DLS.get rigid_variants_key (* drop not force unification in Reither, even in fixed case (not sound, only use it when checking exhaustiveness) *) -let passive_variants = ref false +let passive_variants_key = Request_local.new_key (fun () -> ref false) +let passive_variants () = Domain.DLS.get passive_variants_key let with_passive_variants f x = - if !passive_variants then f x + if !(passive_variants ()) then f x else match - passive_variants := true; + passive_variants () := true; f x with | r -> - passive_variants := false; + passive_variants () := false; r | exception e -> - passive_variants := false; + passive_variants () := false; raise e let unify_eq t1 t2 = t1 == t2 || - match !umode with + match !(umode ()) with | Expression -> false | Pattern -> ( try - Type_pairs.find unify_eq_set (order_type_pair t1 t2); + Type_pairs.find (unify_eq_set ()) (order_type_pair t1 t2); true with Not_found -> false) @@ -2061,14 +2111,14 @@ let rec unify (env : Env.t ref) t1 t2 = let reset_tracing = check_trace_gadt_instances !env in try - type_changed := true; + type_changed () := true; (match (t1.desc, t2.desc) with | Tvar _, Tconstr _ when deep_occur t1 t2 -> unify2 env t1 t2 | Tconstr _, Tvar _ when deep_occur t2 t1 -> unify2 env t1 t2 | Tvar _, _ -> unify1_var !env t1 t2 | _, Tvar _ -> unify1_var !env t2 t1 | Tunivar _, Tunivar _ -> - unify_univar t1 t2 !univar_pairs; + unify_univar t1 t2 !(current_univar_pairs ()); update_level !env t1.level t2; link_type t1 t2 | Tconstr (p1, [], a1), Tconstr (p2, [], a2) @@ -2112,7 +2162,7 @@ and unify2 env t1 t2 = if unify_eq t1' t2' then () else let t1 = repr t1 and t2 = repr t2 in - (if !trace_gadt_instances then + (if !(trace_gadt_instances ()) then (* All types in chains already have the same ambiguity levels *) let ilevel t = match Env.gadt_instance_level !env t with @@ -2137,7 +2187,7 @@ and unify3 env t1 t1' t2 t2' = match (d1, d2) with (* handle vars and univars specially *) | Tunivar _, Tunivar _ -> - unify_univar t1' t2' !univar_pairs; + unify_univar t1' t2' !(current_univar_pairs ()); link_type t1' t2' | Tvar _, _ -> occur !env t1' t2; @@ -2151,7 +2201,7 @@ and unify3 env t1 t1' t2 t2' = (* special case for GADTs *) unify_fields env t1' t2' | _ -> ( - (match !umode with + (match !(umode ()) with | Expression -> occur !env t1' t2'; link_type t1' t2 @@ -2163,7 +2213,7 @@ and unify3 env t1 t1' t2 t2' = && List.for_all2 (fun (a1 : Types.arg) (a2 : Types.arg) -> Asttypes.same_arg_label a1.lbl a2.lbl - || !umode = Pattern + || !(umode ()) = Pattern && not (is_optional a1.lbl || is_optional a2.lbl)) params1 params2 -> List.iter2 @@ -2172,9 +2222,9 @@ and unify3 env t1 t1' t2 t2' = unify env ret1 ret2 | Ttuple tl1, Ttuple tl2 -> unify_list env tl1 tl2 | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2 -> - if !umode = Expression || not !generate_equations then + if !(umode ()) = Expression || not !(generate_equations ()) then unify_list env tl1 tl2 - else if !assume_injective then + else if !(assume_injective ()) then set_mode_pattern ~generate:true ~injective:false (fun () -> unify_list env tl1 tl2) else if @@ -2201,7 +2251,7 @@ and unify3 env t1 t1' t2 t2' = inj (List.combine tl1 tl2) | Tconstr (path, [], _), Tconstr (path', [], _) when is_instantiable !env path && is_instantiable !env path' - && !generate_equations -> + && !(generate_equations ()) -> let[@local] ( > ) ((a : int), (b : int)) (c, d) = a > c || (a = c && b > d) in @@ -2212,20 +2262,21 @@ and unify3 env t1 t1' t2 t2' = in add_gadt_equation env source destination | Tconstr (path, [], _), _ - when is_instantiable !env path && !generate_equations -> + when is_instantiable !env path && !(generate_equations ()) -> reify env t2'; add_gadt_equation env path t2' | _, Tconstr (path, [], _) - when is_instantiable !env path && !generate_equations -> + when is_instantiable !env path && !(generate_equations ()) -> reify env t1'; add_gadt_equation env path t1' - | (Tconstr (_, _, _), _ | _, Tconstr (_, _, _)) when !umode = Pattern -> + | (Tconstr (_, _, _), _ | _, Tconstr (_, _, _)) when !(umode ()) = Pattern + -> reify env t1'; reify env t2'; - if !generate_equations then mcomp !env t1' t2' + if !(generate_equations ()) then mcomp !env t1' t2' | Tobject fi1, Tobject fi2 -> unify_fields env fi1 fi2 | Tvariant row1, Tvariant row2 -> ( - if !umode = Expression then unify_row env row1 row2 + if !(umode ()) = Expression then unify_row env row1 row2 else let snap = snapshot () in try unify_row env row1 row2 @@ -2233,19 +2284,20 @@ and unify3 env t1 t1' t2 t2' = backtrack snap; reify env t1'; reify env t2'; - if !generate_equations then mcomp !env t1' t2') + if !(generate_equations ()) then mcomp !env t1' t2') | Tnil, Tnil -> () | Tpoly (t1, []), Tpoly (t2, []) -> unify env t1 t2 | Tpoly (t1, tl1), Tpoly (t2, tl2) -> - enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env) + enter_poly !env (current_univar_pairs ()) t1 tl1 t2 tl2 (unify env) | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) -> ( try unify_package !env (unify_list env) t1.level p1 n1 tl1 t2.level p2 n2 tl2 with Not_found -> - if !umode = Expression then raise (Unify []); + if !(umode ()) = Expression then raise (Unify []); List.iter (reify env) (tl1 @ tl2) - (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *)) + (* if !(generate_equations ()) then List.iter2 (mcomp !env) tl1 tl2 *) + ) | _, _ -> raise (Unify [])); (* XXX Commentaires + changer "create_recursion" ||| Comments + change "create_recursion" *) @@ -2311,7 +2363,7 @@ and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = (fun (f1, f2) -> unify_mutability ~open1 ~open2 f1 f2; try - if !trace_gadt_instances then update_level !env va.level f1.f_typ; + if !(trace_gadt_instances ()) then update_level !env va.level f1.f_typ; unify env f1.f_typ f2.f_typ with Unify trace -> raise @@ -2430,8 +2482,8 @@ and unify_row env row1 row2 = raise (Unify [(if row == row1 then (t1, t2) else (t2, t1))])); (* The following test is not principal... should rather use Tnil *) let rm = row_more row in - (*if !trace_gadt_instances && rm.desc = Tnil then () else*) - if !trace_gadt_instances then + (*if !(trace_gadt_instances ()) && rm.desc = Tnil then () else*) + if !(trace_gadt_instances ()) then update_level !env rm.level (newgenty (Tvariant row)); if row_fixed row then if more == rm then () @@ -2485,10 +2537,10 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = List.iter2 (unify env) tl1 tl2) else let redo = - (not !passive_variants) + (not !(passive_variants ())) && (m1 || m2 || fixed1 || fixed2 - || (!rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) - ) + || !(rigid_variants ()) + && (List.length tl1 = 1 || List.length tl2 = 1)) && match tl1 @ tl2 with | [] -> false @@ -2520,7 +2572,8 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = | [], [] -> () | tu1 :: tlu1, _ :: _ -> (* Attempt to merge all the types containing univars *) - if not !passive_variants then List.iter (unify env tu1) (tlu1 @ tlu2) + if not !(passive_variants ()) then + List.iter (unify env tu1) (tlu1 @ tlu2) | tu :: _, [] | [], tu :: _ -> occur_univar !env tu); (* Is this handling of levels really principal? *) List.iter (update_level !env (repr more).level) (tl1' @ tl2'); @@ -2561,15 +2614,15 @@ let unify env ty1 ty2 = let unify_gadt ~newtype_level:lev (env : Env.t ref) ty1 ty2 = try - univar_pairs := []; - newtype_level := Some lev; + current_univar_pairs () := []; + current_newtype_level () := Some lev; set_mode_pattern ~generate:true ~injective:true (fun () -> unify env ty1 ty2); - newtype_level := None; - Type_pairs.clear unify_eq_set + current_newtype_level () := None; + Type_pairs.clear (unify_eq_set ()) with e -> - newtype_level := None; - Type_pairs.clear unify_eq_set; + current_newtype_level () := None; + Type_pairs.clear (unify_eq_set ()); raise e let unify_var env t1 t2 = @@ -2594,7 +2647,7 @@ let unify_var env t1 t2 = let _ = unify' := unify_var let unify_pairs env ty1 ty2 pairs = - univar_pairs := pairs; + current_univar_pairs () := pairs; unify env ty1 ty2 let unify env ty1 ty2 = unify_pairs (ref env) ty1 ty2 [] @@ -2806,9 +2859,10 @@ let rec moregen inst_nongen type_pairs env t1 t2 = | Tpoly (t1, []), Tpoly (t2, []) -> moregen inst_nongen type_pairs env t1 t2 | Tpoly (t1, tl1), Tpoly (t2, tl2) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 + enter_poly env (current_univar_pairs ()) t1 tl1 t2 tl2 (moregen inst_nongen type_pairs env) - | Tunivar _, Tunivar _ -> unify_univar t1' t2' !univar_pairs + | Tunivar _, Tunivar _ -> + unify_univar t1' t2' !(current_univar_pairs ()) | _, _ -> raise (Unify []))) with Unify trace -> raise (Unify ((t1, t2) :: trace)) @@ -2867,7 +2921,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 = if r1 <> [] || (row1.row_closed && ((not row2.row_closed) || r2 <> [])) then raise (Unify []); (match (rm1.desc, rm2.desc) with - | Tunivar _, Tunivar _ -> unify_univar rm1 rm2 !univar_pairs + | Tunivar _, Tunivar _ -> unify_univar rm1 rm2 !(current_univar_pairs ()) | Tunivar _, _ | _, Tunivar _ -> raise (Unify []) | _ when static_row row1 -> () | _ when may_inst -> @@ -2912,7 +2966,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 = (* Must empty univar_pairs first *) let moregen inst_nongen type_pairs env patt subj = - univar_pairs := []; + current_univar_pairs () := []; moregen inst_nongen type_pairs env patt subj (* @@ -2924,8 +2978,8 @@ let moregen inst_nongen type_pairs env patt subj = is unimportant. So, no need to propagate abbreviations. *) let moregeneral env inst_nongen pat_sch subj_sch = - let old_level = !current_level in - current_level := generic_level - 1; + let old_level = !(current_level ()) in + current_level () := generic_level - 1; (* Generic variables are first duplicated with [instance]. So, their levels are lowered to [generic_level - 1]. The subject is @@ -2933,7 +2987,7 @@ let moregeneral env inst_nongen pat_sch subj_sch = changed. *) let subj = duplicate_type (instance env subj_sch) in - current_level := generic_level; + current_level () := generic_level; (* Duplicate generic variables *) let patt = instance env pat_sch in let res = @@ -2942,7 +2996,7 @@ let moregeneral env inst_nongen pat_sch subj_sch = true with Unify _ -> false in - current_level := old_level; + current_level () := old_level; res (* Alternative approach: "rigidify" a type scheme, @@ -3004,10 +3058,10 @@ let matches env ty ty' = (*********************************************) let expand_head_rigid env ty = - let old = !rigid_variants in - rigid_variants := true; + let old = !(rigid_variants ()) in + rigid_variants () := true; let ty' = expand_head env ty in - rigid_variants := old; + rigid_variants () := old; ty' let normalize_subst subst = @@ -3088,9 +3142,10 @@ let rec eqtype rename type_pairs subst env t1 t2 = | Tpoly (t1, []), Tpoly (t2, []) -> eqtype rename type_pairs subst env t1 t2 | Tpoly (t1, tl1), Tpoly (t2, tl2) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 + enter_poly env (current_univar_pairs ()) t1 tl1 t2 tl2 (eqtype rename type_pairs subst env) - | Tunivar _, Tunivar _ -> unify_univar t1' t2' !univar_pairs + | Tunivar _, Tunivar _ -> + unify_univar t1' t2' !(current_univar_pairs ()) | _, _ -> raise (Unify []))) with Unify trace -> raise (Unify ((t1, t2) :: trace)) @@ -3180,7 +3235,7 @@ and eqtype_row rename type_pairs subst env row1 row2 = (* Must empty univar_pairs first *) let eqtype_list rename type_pairs subst env tl1 tl2 = - univar_pairs := []; + current_univar_pairs () := []; let snap = Btype.snapshot () in try eqtype_list rename type_pairs subst env tl1 tl2; @@ -3213,7 +3268,10 @@ let equal env rename tyl1 tyl2 = [posi] true if the current variance is positive [level] number of expansions/enlargement allowed on this branch *) -let warn = ref false (* whether double coercion might do better *) +let warn_key = + Request_local.new_key (fun () -> + ref false (* whether double coercion might do better *)) +let warn () = Domain.DLS.get warn_key let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n let pred_enlarge n = if n mod 2 = 1 then pred n else n @@ -3230,7 +3288,7 @@ let rec filter_visited = function let memq_warn t visited = if List.memq t visited then ( - warn := true; + warn () := true; true) else false @@ -3253,7 +3311,7 @@ let rec build_subtype env visited loops posi level t = if posi then try let t' = List.assq t loops in - warn := true; + warn () := true; (t', Equiv) with Not_found -> (t, Unchanged) else (t, Unchanged) @@ -3304,7 +3362,7 @@ let rec build_subtype env visited loops posi level t = if level = 0 && generic_abbrev env p && safe_abbrev env t && not (has_constr_row' env t) - then warn := true; + then warn () := true; let tl' = List.map2 (fun v t -> @@ -3400,7 +3458,7 @@ let rec build_subtype env visited loops posi level t = let v = newvar () in (v, Changed) else ( - warn := true; + warn () := true; (t, Unchanged)) | Tsubst _ | Tlink _ -> assert false | Tpoly (t1, tl) -> @@ -3409,10 +3467,10 @@ let rec build_subtype env visited loops posi level t = | Tunivar _ | Tpackage _ -> (t, Unchanged) let enlarge_type env ty = - warn := false; + warn () := false; (* [level = 4] allows 2 expansions involving objects/variants *) let ty', _ = build_subtype env [] [] true 4 ty in - (ty', !warn) + (ty', !(warn ())) (**** Check whether a type is a subtype of another type. ****) @@ -3430,7 +3488,8 @@ let enlarge_type env ty = [generic_abbrev ...]). *) -let subtypes = Type_pairs.create 17 +let subtypes_key = Request_local.new_key (fun () -> Type_pairs.create 17) +let subtypes () = Domain.DLS.get subtypes_key let subtype_error ?ctx env trace = raise (Subtype (expand_trace env (List.rev trace), [], ctx)) @@ -3446,12 +3505,13 @@ let rec subtype_rec env trace t1 t2 cstrs = if t1 == t2 then cstrs else try - Type_pairs.find subtypes (t1, t2); + Type_pairs.find (subtypes ()) (t1, t2); cstrs with Not_found -> ( - Type_pairs.add subtypes (t1, t2) (); + Type_pairs.add (subtypes ()) (t1, t2) (); match (t1.desc, t2.desc) with - | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs + | Tvar _, _ | _, Tvar _ -> + (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs | Tarrow (params1, ret1), Tarrow (params2, ret2) when List.length params1 = List.length params2 && List.for_all2 @@ -3492,14 +3552,15 @@ let rec subtype_rec env trace t1 t2 cstrs = ( trace, newty2 t1.level (Ttuple [t1]), newty2 t2.level (Ttuple [t2]), - !univar_pairs, + !(current_univar_pairs ()), None ) :: cstrs else subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs else if cn then subtype_rec env ((t2, t1) :: trace) t2 t1 cstrs else cstrs) cstrs decl.type_variance (List.combine tl1 tl2) - with Not_found -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + with Not_found -> + (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs) | Tconstr (p1, _, _), _ when generic_private_abbrev env p1 -> subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs | Tconstr (p1, [], _), Tconstr (p2, [], _) @@ -3523,7 +3584,7 @@ let rec subtype_rec env trace t1 t2 cstrs = ( trace, t1, t2, - !univar_pairs, + !(current_univar_pairs ()), Some (Coercion_target_variant_not_unboxed {variant_name = p; primitive = path}) ) @@ -3537,14 +3598,18 @@ let rec subtype_rec env trace t1 t2 cstrs = ( trace, t1, t2, - !univar_pairs, + !(current_univar_pairs ()), Some (Coercion_target_variant_does_not_cover_type {variant_name = p; primitive = path}) ) :: cstrs | None -> (* Unclear when this case actually happens. *) - (trace, t1, t2, !univar_pairs, Some (Generic {error_code = "VCPMMVD"})) + ( trace, + t1, + t2, + !(current_univar_pairs ()), + Some (Generic {error_code = "VCPMMVD"}) ) :: cstrs) | Tconstr (_, [], _), Tconstr (path, [], _) when Variant_coercion.can_coerce_primitive path @@ -3567,14 +3632,14 @@ let rec subtype_rec env trace t1 t2 cstrs = ( trace, t1, t2, - !univar_pairs, + !(current_univar_pairs ()), Some (Variant_constructor_runtime_representation_mismatch {issues = runtime_representation_issues; variant_name = p}) ) :: cstrs else cstrs - | None -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | None -> (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs) | Tconstr (_, [], _), Tconstr (_, [], _) -> ( (* type coercion for variants and records *) match @@ -3610,7 +3675,7 @@ let rec subtype_rec env trace t1 t2 cstrs = ( trace, t1, t2, - !univar_pairs, + !(current_univar_pairs ()), Some (Variant_configurations_mismatch {left_variant_name = p1; right_variant_name = p2; issue}) ) @@ -3632,7 +3697,7 @@ let rec subtype_rec env trace t1 t2 cstrs = ( trace, t1, t2, - !univar_pairs, + !(current_univar_pairs ()), Some (Variant_configurations_mismatch { @@ -3710,7 +3775,7 @@ let rec subtype_rec env trace t1 t2 cstrs = |> List.filter_map Fun.id in if field_subtype_violations = [] then cstrs - else (trace, t1, t2, !univar_pairs, None) :: cstrs) + else (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs) | ( (p1, _, {type_kind = Type_record (fields1, repr1)}), (p2, _, {type_kind = Type_record (fields2, repr2)}) ) -> let same_repr = @@ -3730,7 +3795,7 @@ let rec subtype_rec env trace t1 t2 cstrs = ( trace, t1, t2, - !univar_pairs, + !(current_univar_pairs ()), Some (Record_fields_mismatch { @@ -3744,14 +3809,14 @@ let rec subtype_rec env trace t1 t2 cstrs = ( trace, t1, t2, - !univar_pairs, + !(current_univar_pairs ()), None (* TODO(subtype-errors) Record representation *) ) :: cstrs | (p1, _, {type_kind = tk1}), (p2, _, {type_kind = tk2}) -> ( trace, t1, t2, - !univar_pairs, + !(current_univar_pairs ()), Some (Different_type_kinds { @@ -3761,17 +3826,19 @@ let rec subtype_rec env trace t1 t2 cstrs = right_type_kind = tk2; }) ) :: cstrs - | exception Not_found -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | exception Not_found -> + (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs) (* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 -> subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *) | Tobject f1, Tobject f2 when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> (* Same row variable implies same object. *) - (trace, t1, t2, !univar_pairs, None) :: cstrs + (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs | Tobject f1, Tobject f2 -> subtype_fields env trace f1 f2 cstrs | Tvariant row1, Tvariant row2 -> ( try subtype_row env trace row1 row2 cstrs - with Exit -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + with Exit -> + (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs) | Tvariant {row_closed = true; row_fields}, Tconstr (_, [], _) when extract_concrete_typedecl_opt env t2 |> Variant_coercion.type_is_variant -> ( @@ -3792,8 +3859,9 @@ let rec subtype_rec env trace t1 t2 cstrs = ~variant_constructors ~layout ~unboxed with | Ok _ -> cstrs - | Error _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) - | _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | Error _ -> + (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs) + | _ -> (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs) | Tvariant v, _ when !variant_is_subtype env (row_repr v) t2 -> cstrs | Tpoly (u1, []), Tpoly (u2, []) -> subtype_rec env trace u1 u2 cstrs | Tpoly (u1, tl1), Tpoly (u2, []) -> @@ -3801,9 +3869,10 @@ let rec subtype_rec env trace t1 t2 cstrs = subtype_rec env trace u1' u2 cstrs | Tpoly (u1, tl1), Tpoly (u2, tl2) -> ( try - enter_poly env univar_pairs u1 tl1 u2 tl2 (fun t1 t2 -> + enter_poly env (current_univar_pairs ()) u1 tl1 u2 tl2 (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs) - with Unify _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + with Unify _ -> + (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs) | Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2) -> ( try let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1 @@ -3814,7 +3883,7 @@ let rec subtype_rec env trace t1 t2 cstrs = let cstrs' = List.map (fun (n2, t2) -> - (trace, List.assoc n2 ntl1, t2, !univar_pairs, None)) + (trace, List.assoc n2 ntl1, t2, !(current_univar_pairs ()), None)) ntl2 in if eq_package_path env p1 p2 then cstrs' @ cstrs @@ -3830,8 +3899,9 @@ let rec subtype_rec env trace t1 t2 cstrs = with Unify _ -> Btype.backtrack snap; raise Not_found - with Not_found -> (trace, t1, t2, !univar_pairs, None) :: cstrs) - | _, _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + with Not_found -> + (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs) + | _, _ -> (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs) and subtype_list env trace tl1 tl2 cstrs = if List.length tl1 <> List.length tl2 then subtype_error env trace; @@ -3852,7 +3922,7 @@ and subtype_fields env trace ty1 ty2 cstrs = ( trace, build_fields (repr ty1).level miss1 rest1, rest2, - !univar_pairs, + !(current_univar_pairs ()), None ) :: cstrs in @@ -3862,7 +3932,7 @@ and subtype_fields env trace ty1 ty2 cstrs = ( trace, rest1, build_fields (repr ty2).level miss2 (newvar ()), - !univar_pairs, + !(current_univar_pairs ()), None ) :: cstrs in @@ -3902,7 +3972,7 @@ and subtype_fields env trace ty1 ty2 cstrs = rest = newvar (); }) in - (trace, src, tgt, !univar_pairs, None) :: cstrs) + (trace, src, tgt, !(current_univar_pairs ()), None) :: cstrs) cstrs pairs and subtype_row env trace row1 row2 cstrs = @@ -3943,11 +4013,11 @@ and subtype_row env trace row1 row2 cstrs = | _ -> raise Exit let subtype env ty1 ty2 = - Type_pairs.clear subtypes; - univar_pairs := []; + Type_pairs.clear (subtypes ()); + current_univar_pairs () := []; (* Build constraint set. *) let cstrs = subtype_rec env [(ty1, ty2)] ty1 ty2 [] in - Type_pairs.clear subtypes; + Type_pairs.clear (subtypes ()); (* Enforce constraints. *) function | () -> @@ -4008,21 +4078,22 @@ let cyclic_abbrev env id ty = (* Check for non-generalizable type variables *) exception Non_closed0 -let visited = ref Type_set.empty +let visited_key = Request_local.new_key (fun () -> ref Type_set.empty) +let visited () = Domain.DLS.get visited_key let rec closed_schema_rec env ty = let ty = repr ty in - if Type_set.mem ty !visited then () + if Type_set.mem ty !(visited ()) then () else ( - visited := Type_set.add ty !visited; + visited () := Type_set.add ty !(visited ()); match ty.desc with | Tvar _ when ty.level <> generic_level -> raise Non_closed0 | Tconstr _ -> ( - let old = !visited in + let old = !(visited ()) in try iter_type_expr (closed_schema_rec env) ty with Non_closed0 -> ( try - visited := old; + visited () := old; closed_schema_rec env (try_expand_head try_expand_safe env ty) with Cannot_expand -> raise Non_closed0)) | Tfield {typ = t1; rest = t2} -> @@ -4036,13 +4107,13 @@ let rec closed_schema_rec env ty = (* Return whether all variables of type [ty] are generic. *) let closed_schema env ty = - visited := Type_set.empty; + visited () := Type_set.empty; try closed_schema_rec env ty; - visited := Type_set.empty; + visited () := Type_set.empty; true with Non_closed0 -> - visited := Type_set.empty; + visited () := Type_set.empty; false (* Normalize a type before printing, saving... *) @@ -4119,11 +4190,13 @@ let normalize_type env ty = normalize_type_rec env (ref Type_set.empty) ty expand_abbrev. *) -let nondep_hash = Type_hash.create 47 -let nondep_variants = Type_hash.create 17 +let nondep_hash_key = Request_local.new_key (fun () -> Type_hash.create 47) +let nondep_hash () = Domain.DLS.get nondep_hash_key +let nondep_variants_key = Request_local.new_key (fun () -> Type_hash.create 17) +let nondep_variants () = Domain.DLS.get nondep_variants_key let clear_hash () = - Type_hash.clear nondep_hash; - Type_hash.clear nondep_variants + Type_hash.clear (nondep_hash ()); + Type_hash.clear (nondep_variants ()) let with_nondep_copy_session f = (* [nondep_type_rec] cannot use [Tsubst] because abbreviation expansion can @@ -4145,11 +4218,11 @@ let rec nondep_type_rec env id ty = | Tvar _ | Tunivar _ -> ty | Tlink ty -> nondep_type_rec env id ty | _ -> ( - try Type_hash.find nondep_hash ty + try Type_hash.find (nondep_hash ()) ty with Not_found -> let ty' = newgenvar () in (* Stub *) - Type_hash.add nondep_hash ty ty'; + Type_hash.add (nondep_hash ()) ty ty'; ty'.desc <- (match ty.desc with | Tconstr (p, tl, _abbrev) -> @@ -4176,13 +4249,13 @@ let rec nondep_type_rec env id ty = let more = repr row.row_more in (* We must keep sharing according to the row variable *) try - let ty2 = Type_hash.find nondep_variants more in + let ty2 = Type_hash.find (nondep_variants ()) more in (* This variant type has been already copied *) - Type_hash.add nondep_hash ty ty2; + Type_hash.add (nondep_hash ()) ty ty2; Tlink ty2 with Not_found -> ( (* Register new type first for recursion *) - Type_hash.add nondep_variants more ty'; + Type_hash.add (nondep_variants ()) more ty'; let static = static_row row in let more' = if static then newgenty Tnil else more in (* Return a new copy *) diff --git a/compiler/ml/delayed_checks.ml b/compiler/ml/delayed_checks.ml index 631425ce6d0..f6a4d6739c3 100644 --- a/compiler/ml/delayed_checks.ml +++ b/compiler/ml/delayed_checks.ml @@ -1,7 +1,9 @@ -let delayed_checks = ref [] -let reset_delayed_checks () = delayed_checks := [] -let add_delayed_check f = - delayed_checks := (f, Warnings.backup ()) :: !delayed_checks +(* A delayed check closes over the typing environment and warning state of the + request that registered it. Another domain must not reset or force it. *) +let delayed_checks = Request_local.new_key (fun () -> ref []) +let checks () = Domain.DLS.get delayed_checks +let reset_delayed_checks () = checks () := [] +let add_delayed_check f = checks () := (f, Warnings.backup ()) :: !(checks ()) let force_delayed_checks () = (* checks may change type levels *) @@ -11,7 +13,7 @@ let force_delayed_checks () = (fun (f, w) -> Warnings.restore w; f ()) - (List.rev !delayed_checks); + (List.rev !(checks ())); Warnings.restore w_old; reset_delayed_checks (); Btype.backtrack snap diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 1f386d89853..3763262d1fb 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -54,10 +54,13 @@ let rec lookup_map lid m = (* Collect free module identifiers in the a.s.t. *) -let free_structure_names = ref String_set.empty +let free_structure_names_key = + Request_local.new_key (fun () -> ref String_set.empty) + +let free_structure_names () = Domain.DLS.get free_structure_names_key let add_names s = - free_structure_names := String_set.union s !free_structure_names + free_structure_names () := String_set.union s !(free_structure_names ()) let rec add_path bv ?(p = []) = function | Lident s -> @@ -162,7 +165,8 @@ let add_type_extension bv te = add bv te.ptyext_path; List.iter (add_extension_constructor bv) te.ptyext_constructors -let pattern_bv = ref String_map.empty +let pattern_bv_key = Request_local.new_key (fun () -> ref String_map.empty) +let pattern_bv () = Domain.DLS.get pattern_bv_key let rec add_pattern bv pat = match pat.ppat_desc with @@ -192,14 +196,15 @@ let rec add_pattern bv pat = add_type bv ty | Ppat_variant (_, {txt = args}) -> List.iter (add_pattern bv) args | Ppat_type li | Ppat_variant_spread li -> add bv li - | Ppat_unpack id -> pattern_bv := String_map.add id.txt bound !pattern_bv + | Ppat_unpack id -> + pattern_bv () := String_map.add id.txt bound !(pattern_bv ()) | Ppat_exception p -> add_pattern bv p | Ppat_extension e -> handle_extension e let add_pattern bv pat = - pattern_bv := bv; + pattern_bv () := bv; add_pattern bv pat; - !pattern_bv + !(pattern_bv ()) let rec add_expr bv exp = match exp.pexp_desc with @@ -390,13 +395,13 @@ and add_module_alias bv l = bound (* cannot delay *)) and add_modtype_binding bv mty = - if not !Clflags.transparent_modules then add_modtype bv mty; + if not !((Clflags.current ()).transparent_modules) then add_modtype bv mty; match mty.pmty_desc with | Pmty_alias l -> add_module_alias bv l | Pmty_signature s -> make_node (add_signature_binding bv s) | Pmty_typeof modl -> add_module_binding bv modl | _ -> - if !Clflags.transparent_modules then add_modtype bv mty; + if !((Clflags.current ()).transparent_modules) then add_modtype bv mty; bound and add_signature bv sg = ignore (add_signature_binding bv sg) @@ -446,7 +451,7 @@ and add_sig_item (bv, m) item = (bv, m) and add_module_binding bv modl = - if not !Clflags.transparent_modules then add_module bv modl; + if not !((Clflags.current ()).transparent_modules) then add_module bv modl; match modl.pmod_desc with | Pmod_ident l -> ( try @@ -460,7 +465,7 @@ and add_module_binding bv modl = bound)) | Pmod_structure s -> make_node (snd (add_structure_binding bv s)) | _ -> - if !Clflags.transparent_modules then add_module bv modl; + if !((Clflags.current ()).transparent_modules) then add_module bv modl; bound and add_module bv modl = @@ -536,5 +541,6 @@ and add_struct_item (bv, m) item : _ String_map.t * _ String_map.t = (bv, m) and add_implementation bv l = - if !Clflags.transparent_modules then ignore (add_structure_binding bv l) + if !((Clflags.current ()).transparent_modules) then + ignore (add_structure_binding bv l) else ignore (add_structure bv l) diff --git a/compiler/ml/depend.mli b/compiler/ml/depend.mli index 12f20d9e2f4..89ed42fca68 100644 --- a/compiler/ml/depend.mli +++ b/compiler/ml/depend.mli @@ -21,7 +21,7 @@ module String_map : Map.S with type key = string type map_tree = Node of String_set.t * bound_map and bound_map = map_tree String_map.t -val free_structure_names : String_set.t ref +val free_structure_names : unit -> String_set.t ref (* dependencies found by preprocessing tools (plugins) *) val open_module : bound_map -> Longident.t -> bound_map diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index e8d4bf8f733..343760a7440 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -16,7 +16,6 @@ (* Environment handling *) open Cmi_format -open Config open Misc open Asttypes open Longident @@ -24,16 +23,22 @@ open Path open Types open Btype -let value_declarations : (string * Location.t, unit -> unit) Hashtbl.t = - Hashtbl.create 16 (* This table is used to usage of value declarations. A declaration is identified with its name and location. The callback attached to a declaration is called whenever the value is used explicitly (lookup_value) or implicitly (inclusion test between signatures, cf Includemod.value_descriptions). *) -let type_declarations = Hashtbl.create 16 -let module_declarations = Hashtbl.create 16 +let value_declarations_key = + Request_local.new_key (fun () -> + (Hashtbl.create 16 : (string * Location.t, unit -> unit) Hashtbl.t)) +let value_declarations () = Domain.DLS.get value_declarations_key + +let type_declarations_key = Request_local.new_key (fun () -> Hashtbl.create 16) +let type_declarations () = Domain.DLS.get type_declarations_key +let module_declarations_key = + Request_local.new_key (fun () -> Hashtbl.create 16) +let module_declarations () = Domain.DLS.get module_declarations_key type constructor_usage = Positive | Pattern | Privatize type constructor_usages = { @@ -48,11 +53,14 @@ let add_constructor_usage cu = function let constructor_usages () = {cu_positive = false; cu_pattern = false; cu_privatize = false} -let used_constructors : - (string * Location.t * string, constructor_usage -> unit) Hashtbl.t = - Hashtbl.create 16 +let used_constructors_key = + Request_local.new_key (fun () -> + (Hashtbl.create 16 + : (string * Location.t * string, constructor_usage -> unit) Hashtbl.t)) +let used_constructors () = Domain.DLS.get used_constructors_key -let prefixed_sg = Hashtbl.create 113 +let prefixed_sg_key = Request_local.new_key (fun () -> Hashtbl.create 113) +let prefixed_sg () = Domain.DLS.get prefixed_sg_key type error = | Illegal_renaming of string * string * string @@ -407,6 +415,7 @@ and functor_components = { fcomp_subst_cache: (Path.t, module_type) Hashtbl.t; } +(* Ctype installs this once during module initialization. Requests only read it. *) let same_constr = ref (fun _ _ _ -> assert false) (* Helper to decide whether to report an identifier shadowing @@ -469,18 +478,20 @@ let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0 type can_load_cmis = Can_load_cmis | Cannot_load_cmis of Env_lazy.log -let can_load_cmis = ref Can_load_cmis +let can_load_cmis_key = Request_local.new_key (fun () -> ref Can_load_cmis) +let can_load_cmis () = Domain.DLS.get can_load_cmis_key let without_cmis f x = let log = Env_lazy.log () in let res = Misc.( - protect_refs [R (can_load_cmis, Cannot_load_cmis log)] (fun () -> f x)) + protect_refs [R (can_load_cmis (), Cannot_load_cmis log)] (fun () -> f x)) in Env_lazy.backtrack log; res -(* Forward declarations *) +(* Forward declarations installed below during module initialization. They are + shared read-only once compilation requests can run. *) let components_of_module' = ref @@ -514,7 +525,7 @@ let strengthen = let md md_type = {md_type; md_attributes = []; md_loc = Location.none} let get_components_opt c = - match !can_load_cmis with + 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 @@ -539,7 +550,8 @@ let get_components c = (* The name of the compilation unit currently compiled. "" if outside a compilation unit. *) -let current_unit = ref "" +let current_unit_key = Request_local.new_key (fun () -> ref "") +let current_unit () = Domain.DLS.get current_unit_key (* Persistent structure descriptions *) @@ -551,25 +563,29 @@ type pers_struct = { ps_filename: string; } -let persistent_structures = - (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t) +let persistent_structures_key = + Request_local.new_key (fun () -> + (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t)) +let persistent_structures () = Domain.DLS.get persistent_structures_key (* Consistency between persistent structures *) -let crc_units = Consistbl.create () +let crc_units_key = Request_local.new_key Consistbl.create +let crc_units () = Domain.DLS.get crc_units_key module String_set = Set.Make (struct type t = string let compare = String.compare end) -let imported_units = ref String_set.empty +let imported_units_key = Request_local.new_key (fun () -> ref String_set.empty) +let imported_units () = Domain.DLS.get imported_units_key -let add_import s = imported_units := String_set.add s !imported_units +let add_import s = imported_units () := String_set.add s !(imported_units ()) let clear_imports () = - Consistbl.clear crc_units; - imported_units := String_set.empty + Consistbl.clear (crc_units ()); + imported_units () := String_set.empty let check_consistency ps = try @@ -579,7 +595,7 @@ let check_consistency ps = | None -> () | Some crc -> add_import name; - Consistbl.check crc_units name crc ps.ps_filename) + Consistbl.check (crc_units ()) name crc ps.ps_filename) ps.ps_crcs with Consistbl.Inconsistency (name, source, auth) -> error (Inconsistent_import (name, auth, source)) @@ -588,16 +604,19 @@ let check_consistency ps = let save_pers_struct crc ps = let modname = ps.ps_name in - Hashtbl.add persistent_structures modname (Some ps); - Consistbl.set crc_units modname crc ps.ps_filename; + Hashtbl.add (persistent_structures ()) modname (Some ps); + Consistbl.set (crc_units ()) modname crc ps.ps_filename; add_import modname module Persistent_signature = struct type t = {filename: string; cmi: Cmi_format.cmi_infos} + (* Bs_conditional_initial installs the native loader once at startup. *) let load = ref (fun ~unit_name -> - match find_in_path_uncap !load_path (unit_name ^ ".cmi") with + match + find_in_path_uncap (Config.get_load_path ()) (unit_name ^ ".cmi") + with | filename -> Some {filename; cmi = read_cmi filename} | exception Not_found -> None) end @@ -630,7 +649,7 @@ let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = 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); + Hashtbl.add (persistent_structures ()) modname (Some ps); ps let read_pers_struct check modname filename = @@ -640,18 +659,18 @@ let read_pers_struct check modname filename = let find_pers_struct check name = if name = "*predef*" then raise Not_found; - match Hashtbl.find persistent_structures name with + match Hashtbl.find (persistent_structures ()) name with | Some ps -> ps | None -> raise Not_found | exception Not_found -> ( - match !can_load_cmis with + 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; + Hashtbl.add (persistent_structures ()) name None; raise Not_found in add_import name; @@ -686,7 +705,7 @@ let read_pers_struct modname filename = read_pers_struct true modname filename let find_pers_struct name = find_pers_struct true name let check_pers_struct name = - if not (Hashtbl.mem persistent_structures name) then ( + if not (Hashtbl.mem (persistent_structures ()) name) then ( (* PR#6843: record the weak dependency ([add_import]) regardless of whether the check succeeds, to help make builds more deterministic. *) @@ -695,32 +714,32 @@ let check_pers_struct name = Delayed_checks.add_delayed_check (fun () -> check_pers_struct name)) let reset_cache () = - current_unit := ""; - Hashtbl.clear persistent_structures; + current_unit () := ""; + Hashtbl.clear (persistent_structures ()); clear_imports (); - Hashtbl.clear value_declarations; - Hashtbl.clear type_declarations; - Hashtbl.clear module_declarations; - Hashtbl.clear used_constructors; - Hashtbl.clear prefixed_sg + Hashtbl.clear (value_declarations ()); + Hashtbl.clear (type_declarations ()); + Hashtbl.clear (module_declarations ()); + Hashtbl.clear (used_constructors ()); + Hashtbl.clear (prefixed_sg ()) let reset_cache_toplevel () = (* Delete 'missing cmi' entries from the cache. *) let l = Hashtbl.fold (fun name r acc -> if r = None then name :: acc else acc) - persistent_structures [] + (persistent_structures ()) [] in - List.iter (Hashtbl.remove persistent_structures) l; - Hashtbl.clear value_declarations; - Hashtbl.clear type_declarations; - Hashtbl.clear module_declarations; - Hashtbl.clear used_constructors; - Hashtbl.clear prefixed_sg + List.iter (Hashtbl.remove (persistent_structures ())) l; + Hashtbl.clear (value_declarations ()); + Hashtbl.clear (type_declarations ()); + Hashtbl.clear (module_declarations ()); + Hashtbl.clear (used_constructors ()); + Hashtbl.clear (prefixed_sg ()) -let set_unit_name name = current_unit := name +let set_unit_name name = current_unit () := name -let get_unit_name () = !current_unit +let get_unit_name () = !(current_unit ()) (* Lookup by identifier *) @@ -729,7 +748,7 @@ let rec find_module_descr path env = | Pident id -> ( try Id_tbl.find_same id env.components with Not_found -> - if Ident.persistent id && not (Ident.name id = !current_unit) then + if Ident.persistent id && not (Ident.name id = !(current_unit ())) then (find_pers_struct (Ident.name id)).ps_comps else raise Not_found) | Pdot (p, s, _pos) -> ( @@ -815,7 +834,7 @@ let find_module ~alias path env = let data = Id_tbl.find_same id env.modules in Env_lazy.force subst_modtype_maker data with Not_found -> - if Ident.persistent id && not (Ident.name id = !current_unit) then + if Ident.persistent id && not (Ident.name id = !(current_unit ())) then let ps = find_pers_struct (Ident.name id) in md (Mty_signature (Lazy.force ps.ps_sig)) else raise Not_found) @@ -941,14 +960,15 @@ let report_deprecated ?loc p deprecated = let mark_module_used env name loc = if not (is_implicit_coercion env) then - try Hashtbl.find module_declarations (name, loc) () with Not_found -> () + try Hashtbl.find (module_declarations ()) (name, loc) () + with Not_found -> () let rec lookup_module_descr_aux ?loc lid env = match lid with | Lident s -> ( try Id_tbl.find_name s env.components with Not_found -> - if s = !current_unit then raise Not_found; + if s = !(current_unit ()) then raise Not_found; let ps = find_pers_struct s in (Pident (Ident.create_persistent s), ps.ps_comps)) | Ldot (l, s) -> ( @@ -979,16 +999,19 @@ and lookup_module ~load ?loc lid env : Path.t = (* see #5965 *) raise Recmodule | Mty_alias (_, Path.Pident id) -> - if (not !Clflags.transparent_modules) && Ident.persistent id then - find_pers_struct (Ident.name id) |> ignore + if + (not !((Clflags.current ()).transparent_modules)) + && Ident.persistent id + then find_pers_struct (Ident.name id) |> ignore | _ -> ()); report_deprecated ?loc p (Builtin_attributes.deprecated_of_attrs md_attributes); p with Not_found -> - if s = !current_unit then raise Not_found; + if s = !(current_unit ()) then raise Not_found; let p = Pident (Ident.create_persistent s) in - (if !Clflags.transparent_modules && not load then check_pers_struct s + (if !((Clflags.current ()).transparent_modules) && not load then + check_pers_struct s else let ps = find_pers_struct s in report_deprecated ?loc p ps.ps_comps.deprecated); @@ -1070,37 +1093,37 @@ let copy_types l env = let mark_value_used env name vd = if not (is_implicit_coercion env) then - try Hashtbl.find value_declarations (name, vd.val_loc) () + try Hashtbl.find (value_declarations ()) (name, vd.val_loc) () with Not_found -> () let mark_type_used env name vd = if not (is_implicit_coercion env) then - try Hashtbl.find type_declarations (name, vd.type_loc) () + try Hashtbl.find (type_declarations ()) (name, vd.type_loc) () with Not_found -> () let mark_constructor_used usage env name vd constr = if not (is_implicit_coercion env) then - try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage + try Hashtbl.find (used_constructors ()) (name, vd.type_loc, constr) usage with Not_found -> () let mark_extension_used usage env ext name = if not (is_implicit_coercion env) then let ty_name = Path.last ext.ext_type_path in - try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage + try Hashtbl.find (used_constructors ()) (ty_name, ext.ext_loc, name) usage with Not_found -> () let set_value_used_callback name vd callback = let key = (name, vd.val_loc) in try - let old = Hashtbl.find value_declarations key in - Hashtbl.replace value_declarations key (fun () -> + let old = Hashtbl.find (value_declarations ()) key in + Hashtbl.replace (value_declarations ()) key (fun () -> old (); callback ()) (* this is to support cases like: let x = let x = 1 in x in x where the two declarations have the same location (e.g. resulting from Camlp4 expansion of grammar entries) *) - with Not_found -> Hashtbl.add value_declarations key callback + with Not_found -> Hashtbl.add (value_declarations ()) key callback let set_type_used_callback name td callback = let loc = td.type_loc in @@ -1108,9 +1131,10 @@ let set_type_used_callback name td callback = else let key = (name, loc) in let old = - try Hashtbl.find type_declarations key with Not_found -> assert false + try Hashtbl.find (type_declarations ()) key + with Not_found -> assert false in - Hashtbl.replace type_declarations key (fun () -> callback old) + Hashtbl.replace (type_declarations ()) key (fun () -> callback old) let lookup_value ?loc lid env = let ((_, desc) as r) = lookup_value ?loc lid env in @@ -1161,7 +1185,8 @@ let mark_constructor usage env name desc = | Extension_constructor _ -> ( let ty_path = ty_path desc.cstr_res in let ty_name = Path.last ty_path in - try Hashtbl.find used_constructors (ty_name, desc.cstr_loc, name) usage + try + Hashtbl.find (used_constructors ()) (ty_name, desc.cstr_loc, name) usage with Not_found -> ()) | _ -> let ty_path = ty_path desc.cstr_res in @@ -1185,13 +1210,14 @@ let lookup_all_labels ?loc lid env = not yet evaluated structures) *) type iter_cont = unit -> unit -let iter_env_cont = ref [] +let iter_env_cont_key = Request_local.new_key (fun () -> ref []) +let iter_env_cont () = Domain.DLS.get iter_env_cont_key let rec scrape_alias_for_visit env mty = match mty with | Mty_alias (_, Pident id) when Ident.persistent id - && not (Hashtbl.mem persistent_structures (Ident.name id)) -> + && not (Hashtbl.mem (persistent_structures ()) (Ident.name id)) -> false | Mty_alias (_, path) -> ( (* PR#6600: find_module may raise Not_found *) @@ -1221,7 +1247,7 @@ let iter_env proj1 proj2 f env () = comps.comp_components | Functor_comps _ -> () in - iter_env_cont := (path, cont) :: !iter_env_cont + iter_env_cont () := (path, cont) :: !(iter_env_cont ()) in Hashtbl.iter (fun s pso -> @@ -1230,16 +1256,16 @@ let iter_env proj1 proj2 f env () = | Some ps -> let id = Pident (Ident.create_persistent s) in iter_components id id ps.ps_comps) - persistent_structures; + (persistent_structures ()); Id_tbl.iter (fun id (path, comps) -> iter_components (Pident id) path comps) env.components let run_iter_cont l = - iter_env_cont := []; + iter_env_cont () := []; List.iter (fun c -> c ()) l; - let cont = List.rev !iter_env_cont in - iter_env_cont := []; + let cont = List.rev !(iter_env_cont ()) in + iter_env_cont () := []; cont let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f @@ -1251,7 +1277,7 @@ let used_persistent () = let r = ref Concr.empty in Hashtbl.iter (fun s pso -> if pso != None then r := Concr.add s !r) - persistent_structures; + (persistent_structures ()); !r let find_all_comps proj s (p, mcomps) = @@ -1392,10 +1418,10 @@ let rec prefix_idents root pos sub = function let prefix_idents root sub sg = if sub = Subst.identity then ( let sgs = - try Hashtbl.find prefixed_sg root + try Hashtbl.find (prefixed_sg ()) root with Not_found -> let sgs = ref [] in - Hashtbl.add prefixed_sg root sgs; + Hashtbl.add (prefixed_sg ()) root sgs; sgs in try List.assq sg !sgs @@ -1525,7 +1551,7 @@ and check_value_name name loc = and store_value ?check id decl env = check_value_name (Ident.name id) decl.val_loc; - may (fun f -> check_usage decl.val_loc id f value_declarations) check; + may (fun f -> check_usage decl.val_loc id f (value_declarations ())) check; { env with values = Id_tbl.add id decl env.values; @@ -1537,7 +1563,7 @@ and store_type ~check id info env = if check then check_usage loc id (fun s -> Warnings.Unused_type_declaration s) - type_declarations; + (type_declarations ()); let path = Pident id in let constructors = Datarepr.constructors_of_type path info in let labels = Datarepr.labels_of_type path info in @@ -1552,9 +1578,9 @@ and store_type ~check id info env = List.iter (fun (_, {cstr_name = c; _}) -> let k = (ty, loc, c) in - if not (Hashtbl.mem used_constructors k) then ( + if not (Hashtbl.mem (used_constructors ()) k) then ( let used = constructor_usages () in - Hashtbl.add used_constructors k (add_constructor_usage used); + Hashtbl.add (used_constructors ()) k (add_constructor_usage used); if not (ty = "" || ty.[0] = '_') then Delayed_checks.add_delayed_check (fun () -> if (not (is_in_signature env)) && not used.cu_positive then @@ -1598,9 +1624,9 @@ and store_extension ~check id ext env = let ty = Path.last ext.ext_type_path in let n = Ident.name id in let k = (ty, loc, n) in - if not (Hashtbl.mem used_constructors k) then ( + if not (Hashtbl.mem (used_constructors ()) k) then ( let used = constructor_usages () in - Hashtbl.add used_constructors k (add_constructor_usage used); + Hashtbl.add (used_constructors ()) k (add_constructor_usage used); Delayed_checks.add_delayed_check (fun () -> if (not (is_in_signature env)) && not used.cu_positive then Location.prerr_warning loc @@ -1616,7 +1642,9 @@ and store_extension ~check id ext env = and store_module ~check id md env = let loc = md.md_loc in if check then - check_usage loc id (fun s -> Warnings.Unused_module s) module_declarations; + check_usage loc id + (fun s -> Warnings.Unused_module s) + (module_declarations ()); let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in { @@ -1813,15 +1841,17 @@ let read_signature modname filename = (* Return the CRC of the interface of the given compilation unit *) let imports () = - let dont_record_crc_unit = !Clflags.dont_record_crc_unit in + let dont_record_crc_unit = !((Clflags.current ()).dont_record_crc_unit) in match dont_record_crc_unit with - | None -> Consistbl.extract (String_set.elements !imported_units) crc_units + | None -> + Consistbl.extract (String_set.elements !(imported_units ())) (crc_units ()) | Some x -> Consistbl.extract (String_set.fold (fun m acc -> if m = x then acc else m :: acc) - !imported_units []) - crc_units + !(imported_units ()) + []) + (crc_units ()) (* Save a signature to a file *) @@ -1919,7 +1949,7 @@ let fold_modules f lid env acc = (Pident (Ident.create_persistent name)) (md (Mty_signature (Lazy.force ps.ps_sig))) acc) - persistent_structures acc + (persistent_structures ()) acc | Some l -> ( let p, desc = lookup_module_descr l env in match get_components desc with @@ -1945,16 +1975,32 @@ and fold_modtypes f = find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f (* Make the initial environment *) -let initial_safe_string = +(* The initial environment contains mutable type graphs. Each compiler domain + needs its own copy because type instantiation marks source graph nodes. *) +let create_initial_safe_string () = Predef.build_initial_env (add_type ~check:false) (add_extension ~check:false) empty -let last_env = ref empty -let last_reduced_env = ref empty +let initial_safe_string_key = Domain.DLS.new_key create_initial_safe_string + +let initial_safe_string () = Domain.DLS.get initial_safe_string_key + +let reset_initial_for_request () = + Domain.DLS.set initial_safe_string_key (create_initial_safe_string ()) + +let with_fresh_initial action = + let previous = initial_safe_string () in + Fun.protect action ~finally:(fun () -> + Domain.DLS.set initial_safe_string_key previous) + +let last_env_key = Request_local.new_key (fun () -> ref empty) +let last_env () = Domain.DLS.get last_env_key +let last_reduced_env_key = Request_local.new_key (fun () -> ref empty) +let last_reduced_env () = Domain.DLS.get last_reduced_env_key let keep_only_summary env = - if !last_env == env then !last_reduced_env + if !(last_env ()) == env then !(last_reduced_env ()) else let new_env = { @@ -1964,8 +2010,8 @@ let keep_only_summary env = flags = env.flags; } in - last_env := env; - last_reduced_env := new_env; + last_env () := env; + last_reduced_env () := new_env; new_env open Format diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli index b46fa784a4e..196c13325c1 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -35,7 +35,9 @@ type summary = type t val empty : t -val initial_safe_string : t +val initial_safe_string : unit -> t +val reset_initial_for_request : unit -> unit +val with_fresh_initial : (unit -> 'a) -> 'a type type_descriptions = constructor_description list * label_description list @@ -197,6 +199,9 @@ val imports : unit -> (string * Digest.t option) list (* Direct access to the table of imported compilation units with their CRC *) +val crc_units : unit -> Consistbl.t +val add_import : string -> unit + (* Summaries -- compact representation of an environment, to be exported in debugging information. *) diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 9e63805ecb7..8665b0c6fb8 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -1,10 +1,12 @@ type extract_concrete_typedecl = Env.t -> Types.type_expr -> Path.t * Path.t * Types.type_declaration -let configured_jsx_module : string option ref = ref None +(* The JSX module affects type-error suggestions for the active request. *) +let configured_jsx_module_key = Request_local.new_key (fun () -> ref None) +let configured_jsx_module () = Domain.DLS.get configured_jsx_module_key let with_configured_jsx_module s = - match !configured_jsx_module with + match !(configured_jsx_module ()) with | None -> s | Some module_name -> module_name ^ "." ^ s @@ -891,7 +893,7 @@ let get_jsx_component_props ~(extract_concrete_typedecl : extract_concrete_typedecl) env ty p = match p with | Path.Pdot (Path.Pident {Ident.name = jsx_module_name}, "fragmentProps", _) - when Some jsx_module_name = !configured_jsx_module -> + when Some jsx_module_name = !(configured_jsx_module ()) -> Some {props_record_path = p; fields = []; jsx_type = `Fragment} | _ -> ( (* TODO: handle lowercase components using JSXDOM.domProps *) diff --git a/compiler/ml/experimental_features.ml b/compiler/ml/experimental_features.ml index b30faa2e0b6..5ec591c740f 100644 --- a/compiler/ml/experimental_features.ml +++ b/compiler/ml/experimental_features.ml @@ -14,12 +14,17 @@ module Feature_set = Set.Make (struct let compare = compare end) -let enabled_features : Feature_set.t ref = ref Feature_set.empty +(* Feature switches belong to the compiling domain, including nested requests. *) +let key = Request_local.new_key (fun () -> ref Feature_set.empty) +let enabled_features () = Domain.DLS.get key + let enable_from_string (s : string) = match from_string s with - | Some f -> enabled_features := Feature_set.add f !enabled_features + | Some f -> + let enabled = enabled_features () in + enabled := Feature_set.add f !enabled | None -> () -let reset () = enabled_features := Feature_set.empty +let reset () = enabled_features () := Feature_set.empty -let is_enabled (f : feature) = Feature_set.mem f !enabled_features +let is_enabled (f : feature) = Feature_set.mem f !(enabled_features ()) diff --git a/compiler/ml/experimental_features.mli b/compiler/ml/experimental_features.mli index 5c28eca2ba2..ad3fdd925c2 100644 --- a/compiler/ml/experimental_features.mli +++ b/compiler/ml/experimental_features.mli @@ -1,6 +1,7 @@ type feature = LetUnwrap val enable_from_string : string -> unit + val is_enabled : feature -> bool val to_string : feature -> string val reset : unit -> unit diff --git a/compiler/ml/lambda_exits.ml b/compiler/ml/lambda_exits.ml index d4c3c695d80..0265886e18b 100644 --- a/compiler/ml/lambda_exits.ml +++ b/compiler/ml/lambda_exits.ml @@ -22,17 +22,20 @@ open Lambda -let raise_count = ref 0 - let next_raise_count () = - incr raise_count; - !raise_count + let state = Compiler_request_state.current () in + state.lambda_raise_count <- state.lambda_raise_count + 1; + state.lambda_raise_count -let negative_raise_count = ref 0 +let reset () = + let state = Compiler_request_state.current () in + state.lambda_raise_count <- 0; + state.lambda_negative_raise_count <- 0 let next_negative_raise_count () = - decr negative_raise_count; - !negative_raise_count + let state = Compiler_request_state.current () in + state.lambda_negative_raise_count <- state.lambda_negative_raise_count - 1; + state.lambda_negative_raise_count let make_exit i = staticraise i [] diff --git a/compiler/ml/lambda_exits.mli b/compiler/ml/lambda_exits.mli index f357ebf0cc7..eb7e0f9ac3e 100644 --- a/compiler/ml/lambda_exits.mli +++ b/compiler/ml/lambda_exits.mli @@ -23,6 +23,9 @@ val next_negative_raise_count : unit -> int where simplifications that assume a static raise sits in tail position of its handler do not apply. *) +val reset : unit -> unit +(** Reset domain-owned request-local static-exit identifiers. *) + val make_exit : int -> Lambda.t val as_simple_exit : Lambda.t -> int option diff --git a/compiler/ml/location.ml b/compiler/ml/location.ml index c328ddc378c..f44818ab744 100644 --- a/compiler/ml/location.ml +++ b/compiler/ml/location.ml @@ -27,15 +27,17 @@ let in_file name = let none = in_file "_none_" -let input_name = ref "_none_" -let set_input_name name = if name <> "" then input_name := name +let get_input_name () = (Compiler_request_state.current ()).input_name +let set_input_name name = + if name <> "" then (Compiler_request_state.current ()).input_name <- name + (* Terminal info *) (* Print the location in some way or another *) open Format -let show_filename file = if file = "_none_" then !input_name else file +let show_filename file = if file = "_none_" then get_input_name () else file let print_filename ppf file = Format.fprintf ppf "%s" (show_filename file) @@ -43,8 +45,8 @@ let print_filename ppf file = Format.fprintf ppf "%s" (show_filename file) let get_pos_info pos = (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) let setup_colors () = - Misc.Color.setup !Clflags.color; - Code_frame.setup !Clflags.color + Misc.Color.setup !((Clflags.current ()).color); + Code_frame.setup !((Clflags.current ()).color) (* ocaml's reported line/col numbering is horrible and super error-prone when being handled programmatically (or humanly for that matter. If you're @@ -166,7 +168,13 @@ let warning_printer = ref default_warning_printer let print_warning loc ppf w = !warning_printer loc ppf w let formatter_for_warnings = ref err_formatter -let prerr_warning loc w = print_warning loc !formatter_for_warnings w +let prerr_warning loc w = + let ppf = + if Compiler_request_output.is_active () then + Compiler_request_output.stderr_formatter () + else !formatter_for_warnings + in + print_warning loc ppf w type 'a loc = {txt: 'a; loc: t} @@ -258,12 +266,12 @@ let report_error ?(custom_intro = None) ?(src = None) ppf err = let error_of_printer loc print x = errorf ~loc "%a@?" print x let error_of_printer_file print x = - error_of_printer (in_file !input_name) print x + error_of_printer (in_file (get_input_name ())) print x let () = register_error_of_exn (function | Sys_error msg -> - Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg) + Some (errorf ~loc:(in_file (get_input_name ())) "I/O error: %s" msg) | _ -> None) external reraise : exn -> 'a = "%reraise" diff --git a/compiler/ml/location.mli b/compiler/ml/location.mli index 2e29b16a679..e13fc9f39bd 100644 --- a/compiler/ml/location.mli +++ b/compiler/ml/location.mli @@ -24,7 +24,7 @@ type t = Warnings.loc = { } (** Note on the use of Lexing.position in this module. - If [pos_fname = ""], then use [!input_name] instead. + If [pos_fname = ""], then use [get_input_name ()] instead. If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and re-parse the file to get the line and character numbers. Else all fields are correct. @@ -36,9 +36,10 @@ val none : t val in_file : string -> t (** Return an empty ghost range located in a given file. *) -val input_name : string ref -val set_input_name : string -> unit +val get_input_name : unit -> string +(** The source filename for the current compiler request on this domain. *) +val set_input_name : string -> unit val get_pos_info : Lexing.position -> string * int * int (* file, line, char *) val print_loc : formatter -> t -> unit diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index ecf81aa544a..c5bacc995c2 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -55,9 +55,7 @@ and may_compats = Parmatch.Compat.compats ~equal_cd - Jump summaries: mapping from exit numbers to contexts *) -let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam; - Format.flush_str_formatter () +let string_of_lam lam = Format.asprintf "%a" Printlambda.lambda lam type matrix = pattern list list @@ -431,9 +429,8 @@ let pretty_cases cases = (fun (ps, _l) -> List.iter (fun p -> - Parmatch.top_pretty Format.str_formatter p; prerr_string " "; - prerr_string (Format.flush_str_formatter ())) + prerr_string (Format.asprintf "%a" Parmatch.top_pretty p)) ps; (* prerr_string " -> " ; diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index a92bcdceae0..74c0a02ee08 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -463,18 +463,15 @@ and pretty_dict_entries ppf = function let top_pretty ppf v = fprintf ppf "@[%a@]@?" pretty_val v -let pretty_pat p = - top_pretty Format.str_formatter p; - prerr_string (Format.flush_str_formatter ()) +let pretty_pat p = prerr_string (Format.asprintf "%a" top_pretty p) type matrix = pattern list list let pretty_line ps = List.iter (fun p -> - top_pretty Format.str_formatter p; prerr_string " <"; - prerr_string (Format.flush_str_formatter ()); + prerr_string (Format.asprintf "%a" top_pretty p); prerr_string ">") ps @@ -1872,10 +1869,10 @@ module Conv = struct open Parsetree let mkpat desc = Ast_helper.Pat.mk desc - let name_counter = ref 0 let fresh name = - let current = !name_counter in - name_counter := !name_counter + 1; + let state = Compiler_request_state.current () in + let current = state.parmatch_name_counter in + state.parmatch_name_counter <- current + 1; "#$" ^ name ^ string_of_int current let conv_record_rest (rest : Typedtree.record_pat_rest) = diff --git a/compiler/ml/platform/native/cmt_format_persistence.ml b/compiler/ml/platform/native/cmt_format_persistence.ml index 56acd6ca540..49c13c5caa5 100644 --- a/compiler/ml/platform/native/cmt_format_persistence.ml +++ b/compiler/ml/platform/native/cmt_format_persistence.ml @@ -15,6 +15,8 @@ open Cmt_format_common +let set_args value = (Compiler_request_state.current ()).cmt_args <- value + let output_cmt output_channel cmt = output_string output_channel Config.cmt_magic_number; output_value output_channel (cmt : cmt_infos) @@ -22,7 +24,7 @@ let output_cmt output_channel cmt = (* Unlike OCaml, no copy of the .cmi is written in front of the cmt infos: tools read the .cmi itself. *) let save_cmt filename modname binary_annots sourcefile initial_env = - if !Clflags.binary_annotations then + if !((Clflags.current ()).binary_annotations) then Misc.output_to_bin_file_directly filename (fun _temp_file_name output_channel -> let cmt = @@ -31,11 +33,15 @@ let save_cmt filename modname binary_annots sourcefile initial_env = cmt_annots = clear_env binary_annots; cmt_value_dependencies = value_dependencies (); cmt_comments = []; - cmt_args = Sys.argv; + cmt_args = (Compiler_request_state.current ()).cmt_args; cmt_sourcefile = sourcefile; - cmt_builddir = Sys.getcwd (); - cmt_loadpath = !Config.load_path; - cmt_source_digest = Misc.may_map Digest.file 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); diff --git a/compiler/ml/platform/playground/cmt_format_persistence.ml b/compiler/ml/platform/playground/cmt_format_persistence.ml index b0b34f8ef43..a6981d8b1a4 100644 --- a/compiler/ml/platform/playground/cmt_format_persistence.ml +++ b/compiler/ml/platform/playground/cmt_format_persistence.ml @@ -1 +1,3 @@ +let set_args _value = () + let save_cmt _filename _modname _binary_annots _sourcefile _initial_env = () diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 4414bb84e8f..531625ff3e2 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -116,35 +116,73 @@ and path_promise = Pident ident_promise and path_tagged_template = Pident ident_tagged_template -let type_int = newgenty (Tconstr (path_int, [], ref Mnil)) - -and type_char = newgenty (Tconstr (path_char, [], ref Mnil)) - -and type_float = newgenty (Tconstr (path_float, [], ref Mnil)) - -and type_bool = newgenty (Tconstr (path_bool, [], ref Mnil)) - -and type_unit = newgenty (Tconstr (path_unit, [], ref Mnil)) - -and type_exn = newgenty (Tconstr (path_exn, [], ref Mnil)) - -and type_array t = newgenty (Tconstr (path_array, [t], ref Mnil)) - -and type_iterable t = newgenty (Tconstr (path_iterable, [t], ref Mnil)) - -and type_async_iterable t = +(* Instantiation temporarily marks source type nodes while copying them. Keep + predefined nodes private to each domain so those marks cannot cross + concurrent compiler requests. *) +let predefined_type path = + Domain.DLS.new_key (fun () -> newgenty (Tconstr (path, [], ref Mnil))) + +let type_int_key = predefined_type path_int +let type_int () = Domain.DLS.get type_int_key +let type_char_key = predefined_type path_char +let type_char () = Domain.DLS.get type_char_key +let type_float_key = predefined_type path_float +let type_float () = Domain.DLS.get type_float_key +let type_bool_key = predefined_type path_bool +let type_bool () = Domain.DLS.get type_bool_key +let type_unit_key = predefined_type path_unit +let type_unit () = Domain.DLS.get type_unit_key +let type_exn_key = predefined_type path_exn +let type_exn () = Domain.DLS.get type_exn_key + +let type_array t = newgenty (Tconstr (path_array, [t], ref Mnil)) + +let type_iterable t = newgenty (Tconstr (path_iterable, [t], ref Mnil)) + +let type_async_iterable t = newgenty (Tconstr (path_async_iterable, [t], ref Mnil)) -and type_list t = newgenty (Tconstr (path_list, [t], ref Mnil)) - -and type_bigint = newgenty (Tconstr (path_bigint, [], ref Mnil)) - -and type_string = newgenty (Tconstr (path_string, [], ref Mnil)) - -and type_unknown = newgenty (Tconstr (path_unkonwn, [], ref Mnil)) - -and type_extension_constructor = - newgenty (Tconstr (path_extension_constructor, [], ref Mnil)) +let type_list t = newgenty (Tconstr (path_list, [t], ref Mnil)) + +let type_bigint_key = predefined_type path_bigint +let type_bigint () = Domain.DLS.get type_bigint_key + +let type_string_key = predefined_type path_string +let type_string () = Domain.DLS.get type_string_key + +let type_unknown_key = predefined_type path_unkonwn +let type_unknown () = Domain.DLS.get type_unknown_key + +let type_extension_constructor_key = predefined_type path_extension_constructor +let type_extension_constructor () = + Domain.DLS.get type_extension_constructor_key + +let predefined_types = + [ + (type_int_key, path_int); + (type_char_key, path_char); + (type_float_key, path_float); + (type_bool_key, path_bool); + (type_unit_key, path_unit); + (type_exn_key, path_exn); + (type_bigint_key, path_bigint); + (type_string_key, path_string); + (type_unknown_key, path_unkonwn); + (type_extension_constructor_key, path_extension_constructor); + ] + +let reset_for_request () = + List.iter + (fun (key, path) -> + Domain.DLS.set key (newgenty (Tconstr (path, [], ref Mnil)))) + predefined_types + +let with_fresh action = + let previous = + List.map (fun (key, _) -> (key, Domain.DLS.get key)) predefined_types + in + Fun.protect action ~finally:(fun () -> + List.iter (fun (key, value) -> Domain.DLS.set key value) previous) let ident_match_failure = ident_create_predef_exn "Match_failure" @@ -317,7 +355,7 @@ let common_initial_env add_type add_extension empty_env = cd_id = ident_ctor_unknown; cd_runtime_tag = None; cd_args = Cstr_tuple [tvar]; - cd_res = Some type_unknown; + cd_res = Some (type_unknown ()); cd_loc = Location.none; cd_attributes = []; }; @@ -382,22 +420,22 @@ let common_initial_env add_type add_extension empty_env = |> add_type ident_dict decl_dict |> add_type ident_unknown decl_unknown |> add_exception ident_undefined_recursive_module - [newgenty (Ttuple [type_string; type_int; type_int])] + [newgenty (Ttuple [type_string (); type_int (); type_int ()])] |> add_exception ident_assert_failure - [newgenty (Ttuple [type_string; type_int; type_int])] + [newgenty (Ttuple [type_string (); type_int (); type_int ()])] |> add_exception ident_division_by_zero [] |> add_exception ident_end_of_file [] |> add_exception ident_not_found [] - |> add_exception ident_failure [type_string] - |> add_exception ident_js_exn [type_unknown] - |> add_exception ident_invalid_argument [type_string] + |> add_exception ident_failure [type_string ()] + |> add_exception ident_js_exn [type_unknown ()] + |> add_exception ident_invalid_argument [type_string ()] |> add_exception ident_match_failure - [newgenty (Ttuple [type_string; type_int; type_int])] + [newgenty (Ttuple [type_string (); type_int (); type_int ()])] let build_initial_env add_type add_exception empty_env = let common = common_initial_env add_type add_exception empty_env in let decl_type_char = - {decl_abstr with type_manifest = Some type_int; type_private = Private} + {decl_abstr with type_manifest = Some (type_int ()); type_private = Private} in add_type ident_char decl_type_char common diff --git a/compiler/ml/predef.mli b/compiler/ml/predef.mli index 408ba7ba0ff..626443418fe 100644 --- a/compiler/ml/predef.mli +++ b/compiler/ml/predef.mli @@ -17,18 +17,21 @@ open Types -val type_int : type_expr -val type_char : type_expr -val type_string : type_expr -val type_float : type_expr -val type_bool : type_expr -val type_unit : type_expr -val type_exn : type_expr +val type_int : unit -> type_expr +val type_char : unit -> type_expr +val type_string : unit -> type_expr +val type_float : unit -> type_expr +val type_bool : unit -> type_expr +val type_unit : unit -> type_expr +val type_exn : unit -> type_expr val type_array : type_expr -> type_expr val type_iterable : type_expr -> type_expr val type_async_iterable : type_expr -> type_expr -val type_bigint : type_expr -val type_extension_constructor : type_expr +val type_bigint : unit -> type_expr +val type_extension_constructor : unit -> type_expr + +val reset_for_request : unit -> unit +val with_fresh : (unit -> 'a) -> 'a val path_int : Path.t val path_char : Path.t diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 57c9c0d35f3..22153df4717 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -26,7 +26,7 @@ let fmt_position with_name f l = fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol (l.pos_cnum - l.pos_bol) let fmt_location f loc = - if !Clflags.dump_location then ( + if !((Clflags.current ()).dump_location) then ( let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in fprintf f "(%a..%a)" (fmt_position true) loc.loc_start (fmt_position p_2nd_name) loc.loc_end; @@ -435,7 +435,8 @@ and expression i ppf x = }) -> ( line i ppf "Pexp_jsx_container_element %a\n" fmt_jsx_tag_name name; jsx_props i ppf props; - if !Clflags.dump_location then line i ppf "> %a\n" (fmt_position false) gt; + if !((Clflags.current ()).dump_location) then + line i ppf "> %a\n" (fmt_position false) gt; jsx_children i ppf children; match closing_tag with | None -> () diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index ea3fc706847..90029de4e3a 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -387,4 +387,4 @@ let serialize (filename : string) (l : Lambda.t) : unit = close_out ou; Format.set_margin old -let lambda_to_string = Format.asprintf "%a" lambda +let lambda_to_string l = Format.asprintf "%a" lambda l diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index a367004ce32..34788d96e7c 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -38,15 +38,17 @@ let rec longident ppf = function (* Print an identifier *) -let unique_names = ref Ident.empty +let unique_names_key = Request_local.new_key (fun () -> ref Ident.empty) +let unique_names () = Domain.DLS.get unique_names_key let ident_name id = - try Ident.find_same id !unique_names with Not_found -> Ident.name id + try Ident.find_same id !(unique_names ()) with Not_found -> Ident.name id let add_unique id = - try ignore (Ident.find_same id !unique_names) + try ignore (Ident.find_same id !(unique_names ())) with Not_found -> - unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names + unique_names () := + Ident.add id (Ident.unique_toplevel_name id) !(unique_names ()) let ident ppf id = pp_print_string ppf (ident_name id) @@ -54,12 +56,13 @@ let ident ppf id = pp_print_string ppf (ident_name id) let ident_pervasives = Ident.create_persistent "Pervasives" let ident_stdlib = Ident.create_persistent "Stdlib" -let printing_env = ref Env.empty +let printing_env_key = Request_local.new_key (fun () -> ref Env.empty) +let printing_env () = Domain.DLS.get printing_env_key let non_shadowed_pervasive_or_stdlib = function | Pdot (Pident id, s, _pos) as path -> ( (Ident.same id ident_pervasives || Ident.same id ident_stdlib) && - try Path.same path (Env.lookup_type (Lident s) !printing_env) + try Path.same path (Env.lookup_type (Lident s) !(printing_env ())) with Not_found -> true) | _ -> false @@ -128,12 +131,13 @@ let print_name ppf = function | None -> fprintf ppf "None" | Some name -> fprintf ppf "\"%s\"" name -let visited = ref [] +let visited_key = Request_local.new_key (fun () -> ref []) +let visited () = Domain.DLS.get visited_key let rec raw_type ppf ty = let ty = safe_repr [] ty in - if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id + if List.memq ty !(visited ()) then fprintf ppf "{id=%d}" ty.id else ( - visited := ty :: !visited; + visited () := ty :: !(visited ()); fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level raw_type_desc ty.desc) @@ -190,9 +194,9 @@ and raw_field ppf = function | Rabsent -> fprintf ppf "Rabsent" let raw_type_expr ppf t = - visited := []; + visited () := []; raw_type ppf t; - visited := [] + visited () := [] (* Normalize paths *) @@ -218,12 +222,18 @@ let apply_subst s1 tyl = type best_path = Paths of Path.t list | Best of Path.t -let printing_depth = ref 0 -let printing_cont = ref ([] : Env.iter_cont list) -let printing_old = ref Env.empty -let printing_pers = ref Concr.empty +let printing_depth_key = Request_local.new_key (fun () -> ref 0) +let printing_depth () = Domain.DLS.get printing_depth_key +let printing_cont_key = + Request_local.new_key (fun () -> ref ([] : Env.iter_cont list)) +let printing_cont () = Domain.DLS.get printing_cont_key +let printing_old_key = Request_local.new_key (fun () -> ref Env.empty) +let printing_old () = Domain.DLS.get printing_old_key +let printing_pers_key = Request_local.new_key (fun () -> ref Concr.empty) +let printing_pers () = Domain.DLS.get printing_pers_key module Path_map = Map.Make (Path) -let printing_map = ref Path_map.empty +let printing_map_key = Request_local.new_key (fun () -> ref Path_map.empty) +let printing_map () = Domain.DLS.get printing_map_key let same_type t t' = repr t == repr t' @@ -275,18 +285,22 @@ let rec path_size = function let same_printing_env env = let used_pers = Env.used_persistent () in - Env.same_types !printing_old env && Concr.equal !printing_pers used_pers + Env.same_types !(printing_old ()) env + && Concr.equal !(printing_pers ()) used_pers let set_printing_env env = - printing_env := env; - if !Clflags.real_paths || !printing_env == Env.empty || same_printing_env env + printing_env () := env; + if + !((Clflags.current ()).real_paths) + || !(printing_env ()) == Env.empty + || same_printing_env env then () else ( (* printf "Reset printing_map@."; *) - printing_old := env; - printing_pers := Env.used_persistent (); - printing_map := Path_map.empty; - printing_depth := 0; + printing_old () := env; + printing_pers () := Env.used_persistent (); + printing_map () := Path_map.empty; + printing_depth () := 0; (* printf "Recompute printing_map.@."; *) let cont = Env.iter_types @@ -295,16 +309,17 @@ let set_printing_env env = (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) if s1 = Id then try - let r = Path_map.find p1 !printing_map in + let r = Path_map.find p1 !(printing_map ()) in match !r with | Paths l -> r := Paths (p :: l) | Best p' -> r := Paths [p; p'] (* assert false *) with Not_found -> - printing_map := Path_map.add p1 (ref (Paths [p])) !printing_map) + printing_map () := + Path_map.add p1 (ref (Paths [p])) !(printing_map ())) env in - printing_cont := [cont]) + printing_cont () := [cont]) let wrap_printing_env env f = set_printing_env env; @@ -341,24 +356,25 @@ let rec get_best_path r = (* Format.eprintf "evaluating %a@." path p; *) match !r with | Best p' when path_size p >= path_size p' -> () - | _ -> if is_unambiguous p !printing_env then r := Best p) + | _ -> if is_unambiguous p !(printing_env ()) then r := Best p) (* else Format.eprintf "%a ignored as ambiguous@." path p *) l; get_best_path r let best_type_path p = - if !Clflags.real_paths || !printing_env == Env.empty then (p, Id) + if !((Clflags.current ()).real_paths) || !(printing_env ()) == Env.empty then + (p, Id) else - let p', s = normalize_type_path !printing_env p in - let get_path () = get_best_path (Path_map.find p' !printing_map) in + let p', s = normalize_type_path !(printing_env ()) p in + let get_path () = get_best_path (Path_map.find p' !(printing_map ())) in while - !printing_cont <> [] + !(printing_cont ()) <> [] && - try fst (path_size (get_path ())) > !printing_depth + try fst (path_size (get_path ())) > !(printing_depth ()) with Not_found -> true do - printing_cont := List.map snd (Env.run_iter_cont !printing_cont); - incr printing_depth + printing_cont () := List.map snd (Env.run_iter_cont !(printing_cont ())); + incr (printing_depth ()) done; let p'' = try get_path () with Not_found -> p' in (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) @@ -366,54 +382,63 @@ let best_type_path p = (* Print a type expression *) -let names = ref ([] : (type_expr * string) list) -let name_counter = ref 0 -let named_vars = ref ([] : string list) - -let weak_counter = ref 1 -let weak_var_map = ref Type_map.empty -let named_weak_vars = ref String_set.empty +let names_key = + Request_local.new_key (fun () -> ref ([] : (type_expr * string) list)) +let names () = Domain.DLS.get names_key +let name_counter_key = Request_local.new_key (fun () -> ref 0) +let name_counter () = Domain.DLS.get name_counter_key +let named_vars_key = Request_local.new_key (fun () -> ref ([] : string list)) +let named_vars () = Domain.DLS.get named_vars_key + +let weak_counter_key = Request_local.new_key (fun () -> ref 1) +let weak_counter () = Domain.DLS.get weak_counter_key +let weak_var_map_key = Request_local.new_key (fun () -> ref Type_map.empty) +let weak_var_map () = Domain.DLS.get weak_var_map_key +let named_weak_vars_key = Request_local.new_key (fun () -> ref String_set.empty) +let named_weak_vars () = Domain.DLS.get named_weak_vars_key let reset_names () = - names := []; - name_counter := 0; - named_vars := [] + names () := []; + name_counter () := 0; + named_vars () := [] let add_named_var ty = match ty.desc with | Tvar (Some name) | Tunivar (Some name) -> - if List.mem name !named_vars then () else named_vars := name :: !named_vars + if List.mem name !(named_vars ()) then () + else named_vars () := name :: !(named_vars ()) | _ -> () let name_is_already_used name = - List.mem name !named_vars - || List.exists (fun (_, name') -> name = name') !names - || String_set.mem name !named_weak_vars + List.mem name !(named_vars ()) + || List.exists (fun (_, name') -> name = name') !(names ()) + || String_set.mem name !(named_weak_vars ()) let rec new_name () = let name = - if !name_counter < 26 then String.make 1 (Char.chr (97 + !name_counter)) + if !(name_counter ()) < 26 then + String.make 1 (Char.chr (97 + !(name_counter ()))) else - String.make 1 (Char.chr (97 + (!name_counter mod 26))) - ^ string_of_int (!name_counter / 26) + String.make 1 (Char.chr (97 + (!(name_counter ()) mod 26))) + ^ string_of_int (!(name_counter ()) / 26) in - incr name_counter; + incr (name_counter ()); if name_is_already_used name then new_name () else name let rec new_weak_name ty () = - let name = "weak" ^ string_of_int !weak_counter in - incr weak_counter; + let name = "weak" ^ string_of_int !(weak_counter ()) in + incr (weak_counter ()); if name_is_already_used name then new_weak_name ty () else ( - named_weak_vars := String_set.add name !named_weak_vars; - weak_var_map := Type_map.add ty name !weak_var_map; + named_weak_vars () := String_set.add name !(named_weak_vars ()); + weak_var_map () := Type_map.add ty name !(weak_var_map ()); name) let name_of_type name_generator t = (* We've already been through repr at this stage, so t is our representative of the union-find class. *) - try List.assq t !names + try List.assq t !(names ()) with Not_found -> ( - try Type_map.find t !weak_var_map + try Type_map.find t !(weak_var_map ()) with Not_found -> let name = match t.desc with @@ -423,7 +448,9 @@ let name_of_type name_generator t = * adding a number until we find a name that's not taken. *) let current_name = ref name in let i = ref 0 in - while List.exists (fun (_, name') -> !current_name = name') !names do + while + List.exists (fun (_, name') -> !current_name = name') !(names ()) + do current_name := name ^ string_of_int !i; i := !i + 1 done; @@ -433,26 +460,32 @@ let name_of_type name_generator t = name_generator () in (* Exception for type declarations *) - if name <> "_" then names := (t, name) :: !names; + if name <> "_" then names () := (t, name) :: !(names ()); name) let check_name_of_type t = ignore (name_of_type new_name t) let remove_names tyl = let tyl = List.map repr tyl in - names := Ext_list.filter !names (fun (ty, _) -> not (List.memq ty tyl)) + names () := + Ext_list.filter !(names ()) (fun (ty, _) -> not (List.memq ty tyl)) -let visited_objects = ref ([] : type_expr list) -let aliased = ref ([] : type_expr list) -let delayed = ref ([] : type_expr list) +let visited_objects_key = + Request_local.new_key (fun () -> ref ([] : type_expr list)) +let visited_objects () = Domain.DLS.get visited_objects_key +let aliased_key = Request_local.new_key (fun () -> ref ([] : type_expr list)) +let aliased () = Domain.DLS.get aliased_key +let delayed_key = Request_local.new_key (fun () -> ref ([] : type_expr list)) +let delayed () = Domain.DLS.get delayed_key -let add_delayed t = if not (List.memq t !delayed) then delayed := t :: !delayed +let add_delayed t = + if not (List.memq t !(delayed ())) then delayed () := t :: !(delayed ()) -let is_aliased ty = List.memq (proxy ty) !aliased +let is_aliased ty = List.memq (proxy ty) !(aliased ()) let add_alias ty = let px = proxy ty in if not (is_aliased px) then ( - aliased := px :: !aliased; + aliased () := px :: !(aliased ()); add_named_var px) let aliasable ty = @@ -488,19 +521,20 @@ let rec mark_loops_rec visited ty = List.iter (mark_loops_rec visited) (apply_subst s tyl) | Tpackage (_, _, tyl) -> List.iter (mark_loops_rec visited) tyl | Tvariant row -> ( - if List.memq px !visited_objects then add_alias px + if List.memq px !(visited_objects ()) then add_alias px else let row = row_repr row in - if not (static_row row) then visited_objects := px :: !visited_objects; + if not (static_row row) then + visited_objects () := px :: !(visited_objects ()); match row.row_name with | Some (_p, tyl) when namable_row row -> List.iter (mark_loops_rec visited) tyl | _ -> iter_row (mark_loops_rec visited) row) | Tobject fi -> - if List.memq px !visited_objects then add_alias px + if List.memq px !(visited_objects ()) then add_alias px else ( if object_row_is_structurally_open ty then - visited_objects := px :: !visited_objects; + visited_objects () := px :: !(visited_objects ()); let fields, _ = flatten_fields fi in List.iter (fun {Ctype.f_typ} -> mark_loops_rec visited f_typ) fields) | Tfield {typ = ty1; rest = ty2} -> @@ -519,12 +553,12 @@ let mark_loops ty = mark_loops_rec [] ty let reset_loop_marks () = - visited_objects := []; - aliased := []; - delayed := [] + visited_objects () := []; + aliased () := []; + delayed () := [] let reset () = - unique_names := Ident.empty; + unique_names () := Ident.empty; reset_names (); reset_loop_marks () @@ -565,7 +599,7 @@ let find_inlined_type name (printing_context : printing_context option) = let rec tree_of_typexp ?(printing_context : printing_context option) sch ty = let ty = repr ty in let px = proxy ty in - if List.mem_assq px !names && not (List.memq px !delayed) then + if List.mem_assq px !(names ()) && not (List.memq px !(delayed ())) then let mark = is_non_gen sch ty in let name = name_of_type (if mark then new_weak_name ty else new_name) px in Otyp_var (mark, name) @@ -664,12 +698,12 @@ let rec tree_of_typexp ?(printing_context : printing_context option) sch ty = | Tpoly (ty, []) -> tree_of_typexp ?printing_context sch ty | Tpoly (ty, tyl) -> (*let print_names () = - List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !(names ()); prerr_string "; " in *) let tyl = List.map repr tyl in if tyl = [] then tree_of_typexp ?printing_context sch ty else - let old_delayed = !delayed in + let old_delayed = !(delayed ()) in (* Make the names delayed, so that the real type is printed once when used as proxy *) List.iter add_delayed tyl; @@ -677,7 +711,7 @@ let rec tree_of_typexp ?(printing_context : printing_context option) sch ty = let tr = Otyp_poly (tl, tree_of_typexp ?printing_context sch ty) in (* Forget names when we leave scope *) remove_names tyl; - delayed := old_delayed; + delayed () := old_delayed; tr | Tunivar _ -> Otyp_var (false, name_of_type new_name ty) | Tpackage (p, n, tyl) -> @@ -686,8 +720,8 @@ let rec tree_of_typexp ?(printing_context : printing_context option) sch ty = in Otyp_module (Path.name p, n, tree_of_typlist ?printing_context sch tyl) in - if List.memq px !delayed then - delayed := Ext_list.filter !delayed (( != ) px); + if List.memq px !(delayed ()) then + delayed () := Ext_list.filter !(delayed ()) (( != ) px); if is_aliased px && aliasable ty then ( check_name_of_type px; Otyp_alias (pr_typ (), name_of_type new_name px)) @@ -896,11 +930,11 @@ and tree_of_constructor ?printing_context ~layout ~position cd = match cd.cd_res with | None -> (name, arg (), None, repr) | Some res -> - let nm = !names in - names := []; + let nm = !(names ()) in + names () := []; let ret = tree_of_typexp ?printing_context false res in let args = arg () in - names := nm; + names () := nm; (name, args, Some ret, repr) and tree_of_label ?printing_context l = @@ -974,11 +1008,11 @@ let tree_of_extension_constructor id ext es = match ext.ext_ret_type with | None -> (tree_of_constructor_arguments ext.ext_args, None) | Some res -> - let nm = !names in - names := []; + let nm = !(names ()) in + names () := []; let ret = tree_of_typexp false res in let args = tree_of_constructor_arguments ext.ext_args in - names := nm; + names () := nm; (args, Some ret) in let ext = @@ -1024,7 +1058,7 @@ let value_description id ppf decl = (* Print a module type *) let wrap_env fenv ftree arg = - let env = !printing_env in + let env = !(printing_env ()) in set_printing_env (fenv env); let tree = ftree arg in set_printing_env env; @@ -1050,7 +1084,7 @@ let dummy = let hide_rec_items = function | Sig_type (id, _decl, rs) :: rem - when rs = Trec_first && not !Clflags.real_paths -> + when rs = Trec_first && not !((Clflags.current ()).real_paths) -> let rec get_ids = function | Sig_type (id, _, Trec_next) :: rem -> id :: get_ids rem | _ -> [] @@ -1059,7 +1093,8 @@ let hide_rec_items = function set_printing_env (List.fold_right (fun id -> Env.add_type ~check:false (Ident.rename id) dummy) - ids !printing_env) + ids + !(printing_env ())) | _ -> () let rec tree_of_modtype ?(ellipsis = false) = function @@ -1081,7 +1116,7 @@ let rec tree_of_modtype ?(ellipsis = false) = function | Mty_alias (_, p) -> Omty_alias (tree_of_path p) and tree_of_signature sg = - wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg + wrap_env (fun env -> env) (tree_of_signature_rec !(printing_env ()) false) sg and tree_of_signature_rec env' in_type_group = function | [] -> [] diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index fd0c8e58bd1..3023a2054e7 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -26,7 +26,7 @@ let fmt_position f l = (l.pos_cnum - l.pos_bol) let fmt_location f loc = - if !Clflags.dump_location then ( + if !((Clflags.current ()).dump_location) then ( fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; if loc.loc_ghost then fprintf f " ghost") diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index ac93e407027..0ba01289e88 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -55,14 +55,15 @@ let add_modtype id ty s = {s with modtypes = Tbl.add id ty s.modtypes} let for_saving s = {s with for_saving = true} let loc s x = - if s.for_saving && not !Clflags.keep_locs then Location.none else x + if s.for_saving && not !((Clflags.current ()).keep_locs) then Location.none + else x let remove_loc = let open Ast_mapper in {default_mapper with location = (fun _this _loc -> Location.none)} let attrs s x = - if s.for_saving && not !Clflags.keep_locs then + if s.for_saving && not !((Clflags.current ()).keep_locs) then remove_loc.Ast_mapper.attributes remove_loc x else x @@ -109,12 +110,13 @@ let to_subst_by_type_function s p = (* Special type ids for saved signatures *) -let new_id = ref (-1) -let reset_for_saving () = new_id := -1 +let reset_for_saving () = + (Compiler_request_state.current ()).substitution_saved_id <- -1 let newpersty desc = - decr new_id; - {desc; level = generic_level; id = !new_id} + let state = Compiler_request_state.current () in + state.substitution_saved_id <- state.substitution_saved_id - 1; + {desc; level = generic_level; id = state.substitution_saved_id} (* ensure that all occurrences of 'Tvar None' are physically shared *) let tvar_none = Tvar None diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml index 55c236f83f7..8ece566fea5 100644 --- a/compiler/ml/switch.ml +++ b/compiler/ml/switch.ml @@ -331,7 +331,8 @@ let rec pkey chan = function Printf.fprintf chan "%a %a" pkey rem pkind k *) -let t = Hashtbl.create 17 +let cache_key = Request_local.new_key (fun () -> Hashtbl.create 17) +let cache () = Domain.DLS.get cache_key let make_key cases = let seen = ref [] and count = ref 0 in @@ -386,11 +387,12 @@ let same_act t = let inter_limit = 1 lsl 16 -let ok_inter = ref false +let ok_inter_key = Request_local.new_key (fun () -> ref false) +let ok_inter () = Domain.DLS.get ok_inter_key let rec opt_count top cases = let key = make_key cases in - try Hashtbl.find t key + try Hashtbl.find (cache ()) key with Not_found -> let r = let lcases = Array.length cases in @@ -402,7 +404,7 @@ let rec opt_count top cases = else if lcases < !more_cut then heuristic cases else divide cases in - Hashtbl.add t key r; + Hashtbl.add (cache ()) key r; r and divide cases = @@ -423,7 +425,7 @@ and heuristic cases = let sep, csep = divide cases and inter, cinter = - if !ok_inter then + if !(ok_inter ()) then let _, _, act0 = cases.(0) and _, _, act1 = cases.(lcases - 1) in if act0 = act1 then ( let low, high, inside, outside = coupe_inter 1 (lcases - 2) cases in @@ -464,7 +466,7 @@ and enum top cases = in let ilow, ihigh, with_inter = - if not !ok_inter then ( + if not !(ok_inter ()) then ( let rlow = ref (-1) and rhigh = ref (-1) and best_cost = ref (too_much, too_much) in @@ -709,9 +711,9 @@ let make_clusters ({cases; actions} as s) n_clusters k = {cases = r; actions = acts} let do_zyva (low, high) arg cases actions = - let old_ok = !ok_inter in - ok_inter := abs low <= inter_limit && abs high <= inter_limit; - if !ok_inter <> old_ok then Hashtbl.clear t; + let old_ok = !(ok_inter ()) in + ok_inter () := abs low <= inter_limit && abs high <= inter_limit; + if !(ok_inter ()) <> old_ok then Hashtbl.clear (cache ()); let s = {cases; actions} in @@ -750,9 +752,9 @@ and test_sequence arg cases actions = assert (Array.length cases > 0); let actions = actions.act_get_shared () in let hs, actions = abstract_shared actions in - let old_ok = !ok_inter in - ok_inter := false; - if !ok_inter <> old_ok then Hashtbl.clear t; + let old_ok = !(ok_inter ()) in + ok_inter () := false; + if !(ok_inter ()) <> old_ok then Hashtbl.clear (cache ()); let s = {cases; actions = Array.map (fun act _ -> act) actions} in (* Printf.eprintf "SEQUENCE: %B\n" !ok_inter ; diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index a5897de7876..f188a6395f2 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1222,7 +1222,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.t = args; transformed_jsx = true; } - when !Clflags.jsx_preserve + when !((Clflags.current ()).jsx_preserve) && Option.is_some (jsx_call e.exp_env funct p ~val_type args) -> ( Builtin_attributes.warning_scope ~ppwarning:false funct.exp_attributes (fun () -> @@ -1523,10 +1523,10 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.t = (transl_exp body) | Texp_pack modl -> !transl_module Tcoerce_none None modl | Texp_assert {exp_desc = Texp_construct (_, {cstr_name = "false"}, _)} -> - if !Clflags.no_assert_false then Lambda.lambda_assert_false + if !((Clflags.current ()).no_assert_false) then Lambda.lambda_assert_false else assert_failed e | Texp_assert cond -> - if !Clflags.noassert then lambda_unit + if !((Clflags.current ()).noassert) then lambda_unit else if_ (transl_exp cond) lambda_unit (assert_failed e) and transl_list expr_list = List.map transl_exp expr_list diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index a1eb7bb8df5..9bf1b0e0fa7 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -84,8 +84,10 @@ let transl_type_extension env rootpath (tyext : Typedtree.type_extension) body : (* Compile a coercion *) let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = - if !Clflags.dump_coercions then - Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion restr; + if !((Clflags.current ()).dump_coercions) then + Format.fprintf + (Compiler_request_output.stderr_formatter ()) + "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion restr; match restr with | Tcoerce_none -> arg | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> @@ -225,8 +227,14 @@ let get_functor_params mexp coercion root_path = ((param, loc, arg_coercion), body, path, res_coercion, inline_attribute) | _ -> assert false -let export_identifiers : Ident.t list ref = ref [] -let js_hoisted : Lambda.hoisted_function list ref = ref [] +(* Translation can overlap on compiler domains. Each request owns the export + and hoisting accumulators until [transl_implementation] returns them. *) +let export_identifiers_key = Request_local.new_key (fun () -> ref []) +let js_hoisted_key = Request_local.new_key (fun () -> ref []) +let export_identifiers () : Ident.t list ref = + Domain.DLS.get export_identifiers_key +let js_hoisted () : Lambda.hoisted_function list ref = + Domain.DLS.get js_hoisted_key let js_hoist_handler rootpath = match exportable_module_path rootpath with @@ -234,9 +242,9 @@ let js_hoist_handler rootpath = | Some path -> Some (fun id loc -> - js_hoisted := + js_hoisted () := {Lambda.binding = id; path = path @ [id.Ident.name]; loc} - :: !js_hoisted) + :: !(js_hoisted ())) let rec compile_functor mexp coercion root_path loc = let functor_param, body, body_path, res_coercion, inline_attribute = @@ -307,14 +315,15 @@ and transl_structure loc fields cc rootpath final_env = function List.fold_left (fun acc id -> if is_top_root_path then - export_identifiers := id :: !export_identifiers; + export_identifiers () := id :: !(export_identifiers ()); Lambda.var id :: acc) [] fields in ( Lambda.prim ~primitive: (Pmakeblock - (if is_top_root_path then Blk_module_export !export_identifiers + (if is_top_root_path then + Blk_module_export !(export_identifiers ()) else Blk_module (List.rev_map (fun id -> id.Ident.name) fields))) ~args:block_fields loc, List.length fields ) @@ -335,13 +344,13 @@ and transl_structure loc fields cc rootpath final_env = function match cc with | Tcoerce_primitive p -> if is_top rootpath then - export_identifiers := p.pc_id :: !export_identifiers; + export_identifiers () := p.pc_id :: !(export_identifiers ()); Translcore.transl_primitive p.pc_loc p.pc_desc p.pc_env p.pc_type ~val_type:p.pc_type :: code | _ -> if is_top rootpath then - export_identifiers := v.(pos) :: !export_identifiers; + export_identifiers () := v.(pos) :: !(export_identifiers ()); apply_coercion loc Strict cc (get_field pos) :: code) pos_cc_list [] in @@ -349,7 +358,8 @@ and transl_structure loc fields cc rootpath final_env = function Lambda.prim ~primitive: (Pmakeblock - (if is_top_root_path then Blk_module_export !export_identifiers + (if is_top_root_path then + Blk_module_export !(export_identifiers ()) else Blk_module runtime_fields)) ~args:result loc and id_pos_list = @@ -468,14 +478,14 @@ type implementation = { } let transl_implementation module_name (str, cc) = - export_identifiers := []; - js_hoisted := []; + export_identifiers () := []; + js_hoisted () := []; let module_id = Ident.create_persistent module_name in let body, _ = transl_struct Location.none [] cc (global_path module_id) str in { lambda = body; - exports = !export_identifiers; - hoisted_functions = !js_hoisted; + exports = !(export_identifiers ()); + hoisted_functions = !(js_hoisted ()); } (* Build the list of value identifiers defined by a toplevel structure diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 185ce007649..a80e677beee 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -105,7 +105,9 @@ type error = exception Error of Location.t * Env.t * error exception Error_forward of Location.error -(* Forward declaration, to be filled in by Typemod.type_module *) +(* Typemod fills these forward declarations during module initialization. + The driver completes that initialization before requests run on domains; + the callbacks are read-only during each request. *) let type_module = ref @@ -145,7 +147,36 @@ let rp node = type recarg = Allowed | Required | Rejected -let loop_depth = ref 0 +(* Typing a request mutates these stacks while traversing expressions and + patterns. A failed request must not leave them in another request. *) +type request_state = { + loop_depth: int ref; + newtype_level: int option ref; + pattern_variables: + (Ident.t * type_expr * string loc * Location.t * bool) list ref; + pattern_force: (unit -> unit) list ref; + allow_modules: bool ref; + module_variables: (string loc * Location.t) list ref; +} + +let fresh_state () = + { + loop_depth = ref 0; + newtype_level = ref None; + pattern_variables = ref []; + pattern_force = ref []; + allow_modules = ref false; + module_variables = ref []; + } + +let state_key = Request_local.new_key fresh_state +let state () = Domain.DLS.get state_key +let loop_depth_ref () = (state ()).loop_depth +let newtype_level_ref () = (state ()).newtype_level +let pattern_variables_ref () = (state ()).pattern_variables +let pattern_force_ref () = (state ()).pattern_force +let allow_modules_ref () = (state ()).allow_modules +let module_variables_ref () = (state ()).module_variables let with_depth depth_ref f = let saved = !depth_ref in @@ -153,9 +184,9 @@ let with_depth depth_ref f = Misc.try_finally f (fun () -> depth_ref := saved) let with_reset_control_flow f = - let saved_loop_depth = !loop_depth in - loop_depth := 0; - Misc.try_finally f (fun () -> loop_depth := saved_loop_depth) + let saved_loop_depth = !(loop_depth_ref ()) in + loop_depth_ref () := 0; + Misc.try_finally f (fun () -> loop_depth_ref () := saved_loop_depth) let case lhs rhs = {c_lhs = lhs; c_guard = None; c_rhs = rhs} @@ -283,11 +314,11 @@ let all_idents_cases el = (* Typing of constants *) let type_constant = function - | Const_int _ -> instance_def Predef.type_int - | Const_char _ -> instance_def Predef.type_char - | Const_string _ -> instance_def Predef.type_string - | Const_float _ -> instance_def Predef.type_float - | Const_bigint _ -> instance_def Predef.type_bigint + | Const_int _ -> instance_def (Predef.type_int ()) + | Const_char _ -> instance_def (Predef.type_char ()) + | Const_string _ -> instance_def (Predef.type_string ()) + | Const_float _ -> instance_def (Predef.type_float ()) + | Const_bigint _ -> instance_def (Predef.type_bigint ()) let constant : Parsetree.constant -> (Asttypes.constant, error) result = function @@ -328,13 +359,13 @@ let mkexp exp_desc exp_type exp_loc exp_env = {exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = []} let option_none ty loc = - let lid = Longident.Lident "None" and env = Env.initial_safe_string in + let lid = Longident.Lident "None" and env = Env.initial_safe_string () in let cnone = Env.lookup_constructor lid env in mkexp (Texp_construct (mknoloc lid, cnone, [])) ty loc env let option_some texp = let lid = Longident.Lident "Some" in - let csome = Env.lookup_constructor lid Env.initial_safe_string in + let csome = Env.lookup_constructor lid (Env.initial_safe_string ()) in mkexp (Texp_construct (mknoloc lid, csome, [texp])) (type_option texp.exp_type) @@ -385,15 +416,14 @@ let unify_exp_types ~context loc env ty expected_ty = raise (Error (loc, env, Expr_type_clash {trace; context})) (* level at which to create the local type declarations *) -let newtype_level = ref None let get_newtype_level () = - match !newtype_level with + match !(newtype_level_ref ()) with | Some y -> y | None -> assert false let unify_pat_types_gadt loc env ty ty' = let newtype_level = - match !newtype_level with + match !(newtype_level_ref ()) with | None -> assert false | Some x -> x in @@ -445,33 +475,26 @@ let has_variants p = with Exit -> true (* pattern environment *) -let pattern_variables = - ref - ([] - : (Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) - list) -let pattern_force = ref ([] : (unit -> unit) list) -let allow_modules = ref false -let module_variables = ref ([] : (string loc * Location.t) list) let reset_pattern allow = - pattern_variables := []; - pattern_force := []; - allow_modules := allow; - module_variables := [] + pattern_variables_ref () := []; + pattern_force_ref () := []; + allow_modules_ref () := allow; + module_variables_ref () := [] let enter_variable ?(is_module = false) ?(is_as_variable = false) loc name ty = if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt) - !pattern_variables + !(pattern_variables_ref ()) then raise (Error (loc, Env.empty, Multiply_bound_variable name.txt)); let id = Ident.create name.txt in - pattern_variables := (id, ty, name, loc, is_as_variable) :: !pattern_variables; + pattern_variables_ref () := + (id, ty, name, loc, is_as_variable) :: !(pattern_variables_ref ()); if is_module then ( (* Note: unpack patterns enter a variable of the same name *) - if not !allow_modules then + if not !(allow_modules_ref ()) then raise (Error (loc, Env.empty, Modules_not_allowed)); - module_variables := (name, loc) :: !module_variables); + module_variables_ref () := (name, loc) :: !(module_variables_ref ())); id let sort_pattern_variables vs = @@ -1335,7 +1358,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp let cty, force = Typetexp.transl_simple_type_delayed !env sty in let ty = cty.ctyp_type in unify_pat_types lloc !env ty expected_ty; - pattern_force := force :: !pattern_force; + pattern_force_ref () := force :: !(pattern_force_ref ()); match ty.desc with | Tpoly (body, tyl) -> begin_def (); @@ -1661,7 +1684,8 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp try Some (Typecore_record_rest.type_record_pat_rest ~env:!env - ~pattern_force ~loc ~record_ty ~lbl_pat_list ~rest + ~pattern_force:(pattern_force_ref ()) ~loc ~record_ty + ~lbl_pat_list ~rest ~enter_variable:(fun loc name ty -> enter_variable loc name ty) ~unify_pat_types ~check_not_private) with Typecore_record_rest.Error (loc, env, err) -> @@ -1709,21 +1733,21 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp let state = save_state env in match if mode = Split_or || mode = Splitting_or then raise Need_backtrack; - let initial_pattern_variables = !pattern_variables in - let initial_module_variables = !module_variables in + let initial_pattern_variables = !(pattern_variables_ref ()) in + let initial_module_variables = !(module_variables_ref ()) in let p1 = try Some (type_pat ~mode:Inside_or sp1 expected_ty (fun x -> x)) with Need_backtrack -> None in - let p1_variables = !pattern_variables in - let p1_module_variables = !module_variables in - pattern_variables := initial_pattern_variables; - module_variables := initial_module_variables; + let p1_variables = !(pattern_variables_ref ()) in + let p1_module_variables = !(module_variables_ref ()) in + pattern_variables_ref () := initial_pattern_variables; + module_variables_ref () := initial_module_variables; let p2 = try Some (type_pat ~mode:Inside_or sp2 expected_ty (fun x -> x)) with Need_backtrack -> None in - let p2_variables = !pattern_variables in + let p2_variables = !(pattern_variables_ref ()) in match (p1, p2) with | None, None -> raise Need_backtrack | Some p, None | None, Some p -> p (* no variables in this case *) @@ -1731,8 +1755,8 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp let alpha_env = enter_orpat_variables loc !env p1_variables p2_variables in - pattern_variables := p1_variables; - module_variables := p1_module_variables; + pattern_variables_ref () := p1_variables; + module_variables_ref () := p1_module_variables; { pat_desc = Tpat_or (p1, alpha_pat alpha_env p2, None); pat_loc = loc; @@ -1766,7 +1790,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp in unify_pat_types loc !env ty expected_ty; type_pat sp expected_ty' (fun p -> - pattern_force := force :: !pattern_force; + pattern_force_ref () := force :: !(pattern_force_ref ()); let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in let p = if not separate then p @@ -1802,17 +1826,17 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp let type_pat ?(allow_existentials = false) ?constrs ?labels ?(mode = Normal) ?(explode = 0) ?(lev = get_current_level ()) env sp expected_ty = - newtype_level := Some lev; + newtype_level_ref () := Some lev; try let r = type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels ~mode ~explode ~env sp expected_ty (fun x -> x) in iter_pattern (fun p -> p.pat_env <- !env) r; - newtype_level := None; + newtype_level_ref () := None; r with e -> - newtype_level := None; + newtype_level_ref () := None; raise e (* this function is passed to Parmatch.check_partial_gadt and @@ -1854,7 +1878,7 @@ let check_unused ?(lev = get_current_level ()) env expected_ty cases = cases let add_pattern_variables ?check ?check_as env = - let pv = get_ref pattern_variables in + let pv = get_ref (pattern_variables_ref ()) in ( List.fold_right (fun (id, ty, _name, loc, as_var) env -> let check = if as_var then check_as else check in @@ -1867,7 +1891,7 @@ let add_pattern_variables ?check ?check_as env = } env) pv env, - get_ref module_variables ) + get_ref (module_variables_ref ()) ) let type_pattern ~lev env spat expected_ty = reset_pattern true; @@ -1878,7 +1902,7 @@ let type_pattern ~lev env spat expected_ty = ~check:(fun s -> Warnings.Unused_var_strict s) ~check_as:(fun s -> Warnings.Unused_var s) in - (pat, new_env, get_ref pattern_force, unpacks) + (pat, new_env, get_ref (pattern_force_ref ()), unpacks) let type_pattern_list env spatl expected_tys allow = reset_pattern allow; @@ -1889,7 +1913,7 @@ let type_pattern_list env spatl expected_tys allow = in let patl = List.map2 type_pat spatl expected_tys in let new_env, unpacks = add_pattern_variables !new_env in - (patl, new_env, get_ref pattern_force, unpacks) + (patl, new_env, get_ref (pattern_force_ref ()), unpacks) let rec final_subexpression sexp = match sexp.pexp_desc with @@ -2590,7 +2614,8 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp let values = List.map (fun value -> - type_expect ~context:(Some StringConcat) env value Predef.type_string) + type_expect ~context:(Some StringConcat) env value + (Predef.type_string ())) values in end_def (); @@ -2599,7 +2624,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_desc = Texp_template {segments; values}; exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_string; + exp_type = instance_def (Predef.type_string ()); exp_attributes = sexp.pexp_attributes; exp_env = env; } @@ -2727,7 +2752,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp val_caselist in let exn_cases, _ = - type_cases ~call_context env Predef.type_exn ty_expected false loc + type_cases ~call_context env (Predef.type_exn ()) ty_expected false loc exn_caselist in re @@ -2742,8 +2767,8 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp | Pexp_try (sbody, caselist) -> let body = type_expect ~context:None env sbody ty_expected in let cases, _ = - type_cases ~call_context:`Try env Predef.type_exn ty_expected false loc - caselist + type_cases ~call_context:`Try env (Predef.type_exn ()) ty_expected false + loc caselist in re { @@ -3064,7 +3089,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_desc = Texp_setfield (record, label_loc, label, newval); exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; + exp_type = instance_def (Predef.type_unit ()); exp_attributes = sexp.pexp_attributes; exp_env = env; } @@ -3118,12 +3143,12 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp | _ -> assert false in let cond = - type_expect ~context:(Some IfCondition) env scond Predef.type_bool + type_expect ~context:(Some IfCondition) env scond (Predef.type_bool ()) in match sifnot with | None -> let ifso = - type_expect ~context:return_context env sifso Predef.type_unit + type_expect ~context:return_context env sifso (Predef.type_unit ()) in rue { @@ -3168,51 +3193,55 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_env = env; } | Pexp_break -> - if !loop_depth = 0 then raise (Error (loc, env, Break_outside_loop)) + if !(loop_depth_ref ()) = 0 then + raise (Error (loc, env, Break_outside_loop)) else rue { exp_desc = Texp_break; exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; + exp_type = instance_def (Predef.type_unit ()); exp_attributes = sexp.pexp_attributes; exp_env = env; } | Pexp_continue -> - if !loop_depth = 0 then raise (Error (loc, env, Continue_outside_loop)) + if !(loop_depth_ref ()) = 0 then + raise (Error (loc, env, Continue_outside_loop)) else rue { exp_desc = Texp_continue; exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; + exp_type = instance_def (Predef.type_unit ()); exp_attributes = sexp.pexp_attributes; exp_env = env; } | Pexp_while (scond, sbody) -> let cond = - type_expect ~context:(Some WhileCondition) env scond Predef.type_bool + type_expect ~context:(Some WhileCondition) env scond (Predef.type_bool ()) in let body = - with_depth loop_depth (fun () -> type_statement ~context:None env sbody) + with_depth (loop_depth_ref ()) (fun () -> + type_statement ~context:None env sbody) in rue { exp_desc = Texp_while (cond, body); exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; + exp_type = instance_def (Predef.type_unit ()); exp_attributes = sexp.pexp_attributes; exp_env = env; } | Pexp_for (param, slow, shigh, dir, sbody) -> let low = - type_expect ~context:(Some ForLoopCondition) env slow Predef.type_int + type_expect ~context:(Some ForLoopCondition) env slow (Predef.type_int ()) in let high = - type_expect ~context:(Some ForLoopCondition) env shigh Predef.type_int + type_expect ~context:(Some ForLoopCondition) env shigh + (Predef.type_int ()) in let id, new_env = match param.ppat_desc with @@ -3220,7 +3249,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp | Ppat_var {txt} -> Env.enter_value txt { - val_type = instance_def Predef.type_int; + val_type = instance_def (Predef.type_int ()); val_attributes = []; val_kind = Val_reg; Types.val_loc = loc; @@ -3230,7 +3259,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp | _ -> raise (Error (param.ppat_loc, env, Invalid_for_loop_index)) in let body = - with_depth loop_depth (fun () -> + with_depth (loop_depth_ref ()) (fun () -> type_statement ~context:None new_env sbody) in rue @@ -3238,7 +3267,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_desc = Texp_for (id, param, low, high, dir, body); exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; + exp_type = instance_def (Predef.type_unit ()); exp_attributes = sexp.pexp_attributes; exp_env = env; } @@ -3291,7 +3320,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp assert false in let body = - with_depth loop_depth (fun () -> + with_depth (loop_depth_ref ()) (fun () -> type_statement ~context:None new_env sbody) in rue @@ -3299,7 +3328,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_desc = Texp_for_of (id, param, collection, body); exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; + exp_type = instance_def (Predef.type_unit ()); exp_attributes = sexp.pexp_attributes; exp_env = env; } @@ -3328,7 +3357,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp assert false in let body = - with_depth loop_depth (fun () -> + with_depth (loop_depth_ref ()) (fun () -> type_statement ~context:None new_env sbody) in rue @@ -3336,7 +3365,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_desc = Texp_for_await_of (id, param, collection, body); exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; + exp_type = instance_def (Predef.type_unit ()); exp_attributes = sexp.pexp_attributes; exp_env = env; } @@ -3524,7 +3553,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_desc = Texp_object_set (obj, name_loc, value); exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; + exp_type = instance_def (Predef.type_unit ()); exp_attributes = sexp.pexp_attributes; exp_env = env; }) @@ -3575,12 +3604,12 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp } | Pexp_assert e -> let cond = - type_expect ~context:(Some AssertCondition) env e Predef.type_bool + type_expect ~context:(Some AssertCondition) env e (Predef.type_bool ()) in let exp_type = match cond.exp_desc with | Texp_construct (_, {cstr_name = "false"}, _) -> instance env ty_expected - | _ -> instance_def Predef.type_unit + | _ -> instance_def (Predef.type_unit ()) in rue { @@ -3638,7 +3667,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_desc = Texp_extension_constructor (lid, path); exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_extension_constructor; + exp_type = instance_def (Predef.type_extension_constructor ()); exp_attributes = sexp.pexp_attributes; exp_env = env; } @@ -4197,23 +4226,23 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) let result_type = match (lhs_type.desc, specialization) with | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> - instance_def Predef.type_int + instance_def (Predef.type_int ()) | Tconstr (path, _, _), {bool = Some _} when Path.same path Predef.path_bool -> - instance_def Predef.type_bool + instance_def (Predef.type_bool ()) | Tconstr (path, _, _), {float = Some _} when Path.same path Predef.path_float -> - instance_def Predef.type_float + instance_def (Predef.type_float ()) | Tconstr (path, _, _), {bigint = Some _} when Path.same path Predef.path_bigint -> - instance_def Predef.type_bigint + instance_def (Predef.type_bigint ()) | Tconstr (path, _, _), {string = Some _} when Path.same path Predef.path_string -> - instance_def Predef.type_string + instance_def (Predef.type_string ()) | _ -> ( try - unify env lhs_type (instance_def Predef.type_int); - instance_def Predef.type_int + unify env lhs_type (instance_def (Predef.type_int ())); + instance_def (Predef.type_int ()) with Ctype.Unify trace -> raise (Error (lhs.exp_loc, env, Expr_type_clash {trace; context = None})) @@ -4231,57 +4260,75 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) (* Rule 1. Try unifying to lhs *) match (lhs_type.desc, specialization) with | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> - let rhs = type_expect ~context:None env rhs_expr Predef.type_int in - (lhs, rhs, instance_def Predef.type_int) + let rhs = + type_expect ~context:None env rhs_expr (Predef.type_int ()) + in + (lhs, rhs, instance_def (Predef.type_int ())) | Tconstr (path, _, _), {bool = Some _} when Path.same path Predef.path_bool -> - let rhs = type_expect ~context:None env rhs_expr Predef.type_bool in - (lhs, rhs, instance_def Predef.type_bool) + let rhs = + type_expect ~context:None env rhs_expr (Predef.type_bool ()) + in + (lhs, rhs, instance_def (Predef.type_bool ())) | Tconstr (path, _, _), {float = Some _} when Path.same path Predef.path_float -> - let rhs = type_expect ~context:None env rhs_expr Predef.type_float in - (lhs, rhs, instance_def Predef.type_float) + let rhs = + type_expect ~context:None env rhs_expr (Predef.type_float ()) + in + (lhs, rhs, instance_def (Predef.type_float ())) | Tconstr (path, _, _), {bigint = Some _} when Path.same path Predef.path_bigint -> - let rhs = type_expect ~context:None env rhs_expr Predef.type_bigint in - (lhs, rhs, instance_def Predef.type_bigint) + let rhs = + type_expect ~context:None env rhs_expr (Predef.type_bigint ()) + in + (lhs, rhs, instance_def (Predef.type_bigint ())) | Tconstr (path, _, _), {string = Some _} when Path.same path Predef.path_string -> - let rhs = type_expect ~context:None env rhs_expr Predef.type_string in - (lhs, rhs, instance_def Predef.type_string) + let rhs = + type_expect ~context:None env rhs_expr (Predef.type_string ()) + in + (lhs, rhs, instance_def (Predef.type_string ())) | _ -> ( (* Rule 2. Try unifying to rhs *) match (rhs_type.desc, specialization) with | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> - let lhs = type_expect ~context:None env lhs_expr Predef.type_int in - (lhs, rhs, instance_def Predef.type_int) + let lhs = + type_expect ~context:None env lhs_expr (Predef.type_int ()) + in + (lhs, rhs, instance_def (Predef.type_int ())) | Tconstr (path, _, _), {bool = Some _} when Path.same path Predef.path_bool -> - let lhs = type_expect ~context:None env lhs_expr Predef.type_bool in - (lhs, rhs, instance_def Predef.type_bool) + let lhs = + type_expect ~context:None env lhs_expr (Predef.type_bool ()) + in + (lhs, rhs, instance_def (Predef.type_bool ())) | Tconstr (path, _, _), {float = Some _} when Path.same path Predef.path_float -> let lhs = - type_expect ~context:None env lhs_expr Predef.type_float + type_expect ~context:None env lhs_expr (Predef.type_float ()) in - (lhs, rhs, instance_def Predef.type_float) + (lhs, rhs, instance_def (Predef.type_float ())) | Tconstr (path, _, _), {bigint = Some _} when Path.same path Predef.path_bigint -> let lhs = - type_expect ~context:None env lhs_expr Predef.type_bigint + type_expect ~context:None env lhs_expr (Predef.type_bigint ()) in - (lhs, rhs, instance_def Predef.type_bigint) + (lhs, rhs, instance_def (Predef.type_bigint ())) | Tconstr (path, _, _), {string = Some _} when Path.same path Predef.path_string -> let lhs = - type_expect ~context:None env lhs_expr Predef.type_string + type_expect ~context:None env lhs_expr (Predef.type_string ()) in - (lhs, rhs, instance_def Predef.type_string) + (lhs, rhs, instance_def (Predef.type_string ())) | _ -> (* Rule 3. Fallback to int *) - let lhs = type_expect ~context:None env lhs_expr Predef.type_int in - let rhs = type_expect ~context:None env rhs_expr Predef.type_int in - (lhs, rhs, instance_def Predef.type_int)) + let lhs = + type_expect ~context:None env lhs_expr (Predef.type_int ()) + in + let rhs = + type_expect ~context:None env rhs_expr (Predef.type_int ()) + in + (lhs, rhs, instance_def (Predef.type_int ()))) in let targs = [(lhs_label, Some lhs); (rhs_label, Some rhs)] in Some (targs, result_type) @@ -4585,7 +4632,7 @@ and type_statement ~context env sexp = let ty = expand_head env exp.exp_type and tv = newvar () in if is_Tvar ty && ty.level > tv.level then Location.prerr_warning loc Warnings.Nonreturning_statement; - let expected_ty = instance_def Predef.type_unit in + let expected_ty = instance_def (Predef.type_unit ()) in let context = type_clash_context_in_statement sexp in unify_exp ~context env exp expected_ty; exp @@ -4689,7 +4736,7 @@ and type_cases ~(call_context : [`LetUnwrap | `Switch | `Function | `Try]) env Some (type_expect ~context:(Some IfCondition) ext_env (wrap_unpacks scond unpacks) - Predef.type_bool) + (Predef.type_bool ())) in let exp = type_expect @@ -4988,7 +5035,7 @@ let type_expression ~context env sexp = begin_def (); let exp = type_exp ~context env sexp in if Warnings.is_active (Bs_toplevel_expression_unit None) then ( - try unify env exp.exp_type (instance_def Predef.type_unit) + try unify env exp.exp_type (instance_def (Predef.type_unit ())) with Unify _ -> let buffer = Buffer.create 10 in let formatter = Format.formatter_of_buffer buffer in diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 52e342afa4e..6d5a4a55168 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -495,14 +495,16 @@ let map_pattern_desc f d = (* List the identifiers bound by a pattern or a let *) -let idents = ref ([] : (Ident.t * string loc) list) +let idents_key = + Request_local.new_key (fun () -> ref ([] : (Ident.t * string loc) list)) +let idents () = Domain.DLS.get idents_key let rec bound_idents pat = match pat.pat_desc with - | Tpat_var (id, s) -> idents := (id, s) :: !idents + | Tpat_var (id, s) -> idents () := (id, s) :: !(idents ()) | Tpat_alias (p, id, s) -> bound_idents p; - idents := (id, s) :: !idents + idents () := (id, s) :: !(idents ()) | Tpat_or (p1, _, _) -> (* Invariant : both arguments binds the same variables *) bound_idents p1 @@ -510,22 +512,22 @@ let rec bound_idents pat = (* Record rest is stored on Tpat_record, not as a child Tpat_var that iter_pattern_desc can visit. Add it here so Lambda compilation sees the binding. *) - idents := (rest.rest_ident, rest.rest_name) :: !idents; + idents () := (rest.rest_ident, rest.rest_name) :: !(idents ()); iter_pattern_desc bound_idents pat.pat_desc | d -> iter_pattern_desc bound_idents d let pat_bound_idents pat = - idents := []; + idents () := []; bound_idents pat; - let res = !idents in - idents := []; + let res = !(idents ()) in + idents () := []; List.map fst res let rev_let_bound_idents_with_loc bindings = - idents := []; + idents () := []; List.iter (fun vb -> bound_idents vb.vb_pat) bindings; - let res = !idents in - idents := []; + let res = !(idents ()) in + idents () := []; res let let_bound_idents_with_loc pat_expr_list = diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index 63d3f50e456..6a2d5a30387 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -1715,10 +1715,10 @@ let type_implementation_more ?check_exists sourcefile outputprefix modulename Delayed_checks.reset_delayed_checks (); let str, sg, finalenv = type_structure initial_env ast in let simple_sg = simplify_signature sg in - let mli_status = !Clflags.assume_no_mli 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.load_path (modulename ^ ".cmi") + try find_in_path_uncap (Config.get_load_path ()) (modulename ^ ".cmi") with Not_found -> let sourceintf = Filename.remove_extension sourcefile ^ Literals.suffix_resi @@ -1753,7 +1753,7 @@ let type_implementation_more ?check_exists sourcefile outputprefix modulename 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.dont_write_files then ( + if not !((Clflags.current ()).dont_write_files) then ( let deprecated = Builtin_attributes.deprecated_of_str ast in ignore (Env.save_signature ?check_exists ~deprecated simple_sg modulename diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 7a805b2cdb8..69c7984ac69 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -88,7 +88,7 @@ let find_component (lookup : ?loc:_ -> _) make_error env loc lid = try match lid with | Longident.Ldot (Longident.Lident "*predef*", s) -> - lookup ~loc (Longident.Lident s) Env.initial_safe_string + lookup ~loc (Longident.Lident s) (Env.initial_safe_string ()) | _ -> lookup ~loc lid env with | Not_found -> narrow_unbound_lid_error env loc lid make_error @@ -189,21 +189,37 @@ let create_package_mty fake loc env (p, l) = (* Translation of type expressions *) -let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t) -let univars = ref ([] : (string * type_expr) list) -let pre_univars = ref ([] : type_expr list) -let used_variables = ref (Tbl.empty : (string, type_expr * Location.t) Tbl.t) +type variable_refs = { + type_variables_ref: (string, type_expr) Tbl.t ref; + univars_ref: (string * type_expr) list ref; + used_variables_ref: (string, type_expr * Location.t) Tbl.t ref; +} + +(* These tables describe the type variables being translated by this request. + Sharing them across domains can make a valid interface report an unbound + type parameter when another translation clears its table. *) +let variable_refs = + Request_local.new_key (fun () -> + { + type_variables_ref = ref Tbl.empty; + univars_ref = ref []; + used_variables_ref = ref Tbl.empty; + }) + +let type_variables () = (Domain.DLS.get variable_refs).type_variables_ref +let univars () = (Domain.DLS.get variable_refs).univars_ref +let used_variables () = (Domain.DLS.get variable_refs).used_variables_ref let reset_type_variables () = reset_global_level (); Ctype.reset_reified_var_counter (); - type_variables := Tbl.empty + type_variables () := Tbl.empty -let narrow () = (increase_global_level (), !type_variables) +let narrow () = (increase_global_level (), !(type_variables ())) let widen (gl, tv) = restore_global_level gl; - type_variables := tv + type_variables () := tv let strict_ident c = c = '_' || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') @@ -231,11 +247,11 @@ let transl_type_param env styp = try if name <> "" && name.[0] = '_' then raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); - ignore (Tbl.find name !type_variables); + ignore (Tbl.find name !(type_variables ())); raise Already_bound with Not_found -> let v = new_global_var ~name () in - type_variables := Tbl.add name v !type_variables; + type_variables () := Tbl.add name v !(type_variables ()); v in { @@ -253,10 +269,7 @@ let transl_type_param env styp = Builtin_attributes.warning_scope styp.ptyp_attributes (fun () -> transl_type_param env styp) -let new_pre_univar ?name () = - let v = newvar ?name () in - pre_univars := v :: !pre_univars; - v +let new_pre_univar ?name () = newvar ?name () let rec swap_list = function | x :: y :: l -> y :: x :: swap_list l @@ -292,15 +305,16 @@ and transl_type_aux env policy styp = let ty = if name <> "" && name.[0] = '_' then raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name))); - try instance env (List.assoc name !univars) + try instance env (List.assoc name !(univars ())) with Not_found -> ( - try instance env (fst (Tbl.find name !used_variables)) + try instance env (fst (Tbl.find name !(used_variables ()))) with Not_found -> let v = if policy = Univars then new_pre_univar ~name () else newvar ~name () in - used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables; + used_variables () := + Tbl.add name (v, styp.ptyp_loc) !(used_variables ()); v) in ctyp (Ttyp_var name) ty @@ -380,9 +394,9 @@ and transl_type_aux env policy styp = let cty = try let t = - try List.assoc alias !univars + try List.assoc alias !(univars ()) with Not_found -> - instance env (fst (Tbl.find alias !used_variables)) + instance env (fst (Tbl.find alias !(used_variables ()))) in let ty = transl_type env policy st in (try unify_var env t ty.ctyp_type @@ -392,7 +406,8 @@ and transl_type_aux env policy styp = ty with Not_found -> let t = newvar () in - used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables; + used_variables () := + Tbl.add alias (t, styp.ptyp_loc) !(used_variables ()); let ty = transl_type env policy st in (try unify_var env t ty.ctyp_type with Unify trace -> @@ -530,11 +545,11 @@ and transl_type_aux env policy styp = let vars = List.map (fun v -> v.txt) vars in begin_def (); let new_univars = List.map (fun name -> (name, newvar ~name ())) vars in - let old_univars = !univars in - univars := new_univars @ !univars; + let old_univars = !(univars ()) in + univars () := new_univars @ !(univars ()); let cty = transl_type env policy st in let ty = cty.ctyp_type in - univars := old_univars; + univars () := old_univars; end_def (); generalize ty; let ty_list = @@ -700,15 +715,15 @@ let globalize_used_variables env fixed = Btype.backtrack snap; false then ( - try r := (loc, v, Tbl.find name !type_variables) :: !r + try r := (loc, v, Tbl.find name !(type_variables ())) :: !r with Not_found -> if fixed && Btype.is_Tvar (repr ty) then raise (Error (loc, env, Unbound_type_variable ("'" ^ name))); let v2 = new_global_var () in r := (loc, v, v2) :: !r; - type_variables := Tbl.add name v2 !type_variables)) - !used_variables; - used_variables := Tbl.empty; + type_variables () := Tbl.add name v2 !(type_variables ()))) + !(used_variables ()); + used_variables () := Tbl.empty; fun () -> List.iter (function @@ -718,16 +733,16 @@ let globalize_used_variables env fixed = !r let transl_simple_type env fixed styp = - univars := []; - used_variables := Tbl.empty; + univars () := []; + used_variables () := Tbl.empty; let typ = transl_type env (if fixed then Fixed else Extensible) styp in globalize_used_variables env fixed (); make_fixed_univars typ.ctyp_type; typ let transl_simple_type_delayed env styp = - univars := []; - used_variables := Tbl.empty; + univars () := []; + used_variables () := Tbl.empty; let typ = transl_type env Extensible styp in make_fixed_univars typ.ctyp_type; (typ, globalize_used_variables env false) diff --git a/compiler/ml/used_attributes.ml b/compiler/ml/used_attributes.ml index 9c159cbce0e..0130b47fc23 100644 --- a/compiler/ml/used_attributes.ml +++ b/compiler/ml/used_attributes.ml @@ -5,11 +5,15 @@ module Attribute_name_set = Hashtbl.Make (struct let hash = Hashtbl.hash end) -let used_attributes = Attribute_name_set.create 16 +let used_attributes_key = + Request_local.new_key (fun () -> Attribute_name_set.create 16) + +let used_attributes () = Domain.DLS.get used_attributes_key (* only mark non-ghost used bs attribute *) let mark_used_attribute ((x, _) : Parsetree.attribute) = - if not x.loc.loc_ghost then Attribute_name_set.replace used_attributes x () + if not x.loc.loc_ghost then + Attribute_name_set.replace (used_attributes ()) x () let is_used_attribute (sloc : string Asttypes.loc) = - Attribute_name_set.mem used_attributes sloc + Attribute_name_set.mem (used_attributes ()) sloc diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index c6c761e3a66..4dc97938f0f 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -76,7 +76,7 @@ let rec get_fn_name binding = let filename_from_loc (pstr_loc : Location.t) = let file_name = match pstr_loc.loc_start.pos_fname with - | "" -> !Location.input_name + | "" -> Location.get_input_name () | file_name -> file_name in let file_name = diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index b41e3d7b1c1..bd33093d787 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -5,10 +5,14 @@ let print_engine = { print_implementation = (fun ~width:_ ~filename:_ ~comments:_ structure -> - Printast.implementation Format.std_formatter structure); + Printast.implementation + (Compiler_request_output.stdout_formatter ()) + structure); print_interface = (fun ~width:_ ~filename:_ ~comments:_ signature -> - Printast.interface Format.std_formatter signature); + Printast.interface + (Compiler_request_output.stdout_formatter ()) + signature); } let comments_print_engine = diff --git a/compiler/syntax/src/res_diagnostics.ml b/compiler/syntax/src/res_diagnostics.ml index 3d54ff82a23..509ae79220b 100644 --- a/compiler/syntax/src/res_diagnostics.ml +++ b/compiler/syntax/src/res_diagnostics.ml @@ -133,8 +133,8 @@ let explain t = let make ~start_pos ~end_pos category = {start_pos; end_pos; category} -let print_report ?(custom_intro = None) ?(formatter = Format.err_formatter) - diagnostics src = +let print_report ?(custom_intro = None) + ?(formatter = Compiler_request_output.stderr_formatter ()) diagnostics src = let rec print diagnostics src = match diagnostics with | [] -> () diff --git a/compiler/syntax/src/res_driver.ml b/compiler/syntax/src/res_driver.ml index 5aed6985aa0..13f34613d45 100644 --- a/compiler/syntax/src/res_driver.ml +++ b/compiler/syntax/src/res_driver.ml @@ -155,34 +155,37 @@ let print_engine = { print_implementation = (fun ~width ~filename:_ ~comments structure -> - print_string + Compiler_request_output.write_stdout (Res_printer.print_implementation ~width structure ~comments)); print_interface = (fun ~width ~filename:_ ~comments signature -> - print_string (Res_printer.print_interface ~width signature ~comments)); + Compiler_request_output.write_stdout + (Res_printer.print_interface ~width signature ~comments)); } +exception Already_reported + let parse_implementation ?(ignore_parse_errors = false) sourcefile = - Location.input_name := sourcefile; + Location.set_input_name sourcefile; let parse_result = parsing_engine.parse_implementation ~filename:sourcefile in if parse_result.invalid then ( Res_diagnostics.print_report parse_result.diagnostics parse_result.source; - if not ignore_parse_errors then exit 1); + if not ignore_parse_errors then raise_notrace Already_reported); parse_result.parsetree -[@@raises exit] +[@@raises Already_reported] let parse_interface ?(ignore_parse_errors = false) sourcefile = - Location.input_name := sourcefile; + Location.set_input_name sourcefile; let parse_result = parsing_engine.parse_interface ~filename:sourcefile in if parse_result.invalid then ( Res_diagnostics.print_report parse_result.diagnostics parse_result.source; - if not ignore_parse_errors then exit 1); + if not ignore_parse_errors then raise_notrace Already_reported); parse_result.parsetree -[@@raises exit] +[@@raises Already_reported] (* suppress unused optional arg *) let _ = fun s -> ( parse_implementation ~ignore_parse_errors:false s, parse_interface ~ignore_parse_errors:false s ) -[@@raises exit] +[@@raises Already_reported] diff --git a/compiler/syntax/src/res_driver.mli b/compiler/syntax/src/res_driver.mli index d721c93a0a3..f941d92419c 100644 --- a/compiler/syntax/src/res_driver.mli +++ b/compiler/syntax/src/res_driver.mli @@ -51,11 +51,13 @@ val parsing_engine : Res_diagnostics.t list parsing_engine val print_engine : print_engine +exception Already_reported + (* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) val parse_implementation : ?ignore_parse_errors:bool -> string -> Parsetree.structure -[@@live] [@@raises Location.Error] +[@@live] [@@raises Location.Error Already_reported] (* ReScript interface parsing compatible with ocaml pparse driver. Used by the compiler *) val parse_interface : ?ignore_parse_errors:bool -> string -> Parsetree.signature -[@@live] [@@raises Location.Error] +[@@live] [@@raises Location.Error Already_reported] diff --git a/compiler/syntax/src/res_driver_ml_printer.ml b/compiler/syntax/src/res_driver_ml_printer.ml index 651ab058402..f2027ccd033 100644 --- a/compiler/syntax/src/res_driver_ml_printer.ml +++ b/compiler/syntax/src/res_driver_ml_printer.ml @@ -3,8 +3,12 @@ let print_engine = { print_implementation = (fun ~width:_ ~filename:_ ~comments:_ structure -> - Pprintast.structure Format.std_formatter structure); + Pprintast.structure + (Compiler_request_output.stdout_formatter ()) + structure); print_interface = (fun ~width:_ ~filename:_ ~comments:_ signature -> - Pprintast.signature Format.std_formatter signature); + Pprintast.signature + (Compiler_request_output.stdout_formatter ()) + signature); } diff --git a/compiler/syntax/src/res_multi_printer.ml b/compiler/syntax/src/res_multi_printer.ml index 43c405a31bc..f126eb7b7af 100644 --- a/compiler/syntax/src/res_multi_printer.ml +++ b/compiler/syntax/src/res_multi_printer.ml @@ -4,7 +4,7 @@ let print_res ~ignore_parse_errors ~is_interface ~filename = let parse_result = Res_driver.parsing_engine.parse_interface ~filename in if parse_result.invalid then ( Res_diagnostics.print_report parse_result.diagnostics parse_result.source; - if not ignore_parse_errors then exit 1); + if not ignore_parse_errors then raise_notrace Res_driver.Already_reported); Res_printer.print_interface ~width:Res_printer.default_print_width ~comments:parse_result.comments parse_result.parsetree) else @@ -13,10 +13,10 @@ let print_res ~ignore_parse_errors ~is_interface ~filename = in if parse_result.invalid then ( Res_diagnostics.print_report parse_result.diagnostics parse_result.source; - if not ignore_parse_errors then exit 1); + if not ignore_parse_errors then raise_notrace Res_driver.Already_reported); Res_printer.print_implementation ~width:Res_printer.default_print_width ~comments:parse_result.comments parse_result.parsetree -[@@raises exit] +[@@raises Res_driver.Already_reported] (* print the given file named input to from "language" to res, general interface exposed by the compiler *) let print ?(ignore_parse_errors = false) input = @@ -25,7 +25,8 @@ let print ?(ignore_parse_errors = false) input = len > 0 && String.unsafe_get input (len - 1) = 'i' in print_res ~ignore_parse_errors ~is_interface ~filename:input -[@@raises exit] +[@@raises Res_driver.Already_reported] (* suppress unused optional arg *) -let _ = fun s -> print ~ignore_parse_errors:false s [@@raises exit] +let _ = fun s -> print ~ignore_parse_errors:false s +[@@raises Res_driver.Already_reported] diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 401e16542b9..33d513430e7 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -6319,4 +6319,4 @@ let print_interface ?(width = default_print_width) (s : Parsetree.signature) ~comments = Doc.to_string ~width (interface_doc s ~comments) ^ "\n" -let print_structure = print_structure ~state:(State.init ()) +let print_structure s t = print_structure ~state:(State.init ()) s t diff --git a/compiler/syntax/src/res_token_debugger.ml b/compiler/syntax/src/res_token_debugger.ml index 9c65b462bdf..5c3a4225e28 100644 --- a/compiler/syntax/src/res_token_debugger.ml +++ b/compiler/syntax/src/res_token_debugger.ml @@ -6,8 +6,9 @@ let dump_tokens filename = close_in ic; content with e -> - Printf.printf "Error reading file %s: %s\n" filename - (Printexc.to_string e); + Compiler_request_output.print_stdout + (Printf.sprintf "Error reading file %s: %s" filename + (Printexc.to_string e)); exit 1 in let scanner = Res_scanner.make ~filename src in @@ -128,8 +129,9 @@ let dump_tokens filename = let end_line = end_pos.Lexing.pos_lnum in let end_col = end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol + 1 in - Printf.printf "%s (%d,%d-%d,%d)\n" token_str start_line start_col end_line - end_col; + Compiler_request_output.print_stdout + (Printf.sprintf "%s (%d,%d-%d,%d)" token_str start_line start_col end_line + end_col); match token with | Res_token.Eof -> () diff --git a/rewatch-ocaml/README.md b/rewatch-ocaml/README.md index a0384eed240..7b352341d8b 100644 --- a/rewatch-ocaml/README.md +++ b/rewatch-ocaml/README.md @@ -7,8 +7,10 @@ implementation in [`../rewatch`](../rewatch) ships next to it as `rescript-rust`, and both are tested with the shared integration suite in [`../rewatch/tests`](../rewatch/tests). -The port follows Rust rewatch's architecture and algorithms. Every parse and -compile runs `bsc` as a separate process. +The port follows Rust rewatch's architecture and algorithms, but it links the +compiler in: parses and compiles run in-process on a pool of OCaml domains +rather than as `bsc` subprocesses (see +[In-process compilation](#in-process-compilation)). ## Building and running @@ -20,16 +22,20 @@ make # builds bsc and packages/@rescript/ close_in_noerr channel) (fun () -> - (try ignore (input_line channel) with End_of_file -> ()); - let rec loop dependencies = - match input_line channel with - | line -> - let line = String.trim line in - if line = "" then loop dependencies - else if Filename.is_relative line then loop (line :: dependencies) - else {dependencies = List.rev dependencies; source = Some line} - | exception End_of_file -> - {dependencies = List.rev dependencies; source = None} + (* The first four bytes give the exact length of the newline-delimited + dependency block. The following source path can itself be relative; + scanning until an absolute path would read the marshalled AST. *) + let dependency_length = input_binary_int channel in + let dependencies = + really_input_string channel dependency_length + |> String.split_on_char '\n' + |> List.filter (fun name -> name <> "") in - loop []) + let source = try Some (input_line channel) with End_of_file -> None in + {dependencies; source}) diff --git a/rewatch-ocaml/ast_header.mli b/rewatch-ocaml/ast_header.mli index 3c41db44d24..8a39f988ff8 100644 --- a/rewatch-ocaml/ast_header.mli +++ b/rewatch-ocaml/ast_header.mli @@ -1,7 +1,7 @@ type t = {dependencies: string list; source: string option} (** Published AST headers are read without deserializing the compiler's full AST. Cleanup needs the original source path, while graph construction needs only - dependency names; keeping one reader prevents those wire-format rules from - drifting. *) + dependency names. The encoded dependency byte length separates those names + from either an absolute or a relative source path and the marshalled AST. *) val read : string -> t diff --git a/rewatch-ocaml/bench/README.md b/rewatch-ocaml/bench/README.md index 747a1a42977..b0ae7945a25 100644 --- a/rewatch-ocaml/bench/README.md +++ b/rewatch-ocaml/bench/README.md @@ -82,6 +82,14 @@ that a differently-cased recreated CMI exists to `stat` and then return `ENOENT` from the immediately following `open`; that host-filesystem artifact is not valid scheduler or benchmark evidence. The harness's default `mktemp` workspace normally stays on the container filesystem. + +The OCaml implementation compiles in-process, so it has no compiler `execve` +to trace. The gate counts its compiler requests from the log it writes when +`REWATCH_COMPILER_CALL_LOG` is set, and still traces PPXs as processes. +`RESCRIPT_BSC_EXE` only selects Rust's compiler; the OCaml executable uses the +compiler linked into it, so build both from the same checkout. Set +`REWATCH_COMPILER_DOMAINS` to measure a specific number of compiler workers. + Set `REWATCH_PERFORMANCE_THRESHOLD_PERCENT` to change the 125% threshold. Set `KEEP_REWATCH_BENCHMARK_WORKDIR=1` to retain traces and raw stdout/stderr for investigation. For a quick correctness-only check, an odd run count below five is accepted only with `REWATCH_ALLOW_SMOKE_RUN=1`; its timing @@ -100,8 +108,11 @@ rewatch-ocaml/bench/watch_performance_gate.sh \ ``` It warms both implementations, interleaves an odd number of timed edits, -requires byte-identical generated JavaScript and normalized parser/compiler -argument logs, and samples file descriptors, tasks, and RSS after every build. +requires byte-identical generated JavaScript and equal parser/compiler work +counts (Rust's through the counting `bsc` proxy, OCaml's through +`REWATCH_COMPILER_CALL_LOG`), and samples file descriptors, tasks, and RSS after +every build. Set `REWATCH_WATCH_COMPILER_DOMAINS` to run the OCaml watcher with +a specific number of compiler workers. This catches retained-state implementations that appear fast by skipping work, as well as resource growth that a single build cannot show. The default median-latency limit is 150% of Rust because individual watch events diff --git a/rewatch-ocaml/bench/performance_gate.sh b/rewatch-ocaml/bench/performance_gate.sh index 4118d7fc651..b9aa48e9421 100755 --- a/rewatch-ocaml/bench/performance_gate.sh +++ b/rewatch-ocaml/bench/performance_gate.sh @@ -89,10 +89,11 @@ tree_resources() { for (pass = 0; pass < NR; pass++) for (i = 1; i <= NR; i++) if (live[parent[pids[i]]]) live[pids[i]] = 1 - for (pid in live) { - total_memory += memory[pid] - total_tasks += tasks[pid] - } + for (pid in live) + if (live[pid]) { + total_memory += memory[pid] + total_tasks += tasks[pid] + } print total_memory + 0, total_tasks + 0 }' } @@ -171,20 +172,35 @@ trace_and_classify() { local implementation=$1 scenario=$2 executable=$3 fixture=$4 manifest=$5 local clean_first=$6 local trace_prefix="$work_root/${implementation}-${scenario}.execve" + local call_log="$work_root/${implementation}-${scenario}.compiler" if [[ "$clean_first" == 1 ]]; then "$executable" clean "$fixture" >/dev/null 2>&1 fi - strace -f -ff -qq -s 4096 -e trace=execve,chdir -o "$trace_prefix" \ - "$executable" build "$fixture" \ - >"$work_root/${implementation}-${scenario}-trace.out" \ - 2>"$work_root/${implementation}-${scenario}-trace.stderr" + if [[ $implementation == ocaml ]]; then + # Embedded requests have no compiler execve. Record them at their shared + # logical boundary while tracing PPXs as external processes. + strace -f -ff -qq -s 4096 -e trace=execve,chdir -o "$trace_prefix" \ + env REWATCH_COMPILER_CALL_LOG="$call_log" \ + "$executable" build "$fixture" \ + >"$work_root/${implementation}-${scenario}-trace.out" \ + 2>"$work_root/${implementation}-${scenario}-trace.stderr" + else + strace -f -ff -qq -s 4096 -e trace=execve,chdir -o "$trace_prefix" \ + "$executable" build "$fixture" \ + >"$work_root/${implementation}-${scenario}-trace.out" \ + 2>"$work_root/${implementation}-${scenario}-trace.stderr" + fi local trace_files=("$trace_prefix".*) local implementation_root=${fixture%/rewatch/testrepo} local trace_file exec_line argv cwd_line cwd phase input identity : >"$manifest.unsorted" for trace_file in "${trace_files[@]}"; do - exec_line=$(grep -m1 -F "execve(\"$RESCRIPT_BSC_EXE\"" "$trace_file" \ - || grep -m1 -E 'execve\("[^"]*sury-ppx' "$trace_file" || true) + if [[ $implementation == ocaml ]]; then + exec_line=$(grep -m1 -E 'execve\("[^"]*sury-ppx' "$trace_file" || true) + else + exec_line=$(grep -m1 -F "execve(\"$RESCRIPT_BSC_EXE\"" "$trace_file" \ + || grep -m1 -E 'execve\("[^"]*sury-ppx' "$trace_file" || true) + fi if [[ -z "$exec_line" ]]; then continue fi @@ -193,7 +209,7 @@ trace_and_classify() { cwd_line=$(grep -m1 '^chdir("' "$trace_file" || true) cwd=${cwd_line#chdir(\"} cwd=${cwd%%\"*} - if [[ "$exec_line" == *"execve(\"$RESCRIPT_BSC_EXE\""* ]]; then + if [[ $implementation == rust && "$exec_line" == *"execve(\"$RESCRIPT_BSC_EXE\""* ]]; then if [[ "$argv" == *'"-bs-ast"'* ]]; then phase=parse elif [[ "$argv" == *'.mlmap"'* ]]; then @@ -205,24 +221,35 @@ trace_and_classify() { input=${input%]} identity="$cwd"$'\t'"$phase"$'\t'"$input" else - # PPX temporary input/output names are deliberately randomized. Its - # executable identity and count are the stable unit of work. + # PPX temporary input/output names are deliberately randomized. identity=ppx$'\t'"${argv%%,*}" fi printf '%s\n' "$identity" \ | sed "s#$implementation_root##g" >>"$manifest.unsorted" done - sort "$manifest.unsorted" >"$manifest" local invocations parse namespace compile interface ppx - invocations=$(grep -hF -c "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ - | awk '{ total += $1 } END { print total + 0 }') - parse=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ - | grep -F -c '"-bs-ast"' || true) - namespace=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ - | grep -E -c '\.mlmap"' || true) - interface=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ - | grep -vF '"-bs-ast"' | grep -vE '\.mlmap"' \ - | grep -E -c '\.iast"' || true) + if [[ $implementation == ocaml ]]; then + while IFS=$'\t' read -r phase cwd input; do + if [[ $phase != parse && $phase != namespace ]]; then phase=compile; fi + printf '%s\t%s\t"%s"\n' "$cwd" "$phase" "$input" \ + | sed "s#$implementation_root##g" >>"$manifest.unsorted" + done <"$call_log" + invocations=$(wc -l <"$call_log") + parse=$(awk -F '\t' '$1 == "parse" { n++ } END { print n+0 }' "$call_log") + namespace=$(awk -F '\t' '$1 == "namespace" { n++ } END { print n+0 }' "$call_log") + interface=$(awk -F '\t' '$1 == "interface" { n++ } END { print n+0 }' "$call_log") + else + invocations=$(grep -hF -c "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ + | awk '{ total += $1 } END { print total + 0 }') + parse=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ + | grep -F -c '"-bs-ast"' || true) + namespace=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ + | grep -E -c '\.mlmap"' || true) + interface=$(grep -hF "execve(\"$RESCRIPT_BSC_EXE\"" "${trace_files[@]}" \ + | grep -vF '"-bs-ast"' | grep -vE '\.mlmap"' \ + | grep -E -c '\.iast"' || true) + fi + sort "$manifest.unsorted" >"$manifest" compile=$((invocations - parse - namespace)) ppx=$(grep -hE -c 'execve\("[^"]*sury-ppx' "${trace_files[@]}" \ | awk '{ total += $1 } END { print total + 0 }') diff --git a/rewatch-ocaml/bench/watch_performance_gate.sh b/rewatch-ocaml/bench/watch_performance_gate.sh index b21f38c5307..0eab1c38cf5 100755 --- a/rewatch-ocaml/bench/watch_performance_gate.sh +++ b/rewatch-ocaml/bench/watch_performance_gate.sh @@ -139,16 +139,32 @@ start_watcher() { fixture="$work_root/$implementation" cp -R "$repo_root/rewatch-ocaml/tests/basic" "$fixture" : >"$work_root/$implementation.bsc" - setsid env \ - RESCRIPT_BSC_EXE="$counting_bsc" \ - REWATCH_BSC_PROXY_MODE=counting \ - RESCRIPT_RUNTIME="$runtime" \ - REWATCH_REAL_BSC="$real_bsc" \ - REWATCH_BSC_CALL_LOG="$work_root/$implementation.bsc" \ - REWATCH_WATCH_MARKER="$work_root/$implementation.marker" \ - "$executable" watch --after-build "node $marker_script" "$fixture" \ - >"$work_root/$implementation.stdout" \ - 2>"$work_root/$implementation.stderr" & + : >"$work_root/$implementation.compiler" + if [[ $implementation == ocaml ]]; then + local -a domain_count_env=() + if [[ ${REWATCH_WATCH_COMPILER_DOMAINS+x} ]]; then + domain_count_env=(REWATCH_COMPILER_DOMAINS="$REWATCH_WATCH_COMPILER_DOMAINS") + fi + setsid env \ + RESCRIPT_RUNTIME="$runtime" \ + "${domain_count_env[@]}" \ + REWATCH_COMPILER_CALL_LOG="$work_root/$implementation.compiler" \ + REWATCH_WATCH_MARKER="$work_root/$implementation.marker" \ + "$executable" watch --after-build "node $marker_script" "$fixture" \ + >"$work_root/$implementation.stdout" \ + 2>"$work_root/$implementation.stderr" & + else + setsid env \ + RESCRIPT_BSC_EXE="$counting_bsc" \ + REWATCH_BSC_PROXY_MODE=counting \ + RESCRIPT_RUNTIME="$runtime" \ + REWATCH_REAL_BSC="$real_bsc" \ + REWATCH_BSC_CALL_LOG="$work_root/$implementation.bsc" \ + REWATCH_WATCH_MARKER="$work_root/$implementation.marker" \ + "$executable" watch --after-build "node $marker_script" "$fixture" \ + >"$work_root/$implementation.stdout" \ + 2>"$work_root/$implementation.stderr" & + fi pids[$implementation]=$! wait_for_lines "$work_root/$implementation.marker" 1 wait_for_text_count "$work_root/$implementation.stdout" \ @@ -169,6 +185,7 @@ for implementation in rust ocaml; do "Finished incremental compilation" 1 wait_for_idle "${pids[$implementation]}" : >"$work_root/$implementation.bsc" + : >"$work_root/$implementation.compiler" done declare -A baseline_fd baseline_tasks baseline_rss max_fd max_tasks max_rss @@ -227,27 +244,20 @@ median() { rust_median=$(median "$work_root/rust.latencies") ocaml_median=$(median "$work_root/ocaml.latencies") -normalize_calls() { - local implementation=$1 - sed "s#$work_root/$implementation##g" \ - "$work_root/$implementation.bsc" >"$work_root/$implementation.bsc.normalized" -} -normalize_calls rust -normalize_calls ocaml -if ! cmp -s "$work_root/rust.bsc.normalized" \ - "$work_root/ocaml.bsc.normalized"; then - echo "Rust and OCaml retained edits performed different compiler work." >&2 +rust_parse_count=$(grep -cF -- '-bs-ast' "$work_root/rust.bsc" || true) +rust_total_count=$(wc -l <"$work_root/rust.bsc") +ocaml_parse_count=$(grep -c '^parse' "$work_root/ocaml.compiler" || true) +ocaml_compile_count=$(grep -c '^implementation' \ + "$work_root/ocaml.compiler" || true) +ocaml_total_count=$(wc -l <"$work_root/ocaml.compiler") +if ((rust_parse_count != runs || rust_total_count != runs * 2 || + ocaml_parse_count != runs || ocaml_compile_count != runs || + ocaml_total_count != runs * 2)); then + printf 'retained work mismatch: Rust %d parser / %d total; embedded OCaml %d parser / %d compiler / %d total; expected %d / %d.\n' \ + "$rust_parse_count" "$rust_total_count" "$ocaml_parse_count" \ + "$ocaml_compile_count" "$ocaml_total_count" "$runs" "$((runs * 2))" >&2 exit 1 fi -for implementation in rust ocaml; do - parse_count=$(grep -cF -- '-bs-ast' "$work_root/$implementation.bsc" || true) - total_count=$(wc -l <"$work_root/$implementation.bsc") - if ((parse_count != runs || total_count != runs * 2)); then - printf '%s retained work was %d parser / %d total calls; expected %d / %d.\n' \ - "$implementation" "$parse_count" "$total_count" "$runs" "$((runs * 2))" >&2 - exit 1 - fi -done for implementation in rust ocaml; do pid=${pids[$implementation]} diff --git a/rewatch-ocaml/build.ml b/rewatch-ocaml/build.ml index 824f0472361..9a1698be61b 100644 --- a/rewatch-ocaml/build.ml +++ b/rewatch-ocaml/build.ml @@ -78,8 +78,10 @@ let run_namespace_jobs (attempt : Build_attempt.t) = attempt.parse_seconds +. (Unix.gettimeofday () -. started_at)) (fun () -> let results = - Process.run_parallel ?poll:attempt.process_poll - (List.map (fun job -> job.Build_attempt.job) jobs) + List.map + (fun job -> + Process.run_task ?poll:attempt.process_poll job.Build_attempt.task) + jobs in List.iter2 (fun job result -> job.Build_attempt.finish result) @@ -138,7 +140,6 @@ let prepare_incremental previous changes (attempt : Build_attempt.t) affected modules' dependency edges in memory. This keeps the long-lived graph coherent without rediscovering the package tree. *) let sources = incremental_sources previous changes in - let bsc = prepared.compiler_context.bsc_path in let started_at = Unix.gettimeofday () in List.iter (fun source -> @@ -162,10 +163,12 @@ let prepare_incremental previous changes (attempt : Build_attempt.t) sources) in let results = - Process.run_parallel_map ?poll:attempt.process_poll - ~on_complete:parse_completed sources ~job:(fun source -> - Compiler_process.parse_job ~bsc ~build_dir:source.package.build_dir + sources + |> List.map (fun source -> + Compiler_process.parse_request ~build_dir:source.package.build_dir ~config:source.package.compile_config source.source.relative_path) + |> Compiler_process.run_requests ?poll:attempt.process_poll + ~on_complete:parse_completed in let affected_modules = Hashtbl.create (List.length sources) in let dependency_updates = ref [] in diff --git a/rewatch-ocaml/build_attempt.ml b/rewatch-ocaml/build_attempt.ml index 61bdbd19a8a..9fcc0890ffc 100644 --- a/rewatch-ocaml/build_attempt.ml +++ b/rewatch-ocaml/build_attempt.ml @@ -18,7 +18,7 @@ let preliminary_parse result = if Process.succeeded result then Parsed_successfully {stderr = result.stderr} else Parse_failed {stdout = result.stdout; stderr = result.stderr} -type namespace_job = {job: Process.job; finish: Process.result -> unit} +type namespace_job = {task: Process.task; finish: Process.result -> unit} type pending_work = { mutable namespace_jobs: namespace_job list; diff --git a/rewatch-ocaml/build_attempt.mli b/rewatch-ocaml/build_attempt.mli index 11fcfe99607..db40bf19f1a 100644 --- a/rewatch-ocaml/build_attempt.mli +++ b/rewatch-ocaml/build_attempt.mli @@ -17,7 +17,7 @@ type preliminary_parse = val preliminary_parse : Process.result -> preliminary_parse -type namespace_job = {job: Process.job; finish: Process.result -> unit} +type namespace_job = {task: Process.task; finish: Process.result -> unit} type pending_work type finalization_state diff --git a/rewatch-ocaml/build_lock.ml b/rewatch-ocaml/build_lock.ml index dd4d8d8f015..a9b4d61835e 100644 --- a/rewatch-ocaml/build_lock.ml +++ b/rewatch-ocaml/build_lock.ml @@ -102,13 +102,26 @@ let release_owned path pid = type owned_lock = {path: string; pid: string; mutable released: bool} +(* The locks this process holds, so an immediate exit can still release them + when it bypasses normal unwinding. *) +let held : owned_lock list Atomic.t = Atomic.make [] + +let rec update_held change = + let current = Atomic.get held in + if not (Atomic.compare_and_set held current (change current)) then + update_held change + let release lock = if not lock.released then ( release_owned lock.path lock.pid; - lock.released <- true) + lock.released <- true; + update_held (List.filter (fun held -> held != lock))) + +let release_held () = List.iter release (Atomic.get held) let with_acquired ~candidate ~path ~pid action = let lock = {path; pid; released = false} in + update_held (fun current -> lock :: current); match unlink_existing candidate; action lock diff --git a/rewatch-ocaml/build_lock.mli b/rewatch-ocaml/build_lock.mli index 593aee79e40..ada58aaefed 100644 --- a/rewatch-ocaml/build_lock.mli +++ b/rewatch-ocaml/build_lock.mli @@ -13,6 +13,11 @@ val with_build : ([attempts] times 50 ms). *) val with_watch : string -> (watch -> 'a) -> 'a + +val release_held : unit -> unit +(** Releases every lock this process holds, for an exit that skips normal + unwinding. *) + val is_owned : watch -> bool module For_test : sig diff --git a/rewatch-ocaml/build_preparation.ml b/rewatch-ocaml/build_preparation.ml index cdae985d7c8..16fe674de06 100644 --- a/rewatch-ocaml/build_preparation.ml +++ b/rewatch-ocaml/build_preparation.ml @@ -5,8 +5,9 @@ type result = { cycle: Module_graph.cycle_info option; } -let bsc_path () = - try Toolchain.bsc () with Toolchain.Error message -> raise (Error message) +let bundled_bsc_path () = + try Toolchain.bundled_bsc ~cwd:(Sys.getcwd ()) ~executable:Sys.executable_name + with Toolchain.Error message -> raise (Error message) let runtime_path root = try Toolchain.runtime ~find_package:(Project_context.dependency_path root) @@ -14,7 +15,6 @@ let runtime_path root = let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch ~(attempt : Build_attempt.t) ~parse_step ~on_cleanup = - let bsc = bsc_path () in let workspace_config = Project_context.workspace_config_for root_config in let package_plans = Package_graph.discover ~root_config ~workspace_config ~prod ~features @@ -24,7 +24,8 @@ let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch let runtime = runtime_path root_config.root in let source_map_args = Compiler_args.source_map_args workspace_config ~watch in let compiler_context = - Compiler_info.make_context ~bsc_path:bsc ~runtime_path:runtime + Compiler_info.make_context ~compiler_path:(bundled_bsc_path ()) + ~compiler_identity:Compiler_process.build_identity ~runtime_path:runtime ~source_map_args ~inherited_compiler_args: (workspace_config.jsx_args @ workspace_config.experimental_args) @@ -182,11 +183,12 @@ let run ~(root_config : Config.t) ~prod ~features ~warn_error ~filter ~watch (List.map (fun (_, _, group) -> group) parse_entries) in let parse_results = - Process.run_parallel_map ?poll:attempt.process_poll - ~on_complete:parse_completed parse_entries - ~job:(fun ((package : Package_plan.t), path, _) -> - Compiler_process.parse_job ~bsc ~build_dir:package.build_dir + parse_entries + |> List.map (fun ((package : Package_plan.t), path, _) -> + Compiler_process.parse_request ~build_dir:package.build_dir ~config:package.compile_config path) + |> Compiler_process.run_requests ?poll:attempt.process_poll + ~on_complete:parse_completed in let failed_parse_paths = Hashtbl.create 8 in List.iter2 diff --git a/rewatch-ocaml/compiler_execution_mode.ml b/rewatch-ocaml/compiler_execution_mode.ml new file mode 100644 index 00000000000..2f02814e36a --- /dev/null +++ b/rewatch-ocaml/compiler_execution_mode.ml @@ -0,0 +1,23 @@ +let max_domain_count = max 12 Process.default_max_jobs + +(* Leave a CPU for dependency scheduling and artifact publication. The cap is + provisional: gains flattened around eight workers on the Linux fixture. *) +let recommended_domain_count available_cpus = min 8 (max 1 (available_cpus - 1)) + +let configured_count () = + let count = + match Sys.getenv_opt "REWATCH_COMPILER_DOMAINS" with + | None -> recommended_domain_count (Domain.recommended_domain_count ()) + | Some value -> ( + match int_of_string_opt value with + | Some count -> count + | None -> + invalid_arg ("REWATCH_COMPILER_DOMAINS must be an integer, got " ^ value) + ) + in + if count < 1 || count > max_domain_count then + invalid_arg + (Printf.sprintf + "REWATCH_COMPILER_DOMAINS must be between 1 and %d, got %d" + max_domain_count count); + count diff --git a/rewatch-ocaml/compiler_execution_mode.mli b/rewatch-ocaml/compiler_execution_mode.mli new file mode 100644 index 00000000000..b59f000d2b8 --- /dev/null +++ b/rewatch-ocaml/compiler_execution_mode.mli @@ -0,0 +1,3 @@ +val max_domain_count : int +val recommended_domain_count : int -> int +val configured_count : unit -> int diff --git a/rewatch-ocaml/compiler_info.ml b/rewatch-ocaml/compiler_info.ml index 859f37ea1c8..46374dca79b 100644 --- a/rewatch-ocaml/compiler_info.ml +++ b/rewatch-ocaml/compiler_info.ml @@ -25,11 +25,11 @@ let package_output_specs (config : Config.t) = }) config.package_specs -let make_context ~bsc_path ~runtime_path ~source_map_args - ~inherited_compiler_args ~package_output_specs = +let make_context ~compiler_path ~compiler_identity ~runtime_path + ~source_map_args ~inherited_compiler_args ~package_output_specs = { - bsc_path; - bsc_hash = Digest.file bsc_path |> Digest.to_hex; + bsc_path = compiler_path; + bsc_hash = compiler_identity; runtime_path; source_map_args; inherited_compiler_args; diff --git a/rewatch-ocaml/compiler_info.mli b/rewatch-ocaml/compiler_info.mli index a638f1059b5..09a81a45540 100644 --- a/rewatch-ocaml/compiler_info.mli +++ b/rewatch-ocaml/compiler_info.mli @@ -20,7 +20,8 @@ and package_output_spec = { val package_output_specs : Config.t -> package_output_spec list val make_context : - bsc_path:string -> + compiler_path:string -> + compiler_identity:string -> runtime_path:string -> source_map_args:string list -> inherited_compiler_args:string list -> diff --git a/rewatch-ocaml/compiler_process.ml b/rewatch-ocaml/compiler_process.ml index 82b07ec1050..fb4117fd7da 100644 --- a/rewatch-ocaml/compiler_process.ml +++ b/rewatch-ocaml/compiler_process.ml @@ -8,7 +8,103 @@ let retain_critical_external_warnings stderr = |> List.filter (fun block -> String_util.contains block marker) |> String.concat "\n\n\n" -let parse_job ~bsc ~build_dir ~(config : Config.t) path = +let build_identity = Rescript_compiler_driver.build_identity + +type request = {args: string list; cwd: string} + +let compiler_phase args = + let input = + match List.rev args with + | input :: _ -> input + | [] -> "" + in + let phase = + if List.mem "-bs-ast" args then "parse" + else if Filename.check_suffix input ".mlmap" then "namespace" + else if Filename.check_suffix input ".iast" then "interface" + else "implementation" + in + (phase, input) + +let log_compiler_request (request : request) = + match Sys.getenv_opt "REWATCH_COMPILER_CALL_LOG" with + | None -> () + | Some path -> + let phase, input = compiler_phase request.args in + let channel = + open_out_gen [Open_creat; Open_append; Open_text] 0o644 path + in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> Printf.fprintf channel "%s\t%s\t%s\n" phase request.cwd input) + +let exit_code = function + | Unix.WEXITED code -> code + | Unix.WSIGNALED signal | Unix.WSTOPPED signal -> 128 + signal + +let run_in_process ?poll (request : request) = + log_compiler_request request; + match List.rev request.args with + | [] -> + { + Process.status = Unix.WEXITED 2; + stdout = ""; + stderr = "missing compiler input"; + } + | input :: reversed_argv -> ( + match + Rescript_compiler_driver.run_request ~cwd:request.cwd + ~argv:(List.rev reversed_argv) ~input + ~run_external: + (Some + (fun command -> + let command = Platform.shell_command command in + let result = + Process.run ?poll ~cwd:request.cwd command.program command.args + in + (exit_code result.status, result.stdout, result.stderr))) + with + | result -> + { + Process.status = Unix.WEXITED result.exit_code; + stdout = result.stdout; + stderr = result.stderr; + } + | exception + Compiler_request_output.Failed {error = Process.Interrupted _ as error} + -> + raise error + | exception Compiler_request_output.Failed {error; stdout; stderr} -> + (* Keep the warnings written before the failure. *) + { + Process.status = Unix.WEXITED 2; + stdout; + stderr = stderr ^ Printexc.to_string error ^ "\n"; + }) + +let run ?poll request = + Option.iter (fun poll -> poll ()) poll; + let result = run_in_process ?poll request in + Option.iter (fun poll -> poll ()) poll; + result + +let task request = + let cancelled = Atomic.make false in + Process.concurrent_task + ~cancel:(fun () -> Atomic.set cancelled true) + (fun () -> + run_in_process + ~poll:(fun () -> + if Atomic.get cancelled then raise (Process.Interrupted 15)) + request) + +let run_requests ?poll ?on_complete requests = + requests |> List.map task + |> Process.run_tasks + ~max_jobs:(Compiler_execution_mode.configured_count ()) + ?poll ?on_complete + +let parse_request ~build_dir ~(config : Config.t) path = let ast = Source.ast_path path in File_util.ensure_dir (Filename.concat build_dir (Filename.dirname ast)); let contents = @@ -16,7 +112,7 @@ let parse_job ~bsc ~build_dir ~(config : Config.t) path = else File_util.read_file (Filename.concat config.root path) in let args = Compiler_args.parser_arguments ~config ~contents ~path in - Process.{program = bsc; args; cwd = build_dir} + {args; cwd = build_dir} let ast_dependencies ~build_dir ast = (Ast_header.read (Filename.concat build_dir ast)).dependencies @@ -52,8 +148,8 @@ let publish_compiler_artifacts ~artifact_dir ~ocaml_dir ~basename artifacts = with error -> raise (Compiler_scheduler.Publication_failure (error, !cmi_change)) -let namespace_task ~bsc ~runtime ~build_dir ~ocaml_dir ~entry ~package_dirty - ~force namespace modules = +let namespace_task ~runtime ~build_dir ~ocaml_dir ~entry ~package_dirty ~force + namespace modules = let mlmap = Filename.concat build_dir (namespace ^ ".mlmap") in let contents = let buffer = Buffer.create 128 in @@ -95,10 +191,9 @@ let namespace_task ~bsc ~runtime ~build_dir ~ocaml_dir ~entry ~package_dirty Some Compiler_scheduler. { - job = - Process. + task = + task { - program = bsc; args = [ "-runtime-path"; @@ -148,7 +243,7 @@ let post_build_tasks (config : Config.t) path = }) config.package_specs -let compile_job ~bsc ~build_dir ~(config : Config.t) ~common_args +let compile_request ~build_dir ~(config : Config.t) ~common_args (module_ : Source.module_) ~source_kind path = let args = Compiler_args.compiler_arguments_with_common ~config ~common_args @@ -156,7 +251,7 @@ let compile_job ~bsc ~build_dir ~(config : Config.t) ~common_args ~has_interface:(Option.is_some module_.interface) ~path in - Process.{program = bsc; args; cwd = build_dir} + {args; cwd = build_dir} let publish ~build_dir ~ocaml_dir ~is_local ~(config : Config.t) ~has_interface ~source_kind path result = diff --git a/rewatch-ocaml/compiler_process.mli b/rewatch-ocaml/compiler_process.mli index 38844006632..3a55794eaac 100644 --- a/rewatch-ocaml/compiler_process.mli +++ b/rewatch-ocaml/compiler_process.mli @@ -1,10 +1,21 @@ val retain_critical_external_warnings : string -> string -val parse_job : - bsc:string -> build_dir:string -> config:Config.t -> string -> Process.job +val build_identity : string + +type request = {args: string list; cwd: string} +(** A request for the embedded compiler: [bsc]'s arguments, ending with the + input file, and the directory it runs in. *) + +val parse_request : build_dir:string -> config:Config.t -> string -> request val ast_dependencies : build_dir:string -> string -> string list +val run : ?poll:(unit -> unit) -> request -> Process.result +val run_requests : + ?poll:(unit -> unit) -> + ?on_complete:(int -> unit) -> + request list -> + Process.result list +val task : request -> Process.task val namespace_task : - bsc:string -> runtime:string -> build_dir:string -> ocaml_dir:string -> @@ -15,15 +26,14 @@ val namespace_task : Source.module_ list -> Compiler_scheduler.namespace_task option -val compile_job : - bsc:string -> +val compile_request : build_dir:string -> config:Config.t -> common_args:string list -> Source.module_ -> source_kind:Source.source_kind -> string -> - Process.job + request val post_build_tasks : Config.t -> string -> Compiler_scheduler.post_build_task list diff --git a/rewatch-ocaml/compiler_scheduler.ml b/rewatch-ocaml/compiler_scheduler.ml index 18cc1523de1..25936aeb56f 100644 --- a/rewatch-ocaml/compiler_scheduler.ml +++ b/rewatch-ocaml/compiler_scheduler.ml @@ -8,7 +8,7 @@ exception Publication_failure of exn * cmi_change type publish_result = {stderr: string; cmi_change: cmi_change} type namespace_task = { - job: Process.job; + task: Process.task; publish: Process.result -> publish_result; } type post_build_task = {output: string; task: Process.task} @@ -44,7 +44,7 @@ type scheduled_module = { cmi_path: string; publication: publication option Atomic.t; prepare: unit -> unit; - compile: source_kind:Source.source_kind -> string -> Process.job; + compile: source_kind:Source.source_kind -> string -> Process.task; publish: source_kind:Source.source_kind -> string -> Process.result -> publish_result; record_published_outputs: source_kind:Source.source_kind -> string -> unit; @@ -202,7 +202,20 @@ let run ~poll ~warning_state ~compile_assets ~build_state ~candidates Publication_failed (Printexc.to_string error) | None -> No_publication in + let publish_compilation (scheduled : scheduled_module) ~source_kind path + result = + (if Process.succeeded result then + let publication = + capture_publication (fun () -> + scheduled.publish ~source_kind path result) + in + Atomic.set scheduled.publication (Some publication)); + result + in let record_result (scheduled : scheduled_module) ~source_kind path result = + (* Domain tasks only compile. Publication and build-state updates remain on + this scheduler domain after their result has been collected. *) + let result = publish_compilation scheduled ~source_kind path result in let result, publication_error = match record_publication scheduled ~source_kind path with | Publication_succeeded stderr -> ({result with Process.stderr}, None) @@ -239,16 +252,9 @@ let run ~poll ~warning_state ~compile_assets ~build_state ~candidates Option.is_none message in let compilation_task (scheduled : scheduled_module) ~source_kind path = - let job = scheduled.compile ~source_kind path in + let task = scheduled.compile ~source_kind path in Atomic.set scheduled.publication None; - Process.task job ~on_result:(fun result -> - (if Process.succeeded result then - let publication = - capture_publication (fun () -> - scheduled.publish ~source_kind path result) - in - Atomic.set scheduled.publication (Some publication)); - result) + task in let record_post_build_result (scheduled : scheduled_module) output result = if Process.succeeded result then ( @@ -320,12 +326,11 @@ let run ~poll ~warning_state ~compile_assets ~build_state ~candidates in let () = try - Process.run_dependency_graph ?poll + let max_jobs = Compiler_execution_mode.configured_count () in + Process.run_dependency_graph ~max_jobs ?poll works - (* Rust's parallel scheduler may already have independent work in - flight when a module fails. Finish all ready, independent work here - so the same diagnostics do not depend on the host's worker count; - dependents of the failed module remain blocked. *) + (* Finish ready independent work after a module failure; dependents of + the failed module remain blocked. Interruptions still abort. *) ~on_failure:(function | Module_failed -> Process.Continue_independent_work | _ -> Process.Abort_immediately) diff --git a/rewatch-ocaml/compiler_scheduler.mli b/rewatch-ocaml/compiler_scheduler.mli index 2d3c31858fe..3038a5b2b21 100644 --- a/rewatch-ocaml/compiler_scheduler.mli +++ b/rewatch-ocaml/compiler_scheduler.mli @@ -12,7 +12,7 @@ exception Publication_failure of exn * cmi_change type publish_result = {stderr: string; cmi_change: cmi_change} type namespace_task = { - job: Process.job; + task: Process.task; publish: Process.result -> publish_result; } type post_build_task = {output: string; task: Process.task} @@ -36,7 +36,7 @@ val create : state:Build_state.module_ -> cmi_path:string -> prepare:(unit -> unit) -> - compile:(source_kind:Source.source_kind -> string -> Process.job) -> + compile:(source_kind:Source.source_kind -> string -> Process.task) -> publish: (source_kind:Source.source_kind -> string -> diff --git a/rewatch-ocaml/dune b/rewatch-ocaml/dune index a2faebbeaf8..228bbc7cd66 100644 --- a/rewatch-ocaml/dune +++ b/rewatch-ocaml/dune @@ -19,7 +19,7 @@ (library (name rewatch_ocaml_lib) - (wrapped false) + (wrapped true) (modules rewatch_version string_util @@ -48,6 +48,7 @@ compiler_args_command compiler_log ast_header + compiler_execution_mode compiler_process compiler_scheduler after_build @@ -76,7 +77,16 @@ output build format) - (libraries unix threads yojson str spawn cmdliner luv re.perl) + (libraries + unix + threads + yojson + str + spawn + cmdliner + luv + re.perl + rescript_compiler_driver) (foreign_stubs (language c) (names windows_job_stubs))) @@ -84,4 +94,6 @@ (executable (name rescript_ocaml) (modules rescript_ocaml) + (flags + (:standard -open Rewatch_ocaml_lib)) (libraries rewatch_ocaml_lib)) diff --git a/rewatch-ocaml/format.ml b/rewatch-ocaml/format.ml index f63f9291bbd..a79bfb5740c 100644 --- a/rewatch-ocaml/format.ml +++ b/rewatch-ocaml/format.ml @@ -23,9 +23,6 @@ let write_file path contents = extended attributes that replacing the directory entry could lose. *) File_util.write_file path contents) -let bsc () = - try Toolchain.bsc () with Toolchain.Error message -> raise (Error message) - type discovered_package = {config: Config.t; files: string list} let package_sources (package : discovered_package) = @@ -118,8 +115,11 @@ let files_in_scope ~verbosity = let formatting_error target stderr = Printf.sprintf "Error formatting %s: %s" target stderr -let formatted ?poll ~bsc ~target path = - let result = Process.run ?poll ~cwd:(Sys.getcwd ()) bsc ["-format"; path] in +let format_request path = + Compiler_process.{args = ["-format"; path]; cwd = Sys.getcwd ()} + +let formatted ?poll ~target path = + let result = Compiler_process.run ?poll (format_request path) in if not (Process.succeeded result) then raise (Error (formatting_error target result.stderr)); result.stdout @@ -128,8 +128,7 @@ let format_check_summary = function | 1 -> "The file listed above needs formatting" | count -> Printf.sprintf "The %d files listed above need formatting" count -let format_files_with_bsc ?max_jobs ?poll ~bsc ~check files = - let cwd = Sys.getcwd () in +let format_files ?poll ~check files = let incorrect = ref 0 in let works = files @@ -138,8 +137,7 @@ let format_files_with_bsc ?max_jobs ?poll ~bsc ~check files = {key = Printf.sprintf "%08d" index; dependencies = []; value = path}) in let next path = function - | None -> - Some (Process.task Process.{program = bsc; args = ["-format"; path]; cwd}) + | None -> Some (Compiler_process.task (format_request path)) | Some result -> if not (Process.succeeded result) then raise (Error (formatting_error path result.stderr)); @@ -151,7 +149,9 @@ let format_files_with_bsc ?max_jobs ?poll ~bsc ~check files = else write_file path result.stdout; None in - Process.run_dependency_graph ?max_jobs ?poll works ~next; + Process.run_dependency_graph + ~max_jobs:(Compiler_execution_mode.configured_count ()) + ?poll works ~next; if !incorrect > 0 then ( prerr_endline (format_check_summary !incorrect); raise (Error "Formatting check failed")) @@ -197,19 +197,17 @@ let read_stdin_interruptibly ?poll () = let format_stdin ?poll extension = if extension <> ".res" && extension <> ".resi" then raise (Error "--stdin must be .res or .resi"); - let bsc = bsc () in let path = Filename.temp_file "rescript-format-" extension in Fun.protect ~finally:(fun () -> try Sys.remove path with Sys_error _ -> ()) (fun () -> let contents = read_stdin_interruptibly ?poll () in File_util.write_file path contents; - print_string (formatted ?poll ~bsc ~target:"stdin" path)) + print_string (formatted ?poll ~target:"stdin" path)) let run_files ?poll ~verbosity ~check paths = - let bsc = bsc () in let files = if paths = [] then files_in_scope ~verbosity else paths in List.iter (fun file -> Output.trace ~channel:stderr ~verbosity ("Formatting " ^ file)) files; - format_files_with_bsc ?poll ~bsc ~check files + format_files ?poll ~check files diff --git a/rewatch-ocaml/format.mli b/rewatch-ocaml/format.mli index 95624e0c3f4..3cb8845e0ac 100644 --- a/rewatch-ocaml/format.mli +++ b/rewatch-ocaml/format.mli @@ -4,13 +4,7 @@ val write_file : string -> string -> unit val formatting_error : string -> string -> string val format_check_summary : int -> string -val format_files_with_bsc : - ?max_jobs:int -> - ?poll:(unit -> unit) -> - bsc:string -> - check:bool -> - string list -> - unit +val format_files : ?poll:(unit -> unit) -> check:bool -> string list -> unit val format_stdin : ?poll:(unit -> unit) -> string -> unit val run_files : diff --git a/rewatch-ocaml/package_compilation.ml b/rewatch-ocaml/package_compilation.ml index 9ac565e481b..68219535e34 100644 --- a/rewatch-ocaml/package_compilation.ml +++ b/rewatch-ocaml/package_compilation.ml @@ -75,13 +75,13 @@ let prepare ~(package : Package_plan.t) ~(prepared : Build_session.prepared) config.package_specs in let compile_process module_ ~source_kind path = - Compiler_process.compile_job ~bsc:prepared.compiler_context.bsc_path - ~build_dir ~config + Compiler_process.compile_request ~build_dir ~config ~common_args: (if module_.Source.is_dev then prepared_package.development_common_args else prepared_package.regular_common_args) module_ ~source_kind path + |> Compiler_process.task in let record_published_outputs ~source_kind path = match source_kind with @@ -156,7 +156,6 @@ let prepare ~(package : Package_plan.t) ~(prepared : Build_session.prepared) || attempt.freshness_mode = Build_attempt.Initialize_freshness then Compiler_process.namespace_task - ~bsc:prepared.compiler_context.bsc_path ~runtime:prepared.compiler_context.runtime_path ~build_dir ~ocaml_dir ~entry:(Config.namespace_entry config.namespace) @@ -190,7 +189,7 @@ let prepare ~(package : Package_plan.t) ~(prepared : Build_session.prepared) raise error in Build_attempt.add_namespace_job attempt - Build_attempt.{job = namespace_task.job; finish})); + Build_attempt.{task = namespace_task.task; finish})); Build_attempt.add_compile_candidates attempt candidates; Build_attempt.register_cleanup attempt (fun () -> if not watch then diff --git a/rewatch-ocaml/package_parse.ml b/rewatch-ocaml/package_parse.ml index 424b1fed46d..ecc1d96c8df 100644 --- a/rewatch-ocaml/package_parse.ml +++ b/rewatch-ocaml/package_parse.ml @@ -52,10 +52,10 @@ let run ~(package : Package_plan.t) ~(prepared : Build_session.prepared) List.map2 (fun path result -> (path, Build_attempt.preliminary_parse result)) parse_paths_to_run - (Process.run_parallel_map ?poll:attempt.process_poll parse_paths_to_run - ~job: - (Compiler_process.parse_job ~bsc:prepared.compiler_context.bsc_path - ~build_dir ~config)) + (List.map + (fun path -> Compiler_process.parse_request ~build_dir ~config path) + parse_paths_to_run + |> Compiler_process.run_requests ?poll:attempt.process_poll) @ (dirty_parse_paths |> List.filter_map (fun path -> Hashtbl.find_opt attempt.preliminary_parses diff --git a/rewatch-ocaml/platform.mli b/rewatch-ocaml/platform.mli index 18c66de50df..96ccf00e8d3 100644 --- a/rewatch-ocaml/platform.mli +++ b/rewatch-ocaml/platform.mli @@ -20,6 +20,7 @@ val error_symbol : string type command = {env: Spawn.Env.t option; program: string; args: string list} val post_build_command : command:string -> output:string -> command +val shell_command : string -> command type process diff --git a/rewatch-ocaml/platform_unix.ml b/rewatch-ocaml/platform_unix.ml index b0fca3df641..da737c7e382 100644 --- a/rewatch-ocaml/platform_unix.ml +++ b/rewatch-ocaml/platform_unix.ml @@ -38,6 +38,9 @@ let post_build_command ~command ~output = args = ["-c"; command ^ " " ^ Filename.quote output]; } +let shell_command command = + {env = None; program = "/bin/sh"; args = ["-c"; command]} + type process = int let spawn ~env ~cwd ~program ~args ~stdin ~stdout ~stderr = diff --git a/rewatch-ocaml/platform_windows.ml b/rewatch-ocaml/platform_windows.ml index f9f4f45b834..b5afa01763e 100644 --- a/rewatch-ocaml/platform_windows.ml +++ b/rewatch-ocaml/platform_windows.ml @@ -76,6 +76,13 @@ let post_build_command ~command ~output = args = ["/D"; "/V:OFF"; "/S"; "/C"; command ^ " \"%" ^ variable ^ "%\""]; } +let shell_command command = + { + env = None; + program = "cmd.exe"; + args = ["/D"; "/V:OFF"; "/S"; "/C"; command]; + } + let is_batch_file program = List.mem (Filename.extension program |> String.lowercase_ascii) diff --git a/rewatch-ocaml/process.ml b/rewatch-ocaml/process.ml index 0559efea75d..acad96f34df 100644 --- a/rewatch-ocaml/process.ml +++ b/rewatch-ocaml/process.ml @@ -7,7 +7,11 @@ type result = Child.result = { } type job = Child.job = {program: string; args: string list; cwd: string} -type task = {job: job; env: Spawn.Env.t option; on_result: result -> result} +type task_kind = + | External of {job: job; env: Spawn.Env.t option} + | Concurrent of {run: unit -> result; cancel: unit -> unit} + +type task = {kind: task_kind; on_result: result -> result} exception Error = Child.Error exception Interrupted of int @@ -29,56 +33,14 @@ let with_completion_notifier ~poll action = Child.with_completion_notifier ~ticker_enabled:false (action ~poll:(fun () -> ())) -let task ?env ?(on_result = fun result -> result) job = {job; env; on_result} - -let run_parallel_map_with_notifier ~max_jobs ~poll ~on_complete notifier values - ~job = - let indexed = List.mapi (fun index value -> (index, value)) values in - let results = Array.make (List.length values) None in - let active = ref [] in - let launch_indexed (index, value) = - active := Child.launch ~notifier index (job value) :: !active - in - let rec fill slots queued = - if slots = 0 then queued - else - match queued with - | [] -> [] - | job :: rest -> - launch_indexed job; - fill (slots - 1) rest - in - let rec schedule queued = - let queued = fill (max_jobs - List.length !active) queued in - match !active with - | [] -> () - | _ -> - let child, result = Child.wait_for_running ~poll notifier !active in - active := List.filter (fun running -> running != child) !active; - Child.release_running child; - results.(Child.payload child) <- Some result; - on_complete (Child.payload child); - schedule queued - in - try - schedule indexed; - Array.to_list results |> List.map Option.get - with exn -> - Child.terminate_running !active; - raise exn +let task ?env ?(on_result = fun result -> result) job = + {kind = External {job; env}; on_result} -let run_parallel_map ?(max_jobs = default_max_jobs) ?poll - ?(on_complete = fun _ -> ()) values ~job = - if max_jobs < 1 then raise (Error "max_jobs must be at least one"); - match values with - | [] -> [] - | _ -> - with_completion_notifier ~poll (fun ~poll notifier -> - run_parallel_map_with_notifier ~max_jobs ~poll ~on_complete notifier - values ~job) +let concurrent_task ~cancel ?(on_result = fun result -> result) run = + {kind = Concurrent {run; cancel}; on_result} -let run_parallel ?max_jobs ?poll ?on_complete jobs = - run_parallel_map ?max_jobs ?poll ?on_complete jobs ~job:Fun.id +let map_result task map = + {task with on_result = (fun result -> map (task.on_result result))} type 'a work = {key: string; dependencies: string list; value: 'a} type failure_action = @@ -110,6 +72,8 @@ type pool_active = { mutable cancellation: cancellation_state; } +type pool_action = {id: int; cancel: unit -> unit} + let cancellation_was_requested = function | Cancellation_not_requested -> false | Cancellation_requested | Cancellation_failed _ -> true @@ -126,13 +90,15 @@ type 'a worker_pool = { queued: ('a * task) Queue.t; completed_tasks: 'a pool_completion Queue.t; mutable active_children: pool_active list; + mutable active_actions: pool_action list; mutable next_active_id: int; mutable stopping: bool; mutable signalling_cancellation: bool; mutable workers: unit Domain.t list; + mutable worker_error: exn option; } -let remove_active pool active = +let remove_active pool (active : pool_active) = Child.with_lock pool.mutex (fun () -> while pool.signalling_cancellation @@ -142,7 +108,7 @@ let remove_active pool active = done; pool.active_children <- List.filter - (fun current -> current.id <> active.id) + (fun (current : pool_active) -> current.id <> active.id) pool.active_children) let complete_pool_task pool completion = @@ -150,70 +116,92 @@ let complete_pool_task pool completion = Queue.add completion pool.completed_tasks); Child.notify_completion pool.notifier +let run_concurrent_task pool payload task run cancel = + let active, cancel_now = + Child.with_lock pool.mutex (fun () -> + let active = {id = pool.next_active_id; cancel} in + pool.next_active_id <- pool.next_active_id + 1; + pool.active_actions <- active :: pool.active_actions; + (active, pool.stopping)) + in + let completion = + try + if cancel_now then cancel (); + Task_completed (payload, task.on_result (run ())) + with exn -> Task_failed (payload, exn) + in + Child.with_lock pool.mutex (fun () -> + pool.active_actions <- + List.filter (fun current -> current.id <> active.id) pool.active_actions); + complete_pool_task pool completion + let run_pool_task pool payload task = - match - try Ok (Child.launch ?env:task.env ~notifier:pool.notifier () task.job) - with exn -> Error exn - with - | Error exn -> complete_pool_task pool (Task_failed (payload, exn)) - | Ok child -> - let active, cancel_after_launch = - Child.with_lock pool.mutex (fun () -> - let active = - { - id = pool.next_active_id; - child; - cancellation = - (if pool.stopping then Cancellation_requested - else Cancellation_not_requested); - } - in - pool.next_active_id <- pool.next_active_id + 1; - pool.active_children <- active :: pool.active_children; - (active, cancellation_was_requested active.cancellation)) - in - let wait_result = - try - if cancel_after_launch then Child.signal_running [child]; - Ok - (Child.wait_for_running - ~poll:(fun () -> - match - Child.with_lock pool.mutex (fun () -> active.cancellation) - with - | Cancellation_failed exn -> raise exn - | Cancellation_not_requested | Cancellation_requested -> ()) - pool.notifier [child]) + match task.kind with + | Concurrent {run; cancel} -> run_concurrent_task pool payload task run cancel + | External {job; env} -> ( + match + try Ok (Child.launch ?env ~notifier:pool.notifier () job) with exn -> Error exn - in - let completion = - match wait_result with - | Ok (_, result) -> ( - remove_active pool active; + with + | Error exn -> complete_pool_task pool (Task_failed (payload, exn)) + | Ok child -> + let active, cancel_after_launch = + Child.with_lock pool.mutex (fun () -> + let active = + { + id = pool.next_active_id; + child; + cancellation = + (if pool.stopping then Cancellation_requested + else Cancellation_not_requested); + } + in + pool.next_active_id <- pool.next_active_id + 1; + pool.active_children <- active :: pool.active_children; + (active, cancellation_was_requested active.cancellation)) + in + let wait_result = try - Child.release_running child; - Task_completed (payload, task.on_result result) - with exn -> Task_failed (payload, exn)) - | Error exn -> ( - let termination = - try - Child.signal_running [child]; - Termination_confirmed - with cancellation_exn -> Termination_unconfirmed cancellation_exn - in - match termination with - | Termination_confirmed -> ( + if cancel_after_launch then Child.signal_running [child]; + Ok + (Child.wait_for_running + ~poll:(fun () -> + match + Child.with_lock pool.mutex (fun () -> active.cancellation) + with + | Cancellation_failed exn -> raise exn + | Cancellation_not_requested | Cancellation_requested -> ()) + pool.notifier [child]) + with exn -> Error exn + in + let completion = + match wait_result with + | Ok (_, result) -> ( remove_active pool active; try Child.release_running child; - Task_failed (payload, exn) - with release_exn -> Task_failed (payload, release_exn)) - | Termination_unconfirmed cancellation_exn -> - remove_active pool active; - Child.release_after_completion child; - Task_failed (payload, cancellation_exn)) - in - complete_pool_task pool completion + Task_completed (payload, task.on_result result) + with exn -> Task_failed (payload, exn)) + | Error exn -> ( + let termination = + try + Child.signal_running [child]; + Termination_confirmed + with cancellation_exn -> Termination_unconfirmed cancellation_exn + in + match termination with + | Termination_confirmed -> ( + remove_active pool active; + try + Child.release_running child; + Task_failed (payload, exn) + with release_exn -> Task_failed (payload, release_exn)) + | Termination_unconfirmed cancellation_exn -> + remove_active pool active; + Child.release_after_completion child; + Task_failed (payload, cancellation_exn)) + in + complete_pool_task pool completion) let rec worker_loop pool = let queued = @@ -240,15 +228,28 @@ let create_worker_pool ~max_jobs notifier = queued = Queue.create (); completed_tasks = Queue.create (); active_children = []; + active_actions = []; next_active_id = 0; stopping = false; signalling_cancellation = false; workers = []; + worker_error = None; } in + (* Workers run in-process compiler requests, which are OCaml computations, so + they must be domains to compile in parallel: threads would serialize them + on the runtime lock. A worker records an escaped exception instead of + letting it escape [Domain.join], so [stop_worker_pool] joins every worker + before re-raising the first error. *) + let run_worker () = + try worker_loop pool + with exn -> + Child.with_lock pool.mutex (fun () -> + if Option.is_none pool.worker_error then pool.worker_error <- Some exn) + in let rec start_workers remaining = if remaining > 0 then ( - let worker = Domain.spawn (fun () -> worker_loop pool) in + let worker = Domain.spawn run_worker in pool.workers <- worker :: pool.workers; start_workers (remaining - 1)) in @@ -282,21 +283,24 @@ let await_pool_completion ~poll pool = Child.notifier_generation pool.notifier |> wait let stop_worker_pool ~cancel pool = - let active = + let active, actions = Child.with_lock pool.mutex (fun () -> pool.stopping <- true; Queue.clear pool.queued; Condition.broadcast pool.work_available; if cancel then ( pool.signalling_cancellation <- true; - pool.active_children - |> List.filter_map (fun active -> - match active.cancellation with - | Cancellation_requested | Cancellation_failed _ -> None - | Cancellation_not_requested -> - active.cancellation <- Cancellation_requested; - Some active.child)) - else []) + let children = + pool.active_children + |> List.filter_map (fun active -> + match active.cancellation with + | Cancellation_requested | Cancellation_failed _ -> None + | Cancellation_not_requested -> + active.cancellation <- Cancellation_requested; + Some active.child) + in + (children, List.map (fun active -> active.cancel) pool.active_actions)) + else ([], [])) in let signal_error = try @@ -304,6 +308,23 @@ let stop_worker_pool ~cancel pool = None with exn -> Some exn in + let action_error = + List.fold_left + (fun first_error cancel -> + try + cancel (); + first_error + with exn -> ( + match first_error with + | Some _ -> first_error + | None -> Some exn)) + None actions + in + let cancellation_error = + match signal_error with + | Some _ -> signal_error + | None -> action_error + in Child.with_lock pool.mutex (fun () -> Option.iter (fun exn -> @@ -314,12 +335,15 @@ let stop_worker_pool ~cancel pool = active.cancellation <- Cancellation_failed exn | Cancellation_not_requested | Cancellation_failed _ -> ()) pool.active_children) - signal_error; + cancellation_error; pool.signalling_cancellation <- false; Condition.broadcast pool.cancellation_finished); - Option.iter (fun _ -> Child.notify_completion pool.notifier) signal_error; + Option.iter + (fun _ -> Child.notify_completion pool.notifier) + cancellation_error; List.iter Domain.join pool.workers; - Option.iter raise signal_error + Option.iter raise cancellation_error; + Option.iter raise pool.worker_error let with_worker_pool ~max_jobs notifier action = let pool = create_worker_pool ~max_jobs notifier in @@ -413,6 +437,10 @@ let run_dependency_graph_with_notifier ~max_jobs ~on_failure ~poll notifier if remaining = 0 then add_ready (Graph.find_node graph dependent_key)) in let rec fill pool = + (* Synchronous tasks and queued domain completions can keep the scheduler + from reaching the wait path's poll. Check before admitting more work so + an interrupt stops the next compiler request. *) + poll (); if (not !stopped) && !in_flight < max_jobs then match Work_ready.min_elt_opt !ready with | None -> () @@ -474,10 +502,34 @@ let run_dependency_graph ?(max_jobs = default_max_jobs) run_dependency_graph_with_notifier ~max_jobs ~on_failure ~poll notifier works ~next) -let run_one ?poll ?stdout_chunk ?stderr_chunk ?stdin ~cwd program args = +let run_tasks ?(max_jobs = default_max_jobs) ?poll ?(on_complete = fun _ -> ()) + tasks = + let tasks = Array.of_list tasks in + let results = Array.make (Array.length tasks) None in + let works = + Array.to_list + (Array.mapi + (fun index _ -> + { + key = Printf.sprintf "%010d" index; + dependencies = []; + value = index; + }) + tasks) + in + run_dependency_graph ~max_jobs ?poll works ~next:(fun index result -> + match result with + | None -> Some tasks.(index) + | Some result -> + results.(index) <- Some result; + on_complete index; + None); + Array.to_list results |> List.map Option.get + +let run_one ?poll ?stdout_chunk ?stderr_chunk ?stdin ?env ~cwd program args = with_completion_notifier ~poll (fun ~poll notifier -> let child = - Child.launch ?stdout_chunk ?stderr_chunk ?stdin ~notifier () + Child.launch ?stdout_chunk ?stderr_chunk ?stdin ?env ~notifier () {program; args; cwd} in let completion_received = ref false in @@ -492,6 +544,15 @@ let run_one ?poll ?stdout_chunk ?stderr_chunk ?stdin ~cwd program args = let run ?poll ~cwd program args = run_one ?poll ~cwd program args +let run_task ?poll task = + let result = + match task.kind with + | Concurrent {run; cancel = _} -> run () + | External {job; env} -> + run_one ?poll ?env ~cwd:job.cwd job.program job.args + in + task.on_result result + let run_streaming ?poll ~cwd program args = let write channel bytes count = output channel bytes 0 count; diff --git a/rewatch-ocaml/process.mli b/rewatch-ocaml/process.mli index a611081869b..250bd26f44e 100644 --- a/rewatch-ocaml/process.mli +++ b/rewatch-ocaml/process.mli @@ -15,21 +15,12 @@ val status_string : Unix.process_status -> string val default_max_jobs : int val task : ?env:Spawn.Env.t -> ?on_result:(result -> result) -> job -> task - -val run_parallel : - ?max_jobs:int -> - ?poll:(unit -> unit) -> - ?on_complete:(int -> unit) -> - job list -> - result list - -val run_parallel_map : - ?max_jobs:int -> - ?poll:(unit -> unit) -> - ?on_complete:(int -> unit) -> - 'a list -> - job:('a -> job) -> - result list +val concurrent_task : + cancel:(unit -> unit) -> + ?on_result:(result -> result) -> + (unit -> result) -> + task +val map_result : task -> (result -> result) -> task type 'a work = {key: string; dependencies: string list; value: 'a} @@ -50,7 +41,15 @@ val run_dependency_graph : next:('a -> result option -> task option) -> unit +val run_tasks : + ?max_jobs:int -> + ?poll:(unit -> unit) -> + ?on_complete:(int -> unit) -> + task list -> + result list + val run : ?poll:(unit -> unit) -> cwd:string -> string -> string list -> result +val run_task : ?poll:(unit -> unit) -> task -> result val run_streaming : ?poll:(unit -> unit) -> cwd:string -> string -> string list -> result diff --git a/rewatch-ocaml/rescript_ocaml.ml b/rewatch-ocaml/rescript_ocaml.ml index 5814ffdfb40..ad945e6a28e 100644 --- a/rewatch-ocaml/rescript_ocaml.ml +++ b/rewatch-ocaml/rescript_ocaml.ml @@ -5,15 +5,9 @@ let with_termination_handlers action = let requested_exit = Atomic.make 0 in let interrupt signal = - (* Shells report a process killed by signal n as exit status 128 + n. *) - let exit_code = - if signal = Sys.sigint then 130 - else if signal = Sys.sigterm then 143 - else if signal = Sys.sighup then 129 - else if signal = Sys.sigquit then 131 - else 1 - in - ignore (Atomic.compare_and_set requested_exit 0 exit_code) + ignore + (Atomic.compare_and_set requested_exit 0 + (Termination_signals.exit_code signal)) in let poll () = let exit_code = Atomic.get requested_exit in @@ -70,9 +64,28 @@ let run = function | command -> with_termination_handlers (fun ~poll -> run_command ~poll command) -let () = +let install_gc_reporter () = + match Sys.getenv_opt "REWATCH_GC_STATS_FILE" with + | None -> () + | Some path -> + at_exit (fun () -> + let stats = Gc.stat () in + let allocated_words = + stats.minor_words +. stats.major_words -. stats.promoted_words + in + File_util.write_file_atomic path + (Printf.sprintf + {|{"allocated_words":%.0f,"minor_words":%.0f,"promoted_words":%.0f,"major_words":%.0f,"minor_collections":%d,"major_collections":%d,"compactions":%d,"heap_words":%d,"top_heap_words":%d,"live_words":%d} +|} + allocated_words stats.minor_words stats.promoted_words + stats.major_words stats.minor_collections stats.major_collections + stats.compactions stats.heap_words stats.top_heap_words + stats.live_words)) + +let main () = Platform.configure_standard_streams (); try + install_gc_reporter (); match Cli.eval Sys.argv with | Cli.Run command -> run command | Cli.Exit code -> exit code @@ -92,3 +105,5 @@ let () = | (Sys_error _ as exn) | (Unix.Unix_error _ as exn) -> prerr_endline (Printexc.to_string exn); exit 1 + +let () = main () diff --git a/rewatch-ocaml/termination_signals.ml b/rewatch-ocaml/termination_signals.ml index ae69a1940e9..f91942e54f3 100644 --- a/rewatch-ocaml/termination_signals.ml +++ b/rewatch-ocaml/termination_signals.ml @@ -1,8 +1,34 @@ +(* Shells report a process killed by signal n as exit status 128 + n. *) +let exit_code signal = + if signal = Sys.sigint then 130 + else if signal = Sys.sigterm then 143 + else if signal = Sys.sighup then 129 + else if signal = Sys.sigquit then 131 + else 1 + +let received = Atomic.make 0 + +(* The first signal asks for a graceful stop, which waits for modules that are + compiling in-process to finish. A second one exits at once: only the main + domain publishes outputs, so an abandoned compile leaves nothing the next + build would trust. *) +let exit_now signal = + Build_lock.release_held (); + (try + flush stdout; + flush stderr + with Sys_error _ -> ()); + Unix._exit (exit_code signal) + let with_handlers handler action = let rec install = function | [] -> action () | signal :: signals -> - let previous = Sys.signal signal (Sys.Signal_handle handler) in + let handle signal = + if Atomic.fetch_and_add received 1 = 0 then handler signal + else exit_now signal + in + let previous = Sys.signal signal (Sys.Signal_handle handle) in Fun.protect (fun () -> install signals) ~finally:(fun () -> ignore (Sys.signal signal previous)) diff --git a/rewatch-ocaml/termination_signals.mli b/rewatch-ocaml/termination_signals.mli index 77cfe608acb..546ccd0ee48 100644 --- a/rewatch-ocaml/termination_signals.mli +++ b/rewatch-ocaml/termination_signals.mli @@ -1,4 +1,8 @@ +val exit_code : int -> int +(** The shell's exit status for a process stopped by the signal. *) + val with_handlers : (int -> unit) -> (unit -> 'a) -> 'a (** Runs the action with the handler installed for every {!Platform.termination_signals} entry, restoring the previous handlers - afterwards. *) + afterwards. The first signal goes to the handler; a second one releases the + held build locks and exits immediately. *) diff --git a/rewatch-ocaml/tests/check_command_validation.sh b/rewatch-ocaml/tests/check_command_validation.sh index 872fc4f7444..27f7ffe3420 100755 --- a/rewatch-ocaml/tests/check_command_validation.sh +++ b/rewatch-ocaml/tests/check_command_validation.sh @@ -6,7 +6,6 @@ rust=${1:-$root/rewatch/target/debug/rescript} ocaml=${2:-$root/_build/default/rewatch-ocaml/rescript_ocaml.exe} rust=$(realpath "$rust") ocaml=$(realpath "$ocaml") -bsc_test_proxy="$root/_build/default/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.exe" work=$(mktemp -d "${TMPDIR:-/tmp}/rewatch-command-validation-XXXXXX") # Compiler diagnostics contain canonical paths. Resolve platform aliases such # as macOS's /var -> /private/var before deriving paths used for comparison. @@ -21,13 +20,8 @@ case $(uname -s) in native_user=$(cygpath -w "$USERPROFILE" | tr '\\' '/') native_short_user=$(cygpath -w -s "$USERPROFILE" | tr '\\' '/') native_short_work=${native_work/"$native_user"/"$native_short_user"} - bsc_test_proxy=$(cygpath -aw \ - "$root/_build/default/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.exe") ;; esac -delete_source_bsc=$bsc_test_proxy -delete_parse_sources_bsc=$bsc_test_proxy -delete_ast_bsc=$bsc_test_proxy lock_owner_pid() { local shell_pid=$1 if $windows_posix_shell; then @@ -146,11 +140,6 @@ mkdir -p "$work/duplicate-dependency/src" \ "$work/duplicate-dependency/node_modules/a/src" \ "$work/duplicate-dependency/node_modules/shared/src" \ "$work/duplicate-dependency/node_modules/a/node_modules/shared/src" -mkdir -p "$work/publication-race-rust/src" \ - "$work/publication-race-ocaml/src" -mkdir -p "$work/ast-race-rust/src" "$work/ast-race-ocaml/src" -mkdir -p "$work/parse-source-race-rust/src" \ - "$work/parse-source-race-ocaml/src" mkdir -p "$work/watch-config-rust/src" "$work/watch-config-ocaml/src" mkdir -p "$work/watch-retained-graph/src" mkdir -p "$work/watch-dependency-recovery/src" \ @@ -163,7 +152,6 @@ mkdir -p "$work/watch-dependency-fallback/src" \ "$work/watch-dependency-fallback/packages/dep/src" \ "$work/node_modules" mkdir -p "$work/watch-symlink-target/src" "$work/watch-symlink-external/sub" -mkdir -p "$work/watch-feature-scope/src" "$work/watch-feature-scope/inactive" mkdir -p "$work/watch-filter-rust/src" "$work/watch-filter-rust/inactive" \ "$work/watch-filter-ocaml/src" "$work/watch-filter-ocaml/inactive" mkdir -p "$work/quiet-watch-rust/src" "$work/quiet-watch-ocaml/src" @@ -352,28 +340,6 @@ printf '{"name":"shared","sources":["src"]}\n' \ >"$work/duplicate-dependency/node_modules/a/node_modules/shared/rescript.json" printf 'let value = 2\n' \ >"$work/duplicate-dependency/node_modules/a/node_modules/shared/src/Shared.res" -printf '{"name":"publication-race","sources":["src"]}\n' \ - >"$work/publication-race-rust/rescript.json" -cp "$work/publication-race-rust/rescript.json" \ - "$work/publication-race-ocaml/rescript.json" -printf 'let value = 1\n' >"$work/publication-race-rust/src/A.res" -cp "$work/publication-race-rust/src/A.res" \ - "$work/publication-race-ocaml/src/A.res" -printf '{"name":"ast-race","sources":["src"]}\n' \ - >"$work/ast-race-rust/rescript.json" -cp "$work/ast-race-rust/rescript.json" "$work/ast-race-ocaml/rescript.json" -printf 'let value = 1\n' >"$work/ast-race-rust/src/A.res" -cp "$work/ast-race-rust/src/A.res" "$work/ast-race-ocaml/src/A.res" -printf '{"name":"parse-source-race","sources":["src"]}\n' \ - >"$work/parse-source-race-rust/rescript.json" -cp "$work/parse-source-race-rust/rescript.json" \ - "$work/parse-source-race-ocaml/rescript.json" -for implementation in rust ocaml; do - printf 'let value = 1\n' \ - >"$work/parse-source-race-$implementation/src/A.res" - printf 'let value = 2\n' \ - >"$work/parse-source-race-$implementation/src/B.res" -done printf '{"name":"watch-config","sources":["src"]}\n' \ >"$work/watch-config-rust/rescript.json" cp "$work/watch-config-rust/rescript.json" \ @@ -397,10 +363,6 @@ directory_link "$work/watch-dependency-recovery/packages/dep" \ printf '{"name":"watch-dependency-install","sources":["src"],"dependencies":["@scope/dep"]}\n' \ >"$work/watch-dependency-install/rescript.json" printf 'let value = 1\n' >"$work/watch-dependency-install/src/A.res" -printf '{"name":"watch-feature-scope","sources":["src",{"dir":"inactive","feature":"inactive"}]}\n' \ - >"$work/watch-feature-scope/rescript.json" -printf 'let value = 1\n' >"$work/watch-feature-scope/src/A.res" -printf 'let inactive = 1\n' >"$work/watch-feature-scope/inactive/Inactive.res" printf '{"name":"watch-dependency-fallback","sources":["src"],"dependencies":["dep"]}\n' \ >"$work/watch-dependency-fallback/rescript.json" printf 'let value = 1\n' >"$work/watch-dependency-fallback/src/A.res" @@ -432,24 +394,6 @@ for implementation in rust ocaml; do done printf 'require("fs").appendFileSync(process.env.REWATCH_WATCH_FILTER_MARKER, "done\\n")\n' \ >"$work/watch-filter-marker.js" -printf '%s\n' \ - '#!/bin/sh' \ - 'if [ -f "$REWATCH_SCOPE_BLOCK_REQUEST" ] && [ ! -f "$REWATCH_SCOPE_BLOCK_STARTED" ]; then' \ - ' : >"$REWATCH_SCOPE_BLOCK_STARTED"' \ - ' attempts=0' \ - ' while [ ! -f "$REWATCH_SCOPE_BLOCK_RELEASE" ] && [ "$attempts" -lt 200 ]; do' \ - ' attempts=$((attempts + 1))' \ - ' sleep 0.05' \ - ' done' \ - 'fi' \ - 'exec "$REWATCH_SCOPE_REAL_BSC" "$@"' \ - >"$work/watch-scope-bsc.sh" -chmod +x "$work/watch-scope-bsc.sh" -watch_scope_bsc="$work/watch-scope-bsc.sh" -if $windows_posix_shell; then - watch_scope_bsc=$bsc_test_proxy -fi - default_bsc=$root/_build/default/compiler/bsc/rescript_compiler_main.exe default_runtime=$root/packages/@rescript/runtime case $(uname -s) in @@ -495,6 +439,10 @@ normalize_project_path() { text = text.split(spelling).join(""); } } + // The Windows compiler can emit CRLF through the Rust process while the + // OCaml process converts captured compiler output to LF. Preserve bare CR + // characters used by terminal control sequences. + text = text.replaceAll("\r\n", "\n"); text = text.replaceAll("\\", "/"); text = text.replaceAll(".//", "./"); fs.writeFileSync(process.argv[2], text); @@ -611,23 +559,19 @@ require_both_errors_contain() { fi } +# Rust needs RESCRIPT_BSC_EXE to exist; OCaml builds and formats with the +# embedded compiler and ignores it. run_missing_bsc_case() { name=$1 shift RESCRIPT_BSC_EXE="$work/missing-bsc" run_both "$@" if [ "$(classify "$rust_status")" != panic ] || \ - [ "$(classify "$ocaml_status")" != reject ]; then - printf '%s: expected Rust=panic/OCaml=reject, got Rust=%s/OCaml=%s\n' \ + [ "$(classify "$ocaml_status")" != accept ]; then + printf '%s: expected Rust=panic/OCaml=accept, got Rust=%s/OCaml=%s\n' \ "$name" "$rust_status" "$ocaml_status" >&2 dump_both exit 1 fi - if ! grep -F 'RESCRIPT_BSC_EXE points to missing path' \ - "$work/ocaml.err" >/dev/null; then - echo "$name: OCaml did not report the stale compiler path" >&2 - cat "$work/ocaml.out" "$work/ocaml.err" >&2 - exit 1 - fi checked=$((checked + 1)) } @@ -1362,108 +1306,6 @@ if ! grep -F "$duplicate_warning" "$work/rust.err.norm" >/dev/null || \ exit 1 fi -set +e -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-source \ -REWATCH_SOURCE_TO_DELETE="$(command_path "$work/publication-race-rust/src/A.res")" \ -REWATCH_SOURCE_DELETED="$(command_path "$work/publication-race-rust/source-deleted")" \ -RESCRIPT_BSC_EXE="$delete_source_bsc" \ - "$rust" build "$work/publication-race-rust" \ - >"$work/rust.out" 2>"$work/rust.err" & -rust_pid=$! -attempts=0 -while kill -0 "$rust_pid" 2>/dev/null && [ "$attempts" -lt 150 ]; do - attempts=$((attempts + 1)) - sleep 0.1 -done -if kill -0 "$rust_pid" 2>/dev/null; then - kill -TERM "$rust_pid" 2>/dev/null - wait "$rust_pid" 2>/dev/null - rust_status=124 -else - wait "$rust_pid" - rust_status=$? -fi -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-source \ -REWATCH_SOURCE_TO_DELETE="$(command_path "$work/publication-race-ocaml/src/A.res")" \ -REWATCH_SOURCE_DELETED="$(command_path "$work/publication-race-ocaml/source-deleted")" \ -RESCRIPT_BSC_EXE="$delete_source_bsc" \ - "$ocaml" build "$work/publication-race-ocaml" \ - >"$work/ocaml.out" 2>"$work/ocaml.err" -ocaml_status=$? -set -e -if [ "$rust_status" -ne 124 ] || \ - ! grep -F "copying source file failed" "$work/rust.err" >/dev/null || \ - [ "$(classify "$ocaml_status")" != reject ] || \ - ! grep -F "A.res" "$work/ocaml.err" >/dev/null; then - printf 'build-source-disappears-during-publication: expected Rust=worker-panic/timeout and OCaml=path-bearing rejection, got Rust=%s/OCaml=%s\n' \ - "$rust_status" "$ocaml_status" >&2 - dump_both - exit 1 -fi -checked=$((checked + 1)) - -set +e -RAYON_NUM_THREADS=1 \ -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-parse-sources \ -REWATCH_SOURCE_A="$(command_path "$work/parse-source-race-rust/src/A.res")" \ -REWATCH_SOURCE_B="$(command_path "$work/parse-source-race-rust/src/B.res")" \ -REWATCH_SOURCES_DELETED="$(command_path "$work/parse-source-race-rust/sources-deleted")" \ -RESCRIPT_BSC_EXE="$delete_parse_sources_bsc" \ - "$rust" build "$work/parse-source-race-rust" \ - >"$work/rust.out" 2>"$work/rust.err" -rust_status=$? -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-parse-sources \ -REWATCH_SOURCE_A="$(command_path "$work/parse-source-race-ocaml/src/A.res")" \ -REWATCH_SOURCE_B="$(command_path "$work/parse-source-race-ocaml/src/B.res")" \ -REWATCH_SOURCES_DELETED="$(command_path "$work/parse-source-race-ocaml/sources-deleted")" \ -RESCRIPT_BSC_EXE="$delete_parse_sources_bsc" \ - "$ocaml" build "$work/parse-source-race-ocaml" \ - >"$work/ocaml.out" 2>"$work/ocaml.err" -ocaml_status=$? -set -e -if [ "$rust_status" -ne 101 ] || \ - ! grep -F "file not found" "$work/rust.err" >/dev/null || \ - [ "$(classify "$ocaml_status")" != reject ] || \ - ! grep -F "parse-source-race" "$work/ocaml.err" >/dev/null || \ - ! grep -E 'A\.(res|ast)' "$work/ocaml.err" >/dev/null; then - printf 'build-source-disappears-before-parse-read: expected Rust=panic and OCaml=path-bearing rejection, got Rust=%s/OCaml=%s\n' \ - "$rust_status" "$ocaml_status" >&2 - dump_both - exit 1 -fi -checked=$((checked + 1)) - -set +e -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-ast \ -REWATCH_AST_DELETED="$(command_path "$work/ast-race-rust/ast-deleted")" \ -RESCRIPT_BSC_EXE="$delete_ast_bsc" \ - "$rust" build "$work/ast-race-rust" \ - >"$work/rust.out" 2>"$work/rust.err" -rust_status=$? -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=delete-ast \ -REWATCH_AST_DELETED="$(command_path "$work/ast-race-ocaml/ast-deleted")" \ -RESCRIPT_BSC_EXE="$delete_ast_bsc" \ - "$ocaml" build "$work/ast-race-ocaml" \ - >"$work/ocaml.out" 2>"$work/ocaml.err" -ocaml_status=$? -set -e -if [ "$rust_status" -ne 101 ] || \ - ! grep -F "Could not read file" "$work/rust.err" >/dev/null || \ - [ "$(classify "$ocaml_status")" != reject ] || \ - ! grep -F "A.ast" "$work/ocaml.err" >/dev/null; then - printf 'build-ast-disappears-before-dependency-read: expected Rust=panic and OCaml=path-bearing rejection, got Rust=%s/OCaml=%s\n' \ - "$rust_status" "$ocaml_status" >&2 - dump_both - exit 1 -fi -checked=$((checked + 1)) - "$rust" watch "$work/watch-config-rust" \ >"$work/watch-rust.out" 2>"$work/watch-rust.err" & rust_watch_pid=$! @@ -1647,47 +1489,6 @@ if $file_symlinks_supported; then checked=$((checked + 1)) fi -feature_scope_marker="$work/watch-feature-scope/after-build.log" -scope_block_request="$work/watch-feature-scope/block-request" -scope_block_started="$work/watch-feature-scope/block-started" -scope_block_release="$work/watch-feature-scope/block-release" -REWATCH_SCOPE_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=scope-block \ -REWATCH_SCOPE_BLOCK_REQUEST="$(command_path "$scope_block_request")" \ -REWATCH_SCOPE_BLOCK_STARTED="$(command_path "$scope_block_started")" \ -REWATCH_SCOPE_BLOCK_RELEASE="$(command_path "$scope_block_release")" \ -RESCRIPT_BSC_EXE="$watch_scope_bsc" \ -REWATCH_WATCH_FILTER_MARKER="$feature_scope_marker" \ - "$ocaml" watch --features other \ - --after-build "node $command_work/watch-filter-marker.js" \ - "$work/watch-feature-scope" \ - >"$work/watch-feature-scope.out" 2>"$work/watch-feature-scope.err" & -feature_scope_pid=$! -background_pids="$background_pids $feature_scope_pid" -if ! wait_for_line_count "$feature_scope_marker" 1; then - echo "OCaml feature-scope watcher did not finish its initial build" >&2 - cat "$work/watch-feature-scope.out" "$work/watch-feature-scope.err" >&2 - exit 1 -fi -: >"$scope_block_request" -printf '{"name":"watch-feature-scope","sources":["src",{"dir":"inactive","feature":"inactive"}],"features":{"other":["inactive"]}}\n' \ - >"$work/watch-feature-scope/rescript.json" -wait_for_file "$scope_block_started" -printf 'let createdDuringBuild = 2\n' \ - >"$work/watch-feature-scope/inactive/CreatedDuringBuild.res" -: >"$scope_block_release" -wait_for_file "$work/watch-feature-scope/inactive/Inactive.js" -wait_for_file "$work/watch-feature-scope/inactive/CreatedDuringBuild.js" -wait_for_line_count "$feature_scope_marker" 3 -if ! line_count_stays "$feature_scope_marker" 3; then - echo "OCaml watcher lost or duplicated an edit during a source-scope transition" >&2 - cat "$work/watch-feature-scope.out" "$work/watch-feature-scope.err" >&2 - exit 1 -fi -terminate_and_wait "$feature_scope_pid" "feature-scope watcher" -checked=$((checked + 1)) - rust_filter_marker="$work/watch-filter-rust/after-build.log" REWATCH_WATCH_FILTER_MARKER="$rust_filter_marker" \ "$rust" watch --features other --filter 'Include\.res$' \ diff --git a/rewatch-ocaml/tests/check_interactive_output.sh b/rewatch-ocaml/tests/check_interactive_output.sh index 1f599c3e87b..5291450f085 100755 --- a/rewatch-ocaml/tests/check_interactive_output.sh +++ b/rewatch-ocaml/tests/check_interactive_output.sh @@ -82,7 +82,6 @@ for implementation in rust ocaml; do printf 'let value = 1\n' >"$work/$implementation/src/A.res" printf 'let value: int\n' >"$work/$implementation/src/A.resi" cp -R "$work/$implementation" "$work/$implementation-after-build" - cp -R "$work/$implementation" "$work/$implementation-parse-warning" cp -R "$work/$implementation" "$work/$implementation-watch" cp -R "$work/$implementation" "$work/$implementation-initial-failure-watch" printf 'let value = (\n' \ @@ -112,12 +111,10 @@ EOF export RESCRIPT_BSC_EXE=${RESCRIPT_BSC_EXE:-$root/_build/default/compiler/bsc/rescript_compiler_main.exe} export RESCRIPT_RUNTIME=${RESCRIPT_RUNTIME:-$root/packages/@rescript/runtime} -parse_warning_bsc="$root/_build/default/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.exe" after_build_command="$work/after-build-marker.sh" if $windows_posix_shell; then RESCRIPT_BSC_EXE=$(command_path "$RESCRIPT_BSC_EXE") RESCRIPT_RUNTIME=$(command_path "$RESCRIPT_RUNTIME") - parse_warning_bsc=$(command_path "$parse_warning_bsc") after_build_command="node $(command_path "$work/after-build-marker.js")" fi @@ -196,55 +193,6 @@ if ! cmp -s "$work/expected" "$work/ocaml.phases"; then exit 1 fi -capture_parse_warning_order() { - implementation=$1 - executable=$2 - transcript="$work/$implementation-parse-warning.tty" - project="$work/$implementation-parse-warning" - command_executable=$(command_path "$executable") - command_project=$(command_path "$project") - if [ "$(uname -s)" = Darwin ]; then - script -qF "$transcript" env -u NO_COLOR \ - "TERM=xterm" \ - "CLICOLOR=1" \ - "CLICOLOR_FORCE=0" \ - "REWATCH_REAL_BSC=$RESCRIPT_BSC_EXE" \ - "REWATCH_BSC_PROXY_MODE=parse-warning" \ - "RESCRIPT_BSC_EXE=$parse_warning_bsc" \ - "RESCRIPT_RUNTIME=$RESCRIPT_RUNTIME" \ - "$executable" build "$project" --no-timing >/dev/null - else - script -qefc \ - "env -u NO_COLOR TERM=xterm CLICOLOR=1 CLICOLOR_FORCE=0 REAL_BSC_EXE=$RESCRIPT_BSC_EXE REWATCH_REAL_BSC=$RESCRIPT_BSC_EXE REWATCH_BSC_PROXY_MODE=parse-warning RESCRIPT_BSC_EXE=$parse_warning_bsc RESCRIPT_RUNTIME=$RESCRIPT_RUNTIME $command_executable build $command_project --no-timing" \ - "$transcript" >/dev/null - fi - tr '\r' '\n' <"$transcript" \ - | normalize_output \ - | grep -E '(^\[[123]/3\] .* Parsed |PARSE_WARNING_MARKER)' \ - >"$work/$implementation-parse-warning.order" -} - -echo "Checking interactive parser warnings..." -capture_parse_warning_order rust "$rust" -capture_parse_warning_order ocaml "$ocaml" - -if ! cmp -s "$work/rust-parse-warning.order" \ - "$work/ocaml-parse-warning.order"; then - echo "Parser warning phase order differs" >&2 - printf '%s\n' '--- Rust order ---' >&2 - cat "$work/rust-parse-warning.order" >&2 - printf '%s\n' '--- OCaml order ---' >&2 - cat "$work/ocaml-parse-warning.order" >&2 - exit 1 -fi - -if ! sed -n '1p' "$work/ocaml-parse-warning.order" \ - | grep -E '^\[2/3\] .* Parsed 1 source files in 0.00s$' >/dev/null; then - echo "Parser warnings were emitted before the completed parse phase" >&2 - cat "$work/ocaml-parse-warning.order" >&2 - exit 1 -fi - capture_after_build_order() { implementation=$1 executable=$2 diff --git a/rewatch-ocaml/tests/ppx-filter/rescript.json b/rewatch-ocaml/tests/ppx-filter/rescript.json index b1d194899bf..91de1018199 100644 --- a/rewatch-ocaml/tests/ppx-filter/rescript.json +++ b/rewatch-ocaml/tests/ppx-filter/rescript.json @@ -1,5 +1,9 @@ { "name": "rewatch-ocaml-ppx-filter", "sources": "src", - "ppx-flags": ["missing-graphql-ppx"] + "ppx-flags": [ + "missing-graphql-ppx", + "missing-rescript-schema-ppx", + "missing-sury-ppx" + ] } diff --git a/rewatch-ocaml/tests/run.sh b/rewatch-ocaml/tests/run.sh index f4d8084191c..504512b04df 100644 --- a/rewatch-ocaml/tests/run.sh +++ b/rewatch-ocaml/tests/run.sh @@ -10,9 +10,7 @@ port="$1" port_directory=$(CDPATH= cd -- "$(dirname "$port")" && pwd) port="$port_directory/$(basename "$port")" root=$(CDPATH= cd -- "$(dirname "$0")/../.." && pwd) -: "${RESCRIPT_BSC_EXE:=$root/_build/default/compiler/bsc/rescript_compiler_main.exe}" : "${RESCRIPT_RUNTIME:=$root/packages/@rescript/runtime}" -test_proxy="$root/_build/default/tests/rewatch_ounit_tests/rewatch_bsc_test_proxy.exe" windows_posix_shell=false case $(uname -s) in CYGWIN*|MINGW*|MSYS*) windows_posix_shell=true ;; @@ -20,21 +18,6 @@ esac native_path() { if $windows_posix_shell; then cygpath -am "$1"; else printf '%s\n' "$1"; fi } -assert_no_test_proxy_processes() { - if $windows_posix_shell; then - if ! powershell.exe -NoProfile -NonInteractive -Command \ - 'if (Get-Process -Name rewatch_bsc_test_proxy -ErrorAction SilentlyContinue) { exit 1 }'; then - echo "rewatch compiler test proxy was left running" >&2 - powershell.exe -NoProfile -NonInteractive -Command \ - 'Get-Process -Name rewatch_bsc_test_proxy -ErrorAction SilentlyContinue | Format-Table -AutoSize' >&2 - exit 1 - fi - # Match only this checkout's proxy: other worktrees may run tests concurrently. - elif test -n "$(pgrep -f -- "$test_proxy_pattern" || true)"; then - echo "rewatch compiler test proxy was left running" >&2 - exit 1 - fi -} directory_link() { link_target=$1 link_path=$2 @@ -59,12 +42,9 @@ file_link_if_supported() { fi } if $windows_posix_shell; then - RESCRIPT_BSC_EXE=$(native_path "$RESCRIPT_BSC_EXE") RESCRIPT_RUNTIME=$(native_path "$RESCRIPT_RUNTIME") - test_proxy=$(native_path "$test_proxy") fi -test_proxy_pattern=$(printf '%s\n' "$test_proxy" | sed 's/[][\.*^$+?(){}|]/\\&/g') -export RESCRIPT_BSC_EXE RESCRIPT_RUNTIME +export RESCRIPT_RUNTIME work="$root/tmp/rewatch-ocaml/test-$$" mkdir -p "$work" cp -R "$root/rewatch-ocaml/tests/basic" "$work/basic" @@ -151,7 +131,6 @@ for dependency in namespace-one namespace-two; do "$work/namespace-collision/node_modules/$dependency" done cp -R "$root/rewatch-ocaml/tests/source-map" "$work/source-map" -cp -R "$root/rewatch-ocaml/tests/warning-replay" "$work/warning-replay" cp -R "$root/rewatch-ocaml/tests/monorepo" "$work/monorepo" basic="$work/basic" cleanup_lifecycle="$work/cleanup-lifecycle" @@ -178,7 +157,6 @@ namespace_entry="$work/namespace-entry" qualified_namespace="$work/qualified-namespace" namespace_collision="$work/namespace-collision" source_map="$work/source-map" -warning_replay="$work/warning-replay" monorepo="$work/monorepo" package_name_mismatch="$work/package-name-mismatch" @@ -271,13 +249,6 @@ printf 'let dependent = A.value + 1\n' \ printf 'let valid = true\n' \ >"$interface_failure_recovery/src/Broken.res" -atomic_save="$work/atomic-save" -mkdir -p "$atomic_save/src" -printf '%s\n' \ - '{"name":"atomic-save","sources":"src/","package-specs":{"module":"esmodule","in-source":true,"suffix":".mjs"}}' \ - >"$atomic_save/rescript.json" -printf 'let value = 1\n' >"$atomic_save/src/Main.res" - missing_nested_source="$work/missing-nested-source" mkdir -p "$missing_nested_source" printf '%s\n' \ @@ -420,14 +391,6 @@ printf '%s\n' \ >"$moved_source/rescript.json" printf 'let value = 1\n' >"$moved_source/src/A.res" -publication_cmi="$work/publication-cmi" -mkdir -p "$publication_cmi/src" -printf '%s\n' \ - '{"name":"publication-cmi","sources":"src","package-specs":{"module":"esmodule","in-source":true,"suffix":".mjs"}}' \ - >"$publication_cmi/rescript.json" -printf 'let value = 1\n' >"$publication_cmi/src/A.res" -printf 'let dependent = A.value + 1\n' >"$publication_cmi/src/B.res" - retained_cycle="$work/retained-cycle" mkdir -p "$retained_cycle/src" printf '%s\n' \ @@ -436,14 +399,6 @@ printf '%s\n' \ printf 'let value = 1\n' >"$retained_cycle/src/A.res" printf 'let dependent = A.value\n' >"$retained_cycle/src/B.res" -retained_parse="$work/retained-parse" -mkdir -p "$retained_parse/src" -printf '%s\n' \ - '{"name":"retained-parse","sources":"src","package-specs":{"module":"esmodule","in-source":true,"suffix":".mjs"}}' \ - >"$retained_parse/rescript.json" -printf 'let value = 1\n' >"$retained_parse/src/A.res" -printf 'let other = 1\n' >"$retained_parse/src/B.res" - initial_failure_freshness="$work/initial-failure-freshness" mkdir -p "$initial_failure_freshness/src" printf '%s\n' \ @@ -542,29 +497,25 @@ for namespace_dependency_name in ns-one ns-two; do "$external_namespace/node_modules/$namespace_dependency_name" done -dev_include_order="$work/dev-include-order" -mkdir -p "$dev_include_order/src" "$dev_include_order/dev" \ - "$dev_include_order/node_modules/regular/src" \ - "$dev_include_order/node_modules/development/src" -printf '%s\n' \ - '{"name":"dev-include-root","sources":["src",{"dir":"dev","type":"dev"}],"dependencies":["regular"],"dev-dependencies":["development"]}' \ - >"$dev_include_order/rescript.json" -printf 'let value = 1\n' >"$dev_include_order/src/Main.res" -printf 'let value = 2\n' >"$dev_include_order/dev/Test.res" -printf '%s\n' '{"name":"regular","sources":"src"}' \ - >"$dev_include_order/node_modules/regular/rescript.json" -printf 'let value = 1\n' \ - >"$dev_include_order/node_modules/regular/src/Regular.res" -printf '%s\n' '{"name":"development","sources":"src"}' \ - >"$dev_include_order/node_modules/development/rescript.json" -printf 'let value = 1\n' \ - >"$dev_include_order/node_modules/development/src/Development.res" - -if [ -x "$port_directory/bsc.exe" ]; then - env -u RESCRIPT_BSC_EXE "$port" build "$packaged_basic" \ - >"$packaged_basic/build.log" - test -f "$packaged_basic/src/A.mjs" -fi +# Builds use the embedded compiler, but editor tooling finds bsc.exe and the +# other platform binaries through compiler-info.json, so it must record the +# bsc.exe shipped next to the executable. +"$port" build "$packaged_basic" >"$packaged_basic/build.log" +test -f "$packaged_basic/src/A.mjs" +COMPILER_INFO=$(native_path "$packaged_basic/lib/bs/compiler-info.json") \ + EXPECTED_BSC=$(native_path "$port_directory/bsc.exe") node -e ' + const fs = require("node:fs"); + const path = require("node:path"); + const info = JSON.parse(fs.readFileSync(process.env.COMPILER_INFO, "utf8")); + const expected = path.join( + fs.realpathSync(path.dirname(process.env.EXPECTED_BSC)), + "bsc.exe", + ); + if (path.relative(info.bsc_path, expected) !== "") { + console.error(`compiler-info.json bsc_path ${info.bsc_path}, expected ${expected}`); + process.exit(1); + } +' mkdir -p "$runtime_discovery/node_modules/@rescript/runtime" runtime_path=$(CDPATH= cd -- \ @@ -798,8 +749,9 @@ wait_for_file_gone() { wait_for_pid_gone() { pid="$1" + max_attempts=${2:-50} attempts=0 - while [ "$attempts" -lt 50 ]; do + while [ "$attempts" -lt "$max_attempts" ]; do if ! kill -0 "$pid" 2>/dev/null; then return 0 fi @@ -1281,42 +1233,6 @@ grep 'does not match the interface' \ grep 'Parsed 0 source files' "$directory_symlink/unchanged.log" >/dev/null grep 'Compiled 0 modules' "$directory_symlink/unchanged.log" >/dev/null -# Record the content that triggered a direct event before building it. An -# atomic replacement made while that build is compiling must cause a second -# build rather than becoming the post-build snapshot baseline. -atomic_release="$atomic_save/release" -atomic_started="$atomic_save/compile-started" -touch "$atomic_release" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=block-compile \ - REWATCH_OCAML_RELEASE_FILE="$(native_path "$atomic_release")" \ - REWATCH_OCAML_COMPILE_STARTED="$(native_path "$atomic_started")" \ - "$port" watch "$atomic_save" >"$atomic_save/watch.log" 2>&1 & -atomic_save_pid=$! -background_pids="$background_pids $atomic_save_pid" -if ! wait_for_file "$atomic_save/src/Main.mjs"; then - cat "$atomic_save/watch.log" >&2 - exit 1 -fi -wait_for_initial_build "$atomic_save/watch.log" -rm "$atomic_release" "$atomic_started" -printf 'let value = 2\n' >"$atomic_save/src/Main.res" -if ! wait_for_file "$atomic_started"; then - cat "$atomic_save/watch.log" >&2 - exit 1 -fi -printf 'let value = 3\n' >"$atomic_save/src/Main.next" -mv "$atomic_save/src/Main.next" "$atomic_save/src/Main.res" -touch "$atomic_release" -if ! wait_for_text "$atomic_save/src/Main.mjs" 'value = 3'; then - cat "$atomic_save/watch.log" >&2 - cat "$atomic_save/src/Main.mjs" >&2 - exit 1 -fi -kill -TERM "$atomic_save_pid" -wait "$atomic_save_pid" 2>/dev/null || true - "$port" watch "$recursive_lib" >"$recursive_lib/watch.log" 2>&1 & recursive_lib_pid=$! background_pids="$background_pids $recursive_lib_pid" @@ -1600,38 +1516,6 @@ fi kill -TERM "$namespace_repair_pid" wait "$namespace_repair_pid" 2>/dev/null || true -publication_destination="$publication_cmi/lib/bs/src/A.res" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=fail-late-publication \ - REWATCH_FAIL_PUBLICATION="$(native_path "$publication_cmi/fail-publication")" \ - REWATCH_PUBLICATION_FAILED="$(native_path "$publication_cmi/publication-failed")" \ - REWATCH_PUBLICATION_DESTINATION="$(native_path "$publication_destination")" \ - "$port" watch "$publication_cmi" >"$publication_cmi/watch.log" 2>&1 & -publication_cmi_pid=$! -background_pids="$background_pids $publication_cmi_pid" -if ! wait_for_file "$publication_cmi/src/B.mjs"; then - cat "$publication_cmi/watch.log" >&2 - exit 1 -fi -wait_for_initial_build "$publication_cmi/watch.log" -touch "$publication_cmi/fail-publication" -printf 'let value = "changed"\n' >"$publication_cmi/src/A.res" -if ! wait_for_file "$publication_cmi/publication-failed" || \ - ! wait_for_text "$publication_cmi/watch.log" 'A.res'; then - cat "$publication_cmi/watch.log" >&2 - exit 1 -fi -remove_obstruction_directory "$publication_destination" -rm "$publication_cmi/fail-publication" -printf 'let value = "changed"\n\n' >"$publication_cmi/src/A.res" -if ! wait_for_text "$publication_cmi/watch.log" 'This has type:'; then - cat "$publication_cmi/watch.log" >&2 - exit 1 -fi -kill -TERM "$publication_cmi_pid" -wait "$publication_cmi_pid" 2>/dev/null || true - "$port" watch "$retained_cycle" >"$retained_cycle/watch.log" 2>&1 & retained_cycle_pid=$! background_pids="$background_pids $retained_cycle_pid" @@ -1689,61 +1573,6 @@ fi kill -TERM "$initial_failure_freshness_pid" wait "$initial_failure_freshness_pid" 2>/dev/null || true -# Failed parses and parser warnings remain pending until the same source parses -# cleanly. An unrelated edit must not compile an older AST or forget diagnostics. -retained_parse_log="$retained_parse/watch.log" -retained_parse_calls="$retained_parse/bsc-calls.log" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=parse-warning-log \ - REWATCH_BSC_CALL_LOG="$(native_path "$retained_parse_calls")" \ - REWATCH_PARSE_WARNING_SOURCE=A.res \ - "$port" watch "$retained_parse" >"$retained_parse_log" 2>&1 & -retained_parse_pid=$! -background_pids="$background_pids $retained_parse_pid" -if ! wait_for_count "$retained_parse_log" REWATCH_PARSE_WARNING 1 || \ - ! wait_for_file "$retained_parse/src/A.mjs"; then - cat "$retained_parse_log" >&2 - exit 1 -fi -wait_for_initial_build "$retained_parse_log" -initial_a_parse_count=$(grep -c -- '-bs-ast.*A.res' "$retained_parse_calls") -printf 'let other = 2\n' >"$retained_parse/src/B.res" -if ! wait_for_count "$retained_parse_log" REWATCH_PARSE_WARNING 2; then - cat "$retained_parse_log" >&2 - exit 1 -fi -if ! wait_for_count "$retained_parse_calls" '-bs-ast.*A.res' \ - "$((initial_a_parse_count + 1))"; then - cat "$retained_parse_calls" >&2 - exit 1 -fi -warning_a_parse_count=$(grep -c -- '-bs-ast.*A.res' "$retained_parse_calls") -test "$warning_a_parse_count" -gt "$initial_a_parse_count" -printf 'let value =\n' >"$retained_parse/src/A.res" -if ! wait_for_count "$retained_parse_log" \ - 'This let-binding misses an expression' 1; then - cat "$retained_parse_log" >&2 - exit 1 -fi -failed_a_parse_count=$(grep -c -- '-bs-ast.*A.res' "$retained_parse_calls") -printf 'let other = 3\n' >"$retained_parse/src/B.res" -if ! wait_for_count "$retained_parse_log" \ - 'This let-binding misses an expression' 2; then - cat "$retained_parse_log" >&2 - exit 1 -fi -retried_a_parse_count=$(grep -c -- '-bs-ast.*A.res' "$retained_parse_calls") -test "$retried_a_parse_count" -gt "$failed_a_parse_count" -grep 'value = 1' "$retained_parse/src/A.mjs" >/dev/null -printf 'let value = 2\n' >"$retained_parse/src/A.res" -if ! wait_for_text "$retained_parse/src/A.mjs" 'value = 2'; then - cat "$retained_parse_log" >&2 - exit 1 -fi -kill -TERM "$retained_parse_pid" -wait "$retained_parse_pid" 2>/dev/null || true - "$port" build "$duplicate_selection" >/dev/null "$port" build "$external_duplicate" >"$external_duplicate/build.log" 2>&1 tr '\\' '/' <"$external_duplicate/build.log" | \ @@ -1814,34 +1643,13 @@ fi kill -TERM "$transitive_local_watch_pid" wait "$transitive_local_watch_pid" 2>/dev/null || true -dev_include_call_log="$dev_include_order/bsc-calls.log" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=counting \ - REWATCH_BSC_CALL_LOG="$(native_path "$dev_include_call_log")" \ - "$port" build "$dev_include_order" >/dev/null -node - "$dev_include_call_log" \ - "$dev_include_order/node_modules/development/lib/ocaml" \ - "$dev_include_order/node_modules/regular/lib/ocaml" <<'EOF' -const fs = require("fs"); -const [log, development, regular] = process.argv.slice(2); -const normalize = value => value.replaceAll("\\", "/"); -const command = fs.readFileSync(log, "utf8").split("\n") - .find(line => line.includes("Test.ast") && !line.includes("-bs-ast")); -const normalizedCommand = command === undefined ? "" : normalize(command); -if (!command || normalizedCommand.indexOf(normalize(development)) < 0 || - normalizedCommand.indexOf(normalize(development)) > - normalizedCommand.indexOf(normalize(regular))) { - process.exit(1); -} -EOF - -warning_call_log="$warning_replay/bsc-calls.log" +# A watch rebuild after an unrelated edit replays warnings from modules it +# doesn't recompile. Compiler requests are counted at the logical request log. +cp -R "$root/rewatch-ocaml/tests/warning-replay" "$work/warning-replay" +warning_replay="$work/warning-replay" +warning_call_log="$warning_replay/compiler-calls.log" warning_watch_log="$warning_replay/watch.log" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=counting \ - REWATCH_BSC_CALL_LOG="$(native_path "$warning_call_log")" \ +env REWATCH_COMPILER_CALL_LOG="$(native_path "$warning_call_log")" \ "$port" watch "$warning_replay" >"$warning_watch_log" 2>&1 & warning_watch_pid=$! background_pids="$background_pids $warning_watch_pid" @@ -1913,62 +1721,13 @@ stop_watch "$watch_basic" "$watch_restart_pid" test ! -f "$watch_basic/lib/watch.lock" if ! $windows_posix_shell; then -interrupt_basic="$work/interrupt-basic" -cp -R "$root/rewatch-ocaml/tests/basic" "$interrupt_basic" -child_marker="$interrupt_basic/child-started" -REWATCH_OCAML_CHILD_STARTED="$(native_path "$child_marker")" \ -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=slow \ -RESCRIPT_BSC_EXE="$test_proxy" \ -"$port" watch "$interrupt_basic" >"$interrupt_basic/watch.log" 2>&1 & -interrupt_pid=$! -background_pids="$background_pids $interrupt_pid" -attempts=0 -while [ "$attempts" -lt 100 ] && [ ! -f "$child_marker" ]; do - attempts=$((attempts + 1)) - sleep 0.1 -done -test -f "$child_marker" -kill -TERM "$interrupt_pid" -wait "$interrupt_pid" -test ! -f "$interrupt_basic/lib/watch.lock" -assert_no_test_proxy_processes -test -z "$(find "$interrupt_basic" -name '.rewatch-ocaml-*.log' -print)" - -# One-shot commands must unwind through the same process and lock owners when -# the shell terminates them during compiler work. Compiler children run in -# their own process groups, so a closing terminal's SIGHUP and a SIGQUIT reach -# only rescript and must be handled like SIGTERM, or the children outlive the -# build and its lock is left behind. -for interrupt_signal in TERM:143 HUP:129 QUIT:131; do - signal_name=${interrupt_signal%%:*} - expected_status=${interrupt_signal#*:} - interrupt_build="$work/interrupt-build-$signal_name" - cp -R "$root/rewatch-ocaml/tests/basic" "$interrupt_build" - build_child_marker="$interrupt_build/child-started" - REWATCH_OCAML_CHILD_STARTED="$(native_path "$build_child_marker")" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=slow \ - RESCRIPT_BSC_EXE="$test_proxy" \ - "$port" build "$interrupt_build" >"$interrupt_build/build.log" 2>&1 & - interrupt_build_pid=$! - background_pids="$background_pids $interrupt_build_pid" - wait_for_file "$build_child_marker" - kill "-$signal_name" "$interrupt_build_pid" - set +e - wait "$interrupt_build_pid" - interrupt_build_status=$? - set -e - test "$interrupt_build_status" -eq "$expected_status" - test ! -f "$interrupt_build/lib/build.lock" - assert_no_test_proxy_processes - test -z "$(find "$interrupt_build" -name '.rewatch-ocaml-*.log' -print)" -done - -# The same signals must also stop a build while it waits for an external -# js-post-build hook, which runs in its own process group too. The hook records -# its pid and then sleeps, so the build is still running when it is signalled; -# the hook must be gone afterwards and the build lock released. +# One-shot builds must unwind through the same process and lock owners when +# the shell terminates them. Compilation runs in process, but a js-post-build +# hook is still an external child in its own process group, so a closing +# terminal's SIGHUP and a SIGQUIT reach only rescript and must be handled like +# SIGTERM, or the hook outlives the build and its lock is left behind. The hook +# records its pid and then sleeps, so the build is still running when it is +# signalled. for hook_signal in TERM:143 HUP:129 QUIT:131; do signal_name=${hook_signal%%:*} expected_status=${hook_signal#*:} @@ -2011,66 +1770,80 @@ for hook_signal in TERM:143 HUP:129 QUIT:131; do done fi -# Removing watch.lock is the shell-suite shutdown protocol. It must interrupt -# an in-progress compiler batch just as SIGTERM does, rather than waiting for -# every queued module to finish. -lock_interrupt_basic="$work/lock-interrupt-basic" -cp -R "$root/rewatch-ocaml/tests/basic" "$lock_interrupt_basic" -lock_child_marker="$lock_interrupt_basic/child-started" -REWATCH_OCAML_CHILD_STARTED="$(native_path "$lock_child_marker")" \ -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=slow \ -RESCRIPT_BSC_EXE="$test_proxy" \ -"$port" watch "$lock_interrupt_basic" \ - >"$lock_interrupt_basic/watch.log" 2>&1 & -lock_interrupt_pid=$! -background_pids="$background_pids $lock_interrupt_pid" -if ! wait_for_file "$lock_child_marker"; then - cat "$lock_interrupt_basic/watch.log" >&2 - exit 1 -fi -remove_file_with_retry "$lock_interrupt_basic/lib/watch.lock" -if ! wait_for_pid_gone "$lock_interrupt_pid"; then - echo "watcher did not stop during compiler work after watch.lock removal" >&2 - exit 1 -fi -wait "$lock_interrupt_pid" -assert_no_test_proxy_processes - -lock_basic="$work/lock-basic" -cp -R "$root/rewatch-ocaml/tests/basic" "$lock_basic" -rm -rf "$lock_basic/lib" -rm -f "$lock_basic/src/A.mjs" "$lock_basic/src/B.mjs" \ - "$lock_basic/src/WithInterface.mjs" -first_marker="$lock_basic/first-child-started" -release_marker="$lock_basic/release-first-build" -REWATCH_OCAML_CHILD_STARTED="$(native_path "$first_marker")" \ -REWATCH_OCAML_RELEASE_FILE="$(native_path "$release_marker")" \ -REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ -REWATCH_BSC_PROXY_MODE=slow \ -RESCRIPT_BSC_EXE="$test_proxy" \ - "$port" build "$lock_basic" >"$lock_basic/first.log" 2>&1 & -first_build_pid=$! -background_pids="$background_pids $first_build_pid" -wait_for_file "$first_marker" -workspace_build_lock="$lock_basic/lib/build.lock" -test -f "$workspace_build_lock" -"$port" build "$lock_basic" >"$lock_basic/second.log" 2>&1 & -second_build_pid=$! -background_pids="$background_pids $second_build_pid" -wait_for_text "$lock_basic/second.log" "Waiting for other build to finish" -test ! -f "$lock_basic/src/A.mjs" -touch "$release_marker" -if ! wait "$first_build_pid"; then - cat "$lock_basic/first.log" >&2 - exit 1 -fi -if ! wait "$second_build_pid"; then - cat "$lock_basic/second.log" >&2 - exit 1 -fi -test -f "$lock_basic/src/A.mjs" -test ! -f "$workspace_build_lock" +# One large module keeps an in-process compile running for seconds. +second_interrupt="$work/second-interrupt" +mkdir -p "$second_interrupt/src" +printf '%s\n' '{"name":"second-interrupt","sources":"src","package-specs":{"module":"esmodule","in-source":true}}' \ + >"$second_interrupt/rescript.json" +awk 'BEGIN { for (i = 1; i <= 200000; i++) printf "let v%d = (%d, \"%d\")\n", i, i, i }' \ + >"$second_interrupt/src/Slow.res" + +# A second build waits for the first one's build lock and then runs. +"$port" -vv build "$second_interrupt" >"$second_interrupt/first.log" 2>&1 & +lock_first_pid=$! +background_pids="$background_pids $lock_first_pid" +# Logged when the parsed module is handed to the compiler. +if ! wait_for_text "$second_interrupt/first.log" 'compile dirty: Slow'; then + cat "$second_interrupt/first.log" >&2 + echo "large module did not reach the compiler" >&2 + exit 1 +fi +"$port" build "$second_interrupt" >"$second_interrupt/second.log" 2>&1 & +lock_second_pid=$! +background_pids="$background_pids $lock_second_pid" +wait_for_text "$second_interrupt/second.log" "Waiting for other build to finish" +test ! -f "$second_interrupt/src/Slow.js" +if ! wait "$lock_first_pid"; then + cat "$second_interrupt/first.log" >&2 + exit 1 +fi +if ! wait "$lock_second_pid"; then + cat "$second_interrupt/second.log" >&2 + exit 1 +fi +test -f "$second_interrupt/src/Slow.js" +test ! -f "$second_interrupt/lib/build.lock" + +# The first termination signal waits for modules compiling in-process; a +# second one exits at once and still releases the build lock. Exiting within +# two seconds rules out the graceful stop. The second signal has a different +# type because pending signals of one type are not queued. Threads may handle +# the two in either order, and the exit status is that of the second one +# handled. +if ! $windows_posix_shell; then + printf 'let dirty = 1\n' >>"$second_interrupt/src/Slow.res" + rm "$second_interrupt/src/Slow.js" + "$port" -vv build "$second_interrupt" >"$second_interrupt/build.log" 2>&1 & + second_interrupt_pid=$! + background_pids="$background_pids $second_interrupt_pid" + # Logged when the parsed module is handed to the compiler. + if ! wait_for_text "$second_interrupt/build.log" 'compile dirty: Slow'; then + cat "$second_interrupt/build.log" >&2 + echo "large module did not reach the compiler" >&2 + exit 1 + fi + kill -INT "$second_interrupt_pid" + kill -TERM "$second_interrupt_pid" + if ! wait_for_pid_gone "$second_interrupt_pid" 20; then + echo "a second signal did not stop an in-process compile" >&2 + exit 1 + fi + set +e + wait "$second_interrupt_pid" + second_interrupt_status=$? + set -e + case $second_interrupt_status in + 130 | 143) second_interrupt_status_ok=true ;; + *) second_interrupt_status_ok=false ;; + esac + if ! $second_interrupt_status_ok || \ + [ -e "$second_interrupt/lib/build.lock" ] || \ + [ -e "$second_interrupt/src/Slow.js" ]; then + cat "$second_interrupt/build.log" >&2 + echo "second signal: status $second_interrupt_status, expected 130 or 143 without a lock or output" >&2 + exit 1 + fi +fi # dep-union is requested with [web] by consumer, then with all features by # consumer's dev-dependency, then with [native] by the root. All features win @@ -2209,35 +1982,43 @@ fi "$port" build "$ppx_filter" test -f "$ppx_filter/src/Main.js" +# A failing PPX leaves no temporary AST files behind. +ppx_cleanup="$work/ppx-temp-cleanup" +mkdir -p "$ppx_cleanup/src" "$ppx_cleanup/tmp" +printf '{"name":"ppx-temp-cleanup","sources":"src","ppx-flags":["%s/missing-ppx"]}\n' \ + "$ppx_cleanup" >"$ppx_cleanup/rescript.json" +printf 'let value = 1\n' >"$ppx_cleanup/src/A.res" +if TMPDIR="$ppx_cleanup/tmp" TEMP="$ppx_cleanup/tmp" TMP="$ppx_cleanup/tmp" \ + "$port" build "$ppx_cleanup" >"$ppx_cleanup/build.log" 2>&1; then + echo "a build with a missing PPX succeeded" >&2 + exit 1 +fi +if ls "$ppx_cleanup/tmp" | grep -q '^ppx'; then + ls "$ppx_cleanup/tmp" >&2 + echo "a failing PPX left temporary files" >&2 + exit 1 +fi + "$port" build "$out_of_source" test -f "$out_of_source/lib/es6/src/Main.js" rm -f "$out_of_source/src/Main.res" "$port" build "$out_of_source" test ! -f "$out_of_source/lib/es6/src/Main.js" -namespace_call_log="$namespace/bsc-calls.log" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=counting \ - REWATCH_BSC_CALL_LOG="$(native_path "$namespace_call_log")" \ -"$port" build "$namespace" +namespace_call_log="$namespace/compiler-calls.log" +REWATCH_COMPILER_CALL_LOG="$(native_path "$namespace_call_log")" \ + "$port" build "$namespace" test -f "$namespace/lib/ocaml/A-Widget.cmi" test -f "$namespace/src/B.js" : > "$namespace_call_log" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=counting \ - REWATCH_BSC_CALL_LOG="$(native_path "$namespace_call_log")" \ +REWATCH_COMPILER_CALL_LOG="$(native_path "$namespace_call_log")" \ "$port" build "$namespace" if grep -F 'Widget.mlmap' "$namespace_call_log" >/dev/null; then echo "unchanged build unexpectedly recompiled its namespace" >&2 exit 1 fi printf '\nlet changed = 1\n' >> "$namespace/src/B.res" -env RESCRIPT_BSC_EXE="$test_proxy" \ - REWATCH_REAL_BSC="$RESCRIPT_BSC_EXE" \ - REWATCH_BSC_PROXY_MODE=counting \ - REWATCH_BSC_CALL_LOG="$(native_path "$namespace_call_log")" \ +REWATCH_COMPILER_CALL_LOG="$(native_path "$namespace_call_log")" \ "$port" build "$namespace" grep -F 'Widget.mlmap' "$namespace_call_log" >/dev/null diff --git a/rewatch-ocaml/toolchain.ml b/rewatch-ocaml/toolchain.ml index 750e9fe2026..1c386df9e24 100644 --- a/rewatch-ocaml/toolchain.ml +++ b/rewatch-ocaml/toolchain.ml @@ -17,7 +17,10 @@ let absolute_program ~cwd program = if Filename.is_relative resolved then Filename.concat cwd resolved else resolved -let sibling_bsc_candidate ~cwd ~executable = +(* Builds use the embedded compiler. The bsc.exe shipped next to the + executable is still recorded in compiler-info.json, where editor tooling + looks for bsc.exe and the other platform binaries. *) +let bundled_bsc ~cwd ~executable = let executable = absolute_program ~cwd executable in let executable = canonical_existing @@ -26,20 +29,6 @@ let sibling_bsc_candidate ~cwd ~executable = in Filename.concat (Filename.dirname executable) "bsc.exe" -let bsc () = - let candidate, message = - match Sys.getenv_opt "RESCRIPT_BSC_EXE" with - | Some path -> - (path, fun missing -> "RESCRIPT_BSC_EXE points to missing path " ^ missing) - | None -> - ( sibling_bsc_candidate ~cwd:(Sys.getcwd ()) - ~executable:Sys.executable_name, - fun missing -> - "Could not locate bsc next to the ReScript executable at " ^ missing - ^ "; set RESCRIPT_BSC_EXE to override it" ) - in - canonical_existing ~message candidate - let runtime ~find_package = match Sys.getenv_opt "RESCRIPT_RUNTIME" with | Some path -> diff --git a/rewatch-ocaml/toolchain.mli b/rewatch-ocaml/toolchain.mli index 3fc8a661719..a50c67e70b3 100644 --- a/rewatch-ocaml/toolchain.mli +++ b/rewatch-ocaml/toolchain.mli @@ -1,5 +1,4 @@ exception Error of string -val sibling_bsc_candidate : cwd:string -> executable:string -> string -val bsc : unit -> string +val bundled_bsc : cwd:string -> executable:string -> string val runtime : find_package:(string -> string option) -> string diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 30038cf3d1e..63994cde073 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -824,7 +824,7 @@ let test_list_constructor_wire_shape _ = Ast_helper.Str.value ~loc Nonrecursive [Ast_helper.Vb.mk ~loc pat expr]; ] in - ignore (Typemod.type_structure Env.initial_safe_string structure); + ignore (Typemod.type_structure (Env.initial_safe_string ()) structure); let printed = Res_printer.print_implementation structure ~comments:[] ~width:80 in @@ -1159,7 +1159,7 @@ let test_fresh_ast0_constructor_tuple_defers_arity_to_typechecker _ = [type_item; value_item; pattern_item] | _ -> assert_failure "Expected type declaration and two value bindings" in - ignore (Typemod.type_structure Env.initial_safe_string structure)) + ignore (Typemod.type_structure (Env.initial_safe_string ()) structure)) ["int, int"; "(int, int)"] let test_polyvariant_args_roundtrip_through_ast0 _ = diff --git a/tests/ounit_tests/ounit_constructor_arguments_tests.ml b/tests/ounit_tests/ounit_constructor_arguments_tests.ml index c08cfd907aa..1938fc9735c 100644 --- a/tests/ounit_tests/ounit_constructor_arguments_tests.ml +++ b/tests/ounit_tests/ounit_constructor_arguments_tests.ml @@ -179,7 +179,7 @@ let test_constructor_normalization_keeps_argument_locations _ = | _ -> assert_failure "Expected a constructor expression" in let typed, _, _ = - Typemod.type_structure Env.initial_safe_string parsed.parsetree + Typemod.type_structure (Env.initial_safe_string ()) parsed.parsetree in let pat, expr = match (Ext_list.last typed.str_items).str_desc with diff --git a/tests/ounit_tests/ounit_lambda_constant_tests.ml b/tests/ounit_tests/ounit_lambda_constant_tests.ml index b60cf16f95c..5265e5c6911 100644 --- a/tests/ounit_tests/ounit_lambda_constant_tests.ml +++ b/tests/ounit_tests/ounit_lambda_constant_tests.ml @@ -269,7 +269,7 @@ let suites = ] in let typed, _, _ = - Typemod.type_structure Env.initial_safe_string structure + Typemod.type_structure (Env.initial_safe_string ()) structure in let implementation = Translmod.transl_implementation "RegexpTest" diff --git a/tests/ounit_tests/ounit_object_mutability_tests.ml b/tests/ounit_tests/ounit_object_mutability_tests.ml index 7d97b038b6f..4eb88631081 100644 --- a/tests/ounit_tests/ounit_object_mutability_tests.ml +++ b/tests/ounit_tests/ounit_object_mutability_tests.ml @@ -12,7 +12,7 @@ let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let assert_bool = OUnit.assert_bool -let int_typ () = Predef.type_int +let int_typ () = Predef.type_int () let immutable_cell () = ref (Types.Mutability_value Asttypes.Immutable) let mutable_cell () = ref (Types.Mutability_value Asttypes.Mutable) @@ -236,7 +236,7 @@ let test_nondep_type_ends_its_copy_session _ = let test_nondep_nested_copy_preserves_class_sharing _ = let alias_id = Ident.create "m" in - let alias_decl = abstract_type_decl (Some Predef.type_int) in + let alias_decl = abstract_type_decl (Some (Predef.type_int ())) in let env = Env.add_type ~check:false alias_id alias_decl Env.empty in Ctype.begin_def (); let cell = immutable_cell () in diff --git a/tests/ounit_tests/ounit_pattern_printer_tests.ml b/tests/ounit_tests/ounit_pattern_printer_tests.ml index 9ee5e21ad97..31d868c1a63 100644 --- a/tests/ounit_tests/ounit_pattern_printer_tests.ml +++ b/tests/ounit_tests/ounit_pattern_printer_tests.ml @@ -35,7 +35,7 @@ let int_pattern n = { record_rest_pattern with Typedtree.pat_desc = Tpat_constant (Const_int n); - pat_type = Predef.type_int; + pat_type = Predef.type_int (); } let count_label = @@ -44,7 +44,7 @@ let count_label = Types.lbl_name = "count"; lbl_runtime_name = "count"; lbl_res = record_type; - lbl_arg = Predef.type_int; + lbl_arg = Predef.type_int (); lbl_mut = Asttypes.Immutable; lbl_optional = false; lbl_pos = 0; @@ -81,7 +81,7 @@ let dummy_expr = Typedtree.exp_desc = Texp_constant (Const_int 0); exp_loc = loc; exp_extra = []; - exp_type = Predef.type_int; + exp_type = Predef.type_int (); exp_env = Env.empty; exp_attributes = []; } diff --git a/tests/ounit_tests/ounit_rec_check_tests.ml b/tests/ounit_tests/ounit_rec_check_tests.ml index ef2fbfa88e1..6f2f7474921 100644 --- a/tests/ounit_tests/ounit_rec_check_tests.ml +++ b/tests/ounit_tests/ounit_rec_check_tests.ml @@ -1,7 +1,7 @@ let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let loc = Location.none -let typ = Predef.type_unit +let typ = Predef.type_unit () let val_desc = {Types.val_type = typ; val_kind = Val_reg; val_loc = loc; val_attributes = []} diff --git a/tests/ounit_tests/ounit_string_literal_tests.ml b/tests/ounit_tests/ounit_string_literal_tests.ml index 20381fdddd0..2aa1f5fde08 100644 --- a/tests/ounit_tests/ounit_string_literal_tests.ml +++ b/tests/ounit_tests/ounit_string_literal_tests.ml @@ -291,8 +291,9 @@ let assert_typed_template ~source_segments ~expected_semantics = Ast_helper.Exp.template (List.map located_string source_segments) [value] in let typed = - Typecore.type_exp Env.initial_safe_string expression - ~context:(Some Error_message_utils.StringConcat) + Typecore.type_exp + (Env.initial_safe_string ()) + expression ~context:(Some Error_message_utils.StringConcat) in begin match typed.exp_desc with | Texp_template @@ -455,7 +456,9 @@ let suites = Ast_helper.Exp.template [located_string "literal"] [] in let typed = - Typecore.type_exp Env.initial_safe_string expression ~context:None + Typecore.type_exp + (Env.initial_safe_string ()) + expression ~context:None in OUnit.assert_bool "an interpolation-free template should generalize like a string \ diff --git a/tests/ounit_tests/ounit_typeopt_tests.ml b/tests/ounit_tests/ounit_typeopt_tests.ml index c451490a724..a199666d05a 100644 --- a/tests/ounit_tests/ounit_typeopt_tests.ml +++ b/tests/ounit_tests/ounit_typeopt_tests.ml @@ -13,6 +13,6 @@ let suites = (Typeopt.type_cannot_contain_undefined typ Env.empty) ); ( "builtin integers still omit option wrapping" >:: fun _ -> OUnit.assert_equal true - (Typeopt.type_cannot_contain_undefined Predef.type_int Env.empty) - ); + (Typeopt.type_cannot_contain_undefined (Predef.type_int ()) + Env.empty) ); ] diff --git a/tests/rewatch_ounit_tests/build_artifacts_tests.ml b/tests/rewatch_ounit_tests/build_artifacts_tests.ml index a20d37165f1..48ab9990066 100644 --- a/tests/rewatch_ounit_tests/build_artifacts_tests.ml +++ b/tests/rewatch_ounit_tests/build_artifacts_tests.ml @@ -133,8 +133,8 @@ let tests = write_file config_path {|{"name":"moved-source","sources":{"dir":"src","subdirs":true}}|}; write_file new_source "let value = 1"; - write_file published_ast - ("Caml1999X\nDependency\n" ^ old_source ^ "\nbinary payload"); + Test_support.write_ast_header published_ast ~dependencies:["Dependency"] + ~source:old_source; write_file working_ast "old working AST"; let config = Config.load_root root in let module_ : Source.module_ = diff --git a/tests/rewatch_ounit_tests/build_attempt_tests.ml b/tests/rewatch_ounit_tests/build_attempt_tests.ml index ca21e60c291..1d739752026 100644 --- a/tests/rewatch_ounit_tests/build_attempt_tests.ml +++ b/tests/rewatch_ounit_tests/build_attempt_tests.ml @@ -53,7 +53,7 @@ let pending_work_is_drained_once _context = Process.{program = "unused"; args = []; cwd = Sys.getcwd ()} in Build_attempt.add_namespace_job attempt - Build_attempt.{job = process_job; finish = ignore}; + Build_attempt.{task = Process.task process_job; finish = ignore}; let build_state = Build_state.create 1 in Build_state.add build_state ~key:"A" ~kind:Build_state.Source_module ~last_compiled_cmi:None ~last_compiled_cmt:None; diff --git a/tests/rewatch_ounit_tests/compile_assets_tests.ml b/tests/rewatch_ounit_tests/compile_assets_tests.ml index cb2c1e3f9b9..075ce81a77e 100644 --- a/tests/rewatch_ounit_tests/compile_assets_tests.ml +++ b/tests/rewatch_ounit_tests/compile_assets_tests.ml @@ -8,6 +8,18 @@ let write path contents = ~finally:(fun () -> close_out_noerr channel) (fun () -> output_string channel contents) +let write_ast path ~dependencies ~source = + let channel = open_out_bin path in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> + let dependency_block = "\n" ^ String.concat "\n" dependencies ^ "\n" in + output_binary_int channel (String.length dependency_block); + output_string channel dependency_block; + output_string channel source; + output_char channel '\n'; + output_value channel "Belt_HashSet\nBelt\n") + let with_temp_dir = Test_support.with_temp_dir "rewatch-compile-assets-" let tests = @@ -24,19 +36,38 @@ let tests = write second "cmt"; write unrelated "notes"; write cleanup_only "cmj"; - write ast ("Caml1999X\nDependency\n" ^ source ^ "\nbinary payload"); + write_ast ast ~dependencies:["Dependency"] ~source; + let relative_ast = Filename.concat root "Relative.iast" in + write_ast relative_ast ~dependencies:["Belt_Id"] + ~source:"../../src/Relative.resi"; + let relative_header = Ast_header.read relative_ast in + check + (relative_header.dependencies = ["Belt_Id"] + && relative_header.source = Some "../../src/Relative.resi") + "relative source paths terminate the dependency header before the AST"; Unix.mkdir nested 0o755; write (Filename.concat nested "Nested.cmi") "nested"; let state = Compile_assets.create [root; root] in check (Compile_assets.files state root |> List.sort String.compare - = List.sort String.compare [ast; cleanup_only; first; second]) + = List.sort String.compare + [ast; relative_ast; cleanup_only; first; second]) "the flat cleanup inventory retains only managed compiler assets"; check - (Compile_assets.ast_sources state root - = [{Compile_assets.ast_path = ast; source_path = source}]) - "published ASTs retain their encoded absolute source location"; + (List.sort + (fun first second -> + String.compare first.Compile_assets.ast_path + second.Compile_assets.ast_path) + (Compile_assets.ast_sources state root) + = [ + {Compile_assets.ast_path = ast; source_path = source}; + { + Compile_assets.ast_path = relative_ast; + source_path = "../../src/Relative.resi"; + }; + ]) + "published ASTs retain absolute and relative source locations"; check (Compile_assets.ast state source |> Option.map (fun entry -> entry.Compile_assets.path) diff --git a/tests/rewatch_ounit_tests/compiler_driver_tests.ml b/tests/rewatch_ounit_tests/compiler_driver_tests.ml new file mode 100644 index 00000000000..6c201a1419a --- /dev/null +++ b/tests/rewatch_ounit_tests/compiler_driver_tests.ml @@ -0,0 +1,1364 @@ +open OUnit2 + +let check condition message = assert_bool message condition + +let request_local_counter = Request_local.new_key (fun () -> ref 0) + +(* A request sees fresh request-local state and leaves the previous state in + place afterwards, also when it fails. *) +let request_local_tests _context = + let counter () = Request_local.get request_local_counter in + counter () := 5; + Request_local.with_fresh (fun () -> + assert_equal 0 !(counter ()); + counter () := 7); + assert_equal 5 !(counter ()); + (try + Request_local.with_fresh (fun () -> + counter () := 9; + failwith "request failed") + with Failure _ -> ()); + assert_equal 5 !(counter ()) + +let ctype_level_isolation_tests _context = + let original = Ctype.save_levels () in + Fun.protect + ~finally:(fun () -> Ctype.set_levels original) + (fun () -> + Ctype.init_def 4; + Ctype.begin_def (); + let child = + Domain.spawn (fun () -> + Ctype.init_def 20; + Ctype.begin_def (); + Ctype.end_def (); + Ctype.get_current_level ()) + in + assert_equal 20 (Domain.join child); + assert_equal 5 (Ctype.get_current_level ()); + Ctype.end_def (); + assert_equal 4 (Ctype.get_current_level ())) + +(* Js_shake keeps a toplevel binding only when the free variables of a live + statement mention it. Free variables computed on two domains at once must + not mix, or a used function definition is dropped from the output. *) +let free_variable_isolation_tests _context = + let free_variables name = + let ident = Ident.create name in + let expression = + Js_exp_make.array (List.init 64 (fun _ -> Js_exp_make.var ident)) + in + Domain.spawn (fun () -> + let rec loop remaining = + remaining = 0 + || Set_ident.elements + (Js_analyzer.free_variables_of_expression expression) + = [ident] + && loop (remaining - 1) + in + loop 20_000) + in + let left = free_variables "left" in + let right = free_variables "right" in + check (Domain.join left) "free variables of the left domain are its own"; + check (Domain.join right) "free variables of the right domain are its own" + +let shared_type_graph_isolation_tests _context = + let host_type = Predef.type_int () in + let host_env = Env.initial_safe_string () in + let child_type, child_env = + Domain.spawn (fun () -> (Predef.type_int (), Env.initial_safe_string ())) + |> Domain.join + in + check (host_type != child_type) "predefined type graphs belong to a domain"; + check (host_env != child_env) "initial environments belong to a domain" + +let dependency_extraction_isolation_tests _context = + let module Set = Depend.String_set in + let wait flag = + let deadline = Unix.gettimeofday () +. 5. in + while (not (Atomic.get flag)) && Unix.gettimeofday () < deadline do + Domain.cpu_relax () + done; + check (Atomic.get flag) "dependency extraction test timed out" + in + Depend.free_structure_names () := Set.singleton "Host"; + let child_ready = Atomic.make false in + let host_ready = Atomic.make false in + let child = + Domain.spawn (fun () -> + Depend.free_structure_names () := Set.singleton "Child"; + Atomic.set child_ready true; + wait host_ready; + !(Depend.free_structure_names ())) + in + wait child_ready; + let host_dependencies = !(Depend.free_structure_names ()) in + Atomic.set host_ready true; + let child_dependencies = Domain.join child in + assert_equal (Set.singleton "Host") host_dependencies; + assert_equal (Set.singleton "Child") child_dependencies + +let gentype_output_capture_tests _context = + let (), stdout, stderr = + Compiler_request_output.with_capture (fun () -> + Log_.Color.setup (); + Log_.info ~loc:Location.none ~name:"Warning genType" (fun ppf () -> + Stdlib.Format.fprintf ppf "captured warning")) + in + check + (String_util.contains stdout "captured warning") + "GenType warnings use the request-owned stdout formatter"; + assert_equal "" stderr + +(* Output written before an exception escapes a request is not lost. *) +let failed_capture_tests _context = + match + Compiler_request_output.with_capture (fun () -> + Compiler_request_output.write_stderr "earlier warning"; + failwith "request failed") + with + | _ -> assert_failure "the failure must propagate" + | exception Compiler_request_output.Failed {error; stdout; stderr} -> + assert_equal (Failure "request failed") error; + assert_equal "" stdout; + assert_equal ~printer:Fun.id "earlier warning" stderr; + check + (not (Compiler_request_output.is_active ())) + "the previous streams are restored" + +(* GenType finds a module's source relative to the request's working + directory, not the host process's. *) +let gentype_source_lookup_tests _context = + Test_support.with_temp_dir "rewatch-driver-gentype-source-" (fun root -> + Test_support.write_file (Filename.concat root "src/A.res") "let a = 1\n"; + let position = {Lexing.dummy_pos with pos_fname = "src/A.res"} in + let item : Typedtree.structure_item = + { + str_desc = + Tstr_attribute (Location.mknoloc "attribute", Parsetree.PStr []); + str_loc = {Location.none with loc_start = position}; + str_env = Env.empty; + } + in + let found = + Compiler_request_state.with_fresh ~cwd:root (fun () -> + Find_source_file.cmt + (Cmt_format.Implementation + {str_items = [item]; str_type = []; str_final_env = Env.empty})) + in + assert_equal + ~printer:(Option.value ~default:"None") + (Some (Filename.concat root "src/A.res")) + found) + +let used_attributes_isolation_tests _context = + let loc = {Location.none with loc_ghost = false} in + let name = Asttypes.{txt = "as"; loc} in + let attribute = (name, Parsetree.PStr []) in + Used_attributes.mark_used_attribute attribute; + let child_before, child_after = + Domain.spawn (fun () -> + let before = Used_attributes.is_used_attribute name in + Used_attributes.mark_used_attribute attribute; + (before, Used_attributes.is_used_attribute name)) + |> Domain.join + in + check ((not child_before) && child_after) "used attributes are domain local"; + check + (Used_attributes.is_used_attribute name) + "another domain does not clear the caller's used attributes" + +let delayed_checks_isolation_tests _context = + Delayed_checks.reset_delayed_checks (); + let host_runs = ref 0 in + Delayed_checks.add_delayed_check (fun () -> incr host_runs); + let child_runs = + Domain.spawn (fun () -> + let runs = ref 0 in + Delayed_checks.reset_delayed_checks (); + Delayed_checks.add_delayed_check (fun () -> incr runs); + Delayed_checks.force_delayed_checks (); + !runs) + |> Domain.join + in + assert_equal 1 child_runs; + assert_equal 0 !host_runs; + Delayed_checks.force_delayed_checks (); + assert_equal 1 !host_runs + +let gentype_flags_isolation_tests _context = + Request_local.with_fresh (fun () -> + Gentype_config.add_source_dir "host-source"; + let child_sources = + Domain.spawn (fun () -> + Gentype_config.add_source_dir "child-source"; + !(Gentype_config.source_dirs_flag ())) + |> Domain.join + in + assert_equal ["child-source"] child_sources; + assert_equal ["host-source"] !(Gentype_config.source_dirs_flag ())) + +let diagnostic_state_isolation_tests _context = + Request_local.with_fresh (fun () -> + Error_message_utils.configured_jsx_module () := Some "HostJsx"; + Debug.set_item "basic"; + let first = Ctype.newvar () in + let second = Ctype.newvar () in + let first_text = Stdlib.Format.asprintf "%a" Printtyp.type_expr first in + let child_jsx, child_debug, child_type = + Domain.spawn (fun () -> + let initial_jsx = !(Error_message_utils.configured_jsx_module ()) in + Error_message_utils.configured_jsx_module () := Some "ChildJsx"; + Debug.set_item "translation"; + ( initial_jsx, + (!(Debug.basic ()), !(Debug.translation ())), + Stdlib.Format.asprintf "%a" Printtyp.type_expr (Ctype.newvar ()) + )) + |> Domain.join + in + let second_text = Stdlib.Format.asprintf "%a" Printtyp.type_expr second in + assert_equal None child_jsx; + assert_equal (false, true) child_debug; + assert_equal (Some "HostJsx") + !(Error_message_utils.configured_jsx_module ()); + check + (!(Debug.basic ()) && not !(Debug.translation ())) + "GenType debug flags remain with their request domain"; + check + (first_text <> second_text) + "type variable names survive another domain's diagnostic reset"; + check (child_type = first_text) + "a child domain starts its own type-printing names") + +let wait_for_atomic flag = + let deadline = Unix.gettimeofday () +. 5. in + while (not (Atomic.get flag)) && Unix.gettimeofday () < deadline do + Domain.cpu_relax () + done; + check (Atomic.get flag) "concurrent test domain did not reach its checkpoint" + +let warning_and_feature_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let left = + Domain.spawn (fun () -> + Request_local.with_fresh (fun () -> + Request_local.with_fresh (fun () -> + Warnings.parse_options false "-8"; + Experimental_features.enable_from_string "LetUnwrap"; + Atomic.set left_ready true; + wait_for_atomic right_ready; + ( Warnings.is_active (Warnings.Partial_match ""), + Experimental_features.is_enabled + Experimental_features.LetUnwrap )))) + in + let right = + Domain.spawn (fun () -> + Request_local.with_fresh (fun () -> + Request_local.with_fresh (fun () -> + wait_for_atomic left_ready; + Warnings.parse_options false "+8"; + Atomic.set right_ready true; + ( Warnings.is_active (Warnings.Partial_match ""), + Experimental_features.is_enabled + Experimental_features.LetUnwrap )))) + in + assert_equal (false, true) (Domain.join left); + assert_equal (true, false) (Domain.join right); + check + (not (Experimental_features.is_enabled Experimental_features.LetUnwrap)) + "feature scope leaves host domain unchanged" + +let js_config_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let left = + Domain.spawn (fun () -> + Request_local.with_fresh (fun () -> + let config = Js_config.current () in + config.jsx_module := Js_config.Generic {module_name = "Left"}; + config.source_map := Js_config.Linked; + Stack.push "left" config.self_stack; + Atomic.set left_ready true; + wait_for_atomic right_ready; + ( !(config.jsx_module), + !(config.source_map), + Stack.top config.self_stack ))) + in + let right = + Domain.spawn (fun () -> + Request_local.with_fresh (fun () -> + wait_for_atomic left_ready; + let config = Js_config.current () in + config.jsx_module := Js_config.Generic {module_name = "Right"}; + config.source_map := Js_config.Inline; + Stack.push "right" config.self_stack; + Atomic.set right_ready true; + ( !(config.jsx_module), + !(config.source_map), + Stack.top config.self_stack ))) + in + assert_equal + (Js_config.Generic {module_name = "Left"}, Js_config.Linked, "left") + (Domain.join left); + assert_equal + (Js_config.Generic {module_name = "Right"}, Js_config.Inline, "right") + (Domain.join right); + let outer = Js_config.current () in + Request_local.with_fresh (fun () -> + let nested = Js_config.current () in + nested.source_map := Js_config.Hidden; + Stack.push "nested" nested.self_stack); + check + (outer == Js_config.current ()) + "nested scope restores host configuration"; + check (Stack.is_empty outer.self_stack) "nested scope restores host stack" + +let clflags_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let left = + Domain.spawn (fun () -> + Request_local.with_fresh (fun () -> + Clflags.reset (); + let flags = Clflags.current () in + flags.include_dirs := ["left"]; + flags.color := Some Misc.Color.Never; + Atomic.set left_ready true; + wait_for_atomic right_ready; + ( !(flags.include_dirs), + !(flags.color), + !(flags.debug), + !(flags.binary_annotations) ))) + in + let right = + Domain.spawn (fun () -> + Request_local.with_fresh (fun () -> + wait_for_atomic left_ready; + Clflags.reset (); + let flags = Clflags.current () in + flags.include_dirs := ["right"]; + flags.color := Some Misc.Color.Auto; + Atomic.set right_ready true; + ( !(flags.include_dirs), + !(flags.color), + !(flags.debug), + !(flags.binary_annotations) ))) + in + assert_equal (["left"], Some Misc.Color.Never, true, true) (Domain.join left); + assert_equal (["right"], Some Misc.Color.Auto, true, true) (Domain.join right); + check + (!((Clflags.current ()).include_dirs) = []) + "flag scopes leave host domain unchanged" + +let env_cache_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let run unit_name ready other_ready = + Domain.spawn (fun () -> + Request_local.with_fresh (fun () -> + Env.set_unit_name unit_name; + Env.add_import unit_name; + Consistbl.set (Env.crc_units ()) unit_name (Digest.string unit_name) + unit_name; + Atomic.set ready true; + wait_for_atomic other_ready; + (Env.get_unit_name (), Env.imports ()))) + in + let left = run "Left" left_ready right_ready in + let right = run "Right" right_ready left_ready in + assert_equal + ("Left", [("Left", Some (Digest.string "Left"))]) + (Domain.join left); + assert_equal + ("Right", [("Right", Some (Digest.string "Right"))]) + (Domain.join right); + assert_equal "" (Env.get_unit_name ()) + +let identifier_stamp_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let starting_time = Ident.current_time () in + let run ready other_ready = + Domain.spawn (fun () -> + Ident.with_fresh (fun () -> + let first = Ident.binding_time (Ident.create "local") in + Atomic.set ready true; + wait_for_atomic other_ready; + let second = Ident.binding_time (Ident.create "local") in + (first, second))) + in + let left = run left_ready right_ready in + let right = run right_ready left_ready in + let left_first, left_second = Domain.join left in + let right_first, right_second = Domain.join right in + assert_equal (left_first + 1) left_second; + assert_equal (right_first + 1) right_second; + assert_equal left_first right_first; + assert_equal starting_time (Ident.current_time ()) + +let output_capture_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 () -> + Compiler_request_output.with_capture (fun () -> + Compiler_request_output.write_stdout (label ^ "\000"); + Atomic.set ready true; + wait_for_atomic other_ready; + let formatter = Compiler_request_output.stderr_formatter () in + Stdlib.Format.pp_print_string formatter label; + Stdlib.Format.pp_print_newline formatter (); + label)) + in + let left = capture "left" left_ready right_ready in + let right = capture "right" right_ready left_ready in + (* Captured output is in text mode, as a bsc process's would be. *) + let newline = if Sys.win32 then "\r\n" else "\n" in + assert_equal ("left", "left\000", "left" ^ newline) (Domain.join left); + assert_equal ("right", "right\000", "right" ^ newline) (Domain.join right); + check + (Compiler_request_output.stdout_channel () == Stdlib.stdout) + "capture scopes restore the host stream" + +let backend_module_cache_isolation_tests _context = + let left_ready = Atomic.make false in + let right_done = Atomic.make false in + let add_module () = + Lam_compile_env.add_js_module External_ffi_types.Phint_nothing + "shared-backend-module" false ~dynamic_import:false + in + let left = + Domain.spawn (fun () -> + Request_local.with_fresh (fun () -> + let first = add_module () in + Atomic.set left_ready true; + wait_for_atomic right_done; + first == add_module ())) + in + let right = + Domain.spawn (fun () -> + wait_for_atomic left_ready; + Request_local.with_fresh (fun () -> + Lam_compile_env.reset (); + ignore (add_module ()); + Atomic.set right_done true)) + in + Domain.join right; + check (Domain.join left) "another request cleared this module cache" + +let command_runner_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let left_done = Atomic.make false in + let left = + Domain.spawn (fun () -> + Ccomp.with_command_runner + (fun _ -> 11) + (fun () -> + Atomic.set left_ready true; + wait_for_atomic right_ready; + let result = Ccomp.command "left" in + Atomic.set left_done true; + result)) + in + let right = + Domain.spawn (fun () -> + wait_for_atomic left_ready; + Ccomp.with_command_runner + (fun _ -> 22) + (fun () -> + Atomic.set right_ready true; + wait_for_atomic left_done; + Ccomp.command "right")) + in + assert_equal 11 (Domain.join left); + assert_equal 22 (Domain.join right) + +let input_name_isolation_tests _context = + let process_cwd = Sys.getcwd () in + let first_root = Filename.concat process_cwd "first" in + let second_root = Filename.concat process_cwd "second" in + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let left = + Domain.spawn (fun () -> + Compiler_request_state.with_fresh ~cwd:first_root (fun () -> + Location.set_input_name "First.res"; + Atomic.set left_ready true; + wait_for_atomic right_ready; + (Location.get_input_name (), Ext_path.absolute_cwd_path "First.res"))) + in + let right = + Domain.spawn (fun () -> + Compiler_request_state.with_fresh ~cwd:second_root (fun () -> + wait_for_atomic left_ready; + Location.set_input_name "Second.res"; + Atomic.set right_ready true; + (Location.get_input_name (), Ext_path.absolute_cwd_path "Second.res"))) + in + assert_equal + ("First.res", Filename.concat first_root "First.res") + (Domain.join left); + assert_equal + ("Second.res", Filename.concat second_root "Second.res") + (Domain.join right); + assert_equal "_none_" (Location.get_input_name ()); + assert_equal process_cwd (Sys.getcwd ()) + +let request_root_io_isolation_tests _context = + Test_support.with_temp_dir "rewatch-request-root-io-" (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; + Test_support.write_file (Filename.concat first "Input.res") "first"; + Test_support.write_file (Filename.concat second "Input.res") "second"; + let start = Atomic.make false in + let access cwd = + Domain.spawn (fun () -> + Compiler_request_state.with_fresh ~cwd (fun () -> + wait_for_atomic start; + let rescript_source = + (Res_driver.parsing_engine.parse_implementation + ~filename:"Input.res") + .source + in + let compiler_source = Ext_io.load_file "Input.res" in + Ext_io.write_file "Output.txt" rescript_source; + (rescript_source, compiler_source))) + in + let left = access first in + let right = access second in + Atomic.set start true; + assert_equal ("first", "first") (Domain.join left); + assert_equal ("second", "second") (Domain.join right); + assert_equal "first" + (File_util.read_file (Filename.concat first "Output.txt")); + assert_equal "second" + (File_util.read_file (Filename.concat second "Output.txt"))) + +let saved_part = + Cmt_format.Partial_signature + {sig_items = []; sig_type = []; sig_final_env = Env.empty} + +let cmt_accumulator_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let left = + Domain.spawn (fun () -> + Cmt_format.clear (); + Cmt_format.set_args [|"bsc"; "First.res"|]; + Cmt_format.add_saved_type saved_part; + Atomic.set left_ready true; + wait_for_atomic right_ready; + ( List.length (Cmt_format.get_saved_types ()), + (Compiler_request_state.current ()).cmt_args )) + in + let right = + Domain.spawn (fun () -> + wait_for_atomic left_ready; + Cmt_format.clear (); + Cmt_format.set_args [|"bsc"; "Second.res"|]; + Cmt_format.add_saved_type saved_part; + Cmt_format.add_saved_type saved_part; + Atomic.set right_ready true; + ( List.length (Cmt_format.get_saved_types ()), + (Compiler_request_state.current ()).cmt_args )) + in + assert_equal (1, [|"bsc"; "First.res"|]) (Domain.join left); + assert_equal (2, [|"bsc"; "Second.res"|]) (Domain.join right) + +let package_output_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let configure name output = + Js_packages_state.set_package_name name; + Js_packages_state.update_npm_package_path output; + match + Js_packages_info.query_package_infos + (Js_packages_state.get_packages_info ()) + Ext_module_system.Commonjs + with + | Js_packages_info.Package_found {rel_path; pkg_rel_path; suffix} -> + (rel_path, pkg_rel_path, suffix) + | Js_packages_info.Package_script | Js_packages_info.Package_not_found -> + assert_failure "missing output spec" + in + let left = + Domain.spawn (fun () -> + Request_local.with_fresh (fun () -> + let output = configure "first-package" "commonjs:lib/first:.js" in + Atomic.set left_ready true; + wait_for_atomic right_ready; + output)) + in + let right = + Domain.spawn (fun () -> + Request_local.with_fresh (fun () -> + wait_for_atomic left_ready; + let output = + configure "second-package" "commonjs:lib/second:.mjs" + in + Atomic.set right_ready true; + output)) + in + assert_equal + ("lib/first", Filename.concat "first-package" "lib/first", ".js") + (Domain.join left); + assert_equal + ("lib/second", Filename.concat "second-package" "lib/second", ".mjs") + (Domain.join right); + check + (Js_packages_info.is_empty (Js_packages_state.get_packages_info ())) + "domain package scopes leave host state unchanged" + +let path_configuration_isolation_tests _context = + let first_root = Filename.concat (Sys.getcwd ()) "first" in + let second_root = Filename.concat (Sys.getcwd ()) "second" in + let initial_runtime = Runtime_package.get_path () in + let initial_root = Ext_path.get_project_root () in + let initial_load_path = (Compiler_request_state.current ()).load_path in + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let configure root = + Runtime_package.set_path (Filename.concat root "runtime"); + Ext_path.set_project_root root; + (Compiler_request_state.current ()).load_path <- + [Filename.concat root "ocaml"]; + ( Runtime_package.get_path (), + Ext_path.package_dir (), + (Compiler_request_state.current ()).load_path ) + in + let left = + Domain.spawn (fun () -> + Compiler_request_state.with_fresh (fun () -> + let paths = configure first_root in + Atomic.set left_ready true; + wait_for_atomic right_ready; + paths)) + in + let right = + Domain.spawn (fun () -> + Compiler_request_state.with_fresh (fun () -> + wait_for_atomic left_ready; + let paths = configure second_root in + Atomic.set right_ready true; + paths)) + in + assert_equal + ( Filename.concat first_root "runtime", + first_root, + [Filename.concat first_root "ocaml"] ) + (Domain.join left); + assert_equal + ( Filename.concat second_root "runtime", + second_root, + [Filename.concat second_root "ocaml"] ) + (Domain.join right); + assert_equal initial_runtime (Runtime_package.get_path ()); + assert_equal initial_root (Ext_path.get_project_root ()); + assert_equal initial_load_path (Compiler_request_state.current ()).load_path + +let lambda_exit_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let left = + Domain.spawn (fun () -> + Compiler_request_state.with_fresh (fun () -> + let first = Lambda_exits.next_raise_count () in + Atomic.set left_ready true; + wait_for_atomic right_ready; + ( first, + Lambda_exits.next_raise_count (), + Lambda_exits.next_negative_raise_count () ))) + in + let right = + Domain.spawn (fun () -> + Compiler_request_state.with_fresh (fun () -> + wait_for_atomic left_ready; + let first = Lambda_exits.next_raise_count () in + let second = Lambda_exits.next_raise_count () in + Atomic.set right_ready true; + (first, second, Lambda_exits.next_negative_raise_count ()))) + in + assert_equal (1, 2, -1) (Domain.join left); + assert_equal (1, 2, -1) (Domain.join right) + +let type_node_id_isolation_tests _context = + let left_ready = Atomic.make false in + let right_ready = Atomic.make false in + let left_done = Atomic.make false in + let left = + Domain.spawn (fun () -> + Compiler_request_state.with_fresh (fun () -> + Request_local.with_fresh (fun () -> + Btype.reinit (); + let ty = Btype.newgenvar () in + let first = ty.Types.id in + let snapshot = Btype.snapshot () in + Btype.set_level ty 3; + Atomic.set left_ready true; + wait_for_atomic right_ready; + Btype.backtrack snapshot; + Atomic.set left_done true; + (first, (Btype.newgenvar ()).Types.id, ty.Types.level)))) + in + let right = + Domain.spawn (fun () -> + Compiler_request_state.with_fresh (fun () -> + Request_local.with_fresh (fun () -> + wait_for_atomic left_ready; + Btype.reinit (); + let ty = Btype.newgenvar () in + let first = ty.Types.id in + let snapshot = Btype.snapshot () in + Btype.set_level ty 7; + let second = (Btype.newgenvar ()).Types.id in + Atomic.set right_ready true; + wait_for_atomic left_done; + Btype.backtrack snapshot; + (first, second, ty.Types.level)))) + in + assert_equal (0, 1, Btype.generic_level) (Domain.join left); + assert_equal (0, 1, Btype.generic_level) (Domain.join right) + +let write root name contents = + Test_support.write_file (Filename.concat root name) contents + +let run root ?(package = "driver-test") ?(extra = []) input = + let argv = + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + root; + "-bs-package-name"; + package; + "-bs-package-output"; + "commonjs:.:.js"; + "-bs-no-version-header"; + ] + @ extra + in + ( argv, + Rescript_compiler_driver.run_request ~run_external:None ~cwd:root ~argv + ~input ) + +let expect_code expected result = + assert_equal ~printer:string_of_int expected + result.Rescript_compiler_driver.exit_code + +(* The standalone bsc writes to its own stdout and stderr as it goes, without + capturing output in temporary files: it compiles even when it can't create + any. *) +let standalone_output_tests _context = + Test_support.with_temp_dir "rewatch-driver-standalone-" (fun root -> + let temp = Filename.concat root "tmp" in + Unix.mkdir temp 0o555; + write root "Plain.res" "let plain = 1\n"; + let previous_temp = Filename.get_temp_dir_name () in + Filename.set_temp_dir_name temp; + let exit_code = + Fun.protect + ~finally:(fun () -> + Filename.set_temp_dir_name previous_temp; + Unix.chmod temp 0o755) + (fun () -> + Rescript_compiler_driver.run + [| + "bsc"; + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + root; + "-bs-package-name"; + "driver-test"; + "-bs-package-output"; + "commonjs:.:.js"; + "-bs-no-version-header"; + Filename.concat root "Plain.res"; + |]) + in + assert_equal ~printer:string_of_int 0 exit_code) + +let recovery_tests _context = + Test_support.with_temp_dir "rewatch-driver-recovery-" (fun root -> + write root "Parse.res" "let value = 1\n"; + let _, initial = run root "Parse.res" in + expect_code 0 initial; + write root "Parse.res" "let value =\n"; + let _, failed = run root "Parse.res" in + expect_code 1 failed; + check + (Test_support.contains_text failed.stderr "Syntax error") + "parse diagnostics are returned to the host"; + write root "Parse.res" "let value = 2\n"; + let _, repaired = run root "Parse.res" in + expect_code 0 repaired; + write root "Typed.res" "let value: string = 1\n"; + let _, failed = run root "Typed.res" in + expect_code 2 failed; + check + (Test_support.contains_text failed.stderr "int" + && Test_support.contains_text failed.stderr "string") + "type diagnostics are returned to the host"; + write root "Typed.res" {|let value: string = "repaired"|}; + let _, repaired = run root "Typed.res" in + expect_code 0 repaired) + +let ppx_recovery_tests _context = + Test_support.with_temp_dir "rewatch-driver-ppx-" (fun root -> + write root "Ppx.res" "let value = 1\n"; + let argv = + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + root; + "-bs-package-name"; + "driver-test"; + "-bs-package-output"; + "commonjs:.:.js"; + "-ppx"; + "rewatch-test-ppx"; + "-verbose"; + ] + in + let failed = + Rescript_compiler_driver.run_request ~cwd:root ~argv ~input:"Ppx.res" + ~run_external:(Some (fun _ -> (7, "", "intentional PPX failure\n"))) + in + expect_code 2 failed; + check + (Test_support.contains_text failed.stderr "intentional PPX failure") + "PPX failure diagnostics are returned through the host boundary"; + let repaired = + Rescript_compiler_driver.run_request ~cwd:root ~argv ~input:"Ppx.res" + ~run_external: + (Some + (fun command -> + let quote = + if String.contains command '\'' then '\'' else '"' + in + match String.split_on_char quote command with + | _program :: input :: _separator :: output :: _ -> + File_util.copy_existing_file input output; + (0, "", "") + | _ -> (2, "", "could not decode test PPX command"))) + in + expect_code 0 repaired; + check + (Test_support.contains_text repaired.stderr "+ rewatch-test-ppx") + "direct verbose output is returned through the request boundary") + +let control_flow_and_output_tests _context = + Test_support.with_temp_dir "rewatch-driver-control-" (fun root -> + let process_cwd = Sys.getcwd () in + write root "Good.res" "let value = 1\n"; + write root "Broken.res" "let value =\n"; + let request argv input = + Rescript_compiler_driver.run_request ~run_external:None ~cwd:root ~argv + ~input + in + let version = request ["-version"] "Good.res" in + expect_code 0 version; + check + (Test_support.contains_text version.stdout "ReScript") + "version output is captured without terminating the host"; + let help = request ["-help"] "Good.res" in + expect_code 0 help; + check + (Test_support.contains_text help.stdout "Usage: bsc") + "help output is captured without terminating the host"; + let reprint = request ["-reprint-source"; "Broken.res"] "Good.res" in + expect_code 1 reprint; + check + (Test_support.contains_text reprint.stderr "Syntax error") + "reprint parse failures return diagnostics instead of exiting"; + let format = request ["-format"; "Broken.res"] "Good.res" in + expect_code 1 format; + check + (Test_support.contains_text format.stderr "Syntax error") + "format parse failures return diagnostics instead of exiting"; + let stdout_compile = + request + ["-nostdlib"; "-nopervasives"; "-bs-no-version-header"] + "Good.res" + in + expect_code 0 stdout_compile; + check + (Test_support.contains_text stdout_compile.stdout "value") + "compiler stdout is captured in the structured result"; + let _, repaired = run root "Good.res" in + expect_code 0 repaired; + assert_equal process_cwd (Sys.getcwd ())) + +let state_boundary_tests _context = + Test_support.with_temp_dir "rewatch-driver-state-" (fun root -> + write root "Warning.res" + "let rec notActuallyRecursive = () => 42\n\n\ + let _ = notActuallyRecursive()\n"; + let _, failed = run root ~extra:["-warn-error"; "+39"] "Warning.res" in + expect_code 2 failed; + let _, warning_only = run root "Warning.res" in + expect_code 0 warning_only; + check + (Test_support.contains_text warning_only.stderr "Warning number 39") + "warning configuration is reset between requests"; + write root "SourceFlags.res" + "@@config({flags: [\"-warn-error\", \"+39\"]})\n\n\ + let rec notActuallyRecursive = () => 42\n\n\ + let _ = notActuallyRecursive()\n"; + let _, source_flags = run root "SourceFlags.res" in + expect_code 2 source_flags; + let _, after_source_flags = run root "Warning.res" in + expect_code 0 after_source_flags; + check + (Test_support.contains_text after_source_flags.stderr + "Warning number 39") + "source-level compiler flags are reset between requests"; + write root "Mapped.res" "let mapped = 1\n"; + let mapped_args, mapped = + run root ~extra:["-bs-source-map"; "linked"] "Mapped.res" + in + expect_code 0 mapped; + check + (Sys.file_exists (Filename.concat root "Mapped.js.map")) + "the requested source map is generated"; + let cmt = Cmt_format.read_cmt (Filename.concat root "Mapped.cmt") in + check + (Array.to_list cmt.cmt_args = ("bsc" :: mapped_args) @ ["Mapped.res"]) + "CMT metadata records the logical request argv"; + write root "Plain.res" "let plain = 1\n"; + let _, plain = + run root + ~extra: + [ + "-bs-jsx"; + "4"; + "-bs-jsx-module"; + "CustomJsx"; + "-enable-experimental"; + "LetUnwrap"; + "-bs-gentype-module"; + "esmodule"; + ] + "Plain.res" + in + expect_code 0 plain; + check + (not (Sys.file_exists (Filename.concat root "Plain.js.map"))) + "source-map state does not leak from the preceding request"; + check + (!((Js_config.current ()).jsx_version) = None + && !((Js_config.current ()).jsx_module) = Js_config.React + && (not + (Experimental_features.is_enabled Experimental_features.LetUnwrap)) + && !(Gentype_config.module_flag ()) = None) + "JSX, experimental, and GenType state is restored after the request") + +(* A request that fails with a type error can leave memorized abbreviation + expansions behind. They are keyed by path, and paths into other compilation + units compare by name, so a later request must not find this [Lib.t]. *) +let ctype_memo_reset_tests _context = + Test_support.with_temp_dir "rewatch-driver-ctype-" (fun root -> + write root "Lib.res" "type t = int\n"; + expect_code 0 (snd (run root "Lib.res")); + write root "Bad.res" "let value: Lib.t = \"text\"\n"; + expect_code 2 (snd (run root ~extra:["-I"; root] "Bad.res")); + let lib_t = + Ctype.newconstr + (Path.Pdot (Path.Pident (Ident.create_persistent "Lib"), "t", 0)) + [] + in + check + (Ctype.expand_head Env.empty lib_t == lib_t) + "abbreviation expansions do not outlive their request") + +let package_and_load_path_isolation_tests _context = + Test_support.with_temp_dir "rewatch-driver-load-roots-" (fun root -> + let first = Filename.concat root "first" in + let second = Filename.concat root "second" in + File_util.ensure_dir first; + File_util.ensure_dir second; + write first "Shared.res" "let value = 1\n"; + write first "Consumer.res" "let value: int = Shared.value\n"; + write second "Shared.res" {|let value = "second"|}; + write second "Consumer.res" "let value: string = Shared.value\n"; + let compile directory package ?(extra = []) input = + run directory ~package ~extra input |> snd + in + expect_code 0 (compile first "first-package" "Shared.res"); + expect_code 0 + (compile first "first-package" ~extra:["-I"; first] "Consumer.res"); + expect_code 0 (compile second "second-package" "Shared.res"); + expect_code 0 + (compile second "second-package" ~extra:["-I"; second] "Consumer.res"); + expect_code 0 + (compile first "first-package" ~extra:["-I"; first] "Consumer.res")) + +let generated_name_isolation_tests _context = + Test_support.with_temp_dir "rewatch-driver-generated-names-" (fun root -> + write root "First.res" "%%private(let hidden = 1)\nlet value = hidden\n"; + write root "Other.res" + "%%private(let first = 1)\n%%private(let second = first + 1)\n"; + let parse input = + let _, result = run root ~extra:["-bs-ast"] input in + expect_code 0 result; + let ast = + File_util.read_file + (Filename.concat root (Filename.remove_extension input ^ ".ast")) + in + check (String.length ast > 0) "binary AST output is nonempty"; + ast + in + let first_ast = parse "First.res" in + ignore (parse "Other.res"); + let repeated_ast = parse "First.res" in + assert_equal ~printer:(fun _ -> "") first_ast repeated_ast; + Btype.reinit (); + Lambda_exits.reset (); + let type_id = (Btype.newgenvar ()).Types.id in + let exit_id = Lambda_exits.next_raise_count () in + ignore (parse "Other.res"); + check + ((Btype.newgenvar ()).Types.id = type_id + 1) + "an embedded request preserves the host domain's type-node counter"; + check + (Lambda_exits.next_raise_count () = exit_id + 1) + "an embedded request preserves the host domain's static-exit counter"; + write root "Objects.res" + "type base<'a> = {\"value\": 'a}\n\ + type pair<'a> = {\"left\": base<'a>, \"right\": base<'a>}\n\ + type nested<'a> = {\"first\": pair<'a>, \"second\": pair<'a>}\n"; + let _, first_objects = run root "Objects.res" in + expect_code 0 first_objects; + let cmi_path = Filename.concat root "Objects.cmi" in + let first_cmi = File_util.read_file cmi_path in + check (String.length first_cmi > 0) "CMI output is nonempty"; + for _ = 1 to 1000 do + ignore (Btype.newgenvar ()) + done; + Sys.remove cmi_path; + let _, repeated_objects = run root "Objects.res" in + expect_code 0 repeated_objects; + let repeated_cmi = File_util.read_file cmi_path in + assert_equal ~printer:(fun _ -> "") first_cmi repeated_cmi; + Btype.reinit (); + Lambda_exits.reset ()) + +let interface_namespace_and_load_path_tests _context = + Test_support.with_temp_dir "rewatch-driver-artifacts-" (fun root -> + write root "Api.resi" "let value: int\n"; + let _, intf = run root "Api.resi" in + expect_code 0 intf; + check + (Sys.file_exists (Filename.concat root "Api.cmti")) + "an explicit interface produces CMTI"; + write root "Api.res" "let value = 1\n"; + let _, impl = run root ~extra:["-I"; root; "-bs-read-cmi"] "Api.res" in + expect_code 0 impl; + write root "Consumer.res" "let value = Api.value\n"; + let _, consumer = run root ~extra:["-I"; root] "Consumer.res" in + expect_code 0 consumer; + write root "DriverNs.mlmap" "randjbuildsystem\nApi\nConsumer\n"; + let _, namespace = + run root ~extra:["-I"; root; "-no-alias-deps"] "DriverNs.mlmap" + in + expect_code 0 namespace; + List.iter + (fun extension -> + check + (Sys.file_exists (Filename.concat root ("DriverNs." ^ extension))) + ("namespace output is retained: " ^ extension)) + ["cmi"; "cmj"; "cmt"]) + +let concurrent_diagnostic_recovery_tests _context = + Test_support.with_temp_dir "rewatch-driver-errors-" (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; + write first "Api.resi" "let value: int\n"; + expect_code 0 (snd (run first "Api.resi")); + write first "Api.res" {|let value = "left"|}; + write second "Bad.res" "let value: int = \"right\"\n"; + let first_request () = + snd + (run first + ~extra:["-I"; first; "-bs-read-cmi"; "-bs-jsx"; "4"] + "Api.res") + in + let second_request () = + snd (run second ~extra:["-bs-jsx-module"; "OtherJsx"] "Bad.res") + in + let expected_first = first_request () in + let expected_second = second_request () in + expect_code 2 expected_first; + expect_code 2 expected_second; + for _ = 1 to 5 do + let left = Domain.spawn first_request in + let right = Domain.spawn second_request in + let actual_first = Domain.join left in + let actual_second = Domain.join right in + assert_equal expected_first.stderr actual_first.stderr; + assert_equal expected_second.stderr actual_second.stderr + done; + write first "Api.res" "let value = 1\n"; + write second "Bad.res" "let value = 1\n"; + expect_code 0 (first_request ()); + expect_code 0 (second_request ())) + +let concurrent_jsx_diagnostic_tests _context = + Test_support.with_temp_dir "rewatch-driver-jsx-errors-" (fun root -> + let source module_name = + "@@config({flags: [\"-bs-jsx\", \"4\"]})\n\nmodule " ^ module_name + ^ " = {\n\ + type element = Jsx.element\n\ + type componentLike<'props, 'return> = 'props => 'return\n\ + type component<'props> = Jsx.component<'props>\n\ + external component: componentLike<'props, element> => \ + component<'props> = \"%component_identity\"\n\ + @module(\"react/jsx-runtime\")\n\ + external jsx: (component<'props>, 'props) => element = \"jsx\"\n\ + type fragmentProps = {children?: element}\n\ + @module(\"react/jsx-runtime\")\n\ + external jsxFragment: component = \"Fragment\"\n\ + }\n\n\ + let x = <> {\"\"} \n" + in + let setup module_name = + let directory = Filename.concat root module_name in + File_util.ensure_dir directory; + write directory "Jsx.res" "type element\ntype component<'props>\n"; + expect_code 0 (snd (run directory "Jsx.res")); + write directory "Bad.res" (source module_name); + let request () = + snd + (run directory + ~extra:["-I"; directory; "-bs-jsx-module"; module_name] + "Bad.res") + in + (module_name, request) + in + let left_name, left_request = setup "React" in + let right_name, right_request = setup "OtherJsx" in + let left_expected = left_request () in + let right_expected = right_request () in + expect_code 2 left_expected; + expect_code 2 right_expected; + List.iter + (fun (module_name, result) -> + check + (String_util.contains result.Rescript_compiler_driver.stderr + (module_name ^ ".string")) + ("JSX diagnostic names " ^ module_name)) + [(left_name, left_expected); (right_name, right_expected)]; + for _ = 1 to 5 do + let left = Domain.spawn left_request in + let right = Domain.spawn right_request in + assert_equal left_expected.stderr (Domain.join left).stderr; + assert_equal right_expected.stderr (Domain.join right).stderr + done) + +(* Exercise concurrent compiler requests without the process-worker boundary. *) +let concurrent_request_isolation_tests _context = + Test_support.with_temp_dir "rewatch-driver-domains-" (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; + write first "First.res" "type box<'a> = array<'a>\nlet first = 1\n"; + write second "Second.res" "type box<'b> = array<'b>\nlet second = 2\n"; + let entered = Atomic.make 0 in + let runner command = + ignore (Atomic.fetch_and_add entered 1); + let deadline = Unix.gettimeofday () +. 5. in + while Atomic.get entered < 2 && Unix.gettimeofday () < deadline do + Domain.cpu_relax () + done; + if Atomic.get entered < 2 then (7, "", "PPX overlap timed out") + else + let quote = if String.contains command '\'' then '\'' else '"' in + match String.split_on_char quote command with + | _program :: input :: _separator :: output :: _ -> + File_util.copy_existing_file input output; + (0, "", "") + | _ -> (7, "", "could not decode test PPX command") + in + let request directory package extra input = + let argv = + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + directory; + "-bs-package-name"; + package; + "-bs-package-output"; + "commonjs:.:.js"; + "-bs-no-version-header"; + "-ppx"; + "rewatch-test-ppx"; + ] + @ extra + in + Rescript_compiler_driver.run_request ~cwd:directory ~argv ~input + ~run_external:(Some runner) + in + let left = + Domain.spawn (fun () -> + request first "first-package" + ["-w"; "-39"; "-bs-jsx"; "4"; "-bs-jsx-module"; "CustomJsx"] + "First.res") + in + let right = + Domain.spawn (fun () -> + request second "second-package" + ["-w"; "+39"; "-bs-source-map"; "linked"] + "Second.res") + in + let left_result = Domain.join left in + let right_result = Domain.join right in + expect_code 0 left_result; + expect_code 0 right_result; + check + (Sys.file_exists (Filename.concat first "First.js")) + "first request writes its JavaScript into its root"; + check + (Sys.file_exists (Filename.concat second "Second.js")) + "second request writes its JavaScript into its root"; + check + (Sys.file_exists (Filename.concat second "Second.js.map")) + "second request writes its requested source map"; + check + (not (Sys.file_exists (Filename.concat first "First.js.map"))) + "source-map configuration does not leak to the first request"; + check + (left_result.stdout = "" && right_result.stdout = "") + "concurrent requests keep stdout separate"; + check + (left_result.stderr = "" && right_result.stderr = "") + (Printf.sprintf + "concurrent requests keep stderr separate: left=%S right=%S" + left_result.stderr right_result.stderr); + Atomic.set entered 0; + let absolute_parser = + Domain.spawn (fun () -> + request first "first-package" + ["-absname"; "-bs-ast"; "-o"; "First.ast"] + "First.res") + in + let relative_parser = + Domain.spawn (fun () -> + request second "second-package" + ["-bs-ast"; "-o"; "Second.ast"] + "Second.res") + in + expect_code 0 (Domain.join absolute_parser); + expect_code 0 (Domain.join relative_parser); + check + ((Ast_header.read (Filename.concat first "First.ast")).source + = Some (Filename.concat first "First.res")) + "-absname retains an absolute source path during concurrent parsing"; + check + ((Ast_header.read (Filename.concat second "Second.ast")).source + = Some "Second.res") + "a concurrent parser without -absname retains its relative source path") + +let concurrent_async_context_tests _context = + Test_support.with_temp_dir "rewatch-driver-async-domains-" (fun root -> + let runtime = Runtime_package.get_path () in + let runtime_ocaml = Filename.concat runtime "lib/ocaml" in + let async_source = + "external get: unit => promise = \"get\"\n" + ^ (List.init 80 (fun index -> + Printf.sprintf + "let async%d = async () => { let value = await get(); value }\n" + index) + |> String.concat "") + ^ "let topLevel = await get()\n" + in + let sync_source = + List.init 80 (fun index -> + Printf.sprintf "let sync%d = () => %d\n" index index) + |> String.concat "" + in + let ready = Atomic.make 0 in + let run_domain index = + let directory = Filename.concat root (string_of_int index) in + File_util.ensure_dir directory; + write directory "Async.res" async_source; + write directory "Sync.res" sync_source; + Domain.spawn (fun () -> + ignore (Atomic.fetch_and_add ready 1); + let deadline = Unix.gettimeofday () +. 5. in + while Atomic.get ready < 8 && Unix.gettimeofday () < deadline do + Domain.cpu_relax () + done; + check (Atomic.get ready = 8) "async requests did not overlap"; + for _ = 1 to 3 do + List.iter + (fun input -> + let _, result = + run directory ~extra:["-I"; runtime_ocaml] input + in + if result.exit_code <> 0 then + assert_failure (Printf.sprintf "%s: %s" input result.stderr)) + (if index mod 2 = 0 then ["Async.res"; "Sync.res"] + else ["Sync.res"; "Async.res"]) + done) + in + List.init 8 run_domain |> List.iter Domain.join) + +let tests = + "compiler_driver_tests" + >::: [ + "request_local" >:: request_local_tests; + "failed_capture" >:: failed_capture_tests; + "gentype_source_lookup" >:: gentype_source_lookup_tests; + "standalone_output" >:: standalone_output_tests; + "ctype_level_isolation" >:: ctype_level_isolation_tests; + "free_variable_isolation" >:: free_variable_isolation_tests; + "ctype_memo_reset" >:: ctype_memo_reset_tests; + "shared_type_graph_isolation" >:: shared_type_graph_isolation_tests; + "dependency_extraction_isolation" + >:: dependency_extraction_isolation_tests; + "gentype_output_capture" >:: gentype_output_capture_tests; + "used_attributes_isolation" >:: used_attributes_isolation_tests; + "delayed_checks_isolation" >:: delayed_checks_isolation_tests; + "gentype_flags_isolation" >:: gentype_flags_isolation_tests; + "diagnostic_state_isolation" >:: diagnostic_state_isolation_tests; + "command_runner_isolation" >:: command_runner_isolation_tests; + "warning_and_feature_isolation" >:: warning_and_feature_isolation_tests; + "js_config_isolation" >:: js_config_isolation_tests; + "clflags_isolation" >:: clflags_isolation_tests; + "env_cache_isolation" >:: env_cache_isolation_tests; + "identifier_stamp_isolation" >:: identifier_stamp_isolation_tests; + "output_capture_isolation" >:: output_capture_isolation_tests; + "backend_module_cache_isolation" + >:: backend_module_cache_isolation_tests; + "input_name_isolation" >:: input_name_isolation_tests; + "request_root_io_isolation" >:: request_root_io_isolation_tests; + "cmt_accumulator_isolation" >:: cmt_accumulator_isolation_tests; + "package_output_isolation" >:: package_output_isolation_tests; + "path_configuration_isolation" >:: path_configuration_isolation_tests; + "lambda_exit_isolation" >:: lambda_exit_isolation_tests; + "type_node_id_isolation" >:: type_node_id_isolation_tests; + "recovery" >:: recovery_tests; + "ppx_recovery" >:: ppx_recovery_tests; + "control_flow_and_output" >:: control_flow_and_output_tests; + "state_boundary" >:: state_boundary_tests; + "package_and_load_path_isolation" + >:: package_and_load_path_isolation_tests; + "generated_name_isolation" >:: generated_name_isolation_tests; + "interfaces_namespaces_load_paths" + >:: interface_namespace_and_load_path_tests; + "concurrent_diagnostic_recovery" + >:: concurrent_diagnostic_recovery_tests; + "concurrent_jsx_diagnostic" >:: concurrent_jsx_diagnostic_tests; + "concurrent_request_isolation" >:: concurrent_request_isolation_tests; + "concurrent_async_context" >:: concurrent_async_context_tests; + ] diff --git a/tests/rewatch_ounit_tests/compiler_info_tests.ml b/tests/rewatch_ounit_tests/compiler_info_tests.ml index 6c27df9aa15..ad60f987a05 100644 --- a/tests/rewatch_ounit_tests/compiler_info_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_info_tests.ml @@ -18,8 +18,9 @@ let context ?(inherited_compiler_args = []) root config source_map_args = let runtime = Filename.concat root "runtime" in if not (Sys.file_exists bsc) then write bsc "compiler-v1"; File_util.ensure_dir runtime; - Compiler_info.make_context ~bsc_path:bsc ~runtime_path:runtime - ~source_map_args ~inherited_compiler_args + Compiler_info.make_context ~compiler_path:bsc + ~compiler_identity:(Digest.file bsc |> Digest.to_hex) + ~runtime_path:runtime ~source_map_args ~inherited_compiler_args ~package_output_specs:(Compiler_info.package_output_specs config) let tests = @@ -123,15 +124,17 @@ let tests = ] in let initial = - Compiler_info.make_context ~bsc_path:bsc ~runtime_path:runtime - ~source_map_args:[] ~inherited_compiler_args:[] + Compiler_info.make_context ~compiler_path:bsc + ~compiler_identity:(Digest.file bsc |> Digest.to_hex) + ~runtime_path:runtime ~source_map_args:[] ~inherited_compiler_args:[] ~package_output_specs:commonjs in Compiler_info.write_package initial dependency; let marker = File_util.path_of_parts root ["lib"; "ocaml"; "marker"] in write marker "keep"; let changed = - Compiler_info.make_context ~bsc_path:bsc ~runtime_path:runtime + Compiler_info.make_context ~compiler_path:bsc + ~compiler_identity:"changed-compiler" ~runtime_path:runtime ~source_map_args:[] ~inherited_compiler_args:[] ~package_output_specs:esmodule in diff --git a/tests/rewatch_ounit_tests/compiler_process_tests.ml b/tests/rewatch_ounit_tests/compiler_process_tests.ml index 5715a7f8dd6..5f25afa9369 100644 --- a/tests/rewatch_ounit_tests/compiler_process_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_process_tests.ml @@ -2,8 +2,7 @@ open OUnit2 let check condition message = assert_bool message condition -let tests = - "compiler_process_tests" >:: fun _context -> +let publication_tests _context = Test_support.with_temp_dir "rewatch-compiler-process-" (fun root -> let build_dir = Filename.concat root "build" in let ocaml_dir = Filename.concat root "ocaml" in @@ -17,9 +16,8 @@ let tests = ["cmi"; "cmj"; "cmt"]; File_util.ensure_dir (Filename.concat ocaml_dir "Ns.cmj"); let namespace_task = - Compiler_process.namespace_task ~bsc:"unused" ~runtime:"unused" - ~build_dir ~ocaml_dir ~entry:None ~package_dirty:true ~force:false - "Ns" [] + Compiler_process.namespace_task ~runtime:"unused" ~build_dir ~ocaml_dir + ~entry:None ~package_dirty:true ~force:false "Ns" [] |> Option.get in let result = @@ -53,16 +51,203 @@ let tests = ["cmi"; "cmj"; "cmt"; "mlmap"]; check (Option.is_some - (Compiler_process.namespace_task ~bsc:"unused" ~runtime:"unused" - ~build_dir ~ocaml_dir ~entry:None ~package_dirty:false - ~force:false "Ns" [])) + (Compiler_process.namespace_task ~runtime:"unused" ~build_dir + ~ocaml_dir ~entry:None ~package_dirty:false ~force:false "Ns" [])) "a published namespace map that differs from membership is rebuilt"; Test_support.write_file (Filename.concat ocaml_dir "Ns.mlmap") "randjbuildsystem\n"; check (Option.is_some - (Compiler_process.namespace_task ~bsc:"unused" ~runtime:"unused" - ~build_dir ~ocaml_dir ~entry:None ~package_dirty:false ~force:true - "Ns" [])) + (Compiler_process.namespace_task ~runtime:"unused" ~build_dir + ~ocaml_dir ~entry:None ~package_dirty:false ~force:true "Ns" [])) "retained namespace publication dirtiness forces a retry") + +let restore_environment name previous = + match previous with + | Some value -> Unix.putenv name value + | None -> Test_support.unsetenv name + +(* A request for DomainPpx.res whose PPX writes its PID to [marker] and then + waits. *) +let waiting_ppx_request root marker = + Test_support.write_file + (Filename.concat root "DomainPpx.res") + "let value = 1\n"; + let ppx_command = + Filename.quote (Unix.realpath Sys.executable_name) + ^ " --ppx-wait " ^ Filename.quote marker + in + Compiler_process. + { + cwd = root; + args = + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + root; + "-bs-package-name"; + "domain-ppx"; + "-bs-package-output"; + "commonjs:.:.js"; + "-ppx"; + ppx_command; + "DomainPpx.res"; + ]; + } + +let check_ppx_gone marker = + if not Sys.win32 then + let pid = File_util.read_file marker |> int_of_string in + check + (try + Unix.kill pid 0; + false + with Unix.Unix_error (Unix.ESRCH, _, _) -> true) + "the domain PPX process is gone when the request returns" + +let domain_ppx_cancellation_test _context = + Test_support.with_temp_dir "rewatch-domain-ppx-cancellation-" (fun root -> + let marker = Filename.concat root "ppx-started" in + let job = waiting_ppx_request root marker in + let interrupted = + try + ignore + (Process.run_tasks ~max_jobs:1 + ~poll:(fun () -> + if Sys.file_exists marker then raise (Process.Interrupted 15)) + [Compiler_process.task job]); + false + with Process.Interrupted 15 -> true + in + check interrupted "domain task cancellation reaches a running PPX"; + check (Sys.file_exists marker) "the domain PPX started"; + check_ppx_gone marker) + +(* An exception that escapes the compiler fails only its own request: the + module fails with exit status 2 and the exception in its output. *) +let escaped_exception_test _context = + Test_support.with_temp_dir "rewatch-escaped-exception-" (fun root -> + let marker = Filename.concat root "ppx-started" in + let raised = ref false in + let poll () = + if Sys.file_exists marker && not !raised then ( + raised := true; + failwith "request failed") + in + let result = + Compiler_process.run ~poll (waiting_ppx_request root marker) + in + check !raised "the exception was raised while the PPX ran"; + assert_equal (Unix.WEXITED 2) result.status; + check + (String.ends_with ~suffix:"Failure(\"request failed\")\n" result.stderr) + ("the request reports the exception: " ^ result.stderr); + check_ppx_gone marker) + +let domain_execution_test _context = + Test_support.with_temp_dir "rewatch-domain-execution-" (fun root -> + let previous_count = Sys.getenv_opt "REWATCH_COMPILER_DOMAINS" in + Fun.protect + ~finally:(fun () -> + restore_environment "REWATCH_COMPILER_DOMAINS" previous_count) + (fun () -> + List.iter + (fun (cpus, workers) -> + assert_equal workers + (Compiler_execution_mode.recommended_domain_count cpus)) + [(1, 1); (2, 1); (4, 3); (8, 7); (10, 8); (16, 8)]; + Test_support.unsetenv "REWATCH_COMPILER_DOMAINS"; + assert_equal + (Compiler_execution_mode.recommended_domain_count + (Domain.recommended_domain_count ())) + (Compiler_execution_mode.configured_count ()); + let count = + if Sys.getenv_opt "REWATCH_TEST_DOMAIN_CONCURRENCY" = Some "1" then + 2 + else 1 + in + Unix.putenv "REWATCH_COMPILER_DOMAINS" (string_of_int count); + assert_equal count (Compiler_execution_mode.configured_count ()); + List.iter + (fun name -> + Test_support.write_file + (Filename.concat root (name ^ ".res")) + "let value = 1\n") + ["First"; "Second"]; + let jobs = + List.map + (fun name -> + Compiler_process. + { + cwd = root; + args = ["-bs-ast"; "-o"; name ^ ".ast"; name ^ ".res"]; + }) + ["First"; "Second"] + in + let results = Compiler_process.run_requests jobs in + List.iter + (fun result -> check (Process.succeeded result) result.stderr) + results; + List.iter + (fun name -> + check + (Sys.file_exists (Filename.concat root (name ^ ".ast"))) + "domain mode retains parser artifacts") + ["First"; "Second"]; + let marker = Filename.concat root "ppx-started" in + let ppx_command = + Filename.quote (Unix.realpath Sys.executable_name) + ^ " --ppx-copy " ^ Filename.quote marker + in + let ppx_result = + Compiler_process.run + Compiler_process. + { + cwd = root; + args = + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + root; + "-bs-package-name"; + "domain-ppx"; + "-bs-package-output"; + "commonjs:.:.js"; + "-ppx"; + ppx_command; + "First.res"; + ]; + } + in + check (Process.succeeded ppx_result) ppx_result.stderr; + check (Sys.file_exists marker) "a domain request launches its PPX"; + check + (Sys.file_exists (Filename.concat root "First.js")) + "the PPX transformed request still writes JavaScript"; + Unix.putenv "REWATCH_COMPILER_DOMAINS" "0"; + check + (try + ignore (Compiler_execution_mode.configured_count ()); + false + with Invalid_argument _ -> true) + "domain counts must be positive"; + Unix.putenv "REWATCH_COMPILER_DOMAINS" + (string_of_int (Compiler_execution_mode.max_domain_count + 1)); + check + (try + ignore (Compiler_execution_mode.configured_count ()); + false + with Invalid_argument _ -> true) + "domain counts must honor the scheduler bound")) + +let tests = + "compiler_process_tests" + >::: [ + "publication" >:: publication_tests; + "domain_ppx_cancellation" >:: domain_ppx_cancellation_test; + "escaped_exception" >:: escaped_exception_test; + "domain_execution" >:: domain_execution_test; + ] diff --git a/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml b/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml index 4c85e18c179..5c6adb73cfc 100644 --- a/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_scheduler_tests.ml @@ -15,6 +15,17 @@ let wait_for_release_job root = let with_temp_dir = Test_support.with_temp_dir "rewatch-scheduler-" +let with_single_domain action = + let previous = Sys.getenv_opt "REWATCH_COMPILER_DOMAINS" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_COMPILER_DOMAINS" value + | None -> Test_support.unsetenv "REWATCH_COMPILER_DOMAINS") + (fun () -> + Unix.putenv "REWATCH_COMPILER_DOMAINS" "1"; + action ()) + let source name = Source. { @@ -26,276 +37,210 @@ let source name = let tests = "compiler_scheduler_tests" >:: fun _context -> - with_temp_dir (fun root -> - let ocaml_dir = Build_artifacts.lib_path root "ocaml" in - File_util.ensure_dir ocaml_dir; - File_util.ensure_dir (Build_artifacts.lib_path root "bs"); - Compiler_log.initialize root; - let a_source = source "A" in - let b_source = source "B" in - let c_source = source "C" in - let build_state = Build_state.create 3 in - List.iter - (fun key -> - Build_state.add build_state ~key ~kind:Build_state.Source_module - ~last_compiled_cmi:(Some 0.) ~last_compiled_cmt:(Some 0.)) - ["A"; "B"; "C"]; - Build_state.set_dependencies build_state ~key:"B" ["A"]; - let a_state = Build_state.find_exn build_state "A" in - let b_state = Build_state.find_exn build_state "B" in - let c_state = Build_state.find_exn build_state "C" in - a_state.compile_dirty <- true; - let a_cmi = Filename.concat ocaml_dir "A.cmi" in - let b_cmi = Filename.concat ocaml_dir "B.cmi" in - let c_cmi = Filename.concat ocaml_dir "C.cmi" in - let a_ast = Filename.concat ocaml_dir "A.ast" in - write_file a_cmi "old interface"; - write_file b_cmi "dependent interface"; - write_file a_ast "published AST"; - let compile_assets = Compile_assets.create [ocaml_dir] in - let fail_a_publication = ref true in - let b_compilations = ref 0 in - let c_candidates_built = ref 0 in - let scheduler_thread = Thread.id (Thread.self ()) in - let output_inventory = Hashtbl.create 1 in - let make_scheduled key source state cmi_path = - Compiler_scheduler.create ~key - ~dependencies:state.Build_state.dependencies ~source ~state ~cmi_path - ~prepare:(fun () -> ()) - ~compile:(fun ~source_kind:_ _path -> - if key = "B" then incr b_compilations; - process_job ()) - ~publish:(fun ~source_kind:_ _path _result -> - write_file cmi_path - (if key = "A" then "new interface" else "dependent interface"); - if key = "A" && !fail_a_publication then ( - fail_a_publication := false; - raise (Failure "later publication failed")); - Compiler_scheduler. - { - stderr = ""; - cmi_change = (if key = "A" then Cmi_changed else Cmi_unchanged); - }) - ~record_published_outputs:(fun ~source_kind:_ _path -> - check - (Thread.id (Thread.self ()) = scheduler_thread) - "the scheduler thread owns the shared output inventory"; - for index = 0 to 127 do - Hashtbl.replace output_inventory - (Printf.sprintf "%s-%d" key index) - () - done) - ~post_build:(fun _ -> []) - ~package_root:root ~is_local:true - ~mark_warning:(fun _ -> ()) - in - let run () = - let candidates = - [ - ("A", a_source, a_state, a_cmi, fun () -> ()); - ("B", b_source, b_state, b_cmi, fun () -> ()); - ("C", c_source, c_state, c_cmi, fun () -> incr c_candidates_built); - ] - |> List.map (fun (key, source, state, cmi_path, on_make) -> - Compiler_scheduler.candidate ~key ~state ~warning_paths:[] - ~make:(fun () -> - on_make (); - make_scheduled key source state cmi_path)) - in - Compiler_scheduler.run ~poll:None - ~warning_state:(Warning_state.create ()) ~compile_assets ~build_state - ~candidates - ~mark_compiled:(fun () -> ()) - ~mark_had_warnings:(fun () -> ()) - ~progress:(Output.Progress.create ~enabled:false ~color:false) - ~compile_step:"1/1" ~namespace_count:0 ~verbosity:0 - in - let first_failed = - try - run (); - false - with Compiler_scheduler.Build_failure message -> - Test_support.contains_text message "later publication failed" - in - check first_failed "a later publication failure is reported normally"; - check - (not (Sys.file_exists a_ast)) - "failed completion invalidates durable freshness for a later process"; - check b_state.compile_dirty - "a published CMI change survives a later publication failure"; - check (!b_compilations = 0) - "a dependent is not compiled during its dependency's failed attempt"; - run (); - check - (!b_compilations = 1 && not b_state.compile_dirty) - "the retained dependent recompiles after publication recovers"; - check - (Hashtbl.length output_inventory = 256) - "scheduler-owned publication inventory updates survive table growth"; - check (!c_candidates_built = 0) - "an unaffected module does not construct compiler callbacks"; - let abort_state = Build_state.create 4 in - List.iter - (fun key -> - Build_state.add abort_state ~key ~kind:Build_state.Source_module - ~last_compiled_cmi:(Some 0.) ~last_compiled_cmt:(Some 0.)) - ["AbortA"; "AbortB"; "AbortC"; "AbortD"]; - Build_state.set_dependencies abort_state ~key:"AbortB" ["AbortC"]; - Build_state.set_dependencies abort_state ~key:"AbortD" ["AbortA"]; - let abort_a = Build_state.find_exn abort_state "AbortA" in - let abort_c = Build_state.find_exn abort_state "AbortC" in - abort_a.compile_dirty <- true; - abort_c.compile_dirty <- true; - let abort_a_ast = Filename.concat ocaml_dir "AbortA.ast" in - write_file abort_a_ast "published AST"; - let published_marker = Filename.concat root "abort-a-published" in - let release_marker = Filename.concat root "abort-a-release" in - let rec wait_for path remaining = - if Sys.file_exists path then () - else if remaining = 0 then failwith ("timed out waiting for " ^ path) - else ( - Thread.delay 0.001; - wait_for path (remaining - 1)) - in - let abort_candidate key dependencies prepare publish = - let state = Build_state.find_exn abort_state key in - Compiler_scheduler.candidate ~key ~state ~warning_paths:[] - ~make:(fun () -> - Compiler_scheduler.create ~key ~dependencies ~source:(source key) - ~state - ~cmi_path:(Filename.concat ocaml_dir (key ^ ".cmi")) - ~prepare - ~compile:(fun ~source_kind:_ _path -> process_job ()) - ~publish - ~record_published_outputs:(fun ~source_kind:_ _path -> ()) - ~post_build:(fun output -> - if key = "AbortA" then - [ - Compiler_scheduler. - {output; task = Process.task (process_job ())}; - ] - else []) - ~package_root:root ~is_local:true - ~mark_warning:(fun _ -> ())) - in - let abort_candidates = - [ - abort_candidate "AbortA" [] - (fun () -> ()) - (fun ~source_kind:_ _path _result -> - write_file (Filename.concat ocaml_dir "AbortA.cmi") "new A"; - write_file published_marker ""; - wait_for release_marker 5000; - Compiler_scheduler.{stderr = ""; cmi_change = Cmi_changed}); - abort_candidate "AbortC" [] - (fun () -> ()) - (fun ~source_kind:_ _path _result -> - wait_for published_marker 5000; - write_file (Filename.concat ocaml_dir "AbortC.cmi") "new C"; - Compiler_scheduler.{stderr = ""; cmi_change = Cmi_changed}); - abort_candidate "AbortB" ["AbortC"] - (fun () -> - write_file release_marker ""; - raise Exit) - (fun ~source_kind:_ _path _result -> assert false); - abort_candidate "AbortD" ["AbortA"] - (fun () -> ()) - (fun ~source_kind:_ _path _result -> assert false); - ] - in - let aborted = - try - Compiler_scheduler.run ~poll:None - ~warning_state:(Warning_state.create ()) - ~compile_assets:(Compile_assets.create [ocaml_dir]) - ~build_state:abort_state ~candidates:abort_candidates - ~mark_compiled:(fun () -> ()) - ~mark_had_warnings:(fun () -> ()) - ~progress:(Output.Progress.create ~enabled:false ~color:false) - ~compile_step:"1/1" ~namespace_count:0 ~verbosity:0; - false - with Exit -> true - in - check aborted "an operational scheduler failure aborts the attempt"; - check (Build_state.find_exn abort_state "AbortD").compile_dirty - "CMI publication completed during abort still invalidates dependents"; - check - (not (Sys.file_exists abort_a_ast)) - "abort before post-build scheduling invalidates persistent freshness"; - let interrupted_state = Build_state.create 1 in - Build_state.add interrupted_state ~key:"Interrupted" - ~kind:Build_state.Source_module ~last_compiled_cmi:(Some 0.) - ~last_compiled_cmt:(Some 0.); - let interrupted_module = - Build_state.find_exn interrupted_state "Interrupted" - in - interrupted_module.compile_dirty <- true; - let interrupted_ast = Filename.concat ocaml_dir "Interrupted.ast" in - let interrupted_cmi = Filename.concat ocaml_dir "Interrupted.cmi" in - let interrupted_hook_root = Filename.concat root "interrupted-hook" in - Unix.mkdir interrupted_hook_root 0o755; - write_file interrupted_ast "published AST"; - let interrupted_candidate = - Compiler_scheduler.candidate ~key:"Interrupted" - ~state:interrupted_module ~warning_paths:[] ~make:(fun () -> - Compiler_scheduler.create ~key:"Interrupted" ~dependencies:[] - ~source:(source "Interrupted") ~state:interrupted_module - ~cmi_path:interrupted_cmi + with_single_domain (fun () -> + with_temp_dir (fun root -> + let ocaml_dir = Build_artifacts.lib_path root "ocaml" in + File_util.ensure_dir ocaml_dir; + File_util.ensure_dir (Build_artifacts.lib_path root "bs"); + Compiler_log.initialize root; + let a_source = source "A" in + let b_source = source "B" in + let c_source = source "C" in + let build_state = Build_state.create 3 in + List.iter + (fun key -> + Build_state.add build_state ~key ~kind:Build_state.Source_module + ~last_compiled_cmi:(Some 0.) ~last_compiled_cmt:(Some 0.)) + ["A"; "B"; "C"]; + Build_state.set_dependencies build_state ~key:"B" ["A"]; + let a_state = Build_state.find_exn build_state "A" in + let b_state = Build_state.find_exn build_state "B" in + let c_state = Build_state.find_exn build_state "C" in + a_state.compile_dirty <- true; + c_state.compile_dirty <- true; + let a_cmi = Filename.concat ocaml_dir "A.cmi" in + let b_cmi = Filename.concat ocaml_dir "B.cmi" in + let c_cmi = Filename.concat ocaml_dir "C.cmi" in + let a_ast = Filename.concat ocaml_dir "A.ast" in + write_file a_cmi "old interface"; + write_file b_cmi "dependent interface"; + Test_support.write_ast_header a_ast ~dependencies:[] + ~source:"src/A.res"; + let compile_assets = Compile_assets.create [ocaml_dir] in + let fail_a_publication = ref true in + let b_compilations = ref 0 in + let c_compilations = ref 0 in + let c_candidates_built = ref 0 in + let scheduler_thread = Thread.id (Thread.self ()) in + let output_inventory = Hashtbl.create 1 in + let make_scheduled key source state cmi_path = + Compiler_scheduler.create ~key + ~dependencies:state.Build_state.dependencies ~source ~state + ~cmi_path ~prepare:(fun () -> ()) - ~compile:(fun ~source_kind:_ _path -> process_job ()) + ~compile:(fun ~source_kind:_ _path -> + if key = "B" then incr b_compilations; + if key = "C" then ( + check (not !fail_a_publication) + "independent work starts after A's publication failure"; + incr c_compilations); + Process.task (process_job ())) ~publish:(fun ~source_kind:_ _path _result -> - write_file interrupted_cmi "published CMI"; - Compiler_scheduler.{stderr = ""; cmi_change = Cmi_changed}) - ~record_published_outputs:(fun ~source_kind:_ _path -> ()) - ~post_build:(fun output -> - [ - Compiler_scheduler. - { - output; - task = - Process.task - (wait_for_release_job interrupted_hook_root); - }; - ]) + write_file cmi_path + (if key = "A" then "new interface" else "dependent interface"); + if key = "A" && !fail_a_publication then ( + fail_a_publication := false; + raise (Failure "later publication failed")); + Compiler_scheduler. + { + stderr = ""; + cmi_change = + (if key = "A" then Cmi_changed else Cmi_unchanged); + }) + ~record_published_outputs:(fun ~source_kind:_ _path -> + check + (Thread.id (Thread.self ()) = scheduler_thread) + "the scheduler thread owns the shared output inventory"; + for index = 0 to 127 do + Hashtbl.replace output_inventory + (Printf.sprintf "%s-%d" key index) + () + done) + ~post_build:(fun _ -> []) ~package_root:root ~is_local:true - ~mark_warning:(fun _ -> ())) - in - let hook_interrupted = - try - Compiler_scheduler.run - ~poll: - (Some - (fun () -> - if - Sys.file_exists - (Filename.concat interrupted_hook_root "child-started") - then raise Exit)) - ~warning_state:(Warning_state.create ()) - ~compile_assets:(Compile_assets.create [ocaml_dir]) - ~build_state:interrupted_state ~candidates:[interrupted_candidate] - ~mark_compiled:(fun () -> ()) - ~mark_had_warnings:(fun () -> ()) - ~progress:(Output.Progress.create ~enabled:false ~color:false) - ~compile_step:"1/1" ~namespace_count:0 ~verbosity:0; - false - with Exit -> true - in - check hook_interrupted "a running post-build hook can be interrupted"; - check - (not (Sys.file_exists interrupted_ast)) - "interrupted post-build invalidates persistent compiler freshness"; - let marker = Failure "copy after CMI failed" in - match - Compiler_scheduler.capture_publication (fun () -> - raise - (Compiler_scheduler.Publication_failure - (marker, Compiler_scheduler.Cmi_changed))) - with - | Compiler_scheduler.Failed_after_cmi_publication - {error; cmi_change = Compiler_scheduler.Cmi_changed} - when error == marker -> - () - | _ -> - assert_failure - "publication capture must retain a CMI change across later copy \ - failure") + ~mark_warning:(fun _ -> ()) + in + let run () = + let candidates = + [ + ("A", a_source, a_state, a_cmi, fun () -> ()); + ("B", b_source, b_state, b_cmi, fun () -> ()); + ( "C", + c_source, + c_state, + c_cmi, + fun () -> incr c_candidates_built ); + ] + |> List.map (fun (key, source, state, cmi_path, on_make) -> + Compiler_scheduler.candidate ~key ~state ~warning_paths:[] + ~make:(fun () -> + on_make (); + make_scheduled key source state cmi_path)) + in + Compiler_scheduler.run ~poll:None + ~warning_state:(Warning_state.create ()) ~compile_assets + ~build_state ~candidates + ~mark_compiled:(fun () -> ()) + ~mark_had_warnings:(fun () -> ()) + ~progress:(Output.Progress.create ~enabled:false ~color:false) + ~compile_step:"1/1" ~namespace_count:0 ~verbosity:0 + in + let first_failed = + try + run (); + false + with Compiler_scheduler.Build_failure message -> + Test_support.contains_text message "later publication failed" + in + check first_failed "a later publication failure is reported normally"; + check + (not (Sys.file_exists a_ast)) + "failed completion invalidates durable freshness for a later \ + process"; + check b_state.compile_dirty + "a published CMI change survives a later publication failure"; + check (!b_compilations = 0) + "a dependent is not compiled during its dependency's failed attempt"; + check (!c_compilations = 1) + "independent work completes after another module fails"; + run (); + check + (!b_compilations = 1 && not b_state.compile_dirty) + "the retained dependent recompiles after publication recovers"; + check + (Hashtbl.length output_inventory = 384) + "scheduler-owned publication inventory updates survive table growth"; + check + (!c_candidates_built = 1 && !c_compilations = 1) + "a completed independent module remains fresh on retry"; + let interrupted_state = Build_state.create 1 in + Build_state.add interrupted_state ~key:"Interrupted" + ~kind:Build_state.Source_module ~last_compiled_cmi:(Some 0.) + ~last_compiled_cmt:(Some 0.); + let interrupted_module = + Build_state.find_exn interrupted_state "Interrupted" + in + interrupted_module.compile_dirty <- true; + let interrupted_ast = Filename.concat ocaml_dir "Interrupted.ast" in + let interrupted_cmi = Filename.concat ocaml_dir "Interrupted.cmi" in + let interrupted_hook_root = Filename.concat root "interrupted-hook" in + Unix.mkdir interrupted_hook_root 0o755; + Test_support.write_ast_header interrupted_ast ~dependencies:[] + ~source:"src/Interrupted.res"; + let interrupted_candidate = + Compiler_scheduler.candidate ~key:"Interrupted" + ~state:interrupted_module ~warning_paths:[] ~make:(fun () -> + Compiler_scheduler.create ~key:"Interrupted" ~dependencies:[] + ~source:(source "Interrupted") ~state:interrupted_module + ~cmi_path:interrupted_cmi + ~prepare:(fun () -> ()) + ~compile:(fun ~source_kind:_ _path -> + Process.task (process_job ())) + ~publish:(fun ~source_kind:_ _path _result -> + write_file interrupted_cmi "published CMI"; + Compiler_scheduler.{stderr = ""; cmi_change = Cmi_changed}) + ~record_published_outputs:(fun ~source_kind:_ _path -> ()) + ~post_build:(fun output -> + [ + Compiler_scheduler. + { + output; + task = + Process.task + (wait_for_release_job interrupted_hook_root); + }; + ]) + ~package_root:root ~is_local:true + ~mark_warning:(fun _ -> ())) + in + let hook_interrupted = + try + Compiler_scheduler.run + ~poll: + (Some + (fun () -> + if + Sys.file_exists + (Filename.concat interrupted_hook_root + "child-started") + then raise Exit)) + ~warning_state:(Warning_state.create ()) + ~compile_assets:(Compile_assets.create [ocaml_dir]) + ~build_state:interrupted_state + ~candidates:[interrupted_candidate] + ~mark_compiled:(fun () -> ()) + ~mark_had_warnings:(fun () -> ()) + ~progress:(Output.Progress.create ~enabled:false ~color:false) + ~compile_step:"1/1" ~namespace_count:0 ~verbosity:0; + false + with Exit -> true + in + check hook_interrupted "a running post-build hook can be interrupted"; + check + (not (Sys.file_exists interrupted_ast)) + "interrupted post-build invalidates persistent compiler freshness"; + let marker = Failure "copy after CMI failed" in + match + Compiler_scheduler.capture_publication (fun () -> + raise + (Compiler_scheduler.Publication_failure + (marker, Compiler_scheduler.Cmi_changed))) + with + | Compiler_scheduler.Failed_after_cmi_publication + {error; cmi_change = Compiler_scheduler.Cmi_changed} + when error == marker -> + () + | _ -> + assert_failure + "publication capture must retain a CMI change across later copy \ + failure")) diff --git a/tests/rewatch_ounit_tests/config_tests.ml b/tests/rewatch_ounit_tests/config_tests.ml index b518b020004..3af05136f28 100644 --- a/tests/rewatch_ounit_tests/config_tests.ml +++ b/tests/rewatch_ounit_tests/config_tests.ml @@ -275,7 +275,7 @@ let compiler_job_tests = File_util.ensure_dir (Filename.dirname source); write_file source "let value = 1\n"; let parse_job = - Compiler_process.parse_job ~bsc:"bsc" ~build_dir ~config "src/A.res" + Compiler_process.parse_request ~build_dir ~config "src/A.res" in let module_ = Source. @@ -287,7 +287,7 @@ let compiler_job_tests = } in let compile_job = - Compiler_process.compile_job ~bsc:"bsc" ~build_dir ~config + Compiler_process.compile_request ~build_dir ~config ~common_args: (Compiler_args.compiler_common_arguments ~config ~runtime:"runtime" ~dependency_dirs:[] ~watch:false ~gentype_dependency_args:[]) @@ -299,7 +299,7 @@ let compiler_job_tests = | [] -> None in check - (parse_job.Process.cwd = compile_job.Process.cwd + (parse_job.Compiler_process.cwd = compile_job.Compiler_process.cwd && parse_job.cwd = build_dir) "parser and compiler jobs derive the same canonical working directory"; check diff --git a/tests/rewatch_ounit_tests/dune b/tests/rewatch_ounit_tests/dune index b169b0e0552..8d7d67ae192 100644 --- a/tests/rewatch_ounit_tests/dune +++ b/tests/rewatch_ounit_tests/dune @@ -24,6 +24,7 @@ cli_tests compile_assets_tests compiler_args_tests + compiler_driver_tests compiler_info_tests compiler_process_tests compiler_scheduler_tests @@ -45,4 +46,6 @@ (foreign_stubs (language c) (names test_env_stubs)) + (flags + (:standard -open Rewatch_ocaml_lib)) (libraries rewatch_ocaml_lib ounit2)) diff --git a/tests/rewatch_ounit_tests/format_tests.ml b/tests/rewatch_ounit_tests/format_tests.ml index 48a906fbef3..364226a516e 100644 --- a/tests/rewatch_ounit_tests/format_tests.ml +++ b/tests/rewatch_ounit_tests/format_tests.ml @@ -16,6 +16,11 @@ let write_file = Test_support.write_file let with_temp_dir = Test_support.with_temp_dir "rewatch-ocaml-format-" +(* The formatter writes text-mode output, so lines end in CRLF on Windows. *) +let native text = + if Sys.win32 then String.concat "\r\n" (String.split_on_char '\n' text) + else text + let tests = "format_tests" >:: fun _context -> check @@ -44,31 +49,6 @@ let tests = contains message "Could not write formatted file" && contains message path) "formatter write failures retain their operation and source path"); - with_temp_dir (fun root -> - write_file (Filename.concat root "rescript.json") "{"; - let previous_directory = Sys.getcwd () in - let previous_bsc = Sys.getenv_opt "RESCRIPT_BSC_EXE" in - Unix.chdir root; - Unix.putenv "RESCRIPT_BSC_EXE" (Filename.concat root "missing-bsc"); - let message = - Fun.protect - ~finally:(fun () -> - Unix.chdir previous_directory; - match previous_bsc with - | Some value -> Unix.putenv "RESCRIPT_BSC_EXE" value - | None -> Test_support.unsetenv "RESCRIPT_BSC_EXE") - (fun () -> - try - Format.run_files ~verbosity:0 ~check:false []; - None - with Format.Error message -> Some message) - in - check - (match message with - | Some message -> - contains message "RESCRIPT_BSC_EXE points to missing path" - | None -> false) - "format resolves the compiler before discovering implicit project files"); if not Sys.win32 then with_temp_dir (fun root -> let target = Filename.concat root "target.res" in @@ -88,25 +68,32 @@ let tests = && File_util.read_file target = "through hard link") "formatting should preserve hard-link identity"); with_temp_dir (fun root -> - let first = Filename.concat root "First.res" in - let second = Filename.concat root "Second.res" in - write_file first "let first = 1\n"; - write_file second "let second = 2\n"; - let previous_root = Sys.getenv_opt "REWATCH_FORMAT_TEST_ROOT" in - Unix.putenv "REWATCH_FORMAT_TEST_ROOT" root; - Fun.protect - ~finally:(fun () -> - match previous_root with - | Some value -> Unix.putenv "REWATCH_FORMAT_TEST_ROOT" value - | None -> Test_support.unsetenv "REWATCH_FORMAT_TEST_ROOT") - (fun () -> - Format.format_files_with_bsc ~max_jobs:2 - ~bsc:(Unix.realpath Sys.executable_name) - ~check:true [first; second]); + let unformatted = Filename.concat root "Unformatted.res" in + let formatted = Filename.concat root "Formatted.res" in + write_file unformatted "let first=1\n"; + write_file formatted (native "let second = 2\n"); + check + (try + Format.format_files ~check:true [unformatted; formatted]; + false + with Format.Error message -> message = "Formatting check failed") + "format --check reports a file that needs formatting"; check - (Sys.file_exists (first ^ ".started") - && Sys.file_exists (second ^ ".started")) - "formatter subprocesses overlap rather than running serially"); + (File_util.read_file unformatted = "let first=1\n") + "format --check leaves files unchanged"; + Format.format_files ~check:false [unformatted; formatted]; + check + (File_util.read_file unformatted = native "let first = 1\n" + && File_util.read_file formatted = native "let second = 2\n") + "the embedded formatter rewrites only files that need formatting"; + check + (try + write_file unformatted "let =\n"; + Format.format_files ~check:false [unformatted]; + false + with Format.Error message -> + contains message ("Error formatting " ^ unformatted)) + "syntax errors are reported with the source path"); with_temp_dir (fun root -> let root_source = Test_support.path root "src/App.res" in let orphan_interface = Test_support.path root "src/Orphan.resi" in @@ -118,46 +105,31 @@ let tests = write_file (Filename.concat root "rescript.json") {|{"name":"app","sources":[{"dir":"src","subdirs":true}],"dependencies":["installed"]}|}; - write_file root_source "let value = 1\n"; - write_file orphan_interface "let value: int\n"; - write_file duplicate_one "let value = 1\n"; - write_file duplicate_two "let value = 2\n"; + write_file root_source "let value=1\n"; + write_file orphan_interface "let value:int\n"; + write_file duplicate_one "let value=1\n"; + write_file duplicate_two "let value=1\n"; write_file (Test_support.path root "node_modules/installed/rescript.json") {|{"name":"installed","sources":["src"]}|}; - write_file installed_source "let value = 2\n"; + write_file installed_source "let value=1\n"; let previous = Sys.getcwd () in - let previous_bsc = Sys.getenv_opt "RESCRIPT_BSC_EXE" in - let previous_inventory_root = - Sys.getenv_opt "REWATCH_FORMAT_INVENTORY_TEST_ROOT" - in - let marker path = - Filename.concat root (Digest.string path |> Digest.to_hex) - in - Unix.putenv "RESCRIPT_BSC_EXE" (Unix.realpath Sys.executable_name); - Unix.putenv "REWATCH_FORMAT_INVENTORY_TEST_ROOT" root; Fun.protect - ~finally:(fun () -> - Unix.chdir previous; - (match previous_bsc with - | Some value -> Unix.putenv "RESCRIPT_BSC_EXE" value - | None -> Test_support.unsetenv "RESCRIPT_BSC_EXE"); - match previous_inventory_root with - | Some value -> Unix.putenv "REWATCH_FORMAT_INVENTORY_TEST_ROOT" value - | None -> Test_support.unsetenv "REWATCH_FORMAT_INVENTORY_TEST_ROOT") + ~finally:(fun () -> Unix.chdir previous) (fun () -> Unix.chdir root; - Format.run_files ~verbosity:0 ~check:true []); - check - (Sys.file_exists (marker root_source)) + Format.run_files ~verbosity:0 ~check:false []); + let formatted path = + File_util.read_file path = native "let value = 1\n" + in + check (formatted root_source) "implicit format includes the current package"; check - (Sys.file_exists (marker orphan_interface)) + (File_util.read_file orphan_interface = native "let value: int\n") "implicit format includes an orphan interface"; check - (Sys.file_exists (marker duplicate_one) - && Sys.file_exists (marker duplicate_two)) + (formatted duplicate_one && formatted duplicate_two) "implicit format does not impose compilation module uniqueness"; check - (not (Sys.file_exists (marker installed_source))) + (File_util.read_file installed_source = "let value=1\n") "implicit format does not rewrite installed node_modules dependencies") diff --git a/tests/rewatch_ounit_tests/rewatch_ounit_tests_main.ml b/tests/rewatch_ounit_tests/rewatch_ounit_tests_main.ml index d5111b250ed..3c44c09d626 100644 --- a/tests/rewatch_ounit_tests/rewatch_ounit_tests_main.ml +++ b/tests/rewatch_ounit_tests/rewatch_ounit_tests_main.ml @@ -11,6 +11,7 @@ let () = Cli_tests.tests; Compile_assets_tests.tests; Compiler_args_tests.tests; + Compiler_driver_tests.tests; Compiler_info_tests.tests; Compiler_process_tests.tests; Compiler_scheduler_tests.tests; diff --git a/tests/rewatch_ounit_tests/test_support.ml b/tests/rewatch_ounit_tests/test_support.ml index 2986c39d06f..3ccaa3202f8 100644 --- a/tests/rewatch_ounit_tests/test_support.ml +++ b/tests/rewatch_ounit_tests/test_support.ml @@ -9,6 +9,18 @@ let write_file path contents = ~finally:(fun () -> close_out_noerr channel) (fun () -> output_string channel contents) +let write_ast_header path ~dependencies ~source = + File_util.ensure_dir (Filename.dirname path); + let channel = open_out_bin path in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> + let dependency_block = "\n" ^ String.concat "\n" dependencies ^ "\n" in + output_binary_int channel (String.length dependency_block); + output_string channel dependency_block; + output_string channel source; + output_char channel '\n') + let path root relative = relative |> String.split_on_char '/' |> File_util.path_of_parts root diff --git a/tests/rewatch_ounit_tests/toolchain_tests.ml b/tests/rewatch_ounit_tests/toolchain_tests.ml index 1c77ab6982d..0630fd09df2 100644 --- a/tests/rewatch_ounit_tests/toolchain_tests.ml +++ b/tests/rewatch_ounit_tests/toolchain_tests.ml @@ -18,11 +18,11 @@ let tests = let executable = Filename.concat bin "rescript.exe" in write_file executable "test executable"; check - (Toolchain.sibling_bsc_candidate ~cwd:root ~executable + (Toolchain.bundled_bsc ~cwd:root ~executable = Filename.concat bin "bsc.exe") "absolute executable paths locate sibling bsc.exe"; check - (Toolchain.sibling_bsc_candidate ~cwd:root + (Toolchain.bundled_bsc ~cwd:root ~executable:(Filename.concat "bin" "rescript.exe") = Filename.concat bin "bsc.exe") "relative executable paths locate sibling bsc.exe"); diff --git a/tests/rewatch_ounit_tests/unit_tests.ml b/tests/rewatch_ounit_tests/unit_tests.ml index 053e132b1b2..58760b4d11a 100644 --- a/tests/rewatch_ounit_tests/unit_tests.ml +++ b/tests/rewatch_ounit_tests/unit_tests.ml @@ -2,10 +2,6 @@ open OUnit2 let check condition message = assert_bool message condition -module Checked_windows_platform : module type of Platform = Platform_windows - -type lazy_job = First | Second - let write_file = Test_support.write_file let read_file path = @@ -69,6 +65,14 @@ let () = while true do ignore (Unix.select [] [] [] 1.) done + | "--ppx-wait" -> + write_file (argument 2) (string_of_int (Unix.getpid ())); + Unix.sleepf 30.; + exit 0 + | "--ppx-copy" -> + write_file (argument 2) "started"; + write_file (argument 4) (read_file (argument 3)); + exit 0 | "--sleep" -> Thread.delay (float_of_string (argument 2)); exit 0 @@ -86,29 +90,6 @@ let () = write_file pending (Unix.getpid () |> string_of_int); Unix.rename pending marker; exit 0 - | "-format" -> ( - if Sys.win32 then set_binary_mode_out stdout true; - match - ( Sys.getenv_opt "REWATCH_FORMAT_TEST_ROOT", - Sys.getenv_opt "REWATCH_FORMAT_INVENTORY_TEST_ROOT" ) - with - | _, Some root -> - let source = argument 2 in - let marker = Digest.string source |> Digest.to_hex in - touch_file (Filename.concat root marker); - print_string (read_file source); - exit 0 - | None, None -> () - | Some root, None -> - let source = argument 2 in - touch_file - (Filename.concat root (Filename.basename source ^ ".started")); - let first_started = Filename.concat root "First.res.started" in - let second_started = Filename.concat root "Second.res.started" in - if not (wait_for_file first_started && wait_for_file second_started) - then exit 2; - print_string (read_file source); - exit 0) | _ -> () let test_executable () = Unix.realpath Sys.executable_name @@ -155,14 +136,15 @@ let process_parallel_tests _context = "parallel subprocess bound follows the available CPUs"; let completed_indices = ref [] in let parallel_results = - Process.run_parallel ~max_jobs:2 + Process.run_tasks ~max_jobs:2 ~on_complete:(fun index -> completed_indices := index :: !completed_indices) - [ - process_job ["--process-result"; "first"; ""; "0"]; - process_job ["--process-result"; "second"; ""; "0"]; - process_job ["--process-result"; "third"; ""; "0"]; - ] + (List.map Process.task + [ + process_job ["--process-result"; "first"; ""; "0"]; + process_job ["--process-result"; "second"; ""; "0"]; + process_job ["--process-result"; "third"; ""; "0"]; + ]) in check (List.map (fun (result : Process.result) -> result.stdout) parallel_results @@ -173,8 +155,9 @@ let process_parallel_tests _context = "parallel subprocess completion reports every input index once"; let recycled_handle_results = List.init 64 (fun index -> - process_job ["--process-result"; string_of_int index; ""; "0"]) - |> Process.run_parallel ~max_jobs:4 + Process.task + (process_job ["--process-result"; string_of_int index; ""; "0"])) + |> Process.run_tasks ~max_jobs:4 in check (List.mapi @@ -183,26 +166,6 @@ let process_parallel_tests _context = recycled_handle_results |> List.for_all Fun.id) "rapid subprocess completion cannot confuse recycled Windows handles"; - let lazy_root = Filename.temp_file "rewatch-lazy-jobs-" "" in - Sys.remove lazy_root; - Unix.mkdir lazy_root 0o755; - let lazy_results = - Fun.protect - ~finally:(fun () -> File_util.remove_tree lazy_root) - (fun () -> - Process.run_parallel_map ~max_jobs:2 [First; Second] ~job:(function - | First -> process_job ["--wait-for-release"; lazy_root] - | Second -> - check - (wait_for_file (Filename.concat lazy_root "child-started")) - "later job preparation overlaps an already-running child"; - touch_file (Filename.concat lazy_root "release"); - process_job ["--process-result"; "second"; ""; "0"])) - in - check - (List.map (fun (result : Process.result) -> result.stdout) lazy_results - = [""; "second"]) - "demand-built subprocess results retain input order"; let large_result = Process.run ~cwd:(Sys.getcwd ()) test_executable ["--large-process-result"] in @@ -213,7 +176,7 @@ let process_parallel_tests _context = "stdout and stderr pipes are drained concurrently without truncation"; let invalid_parallel_bound_rejected = try - ignore (Process.run_parallel ~max_jobs:0 []); + ignore (Process.run_tasks ~max_jobs:0 []); false with Process.Error _ -> true in @@ -223,6 +186,37 @@ let graph_work key dependencies = Process.{key; dependencies; value = key} let process_cancellation_tests _context = let test_executable = test_executable () in + let completed_request = + Process.{status = Unix.WEXITED 0; stdout = ""; stderr = ""} + in + let domain_interrupt_requested = Atomic.make false in + let second_domain_request_started = Atomic.make false in + let domain_cancelled = + try + ignore + (Process.run_tasks ~max_jobs:1 + ~poll:(fun () -> + if Atomic.get domain_interrupt_requested then + raise (Process.Interrupted 130)) + [ + Process.concurrent_task + ~cancel:(fun () -> ()) + ~on_result:(fun result -> + Atomic.set domain_interrupt_requested true; + result) + (fun () -> completed_request); + Process.concurrent_task + ~cancel:(fun () -> ()) + (fun () -> + Atomic.set second_domain_request_started true; + completed_request); + ]); + false + with Process.Interrupted 130 -> true + in + check + (domain_cancelled && not (Atomic.get second_domain_request_started)) + "an interrupt after a domain request stops the next request"; let cancellation_polls = ref 0 in let dependency_graph_cancelled = let exception Cancel in @@ -281,6 +275,33 @@ let process_cancellation_tests _context = in check process_cancelled "single subprocess cancellation terminates the active process"; + let concurrent_cancelled = Atomic.make false in + let concurrent_started = Atomic.make false in + let concurrent_task_cancelled = + let exception Cancel in + try + Process.run_dependency_graph ~max_jobs:1 + [graph_work "concurrent-cancel" []] + ~poll:(fun () -> if Atomic.get concurrent_started then raise Cancel) + ~next:(fun _ result -> + match result with + | Some _ -> None + | None -> + Some + (Process.concurrent_task + ~cancel:(fun () -> Atomic.set concurrent_cancelled true) + (fun () -> + Atomic.set concurrent_started true; + while not (Atomic.get concurrent_cancelled) do + Thread.delay 0.001 + done; + Process.{status = Unix.WEXITED 0; stdout = ""; stderr = ""}))); + false + with Cancel -> true + in + check + (concurrent_task_cancelled && Atomic.get concurrent_cancelled) + "dependency scheduler cancellation invokes active concurrent-task cleanup"; if not Sys.win32 then Test_support.with_temp_dir "rewatch-descendant-pipe-" (fun root -> let marker = Filename.concat root "parent-exiting" in @@ -374,6 +395,36 @@ let process_dependency_graph_tests _context = in check parallel_finalizers_completed "independent subprocess finalizers run before scheduler dispatch resumes"; + let concurrent_tasks_entered = Atomic.make 0 in + let concurrent_tasks_completed = + let exception Tasks_serialized in + try + Process.run_dependency_graph ~max_jobs:2 + [graph_work "concurrent-first" []; graph_work "concurrent-second" []] + ~next:(fun _ result -> + match result with + | Some _ -> None + | None -> + Some + (Process.concurrent_task + ~cancel:(fun () -> ()) + (fun () -> + ignore (Atomic.fetch_and_add concurrent_tasks_entered 1); + let deadline = Unix.gettimeofday () +. 2. in + while + Atomic.get concurrent_tasks_entered < 2 + && Unix.gettimeofday () < deadline + do + Thread.delay 0.001 + done; + if Atomic.get concurrent_tasks_entered < 2 then + raise Tasks_serialized; + Process.{status = Unix.WEXITED 0; stdout = ""; stderr = ""}))); + true + with Tasks_serialized -> false + in + check concurrent_tasks_completed + "independent concurrent tasks run on separate scheduler workers"; let graph_cycle_rejected = try Process.run_dependency_graph @@ -597,8 +648,8 @@ let scheduler_tests _context = } in let results = - Process.run_parallel ~max_jobs:2 - [job "first"; job "second"; job "third"] + Process.run_tasks ~max_jobs:2 + (List.map Process.task [job "first"; job "second"; job "third"]) in let _, helper_status = Unix.waitpid [] helper in check (helper_status = Unix.WEXITED 0) "scheduler test helper exits"; @@ -611,8 +662,11 @@ let scheduler_tests _context = = ["first"; "second"; "third"]) "dynamically scheduled results retain input order"; let failure = - Process.run_parallel ~max_jobs:1 - [process_job ["--process-result"; "partial"; "diagnostic"; "7"]] + Process.run_tasks ~max_jobs:1 + [ + Process.task + (process_job ["--process-result"; "partial"; "diagnostic"; "7"]); + ] |> List.hd in check @@ -922,7 +976,6 @@ let lock_tests _context = File_util.remove_file lock) let dependency_validation_tests _context = - let test_executable = test_executable () in let dependency_root = Filename.temp_file "rewatch-ocaml-allowed-dependents-" "" in @@ -939,44 +992,33 @@ let dependency_validation_tests _context = (List.fold_left Filename.concat dependency_root ["node_modules"; "restricted"; "rescript.json"]) {|{"name":"restricted","allowed-dependents":["other"]}|}; - let previous_bsc = Sys.getenv_opt "RESCRIPT_BSC_EXE" in - Unix.putenv "RESCRIPT_BSC_EXE" test_executable; - Fun.protect - ~finally:(fun () -> - match previous_bsc with - | Some value -> Unix.putenv "RESCRIPT_BSC_EXE" value - | None -> Test_support.unsetenv "RESCRIPT_BSC_EXE") - (fun () -> - let rejected = - try - Build.run - ~poll:(fun () -> ()) - ~verbosity:0 ~folder:dependency_root ~prod:false ~features:None - ~warn_error:None ~after_build:None ~filter:None ~no_timing:false; - false - with Project_context.Error message -> - if - Test_support.contains_text message - "app dependencies: restricted" - then true - else failwith ("unexpected allowed-dependents error: " ^ message) - in - check rejected "unallowed package dependency is rejected"; - write_file - (Filename.concat dependency_root "rescript.json") - {|{"name":"app","dev-dependencies":["restricted"]}|}; - let rejected = - try - Build.run - ~poll:(fun () -> ()) - ~verbosity:0 ~folder:dependency_root ~prod:false ~features:None - ~warn_error:None ~after_build:None ~filter:None ~no_timing:false; - false - with Project_context.Error message -> - Test_support.contains_text message - "app dev-dependencies: restricted" - in - check rejected "unallowed development dependency is rejected")) + let rejected = + try + Build.run + ~poll:(fun () -> ()) + ~verbosity:0 ~folder:dependency_root ~prod:false ~features:None + ~warn_error:None ~after_build:None ~filter:None ~no_timing:false; + false + with Project_context.Error message -> + if Test_support.contains_text message "app dependencies: restricted" + then true + else failwith ("unexpected allowed-dependents error: " ^ message) + in + check rejected "unallowed package dependency is rejected"; + write_file + (Filename.concat dependency_root "rescript.json") + {|{"name":"app","dev-dependencies":["restricted"]}|}; + let rejected = + try + Build.run + ~poll:(fun () -> ()) + ~verbosity:0 ~folder:dependency_root ~prod:false ~features:None + ~warn_error:None ~after_build:None ~filter:None ~no_timing:false; + false + with Project_context.Error message -> + Test_support.contains_text message "app dev-dependencies: restricted" + in + check rejected "unallowed development dependency is rejected") let tests = "unit_tests" diff --git a/tests/syntax_tests/res_test.ml b/tests/syntax_tests/res_test.ml index dadc9069bda..c245347566c 100644 --- a/tests/syntax_tests/res_test.ml +++ b/tests/syntax_tests/res_test.ml @@ -79,10 +79,10 @@ module Outcome_printer_tests = struct let signature_to_outcome structure = Lazy.force Res_outcome_printer.setup; - Clflags.include_dirs := - Filename.concat "lib" "ocaml" :: !Clflags.include_dirs; + (Clflags.current ()).include_dirs := + Filename.concat "lib" "ocaml" :: !((Clflags.current ()).include_dirs); Res_compmisc.init_path (); - Clflags.nopervasives := true; + (Clflags.current ()).nopervasives := true; let env = Res_compmisc.initial_env () in try let _typedStructure, signature, _newenv = diff --git a/tools/bin/main.ml b/tools/bin/main.ml index 763d29e51f6..0ec41f6b11c 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -142,7 +142,7 @@ let main () = let is_stdout = List.mem "--stdout" args in let transform_assert_equal = List.mem "--transform-assert-equal" args in let output_mode = if is_stdout then `Stdout else `File in - Clflags.color := Some Misc.Color.Never; + (Clflags.current ()).color := Some Misc.Color.Never; match ( Tools.Format_codeblocks.format_code_blocks_in_file ~output_mode ~transform_assert_equal ~entry_point_file:path, @@ -157,7 +157,7 @@ let main () = | ["-h"] | ["--help"] -> log_and_exit (Ok extract_codeblocks_help) | path :: args -> let transform_assert_equal = List.mem "--transform-assert-equal" args in - Clflags.color := Some Misc.Color.Never; + (Clflags.current ()).color := Some Misc.Color.Never; (* TODO: Add result/JSON mode *) Tools.Extract_codeblocks.extract_codeblocks_from_file