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/compiler-request-isolation.internal.md b/changes/compiler-request-isolation.internal.md new file mode 100644 index 00000000000..1290835e5cf --- /dev/null +++ b/changes/compiler-request-isolation.internal.md @@ -0,0 +1 @@ +- Make compiler requests safe to run repeatedly and in parallel in one process, as a preparation for compiling in-process in the OCaml build system. https://github.com/rescript-lang/rescript/pull/8864 diff --git a/changes/ppx-temp-file-cleanup.fix.md b/changes/ppx-temp-file-cleanup.fix.md new file mode 100644 index 00000000000..ce2b462d201 --- /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/8864 diff --git a/compiler/bsc/dune b/compiler/bsc/dune index 04520ffe793..0700fd697b6 100644 --- a/compiler/bsc/dune +++ b/compiler/bsc/dune @@ -3,10 +3,19 @@ (flags (:standard -ccopt -static)))) +(library + (name rescript_compiler_driver) + (wrapped false) + (modules rescript_compiler_driver) + (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..49880e5aa79 --- /dev/null +++ b/compiler/bsc/rescript_compiler_driver.ml @@ -0,0 +1,636 @@ +(***********************************************************************) +(* *) +(* 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 ~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 ~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 + +(* The temporary file is made absolute: a relative temporary directory names a + directory under the process's working directory, while a request resolves + relative paths against its own. *) +let eval (s : string) ~suffix = + let tmpfile = Filename.temp_file "eval" suffix in + let tmpfile = + if Filename.is_relative tmpfile then Filename.concat (Sys.getcwd ()) tmpfile + else tmpfile + in + Fun.protect + ~finally:(fun () -> + if not !((Clflags.current ()).verbose) then + try Sys.remove tmpfile with _ -> ()) + (fun () -> + Ext_io.write_file tmpfile s; + anonymous ~rev_args:[tmpfile]) + +(* 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 -> + (* Writers open paths under the root without resolving them against + the request's working directory, so make it absolute here. *) + let root = Ext_path.absolute_cwd_path s in + Ext_path.set_project_root root; + Gentype_config.project_root () := root), + "*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} + +(* Request_local gives every request the state of a new compiler process. + On top of that, a request needs bsc's own defaults, and allocates the shared + predefined type graphs in a fixed order: lazy first use on different worker + domains would otherwise shift serialized type IDs. *) +let start_request () = + Clflags.reset (); + 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; + (* Written past the formatter, which would count the PPX's + output as the current column and indent later errors. *) + Format.pp_print_flush (ppf ()) (); + Compiler_request_output.write_stderr 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..7b4b189cbf5 --- /dev/null +++ b/compiler/bsc/rescript_compiler_driver.mli @@ -0,0 +1,24 @@ +type result = {exit_code: int; stdout: string; stderr: string} + +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, with the command + line [bsc argv input]. [input] is the request's last argument: usually the + file to compile, but it can also be the value of a final option, as with + [-format]. 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 463fd73a63b..d88bb959d99 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -1,523 +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 ~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 ~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..063a85a668b 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; Unix.O_CLOEXEC] 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 6dde3d56d8f..be91fe50d66 100644 --- a/compiler/core/cmd_ppx_apply.ml +++ b/compiler/core/cmd_ppx_apply.ml @@ -27,18 +27,23 @@ 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 +(* Absolute, because the PPX runs in the request's directory while a relative + temporary directory names one below the process's. *) let temp_ppx_file () = - Filename.temp_file "ppx" (Filename.basename !Location.input_name) + let path = + Filename.temp_file "ppx" (Filename.basename (Location.get_input_name ())) + in + if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path + else path -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,52 +56,55 @@ 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 = let ic = open_in_bin fn in - let magic = Ml_binary.magic_of_kind kind in - let buffer = really_input_string ic (String.length magic) in - assert (buffer = magic); - (* already checked by apply_rewriter *) - Location.set_input_name @@ (input_value ic : string); - let ast0 = - match kind with - | Ml_binary.Ml -> Ml_binary.Impl (input_value ic : Parsetree0.structure) - | Ml_binary.Mli -> Ml_binary.Intf (input_value ic : Parsetree0.signature) - in - close_in ic; - ast0 + Fun.protect + ~finally:(fun () -> close_in_noerr ic) + (fun () -> + let magic = Ml_binary.magic_of_kind kind in + let buffer = really_input_string ic (String.length magic) in + assert (buffer = magic); + (* already checked by apply_rewriter *) + Location.set_input_name @@ (input_value ic : string); + match kind with + | Ml_binary.Ml -> Ml_binary.Impl (input_value ic : Parsetree0.structure) + | Ml_binary.Mli -> Ml_binary.Intf (input_value ic : Parsetree0.signature)) (** [ppxs] are a stack, [-ppx1 -ppx2 -ppx3] are stored as [-ppx3; -ppx2; -ppx1] [fold_right] happens to process the first one *) let rewrite kind ppxs ast = - let fn_in = temp_ppx_file () in - let ast0 = Ml_binary.to_ast0 kind ast in - write_ast fn_in ast0; - let temp_files = - List.fold_right - (fun ppx fns -> - match fns with - | [] -> assert false - | fn_in :: _ -> apply_rewriter kind fn_in ppx :: fns) - ppxs [fn_in] + (* 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 ~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 +114,9 @@ let apply_rewriters_str ~tool_name ast = |> Ast_mapper.drop_ppx_context_str let apply_rewriters_sig ~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 5276e47d20b..da4cd276d14 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..21887c64831 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -82,19 +82,25 @@ let make ~(values : cmj_value Map_string.t) ~hoisted_exports ~effect_ } (* Serialization .. *) +(* Channels are closed also when decoding fails: the compiler can run inside a + long-lived build process, which would otherwise keep the file open. *) let from_file name : t = - let ic = open_in_bin name in - let _digest = Digest.input ic in - let v : t = input_value ic in - close_in ic; - v + let ic = open_in_bin (Compiler_request_state.resolve_path name) in + Fun.protect + ~finally:(fun () -> close_in_noerr ic) + (fun () -> + let _digest = Digest.input ic in + (input_value ic : t)) let for_sure_not_changed (name : string) (header : string) = - if Sys.file_exists name then ( - let ic = open_in_bin name in - let holder = really_input_string ic Ext_digest.length in - close_in ic; - holder = header) + if Sys.file_exists (Compiler_request_state.resolve_path name) then + let ic = open_in_bin (Compiler_request_state.resolve_path name) in + Fun.protect + ~finally:(fun () -> close_in_noerr ic) + (fun () -> + match really_input_string ic Ext_digest.length with + | holder -> holder = header + | exception End_of_file -> false) else false (* This may cause some build system always rebuild @@ -104,11 +110,14 @@ let to_file name ~check_exists (v : t) = let s = Marshal.to_string v [] in let cur_digest = Digest.string s in let header = cur_digest in - if not (check_exists && for_sure_not_changed name header) then ( - let oc = open_out_bin name in - output_string oc header; - output_string oc s; - close_out oc) + if not (check_exists && for_sure_not_changed name header) then + let oc = open_out_bin (Compiler_request_state.resolve_path name) in + Fun.protect + ~finally:(fun () -> close_out_noerr oc) + (fun () -> + output_string oc header; + output_string oc s; + close_out oc) let key_comp a b = Ext_string.compare a b.name @@ -123,7 +132,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 bcfe61116e4..e0d3e3ae511 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, _) -> @@ -928,7 +928,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 d4008617d81..2b1719a2761 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")) @@ -66,15 +69,15 @@ let interface ~parser ppf ?outputprefix fname = parser fname |> Cmd_ppx_apply.apply_rewriters ~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) = @@ -101,21 +104,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 (); @@ -123,22 +130,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")) @@ -152,15 +162,17 @@ let implementation ~parser ppf ?outputprefix fname = parser fname |> Cmd_ppx_apply.apply_rewriters ~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 = @@ -174,8 +186,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; @@ -187,6 +199,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 12f3241d362..13330638622 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..e382ee17661 100644 --- a/compiler/depends/binary_ast.ml +++ b/compiler/depends/binary_ast.ml @@ -29,14 +29,15 @@ 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 dep_size = input_binary_int ic in - seek_in ic (pos_in ic + dep_size); - let sourcefile = input_line ic in - Location.set_input_name sourcefile; - let ast = input_value ic in - close_in ic; - ast + let ic = open_in_bin (Compiler_request_state.resolve_path fname) in + Fun.protect + ~finally:(fun () -> close_in_noerr ic) + (fun () -> + let dep_size = input_binary_int ic in + seek_in ic (pos_in ic + dep_size); + let sourcefile = input_line ic in + Location.set_input_name sourcefile; + input_value ic) let magic_sep_char = '\n' @@ -56,10 +57,13 @@ 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 - output_binary_int oc (Ext_buffer.length buf); - Ext_buffer.output_buffer oc buf; - output_string oc sourcefile; - output_char oc '\n'; - output_value oc pt; - close_out oc + let oc = open_out_bin (Compiler_request_state.resolve_path output) in + Fun.protect + ~finally:(fun () -> close_out_noerr oc) + (fun () -> + output_binary_int oc (Ext_buffer.length buf); + Ext_buffer.output_buffer oc buf; + output_string oc sourcefile; + output_char oc '\n'; + output_value oc pt; + close_out oc) diff --git a/compiler/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..ae1ac7ff39f --- /dev/null +++ b/compiler/ext/compiler_request_output.ml @@ -0,0 +1,168 @@ +(* One captured stream. Output collects in memory; a temporary file is created + only when a caller needs a real channel, which only compiler modes that + write a binary AST or JavaScript to stdout do. *) +type sink = { + prefix: string; + buffer: Buffer.t; + mutable file: (string * out_channel) option; +} + +type streams = { + stdout: sink; + stderr: sink; + 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 ()) + +(* A text-mode channel, like a bsc process's stdout and stderr, writes CRLF + line endings on Windows. A line that already ends in CRLF, such as a PPX's + output, keeps it. *) +let text_mode_line_endings ~win32 text = + if not win32 then text + else + let converted = Buffer.create (String.length text) in + String.iteri + (fun index character -> + if character = '\n' && (index = 0 || text.[index - 1] <> '\r') then + Buffer.add_char converted '\r'; + Buffer.add_char converted character) + text; + Buffer.contents converted + +(* The inverse, for text written to a text-mode channel, which adds the CR + itself: without it, a line that already ends in CRLF would get CR CR LF. *) +let text_mode_input ~win32 text = + if (not win32) || not (String.contains text '\r') then text + else + let converted = Buffer.create (String.length text) in + String.iteri + (fun index character -> + if + not + (character = '\r' + && index + 1 < String.length text + && text.[index + 1] = '\n') + then Buffer.add_char converted character) + text; + Buffer.contents converted + +let write_sink sink text position length = + match sink.file with + | Some (_, channel) -> + output_string channel + (text_mode_input ~win32:Sys.win32 (String.sub text position length)) + | None -> Buffer.add_substring sink.buffer text position length + +let sink_channel sink = + match sink.file with + | Some (_, channel) -> channel + | None -> + let path, channel = + Filename.open_temp_file ~mode:[Open_text] sink.prefix ".log" + in + (* Output written so far goes first. The channel is in text mode, so it + already converts line endings. *) + output_string channel + (text_mode_input ~win32:Sys.win32 (Buffer.contents sink.buffer)); + Buffer.clear sink.buffer; + sink.file <- Some (path, channel); + channel + +let sink_contents sink = + match sink.file with + | None -> + text_mode_line_endings ~win32:Sys.win32 (Buffer.contents sink.buffer) + | Some (path, channel) -> + close_out channel; + let input = open_in_bin path in + Fun.protect + (fun () -> really_input_string input (in_channel_length input)) + ~finally:(fun () -> close_in_noerr input) + +let close_sink sink = + match sink.file with + | None -> () + | Some (path, channel) -> + close_out_noerr channel; + (try Sys.remove path with Sys_error _ -> ()); + sink.file <- None + +let sink_formatter sink = + Format.make_formatter (write_sink sink) (fun () -> + Option.iter (fun (_, channel) -> flush channel) sink.file) + +let stdout_channel () = + match current () with + | Some streams -> sink_channel streams.stdout + | None -> Stdlib.stdout + +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 = + match current () with + | Some streams -> write_sink streams.stdout text 0 (String.length text) + | None -> output_string Stdlib.stdout text + +let write_stderr text = + match current () with + | Some streams -> write_sink streams.stderr text 0 (String.length text) + | None -> output_string Stdlib.stderr text + +(* Like print_endline and prerr_endline, a line printed outside a capture is + flushed: a subprocess the compiler runs next, such as a PPX, writes to the + same terminal. *) +let print_stdout text = + write_stdout (text ^ "\n"); + if not (is_active ()) then flush Stdlib.stdout + +let print_stderr text = + write_stderr (text ^ "\n"); + if not (is_active ()) then flush Stdlib.stderr + +exception Failed of {error: exn; stdout: string; stderr: string} + +let with_capture action = + let sink prefix = {prefix; buffer = Buffer.create 256; file = None} in + let stdout = sink "rescript-compiler-stdout-" in + let stderr = sink "rescript-compiler-stderr-" in + let streams = + { + stdout; + stderr; + stdout_formatter = sink_formatter stdout; + stderr_formatter = sink_formatter stderr; + } + in + let previous = current () in + Domain.DLS.set key (Some streams); + let contents () = + Format.pp_print_flush streams.stdout_formatter (); + Format.pp_print_flush streams.stderr_formatter (); + (sink_contents stdout, sink_contents stderr) + in + Fun.protect + (fun () -> + match action () with + | result -> + let stdout, stderr = contents () in + (result, stdout, stderr) + | exception error -> + let backtrace = Printexc.get_raw_backtrace () in + let stdout, stderr = contents () in + Printexc.raise_with_backtrace (Failed {error; stdout; stderr}) backtrace) + ~finally:(fun () -> + close_sink stdout; + close_sink stderr; + Domain.DLS.set key previous) diff --git a/compiler/ext/compiler_request_output.mli b/compiler/ext/compiler_request_output.mli new file mode 100644 index 00000000000..14a88a017f5 --- /dev/null +++ b/compiler/ext/compiler_request_output.mli @@ -0,0 +1,20 @@ +val stdout_channel : unit -> out_channel +(** A real channel for binary or bulk stdout output. While capturing, it is + backed by a temporary file, created on first use. *) + +val is_active : unit -> bool +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 in memory and restore its previous + streams. On Windows the captured text has CRLF line endings, as a bsc + process's output would. *) diff --git a/compiler/ext/compiler_request_state.ml b/compiler/ext/compiler_request_state.ml new file mode 100644 index 00000000000..db71341576e --- /dev/null +++ b/compiler/ext/compiler_request_state.ml @@ -0,0 +1,59 @@ +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_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_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..71e3bed64fd --- /dev/null +++ b/compiler/ext/compiler_request_state.mli @@ -0,0 +1,31 @@ +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_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..2bcfd95c8c5 --- /dev/null +++ b/compiler/ext/request_local.ml @@ -0,0 +1,37 @@ +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 = + (* [entries] lists the newest key first. Initialize in registration order, + which is module initialization order, so every request allocates its + fresh state the same way, and restore in reverse. *) + let restores = + List.fold_left + (fun restores fresh -> fresh () :: restores) + [] + (List.rev (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 38d5696e46c..9f5a1e67b9d 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 = @@ -874,12 +893,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..f19f783442c 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -235,8 +235,8 @@ 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; + (Clflags.current ()).color := Some Always; Lazy.force Res_outcome_printer.setup let error_of_exn e = @@ -270,7 +270,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 +504,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 +637,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 +647,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 +760,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 b1c8e151a3c..09619a640d3 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -644,20 +644,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}; (* The compiler doesn't read back the cookies a PPX sets. *) {lid = lid "cookies"; x = make_list Fun.id []; opt = false}; ] diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index 3301f0c5456..637be0b627e 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -38,11 +38,10 @@ let pivot_level = (2 * lowest_level) - 1 (**** Some type creators ****) -let new_id = ref (-1) - 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 +88,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 +426,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 +440,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 +630,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 +719,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 +746,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 +764,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 +784,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 @@ -804,3 +815,7 @@ let undo_compress (changes, _old) = r := !next | _ -> ()) log + +module For_test = struct + let memorized_abbrev_count () = List.length !(Domain.DLS.get memo) +end diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index d38d0a6f3f8..90d0e2cd3f2 100644 --- a/compiler/ml/btype.mli +++ b/compiler/ml/btype.mli @@ -246,3 +246,8 @@ val iter_type_expr_cstr_args : (type_expr -> unit) -> constructor_arguments -> unit val map_type_expr_cstr_args : (type_expr -> type_expr) -> constructor_arguments -> constructor_arguments + +module For_test : sig + val memorized_abbrev_count : unit -> int + (** The abbreviation expansions memorized on this domain. *) +end 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 af9e1003713..b32e92b1d83 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 (* set in Bs_conditional_initial *) - -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 (* -no-alias-deps *) -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 (* set in [reset] *); + 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 (* -no-alias-deps *); + 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 2bc9acba1d9..2844282e751 100644 --- a/compiler/ml/clflags.mli +++ b/compiler/ml/clflags.mli @@ -1,39 +1,44 @@ -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, and + by js_dump through [Js_config] *) + 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 - -(* Keep JSX in the output ([-bs-jsx-preserve]); read by translcore, and by - js_dump through [Js_config] *) -val jsx_preserve : bool ref - -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..92a71bd5989 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,11 +103,14 @@ 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 - output_string oc content; - output_value oc crcs; - output_value oc cmi.cmi_flags; - close_out oc; + let oc = open_out_bin (Compiler_request_state.resolve_path filename) in + Fun.protect + ~finally:(fun () -> close_out_noerr oc) + (fun () -> + output_string oc content; + output_value oc crcs; + output_value oc cmi.cmi_flags; + close_out oc); crc (* Error report *) diff --git a/compiler/ml/cmi_format.mli b/compiler/ml/cmi_format.mli index 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..3d79e206612 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 *) @@ -4312,3 +4385,7 @@ let get_arity env typ = match (expand_head env typ).desc with | Tarrow (params, _) -> Some (List.length params) | _ -> None + +module For_test = struct + let previous_env_is_empty () = !(previous_env ()) == Env.empty +end diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 908dc348df7..2b3087037f8 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -341,3 +341,9 @@ val variant_is_subtype : (Env.t -> Types.row_desc -> Types.type_expr -> bool) ref val get_arity : Env.t -> type_expr -> int option + +module For_test : sig + val previous_env_is_empty : unit -> bool + (** The environment of the last expansion on this domain is still the + initial empty one. *) +end 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 439f7c1c74e..fdd095ca773 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -58,9 +58,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 @@ -434,9 +432,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 461871acda1..8a5297a301b 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 @@ -1839,10 +1836,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 4d044c9316e..8934814cdeb 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1237,7 +1237,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.t = args; transformed_jsx = true; } as apply) - when !Clflags.jsx_preserve -> ( + when !((Clflags.current ()).jsx_preserve) -> ( match jsx_call e.exp_env funct p ~val_type args with | Some call -> check_callee_attributes funct; @@ -1535,10 +1535,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 2f61db72823..4f7abe3957e 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -106,7 +106,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 @@ -146,7 +148,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 @@ -154,9 +185,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} @@ -284,11 +315,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 @@ -334,13 +365,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) @@ -391,15 +422,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 @@ -451,33 +481,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 = @@ -1341,7 +1364,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 (); @@ -1667,7 +1690,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) -> @@ -1715,21 +1739,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 *) @@ -1737,8 +1761,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; @@ -1772,7 +1796,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 @@ -1808,17 +1832,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 @@ -1860,7 +1884,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 @@ -1873,7 +1897,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; @@ -1884,7 +1908,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; @@ -1895,7 +1919,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 @@ -2609,7 +2633,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 (); @@ -2618,7 +2643,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; } @@ -2747,7 +2772,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 @@ -2762,8 +2787,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 { @@ -3084,7 +3109,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; } @@ -3138,12 +3163,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 { @@ -3188,51 +3213,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 @@ -3240,7 +3269,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; @@ -3250,7 +3279,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 @@ -3258,7 +3287,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; } @@ -3311,7 +3340,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 @@ -3319,7 +3348,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; } @@ -3348,7 +3377,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 @@ -3356,7 +3385,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; } @@ -3544,7 +3573,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; }) @@ -3595,12 +3624,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 { @@ -3658,7 +3687,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; } @@ -4217,23 +4246,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})) @@ -4251,57 +4280,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) @@ -4605,7 +4652,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 @@ -4709,7 +4756,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 @@ -5008,7 +5055,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 08e1cb22d68..86cf86181af 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/packages/playground/playground_test.cjs b/packages/playground/playground_test.cjs index 6dc64bcf4f4..cf0726b3f5a 100644 --- a/packages/playground/playground_test.cjs +++ b/packages/playground/playground_test.cjs @@ -163,3 +163,13 @@ assert.equal(disabledResult.source_map, undefined); assert.doesNotMatch(disabledResult.js_code, /\/\/# sourceMappingURL=/); console.log("-- Playground source map test complete --"); + +// Error messages keep their ANSI color codes, which the playground renders, +// also without a terminal, as in a browser. +delete process.env.TERM; +const typeErrorResult = compiler.rescript.compile(`let x: int = "text"`); +assert.equal(typeErrorResult.type, "type_error"); +assert.match(typeErrorResult.errors[0].fullMsg, /\u001b\[/); +const syntaxErrorResult = compiler.rescript.compile("let = 1"); +assert.equal(syntaxErrorResult.type, "syntax_error"); +assert.match(syntaxErrorResult.errors[0].fullMsg, /\u001b\[/); diff --git a/tests/ounit_tests/dune b/tests/ounit_tests/dune index 3dd8febfaf0..9890b904453 100644 --- a/tests/ounit_tests/dune +++ b/tests/ounit_tests/dune @@ -11,4 +11,4 @@ (<> %{profile} browser)) (instrumentation (backend bisect_ppx)) - (libraries core gentype ounit2 analysis)) + (libraries core gentype ounit2 analysis rescript_compiler_driver unix)) diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index eb5322e1bd9..2130d516963 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -872,7 +872,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 @@ -1207,7 +1207,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_compiler_request_tests.ml b/tests/ounit_tests/ounit_compiler_request_tests.ml new file mode 100644 index 00000000000..eb7a8156892 --- /dev/null +++ b/tests/ounit_tests/ounit_compiler_request_tests.ml @@ -0,0 +1,1604 @@ +open OUnit + +(* Tests that each compiler request starts from fresh state and leaves the + state of the domain that runs it unchanged, for consecutive requests and + for requests on several domains at once. *) + +let check condition message = assert_bool message condition + +let rec ensure_dir path = + if not (Sys.file_exists path) then ( + ensure_dir (Filename.dirname path); + try Unix.mkdir path 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()) + +let write_file path contents = + ensure_dir (Filename.dirname path); + let channel = open_out_bin path in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> output_string channel contents) + +let read_file path = + let channel = open_in_bin path in + Fun.protect + ~finally:(fun () -> close_in_noerr channel) + (fun () -> really_input_string channel (in_channel_length channel)) + +let copy_existing_file source destination = + write_file destination (read_file source) + +let contains_text text fragment = + let text_length = String.length text in + let fragment_length = String.length fragment in + let rec from index = + index + fragment_length <= text_length + && (String.sub text index fragment_length = fragment || from (index + 1)) + in + from 0 + +let rec remove_tree path = + match (Unix.lstat path).st_kind with + | Unix.S_DIR -> + Array.iter + (fun name -> remove_tree (Filename.concat path name)) + (Sys.readdir path); + Unix.rmdir path + | _ -> Sys.remove path + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () + +(* The source path recorded in a binary AST written by -bs-ast: it follows the + length-prefixed dependency block. *) +let ast_source path = + let channel = open_in_bin path in + Fun.protect + ~finally:(fun () -> close_in_noerr channel) + (fun () -> + let dependencies = input_binary_int channel in + seek_in channel (pos_in channel + dependencies); + try Some (input_line channel) with End_of_file -> None) + +let with_temp_dir prefix action = + let path = Filename.temp_file prefix "" in + Sys.remove path; + Unix.mkdir path 0o755; + let path = Unix.realpath path in + Fun.protect ~finally:(fun () -> remove_tree path) (fun () -> action path) + +let request_local_counter = Request_local.new_key (fun () -> ref 0) + +(* Keys created in this order; their initializers record when they run. *) +let initialized = ref [] +let first_ordered_key = + Request_local.new_key (fun () -> initialized := "first" :: !initialized) +let second_ordered_key = + Request_local.new_key (fun () -> initialized := "second" :: !initialized) + +(* A fresh request initializes keys in the order they were created, which is + module initialization order. *) +let request_local_order_tests _ = + ignore first_ordered_key; + ignore second_ordered_key; + initialized := []; + Request_local.with_fresh (fun () -> ()); + assert_equal ~printer:(String.concat ", ") ["first"; "second"] + (List.rev !initialized) + +(* 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 + (contains_text 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" + +(* Captured text has a bsc process's line endings: CRLF on Windows, without + doubling the carriage return of output that already ends lines in CRLF, such + as a PPX's. *) +let captured_line_endings_tests _context = + let (), stdout, stderr = + Compiler_request_output.with_capture (fun () -> + Compiler_request_output.write_stdout "one\ntwo\n"; + Compiler_request_output.write_stderr "ppx line\r\nwarning\n") + in + if Sys.win32 then ( + assert_equal ~printer:String.escaped "one\r\ntwo\r\n" stdout; + assert_equal ~printer:String.escaped "ppx line\r\nwarning\r\n" stderr) + else ( + assert_equal ~printer:String.escaped "one\ntwo\n" stdout; + assert_equal ~printer:String.escaped "ppx line\r\nwarning\n" stderr); + (* The same holds once stdout is backed by a file, both for output written + before the switch and for output written after it. *) + let (), stdout, _ = + Compiler_request_output.with_capture (fun () -> + Compiler_request_output.write_stdout "before\r\nplain\n"; + ignore (Compiler_request_output.stdout_channel () : out_channel); + Compiler_request_output.write_stdout "after\r\n") + in + let newline = if Sys.win32 then "\r\n" else "\n" in + assert_equal ~printer:String.escaped + ("before\r\nplain" ^ newline ^ "after\r\n") + stdout + +(* Readers of compiler artifacts close their file when decoding fails, so a + long-lived build process does not keep it open. *) +let failed_decoding_closes_files_tests _context = + if Sys.file_exists "/proc/self/fd" then + with_temp_dir "rewatch-driver-decoding-" (fun root -> + let truncated = Filename.concat root "Truncated" in + write_file truncated "abc"; + let open_files () = Array.length (Sys.readdir "/proc/self/fd") in + let before = open_files () in + for _ = 1 to 20 do + (try ignore (Js_cmj_format.from_file truncated) with _ -> ()); + try + ignore + (Binary_ast.read_ast_exn ~fname:truncated Binary_ast.Ml + : Parsetree.structure) + with _ -> () + done; + assert_equal ~printer:string_of_int before (open_files ())) + +(* Writers of compiler artifacts close their file when writing fails, as on a + full disk. *) +let failed_writing_closes_files_tests _context = + if Sys.file_exists "/proc/self/fd" && Sys.file_exists "/dev/full" then ( + let open_files () = Array.length (Sys.readdir "/proc/self/fd") in + let before = open_files () in + let cmj = + Js_cmj_format.make ~values:Map_string.empty ~hoisted_exports:[] + ~effect_:None ~package_spec:Js_packages_info.empty + ~case:Ext_js_file_kind.Little + in + let cmi = + { + Cmi_format.cmi_name = "Full"; + cmi_sign = []; + cmi_crcs = []; + cmi_flags = []; + } + in + for _ = 1 to 20 do + (try Js_cmj_format.to_file "/dev/full" ~check_exists:false cmj + with Sys_error _ -> ()); + (try + Binary_ast.write_ast ~sourcefile:"Full.res" ~output:"/dev/full" + Binary_ast.Ml [] + with Sys_error _ -> ()); + try ignore (Cmi_format.create_cmi "/dev/full" cmi : Digest.t) + with Sys_error _ -> () + done; + assert_equal ~printer:string_of_int before (open_files ())) + +(* GenType finds a module's source relative to the request's working + directory, not the host process's. *) +let gentype_source_lookup_tests _context = + with_temp_dir "rewatch-driver-gentype-source-" (fun root -> + 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 = + with_temp_dir "rewatch-request-root-io-" (fun root -> + let first = Filename.concat root "first" in + let second = Filename.concat root "second" in + ensure_dir first; + ensure_dir second; + write_file (Filename.concat first "Input.res") "first"; + 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" (read_file (Filename.concat first "Output.txt")); + assert_equal "second" (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 () -> + 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; + 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 = 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 = + 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) + +(* A relative project root names a directory under the request's working + directory, not the host process's, for the JavaScript writer too. *) +let relative_project_root_tests _context = + with_temp_dir "rewatch-driver-relative-root-" (fun root -> + write root "Relative.res" "let relative = 1\n"; + let argv = + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + "."; + "-bs-package-name"; + "driver-test"; + "-bs-package-output"; + "commonjs:.:.js"; + "-bs-no-version-header"; + ] + in + let result = + Rescript_compiler_driver.run_request ~run_external:None ~cwd:root ~argv + ~input:"Relative.res" + in + expect_code 0 result; + check + (Sys.file_exists (Filename.concat root "Relative.js")) + "JavaScript is written under the request's directory"; + check + (not (Sys.file_exists "Relative.js")) + "JavaScript is not written under the host's directory") + +(* -e writes its source to a temporary file. With a relative temporary + directory, which names a directory under the host's working directory, the + file is still found and removed when the request runs elsewhere. *) +let eval_relative_temp_dir_tests _context = + with_temp_dir "rewatch-driver-eval-root-" (fun root -> + with_temp_dir "rewatch-driver-eval-host-" (fun host -> + let temp = Filename.concat host "tmp" in + Unix.mkdir temp 0o755; + let previous_cwd = Sys.getcwd () in + let previous_temp = Filename.get_temp_dir_name () in + Sys.chdir host; + Filename.set_temp_dir_name "tmp"; + let result = + Fun.protect + ~finally:(fun () -> + Filename.set_temp_dir_name previous_temp; + Sys.chdir previous_cwd) + (fun () -> + Rescript_compiler_driver.run_request ~run_external:None + ~cwd:root + ~argv: + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + root; + "-bs-package-name"; + "driver-test"; + "-bs-no-version-header"; + "-e"; + ] + ~input:"let value = 1") + in + if result.exit_code <> 0 then + assert_failure (result.stdout ^ result.stderr); + check + (not + (Array.exists + (fun name -> Filename.check_suffix name ".res") + (Sys.readdir temp))) + "the -e source file is removed")) + +let recovery_tests _context = + 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 + (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 + (contains_text failed.stderr "int" + && 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 = + 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 + (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 :: _ -> + copy_existing_file input output; + (0, "", "") + | _ -> (2, "", "could not decode test PPX command"))) + in + expect_code 0 repaired; + check + (contains_text repaired.stderr "+ rewatch-test-ppx") + "direct verbose output is returned through the request boundary") + +let control_flow_and_output_tests _context = + 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 + (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 + (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 + (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 + (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 + (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 = + 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 + (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 + (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 = + with_temp_dir "rewatch-driver-ctype-" (fun root -> + write root "Lib.res" "type t = int\n"; + expect_code 0 (snd (run root "Lib.res")); + let memorized = Btype.For_test.memorized_abbrev_count () in + (* A failing request stops before it would flush the memo itself. *) + write root "Bad.res" "let value: Lib.t = \"text\"\n"; + expect_code 2 (snd (run root ~extra:["-I"; root] "Bad.res")); + assert_equal ~printer:string_of_int memorized + (Btype.For_test.memorized_abbrev_count ()) + ~msg:"abbreviation expansions do not outlive their request"; + check + (Ctype.For_test.previous_env_is_empty ()) + "the expansion environment does not outlive its request") + +let package_and_load_path_isolation_tests _context = + with_temp_dir "rewatch-driver-load-roots-" (fun root -> + let first = Filename.concat root "first" in + let second = Filename.concat root "second" in + ensure_dir first; + 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 = + 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 = + 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; + 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; + (* Saved types in the CMI get fresh ids, so only the CMT shows type-node + ids that continue from the host's counter. *) + let artifacts = ["Objects.cmi"; "Objects.cmt"] in + let read_artifacts () = + List.map + (fun name -> + let contents = read_file (Filename.concat root name) in + check (String.length contents > 0) (name ^ " output is nonempty"); + contents) + artifacts + in + let first_artifacts = read_artifacts () in + for _ = 1 to 1000 do + ignore (Btype.newgenvar ()) + done; + List.iter (fun name -> Sys.remove (Filename.concat root name)) artifacts; + let _, repeated_objects = run root "Objects.res" in + expect_code 0 repeated_objects; + List.iter2 + (fun name (first, repeated) -> + assert_equal + ~printer:(fun _ -> "") + first repeated) + artifacts + (List.combine first_artifacts (read_artifacts ())); + Lambda_exits.reset ()) + +let interface_namespace_and_load_path_tests _context = + 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 = + with_temp_dir "rewatch-driver-errors-" (fun root -> + let first = Filename.concat root "first" in + let second = Filename.concat root "second" in + ensure_dir first; + 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 = + 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 + 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 + (contains_text 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 = + with_temp_dir "rewatch-driver-domains-" (fun root -> + let first = Filename.concat root "first" in + let second = Filename.concat root "second" in + ensure_dir first; + 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 :: _ -> + 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_source (Filename.concat first "First.ast") + = Some (Filename.concat first "First.res")) + "-absname retains an absolute source path during concurrent parsing"; + check + (ast_source (Filename.concat second "Second.ast") = Some "Second.res") + "a concurrent parser without -absname retains its relative source path") + +let concurrent_async_context_tests _context = + 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 + 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 suites = + __FILE__ + >::: [ + "request_local" >:: request_local_tests; + "request_local_order" >:: request_local_order_tests; + "failed_capture" >:: failed_capture_tests; + "captured_line_endings" >:: captured_line_endings_tests; + "failed_decoding_closes_files" >:: failed_decoding_closes_files_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; + "relative_project_root" >:: relative_project_root_tests; + "failed_writing_closes_files" >:: failed_writing_closes_files_tests; + "eval_relative_temp_dir" >:: eval_relative_temp_dir_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/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 872a68d0363..cbed5fa9a10 100644 --- a/tests/ounit_tests/ounit_lambda_constant_tests.ml +++ b/tests/ounit_tests/ounit_lambda_constant_tests.ml @@ -295,7 +295,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_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index 40d52bd8329..9db0f4674aa 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -34,6 +34,7 @@ let suites = Ounit_ffi_inclusion_tests.suites; Ounit_typeopt_tests.suites; Ounit_gentype_tests.suites; + Ounit_compiler_request_tests.suites; ] let _ = OUnit.run_test_tt_main suites 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/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