diff options
176 files changed, 2578 insertions, 1510 deletions
@@ -2116,26 +2116,26 @@ asmcomp/asmpackager.cmi : \ asmcomp/branch_relaxation.cmo : \ utils/misc.cmi \ asmcomp/mach.cmi \ - asmcomp/linearize.cmi \ + asmcomp/linear.cmi \ asmcomp/cmm.cmi \ asmcomp/branch_relaxation_intf.cmo \ asmcomp/branch_relaxation.cmi asmcomp/branch_relaxation.cmx : \ utils/misc.cmx \ asmcomp/mach.cmx \ - asmcomp/linearize.cmx \ + asmcomp/linear.cmx \ asmcomp/cmm.cmx \ asmcomp/branch_relaxation_intf.cmx \ asmcomp/branch_relaxation.cmi asmcomp/branch_relaxation.cmi : \ - asmcomp/linearize.cmi \ + asmcomp/linear.cmi \ asmcomp/branch_relaxation_intf.cmo asmcomp/branch_relaxation_intf.cmo : \ - asmcomp/linearize.cmi \ + asmcomp/linear.cmi \ asmcomp/cmm.cmi \ asmcomp/arch.cmo asmcomp/branch_relaxation_intf.cmx : \ - asmcomp/linearize.cmx \ + asmcomp/linear.cmx \ asmcomp/cmm.cmx \ asmcomp/arch.cmx asmcomp/cmm.cmo : \ @@ -2279,7 +2279,7 @@ asmcomp/emit.cmo : \ asmcomp/proc.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ - asmcomp/linearize.cmi \ + asmcomp/linear.cmi \ lambda/lambda.cmi \ asmcomp/emitaux.cmi \ utils/domainstate.cmi \ @@ -2301,7 +2301,7 @@ asmcomp/emit.cmx : \ asmcomp/proc.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ - asmcomp/linearize.cmx \ + asmcomp/linear.cmx \ lambda/lambda.cmx \ asmcomp/emitaux.cmx \ utils/domainstate.cmx \ @@ -2314,7 +2314,7 @@ asmcomp/emit.cmx : \ asmcomp/arch.cmx \ asmcomp/emit.cmi asmcomp/emit.cmi : \ - asmcomp/linearize.cmi \ + asmcomp/linear.cmi \ asmcomp/cmm.cmi asmcomp/emitaux.cmo : \ lambda/debuginfo.cmi \ @@ -2359,12 +2359,32 @@ asmcomp/interval.cmx : \ asmcomp/interval.cmi : \ asmcomp/reg.cmi \ asmcomp/mach.cmi +asmcomp/linear.cmo : \ + asmcomp/reg.cmi \ + asmcomp/mach.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ + asmcomp/cmm.cmi \ + asmcomp/linear.cmi +asmcomp/linear.cmx : \ + asmcomp/reg.cmx \ + asmcomp/mach.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ + asmcomp/cmm.cmx \ + asmcomp/linear.cmi +asmcomp/linear.cmi : \ + asmcomp/reg.cmi \ + asmcomp/mach.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/linearize.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ - lambda/lambda.cmi \ + asmcomp/linear.cmi \ lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ @@ -2374,17 +2394,14 @@ asmcomp/linearize.cmx : \ asmcomp/proc.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ - lambda/lambda.cmx \ + asmcomp/linear.cmx \ lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ asmcomp/linearize.cmi asmcomp/linearize.cmi : \ - asmcomp/reg.cmi \ asmcomp/mach.cmi \ - lambda/lambda.cmi \ - lambda/debuginfo.cmi \ - asmcomp/cmm.cmi + asmcomp/linear.cmi asmcomp/linscan.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ @@ -2480,19 +2497,19 @@ asmcomp/printcmm.cmi : \ asmcomp/printlinear.cmo : \ asmcomp/printmach.cmi \ asmcomp/mach.cmi \ - asmcomp/linearize.cmi \ + asmcomp/linear.cmi \ lambda/lambda.cmi \ lambda/debuginfo.cmi \ asmcomp/printlinear.cmi asmcomp/printlinear.cmx : \ asmcomp/printmach.cmx \ asmcomp/mach.cmx \ - asmcomp/linearize.cmx \ + asmcomp/linear.cmx \ lambda/lambda.cmx \ lambda/debuginfo.cmx \ asmcomp/printlinear.cmi asmcomp/printlinear.cmi : \ - asmcomp/linearize.cmi + asmcomp/linear.cmi asmcomp/printmach.cmo : \ asmcomp/debug/reg_availability_set.cmi \ asmcomp/reg.cmi \ @@ -2593,7 +2610,7 @@ asmcomp/schedgen.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ asmcomp/mach.cmi \ - asmcomp/linearize.cmi \ + asmcomp/linear.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ asmcomp/arch.cmo \ @@ -2602,14 +2619,14 @@ asmcomp/schedgen.cmx : \ asmcomp/reg.cmx \ asmcomp/proc.cmx \ asmcomp/mach.cmx \ - asmcomp/linearize.cmx \ + asmcomp/linear.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ asmcomp/arch.cmx \ asmcomp/schedgen.cmi asmcomp/schedgen.cmi : \ asmcomp/mach.cmi \ - asmcomp/linearize.cmi + asmcomp/linear.cmi asmcomp/scheduling.cmo : \ asmcomp/schedgen.cmi \ asmcomp/scheduling.cmi @@ -2617,7 +2634,7 @@ asmcomp/scheduling.cmx : \ asmcomp/schedgen.cmx \ asmcomp/scheduling.cmi asmcomp/scheduling.cmi : \ - asmcomp/linearize.cmi + asmcomp/linear.cmi asmcomp/selectgen.cmo : \ lambda/simplif.cmi \ asmcomp/reg.cmi \ @@ -5476,7 +5493,7 @@ asmcomp/debug/compute_ranges.cmo : \ asmcomp/printlinear.cmi \ utils/numbers.cmi \ utils/misc.cmi \ - asmcomp/linearize.cmi \ + asmcomp/linear.cmi \ utils/int_replace_polymorphic_compare.cmi \ asmcomp/debug/compute_ranges_intf.cmo \ asmcomp/cmm.cmi \ @@ -5485,7 +5502,7 @@ asmcomp/debug/compute_ranges.cmx : \ asmcomp/printlinear.cmx \ utils/numbers.cmx \ utils/misc.cmx \ - asmcomp/linearize.cmx \ + asmcomp/linear.cmx \ utils/int_replace_polymorphic_compare.cmx \ asmcomp/debug/compute_ranges_intf.cmx \ asmcomp/cmm.cmx \ @@ -5494,11 +5511,11 @@ asmcomp/debug/compute_ranges.cmi : \ asmcomp/debug/compute_ranges_intf.cmo asmcomp/debug/compute_ranges_intf.cmo : \ utils/numbers.cmi \ - asmcomp/linearize.cmi \ + asmcomp/linear.cmi \ utils/identifiable.cmi asmcomp/debug/compute_ranges_intf.cmx : \ utils/numbers.cmx \ - asmcomp/linearize.cmx \ + asmcomp/linear.cmx \ utils/identifiable.cmx asmcomp/debug/reg_availability_set.cmo : \ asmcomp/debug/reg_with_debug_info.cmi \ @@ -8,6 +8,14 @@ Working version - #7557, #1726: multi-indices for extended indexing operators (Florian Angeletti, review by Gabriel Radanne) +* #1859: --enable-force-safe-string is now the default. This can be + overridden at configure time only (introduced by 4.04 in 2016). + Unless --disable-force-safe-string is used at configure time, this + breaks code that use the '-unsafe-string' argument and C stubs that + use String_val as a char* instead of const char* + (Kate Deplaix) + + ### Internal/compiler-libs changes: - #8844: Printing faulty constructors, inline records fields and their types @@ -25,6 +33,10 @@ Working version - #1901: Fix lexing of character literals in comments (Pieter Goetschalckx, review by Damien Doligez) +- #1932: Allow octal escape sequences and identifiers containing apostrophes + in ocamlyacc actions and comments. + (Pieter Goetschalckx, review by Damien Doligez) + - #2288: Move middle end code from [Asmgen] to [Clambda_middle_end] and [Flambda_middle_end]. Run [Un_anf] from the middle end, not [Cmmgen]. (Mark Shinwell, review by Pierre Chambart) @@ -48,6 +60,16 @@ Working version - #8890: in -dtimings output, show time spent in C linker clearly (Valentin Gatien-Baron) +- #8910, #8911: minor improvements to the printing of module types + (Gabriel Scherer, review by Florian Angeletti) + +- #8913: ocamltest: improve 'promote' implementation to take + skipped lines/bytes into account + (Gabriel Scherer, review by Sébastien Hinderer) + +- #8928: Move contains_calls and num_stack_slots from Proc to Mach.fundecl + (Greta Yorsh, review by Florian Angeletti and Vincent Laviron) + ### Code generation and optimizations: - #8672: Optimise Switch code generation on booleans. @@ -67,6 +89,9 @@ Working version - #2321: Eliminate dead ICatch handlers (Greta Yorsh, review by Pierre Chambart and Vincent Laviron) +- #8919: lift mutable lets along with immutable ones + (Leo White, review by Pierre Chambart) + ### Runtime system: - #8619: Ensure Gc.minor_words remains accurate after a GC. @@ -77,7 +102,7 @@ Working version OCaml heap. (Jacques-Henri Jourdan, review by Damien Doligez) -- #8691: Allocation functions are now guaranteed not to trigger any +- #8691, #8897: Allocation functions are now guaranteed not to trigger any OCaml callback when called from C. (Jacques-Henri Jourdan, review by Stephen Dolan and Gabriel Scherer) @@ -100,15 +125,18 @@ Working version ### Standard library: +- #8832: List.find_map : ('a -> 'b option) -> 'a list -> 'b option + (Gabriel Scherer, review by Jeremy Yallop, Nicolás Ojeda Bär + and Daniel Bünzli) + - #8657: Optimization in [Array.make] when initializing with unboxed or young values. (Jacques-Henri Jourdan, review by Gabriel Scherer and Stephen Dolan) - #8634: Statistical memory profiling provided by the Gc.Memprof module. - Incomplete version: does not sample - - objects allocated in the minor heap in native mode, - - objects allocated by de-marshalling. + Incomplete version: does not sample objects allocated in the minor + heap in native mode (Jacques-Henri Jourdan, review by Stephen Dolan, Gabriel Scherer and Damien Doligez) @@ -128,6 +156,12 @@ Working version - #1939, #2023: Implement Unix.truncate and Unix.ftruncate on Windows. (Florent Monnier and Nicolás Ojeda Bär, review by David Allsopp) +### Manual and documentation: + +- #8950: manual, move local opens in pattern out of the extension chapter + (Florian Angeletti, review and suggestion by Gabriel Scherer) + + ### Compiler user-interface and warnings: - #8833: Hint for (type) redefinitions in toplevel session @@ -141,6 +175,9 @@ Working version has been defined as private (Leo White, review by Thomas Refis) +- #8885: Warn about unused local modules + (Thomas Refis, review by Alain Frisch) + ### Build system: - #8650: ensure that "make" variables are defined before use; @@ -152,9 +189,17 @@ Working version (Stephen Dolan, review by Gabriel Scherer, Sébastien Hinderer and Thomas Refis) +- #8837: build manpages using ocamldoc.opt when available + cuts the manpages build time from 14s to 4s + (Gabriel Scherer, review by David Allsopp and Sébastien Hinderer, + report by David Allsopp) + - #8843, #8841: fix use of off_t on 32-bit systems. (Stephen Dolan, report by Richard Jones, review by Xavier Leroy) +- #8947: fix/improve support for the BFD library + (Sébastien Hinderer, review by Damien Doligez) + ### Compiler user-interface and warnings: - #8702, #8777: improved error messages for fixed row polymorphic variants @@ -164,8 +209,16 @@ Working version pretty-printing boxes. (Oxana Kostikova, review by Gabriel Scherer) +- #8914: clarify the warning on unboxable types used in external primitives (61) + (Gabriel Scherer, review by Florian Angeletti, report on the Discourse forum) + ### Bug fixes: +- #7925, #8611: fix error highlighting for exceptionally + long toplevel phrases + (Kyle Miller, reported by Armaël Guéneau, review by Armaël Guéneau + and Nicolás Ojeda Bär) + - #8622: Don't generate #! headers over 127 characters. (David Allsopp, review by Xavier Leroy and Stephen Dolan) @@ -174,35 +227,86 @@ Working version (Gabriel Scherer and Florian Angeletti, review by Florian Angeletti and Gabriel Radanne) -- #8862, #8871: subst: preserve scopes - (Thomas Refis, report by Leo White) - - #8875: fix missing newlines in the output from MSVC invocation. (Nicolás Ojeda Bär, review by Gabriel Scherer) -OCaml 4.09.0 ------------- +- #8921, #8924: Fix stack overflow with Flambda + (Vincent Laviron, review by Pierre Chambart and Leo White, + report by Aleksandr Kuzmenko) -### Code generation and optimizations: +OCaml 4.09 maintenance branch: +------------------------------ -- #2278: Remove native code generation support for 32-bit Intel macOS, - iOS and other Darwin targets. - (Mark Shinwell, review by Nicolas Ojeda Bar and Xavier Leroy) +- #8953, #8954: Fix error submessages in the toplevel: do not display + dummy locations + (Armaël Guéneau, review by Gabriel Scherer) -- #8507: Shorten symbol names of anonymous functions in Flambda mode - (the directory portions are now hidden) - (Mark Shinwell, review by Nicolás Ojeda Bär) +OCaml 4.09.0 (19 September 2019): +--------------------------------- -- #7931, #1904: Add FreeBSD/aarch64 support - (Greg V, review by Sébastien Hinderer, Stephen Dolan, Damien Doligez - and Xavier Leroy) +### Runtime system: -- #8547: Optimize matches that are an affine function of the input. - (Stefan Muenzel, review by Alain Frisch, Gabriel Scherer) +* #1725, #2279: Deprecate Obj.set_tag and Obj.truncate + (Stephen Dolan, review by Gabriel Scherer, Damien Doligez and Xavier Leroy) -- #8681, #8699, #8712: Fix code generation with nested let rec of functions. - (Stephen Dolan, Leo White, Gabriel Scherer and Pierre Chambart, - review by Gabriel Scherer, reports by Alexey Solovyev and Jonathan French) +* #2240: Constify "identifier" in struct custom_operations + (Cedric Cellier, review by Xavier Leroy) + +* #2293: Constify "caml_named_value" + (Stephen Dolan, review by Xavier Leroy) + +- #8787, #8788: avoid integer overflow in caml_output_value_to_bytes + (Jeremy Yallop, report by Marcello Seri) + + +- #2075, #7729: rename _T macro used to support Unicode in the (Windows) runtime + in order to avoid compiler warning + (Nicolás Ojeda Bär, review by Gabriel Scherer and David Allsopp) + +- #2250: Remove extra integer sign-extension in compare functions + (Stefan Muenzel, review by Xavier Leroy) + +- #8607: Remove obsolete macros for pre-2002 MSVC support + (Stephen Dolan, review by Nicolás Ojeda Bär and David Allsopp) + +- #8656: Fix a bug in [caml_modify_generational_global_root] + (Jacques-Henri Jourdan, review by Gabriel Scherer) + +### Standard library: + +- #2262: take precision (.<n>) and flags ('+' and ' ') into account + in printf %F + (Pierre Roux, review by Gabriel Scherer) + +- #6148, #8596: optimize some buffer operations + (Damien Doligez, reports by John Whitington and Alain Frisch, + review by Jeremy Yallop and Gabriel Scherer) + +### Other libraries: + +* #2318: Delete the graphics library. This library is now available + as a separate "graphics" package in opam. Its new home is: + https://github.com/ocaml/graphics + (Jérémie Dimino, review by Nicolas Ojeda Bar, Xavier Leroy and + Sébastien Hinderer) + +* #2289: Delete the vmthreads library. This library was deprecated in 4.08.0. + (Jérémie Dimino) + +- #2112: Fix Thread.yield unfairness with busy threads yielding to each + other. + (Andrew Hunter, review by Jacques-Henri Jourdan, Spiros Eliopoulos, Stephen + Weeks, & Mark Shinwell) + +- #7903, #2306: Make Thread.delay interruptible by signals again + (Xavier Leroy, review by Jacques-Henri Jourdan and Edwin Török) + +- #2248: Unix alloc_sockaddr: Fix read of uninitialized memory for an + unbound Unix socket. Add support for receiving abstract (Linux) socket paths. + (Tim Cuthbertson, review by Sébastien Hinderer and Jérémie Dimino) + +- #2165: better unboxing heuristics for let-bound identifiers + (Alain Frisch, review by Vincent Laviron and Gabriel Scherer) ### Compiler user-interface and warnings: @@ -215,18 +319,24 @@ OCaml 4.09.0 (Jules Aguillon, review by Nicolás Ojeda Bär , Florian Angeletti, Gabriel Scherer and Armaël Guéneau) -- #2307: Hint on type error on int's operators - (Jules Aguillon, with help from Armaël Guéneau, - review by Gabriel Scherer and Florian Angeletti) +* #2314: Remove support for gprof profiling. + (Mark Shinwell, review by Xavier Clerc and Stephen Dolan) + +- #2190: fix pretty printing (using Pprintast) of "lazy ..." patterns and + "fun (type t) -> ..." expressions. + (Nicolás Ojeda Bär, review by Gabriel Scherer) + +- #2277: Use newtype names as type variable names + The inferred type of (fun (type t) (x : t) -> x) + is now printed as ('t -> 't) rather than ('a -> 'a). + (Matthew Ryan) + - #2309: New options -with-runtime and -without-runtime in ocamlopt/ocamlc that control the inclusion of the runtime system in the generated program. (Lucas Pluvinage, review by Daniel Bünzli, Damien Doligez, David Allsopp and Florian Angeletti) -- #2314: Remove support for gprof profiling. - (Mark Shinwell, review by Xavier Clerc and Stephen Dolan) - - #3819, #8546 more explanations and tests for illegal permutation (Florian Angeletti, review by Gabriel Scherer) @@ -240,14 +350,46 @@ OCaml 4.09.0 of an extensible variant type (Guillaume Bury, review by many fine eyes) -### Compiler distribution build system: +### Code generation and optimizations: -- #2267: merge generation of header programs, also fixing parallel build on - Cygwin. - (David Allsopp, review by Sébastien Hinderer) +- #2278: Remove native code generation support for 32-bit Intel macOS, + iOS and other Darwin targets. + (Mark Shinwell, review by Nicolas Ojeda Bar and Xavier Leroy) -- #8514: Use boot/ocamlc.opt for building, if available. - (Stephen Dolan, review by Gabriel Scherer) +- #8547: Optimize matches that are an affine function of the input. + (Stefan Muenzel, review by Alain Frisch, Gabriel Scherer) + + +- #1904, #7931: Add FreeBSD/aarch64 support + (Greg V, review by Sébastien Hinderer, Stephen Dolan, Damien Doligez + and Xavier Leroy) + +- #8507: Shorten symbol names of anonymous functions in Flambda mode + (the directory portions are now hidden) + (Mark Shinwell, review by Nicolás Ojeda Bär) + +- #8681, #8699, #8712: Fix code generation with nested let rec of functions. + (Stephen Dolan, Leo White, Gabriel Scherer and Pierre Chambart, + review by Gabriel Scherer, reports by Alexey Solovyev and Jonathan French) + +### Manual and documentation: + +- #7584, #8538: Document .cmt* files in the "overview" of ocaml{c,opt} + (Oxana Kostikova, rewiew by Florian Angeletti) + + +- #8757: Rename Pervasives to Stdlib in core library documentation. + (Ian Zimmerman, review by David Allsopp) + +- #8515: manual, precise constraints on reexported types + (Florian Angeletti, review by Gabriel Scherer) + +### Tools: + +- #2221: ocamldep will now correctly allow a .ml file in an include directory + that appears first in the search order to shadow a .mli appearing in a later + include directory. + (Nicolás Ojeda Bär, review by Florian Angeletti) ### Internal/compiler-libs changes: @@ -260,10 +402,6 @@ OCaml 4.09.0 - #1973: fix compilation of catches with multiple handlers (Vincent Laviron) -- #2190: fix pretty printing (using Pprintast) of "lazy ..." patterns and - "fun (type t) -> ..." expressions. - (Nicolás Ojeda Bär, review by Gabriel Scherer) - - #2228, #8545: refactoring the handling of .cmi files by moving the logic from Env to a new module Persistent_env (Gabriel Scherer, review by Jérémie Dimino and Thomas Refis) @@ -282,9 +420,6 @@ OCaml 4.09.0 into the Dynlink libraries (Mark Shinwell, Stephen Dolan, review by David Allsopp) -- #2277: Use newtype names as type variable names - (Matthew Ryan) - - #2280: Don't make more Clambda constants after starting Cmmgen (Mark Shinwell, review by Vincent Laviron) @@ -320,98 +455,42 @@ OCaml 4.09.0 (Thomas Refis, review by David Allsopp, Florian Angeletti, Gabriel Radanne, Gabriel Scherer and Xavier Leroy) -### Runtime system: - -- #1725, #2279: Deprecate Obj.set_tag and Obj.truncate - (Stephen Dolan, review by Gabriel Scherer, Damien Doligez and Xavier Leroy) - -- #2075, #7729: rename _T macro used to support Unicode in the (Windows) runtime - in order to avoid compiler warning - (Nicolás Ojeda Bär, review by Gabriel Scherer and David Allsopp) - -* #2240: Constify "identifier" in struct custom_operations - (Cedric Cellier, review by Xavier Leroy) - -- #2250: Remove extra integer sign-extension in compare functions - (Stefan Muenzel, review by Xavier Leroy) - -* #2293: Constify "caml_named_value" - (Stephen Dolan, review by Xavier Leroy) - -- #8607: Remove obsolete macros for pre-2002 MSVC support - (Stephen Dolan, review by Nicolás Ojeda Bär and David Allsopp) - -- #8656: Fix a bug in [caml_modify_generational_global_root] - (Jacques-Henri Jourdan, review by Gabriel Scherer) - -- #8787, #8788: avoid integer overflow in caml_output_value_to_bytes - (Jeremy Yallop, report by Marcello Seri) - -### Standard library: - -- #2262: take precision (.<n>) and flags ('+' and ' ') into account - in printf %F - (Pierre Roux, review by Gabriel Scherer) - -- #6148, #8596: optimize some buffer operations - (Damien Doligez, reports by John Whitington and Alain Frisch, - review by Jeremy Yallop and Gabriel Scherer) - -### Other libraries: - -- #2112: Fix Thread.yield unfairness with busy threads yielding to each - other. - (Andrew Hunter, review by Jacques-Henri Jourdan, Spiros Eliopoulos, Stephen - Weeks, & Mark Shinwell) - -- #7903, #2306: Make Thread.delay interruptible by signals again - (Xavier Leroy, review by Jacques-Henri Jourdan and Edwin Török) - -- #2248: Unix alloc_sockaddr: Fix read of uninitialized memory for an - unbound Unix socket. Add support for receiving abstract (Linux) socket paths. - (Tim Cuthbertson, review by Sébastien Hinderer and Jérémie Dimino) - -- #2289: Delete the vmthreads library. This library was deprecated in 4.08.0. - (Jérémie Dimino) +### Compiler distribution build system: -- #2318: Delete the graphics library. This library is now available - as a separate "graphics" package in opam. Its new home is: - https://github.com/ocaml/graphics - (Jérémie Dimino, review by Nicolas Ojeda Bar, Xavier Leroy and - Sébastien Hinderer) +- #2267: merge generation of header programs, also fixing parallel build on + Cygwin. + (David Allsopp, review by Sébastien Hinderer) -### Tools: +- #8514: Use boot/ocamlc.opt for building, if available. + (Stephen Dolan, review by Gabriel Scherer) -- #2221: ocamldep will now correctly allow a .ml file in an include directory - that appears first in the search order to shadow a .mli appearing in a later - include directory. - (Nicolás Ojeda Bär, review by Florian Angeletti) +### Bug fixes: -### Manual and documentation: +- #8864, #8865: Fix native compilation of left shift by (word_size - 1) + (Vincent Laviron, report by Murilo Giacometti Rocha, review by Xavier Leroy) -- #8757: Rename Pervasives to Stdlib in core library documentation. - (Ian Zimmerman, review by David Allsopp) +- #2296: Fix parsing of hexadecimal floats with underscores in the exponent. + (Hugo Heuzard and Xavier Leroy, review by Gabriel Scherer) -- #7584, #8538: Document .cmt* files in the "overview" of ocaml{c,opt} - (Oxana Kostikova, rewiew by Florian Angeletti) +- #8800: Fix soundness bug in extension constructor inclusion + (Leo White, review by Jacques Garrigue) -- #8515: manual, precise constraints on reexported types - (Florian Angeletti, review by Gabriel Scherer) +- #8848: Fix x86 stack probe CFI information in caml_c_call and + caml_call_gc + (Tom Kelly, review by Xavier Leroy) -### Bug fixes: - #7156, #8594: make top level use custom printers if they are available (Andrew Litteken, report by Martin Jambon, review by Nicolás Ojeda Bär, Thomas Refis, Armaël Guéneau, Gabriel Scherer, David Allsopp) + - #3249: ocamlmklib should reject .cmxa files (Xavier Leroy) + - #7937, #2287: fix uncaught Unify exception when looking for type declaration (Florian Angeletti, review by Jacques Garrigue) -- #2296: Fix parsing of hexadecimal floats with underscores in the exponent. - (Hugo Heuzard and Xavier Leroy, review by Gabriel Scherer) - - #8610, #8613: toplevel printing, consistent deduplicated name for types (Florian Angeletti, review by Thomas Refis and Gabriel Scherer, reported by Xavier Clerc) @@ -423,24 +502,28 @@ OCaml 4.09.0 - #8701, #8725: Variance of constrained parameters causes principality issues (Jacques Garrigue, report by Leo White, review by Gabriel Scherer) +- #8777(partial): fix position information in some polymorphic variant + error messages about missing tags + (Florian Angeletti, review by Thomas Refis) + - #8779, more cautious variance computation to avoid missing cmis (Florian Angeletti, report by Antonio Nuno Monteiro, review by Leo White) -- #8800: Fix soundness bug in extension constructor inclusion - (Leo White, review by Jacques Garrigue) - - #8810: Env.lookup_module: don't allow creating loops (Thomas Refis, report by Leo White, review by Jacques Garrigue) -- #8848: Fix x86 stack probe CFI information in caml_c_call and - caml_call_gc - (Tom Kelly, review by Xavier Leroy) +- #8862, #8871: subst: preserve scopes + (Thomas Refis, report by Leo White, review by Jacques Garrigue) -- #8864, #8865: Fix native compilation of left shift by (word_size - 1) - (Vincent Laviron, report by Murilo Giacometti Rocha, review by Xavier Leroy) +- #8921, #8924: Fix stack overflow with Flambda + (Vincent Laviron, review by Pierre Chambart and Leo White, + report by Aleksandr Kuzmenko) -OCaml 4.08 maintenance branch: ------------------------------- +- #8944: Fix "open struct .. end" on clambda backend + (Thomas Refis, review by Leo White, report by Damon Wang and Mark Shinwell) + +OCaml 4.08.1 (5 August 2019) +---------------------------- ### Bug fixes: @@ -463,6 +546,9 @@ OCaml 4.08 maintenance branch: detection (Stéphane Glondu, review by David Allsopp) +- #8843, #8841: fix use of off_t on 32-bit systems. + (Stephen Dolan, report by Richard Jones, review by Xavier Leroy) + OCaml 4.08.0 (13 June 2019) --------------------------- @@ -177,7 +177,7 @@ ASMCOMP=\ asmcomp/linscan.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/deadcode.cmo \ - asmcomp/printlinear.cmo asmcomp/linearize.cmo \ + asmcomp/linear.cmo asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/debug/available_regs.cmo \ asmcomp/debug/compute_ranges_intf.cmo \ asmcomp/debug/compute_ranges.cmo \ @@ -432,6 +432,9 @@ opt.opt: checknative $(MAKE) otherlibrariesopt $(MAKE) ocamllex.opt ocamltoolsopt ocamltoolsopt.opt $(OCAMLDOC_OPT) \ ocamltest.opt +ifneq "$(WITH_OCAMLDOC)" "" + $(MAKE) manpages +endif # Core bootstrapping cycle .PHONY: coreboot @@ -478,6 +481,9 @@ coreboot_pervasives_stdlib_change: all: coreall $(MAKE) ocaml $(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC) ocamltest +ifneq "$(WITH_OCAMLDOC)" "" + $(MAKE) manpages +endif # Bootstrap and rebuild the whole system. # The compilation of ocaml will fail if the runtime has changed. @@ -632,9 +638,9 @@ endif # from an previous installation of OCaml before otherlibs/num was removed. rm -f "$(INSTALL_LIBDIR)"/num.cm? # End transitional - if test -n "$(WITH_OCAMLDOC)"; then \ - $(MAKE) -C ocamldoc install; \ - fi +ifneq "$(WITH_OCAMLDOC)" "" + $(MAKE) -C ocamldoc install +endif if test -n "$(WITH_DEBUGGER)"; then \ $(MAKE) -C debugger install; \ fi @@ -677,6 +683,9 @@ endif $(INSTALL_DATA) \ asmcomp/*.cmi \ "$(INSTALL_COMPLIBDIR)" + $(INSTALL_DATA) \ + asmcomp/debug/*.cmi \ + "$(INSTALL_COMPLIBDIR)" ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" $(INSTALL_DATA) \ middle_end/*.cmt middle_end/*.cmti \ @@ -699,13 +708,17 @@ ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" asmcomp/*.cmt asmcomp/*.cmti \ asmcomp/*.mli \ "$(INSTALL_COMPLIBDIR)" + $(INSTALL_DATA) \ + asmcomp/debug/*.cmt asmcomp/debug/*.cmti \ + asmcomp/debug/*.mli \ + "$(INSTALL_COMPLIBDIR)" endif $(INSTALL_DATA) \ compilerlibs/ocamloptcomp.cma $(OPTSTART) \ "$(INSTALL_COMPLIBDIR)" - if test -n "$(WITH_OCAMLDOC)"; then \ - $(MAKE) -C ocamldoc installopt; \ - fi +ifneq "$(WITH_OCAMLDOC)" "" + $(MAKE) -C ocamldoc installopt +endif for i in $(OTHERLIBRARIES); do \ $(MAKE) -C otherlibs/$$i installopt || exit $$?; \ done @@ -743,6 +756,7 @@ installoptopt: middle_end/closure/*.cmx \ middle_end/flambda/*.cmx \ middle_end/flambda/base_types/*.cmx \ + asmcomp/debug/*.cmx \ "$(INSTALL_COMPLIBDIR)" $(INSTALL_DATA) \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ @@ -777,6 +791,7 @@ ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" toplevel/*.ml middle_end/*.ml middle_end/closure/*.ml \ middle_end/flambda/*.ml middle_end/flambda/base_types/*.ml \ asmcomp/*.ml \ + asmcmp/debug/*.ml \ "$(INSTALL_COMPLIBDIR)" endif @@ -1137,6 +1152,10 @@ html_doc: ocamldoc $(MAKE) -C ocamldoc $@ @echo "documentation is in ./ocamldoc/stdlib_html/" +.PHONY: manpages +manpages: + $(MAKE) -C ocamldoc $@ + partialclean:: $(MAKE) -C ocamldoc clean diff --git a/Makefile.common.in b/Makefile.common.in index 5ea3cfbad4..f389d5b02f 100644 --- a/Makefile.common.in +++ b/Makefile.common.in @@ -1,3 +1,5 @@ +# @configure_input@ + #************************************************************************** #* * #* OCaml * @@ -13,7 +15,8 @@ #* * #************************************************************************** -# This makefile contains common definitions shared by other Makefiles +# This makefile contains common definitions and rules shared by +# other Makefiles # We assume that Makefile.config has already been included INSTALL ?= @INSTALL@ @@ -65,3 +68,11 @@ endif # By default, request ocamllex to be quiet OCAMLLEX_FLAGS ?= -q + +# The rule to compile C files + +# This rule is similar to GNU make's implicit rule, except that it is more +# general (it supports both .o and .obj) + +%.$(O): %.c + $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) $(OUTPUTOBJ)$@ $< diff --git a/Makefile.config.in b/Makefile.config.in index 2439b4f7b4..1e20d347d9 100644 --- a/Makefile.config.in +++ b/Makefile.config.in @@ -167,8 +167,9 @@ PTHREAD_CAML_LINK=$(addprefix -cclib ,$(PTHREAD_LINK)) UNIX_OR_WIN32=@unix_or_win32@ UNIXLIB=@unixlib@ -LIBBFD_LINK=@libbfd_link@ -LIBBFD_INCLUDE=@libbfd_include@ +BFD_CPPFLAGS=@bfd_cppflags@ +BFD_LDFLAGS=@bfd_ldflags@ +BFD_LDLIBS=@bfd_ldlibs@ INSTALL_SOURCE_ARTIFACTS=@install_source_artifacts@ OC_CFLAGS=@oc_cflags@ diff --git a/Makefile.dev b/Makefile.dev index de69a1bf8f..90a69dece1 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -45,4 +45,4 @@ list-all-asts: @for f in $(AST_FILES); do echo "'$$f'"; done partialclean:: - rm -f $(AST_FILES) + @rm -f $(AST_FILES) diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index c9ae7884c2..e0222c9c6b 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -21,7 +21,7 @@ open Arch open Proc open Reg open Mach -open Linearize +open Linear open Emitaux open X86_ast @@ -79,14 +79,19 @@ let fp = Config.with_frame_pointers let fastcode_flag = ref true -let stack_offset = ref 0 - (* Layout of the stack frame *) +let stack_offset = ref 0 let stack_threshold_size = Config.stack_threshold * 8 (* bytes *) +let num_stack_slots = Array.make Proc.num_register_classes 0 + +let prologue_required = ref false + +let frame_required = ref false + let frame_size () = (* includes return address *) - if frame_required() then begin + if !frame_required then begin let sz = (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8 + (if fp then 8 else 0)) @@ -459,7 +464,7 @@ let emit_float_test cmp i lbl = (* Deallocate the stack frame before a return or tail call *) let output_epilogue f = - if frame_required() then begin + if !frame_required then begin let n = frame_size() - 8 - (if fp then 8 else 0) in if n <> 0 then begin @@ -531,13 +536,13 @@ let emit_instr fallthrough i = match i.desc with | Lend -> () | Lprologue -> - assert (Proc.prologue_required ()); + assert (!prologue_required); if fp then begin I.push rbp; cfi_adjust_cfa_offset 8; I.mov rsp rbp; end; - if frame_required() then begin + if !frame_required then begin let n = frame_size() - 8 - (if fp then 8 else 0) in if n <> 0 then begin @@ -998,7 +1003,7 @@ let rec emit_all fallthrough i = | Lend -> () | _ -> emit_instr fallthrough i; - emit_all (Linearize.has_fallthrough i.desc) i.next + emit_all (Linear.has_fallthrough i.desc) i.next let all_functions = ref [] @@ -1057,6 +1062,11 @@ let fundecl fundecl = call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; + for i = 0 to Proc.num_register_classes - 1 do + num_stack_slots.(i) <- fundecl.fun_num_stack_slots.(i); + done; + prologue_required := fundecl.fun_prologue_required; + frame_required := fundecl.fun_frame_required; all_functions := fundecl :: !all_functions; emit_named_text_section !function_name; D.align 16; @@ -1102,7 +1112,7 @@ let fundecl fundecl = I.pop r10; (* ignored *) I.jmp (label ret) end); - if frame_required() then begin + if !frame_required then begin let n = frame_size() - 8 - (if fp then 8 else 0) in if n <> 0 then begin diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index b519f4c005..50b0261fc5 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -382,14 +382,12 @@ let op_is_pure = function (* Layout of the stack frame *) -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false +let frame_required fd = + fp || fd.fun_contains_calls || + fd.fun_num_stack_slots.(0) > 0 || fd.fun_num_stack_slots.(1) > 0 -let frame_required () = - fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 - -let prologue_required () = - frame_required () +let prologue_required fd = + frame_required fd (* Calling the assembler *) diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index a4070b47cd..16819c09bf 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -124,5 +124,5 @@ method! reload_test tst arg = end -let fundecl f = - (new reload)#fundecl f +let fundecl f num_stack_slots = + (new reload)#fundecl f num_stack_slots diff --git a/asmcomp/amd64/scheduling.ml b/asmcomp/amd64/scheduling.ml index ad146c5063..2c4b072bee 100644 --- a/asmcomp/amd64/scheduling.ml +++ b/asmcomp/amd64/scheduling.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -let _ = let module M = Schedgen in () (* to create a dependency *) +open! Schedgen (* to create a dependency *) (* Scheduling is turned off because the processor schedules dynamically much better than what we could do. *) diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 484883a48a..acd4d5636e 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -259,7 +259,7 @@ method select_floatarith commutative regular_op mem_op args = assert false method! mark_c_tailcall = - Proc.contains_calls := true + contains_calls := true (* Deal with register constraints *) diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 236ea0c224..1393d4576d 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -23,7 +23,7 @@ open Arch open Proc open Reg open Mach -open Linearize +open Linear open Emitaux (* Tradeoff between code size and code speed *) @@ -60,6 +60,12 @@ let emit_reg = function let stack_offset = ref 0 +let num_stack_slots = Array.make Proc.num_register_classes 0 + +let prologue_required = ref false + +let contains_calls = ref false + let frame_size () = let sz = !stack_offset + @@ -452,7 +458,7 @@ let emit_instr i = match i.desc with | Lend -> 0 | Lprologue -> - assert (Proc.prologue_required ()); + assert (!prologue_required); let n = frame_size() in let num_instrs = if n > 0 then begin @@ -968,6 +974,11 @@ let fundecl fundecl = stack_offset := 0; call_gc_sites := []; bound_error_sites := []; + for i = 0 to Proc.num_register_classes - 1 do + num_stack_slots.(i) <- fundecl.fun_num_stack_slots.(i); + done; + contains_calls := fundecl.fun_contains_calls; + prologue_required := fundecl.fun_prologue_required; emit_named_text_section !function_name; ` .align 2\n`; ` .globl {emit_symbol fundecl.fun_name}\n`; diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 1e16621be5..9ac9cf13a2 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -342,17 +342,15 @@ let op_is_pure = function (* Layout of the stack *) -let num_stack_slots = [| 0; 0; 0 |] -let contains_calls = ref false - -let frame_required () = - !contains_calls +let frame_required fd = + let num_stack_slots = fd.fun_num_stack_slots in + fd.fun_contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 || num_stack_slots.(2) > 0 -let prologue_required () = - frame_required () +let prologue_required fd = + frame_required fd (* Calling the assembler *) diff --git a/asmcomp/arm/reload.ml b/asmcomp/arm/reload.ml index 9d4f3973c6..301ec112ca 100644 --- a/asmcomp/arm/reload.ml +++ b/asmcomp/arm/reload.ml @@ -53,5 +53,5 @@ method! reload_operation op arg res = argres' end -let fundecl f = - (new reload)#fundecl f +let fundecl f num_stack_slots = + (new reload)#fundecl f num_stack_slots diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index 390dd4124b..64a91a10bd 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -24,7 +24,7 @@ open Arch open Proc open Reg open Mach -open Linearize +open Linear open Emitaux (* Tradeoff between code size and code speed *) @@ -78,6 +78,12 @@ let stack_threshold_size = Config.stack_threshold * 8 (* bytes *) let stack_offset = ref 0 +let num_stack_slots = Array.make Proc.num_register_classes 0 + +let prologue_required = ref false + +let contains_calls = ref false + let frame_size () = let sz = !stack_offset + @@ -616,7 +622,7 @@ let emit_instr i = match i.desc with | Lend -> () | Lprologue -> - assert (Proc.prologue_required ()); + assert (!prologue_required); let n = frame_size() in if n > 0 then emit_stack_adjustment (-n); @@ -1030,6 +1036,11 @@ let fundecl fundecl = call_gc_sites := []; bound_error_sites := []; read_barrier_call_sites := []; + for i = 0 to Proc.num_register_classes - 1 do + num_stack_slots.(i) <- fundecl.fun_num_stack_slots.(i); + done; + prologue_required := fundecl.fun_prologue_required; + contains_calls := fundecl.fun_contains_calls; emit_named_text_section !function_name; ` .align 3\n`; ` .globl {emit_symbol fundecl.fun_name}\n`; diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml index 243bd11cb6..dfa42ffe13 100644 --- a/asmcomp/arm64/proc.ml +++ b/asmcomp/arm64/proc.ml @@ -258,17 +258,13 @@ let op_is_pure = function | _ -> true (* Layout of the stack *) +let frame_required fd = + fd.fun_contains_calls + || fd.fun_num_stack_slots.(0) > 0 + || fd.fun_num_stack_slots.(1) > 0 -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -let frame_required () = - !contains_calls - || num_stack_slots.(0) > 0 - || num_stack_slots.(1) > 0 - -let prologue_required () = - frame_required () +let prologue_required fd = + frame_required fd (* Calling the assembler *) diff --git a/asmcomp/arm64/reload.ml b/asmcomp/arm64/reload.ml index 0d6cacd0bb..0c342b6448 100644 --- a/asmcomp/arm64/reload.ml +++ b/asmcomp/arm64/reload.ml @@ -15,5 +15,5 @@ (* Reloading for the ARM 64 bits *) -let fundecl f = - (new Reloadgen.reload_generic)#fundecl f +let fundecl f num_stack_slots = + (new Reloadgen.reload_generic)#fundecl f num_stack_slots diff --git a/asmcomp/arm64/scheduling.ml b/asmcomp/arm64/scheduling.ml index 04f514e91d..86a3c616db 100644 --- a/asmcomp/arm64/scheduling.ml +++ b/asmcomp/arm64/scheduling.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -let _ = let module M = Schedgen in () (* to create a dependency *) +open! Schedgen (* to create a dependency *) (* Scheduling is turned off because the processor schedules dynamically much better than what we could do. *) diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 290d01f742..b91be91091 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -44,20 +44,22 @@ let rec regalloc ~ppf_dump round fd = fatal_error(fd.Mach.fun_name ^ ": function too complex, cannot complete register allocation"); dump_if ppf_dump dump_live "Liveness analysis" fd; - if !use_linscan then begin - (* Linear Scan *) - Interval.build_intervals fd; - if !dump_interval then Printmach.intervals ppf_dump (); - Linscan.allocate_registers() - end else begin - (* Graph Coloring *) - Interf.build_graph fd; - if !dump_interf then Printmach.interferences ppf_dump (); - if !dump_prefer then Printmach.preferences ppf_dump (); - Coloring.allocate_registers() - end; + let num_stack_slots = + if !use_linscan then begin + (* Linear Scan *) + Interval.build_intervals fd; + if !dump_interval then Printmach.intervals ppf_dump (); + Linscan.allocate_registers() + end else begin + (* Graph Coloring *) + Interf.build_graph fd; + if !dump_interf then Printmach.interferences ppf_dump (); + if !dump_prefer then Printmach.preferences ppf_dump (); + Coloring.allocate_registers() + end + in dump_if ppf_dump dump_regalloc "After register allocation" fd; - let (newfd, redo_regalloc) = Reload.fundecl fd in + let (newfd, redo_regalloc) = Reload.fundecl fd num_stack_slots in dump_if ppf_dump dump_reload "After insertion of reloading code" newfd; if redo_regalloc then begin Reg.reinit(); Liveness.fundecl newfd; regalloc ~ppf_dump (round + 1) newfd diff --git a/asmcomp/branch_relaxation.ml b/asmcomp/branch_relaxation.ml index f8f9071970..953c2827c4 100644 --- a/asmcomp/branch_relaxation.ml +++ b/asmcomp/branch_relaxation.ml @@ -15,7 +15,7 @@ (**************************************************************************) open Mach -open Linearize +open Linear module Make (T : Branch_relaxation_intf.S) = struct let label_map code = @@ -45,7 +45,7 @@ module Make (T : Branch_relaxation_intf.S) = struct | Some branch -> let max_branch_offset = (* Remember to cut some slack for multi-word instructions (in the - [Linearize] sense of the word) where the branch can be anywhere in + [Linear] sense of the word) where the branch can be anywhere in the middle. 12 words of slack is plenty. *) T.Cond_branch.max_displacement branch - 12 in diff --git a/asmcomp/branch_relaxation.mli b/asmcomp/branch_relaxation.mli index 170f306d82..7d5401988a 100644 --- a/asmcomp/branch_relaxation.mli +++ b/asmcomp/branch_relaxation.mli @@ -18,7 +18,7 @@ module Make (T : Branch_relaxation_intf.S) : sig val relax - : Linearize.instruction + : Linear.instruction (* [max_offset_of_out_of_line_code] specifies the furthest distance, measured from the first address immediately after the last instruction of the function, that may be branched to from within the function in diff --git a/asmcomp/branch_relaxation_intf.ml b/asmcomp/branch_relaxation_intf.ml index f95ab67dc8..d5552f83f4 100644 --- a/asmcomp/branch_relaxation_intf.ml +++ b/asmcomp/branch_relaxation_intf.ml @@ -46,7 +46,7 @@ module type S = sig - Lcondbranch3 (_, _, _) [classify_instr] is expected to return [None] when called on any instruction not in this list. *) - val classify_instr : Linearize.instruction_desc -> t option + val classify_instr : Linear.instruction_desc -> t option end (* The value to be added to the program counter (in [distance] units) @@ -55,7 +55,7 @@ module type S = sig val offset_pc_at_branch : distance (* The maximum size of a given instruction. *) - val instr_size : Linearize.instruction_desc -> distance + val instr_size : Linear.instruction_desc -> distance (* Insertion of target-specific code to relax operations that cannot be relaxed generically. It is assumed that these rewrites do not change @@ -63,13 +63,13 @@ module type S = sig val relax_allocation : num_bytes:int -> label_after_call_gc:Cmm.label option - -> Linearize.instruction_desc + -> Linear.instruction_desc val relax_intop_checkbound : label_after_error:Cmm.label option - -> Linearize.instruction_desc + -> Linear.instruction_desc val relax_intop_imm_checkbound : bound:int -> label_after_error:Cmm.label option - -> Linearize.instruction_desc - val relax_specific_op : Arch.specific_operation -> Linearize.instruction_desc + -> Linear.instruction_desc + val relax_specific_op : Arch.specific_operation -> Linear.instruction_desc end diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 80e6a36c01..d3e3f1de64 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -211,3 +211,76 @@ let ccatch (i, ids, e1, e2, dbg) = let reset () = label_counter := 99 + +let iter_shallow_tail f = function + | Clet(_, _, body) | Cphantom_let (_, _, body) -> + f body; + true + | Cifthenelse(_cond, _dbg_cond, e1, _dbg_e1, e2, _dbg_e2) -> + f e1; + f e2; + true + | Csequence(_e1, e2) -> + f e2; + true + | Cswitch(_e, _tbl, el, _dbg') -> + Array.iter (fun (e, _dbg) -> f e) el; + true + | Ccatch(_rec_flag, handlers, body) -> + List.iter (fun (_, _, h, _dbg) -> f h) handlers; + f body; + true + | Ctrywith(e1, _id, e2, _dbg) -> + f e1; + f e2; + true + | Cexit _ | Cop (Craise _, _, _) -> + true + | Cconst_int _ + | Cconst_natint _ + | Cconst_float _ + | Cconst_symbol _ + | Cconst_pointer _ + | Cconst_natpointer _ + | Cblockheader _ + | Cvar _ + | Cassign _ + | Ctuple _ + | Cop _ -> + false + +let rec map_tail f = function + | Clet(id, exp, body) -> + Clet(id, exp, map_tail f body) + | Cphantom_let(id, exp, body) -> + Cphantom_let (id, exp, map_tail f body) + | Cifthenelse(cond, dbg_cond, e1, dbg_e1, e2, dbg_e2) -> + Cifthenelse + ( + cond, dbg_cond, + map_tail f e1, dbg_e1, + map_tail f e2, dbg_e2 + ) + | Csequence(e1, e2) -> + Csequence(e1, map_tail f e2) + | Cswitch(e, tbl, el, dbg') -> + Cswitch(e, tbl, Array.map (fun (e, dbg) -> map_tail f e, dbg) el, dbg') + | Ccatch(rec_flag, handlers, body) -> + let map_h (n, ids, handler, dbg) = (n, ids, map_tail f handler, dbg) in + Ccatch(rec_flag, List.map map_h handlers, map_tail f body) + | Ctrywith(e1, id, e2, dbg) -> + Ctrywith(map_tail f e1, id, map_tail f e2, dbg) + | Cexit _ | Cop (Craise _, _, _) as cmm -> + cmm + | Cconst_int _ + | Cconst_natint _ + | Cconst_float _ + | Cconst_symbol _ + | Cconst_pointer _ + | Cconst_natpointer _ + | Cblockheader _ + | Cvar _ + | Cassign _ + | Ctuple _ + | Cop _ as c -> + f c diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index f59f9749ef..4209ed0a22 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -218,3 +218,18 @@ val ccatch : -> expression val reset : unit -> unit + +val iter_shallow_tail: (expression -> unit) -> expression -> bool + (** Either apply the callback to all immediate sub-expressions that + can produce the final result for the expression and return + [true], or do nothing and return [false]. Note that the notion + of "tail" sub-expression used here does not match the one used + to trigger tail calls; in particular, try...with handlers are + considered to be in tail position (because their result become + the final result for the expression). *) + +val map_tail: (expression -> expression) -> expression -> expression + (** Apply the transformation to an expression, trying to push it + to all inner sub-expressions that can produce the final result. + Same disclaimer as for [iter_shallow_tail] about the notion + of "tail" sub-expression. *) diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index a818fc5bb2..910f035431 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -64,6 +64,11 @@ let add_unboxed_id id unboxed_id bn env = unboxed_ids = V.add id (unboxed_id, bn) env.unboxed_ids; } +let structured_constant_of_sym s = + match Compilenv.structured_constant_of_symbol s with + | None -> Cmmgen_state.get_structured_constant s + | Some _ as r -> r + (* Local binding of complex expressions *) let bind name arg fn = @@ -583,30 +588,25 @@ let test_bool dbg cmm = let box_float dbg c = Cop(Calloc, [alloc_float_header dbg; c], dbg) -let map_ccatch f rec_flag handlers body = - let handlers = List.map - (fun (n, ids, handler, dbg) -> (n, ids, f handler, dbg)) - handlers in - Ccatch(rec_flag, handlers, f body) - -let rec unbox_float dbg cmm = - match cmm with - | Cop(Calloc, [Cblockheader (header, _); c], _) when header = float_header -> - c - | Clet(id, exp, body) -> Clet(id, exp, unbox_float dbg body) - | Cifthenelse(cond, ifso_dbg, e1, ifnot_dbg, e2, dbg) -> - Cifthenelse(cond, - ifso_dbg, unbox_float dbg e1, - ifnot_dbg, unbox_float dbg e2, - dbg) - | Csequence(e1, e2) -> Csequence(e1, unbox_float dbg e2) - | Cswitch(e, tbl, el, dbg') -> - Cswitch(e, tbl, - Array.map (fun (expr, dbg) -> unbox_float dbg expr, dbg) el, dbg') - | Ccatch(rec_flag, handlers, body) -> - map_ccatch (unbox_float dbg) rec_flag handlers body - | Ctrywith(e1, id, e2, dbg) -> Ctrywith(unbox_float dbg e1, id, unbox_float dbg e2, dbg) - | c -> Cop(Cload {memory_chunk=Double_u; mutability=Immutable; is_atomic=false}, [c], dbg) +let unbox_float dbg = + map_tail + (function + | Cop(Calloc, [Cblockheader (hdr, _); c], _) + when Nativeint.equal hdr float_header -> + c + | Cconst_symbol (s, _dbg) as cmm -> + begin match structured_constant_of_sym s with + | Some (Uconst_float x) -> + Cconst_float (x, dbg) (* or keep _dbg? *) + | _ -> + Cop(Cload {memory_chunk=Double_u; mutability=Immutable; + is_atomic=false}, + [cmm], dbg) + end + | cmm -> Cop(Cload {memory_chunk=Double_u; mutability=Immutable; + is_atomic=false}, + [cmm], dbg) + ) (* Complex *) @@ -637,7 +637,8 @@ let rec remove_unit = function Array.map (fun (case, dbg) -> remove_unit case, dbg) cases, dbg) | Ccatch(rec_flag, handlers, body) -> - map_ccatch remove_unit rec_flag handlers body + let map_h (n, ids, handler, dbg) = (n, ids, remove_unit handler, dbg) in + Ccatch(rec_flag, List.map map_h handlers, remove_unit body) | Ctrywith(body, exn, handler, dbg) -> Ctrywith(remove_unit body, exn, remove_unit handler, dbg) | Clet(id, c1, c2) -> @@ -1116,51 +1117,63 @@ let alloc_matches_boxed_int bi ~hdr ~ops = && String.equal sym caml_int64_ops | (Pnativeint | Pint32 | Pint64), _, _ -> false -let rec unbox_int bi arg dbg = - match arg with - Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int (32, _)], dbg')], - _dbg) - when bi = Pint32 && size_int = 8 && big_endian - && alloc_matches_boxed_int bi ~hdr ~ops -> - (* Force sign-extension of low 32 bits *) - Cop(Casr, [Cop(Clsl, [contents; Cconst_int (32, dbg)], dbg'); - Cconst_int (32, dbg)], - dbg) - | Cop(Calloc, [hdr; ops; contents], _dbg) - when bi = Pint32 && size_int = 8 && not big_endian - && alloc_matches_boxed_int bi ~hdr ~ops -> - (* Force sign-extension of low 32 bits *) - Cop(Casr, [Cop(Clsl, [contents; Cconst_int (32, dbg)], dbg); - Cconst_int (32, dbg)], - dbg) - | Cop(Calloc, [hdr; ops; contents], _dbg) - when alloc_matches_boxed_int bi ~hdr ~ops -> - contents - | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body dbg) - | Cifthenelse(cond, ifso_dbg, e1, ifnot_dbg, e2, dbg) -> - Cifthenelse(cond, - ifso_dbg, unbox_int bi e1 ifso_dbg, - ifnot_dbg, unbox_int bi e2 ifnot_dbg, - dbg) - | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2 dbg) - | Cswitch(e, tbl, el, dbg') -> - Cswitch(e, tbl, - Array.map (fun (e, dbg) -> unbox_int bi e dbg, dbg) el, - dbg') - | Ccatch(rec_flag, handlers, body) -> - map_ccatch (fun e -> unbox_int bi e dbg) rec_flag handlers body - | Ctrywith(e1, id, e2, handler_dbg) -> - Ctrywith(unbox_int bi e1 dbg, id, - unbox_int bi e2 handler_dbg, handler_dbg) - | _ -> - if size_int = 4 && bi = Pint64 then - split_int64_for_32bit_target arg dbg - else - let memory_chunk = if bi = Pint32 then Thirtytwo_signed else Word_int - in - Cop( - Cload {memory_chunk; mutability=Mutable; is_atomic=false}, - [Cop(Cadda, [arg; Cconst_int (size_addr, dbg)], dbg)], dbg) +let unbox_int dbg bi = + let default arg = + if size_int = 4 && bi = Pint64 then + split_int64_for_32bit_target arg dbg + else + let memory_chunk = if bi = Pint32 then Thirtytwo_signed else Word_int + in + Cop( + Cload {memory_chunk; mutability=Immutable; is_atomic=false}, + [Cop(Cadda, [arg; Cconst_int (size_addr, dbg)], dbg)], dbg) + in + map_tail + (function + | Cop(Calloc, + [hdr; ops; + Cop(Clsl, [contents; Cconst_int (32, _)], dbg')], _dbg) + when bi = Pint32 && size_int = 8 && big_endian + && alloc_matches_boxed_int bi ~hdr ~ops -> + (* Force sign-extension of low 32 bits *) + Cop(Casr, [Cop(Clsl, [contents; Cconst_int (32, dbg)], dbg'); + Cconst_int (32, dbg)], + dbg) + | Cop(Calloc, + [hdr; ops; contents], _dbg) + when bi = Pint32 && size_int = 8 && not big_endian + && alloc_matches_boxed_int bi ~hdr ~ops -> + (* Force sign-extension of low 32 bits *) + Cop(Casr, [Cop(Clsl, [contents; Cconst_int (32, dbg)], dbg); + Cconst_int (32, dbg)], + dbg) + | Cop(Calloc, [hdr; ops; contents], _dbg) + when alloc_matches_boxed_int bi ~hdr ~ops -> + contents + | Cconst_symbol (s, _dbg) as cmm -> + begin match structured_constant_of_sym s, bi with + | Some (Uconst_nativeint n), Pnativeint -> + Cconst_natint (n, dbg) + | Some (Uconst_int32 n), Pint32 -> + Cconst_natint (Nativeint.of_int32 n, dbg) + | Some (Uconst_int64 n), Pint64 -> + if size_int = 8 then + Cconst_natint (Int64.to_nativeint n, dbg) + else + let low = Int64.to_nativeint n in + let high = + Int64.to_nativeint (Int64.shift_right_logical n 32) + in + if big_endian then + Ctuple [Cconst_natint (high, dbg); Cconst_natint (low, dbg)] + else + Ctuple [Cconst_natint (low, dbg); Cconst_natint (high, dbg)] + | _ -> + default cmm + end + | cmm -> + default cmm + ) let make_unsigned_int bi arg dbg = if bi = Pint32 && size_int = 8 @@ -1188,6 +1201,11 @@ let box_number bn arg = | Boxed_float dbg -> box_float dbg arg | Boxed_integer (bi, dbg) -> box_int dbg bi arg +let unbox_number dbg bn arg = + match bn with + | Boxed_float _ -> unbox_float dbg arg + | Boxed_integer (bi, _) -> unbox_int dbg bi arg + (* Big arrays *) let bigarray_elt_size = function @@ -1847,118 +1865,72 @@ type unboxed_number_kind = | Boxed of boxed_number * bool (* true: boxed form available at no cost *) | No_result (* expression never returns a result *) -let unboxed_number_kind_of_unbox dbg = function - | Same_as_ocaml_repr -> No_unboxing - | Unboxed_float -> Boxed (Boxed_float dbg, false) - | Unboxed_integer bi -> Boxed (Boxed_integer (bi, dbg), false) - | Untagged_int -> No_unboxing - -let rec is_unboxed_number ~strict env e = - (* Given unboxed_number_kind from two branches of the code, returns the - resulting unboxed_number_kind. - - If [strict=false], one knows that the type of the expression - is an unboxable number, and we decide to return an unboxed value - if this indeed eliminates at least one allocation. - - If [strict=true], we need to ensure that all possible branches - return an unboxable number (of the same kind). This could not - be the case in presence of GADTs. - *) - let join k1 e = - match k1, is_unboxed_number ~strict env e with - | Boxed (b1, c1), Boxed (b2, c2) when equal_boxed_number b1 b2 -> - Boxed (b1, c1 && c2) - | No_result, k | k, No_result -> +(* Given unboxed_number_kind from two branches of the code, returns the + resulting unboxed_number_kind. + + If [strict=false], one knows that the type of the expression + is an unboxable number, and we decide to return an unboxed value + if this indeed eliminates at least one allocation. + + If [strict=true], we need to ensure that all possible branches + return an unboxable number (of the same kind). This could not + be the case in presence of GADTs. +*) +let join_unboxed_number_kind ~strict k1 k2 = + match k1, k2 with + | Boxed (b1, c1), Boxed (b2, c2) when equal_boxed_number b1 b2 -> + Boxed (b1, c1 && c2) + | No_result, k | k, No_result -> k (* if a branch never returns, it is safe to unbox it *) - | No_unboxing, k | k, No_unboxing when not strict -> - k - | _, _ -> No_unboxing + | No_unboxing, k | k, No_unboxing when not strict -> + k + | _, _ -> No_unboxing + +let is_unboxed_number_cmm ~strict cmm = + let r = ref No_result in + let notify k = + r := join_unboxed_number_kind ~strict !r k in - match e with - | Uvar id -> - begin match is_unboxed_id id env with - | None -> No_unboxing - | Some (_, bn) -> Boxed (bn, false) - end - - (* CR mshinwell: Changes to [Clambda] will provide the [Debuginfo] here *) - | Uconst(Uconst_ref(_, Some (Uconst_float _))) -> - let dbg = Debuginfo.none in - Boxed (Boxed_float dbg, true) - | Uconst(Uconst_ref(_, Some (Uconst_int32 _))) -> - let dbg = Debuginfo.none in - Boxed (Boxed_integer (Pint32, dbg), true) - | Uconst(Uconst_ref(_, Some (Uconst_int64 _))) -> - let dbg = Debuginfo.none in - Boxed (Boxed_integer (Pint64, dbg), true) - | Uconst(Uconst_ref(_, Some (Uconst_nativeint _))) -> - let dbg = Debuginfo.none in - Boxed (Boxed_integer (Pnativeint, dbg), true) - | Uprim(p, _, dbg) -> - begin match simplif_primitive p with - | Pccall p -> unboxed_number_kind_of_unbox dbg p.prim_native_repr_res - | Pfloatfield _ - | Pfloatofint - | Pnegfloat - | Pabsfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - | Parrayrefu Pfloatarray - | Parrayrefs Pfloatarray -> Boxed (Boxed_float dbg, false) - | Pbintofint bi - | Pcvtbint(_, bi) - | Pnegbint bi - | Paddbint bi - | Psubbint bi - | Pmulbint bi - | Pdivbint {size=bi} - | Pmodbint {size=bi} - | Pandbint bi - | Porbint bi - | Pxorbint bi - | Plslbint bi - | Plsrbint bi - | Pasrbint bi - | Pbbswap bi -> Boxed (Boxed_integer (bi, dbg), false) - | Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) -> - Boxed (Boxed_float dbg, false) - | Pbigarrayref(_, _, Pbigarray_int32, _) -> - Boxed (Boxed_integer (Pint32, dbg), false) - | Pbigarrayref(_, _, Pbigarray_int64, _) -> - Boxed (Boxed_integer (Pint64, dbg), false) - | Pbigarrayref(_, _, Pbigarray_native_int,_) -> - Boxed (Boxed_integer (Pnativeint, dbg), false) - | Pstring_load(Thirty_two,_) - | Pbytes_load(Thirty_two,_) -> - Boxed (Boxed_integer (Pint32, dbg), false) - | Pstring_load(Sixty_four,_) - | Pbytes_load(Sixty_four,_) -> - Boxed (Boxed_integer (Pint64, dbg), false) - | Pbigstring_load(Thirty_two,_) -> - Boxed (Boxed_integer (Pint32, dbg), false) - | Pbigstring_load(Sixty_four,_) -> - Boxed (Boxed_integer (Pint64, dbg), false) - | Praise _ -> No_result - | _ -> No_unboxing - end - | Ulet (_, _, _, _, e) | Uletrec (_, e) | Usequence (_, e) -> - is_unboxed_number ~strict env e - | Uswitch (_, switch, _dbg) -> - let k = Array.fold_left join No_result switch.us_actions_consts in - Array.fold_left join k switch.us_actions_blocks - | Ustringswitch (_, actions, default_opt) -> - let k = List.fold_left (fun k (_, e) -> join k e) No_result actions in - begin match default_opt with - None -> k - | Some default -> join k default - end - | Ustaticfail _ -> No_result - | Uifthenelse (_, e1, e2) | Ucatch (_, _, e1, e2) | Utrywith (e1, _, e2) -> - join (is_unboxed_number ~strict env e1) e2 - | _ -> No_unboxing + let rec aux = function + | Cop(Calloc, [Cblockheader (hdr, _); _], dbg) + when Nativeint.equal hdr float_header -> + notify (Boxed (Boxed_float dbg, false)) + | Cop(Calloc, [Cblockheader (hdr, _); Cconst_symbol (ops, _); _], dbg) -> + if Nativeint.equal hdr boxedintnat_header + && String.equal ops caml_nativeint_ops + then + notify (Boxed (Boxed_integer (Pnativeint, dbg), false)) + else + if Nativeint.equal hdr boxedint32_header + && String.equal ops caml_int32_ops + then + notify (Boxed (Boxed_integer (Pint32, dbg), false)) + else + if Nativeint.equal hdr boxedint64_header + && String.equal ops caml_int64_ops + then + notify (Boxed (Boxed_integer (Pint64, dbg), false)) + else + notify No_unboxing + | Cconst_symbol (s, _) -> + begin match structured_constant_of_sym s with + | Some (Uconst_float _) -> + notify (Boxed (Boxed_float Debuginfo.none, true)) + | Some (Uconst_nativeint _) -> + notify (Boxed (Boxed_integer (Pnativeint, Debuginfo.none), true)) + | Some (Uconst_int32 _) -> + notify (Boxed (Boxed_integer (Pint32, Debuginfo.none), true)) + | Some (Uconst_int64 _) -> + notify (Boxed (Boxed_integer (Pint64, Debuginfo.none), true)) + | _ -> + notify No_unboxing + end + | l -> + if not (Cmm.iter_shallow_tail aux l) then + notify No_unboxing + in + aux cmm; + !r (* Helper for compilation of initialization and assignment operations *) @@ -2311,12 +2283,12 @@ let rec transl env e = dbg)))) | Uassign(id, exp) -> let dbg = Debuginfo.none in + let cexp = transl env exp in begin match is_unboxed_id id env with | None -> - return_unit dbg (Cassign(id, transl env exp)) + return_unit dbg (Cassign(id, cexp)) | Some (unboxed_id, bn) -> - return_unit dbg (Cassign(unboxed_id, - transl_unbox_number dbg env bn exp)) + return_unit dbg (Cassign(unboxed_id, unbox_number dbg bn cexp)) end | Uunreachable -> let dbg = Debuginfo.none in @@ -2955,34 +2927,11 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = fatal_errorf "Cmmgen.transl_prim_3: %a" Printclambda_primitives.primitive p -and transl_unbox_float dbg env = function - Uconst(Uconst_ref(_, Some (Uconst_float f))) -> Cconst_float (f, dbg) - | exp -> unbox_float dbg (transl env exp) - -and transl_unbox_int dbg env bi = function - Uconst(Uconst_ref(_, Some (Uconst_int32 n))) -> - Cconst_natint (Nativeint.of_int32 n, dbg) - | Uconst(Uconst_ref(_, Some (Uconst_nativeint n))) -> - Cconst_natint (n, dbg) - | Uconst(Uconst_ref(_, Some (Uconst_int64 n))) -> - if size_int = 8 then - Cconst_natint (Int64.to_nativeint n, dbg) - else begin - let low = Int64.to_nativeint n in - let high = Int64.to_nativeint (Int64.shift_right_logical n 32) in - if big_endian then - Ctuple [Cconst_natint (high, dbg); Cconst_natint (low, dbg)] - else - Ctuple [Cconst_natint (low, dbg); Cconst_natint (high, dbg)] - end - | Uprim(Pbintofint bi',[Uconst(Uconst_int i)],_) when bi = bi' -> - Cconst_int (i, dbg) - | exp -> unbox_int bi (transl env exp) dbg +and transl_unbox_float dbg env exp = + unbox_float dbg (transl env exp) -and transl_unbox_number dbg env bn arg = - match bn with - | Boxed_float _ -> transl_unbox_float dbg env arg - | Boxed_integer (bi, _) -> transl_unbox_int dbg env bi arg +and transl_unbox_int dbg env bi exp = + unbox_int dbg bi (transl env exp) and transl_unbox_sized size dbg env exp = match size with @@ -2992,6 +2941,7 @@ and transl_unbox_sized size dbg env exp = and transl_let env str kind id exp body = let dbg = Debuginfo.none in + let cexp = transl env exp in let unboxing = (* If [id] is a mutable variable (introduced to eliminate a local reference) and it contains a type of unboxable numbers, then @@ -3007,14 +2957,14 @@ and transl_let env str kind id exp body = (* It would be safe to always unbox in this case, but we do it only if this indeed allows us to get rid of some allocations in the bound expression. *) - is_unboxed_number ~strict:false env exp + is_unboxed_number_cmm ~strict:false cexp | _, Pgenval -> (* Here we don't know statically that the bound expression evaluates to an unboxable number type. We need to be stricter and ensure that all possible branches in the expression return a boxed value (of the same kind). Indeed, with GADTs, different branches could return different types. *) - is_unboxed_number ~strict:true env exp + is_unboxed_number_cmm ~strict:true cexp | _, Pintval -> No_unboxing in @@ -3022,10 +2972,10 @@ and transl_let env str kind id exp body = | No_unboxing | Boxed (_, true) | No_result -> (* N.B. [body] must still be traversed even if [exp] will never return: there may be constant closures inside that need lifting out. *) - Clet(id, transl env exp, transl env body) + Clet(id, cexp, transl env body) | Boxed (boxed_number, _false) -> let unboxed_id = V.create_local (VP.name id) in - Clet(VP.create unboxed_id, transl_unbox_number dbg env boxed_number exp, + Clet(VP.create unboxed_id, unbox_number dbg boxed_number cexp, transl (add_unboxed_id (VP.var id) unboxed_id boxed_number env) body) and make_catch ncatch body handler dbg = match body with @@ -3442,6 +3392,7 @@ let emit_preallocated_blocks preallocated_blocks cont = let compunit (ulam, preallocated_blocks, constants) = assert (Cmmgen_state.no_more_functions ()); let dbg = Debuginfo.none in + Cmmgen_state.set_structured_constants constants; let init_code = if !Clflags.afl_instrument then Afl_instrument.instrument_initialiser (transl empty_env ulam) @@ -3463,6 +3414,7 @@ let compunit (ulam, preallocated_blocks, constants) = fun_dbg = Debuginfo.none }] in let c2 = transl_clambda_constants constants c1 in let c3 = transl_all_functions c2 in + Cmmgen_state.set_structured_constants []; let c4 = emit_preallocated_blocks preallocated_blocks c3 in emit_cmm_data_items_for_constants c4 diff --git a/asmcomp/cmmgen_state.ml b/asmcomp/cmmgen_state.ml index 8fa8563482..c4023e0cc9 100644 --- a/asmcomp/cmmgen_state.ml +++ b/asmcomp/cmmgen_state.ml @@ -28,6 +28,7 @@ type constant = type t = { mutable constants : constant S.Map.t; mutable data_items : Cmm.data_item list list; + structured_constants : (string, Clambda.ustructured_constant) Hashtbl.t; functions : Clambda.ufunction Queue.t; } @@ -35,6 +36,7 @@ let empty = { constants = S.Map.empty; data_items = []; functions = Queue.create (); + structured_constants = Hashtbl.create 16; } let state = empty @@ -65,3 +67,14 @@ let next_function () = let no_more_functions () = Queue.is_empty state.functions + +let set_structured_constants l = + Hashtbl.clear state.structured_constants; + List.iter + (fun (c : Clambda.preallocated_constant) -> + Hashtbl.add state.structured_constants c.symbol c.definition + ) + l + +let get_structured_constant s = + Hashtbl.find_opt state.structured_constants s diff --git a/asmcomp/cmmgen_state.mli b/asmcomp/cmmgen_state.mli index bfb6121d7c..c5c3d550cb 100644 --- a/asmcomp/cmmgen_state.mli +++ b/asmcomp/cmmgen_state.mli @@ -38,3 +38,7 @@ val get_and_clear_data_items : unit -> Cmm.data_item list val next_function : unit -> Clambda.ufunction option val no_more_functions : unit -> bool + +val set_structured_constants : Clambda.preallocated_constant list -> unit + +val get_structured_constant : string -> Clambda.ustructured_constant option diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml index 62a9b0da1b..ffcd71b730 100644 --- a/asmcomp/coloring.ml +++ b/asmcomp/coloring.ml @@ -43,13 +43,16 @@ let allocate_registers() = (* Unconstrained regs with degree < number of available registers *) let unconstrained = ref [] in + (* Reset the stack slot counts *) + let num_stack_slots = Array.make Proc.num_register_classes 0 in + (* Preallocate the spilled registers in the stack. Split the remaining registers into constrained and unconstrained. *) let remove_reg reg = let cl = Proc.register_class reg in if reg.spill then begin (* Preallocate the registers in the stack *) - let nslots = Proc.num_stack_slots.(cl) in + let nslots = num_stack_slots.(cl) in let conflict = Array.make nslots false in List.iter (fun r -> @@ -61,7 +64,7 @@ let allocate_registers() = let slot = ref 0 in while !slot < nslots && conflict.(!slot) do incr slot done; reg.loc <- Stack(Local !slot); - if !slot >= nslots then Proc.num_stack_slots.(cl) <- !slot + 1 + if !slot >= nslots then num_stack_slots.(cl) <- !slot + 1 end else if reg.degree < Proc.num_available_registers.(cl) then unconstrained := reg :: !unconstrained else begin @@ -163,7 +166,7 @@ let allocate_registers() = if start >= num_regs then 0 else start) end else begin (* Sorry, we must put the pseudoreg in a stack location *) - let nslots = Proc.num_stack_slots.(cl) in + let nslots = num_stack_slots.(cl) in let score = Array.make nslots 0 in (* Compute the scores as for registers *) List.iter @@ -206,21 +209,17 @@ let allocate_registers() = else begin (* Allocate a new stack slot *) reg.loc <- Stack(Local nslots); - Proc.num_stack_slots.(cl) <- nslots + 1 + num_stack_slots.(cl) <- nslots + 1 end end; (* Cancel the preferences of this register so that they don't influence transitively the allocation of registers that prefer this reg. *) reg.prefer <- [] in - (* Reset the stack slot counts *) - for i = 0 to Proc.num_register_classes - 1 do - Proc.num_stack_slots.(i) <- 0; - done; - (* First pass: preallocate spill registers and split remaining regs Second pass: assign locations to constrained regs Third pass: assign locations to unconstrained regs *) List.iter remove_reg (Reg.all_registers()); OrderedRegSet.iter assign_location !constrained; - List.iter assign_location !unconstrained + List.iter assign_location !unconstrained; + num_stack_slots diff --git a/asmcomp/coloring.mli b/asmcomp/coloring.mli index 874a6f98e1..83439b90c7 100644 --- a/asmcomp/coloring.mli +++ b/asmcomp/coloring.mli @@ -15,4 +15,4 @@ (* Register allocation by coloring of the interference graph *) -val allocate_registers: unit -> unit +val allocate_registers: unit -> int array diff --git a/asmcomp/debug/compute_ranges.ml b/asmcomp/debug/compute_ranges.ml index 3ace8c2437..7d40194d44 100644 --- a/asmcomp/debug/compute_ranges.ml +++ b/asmcomp/debug/compute_ranges.ml @@ -16,7 +16,7 @@ open! Int_replace_polymorphic_compare -module L = Linearize +module L = Linear module Make (S : Compute_ranges_intf.S_functor) = struct module Subrange_state = S.Subrange_state @@ -39,7 +39,7 @@ module Make (S : Compute_ranges_intf.S_functor) = struct subrange_info : Subrange_info.t; } - let create ~(start_insn : Linearize.instruction) + let create ~(start_insn : L.instruction) ~start_pos ~start_pos_offset ~end_pos ~end_pos_offset ~subrange_info = diff --git a/asmcomp/debug/compute_ranges_intf.ml b/asmcomp/debug/compute_ranges_intf.ml index 69d82069ff..1fb4bdb600 100644 --- a/asmcomp/debug/compute_ranges_intf.ml +++ b/asmcomp/debug/compute_ranges_intf.ml @@ -28,7 +28,7 @@ the documentation on module type [S], below. *) -module L = Linearize +module L = Linear (** The type of caller-defined contextual state associated with subranges. This may be used to track information throughout the range-computing @@ -81,7 +81,7 @@ module type S_functor = sig module Index : Identifiable.S (** The module [Key] corresponds to the identifiers that define the ranges in - [Linearize] instructions. Each instruction should have two sets of keys, + [Linear] instructions. Each instruction should have two sets of keys, [available_before] and [available_across], with accessor functions of these names being provided to retrieve them. The notion of "availability" is not prescribed. The availability sets are used to compute subranges @@ -158,7 +158,7 @@ end (** This module type is the result type of the [Compute_ranges.Make] functor. The _ranges_ being computed are composed of contiguous _subranges_ delimited - by two labels (of type [Linearize.label]). These labels will be added by + by two labels (of type [Linear.label]). These labels will be added by this pass to the code being inspected, which is why the [create] function in the result of the functor returns not only the ranges but also the updated function with the labels added. The [start_pos_offset] and [end_pos_offset] @@ -199,7 +199,7 @@ module type S = sig val info : t -> Subrange_info.t (** The label at the start of the range. *) - val start_pos : t -> Linearize.label + val start_pos : t -> Linear.label (** How many bytes from the label at [start_pos] the range actually commences. If this value is zero, then the first byte of the range @@ -207,7 +207,7 @@ module type S = sig val start_pos_offset : t -> int (** The label at the end of the range. *) - val end_pos : t -> Linearize.label + val end_pos : t -> Linear.label (** Like [start_pos_offset], but analogously for the end of the range. (The sense is not inverted; a positive [end_pos_offset] means the range ends @@ -232,7 +232,7 @@ module type S = sig cross an extremity of any other range. (This should be satisfied in typical uses because the offsets are typically zero or one.) If there are no ranges supplied then [None] is returned. *) - val estimate_lowest_address : t -> (Linearize.label * int) option + val estimate_lowest_address : t -> (Linear.label * int) option (** Fold over all subranges within the given range. *) val fold @@ -251,7 +251,7 @@ module type S = sig (** Compute ranges for the code in the given linearized function declaration, returning the ranges as a value of type [t] and the rewritten code that must go forward for emission. *) - val create : Linearize.fundecl -> t * Linearize.fundecl + val create : Linear.fundecl -> t * Linear.fundecl (** Iterate through ranges. Each range is associated with an index. *) val iter : t -> f:(Index.t -> Range.t -> unit) -> unit diff --git a/asmcomp/emit.mli b/asmcomp/emit.mli index cab5083375..ad7ede8d21 100644 --- a/asmcomp/emit.mli +++ b/asmcomp/emit.mli @@ -15,7 +15,7 @@ (* Generation of assembly code *) -val fundecl: Linearize.fundecl -> unit +val fundecl: Linear.fundecl -> unit val data: Cmm.data_item list -> unit val begin_assembly: unit -> unit val end_assembly: unit -> unit diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 4f32d39102..9c1ca30a21 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -22,7 +22,7 @@ open Arch open Proc open Reg open Mach -open Linearize +open Linear open Emitaux module String = Misc.Stdlib.String @@ -56,6 +56,9 @@ let fastcode_flag = ref true let stack_offset = ref 0 (* Layout of the stack frame *) +let num_stack_slots = Array.make Proc.num_register_classes 0 + +let prologue_required = ref false let frame_size () = (* includes return address *) let sz = @@ -490,7 +493,7 @@ let emit_instr fallthrough i = match i.desc with | Lend -> () | Lprologue -> - assert (Proc.prologue_required ()); + assert (!prologue_required); let n = frame_size() - 4 in if n > 0 then begin I.sub (int n) esp; @@ -912,7 +915,7 @@ let rec emit_all fallthrough i = | _ -> emit_instr fallthrough i; emit_all - (system = S_win32 || Linearize.has_fallthrough i.desc) + (system = S_win32 || Linear.has_fallthrough i.desc) i.next (* Emission of a function declaration *) @@ -925,6 +928,10 @@ let fundecl fundecl = call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; + for i = 0 to Proc.num_register_classes - 1 do + num_stack_slots.(i) <- fundecl.fun_num_stack_slots.(i); + done; + prologue_required := fundecl.fun_prologue_required; emit_named_text_section !function_name; add_def_symbol fundecl.fun_name; D.align (if system = S_win32 then 4 else 16); diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index ee7e634983..e3e114a688 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -241,19 +241,16 @@ let op_is_pure = function (* Layout of the stack frame *) -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -let frame_required () = +let frame_required fd = let frame_size_at_top_of_function = (* cf. [frame_size] in emit.mlp. *) - Misc.align (4*num_stack_slots.(0) + 8*num_stack_slots.(1) + 4) + Misc.align (4*fd.fun_num_stack_slots.(0) + 8*fd.fun_num_stack_slots.(1) + 4) stack_alignment in frame_size_at_top_of_function > 4 -let prologue_required () = - frame_required () +let prologue_required fd = + frame_required fd (* Calling the assembler *) diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml index 511b7f1bd6..a95e67c665 100644 --- a/asmcomp/i386/reload.ml +++ b/asmcomp/i386/reload.ml @@ -82,5 +82,5 @@ method! reload_test tst arg = end -let fundecl f = - (new reload)#fundecl f +let fundecl f num_stack_slots = + (new reload)#fundecl f num_stack_slots diff --git a/asmcomp/i386/scheduling.ml b/asmcomp/i386/scheduling.ml index 05627b0405..c6c9a32473 100644 --- a/asmcomp/i386/scheduling.ml +++ b/asmcomp/i386/scheduling.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -let () = let module M = Schedgen in () (* to create a dependency *) +open! Schedgen (* to create a dependency *) (* Scheduling is turned off because our model does not fit the 486 nor the Pentium very well. In particular, it messes up with the diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index 7e62f2965a..4b95d663e0 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -302,7 +302,7 @@ method select_push exp = | _ -> (Ispecific(Ipush), exp) method! mark_c_tailcall = - Proc.contains_calls := true + contains_calls := true method! emit_extcall_args env args = let rec size_pushes = function diff --git a/asmcomp/linear.ml b/asmcomp/linear.ml new file mode 100644 index 0000000000..e0cf104cdc --- /dev/null +++ b/asmcomp/linear.ml @@ -0,0 +1,93 @@ +(**************************************************************************) +(* *) +(* 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 GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) +open Mach + +(* Transformation of Mach code into a list of pseudo-instructions. *) +type label = Cmm.label + +type instruction = + { mutable desc: instruction_desc; + mutable next: instruction; + arg: Reg.t array; + res: Reg.t array; + dbg: Debuginfo.t; + live: Reg.Set.t } + +and instruction_desc = + | Lprologue + | Lend + | Lop of Mach.operation + | Lreloadretaddr + | Lreturn + | Llabel of label + | Lbranch of label + | Lcondbranch of Mach.test * label + | Lcondbranch3 of label option * label option * label option + | Lswitch of label array + | Lentertrap + | Ladjust_trap_depth of { delta_traps : int; } + | Lpushtrap of { lbl_handler : label; } + | Lpoptrap + | Lraise of Lambda.raise_kind + +let has_fallthrough = function + | Lreturn | Lbranch _ | Lswitch _ | Lraise _ + | Lop Itailcall_ind _ | Lop (Itailcall_imm _) -> false + | _ -> true + +type fundecl = + { fun_name: string; + fun_args: Reg.Set.t; + fun_body: instruction; + fun_fast: bool; + fun_dbg : Debuginfo.t; + fun_spacetime_shape : Mach.spacetime_shape option; + fun_tailrec_entry_point_label : label; + fun_contains_calls: bool; + fun_num_stack_slots: int array; + fun_frame_required: bool; + fun_prologue_required: bool; + } + +(* Invert a test *) + +let invert_integer_test = function + Isigned cmp -> Isigned(Cmm.negate_integer_comparison cmp) + | Iunsigned cmp -> Iunsigned(Cmm.negate_integer_comparison cmp) + +let invert_test = function + Itruetest -> Ifalsetest + | Ifalsetest -> Itruetest + | Iinttest(cmp) -> Iinttest(invert_integer_test cmp) + | Iinttest_imm(cmp, n) -> Iinttest_imm(invert_integer_test cmp, n) + | Ifloattest(cmp) -> Ifloattest(Cmm.negate_float_comparison cmp) + | Ieventest -> Ioddtest + | Ioddtest -> Ieventest + +(* The "end" instruction *) + +let rec end_instr = + { desc = Lend; + next = end_instr; + arg = [||]; + res = [||]; + dbg = Debuginfo.none; + live = Reg.Set.empty } + +(* Cons an instruction (live, debug empty) *) + +let instr_cons d a r n = + { desc = d; next = n; arg = a; res = r; + dbg = Debuginfo.none; live = Reg.Set.empty } diff --git a/asmcomp/linear.mli b/asmcomp/linear.mli new file mode 100644 index 0000000000..3d289411fe --- /dev/null +++ b/asmcomp/linear.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* 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 GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Transformation of Mach code into a list of pseudo-instructions. *) + +type label = Cmm.label + +type instruction = + { mutable desc: instruction_desc; + mutable next: instruction; + arg: Reg.t array; + res: Reg.t array; + dbg: Debuginfo.t; + live: Reg.Set.t } + +and instruction_desc = + | Lprologue + | Lend + | Lop of Mach.operation + | Lreloadretaddr + | Lreturn + | Llabel of label + | Lbranch of label + | Lcondbranch of Mach.test * label + | Lcondbranch3 of label option * label option * label option + | Lswitch of label array + | Lentertrap + | Ladjust_trap_depth of { delta_traps : int; } + | Lpushtrap of { lbl_handler : label; } + | Lpoptrap + | Lraise of Lambda.raise_kind + +val has_fallthrough : instruction_desc -> bool +val end_instr: instruction +val instr_cons: + instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction +val invert_test: Mach.test -> Mach.test + +type fundecl = + { fun_name: string; + fun_args: Reg.Set.t; + fun_body: instruction; + fun_fast: bool; + fun_dbg : Debuginfo.t; + fun_spacetime_shape : Mach.spacetime_shape option; + fun_tailrec_entry_point_label : label; + fun_contains_calls: bool; + fun_num_stack_slots: int array; + fun_frame_required: bool; + fun_prologue_required: bool; + } diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index c1ae2c5588..33a1b5b5fe 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -14,82 +14,7 @@ (**************************************************************************) (* Transformation of Mach code into a list of pseudo-instructions. *) - -open Reg -open Mach - -type label = Cmm.label - -type instruction = - { mutable desc: instruction_desc; - mutable next: instruction; - arg: Reg.t array; - res: Reg.t array; - dbg: Debuginfo.t; - live: Reg.Set.t } - -and instruction_desc = - | Lprologue - | Lend - | Lop of operation - | Lreloadretaddr - | Lreturn - | Llabel of label - | Lbranch of label - | Lcondbranch of test * label - | Lcondbranch3 of label option * label option * label option - | Lswitch of label array - | Lentertrap - | Ladjust_trap_depth of { delta_traps : int; } - | Lpushtrap of { lbl_handler : label; } - | Lpoptrap - | Lraise of Lambda.raise_kind - -let has_fallthrough = function - | Lreturn | Lbranch _ | Lswitch _ | Lraise _ - | Lop Itailcall_ind _ | Lop (Itailcall_imm _) -> false - | _ -> true - -type fundecl = - { fun_name: string; - fun_args: Reg.Set.t; - fun_body: instruction; - fun_fast: bool; - fun_dbg : Debuginfo.t; - fun_spacetime_shape : Mach.spacetime_shape option; - fun_tailrec_entry_point_label : label; - } - -(* Invert a test *) - -let invert_integer_test = function - Isigned cmp -> Isigned(Cmm.negate_integer_comparison cmp) - | Iunsigned cmp -> Iunsigned(Cmm.negate_integer_comparison cmp) - -let invert_test = function - Itruetest -> Ifalsetest - | Ifalsetest -> Itruetest - | Iinttest(cmp) -> Iinttest(invert_integer_test cmp) - | Iinttest_imm(cmp, n) -> Iinttest_imm(invert_integer_test cmp, n) - | Ifloattest(cmp) -> Ifloattest(Cmm.negate_float_comparison cmp) - | Ieventest -> Ioddtest - | Ioddtest -> Ieventest - -(* The "end" instruction *) - -let rec end_instr = - { desc = Lend; - next = end_instr; - arg = [||]; - res = [||]; - dbg = Debuginfo.none; - live = Reg.Set.empty } - -(* Cons an instruction (live, debug empty) *) - -let instr_cons d a r n = - { desc = d; next = n; arg = a; res = r; - dbg = Debuginfo.none; live = Reg.Set.empty } +open Linear (* Cons a simple instruction (arg, res, live empty) *) @@ -208,134 +133,135 @@ let local_exit k = snd (find_exit_label_try_depth k) = !try_depth (* Linearize an instruction [i]: add it in front of the continuation [n] *) - -let rec linear i n = - match i.Mach.desc with - Iend -> n - | Iop(Itailcall_ind _ | Itailcall_imm _ as op) -> - if not Config.spacetime then - copy_instr (Lop op) i (discard_dead_code n) - else +let linear i n contains_calls = + let rec linear i n = + match i.Mach.desc with + Iend -> n + | Iop(Itailcall_ind _ | Itailcall_imm _ as op) -> + if not Config.spacetime then + copy_instr (Lop op) i (discard_dead_code n) + else + copy_instr (Lop op) i (linear i.Mach.next n) + | Iop(Imove | Ireload | Ispill) + when i.Mach.arg.(0).loc = i.Mach.res.(0).loc -> + linear i.Mach.next n + | Iop op -> copy_instr (Lop op) i (linear i.Mach.next n) - | Iop(Imove | Ireload | Ispill) - when i.Mach.arg.(0).loc = i.Mach.res.(0).loc -> - linear i.Mach.next n - | Iop op -> - copy_instr (Lop op) i (linear i.Mach.next n) - | Ireturn -> - let n1 = copy_instr Lreturn i (discard_dead_code n) in - if !Proc.contains_calls - then cons_instr Lreloadretaddr n1 - else n1 - | Iifthenelse(test, ifso, ifnot) -> - let n1 = linear i.Mach.next n in - begin match (ifso.Mach.desc, ifnot.Mach.desc, n1.desc) with - Iend, _, Lbranch lbl -> - copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1) - | _, Iend, Lbranch lbl -> - copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1) - | Iexit nfail1, Iexit nfail2, _ - when is_next_catch nfail1 && local_exit nfail2 -> - let lbl2 = find_exit_label nfail2 in - copy_instr - (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1) - | Iexit nfail, _, _ when local_exit nfail -> - let n2 = linear ifnot n1 - and lbl = find_exit_label nfail in - copy_instr (Lcondbranch(test, lbl)) i n2 - | _, Iexit nfail, _ when local_exit nfail -> - let n2 = linear ifso n1 in - let lbl = find_exit_label nfail in - copy_instr (Lcondbranch(invert_test test, lbl)) i n2 - | Iend, _, _ -> - let (lbl_end, n2) = get_label n1 in - copy_instr (Lcondbranch(test, lbl_end)) i (linear ifnot n2) - | _, Iend, _ -> - let (lbl_end, n2) = get_label n1 in - copy_instr (Lcondbranch(invert_test test, lbl_end)) i - (linear ifso n2) - | _, _, _ -> - (* Should attempt branch prediction here *) - let (lbl_end, n2) = get_label n1 in - let (lbl_else, nelse) = get_label (linear ifnot n2) in - copy_instr (Lcondbranch(invert_test test, lbl_else)) i - (linear ifso (add_branch lbl_end nelse)) - end - | Iswitch(index, cases) -> - let lbl_cases = Array.make (Array.length cases) 0 in - let (lbl_end, n1) = get_label(linear i.Mach.next n) in - let n2 = ref (discard_dead_code n1) in - for i = Array.length cases - 1 downto 0 do - let (lbl_case, ncase) = - get_label(linear cases.(i) (add_branch lbl_end !n2)) in - lbl_cases.(i) <- lbl_case; - n2 := discard_dead_code ncase - done; - (* Switches with 1 and 2 branches have been eliminated earlier. - Here, we do something for switches with 3 branches. *) - if Array.length index = 3 then begin - let fallthrough_lbl = check_label !n2 in - let find_label n = - let lbl = lbl_cases.(index.(n)) in - if lbl = fallthrough_lbl then None else Some lbl in - copy_instr (Lcondbranch3(find_label 0, find_label 1, find_label 2)) - i !n2 - end else - copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2 - | Icatch(_rec_flag, handlers, body) -> - let (lbl_end, n1) = get_label(linear i.Mach.next n) in - (* CR mshinwell for pchambart: - 1. rename "io" - 2. Make sure the test cases cover the "Iend" cases too *) - let labels_at_entry_to_handlers = List.map (fun (_nfail, handler) -> - match handler.Mach.desc with - | Iend -> lbl_end - | _ -> Cmm.new_label ()) - handlers in - let exit_label_add = List.map2 - (fun (nfail, _) lbl -> (nfail, (lbl, !try_depth))) - handlers labels_at_entry_to_handlers in - let previous_exit_label = !exit_label in - exit_label := exit_label_add @ !exit_label; - let n2 = List.fold_left2 (fun n (_nfail, handler) lbl_handler -> - match handler.Mach.desc with - | Iend -> n - | _ -> cons_instr (Llabel lbl_handler) - (linear handler (add_branch lbl_end n))) - n1 handlers labels_at_entry_to_handlers - in - let n3 = linear body (add_branch lbl_end n2) in - exit_label := previous_exit_label; - n3 - | Iexit nfail -> - let lbl, t = find_exit_label_try_depth nfail in - assert (i.Mach.next.desc = Iend); - let delta_traps = !try_depth - t in - let n1 = adjust_trap_depth delta_traps n in - let rec loop i tt = - if t = tt then i - else loop (cons_instr Lpoptrap i) (tt - 1) - in - loop (add_branch lbl n1) !try_depth - | Itrywith(body, handler) -> - let (lbl_join, n1) = get_label (linear i.Mach.next n) in - let (lbl_handler, n2) = - get_label (cons_instr Lentertrap (linear handler n1)) - in - incr try_depth; - assert (i.Mach.arg = [| |] || Config.spacetime); - let n3 = cons_instr (Lpushtrap { lbl_handler; }) - (linear body - (cons_instr - Lpoptrap - (add_branch lbl_join n2))) in - decr try_depth; - n3 - - | Iraise k -> - copy_instr (Lraise k) i (discard_dead_code n) - -let add_prologue first_insn = + | Ireturn -> + let n1 = copy_instr Lreturn i (discard_dead_code n) in + if contains_calls + then cons_instr Lreloadretaddr n1 + else n1 + | Iifthenelse(test, ifso, ifnot) -> + let n1 = linear i.Mach.next n in + begin match (ifso.Mach.desc, ifnot.Mach.desc, n1.desc) with + Iend, _, Lbranch lbl -> + copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1) + | _, Iend, Lbranch lbl -> + copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1) + | Iexit nfail1, Iexit nfail2, _ + when is_next_catch nfail1 && local_exit nfail2 -> + let lbl2 = find_exit_label nfail2 in + copy_instr + (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1) + | Iexit nfail, _, _ when local_exit nfail -> + let n2 = linear ifnot n1 + and lbl = find_exit_label nfail in + copy_instr (Lcondbranch(test, lbl)) i n2 + | _, Iexit nfail, _ when local_exit nfail -> + let n2 = linear ifso n1 in + let lbl = find_exit_label nfail in + copy_instr (Lcondbranch(invert_test test, lbl)) i n2 + | Iend, _, _ -> + let (lbl_end, n2) = get_label n1 in + copy_instr (Lcondbranch(test, lbl_end)) i (linear ifnot n2) + | _, Iend, _ -> + let (lbl_end, n2) = get_label n1 in + copy_instr (Lcondbranch(invert_test test, lbl_end)) i + (linear ifso n2) + | _, _, _ -> + (* Should attempt branch prediction here *) + let (lbl_end, n2) = get_label n1 in + let (lbl_else, nelse) = get_label (linear ifnot n2) in + copy_instr (Lcondbranch(invert_test test, lbl_else)) i + (linear ifso (add_branch lbl_end nelse)) + end + | Iswitch(index, cases) -> + let lbl_cases = Array.make (Array.length cases) 0 in + let (lbl_end, n1) = get_label(linear i.Mach.next n) in + let n2 = ref (discard_dead_code n1) in + for i = Array.length cases - 1 downto 0 do + let (lbl_case, ncase) = + get_label(linear cases.(i) (add_branch lbl_end !n2)) in + lbl_cases.(i) <- lbl_case; + n2 := discard_dead_code ncase + done; + (* Switches with 1 and 2 branches have been eliminated earlier. + Here, we do something for switches with 3 branches. *) + if Array.length index = 3 then begin + let fallthrough_lbl = check_label !n2 in + let find_label n = + let lbl = lbl_cases.(index.(n)) in + if lbl = fallthrough_lbl then None else Some lbl in + copy_instr (Lcondbranch3(find_label 0, find_label 1, find_label 2)) + i !n2 + end else + copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2 + | Icatch(_rec_flag, handlers, body) -> + let (lbl_end, n1) = get_label(linear i.Mach.next n) in + (* CR mshinwell for pchambart: + 1. rename "io" + 2. Make sure the test cases cover the "Iend" cases too *) + let labels_at_entry_to_handlers = List.map (fun (_nfail, handler) -> + match handler.Mach.desc with + | Iend -> lbl_end + | _ -> Cmm.new_label ()) + handlers in + let exit_label_add = List.map2 + (fun (nfail, _) lbl -> (nfail, (lbl, !try_depth))) + handlers labels_at_entry_to_handlers in + let previous_exit_label = !exit_label in + exit_label := exit_label_add @ !exit_label; + let n2 = List.fold_left2 (fun n (_nfail, handler) lbl_handler -> + match handler.Mach.desc with + | Iend -> n + | _ -> cons_instr (Llabel lbl_handler) + (linear handler (add_branch lbl_end n))) + n1 handlers labels_at_entry_to_handlers + in + let n3 = linear body (add_branch lbl_end n2) in + exit_label := previous_exit_label; + n3 + | Iexit nfail -> + let lbl, t = find_exit_label_try_depth nfail in + assert (i.Mach.next.desc = Mach.Iend); + let delta_traps = !try_depth - t in + let n1 = adjust_trap_depth delta_traps n in + let rec loop i tt = + if t = tt then i + else loop (cons_instr Lpoptrap i) (tt - 1) + in + loop (add_branch lbl n1) !try_depth + | Itrywith(body, handler) -> + let (lbl_join, n1) = get_label (linear i.Mach.next n) in + let (lbl_handler, n2) = + get_label (cons_instr Lentertrap (linear handler n1)) + in + incr try_depth; + assert (i.Mach.arg = [| |] || Config.spacetime); + let n3 = cons_instr (Lpushtrap { lbl_handler; }) + (linear body + (cons_instr + Lpoptrap + (add_branch lbl_join n2))) in + decr try_depth; + n3 + + | Iraise k -> + copy_instr (Lraise k) i (discard_dead_code n) + in linear i n + +let add_prologue first_insn prologue_required = (* The prologue needs to come after any [Iname_for_debugger] operations that refer to parameters. (Such operations always come in a contiguous block, cf. [Selectgen].) *) @@ -378,7 +304,7 @@ let add_prologue first_insn = (which is encoded with two zero words), then complaining about a "hole in location list" (as it ignores any remaining list entries after the misinterpreted entry). *) - if Proc.prologue_required () then + if prologue_required then let prologue = { desc = Lprologue; next = tailrec_entry_point; @@ -395,8 +321,11 @@ let add_prologue first_insn = skip_naming_ops first_insn let fundecl f = + let fun_prologue_required = Proc.prologue_required f in + let contains_calls = f.Mach.fun_contains_calls in let fun_tailrec_entry_point_label, fun_body = - add_prologue (linear f.Mach.fun_body end_instr) + add_prologue (linear f.Mach.fun_body end_instr contains_calls) + fun_prologue_required in { fun_name = f.Mach.fun_name; fun_args = Reg.set_of_array f.Mach.fun_args; @@ -405,4 +334,8 @@ let fundecl f = fun_dbg = f.Mach.fun_dbg; fun_spacetime_shape = f.Mach.fun_spacetime_shape; fun_tailrec_entry_point_label; + fun_contains_calls = contains_calls; + fun_num_stack_slots = f.Mach.fun_num_stack_slots; + fun_frame_required = Proc.frame_required f; + fun_prologue_required; } diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index ca40fccd58..080b304bf2 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -14,48 +14,4 @@ (**************************************************************************) (* Transformation of Mach code into a list of pseudo-instructions. *) - -type label = Cmm.label - -type instruction = - { mutable desc: instruction_desc; - mutable next: instruction; - arg: Reg.t array; - res: Reg.t array; - dbg: Debuginfo.t; - live: Reg.Set.t } - -and instruction_desc = - | Lprologue - | Lend - | Lop of Mach.operation - | Lreloadretaddr - | Lreturn - | Llabel of label - | Lbranch of label - | Lcondbranch of Mach.test * label - | Lcondbranch3 of label option * label option * label option - | Lswitch of label array - | Lentertrap - | Ladjust_trap_depth of { delta_traps : int; } - | Lpushtrap of { lbl_handler : label; } - | Lpoptrap - | Lraise of Lambda.raise_kind - -val has_fallthrough : instruction_desc -> bool -val end_instr: instruction -val instr_cons: - instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction -val invert_test: Mach.test -> Mach.test - -type fundecl = - { fun_name: string; - fun_args: Reg.Set.t; - fun_body: instruction; - fun_fast: bool; - fun_dbg : Debuginfo.t; - fun_spacetime_shape : Mach.spacetime_shape option; - fun_tailrec_entry_point_label : label; - } - -val fundecl: Mach.fundecl -> fundecl +val fundecl: Mach.fundecl -> Linear.fundecl diff --git a/asmcomp/linscan.ml b/asmcomp/linscan.ml index d1bfbe546c..21416be23d 100644 --- a/asmcomp/linscan.ml +++ b/asmcomp/linscan.ml @@ -71,10 +71,10 @@ let rec release_expired_inactive ci pos = function (* Allocate a new stack slot to the interval. *) -let allocate_stack_slot i = +let allocate_stack_slot num_stack_slots i = let cl = Proc.register_class i.reg in - let ss = Proc.num_stack_slots.(cl) in - Proc.num_stack_slots.(cl) <- succ ss; + let ss = num_stack_slots.(cl) in + num_stack_slots.(cl) <- succ ss; i.reg.loc <- Stack(Local ss); i.reg.spill <- true @@ -82,11 +82,11 @@ let allocate_stack_slot i = The interval is added to active. Raises Not_found if no free registers left. *) -let allocate_free_register i = +let allocate_free_register num_stack_slots i = begin match i.reg.loc, i.reg.spill with Unknown, true -> (* Allocate a stack slot for the already spilled interval *) - allocate_stack_slot i + allocate_stack_slot num_stack_slots i | Unknown, _ -> (* We need to allocate a register to this interval somehow *) let cl = Proc.register_class i.reg in @@ -136,7 +136,7 @@ let allocate_free_register i = | _ -> () end -let allocate_blocked_register i = +let allocate_blocked_register num_stack_slots i = let cl = Proc.register_class i.reg in let ci = active.(cl) in match ci.ci_active with @@ -154,14 +154,14 @@ let allocate_blocked_register i = (* Remove the last interval from active and insert the current *) ci.ci_active <- insert_interval_sorted i il; (* Now get a new stack slot for the spilled register *) - allocate_stack_slot ilast + allocate_stack_slot num_stack_slots ilast | _ -> (* Either the current interval is last and we have to spill it, or there are no registers at all in the register class (i.e. floating point class on i386). *) - allocate_stack_slot i + allocate_stack_slot num_stack_slots i -let walk_interval i = +let walk_interval num_stack_slots i = let pos = i.ibegin land (lnot 0x01) in (* Release all intervals that have been expired at the current position *) Array.iter @@ -172,11 +172,11 @@ let walk_interval i = active; try (* Allocate free register (if any) *) - allocate_free_register i + allocate_free_register num_stack_slots i with Not_found -> (* No free register, need to decide which interval to spill *) - allocate_blocked_register i + allocate_blocked_register num_stack_slots i let allocate_registers() = (* Initialize the stack slots and interval lists *) @@ -187,8 +187,9 @@ let allocate_registers() = ci_active = []; ci_inactive = [] }; - Proc.num_stack_slots.(cl) <- 0 done; + (* Reset the stack slot counts *) + let num_stack_slots = Array.make Proc.num_register_classes 0 in (* Add all fixed intervals (sorted by end position) *) List.iter (fun i -> @@ -196,4 +197,5 @@ let allocate_registers() = ci.ci_fixed <- insert_interval_sorted i ci.ci_fixed) (Interval.all_fixed_intervals()); (* Walk all the intervals within the list *) - List.iter walk_interval (Interval.all_intervals()) + List.iter (walk_interval num_stack_slots) (Interval.all_intervals()); + num_stack_slots diff --git a/asmcomp/linscan.mli b/asmcomp/linscan.mli index b978eeb5c2..650e41391b 100644 --- a/asmcomp/linscan.mli +++ b/asmcomp/linscan.mli @@ -16,4 +16,4 @@ (* Linear scan register allocation. *) -val allocate_registers: unit -> unit +val allocate_registers: unit -> int array diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 721be95cce..f9eeda751d 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -102,6 +102,8 @@ type fundecl = fun_codegen_options : Cmm.codegen_option list; fun_dbg : Debuginfo.t; fun_spacetime_shape : spacetime_shape option; + fun_num_stack_slots: int array; + fun_contains_calls: bool; } let rec dummy_instr = diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index ed27df3115..f49a4d1788 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -125,6 +125,8 @@ type fundecl = fun_codegen_options : Cmm.codegen_option list; fun_dbg : Debuginfo.t; fun_spacetime_shape : spacetime_shape option; + fun_num_stack_slots: int array; + fun_contains_calls: bool; } val dummy_instr: instruction diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index e667893562..4c577d0b18 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -21,7 +21,7 @@ open Arch open Proc open Reg open Mach -open Linearize +open Linear open Emitaux (* Reserved space at bottom of stack *) @@ -36,6 +36,12 @@ let reserved_stack_space = let stack_offset = ref 0 +let num_stack_slots = Array.make Proc.num_register_classes 0 + +let prologue_required = ref false + +let contains_calls = ref false + let frame_size () = let size = reserved_stack_space + @@ -557,7 +563,7 @@ let emit_instr i = match i.desc with | Lend -> () | Lprologue -> - assert (Proc.prologue_required ()); + assert (!prologue_required); let n = frame_size() in if n > 0 then begin ` addi 1, 1, {emit_int(-n)}\n`; @@ -1048,6 +1054,11 @@ let fundecl fundecl = call_gc_labels := IntMap.empty; float_literals := []; jumptables := []; jumptables_lbl := -1; + for i = 0 to Proc.num_register_classes - 1 do + num_stack_slots.(i) <- fundecl.fun_num_stack_slots.(i); + done; + prologue_required := fundecl.fun_prologue_required; + contains_calls := fundecl.fun_contains_calls; begin match abi with | ELF32 -> emit_string code_space; diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 8a585e5a80..3bcd12fcbf 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -339,28 +339,25 @@ let op_is_pure = function (* Layout of the stack *) -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - (* See [reserved_stack_space] in emit.mlp. *) let reserved_stack_space_required () = match abi with | ELF32 -> false | ELF64v1 | ELF64v2 -> true -let frame_required () = +let frame_required fd = let is_elf32 = match abi with | ELF32 -> true | ELF64v1 | ELF64v2 -> false in reserved_stack_space_required () - || num_stack_slots.(0) > 0 - || num_stack_slots.(1) > 0 - || (!contains_calls && is_elf32) + || fd.fun_num_stack_slots.(0) > 0 + || fd.fun_num_stack_slots.(1) > 0 + || (fd.fun_contains_calls && is_elf32) -let prologue_required () = - frame_required () +let prologue_required fd = + frame_required fd (* Calling the assembler *) diff --git a/asmcomp/power/reload.ml b/asmcomp/power/reload.ml index 040c793915..21ace08cf3 100644 --- a/asmcomp/power/reload.ml +++ b/asmcomp/power/reload.ml @@ -15,5 +15,5 @@ (* Reloading for the PowerPC *) -let fundecl f = - (new Reloadgen.reload_generic)#fundecl f +let fundecl f num_stack_slots = + (new Reloadgen.reload_generic)#fundecl f num_stack_slots diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index 29566a410f..793580c09b 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -18,7 +18,7 @@ open Format open Mach open Printmach -open Linearize +open Linear let label ppf l = Format.fprintf ppf "L%i" l diff --git a/asmcomp/printlinear.mli b/asmcomp/printlinear.mli index b598868e0e..fdf3602460 100644 --- a/asmcomp/printlinear.mli +++ b/asmcomp/printlinear.mli @@ -16,7 +16,7 @@ (* Pretty-printing of linearized machine code *) open Format -open Linearize +open Linear val instr: formatter -> instruction -> unit val fundecl: formatter -> fundecl -> unit diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index 4e0e03640e..91b15de45c 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -65,12 +65,10 @@ val regs_are_volatile: Reg.t array -> bool val op_is_pure: Mach.operation -> bool (* Info for laying out the stack frame *) -val num_stack_slots: int array -val contains_calls: bool ref -val frame_required : unit -> bool +val frame_required : Mach.fundecl -> bool (* Function prologues *) -val prologue_required : unit -> bool +val prologue_required : Mach.fundecl -> bool (** For a given register class, the DWARF register numbering for that class. Given an allocated register with location [Reg n] and class [reg_class], the diff --git a/asmcomp/reload.mli b/asmcomp/reload.mli index f636877ba5..5d9e35e31b 100644 --- a/asmcomp/reload.mli +++ b/asmcomp/reload.mli @@ -15,4 +15,4 @@ (* Insert load/stores for pseudoregs that got assigned to stack locations. *) -val fundecl: Mach.fundecl -> Mach.fundecl * bool +val fundecl: Mach.fundecl -> int array -> Mach.fundecl * bool diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index b1f260c1ae..bea7bafa7e 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -123,11 +123,14 @@ method private reload i = instr_cons (Itrywith(self#reload body, self#reload handler)) [||] [||] (self#reload i.next) -method fundecl f = +method fundecl f num_stack_slots = redo_regalloc <- false; let new_body = self#reload f.fun_body in ({fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body; fun_codegen_options = f.fun_codegen_options; - fun_dbg = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape}, + fun_dbg = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape; + fun_contains_calls = f.fun_contains_calls; + fun_num_stack_slots = Array.copy num_stack_slots; + }, redo_regalloc) end diff --git a/asmcomp/reloadgen.mli b/asmcomp/reloadgen.mli index 75e870fb1c..638082f0a7 100644 --- a/asmcomp/reloadgen.mli +++ b/asmcomp/reloadgen.mli @@ -22,6 +22,6 @@ class reload_generic : object method makereg : Reg.t -> Reg.t (* Can be overridden to avoid creating new registers of some class (i.e. if all "registers" of that class are actually on stack) *) - method fundecl : Mach.fundecl -> Mach.fundecl * bool + method fundecl : Mach.fundecl -> int array -> Mach.fundecl * bool (* The entry point *) end diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp index 897f405e89..05070ec7ca 100644 --- a/asmcomp/s390x/emit.mlp +++ b/asmcomp/s390x/emit.mlp @@ -22,13 +22,19 @@ open Arch open Proc open Reg open Mach -open Linearize +open Linear open Emitaux (* Layout of the stack. The stack is kept 8-aligned. *) let stack_offset = ref 0 +let num_stack_slots = Array.make Proc.num_register_classes 0 + +let prologue_required = ref false + +let contains_calls = ref false + let frame_size () = let size = !stack_offset + (* Trap frame, outgoing parameters *) @@ -308,7 +314,7 @@ let emit_instr i = match i.desc with Lend -> () | Lprologue -> - assert (Proc.prologue_required ()); + assert (!prologue_required); let n = frame_size() in emit_stack_adjust n; if !contains_calls then @@ -668,6 +674,11 @@ let fundecl fundecl = bound_error_call := 0; float_literals := []; int_literals := []; + for i = 0 to Proc.num_register_classes - 1 do + num_stack_slots.(i) <- fundecl.fun_num_stack_slots.(i); + done; + prologue_required := fundecl.fun_prologue_required; + contains_calls := fundecl.fun_contains_calls; ` .globl {emit_symbol fundecl.fun_name}\n`; emit_debug_info fundecl.fun_dbg; ` .type {emit_symbol fundecl.fun_name}, @function\n`; diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml index 73c141653b..9f0dff2132 100644 --- a/asmcomp/s390x/proc.ml +++ b/asmcomp/s390x/proc.ml @@ -225,16 +225,13 @@ let op_is_pure = function (* Layout of the stack *) -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false +let frame_required fd = + fd.fun_contains_calls + || fd.fun_num_stack_slots.(0) > 0 + || fd.fun_num_stack_slots.(1) > 0 -let frame_required () = - !contains_calls - || num_stack_slots.(0) > 0 - || num_stack_slots.(1) > 0 - -let prologue_required () = - frame_required () +let prologue_required fd = + frame_required fd (* Calling the assembler *) diff --git a/asmcomp/s390x/reload.ml b/asmcomp/s390x/reload.ml index f5d710a132..46d1daa70e 100644 --- a/asmcomp/s390x/reload.ml +++ b/asmcomp/s390x/reload.ml @@ -46,5 +46,5 @@ method! reload_operation op arg res = end -let fundecl f = - (new reload)#fundecl f +let fundecl f num_stack_slots = + (new reload)#fundecl f num_stack_slots diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index e843919ef1..35fe1ec95c 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -17,7 +17,7 @@ open Reg open Mach -open Linearize +open Linear (* Representation of the code DAG. *) @@ -394,6 +394,10 @@ method schedule_fundecl f = fun_dbg = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape; fun_tailrec_entry_point_label = f.fun_tailrec_entry_point_label; + fun_contains_calls = f.fun_contains_calls; + fun_num_stack_slots = f.fun_num_stack_slots; + fun_frame_required = f.fun_frame_required; + fun_prologue_required = f.fun_prologue_required; } end else f diff --git a/asmcomp/schedgen.mli b/asmcomp/schedgen.mli index 0fa16dacac..bc3f798dad 100644 --- a/asmcomp/schedgen.mli +++ b/asmcomp/schedgen.mli @@ -16,7 +16,7 @@ (* Instruction scheduling *) type code_dag_node = - { instr: Linearize.instruction; + { instr: Linear.instruction; delay: int; mutable sons: (code_dag_node * int) list; mutable date: int; @@ -43,7 +43,7 @@ class virtual scheduler_generic : object method is_checkbound : Mach.operation -> bool (* Says whether the given operation is a checkbound *) (* Entry point *) - method schedule_fundecl : Linearize.fundecl -> Linearize.fundecl + method schedule_fundecl : Linear.fundecl -> Linear.fundecl end val reset : unit -> unit diff --git a/asmcomp/scheduling.mli b/asmcomp/scheduling.mli index 9383010638..9f73478091 100644 --- a/asmcomp/scheduling.mli +++ b/asmcomp/scheduling.mli @@ -15,4 +15,4 @@ (* Instruction scheduling *) -val fundecl: Linearize.fundecl -> Linearize.fundecl +val fundecl: Linear.fundecl -> Linear.fundecl diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index d17d383903..d9fa22c7f1 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -387,9 +387,10 @@ method select_store is_assign addr arg = (Istore(Word_val, addr, is_assign), arg) (* call marking methods, documented in selectgen.mli *) +val contains_calls = ref false method mark_call = - Proc.contains_calls := true + contains_calls := true method mark_tailcall = () @@ -1221,7 +1222,6 @@ method insert_prologue _f ~loc_arg ~rarg ~spacetime_node_hole:_ ~env = method initial_env () = env_empty method emit_fundecl f = - Proc.contains_calls := false; current_function_name := f.Cmm.fun_name; let rargs = List.map @@ -1260,6 +1260,8 @@ method emit_fundecl f = fun_codegen_options = f.Cmm.fun_codegen_options; fun_dbg = f.Cmm.fun_dbg; fun_spacetime_shape; + fun_num_stack_slots = Array.make Proc.num_register_classes 0; + fun_contains_calls = !contains_calls; } end diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 23252c43e1..790f4c5f36 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -107,7 +107,7 @@ class virtual selector_generic : object method mark_call : unit (* informs the code emitter that the current function is non-leaf: it may perform a (non-tail) call; by default, sets - [Proc.contains_calls := true] *) + [contains_calls := true] *) method mark_tailcall : unit (* informs the code emitter that the current function may end with @@ -121,7 +121,7 @@ class virtual selector_generic : object (which is the main purpose of tracking leaf functions) but some architectures still need to ensure that the stack is properly aligned when the C function is called. This is achieved by - overloading this method to set [Proc.contains_calls := true] *) + overloading this method to set [contains_calls := true] *) method mark_instr : Mach.instruction_desc -> unit (* dispatches on instructions to call one of the marking function @@ -181,6 +181,10 @@ class virtual selector_generic : object val mutable instr_seq : Mach.instruction + (* [contains_calls] is declared as a reference instance variable, + instead of a mutable boolean instance variable, + because the traversal uses functional object copies. *) + val contains_calls : bool ref end val reset : unit -> unit diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 0aeee83c2b..da739f973c 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -432,4 +432,6 @@ let fundecl f = fun_codegen_options = f.fun_codegen_options; fun_dbg = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape; + fun_num_stack_slots = f.fun_num_stack_slots; + fun_contains_calls = f.fun_contains_calls; } diff --git a/asmcomp/split.ml b/asmcomp/split.ml index cfe4b0d623..87c9c71f65 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -220,4 +220,6 @@ let fundecl f = fun_codegen_options = f.fun_codegen_options; fun_dbg = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape; + fun_num_stack_slots = f.fun_num_stack_slots; + fun_contains_calls = f.fun_contains_calls; } @@ -673,6 +673,8 @@ ac_ct_LD LD DEFAULT_STRING WINDOWS_UNICODE_MODE +BFD_LIB_DIR +BFD_INCLUDE_DIR LIBUNWIND_LIB_DIR LIBUNWIND_INCLUDE_DIR DLLIBS @@ -719,8 +721,9 @@ sharedlib_cflags asm_cfi_supported AS ASPP -libbfd_link -libbfd_include +bfd_ldlibs +bfd_ldflags +bfd_cppflags x_libraries x_includes pthread_link @@ -828,6 +831,7 @@ enable_instrumented_runtime enable_vmthreads enable_systhreads with_libunwind +with_bfd enable_graph_lib enable_str_lib enable_unix_lib @@ -868,6 +872,8 @@ PARTIALLD DLLIBS LIBUNWIND_INCLUDE_DIR LIBUNWIND_LIB_DIR +BFD_INCLUDE_DIR +BFD_LIB_DIR WINDOWS_UNICODE_MODE DEFAULT_STRING CC @@ -1520,8 +1526,8 @@ Optional Features: --enable-reserved-header-bits=BITS reserve BITS (between 0 and 31) bits in block headers for profiling info - --enable-force-safe-string - force strings to be safe + --disable-force-safe-string + do not force strings to be safe --disable-flat-float-array do not use flat float arrays --disable-function-sections @@ -1536,6 +1542,8 @@ Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --without-libunwind disable libunwind support for Spacetime profiling + --without-bfd disable BFD (Binary File Description) library + support --with-target-bindir location of binary programs on target system --with-afl use the AFL fuzzer --with-pic[=PKGS] try to use only PIC/non-PIC objects [default=use @@ -1557,6 +1565,9 @@ Some influential environment variables: location of header files for libunwind LIBUNWIND_LIB_DIR location of library files for libunwind + BFD_INCLUDE_DIR + location of header files for the BFD library + BFD_LIB_DIR location of library files for the BFD library WINDOWS_UNICODE_MODE how to handle Unicode under Windows: ansi, compatible DEFAULT_STRING @@ -2823,6 +2834,7 @@ VERSION=4.10.0+multicore+dev0 + ## Generated files ac_config_files="$ac_config_files Makefile.common" @@ -3020,6 +3032,19 @@ fi + +# Check whether --with-bfd was given. +if test "${with_bfd+set}" = set; then : + withval=$with_bfd; +else + with_bfd=auto +fi + + + + + + # Check whether --enable-graph-lib was given. if test "${enable_graph_lib+set}" = set; then : enableval=$enable_graph_lib; as_fn_error $? "The graphics library is no longer distributed with OCaml \ @@ -3162,9 +3187,11 @@ fi # explicitly passed. # # The configure-time behavior of OCaml 4.05 and older was equivalent -# to --disable-force-safe-string DEFAULT_STRING=unsafe. OCaml 4.06 -# and later use --disable-force-safe-string DEFAULT_STRING=safe. We -# expect --enable-force-safe-string to become the default in the future. +# to --disable-force-safe-string DEFAULT_STRING=unsafe. With OCaml 4.06 +# and older was equivalent to --disable-force-safe-string DEFAULT_STRING=safe. +# With OCaml 4.10 and later use --enable-force-safe-string DEFAULT_STRING=safe. +# We expect the --disable-force-safe-string and DEFAULT_STRING=unsafe options +# to be removed in the future. # Check whether --enable-force-safe-string was given. if test "${enable_force_safe_string+set}" = set; then : @@ -15884,12 +15911,39 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu esac fi -## libbfd +## BFD (Binary File Description) library + +bfd_cppflags="" +bfd_ldflags="" +bfd_ldlibs="" -ac_fn_c_check_header_mongrel "$LINENO" "bfd.h" "ac_cv_header_bfd_h" "$ac_includes_default" +if test x"$with_bfd" != "xno"; then : + bfd_available=false + case $host in #( + x86_64-*-darwin*) : + if test -z "$BFD_INCLUDE_DIR"; then : + BFD_INCLUDE_DIR="/opt/local/include" +fi + if test -z "$BFD_LIB_DIR"; then : + BFD_LIB_DIR="/opt/local/lib" +fi ;; #( + *) : + ;; +esac + if test -n "$BFD_INCLUDE_DIR"; then : + bfd_cppflags="-I$BFD_INCLUDE_DIR" +fi + if test -n "$BFD_LIB_DIR"; then : + bfd_ldflags="-L$BFD_LIB_DIR" +fi + SAVED_CPPFLAGS="$CPPFLAGS" + SAVED_LDFLAGS="$LDFLAGS" + CPPFLAGS="$CPPFLAGS $bfd_cppflags" + LDFLAGS="$LDFLAGS $bfd_ldflags" + ac_fn_c_check_header_mongrel "$LINENO" "bfd.h" "ac_cv_header_bfd_h" "$ac_includes_default" if test "x$ac_cv_header_bfd_h" = xyes; then : - libbfd_ling="" - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5 + bfd_ldlibs="" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5 $as_echo_n "checking for bfd_openr in -lbfd... " >&6; } if ${ac_cv_lib_bfd_bfd_openr+:} false; then : $as_echo_n "(cached) " >&6 @@ -15926,10 +15980,10 @@ fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_openr" >&5 $as_echo "$ac_cv_lib_bfd_bfd_openr" >&6; } if test "x$ac_cv_lib_bfd_bfd_openr" = xyes; then : - libbfd_link="-lbfd" + bfd_ldlibs="-lbfd" fi - if test -z "$libbfd_link"; then : + if test -z "$bfd_ldlibs"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5 $as_echo_n "checking for bfd_openr in -lbfd... " >&6; } if ${ac_cv_lib_bfd_bfd_openr+:} false; then : @@ -15967,11 +16021,11 @@ fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_openr" >&5 $as_echo "$ac_cv_lib_bfd_bfd_openr" >&6; } if test "x$ac_cv_lib_bfd_bfd_openr" = xyes; then : - libbfd_link="-lbfd -ldl" + bfd_ldlibs="-lbfd -ldl" fi fi - if test -z "$libbfd_link"; then : + if test -z "$bfd_ldlibs"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5 $as_echo_n "checking for bfd_openr in -lbfd... " >&6; } if ${ac_cv_lib_bfd_bfd_openr+:} false; then : @@ -16009,11 +16063,11 @@ fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_openr" >&5 $as_echo "$ac_cv_lib_bfd_bfd_openr" >&6; } if test "x$ac_cv_lib_bfd_bfd_openr" = xyes; then : - libbfd_link="-lbfd -ldl -liberty" + bfd_ldlibs="-lbfd -ldl -liberty" fi fi - if test -z "$libbfd_link"; then : + if test -z "$bfd_ldlibs"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5 $as_echo_n "checking for bfd_openr in -lbfd... " >&6; } if ${ac_cv_lib_bfd_bfd_openr+:} false; then : @@ -16051,11 +16105,11 @@ fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_openr" >&5 $as_echo "$ac_cv_lib_bfd_bfd_openr" >&6; } if test "x$ac_cv_lib_bfd_bfd_openr" = xyes; then : - libbfd_link="-lbfd -ldl -liberty -lz" + bfd_ldlibs="-lbfd -ldl -liberty -lz" fi fi - if test -z "$libbfd_link"; then : + if test -z "$bfd_ldlibs"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5 $as_echo_n "checking for bfd_openr in -lbfd... " >&6; } if ${ac_cv_lib_bfd_bfd_openr+:} false; then : @@ -16093,21 +16147,34 @@ fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_openr" >&5 $as_echo "$ac_cv_lib_bfd_bfd_openr" >&6; } if test "x$ac_cv_lib_bfd_bfd_openr" = xyes; then : - libbfd_link="-lbfd -ldl -liberty -lz -lintl" + bfd_ldlibs="-lbfd -ldl -liberty -lz -lintl" fi fi - if test -n "$libbfd_link"; then : - $as_echo "#define HAS_LIBBFD 1" >>confdefs.h + if test -n "$bfd_ldlibs"; then : + bfd_available=true + $as_echo "#define HAS_LIBBFD 1" >>confdefs.h -else - { $as_echo "$as_me:${as_lineno-$LINENO}: BFD library not found, 'objinfo' will be unable to display info on .cmxs files." >&5 -$as_echo "$as_me: BFD library not found, 'objinfo' will be unable to display info on .cmxs files." >&6;} fi - fi + if ! $bfd_available; then : + if test x"$with_bfd" = "xyes"; then : + as_fn_error $? "BFD library support requested but not available" "$LINENO" 5 +else + bfd_cppflags="" + bfd_ldflags="" + { $as_echo "$as_me:${as_lineno-$LINENO}: BFD library not found, 'ocamlobjinfo' will be unable to display info on .cmxs files." >&5 +$as_echo "$as_me: BFD library not found, 'ocamlobjinfo' will be unable to display info on .cmxs files." >&6;} +fi +fi + LDFLAGS="$SAVED_LDFLAGS" + CPP_FLAGS="$SAVED_CPPFLAGS" +else + { $as_echo "$as_me:${as_lineno-$LINENO}: Support for the BFD (Binary File Description) library disabled, 'ocamlobjinfo' will be unable to display info on .cmxs files." >&5 +$as_echo "$as_me: Support for the BFD (Binary File Description) library disabled, 'ocamlobjinfo' will be unable to display info on .cmxs files." >&6;} +fi ## Does the assembler support debug prefix map and CFI directives as_has_debug_prefix_map=false @@ -16621,12 +16688,12 @@ else afl=false fi -if test x"$enable_force_safe_string" = "xyes"; then : +if test x"$enable_force_safe_string" = "xno"; then : $as_echo "#define CAML_SAFE_STRING 1" >>confdefs.h - force_safe_string=true -else force_safe_string=false +else + force_safe_string=true fi if test x"$DEFAULT_STRING" = "xunsafe"; then : diff --git a/configure.ac b/configure.ac index 84948aca80..7a3a480760 100644 --- a/configure.ac +++ b/configure.ac @@ -132,8 +132,9 @@ AC_SUBST([ocamldoc]) AC_SUBST([pthread_link]) AC_SUBST([x_includes]) AC_SUBST([x_libraries]) -AC_SUBST([libbfd_include]) -AC_SUBST([libbfd_link]) +AC_SUBST([bfd_cppflags]) +AC_SUBST([bfd_ldflags]) +AC_SUBST([bfd_ldlibs]) AC_SUBST([ASPP]) AC_SUBST([AS]) AC_SUBST([asm_cfi_supported]) @@ -239,6 +240,18 @@ AC_ARG_VAR([LIBUNWIND_INCLUDE_DIR], AC_ARG_VAR([LIBUNWIND_LIB_DIR], [location of library files for libunwind]) +AC_ARG_WITH([bfd], + [AS_HELP_STRING([--without-bfd], + [disable BFD (Binary File Description) library support])], + [], + [with_bfd=auto]) + +AC_ARG_VAR([BFD_INCLUDE_DIR], + [location of header files for the BFD library]) + +AC_ARG_VAR([BFD_LIB_DIR], + [location of library files for the BFD library]) + AC_ARG_ENABLE([graph-lib], [], [AC_MSG_ERROR([The graphics library is no longer distributed with OCaml \ since version 4.09. It is now distributed as a separate "graphics" package: \ @@ -344,13 +357,15 @@ AC_ARG_VAR([WINDOWS_UNICODE_MODE], # explicitly passed. # # The configure-time behavior of OCaml 4.05 and older was equivalent -# to --disable-force-safe-string DEFAULT_STRING=unsafe. OCaml 4.06 -# and later use --disable-force-safe-string DEFAULT_STRING=safe. We -# expect --enable-force-safe-string to become the default in the future. +# to --disable-force-safe-string DEFAULT_STRING=unsafe. With OCaml 4.06 +# and older was equivalent to --disable-force-safe-string DEFAULT_STRING=safe. +# With OCaml 4.10 and later use --enable-force-safe-string DEFAULT_STRING=safe. +# We expect the --disable-force-safe-string and DEFAULT_STRING=unsafe options +# to be removed in the future. AC_ARG_ENABLE([force-safe-string], - [AS_HELP_STRING([--enable-force-safe-string], - [force strings to be safe])]) + [AS_HELP_STRING([--disable-force-safe-string], + [do not force strings to be safe])]) AC_ARG_VAR([DEFAULT_STRING], [whether strings should be safe (default) or unsafe]) @@ -1463,30 +1478,61 @@ AS_IF([test x"$enable_systhreads" = "xno"], [systhread_support=false AC_MSG_NOTICE([the POSIX threads library is not supported])])])])]) -## libbfd - -AC_CHECK_HEADER([bfd.h], - [libbfd_ling="" - AC_CHECK_LIB([bfd], [bfd_openr], [libbfd_link="-lbfd"]) - AS_IF([test -z "$libbfd_link"], - [AC_CHECK_LIB([bfd], [bfd_openr], [libbfd_link="-lbfd -ldl"], [], [-ldl])]) - AS_IF([test -z "$libbfd_link"], - [AC_CHECK_LIB([bfd], [bfd_openr], - [libbfd_link="-lbfd -ldl -liberty"], [], [-ldl -liberty])]) - AS_IF([test -z "$libbfd_link"], - [AC_CHECK_LIB([bfd], [bfd_openr], - [libbfd_link="-lbfd -ldl -liberty -lz"], [], [-ldl -liberty -lz])]) - AS_IF([test -z "$libbfd_link"], - [AC_CHECK_LIB([bfd], [bfd_openr], - [libbfd_link="-lbfd -ldl -liberty -lz -lintl"], [], - [-ldl -liberty -lz -lintl])]) - AS_IF([test -n "$libbfd_link"], - [AC_DEFINE([HAS_LIBBFD])], - [AC_MSG_NOTICE(m4_normalize([ - BFD library not found, 'objinfo' will be unable to display - info on .cmxs files. +## BFD (Binary File Description) library + +bfd_cppflags="" +bfd_ldflags="" +bfd_ldlibs="" + +AS_IF([test x"$with_bfd" != "xno"], + [bfd_available=false + AS_CASE([$host], + [x86_64-*-darwin*], + [AS_IF([test -z "$BFD_INCLUDE_DIR"], + [BFD_INCLUDE_DIR="/opt/local/include"]) + AS_IF([test -z "$BFD_LIB_DIR"], + [BFD_LIB_DIR="/opt/local/lib"])]) + AS_IF([test -n "$BFD_INCLUDE_DIR"], + [bfd_cppflags="-I$BFD_INCLUDE_DIR"]) + AS_IF([test -n "$BFD_LIB_DIR"], + [bfd_ldflags="-L$BFD_LIB_DIR"]) + SAVED_CPPFLAGS="$CPPFLAGS" + SAVED_LDFLAGS="$LDFLAGS" + CPPFLAGS="$CPPFLAGS $bfd_cppflags" + LDFLAGS="$LDFLAGS $bfd_ldflags" + AC_CHECK_HEADER([bfd.h], + [bfd_ldlibs="" + AC_CHECK_LIB([bfd], [bfd_openr], [bfd_ldlibs="-lbfd"]) + AS_IF([test -z "$bfd_ldlibs"], + [AC_CHECK_LIB([bfd], [bfd_openr], [bfd_ldlibs="-lbfd -ldl"], [], [-ldl])]) + AS_IF([test -z "$bfd_ldlibs"], + [AC_CHECK_LIB([bfd], [bfd_openr], + [bfd_ldlibs="-lbfd -ldl -liberty"], [], [-ldl -liberty])]) + AS_IF([test -z "$bfd_ldlibs"], + [AC_CHECK_LIB([bfd], [bfd_openr], + [bfd_ldlibs="-lbfd -ldl -liberty -lz"], [], [-ldl -liberty -lz])]) + AS_IF([test -z "$bfd_ldlibs"], + [AC_CHECK_LIB([bfd], [bfd_openr], + [bfd_ldlibs="-lbfd -ldl -liberty -lz -lintl"], [], + [-ldl -liberty -lz -lintl])]) + AS_IF([test -n "$bfd_ldlibs"], + [bfd_available=true + AC_DEFINE([HAS_LIBBFD])])]) + AS_IF([! $bfd_available], + [AS_IF([test x"$with_bfd" = "xyes"], + [AC_MSG_ERROR([BFD library support requested but not available])], + [bfd_cppflags="" + bfd_ldflags="" + AC_MSG_NOTICE(m4_normalize([ + BFD library not found, 'ocamlobjinfo' will be unable to display + info on .cmxs files. + ]))])]) + LDFLAGS="$SAVED_LDFLAGS" + CPP_FLAGS="$SAVED_CPPFLAGS"], + [AC_MSG_NOTICE(m4_normalize([ + Support for the BFD (Binary File Description) library disabled, + 'ocamlobjinfo' will be unable to display info on .cmxs files. ]))]) - ]) ## Does the assembler support debug prefix map and CFI directives as_has_debug_prefix_map=false @@ -1675,10 +1721,10 @@ AS_IF([test x"$with_afl" = "xyes"], [afl=true], [afl=false]) -AS_IF([test x"$enable_force_safe_string" = "xyes"], +AS_IF([test x"$enable_force_safe_string" = "xno"], [AC_DEFINE([CAML_SAFE_STRING]) - force_safe_string=true], - [force_safe_string=false]) + force_safe_string=false], + [force_safe_string=true]) AS_IF([test x"$DEFAULT_STRING" = "xunsafe"], [default_safe_string=false], @@ -112,7 +112,7 @@ symbol variable ;; middle_end/closure/ - closure + closure closure_middle_end ;; middle_end/flambda/base_types/ closure_element closure_id closure_origin export_id id_types mutable_variable @@ -148,10 +148,10 @@ ;; asmcomp/ afl_instrument arch asmgen asmlibrarian asmlink asmpackager branch_relaxation branch_relaxation_intf cmm cmmgen cmmgen_state coloring comballoc CSE CSEgen - deadcode emit emitaux interf interval linearize linscan liveness mach - printcmm printlinear printmach proc reg reload reloadgen schedgen scheduling - selectgen selection spacetime_profiling spill split strmatch x86_ast - x86_dsl x86_gas x86_masm x86_proc + deadcode domainstate emit emitaux interf interval linear linearize linscan + liveness mach printcmm printlinear printmach proc reg reload reloadgen + schedgen scheduling selectgen selection spacetime_profiling spill split + strmatch x86_ast x86_dsl x86_gas x86_masm x86_proc ;; asmcomp/debug/ reg_availability_set compute_ranges_intf available_regs reg_with_debug_info @@ -206,3 +206,16 @@ toplevel/ocaml.byte toplevel/expunge.exe )) + +(alias + (name libs) + (deps + ocamloptcomp.cma + ocamlmiddleend.cma + ocamlcommon.cma + runtime/runtime.cma + stdlib/stdlib.cma + ocamlbytecomp.cma + ocamltest/ocamltest_core_and_plugin.cma + toplevel/ocamltoplevel.cma + )) diff --git a/lambda/lambda.ml b/lambda/lambda.ml index d27097e127..de83647d54 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -690,7 +690,6 @@ let subst update_env s lam = let remove_list l s = List.fold_left (fun s (id, _kind) -> Ident.Map.remove id s) s l in - let module M = Ident.Map in match lam with | Lvar id as l -> begin try Ident.Map.find id s with Not_found -> l end diff --git a/lambda/translmod.ml b/lambda/translmod.ml index a00c714f1f..71be7917f1 100644 --- a/lambda/translmod.ml +++ b/lambda/translmod.ml @@ -1128,7 +1128,8 @@ let transl_store_structure glob map prims aliases str = let ids0 = bound_value_identifiers od.open_bound_items in let subst = !transl_store_subst in let rec store_idents pos = function - | [] -> transl_store rootpath subst cont rem + | [] -> + transl_store rootpath (add_idents true ids0 subst) cont rem | id :: idl -> Llet(Alias, Pgenval, id, Lvar ids.(pos), Lsequence(store_ident od.open_loc id, diff --git a/manual/manual/refman/exten.etex b/manual/manual/refman/exten.etex index 050b370515..1f47c558ce 100644 --- a/manual/manual/refman/exten.etex +++ b/manual/manual/refman/exten.etex @@ -330,34 +330,6 @@ constructors of [t] could be present. Similarly to abstract types, the variance of type parameters is not inferred, and must be given explicitly. - -\section{Local opens for patterns} -\ikwd{let\@\texttt{let}} -\ikwd{open\@\texttt{open}} \label{s:local-opens} - -(Introduced in OCaml 4.04) - -\begin{syntax} -pattern: - ... - | module-path '.(' pattern ')' - | module-path '.[' pattern ']' - | module-path '.[|' pattern '|]' - | module-path '.{' pattern '}' - -\end{syntax} - -For patterns, local opens are limited to the -@module-path'.('pattern')'@ construction. This -construction locally open the module referred to by the module path -@module-path@ in the scope of the pattern @pattern@. - -When the body of a local open pattern is delimited by -@'[' ']'@, @'[|' '|]'@, or @'{' '}'@, the parentheses can be omitted. -For example, @module-path'.['pattern']'@ is equivalent to -@module-path'.(['pattern'])'@, and @module-path'.[|' pattern '|]'@ is -equivalent to @module-path'.([|' pattern '|])'@. - \section{Locally abstract types} \ikwd{type\@\texttt{type}} \ikwd{fun\@\texttt{fun}} \label{s:locally-abstract} diff --git a/manual/manual/refman/patterns.etex b/manual/manual/refman/patterns.etex index 36b8679cb3..be6cd4a645 100644 --- a/manual/manual/refman/patterns.etex +++ b/manual/manual/refman/patterns.etex @@ -22,9 +22,12 @@ pattern: | char-literal '..' char-literal | 'lazy' pattern | 'exception' pattern + | module-path '.(' pattern ')' + | module-path '.[' pattern ']' + | module-path '.[|' pattern '|]' + | module-path '.{' pattern '}' \end{syntax} See also the following language extensions: -\hyperref[s:local-opens]{local opens}, \hyperref[s-first-class-modules]{first-class modules}, \hyperref[s:attributes]{attributes} and \hyperref[s:extension-nodes]{extension nodes}. @@ -225,3 +228,18 @@ call. A pattern match must contain at least one value case. It is an error if all cases are exceptions, because there would be no code to handle the return of a value. + +\subsubsection*{Local opens for patterns} +\ikwd{open\@\texttt{open}} \label{s:local-opens-pattern} +(Introduced in OCaml 4.04) + +For patterns, local opens are limited to the +@module-path'.('pattern')'@ construction. This +construction locally opens the module referred to by the module path +@module-path@ in the scope of the pattern @pattern@. + +When the body of a local open pattern is delimited by +@'[' ']'@, @'[|' '|]'@, or @'{' '}'@, the parentheses can be omitted. +For example, @module-path'.['pattern']'@ is equivalent to +@module-path'.(['pattern'])'@, and @module-path'.[|' pattern '|]'@ is +equivalent to @module-path'.([|' pattern '|])'@. diff --git a/manual/manual/tutorials/moduleexamples.etex b/manual/manual/tutorials/moduleexamples.etex index bb68975cca..da022aa664 100644 --- a/manual/manual/tutorials/moduleexamples.etex +++ b/manual/manual/tutorials/moduleexamples.etex @@ -99,6 +99,12 @@ becomes \begin{caml_example}{toplevel} PrioQueue.[insert empty 1 "hello"];; \end{caml_example} +This second form also works for patterns: +\begin{caml_example}{toplevel} + let at_most_one_element x = match x with + | PrioQueue.( Empty| Node (_,_, Empty,Empty) ) -> true + | _ -> false ;; +\end{caml_example} It is also possible to copy the components of a module inside another module by using an "include" statement. This can be diff --git a/middle_end/compilenv.ml b/middle_end/compilenv.ml index add4e90e57..247b069403 100644 --- a/middle_end/compilenv.ml +++ b/middle_end/compilenv.ml @@ -49,16 +49,18 @@ module CstMap = because it compares "0.0" and "-0.0" equal. *) end) +module SymMap = Misc.Stdlib.String.Map + type structured_constants = { strcst_shared: string CstMap.t; - strcst_all: (string * Clambda.ustructured_constant) list; + strcst_all: Clambda.ustructured_constant SymMap.t; } let structured_constants_empty = { strcst_shared = CstMap.empty; - strcst_all = []; + strcst_all = SymMap.empty; } let structured_constants = ref structured_constants_empty @@ -371,7 +373,7 @@ let new_structured_constant cst ~shared = structured_constants := { strcst_shared = CstMap.add cst lbl strcst_shared; - strcst_all = (lbl, cst) :: strcst_all; + strcst_all = SymMap.add lbl cst strcst_all; }; lbl else @@ -379,7 +381,7 @@ let new_structured_constant cst ~shared = structured_constants := { strcst_shared; - strcst_all = (lbl, cst) :: strcst_all; + strcst_all = SymMap.add lbl cst strcst_all; }; lbl @@ -389,6 +391,9 @@ let add_exported_constant s = let clear_structured_constants () = structured_constants := structured_constants_empty +let structured_constant_of_symbol s = + SymMap.find_opt s (!structured_constants).strcst_all + let structured_constants () = let provenance : Clambda.usymbol_provenance = { original_idents = []; @@ -396,7 +401,8 @@ let structured_constants () = Path.Pident (Ident.create_persistent (current_unit_name ())); } in - List.map + SymMap.bindings (!structured_constants).strcst_all + |> List.map (fun (symbol, definition) -> { Clambda.symbol; @@ -404,7 +410,6 @@ let structured_constants () = definition; provenance = Some provenance; }) - (!structured_constants).strcst_all let closure_symbol fv = let compilation_unit = Closure_id.get_compilation_unit fv in diff --git a/middle_end/compilenv.mli b/middle_end/compilenv.mli index 569d51ea08..8f1ef284f0 100644 --- a/middle_end/compilenv.mli +++ b/middle_end/compilenv.mli @@ -117,6 +117,10 @@ val new_structured_constant: val structured_constants: unit -> Clambda.preallocated_constant list val clear_structured_constants: unit -> unit + +val structured_constant_of_symbol: + string -> Clambda.ustructured_constant option + val add_exported_constant: string -> unit (* clambda-only *) type structured_constants diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml index de25c7e704..8b778528fc 100644 --- a/middle_end/flambda/build_export_info.ml +++ b/middle_end/flambda/build_export_info.ml @@ -38,6 +38,8 @@ module Env : sig val new_unit_descr : t -> Export_id.t + val is_symbol_being_defined : t -> Symbol.t -> bool + module Global : sig (* "Global" as in "without local variable bindings". *) type t @@ -53,7 +55,7 @@ module Env : sig (** Creates a new environment, sharing the mapping from export IDs to export descriptions with the given global environment. *) - val empty_of_global : Global.t -> t + val empty_of_global : symbols_being_defined:Symbol.Set.t -> Global.t -> t end = struct let fresh_id () = Export_id.create (Compilenv.current_unit ()) @@ -93,13 +95,15 @@ end = struct type t = { var : Export_info.approx Variable.Map.t; sym : Export_id.t Symbol.Map.t; + symbols_being_defined : Symbol.Set.t; ex_table : Export_info.descr Export_id.Map.t ref; closure_table: Export_id.t Closure_id.Map.t ref; } - let empty_of_global (env : Global.t) = + let empty_of_global ~symbols_being_defined (env : Global.t) = { var = Variable.Map.empty; sym = env.sym; + symbols_being_defined; ex_table = env.ex_table; closure_table = env.closure_table; } @@ -188,6 +192,9 @@ end = struct let find_approx t var : Export_info.approx = try Variable.Map.find var t.var with | Not_found -> Value_unknown + + let is_symbol_being_defined t sym = + Symbol.Set.mem sym t.symbols_being_defined end let descr_of_constant (c : Flambda.const) : Export_info.descr = @@ -402,15 +409,18 @@ and describe_set_of_closures env (set : Flambda.set_of_closures) let approx_of_constant_defining_value_block_field env (c : Flambda.constant_defining_value_block_field) : Export_info.approx = match c with - | Symbol s -> Value_symbol s + | Symbol s -> + if Env.is_symbol_being_defined env s + then Value_unknown + else Value_symbol s | Const c -> Value_id (Env.new_descr env (descr_of_constant c)) let describe_constant_defining_value env export_id symbol - (const : Flambda.constant_defining_value) = + ~symbols_being_defined (const : Flambda.constant_defining_value) = let env = (* Assignments of variables to export IDs are local to each constant defining value. *) - Env.empty_of_global env + Env.empty_of_global ~symbols_being_defined env in match const with | Allocated_const alloc_const -> @@ -468,7 +478,9 @@ let describe_program (env : Env.Global.t) (program : Flambda.program) = match program with | Let_symbol (symbol, constant_defining_value, program) -> let id, env = Env.Global.new_symbol env symbol in - describe_constant_defining_value env id symbol constant_defining_value; + describe_constant_defining_value env id symbol + ~symbols_being_defined:(Symbol.Set.singleton symbol) + constant_defining_value; loop env program | Let_rec_symbol (defs, program) -> let env, defs = @@ -485,11 +497,16 @@ let describe_program (env : Env.Global.t) (program : Flambda.program) = | _ -> false) defs in + let symbols_being_defined = + Symbol.Set.of_list (List.map (fun (_, sym, _) -> sym) defs) + in List.iter (fun (id, symbol, def) -> - describe_constant_defining_value env id symbol def) + describe_constant_defining_value env id symbol + ~symbols_being_defined def) other_constants; List.iter (fun (id, symbol, def) -> - describe_constant_defining_value env id symbol def) + describe_constant_defining_value env id symbol + ~symbols_being_defined def) project_closures; loop env program | Initialize_symbol (symbol, tag, fields, program) -> @@ -497,7 +514,8 @@ let describe_program (env : Env.Global.t) (program : Flambda.program) = let env = (* Assignments of variables to export IDs are local to each [Initialize_symbol] construction. *) - Env.empty_of_global env + Env.empty_of_global + ~symbols_being_defined:(Symbol.Set.singleton symbol) env in let field_approxs = List.map (approx_of_expr env) fields in let descr : Export_info.descr = diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml index 74fd021bb9..a1dffaf309 100644 --- a/middle_end/flambda/inline_and_simplify.ml +++ b/middle_end/flambda/inline_and_simplify.ml @@ -1630,7 +1630,6 @@ let rec simplify_program_body env r (program : Flambda.program_body) let approx = A.augment_with_symbol (A.value_block tag (Array.of_list approxs)) symbol in - let module Backend = (val (E.backend env) : Backend_intf.S) in let env = E.add_symbol env symbol approx in let program, r = simplify_program_body env r program in Initialize_symbol (symbol, tag, fields, program), r diff --git a/middle_end/flambda/lift_code.ml b/middle_end/flambda/lift_code.ml index 02292c46e1..3474b06ba5 100644 --- a/middle_end/flambda/lift_code.ml +++ b/middle_end/flambda/lift_code.ml @@ -19,36 +19,50 @@ open! Int_replace_polymorphic_compare type lifter = Flambda.program -> Flambda.program -let rebuild_let - (defs : (Variable.t * Flambda.named Flambda.With_free_variables.t) list) - (body : Flambda.t) = +type def = + | Immutable of Variable.t * Flambda.named Flambda.With_free_variables.t + | Mutable of Mutable_variable.t * Variable.t * Lambda.value_kind + +let rebuild_let (defs : def list) (body : Flambda.t) = let module W = Flambda.With_free_variables in - List.fold_left (fun body (var, def) -> - W.create_let_reusing_defining_expr var def body) + List.fold_left (fun body def -> + match def with + | Immutable(var, def) -> + W.create_let_reusing_defining_expr var def body + | Mutable(var, initial_value, contents_kind) -> + Flambda.Let_mutable {var; initial_value; contents_kind; body}) body defs -let rec extract_lets - (acc:(Variable.t * Flambda.named Flambda.With_free_variables.t) list) - (let_expr:Flambda.let_expr) : - (Variable.t * Flambda.named Flambda.With_free_variables.t) list * - Flambda.t Flambda.With_free_variables.t = +let rec extract_let_expr (acc:def list) (let_expr:Flambda.let_expr) : + def list * Flambda.t Flambda.With_free_variables.t = + let module W = Flambda.With_free_variables in + let acc = + match let_expr with + | { var = v1; defining_expr = Expr (Let let2); _ } -> + let acc, body2 = extract_let_expr acc let2 in + Immutable(v1, W.expr body2) :: acc + | { var = v1; defining_expr = Expr (Let_mutable let_mut); _ } -> + let acc, body2 = extract_let_mutable acc let_mut in + Immutable(v1, W.expr body2) :: acc + | { var = v; _ } -> + Immutable(v, W.of_defining_expr_of_let let_expr) :: acc + in + let body = W.of_body_of_let let_expr in + extract acc body + +and extract_let_mutable acc (let_mut : Flambda.let_mutable) = let module W = Flambda.With_free_variables in - match let_expr with - | { var = v1; defining_expr = Expr (Let let2); _ } -> - let acc, body2 = extract_lets acc let2 in - let acc = (v1, W.expr body2) :: acc in - let body = W.of_body_of_let let_expr in - extract acc body - | { var = v; _ } -> - let acc = (v, W.of_defining_expr_of_let let_expr) :: acc in - let body = W.of_body_of_let let_expr in - extract acc body + let { Flambda.var; initial_value; contents_kind; body } = let_mut in + let acc = Mutable(var, initial_value, contents_kind) :: acc in + extract acc (W.of_expr body) and extract acc (expr : Flambda.t Flambda.With_free_variables.t) = let module W = Flambda.With_free_variables in match W.contents expr with | Let let_expr -> - extract_lets acc let_expr + extract_let_expr acc let_expr + | Let_mutable let_mutable -> + extract_let_mutable acc let_mutable | _ -> acc, expr @@ -56,10 +70,13 @@ let rec lift_lets_expr (expr:Flambda.t) ~toplevel : Flambda.t = let module W = Flambda.With_free_variables in match expr with | Let let_expr -> - let defs, body = extract_lets [] let_expr in - let rev_defs = - List.rev_map (lift_lets_named_with_free_variables ~toplevel) defs - in + let defs, body = extract_let_expr [] let_expr in + let rev_defs = List.rev_map (lift_lets_def ~toplevel) defs in + let body = lift_lets_expr (W.contents body) ~toplevel in + rebuild_let (List.rev rev_defs) body + | Let_mutable let_mut -> + let defs, body = extract_let_mutable [] let_mut in + let rev_defs = List.rev_map (lift_lets_def ~toplevel) defs in let body = lift_lets_expr (W.contents body) ~toplevel in rebuild_let (List.rev rev_defs) body | e -> @@ -68,26 +85,28 @@ let rec lift_lets_expr (expr:Flambda.t) ~toplevel : Flambda.t = (lift_lets_named ~toplevel) e -and lift_lets_named_with_free_variables - ((var, named):Variable.t * Flambda.named Flambda.With_free_variables.t) - ~toplevel : Variable.t * Flambda.named Flambda.With_free_variables.t = +and lift_lets_def def ~toplevel = let module W = Flambda.With_free_variables in - match W.contents named with - | Expr e -> - var, W.expr (W.of_expr (lift_lets_expr e ~toplevel)) - | Set_of_closures set when not toplevel -> - var, - W.of_named - (Set_of_closures - (Flambda_iterators.map_function_bodies - ~f:(lift_lets_expr ~toplevel) set)) - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _ - | Project_var _ | Prim _ | Set_of_closures _ -> - var, named + match def with + | Mutable _ -> def + | Immutable(var, named) -> + let named = + match W.contents named with + | Expr e -> W.expr (W.of_expr (lift_lets_expr e ~toplevel)) + | Set_of_closures set when not toplevel -> + W.of_named + (Set_of_closures + (Flambda_iterators.map_function_bodies + ~f:(lift_lets_expr ~toplevel) set)) + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field (_, _) | Project_closure _ + | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Set_of_closures _ -> + named + in + Immutable(var, named) and lift_lets_named _var (named:Flambda.named) ~toplevel : Flambda.named = - let module W = Flambda.With_free_variables in match named with | Expr e -> Expr (lift_lets_expr e ~toplevel) diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index b109815071..8c29b42af4 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -44,24 +44,37 @@ OCAMLPP=-pp 'sh ./remove_DEBUG' MKDIR=mkdir -p CP=cp OCAMLDOC=ocamldoc +OCAMLDOC_OPT=$(OCAMLDOC).opt # TODO: clarify whether the following really needs to be that complicated ifeq "$(UNIX_OR_WIN32)" "unix" ifeq "$(TARGET)" "$(HOST)" ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true" - OCAMLDOC_RUN=$(OCAMLRUN) -I $(ROOTDIR)/otherlibs/$(UNIXLIB) -I $(ROOTDIR)/otherlibs/str ./$(OCAMLDOC) + OCAMLDOC_RUN_BYTE=$(OCAMLRUN) -I $(ROOTDIR)/otherlibs/$(UNIXLIB) -I $(ROOTDIR)/otherlibs/str ./$(OCAMLDOC) else - OCAMLDOC_RUN=./$(OCAMLDOC) +# if shared-libraries are not supported, unix.cma and str.cma +# are compiled with -custom, so ocamldoc also uses -custom, +# and (ocamlrun ocamldoc) does not work. + OCAMLDOC_RUN_BYTE=./$(OCAMLDOC) endif else - OCAMLDOC_RUN=$(OCAMLRUN) ./$(OCAMLDOC) + OCAMLDOC_RUN_BYTE=$(OCAMLRUN) ./$(OCAMLDOC) endif else # Windows - OCAMLDOC_RUN = \ + OCAMLDOC_RUN_BYTE = \ CAML_LD_LIBRARY_PATH="$(ROOTDIR)/otherlibs/win32unix;$(ROOTDIR)/otherlibs/str" $(OCAMLRUN) ./$(OCAMLDOC) endif -OCAMLDOC_OPT=$(OCAMLDOC).opt +OCAMLDOC_RUN_OPT=./$(OCAMLDOC_OPT) + +OCAMLDOC_RUN_PLUGINS=$(OCAMLDOC_RUN_BYTE) + +ifeq "$(wildcard $(OCAMLDOC_OPT))" "" + OCAMLDOC_RUN=$(OCAMLDOC_RUN_BYTE) +else + OCAMLDOC_RUN=$(OCAMLDOC_RUN_OPT) +endif + OCAMLDOC_LIBCMA=odoc_info.cma OCAMLDOC_LIBCMI=odoc_info.cmi OCAMLDOC_LIBCMXA=odoc_info.cmxa @@ -170,9 +183,7 @@ LIBCMIFILES = $(LIBCMOFILES:.cmo=.cmi) .PHONY: all -all: lib exe generators manpages - -manpages: generators +all: lib exe generators .PHONY: exe exe: $(OCAMLDOC) @@ -343,7 +354,7 @@ test: $(MKDIR) $@ $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/ocamldoc.odoc odoc*.ml odoc*.mli -v $(MKDIR) $@-custom - $(OCAMLDOC_RUN) -colorize-code -sort -d $@-custom $(INCLUDES) \ + $(OCAMLDOC_RUN_PLUGINS) -colorize-code -sort -d $@-custom $(INCLUDES) \ -g generators/odoc_literate.cmo -g generators/odoc_todo.cmo \ -load $@/ocamldoc.odoc -v @@ -363,11 +374,6 @@ test_stdlib_code: $(ROOTDIR)/otherlibs/$(UNIXLIB)/unix.ml \ $(ROOTDIR)/otherlibs/str/str.ml -.PHONY: test_framed -test_framed: - $(MKDIR) $@ - $(OCAMLDOC_RUN) -g odoc_fhtml.cmo -sort -colorize-code -d $@ $(INCLUDES) odoc*.ml odoc*.mli - .PHONY: test_latex test_latex: $(MKDIR) $@ @@ -446,7 +452,7 @@ stdlib_latex/stdlib.pdf: stdlib_latex/stdlib.tex .PHONY: autotest_stdlib autotest_stdlib: $(MKDIR) $@ - $(OCAMLDOC_RUN) -g autotest/odoc_test.cmo\ + $(OCAMLDOC_RUN_PLUGINS) -g autotest/odoc_test.cmo\ $(INCLUDES) -keep-code \ $(ROOTDIR)/stdlib/*.mli \ $(ROOTDIR)/otherlibs/$(UNIXLIB)/unix.mli \ diff --git a/ocamltest/Makefile b/ocamltest/Makefile index 0065cc6876..9694b94b3c 100644 --- a/ocamltest/Makefile +++ b/ocamltest/Makefile @@ -220,9 +220,6 @@ ocamltest.opt$(EXE): $(native_modules) %.ml: %.mll $(ocamllex) $(OCAMLLEX_FLAGS) $< -%.$(O): %.c - $(CC) $(OC_CFLAGS) $(OC_CPPFLAGS) -c $< - ocamltest_config.ml: ocamltest_config.ml.in Makefile ../Makefile.config sed \ -e 's|@@AFL_INSTRUMENT@@|$(AFL_INSTRUMENT)|' \ diff --git a/ocamltest/actions_helpers.ml b/ocamltest/actions_helpers.ml index 210b2f2561..3e394be271 100644 --- a/ocamltest/actions_helpers.ml +++ b/ocamltest/actions_helpers.ml @@ -287,8 +287,12 @@ let check_output kind_of_output output_variable reference_variable log Filecompare.reference_filename = reference_filename; Filecompare.output_filename = output_filename } in + let ignore_header_conf = { + Filecompare.lines = skip_lines; + Filecompare.bytes = skip_bytes; + } in let tool = - Filecompare.(make_cmp_tool ~ignore:{lines=skip_lines;bytes=skip_bytes}) in + Filecompare.make_cmp_tool ~ignore:ignore_header_conf in match Filecompare.check_file ~tool files with | Filecompare.Same -> (Result.pass, env) | Filecompare.Different -> @@ -303,7 +307,7 @@ let check_output kind_of_output output_variable reference_variable log then begin Printf.fprintf log "Promoting %s output %s to reference %s\n%!" kind_of_output output_filename reference_filename; - Sys.copy_file output_filename reference_filename; + Filecompare.promote files ignore_header_conf; end; (Result.fail_with_reason reason, env) | Filecompare.Unexpected_output -> diff --git a/ocamltest/filecompare.ml b/ocamltest/filecompare.ml index f9a596096f..d2e8c310c7 100644 --- a/ocamltest/filecompare.ml +++ b/ocamltest/filecompare.ml @@ -179,3 +179,22 @@ let diff files = in Sys.force_remove temporary_file; result + +let promote files ignore_conf = + match files.filetype, ignore_conf with + | Text, {lines = skip_lines; _} -> + let reference = open_out files.reference_filename in + let output = open_in files.output_filename in + for _ = 1 to skip_lines do + try ignore (input_line output) with End_of_file -> () + done; + Sys.copy_chan output reference; + close_out reference; + close_in output + | Binary, {bytes = skip_bytes; _} -> + let reference = open_out_bin files.reference_filename in + let output = open_in_bin files.output_filename in + seek_in output skip_bytes; + Sys.copy_chan output reference; + close_out reference; + close_in output diff --git a/ocamltest/filecompare.mli b/ocamltest/filecompare.mli index 42b493ae14..6a071dc610 100644 --- a/ocamltest/filecompare.mli +++ b/ocamltest/filecompare.mli @@ -46,3 +46,5 @@ val check_file : ?tool:tool -> files -> result val cmp_result_of_exitcode : string -> int -> result val diff : files -> (string, string) Stdlib.result + +val promote : files -> ignore -> unit diff --git a/ocamltest/ocamltest_stdlib.mli b/ocamltest/ocamltest_stdlib.mli index 2200b3d576..d74fc2c2df 100644 --- a/ocamltest/ocamltest_stdlib.mli +++ b/ocamltest/ocamltest_stdlib.mli @@ -49,6 +49,7 @@ module Sys : sig val run_system_command : string -> unit val make_directory : string -> unit val string_of_file : string -> string + val copy_chan : in_channel -> out_channel -> unit val copy_file : string -> string -> unit val force_remove : string -> unit val has_symlink : unit -> bool diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index d0b59a8d8f..da09d089c4 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -18,6 +18,13 @@ ROOTDIR=../.. include $(ROOTDIR)/Makefile.config include $(ROOTDIR)/Makefile.common +OC_CFLAGS += $(SHAREDLIB_CFLAGS) + +OC_CPPFLAGS += -I$(ROOTDIR)/runtime + +NATIVE_CPPFLAGS = \ + -DNATIVE_CODE -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) + CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun LIBS = -nostdlib -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/$(UNIXLIB) @@ -92,15 +99,13 @@ $(LIBNAME).cmxa: $(THREADS_NCOBJS) # st_stubs_n.$(O) from the same source file st_stubs.c (it is compiled # twice, each time with different options). +st_stubs_n.$(O): OC_CPPFLAGS += $(NATIVE_CPPFLAGS) + st_stubs_b.$(O): st_stubs.c $(HEADER) - $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) -I$(ROOTDIR)/runtime \ - $(SHAREDLIB_CFLAGS) $(OUTPUTOBJ)$@ $< + $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) $(OUTPUTOBJ)$@ $< st_stubs_n.$(O): st_stubs.c $(HEADER) - $(CC) $(OC_CFLAGS) $(OC_CPPFLAGS) \ - -I$(ROOTDIR)/runtime $(SHAREDLIB_CFLAGS) -DNATIVE_CODE \ - -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) \ - $(OUTPUTOBJ)$@ -c $< + $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) $(OUTPUTOBJ)$@ $< partialclean: rm -f *.cm* @@ -154,11 +159,10 @@ depend: $(error Dependencies cannot be regenerated using the MSVC ports) else depend: - $(CC) -MM $(OC_CPPFLAGS) -I$(ROOTDIR)/runtime st_stubs.c \ + $(CC) -MM $(OC_CPPFLAGS) st_stubs.c \ | sed -e 's/st_stubs\.o/st_stubs_b.$$(O)/' \ -e 's/ st_\(posix\|win32\)\.h//g' > .depend - $(CC) -MM $(OC_CPPFLAGS) -I$(ROOTDIR)/runtime \ - -DNATIVE_CODE -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) \ + $(CC) -MM $(OC_CPPFLAGS) $(NATIVE_CPPFLAGS) \ st_stubs.c | sed -e 's/st_stubs\.o/st_stubs_n.$$(O)/' \ -e 's/ st_\(posix\|win32\)\.h//g' >> .depend $(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend -slash *.mli *.ml >> .depend diff --git a/parsing/location.ml b/parsing/location.ml index b8e19871b1..4411f55e74 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -82,6 +82,7 @@ let mknoloc txt = mkloc txt none let input_name = ref "_none_" let input_lexbuf = ref (None : lexbuf option) +let input_phrase_buffer = ref (None : Buffer.t option) (******************************************************************************) (* Terminal info *) @@ -546,6 +547,23 @@ let lines_around_from_lexbuf lines_around ~start_pos ~end_pos ~seek ~read_char end +(* Attempt to get lines from the phrase buffer *) +let lines_around_from_phrasebuf + ~(start_pos: position) ~(end_pos: position) + (pb: Buffer.t): + input_line list + = + let pos = ref 0 in + let seek n = pos := n in + let read_char () = + if !pos >= Buffer.length pb then None + else begin + let c = Buffer.nth pb !pos in + incr pos; Some c + end + in + lines_around ~start_pos ~end_pos ~seek ~read_char + (* Get lines from a file *) let lines_around_from_file ~(start_pos: position) ~(end_pos: position) @@ -583,15 +601,23 @@ let lines_around_from_current_input ~start_pos ~end_pos = else [] in - match !input_lexbuf with - | Some lb -> + match !input_lexbuf, !input_phrase_buffer, !input_name with + | _, Some pb, "//toplevel//" -> + begin match lines_around_from_phrasebuf pb ~start_pos ~end_pos with + | [] -> (* Could not read the input from the phrase buffer. This is likely + a sign that we were given a buggy location. *) + [] + | lines -> + lines + end + | Some lb, _, _ -> begin match lines_around_from_lexbuf lb ~start_pos ~end_pos with | [] -> (* The input is likely not in the lexbuf anymore *) from_file () | lines -> lines end - | None -> + | None, _, _ -> from_file () (******************************************************************************) @@ -752,7 +778,8 @@ let terminfo_toplevel_printer (lb: lexbuf): report_printer = in let pp_main_loc _ _ _ _ = () in let pp_submsg_loc _ _ ppf loc = - Format.fprintf ppf "%a:@ " print_loc loc in + if not loc.loc_ghost then + Format.fprintf ppf "%a:@ " print_loc loc in { batch_mode_printer with pp; pp_main_loc; pp_submsg_loc } let best_toplevel_printer () = diff --git a/parsing/location.mli b/parsing/location.mli index b1c3e01366..784c96943c 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -74,6 +74,13 @@ val mkloc : 'a -> t -> 'a loc val input_name: string ref val input_lexbuf: Lexing.lexbuf option ref +(* This is used for reporting errors coming from the toplevel. + + When running a toplevel session (i.e. when [!input_name] is "//toplevel//"), + [!input_phrase_buffer] should be [Some buf] where [buf] contains the last + toplevel phrase. *) +val input_phrase_buffer: Buffer.t option ref + (** {1 Toplevel-specific functions} *) diff --git a/runtime/caml/memprof.h b/runtime/caml/memprof.h index 66a842760a..c1d8b61fe1 100644 --- a/runtime/caml/memprof.h +++ b/runtime/caml/memprof.h @@ -20,6 +20,7 @@ #include "config.h" #include "mlvalues.h" +#include "roots.h" extern int caml_memprof_suspended; @@ -27,10 +28,13 @@ extern void caml_memprof_handle_postponed(); extern void caml_memprof_track_alloc_shr(value block); extern void caml_memprof_track_young(tag_t tag, uintnat wosize, int from_caml); +extern void caml_memprof_track_interned(header_t* block, header_t* blockend); extern void caml_memprof_renew_minor_sample(void); extern value* caml_memprof_young_trigger; +extern void caml_memprof_scan_roots(scanning_action f); + #endif #endif /* CAML_MEMPROF_H */ diff --git a/runtime/dune b/runtime/dune index 8e8a116ba3..4b9c50af18 100644 --- a/runtime/dune +++ b/runtime/dune @@ -33,7 +33,7 @@ io.c extern.c intern.c hash.c sys.c meta.c parsing.c gc_ctrl.c md5.c obj.c lexing.c callback.c debugger.c weak.c compact.c finalise.c custom.c dynlink.c spacetime_byt.c afl.c unix.c win32.c bigarray.c - main.c) + main.c memprof.c domain.c) (action (progn (bash "touch .depend") ; hack. diff --git a/runtime/memprof.c b/runtime/memprof.c index 236f0d6bc0..5bbb3b9dda 100644 --- a/runtime/memprof.c +++ b/runtime/memprof.c @@ -179,7 +179,7 @@ CAMLprim value caml_memprof_set(value v) enum ml_alloc_kind { Minor = Val_long(0), Major = Val_long(1), - Serialized = Val_long(2) + Unmarshalled = Val_long(2) }; /* When we call do_callback, we suspend/resume sampling. In order to @@ -265,17 +265,15 @@ static struct postponed_block { *postponed_hd = default_postponed_queue; /* Pointer to next push */ int caml_memprof_to_do = 0; -static void postponed_pop(void) +static struct postponed_block* postponed_next(struct postponed_block* p) { - caml_remove_global_root(&postponed_tl->block); - caml_remove_global_root(&postponed_tl->callstack); - postponed_tl++; - if (postponed_tl == postponed_queue_end) postponed_tl = postponed_queue; + p++; + if (p == postponed_queue_end) return postponed_queue; + else return p; } static void purge_postponed_queue(void) { - while (postponed_tl != postponed_hd) postponed_pop(); if (postponed_queue != default_postponed_queue) { caml_stat_free(postponed_queue); postponed_queue = default_postponed_queue; @@ -289,31 +287,28 @@ static void purge_postponed_queue(void) block is allocated, but not yet initialized, so that the heap invariants are broken. */ static void register_postponed_callback(value block, uintnat occurrences, - enum ml_alloc_kind kind) + enum ml_alloc_kind kind, + value* callstack) { - value callstack; struct postponed_block* new_hd; if (occurrences == 0) return; - callstack = capture_callstack_postponed(); - if (callstack == 0) return; /* OOM */ + if (*callstack == 0) *callstack = capture_callstack_postponed(); + if (*callstack == 0) return; /* OOM */ - new_hd = postponed_hd + 1; - if (new_hd == postponed_queue_end) new_hd = postponed_queue; + new_hd = postponed_next(postponed_hd); if (new_hd == postponed_tl) { /* Queue is full, reallocate it. (We always leave one free slot in order to be able to distinguish the 100% full and the empty states). */ - uintnat sz = 4 * (postponed_queue_end - postponed_queue); + uintnat sz = 2 * (postponed_queue_end - postponed_queue); struct postponed_block* new_queue = caml_stat_alloc_noexc(sz * sizeof(struct postponed_block)); if (new_queue == NULL) return; new_hd = new_queue; while (postponed_tl != postponed_hd) { *new_hd = *postponed_tl; - caml_register_global_root(&new_hd->block); - caml_register_global_root(&new_hd->callstack); new_hd++; - postponed_pop(); + postponed_tl = postponed_next(postponed_tl); } if (postponed_queue != default_postponed_queue) caml_stat_free(postponed_queue); @@ -324,9 +319,7 @@ static void register_postponed_callback(value block, uintnat occurrences, } postponed_hd->block = block; - postponed_hd->callstack = callstack; - caml_register_global_root(&postponed_hd->block); - caml_register_global_root(&postponed_hd->callstack); + postponed_hd->callstack = *callstack; postponed_hd->occurrences = occurrences; postponed_hd->kind = kind; postponed_hd = new_hd; @@ -348,7 +341,7 @@ void caml_memprof_handle_postponed(void) while (postponed_tl != postponed_hd) { struct postponed_block pb = *postponed_tl; block = pb.block; /* pb.block is not a root! */ - postponed_pop(); + postponed_tl = postponed_next(postponed_tl); if (postponed_tl == postponed_hd) purge_postponed_queue(); /* If using threads, this call can trigger reentrant calls to @@ -364,15 +357,26 @@ void caml_memprof_handle_postponed(void) CAMLreturn0; } +/* We don't expect these roots to live long. No need to have a special + case for young roots. */ +void caml_memprof_scan_roots(scanning_action f) { + struct postponed_block* p; + for(p = postponed_tl; p != postponed_hd; p = postponed_next(p)) { + f(p->block, &p->block); + f(p->callstack, &p->callstack); + } +} + /**** Sampling procedures ****/ void caml_memprof_track_alloc_shr(value block) { + value callstack = 0; CAMLassert(Is_in_heap(block)); /* This test also makes sure memprof is initialized. */ if (lambda == 0 || caml_memprof_suspended) return; register_postponed_callback( - block, mt_generate_binom(Whsize_val(block)), Major); + block, mt_generate_binom(Whsize_val(block)), Major, &callstack); } /* Shifts the next sample in the minor heap by [n] words. Essentially, @@ -435,8 +439,9 @@ void caml_memprof_track_young(tag_t tag, uintnat wosize, int from_caml) - Caml_state->young_ptr) + 1; if (!from_caml) { + value callstack = 0; register_postponed_callback(Val_hp(Caml_state->young_ptr), occurrences, - Minor); + Minor, &callstack); caml_memprof_renew_minor_sample(); CAMLreturn0; } @@ -490,3 +495,39 @@ void caml_memprof_track_young(tag_t tag, uintnat wosize, int from_caml) CAMLreturn0; } + +void caml_memprof_track_interned(header_t* block, header_t* blockend) { + header_t *p; + value callstack = 0; + + if(lambda == 0 || caml_memprof_suspended) + return; + + /* We have to select the sampled blocks before sampling them, + because sampling may trigger GC, and then blocks can escape from + [block, blockend[. So we use the postponing machinery for + selecting blocks. [intern.c] will call [check_urgent_gc] which + will call [caml_memprof_handle_postponed] in turn. */ + p = block; + while(1) { + uintnat next_sample = mt_generate_geom(); + header_t *next_sample_p, *next_p; + if(next_sample > blockend - p) + break; + /* [next_sample_p] is the block *following* the next sampled + block! */ + next_sample_p = p + next_sample; + + while(1) { + next_p = p + Whsize_hp(p); + if(next_p >= next_sample_p) break; + p = next_p; + } + + register_postponed_callback( + Val_hp(p), mt_generate_binom(next_p - next_sample_p) + 1, + Unmarshalled, &callstack); + + p = next_p; + } +} diff --git a/stdlib/Makefile b/stdlib/Makefile index 4cd5f1d358..95c5de8463 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -180,10 +180,11 @@ ifneq "$(UNIX_OR_WIN32)" "win32" strip $@ endif +$(HEADERPROGRAM)%$(O): \ + OC_CPPFLAGS += -DRUNTIME_NAME='"$(HEADER_PATH)ocamlrun$(subst .,,$*)"' + $(HEADERPROGRAM)%$(O): $(HEADERPROGRAM).c - $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) \ - -DRUNTIME_NAME='"$(HEADER_PATH)ocamlrun$(subst .,,$*)"' \ - $(OUTPUTOBJ)$@ $^ + $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) $(OUTPUTOBJ)$@ $^ camlheader_ur: camlheader cp camlheader $@ diff --git a/stdlib/bytes.mli b/stdlib/bytes.mli index 1016c685d0..08b5fd5487 100644 --- a/stdlib/bytes.mli +++ b/stdlib/bytes.mli @@ -130,8 +130,8 @@ val blit : bytes -> int -> bytes -> int -> int -> unit do not designate a valid range of [dst]. *) val blit_string : string -> int -> bytes -> int -> int -> unit -(** [blit src srcoff dst dstoff len] copies [len] bytes from string - [src], starting at index [srcoff], to byte sequence [dst], +(** [blit_string src srcoff dst dstoff len] copies [len] bytes from + string [src], starting at index [srcoff], to byte sequence [dst], starting at index [dstoff]. Raise [Invalid_argument] if [srcoff] and [len] do not @@ -218,7 +218,7 @@ val index_from : bytes -> int -> char -> int Raise [Not_found] if [c] does not occur in [s] after position [i]. *) val index_from_opt: bytes -> int -> char -> int option -(** [index_from _opts i c] returns the index of the first occurrence of +(** [index_from_opt s i c] returns the index of the first occurrence of byte [c] in [s] after position [i] or [None] if [c] does not occur in [s] after position [i]. [Bytes.index_opt s c] is equivalent to [Bytes.index_from_opt s 0 c]. diff --git a/stdlib/list.ml b/stdlib/list.ml index 90aab32820..2381e06f7b 100644 --- a/stdlib/list.ml +++ b/stdlib/list.ml @@ -228,6 +228,14 @@ let rec find_opt p = function | [] -> None | x :: l -> if p x then Some x else find_opt p l +let rec find_map f = function + | [] -> None + | x :: l -> + begin match f x with + | Some _ as result -> result + | None -> find_map f l + end + let find_all p = let rec find accu = function | [] -> rev accu diff --git a/stdlib/list.mli b/stdlib/list.mli index d0250afde9..e1c04465ec 100644 --- a/stdlib/list.mli +++ b/stdlib/list.mli @@ -230,6 +230,13 @@ val find_opt: ('a -> bool) -> 'a list -> 'a option satisfies [p] in the list [l]. @since 4.05 *) +val find_map: ('a -> 'b option) -> 'a list -> 'b option +(** [find_map f l] applies [f] to the elements of [l] in order, + and returns the first result of the form [Some v], or [None] + if none exist. + @since 4.10.0 +*) + val filter : ('a -> bool) -> 'a list -> 'a list (** [filter p l] returns all the elements of the list [l] that satisfy the predicate [p]. The order of the elements diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli index 2fc4780ff3..dce1e458e3 100644 --- a/stdlib/listLabels.mli +++ b/stdlib/listLabels.mli @@ -235,6 +235,13 @@ val find_opt: f:('a -> bool) -> 'a list -> 'a option list [l]. @since 4.05 *) +val find_map: f:('a -> 'b option) -> 'a list -> 'b option +(** [find_map f l] applies [f] to the elements of [l] in order, + and returns the first result of the form [Some v], or [None] + if none exist. + @since 4.10.0 +*) + val filter : f:('a -> bool) -> 'a list -> 'a list (** [filter p l] returns all the elements of the list [l] that satisfy the predicate [p]. The order of the elements diff --git a/testsuite/disabled b/testsuite/disabled index 241842f694..53d06e7cf3 100644 --- a/testsuite/disabled +++ b/testsuite/disabled @@ -27,6 +27,11 @@ ephe-c-api # https://github.com/ocaml/ocaml/pull/8634 statmemprof +# TODO: alloc async changes +# https://github.com/ocaml/ocaml/pull/8897 +tests/c-api/'alloc_async.ml' with 2 (bytecode) +tests/c-api/'alloc_async.ml' with 1 (native) + # TODO: not clear compatibility is sensible for multicore compatibility diff --git a/testsuite/tests/asmcomp/lift_mutable_let_flambda.ml b/testsuite/tests/asmcomp/lift_mutable_let_flambda.ml new file mode 100644 index 0000000000..8c8b017d49 --- /dev/null +++ b/testsuite/tests/asmcomp/lift_mutable_let_flambda.ml @@ -0,0 +1,29 @@ +(* TEST + * flambda + ** native +*) + +type t = T of { pos : int } + +let[@inline always] find_pos i = + let i = ref i in + let pos = !i in + T {pos} + +let[@inline always] use_pos i = + let (T {pos}) = find_pos i in + pos * 2 + + +let f () = + let x0 = Gc.allocated_bytes () in + let x1 = Gc.allocated_bytes () in + + let n : int = (Sys.opaque_identity use_pos) 10 in + + let x2 = Gc.allocated_bytes () in + assert (n = 20); + assert(x1 -. x0 = x2 -. x1) (* check no allocation between x1 and x2 *) + [@@inline never] + +let () = f () diff --git a/testsuite/tests/asmcomp/ocamltests b/testsuite/tests/asmcomp/ocamltests index e40f53bf33..748a074d40 100644 --- a/testsuite/tests/asmcomp/ocamltests +++ b/testsuite/tests/asmcomp/ocamltests @@ -10,3 +10,4 @@ static_float_array_flambda_opaque.ml unrolling_flambda2.ml unrolling_flambda.ml func_sections.ml +lift_mutable_let_flambda.ml diff --git a/testsuite/tests/c-api/alloc_async.ml b/testsuite/tests/c-api/alloc_async.ml new file mode 100644 index 0000000000..0ed35acf16 --- /dev/null +++ b/testsuite/tests/c-api/alloc_async.ml @@ -0,0 +1,17 @@ +(* TEST + modules = "alloc_async_stubs.c" +*) + +external test : int ref -> unit = "stub" + +let f () = + let r = ref 42 in + Gc.finalise (fun s -> r := !s) (ref 17); + Printf.printf "OCaml, before: %d\n%!" !r; + test r; + Printf.printf "OCaml, after: %d\n%!" !r; + ignore (Sys.opaque_identity (ref 100)); + Printf.printf "OCaml, after alloc: %d\n%!" !r; + () + +let () = (f [@inlined never]) () diff --git a/testsuite/tests/c-api/alloc_async.reference b/testsuite/tests/c-api/alloc_async.reference new file mode 100644 index 0000000000..839271f55d --- /dev/null +++ b/testsuite/tests/c-api/alloc_async.reference @@ -0,0 +1,5 @@ +OCaml, before: 42 +C, before: 42 +C, after: 42 +OCaml, after: 42 +OCaml, after alloc: 17 diff --git a/testsuite/tests/c-api/alloc_async_stubs.c b/testsuite/tests/c-api/alloc_async_stubs.c new file mode 100644 index 0000000000..5734b06de4 --- /dev/null +++ b/testsuite/tests/c-api/alloc_async_stubs.c @@ -0,0 +1,54 @@ +#include <stdio.h> +#include <stdlib.h> +#include "caml/alloc.h" +#include "caml/memory.h" + +const char* strs[] = { "foo", "bar", 0 }; +value stub(value ref) +{ + CAMLparam1(ref); + CAMLlocal2(x, y); + int i; char* s; intnat coll_before; + + printf("C, before: %d\n", Int_val(Field(ref, 0))); + + /* First, do enough major allocation to trigger a major collection */ + coll_before = Caml_state_field(stat_major_collections); + while (Caml_state_field(stat_major_collections) == coll_before) { + caml_alloc(10000, 0); + } + + /* Now, call lots of allocation functions */ + + /* Small allocations */ + caml_alloc(10, 0); + x = caml_alloc_small(2, 0); + Field(x, 0) = Val_unit; + Field(x, 1) = Val_unit; + caml_alloc_tuple(3); + caml_alloc_float_array(10); + caml_alloc_string(42); + caml_alloc_initialized_string(10, "abcdeabcde"); + caml_copy_string("asoidjfa"); + caml_copy_string_array(strs); + caml_copy_double(42.0); + caml_copy_int32(100); + caml_copy_int64(100); + caml_alloc_array(caml_copy_string, strs); + caml_alloc_sprintf("[%d]", 42); + + /* Large allocations */ + caml_alloc(1000, 0); + caml_alloc_shr(1000, 0); + caml_alloc_tuple(1000); + caml_alloc_float_array(1000); + caml_alloc_string(10000); + s = calloc(10000, 1); + caml_alloc_initialized_string(10000, s); + free(s); + + + printf("C, after: %d\n", Int_val(Field(ref, 0))); + fflush(stdout); + CAMLreturn (Val_unit); +} diff --git a/testsuite/tests/c-api/ocamltests b/testsuite/tests/c-api/ocamltests new file mode 100644 index 0000000000..2741b81d4e --- /dev/null +++ b/testsuite/tests/c-api/ocamltests @@ -0,0 +1 @@ +alloc_async.ml diff --git a/testsuite/tests/generalized-open/clambda_optim.ml b/testsuite/tests/generalized-open/clambda_optim.ml new file mode 100644 index 0000000000..d7ca317ea6 --- /dev/null +++ b/testsuite/tests/generalized-open/clambda_optim.ml @@ -0,0 +1,15 @@ +(* TEST + +compile_only = "true" + +* no-flambda +** setup-ocamlopt.byte-build-env +*** ocamlopt.byte +**** check-ocamlopt.byte-output + +*) + +module Stable = struct + open struct module V0 = struct module U = struct end end end + module V0 = V0.U +end diff --git a/testsuite/tests/generalized-open/gpr1506.ml b/testsuite/tests/generalized-open/gpr1506.ml index bd8dbb7ea4..c7b1333a6e 100644 --- a/testsuite/tests/generalized-open/gpr1506.ml +++ b/testsuite/tests/generalized-open/gpr1506.ml @@ -77,7 +77,7 @@ Line 3, characters 7-20: 3 | open M(struct end) ^^^^^^^^^^^^^ Error: This module is not a structure; it has type - functor (X : sig end) -> sig end + functor (X : sig end) -> sig end |}] open struct @@ -100,9 +100,9 @@ include struct open struct type t = T end let x = T end Line 1, characters 15-41: 1 | include struct open struct type t = T end let x = T end ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The type t/152 introduced by this open appears in the signature +Error: The type t/151 introduced by this open appears in the signature Line 1, characters 46-47: - The value x has no valid type if t/152 is hidden + The value x has no valid type if t/151 is hidden |}];; module A = struct @@ -120,9 +120,9 @@ Lines 3-6, characters 4-7: 4 | type t = T 5 | let x = T 6 | end -Error: The type t/158 introduced by this open appears in the signature +Error: The type t/156 introduced by this open appears in the signature Line 7, characters 8-9: - The value y has no valid type if t/158 is hidden + The value y has no valid type if t/156 is hidden |}];; module A = struct @@ -139,9 +139,9 @@ Lines 3-5, characters 4-7: 3 | ....open struct 4 | type t = T 5 | end -Error: The type t/164 introduced by this open appears in the signature +Error: The type t/161 introduced by this open appears in the signature Line 6, characters 8-9: - The value y has no valid type if t/164 is hidden + The value y has no valid type if t/161 is hidden |}] (* It was decided to not allow this anymore. *) @@ -298,7 +298,7 @@ module N = struct assert(y = 1) end [%%expect{| -module N : sig end +module N : sig end |}] module M = struct @@ -314,7 +314,7 @@ module M = struct end end [%%expect{| -module M : sig end +module M : sig end |}] (* It was decided to not allow this anymore *) @@ -385,5 +385,5 @@ Line 1, characters 20-53: 1 | let f () = let open functor(X: sig end) -> struct end in ();; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This module is not a structure; it has type - functor (X : sig end) -> sig end + functor (X : sig end) -> sig end |}] diff --git a/testsuite/tests/generalized-open/ocamltests b/testsuite/tests/generalized-open/ocamltests index 897bd05211..ec6f2cff28 100644 --- a/testsuite/tests/generalized-open/ocamltests +++ b/testsuite/tests/generalized-open/ocamltests @@ -1,5 +1,6 @@ accepted_batch.ml accepted_expect.ml +clambda_optim.ml expansiveness.ml funct_body.ml gpr1506.ml diff --git a/testsuite/tests/let-syntax/let_syntax.ml b/testsuite/tests/let-syntax/let_syntax.ml index b8d6673ea1..9f19e0e4a1 100644 --- a/testsuite/tests/let-syntax/let_syntax.ml +++ b/testsuite/tests/let-syntax/let_syntax.ml @@ -134,7 +134,7 @@ val bind_map : int list = [8; 9; 10; 9; 10; 11; 10; 11; 12] module Let_unbound = struct end;; [%%expect{| -module Let_unbound : sig end +module Let_unbound : sig end |}];; let let_unbound = diff --git a/testsuite/tests/letrec-check/modules.ml b/testsuite/tests/letrec-check/modules.ml index 6507d9a593..9d61e1eddc 100644 --- a/testsuite/tests/letrec-check/modules.ml +++ b/testsuite/tests/letrec-check/modules.ml @@ -72,7 +72,7 @@ let rec x = (module (val y : T) : T) and y = let module M = struct let x = x end in (module M : T) ;; [%%expect{| -module type T = sig end +module type T = sig end Line 2, characters 12-36: 2 | let rec x = (module (val y : T) : T) ^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/testsuite/tests/lib-arg/testarg.ml b/testsuite/tests/lib-arg/testarg.ml index 6458ce8dca..5fb9f5b89e 100644 --- a/testsuite/tests/lib-arg/testarg.ml +++ b/testsuite/tests/lib-arg/testarg.ml @@ -1,4 +1,5 @@ (* TEST + compare_programs = "false" (* See https://github.com/ocaml/ocaml/pull/8853 *) *) let current = ref 0;; diff --git a/testsuite/tests/lib-bigarray/change_layout.ml b/testsuite/tests/lib-bigarray/change_layout.ml index fcc0d1fb59..2456cdc53f 100644 --- a/testsuite/tests/lib-bigarray/change_layout.ml +++ b/testsuite/tests/lib-bigarray/change_layout.ml @@ -1,4 +1,5 @@ (* TEST + compare_programs = "false" (* See https://github.com/ocaml/ocaml/pull/8853 *) *) (** Test the various change_layout for Genarray and the various Array[n] *) diff --git a/testsuite/tests/lib-list/test.ml b/testsuite/tests/lib-list/test.ml index 88b0a5becd..e054529d6e 100644 --- a/testsuite/tests/lib-list/test.ml +++ b/testsuite/tests/lib-list/test.ml @@ -26,6 +26,13 @@ let () = assert (not (List.exists (fun a -> a > 9) l)); assert (List.exists (fun _ -> true) l); + begin + let f ~limit a = if a >= limit then Some (a, limit) else None in + assert (List.find_map (f ~limit:3) [] = None); + assert (List.find_map (f ~limit:3) l = Some (3, 3)); + assert (List.find_map (f ~limit:30) l = None); + end; + assert (List.compare_lengths [] [] = 0); assert (List.compare_lengths [1;2] ['a';'b'] = 0); assert (List.compare_lengths [] [1;2] < 0); diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml index e932f9602b..cebc76d4fc 100644 --- a/testsuite/tests/lib-scanf/tscanf.ml +++ b/testsuite/tests/lib-scanf/tscanf.ml @@ -1,5 +1,6 @@ (* TEST include testing + compare_programs = "false" (* See https://github.com/ocaml/ocaml/pull/8853 *) *) (* diff --git a/testsuite/tests/parsing/docstrings.ml b/testsuite/tests/parsing/docstrings.ml index 3cae459dc2..fd34987e75 100644 --- a/testsuite/tests/parsing/docstrings.ml +++ b/testsuite/tests/parsing/docstrings.ml @@ -516,7 +516,7 @@ module M = struct (** foo *) end;; [%%expect {| module M = struct [@@@ocaml.text " foo "] end;; -module M : sig end +module M : sig end |}] module M = struct (** foo *) @@ -525,7 +525,7 @@ end;; [%%expect {| module M = struct [@@@ocaml.text " foo "] end;; -module M : sig end +module M : sig end |}] module M = struct @@ -534,7 +534,7 @@ module M = struct [%%expect {| module M = struct [@@@ocaml.text " foo "] end;; -module M : sig end +module M : sig end |}] module M = struct @@ -543,7 +543,7 @@ end;; [%%expect {| module M = struct [@@@ocaml.text " foo "] end;; -module M : sig end +module M : sig end |}] module M = struct @@ -553,7 +553,7 @@ end;; [%%expect {| module M = struct [@@@ocaml.text " foo "] end;; -module M : sig end +module M : sig end |}] module M = struct @@ -563,7 +563,7 @@ end;; [%%expect {| module M = struct [@@@ocaml.text " foo "] end;; -module M : sig end +module M : sig end |}] module M = struct @@ -574,7 +574,7 @@ end;; [%%expect {| module M = struct [@@@ocaml.text " foo "] end;; -module M : sig end +module M : sig end |}] module M = struct @@ -588,7 +588,7 @@ end;; module M = struct [@@@ocaml.text " foo "] [@@@ocaml.text " bar "] end;; -module M : sig end +module M : sig end |}] module M = struct @@ -600,7 +600,7 @@ end;; module M = struct [@@@ocaml.text " foo "] [@@@ocaml.text " bar "] end;; -module M : sig end +module M : sig end |}] diff --git a/testsuite/tests/ppx-contexts/myppx.ml b/testsuite/tests/ppx-contexts/myppx.ml index 76c80d64c9..c1945d20da 100644 --- a/testsuite/tests/ppx-contexts/myppx.ml +++ b/testsuite/tests/ppx-contexts/myppx.ml @@ -36,8 +36,6 @@ let () = !Clflags.transparent_modules; Printf.eprintf "unboxed_types: %B\n" !Clflags.unboxed_types; - Printf.eprintf "unsafe_string: %B\n" - !Clflags.unsafe_string; Printf.eprintf "</ppx-context>\n"; flush stderr; default_mapper); diff --git a/testsuite/tests/ppx-contexts/test.compilers.reference b/testsuite/tests/ppx-contexts/test.compilers.reference index b3486e40ed..e28c8597d1 100644 --- a/testsuite/tests/ppx-contexts/test.compilers.reference +++ b/testsuite/tests/ppx-contexts/test.compilers.reference @@ -8,7 +8,6 @@ recursive_types: true principal: true transparent_modules: false unboxed_types: true -unsafe_string: false </ppx-context> <ppx-context> tool_name: "ocamlc" @@ -20,5 +19,4 @@ recursive_types: false principal: false transparent_modules: true unboxed_types: false -unsafe_string: true </ppx-context> diff --git a/testsuite/tests/ppx-contexts/test.ml b/testsuite/tests/ppx-contexts/test.ml index e61840c433..f348e46035 100644 --- a/testsuite/tests/ppx-contexts/test.ml +++ b/testsuite/tests/ppx-contexts/test.ml @@ -14,14 +14,12 @@ flags = "-thread \ -principal \ -alias-deps \ -unboxed-types \ - -safe-string \ -ppx ${program}" **** ocamlc.byte module = "test.ml" flags = "-g \ -no-alias-deps \ -no-unboxed-types \ - -unsafe-string \ -ppx ${program}" ***** check-ocamlc.byte-output *) diff --git a/testsuite/tests/shadow_include/shadow_all.ml b/testsuite/tests/shadow_include/shadow_all.ml index 7e31cad267..b4d9b37c8b 100644 --- a/testsuite/tests/shadow_include/shadow_all.ml +++ b/testsuite/tests/shadow_include/shadow_all.ml @@ -282,8 +282,8 @@ module N : type t val unit : unit external e : unit -> unit = "%identity" - module M : sig end - module type T = sig end + module M : sig end + module type T = sig end exception E type ext = .. type ext += C @@ -304,7 +304,7 @@ module NN : val unit : unit external e : unit -> unit = "%identity" module M = N.M - module type T = sig end + module type T = sig end exception E type ext = N.ext = .. type ext += C @@ -329,7 +329,7 @@ module Type : val unit : unit external e : unit -> unit = "%identity" module M = N.M - module type T = sig end + module type T = sig end exception E type ext = N.ext = .. type ext += C @@ -352,7 +352,7 @@ module Module : val unit : unit external e : unit -> unit = "%identity" module M = N.M - module type T = sig end + module type T = sig end exception E type ext = N.ext = .. type ext += C @@ -370,12 +370,12 @@ end [%%expect{| module Module_type : sig - module type U = sig end + module type U = sig end type t = N.t val unit : unit external e : unit -> unit = "%identity" module M = N.M - module type T = sig end + module type T = sig end exception E type ext = N.ext = .. type ext += C @@ -398,7 +398,7 @@ module Exception : val unit : unit external e : unit -> unit = "%identity" module M = N.M - module type T = sig end + module type T = sig end exception E type ext = N.ext = .. type ext += C @@ -421,7 +421,7 @@ module Extension : val unit : unit external e : unit -> unit = "%identity" module M = N.M - module type T = sig end + module type T = sig end exception E type ext = N.ext = .. type ext += C @@ -444,7 +444,7 @@ module Class : val unit : unit external e : unit -> unit = "%identity" module M = N.M - module type T = sig end + module type T = sig end exception E type ext = N.ext = .. type ext += C @@ -467,7 +467,7 @@ module Class_type : val unit : unit external e : unit -> unit = "%identity" module M = N.M - module type T = sig end + module type T = sig end exception E type ext = N.ext = .. type ext += C diff --git a/testsuite/tests/statmemprof/intern.byte.reference b/testsuite/tests/statmemprof/intern.byte.reference new file mode 100644 index 0000000000..5c08362348 --- /dev/null +++ b/testsuite/tests/statmemprof/intern.byte.reference @@ -0,0 +1,13 @@ +check_nosample +check_ephe_full_major +check_no_nested +check_distrib 2 3000 3 0.000010 +check_distrib 2 3000 1 0.000100 +check_distrib 2 2000 1 0.010000 +check_distrib 2 2000 1 0.900000 +check_distrib 300000 300000 20 0.100000 +check_callstack +Raised by primitive operation at file "intern.ml", line 32, characters 14-35 +Called from file "intern.ml", line 168, characters 2-25 +Called from file "intern.ml", line 174, characters 9-27 +OK ! diff --git a/testsuite/tests/statmemprof/intern.ml b/testsuite/tests/statmemprof/intern.ml new file mode 100644 index 0000000000..035643655b --- /dev/null +++ b/testsuite/tests/statmemprof/intern.ml @@ -0,0 +1,177 @@ +(* TEST + flags = "-g" + * bytecode + reference = "${test_source_directory}/intern.byte.reference" + * native + reference = "${test_source_directory}/intern.opt.reference" + compare_programs = "false" +*) + +open Gc.Memprof + +type t = Dummy of int (* Skip tag 0. *) | I of int | II of int * int | Cons of t +let rec t_of_len = function + | len when len <= 1 -> assert false + | 2 -> I 1 + | 3 -> II (2, 3) + | len -> Cons (t_of_len (len - 2)) + +let marshalled_data = Hashtbl.create 17 +let[@inline never] get_marshalled_data len : t = + Marshal.from_string (Hashtbl.find marshalled_data len) 0 +let precompute_marshalled_data lo hi = + for len = lo to hi do + if not (Hashtbl.mem marshalled_data len) then + Hashtbl.add marshalled_data len (Marshal.to_string (t_of_len len) []) + done + +let root = ref [] +let[@inline never] do_intern lo hi cnt keep = + for j = 0 to cnt-1 do + for i = lo to hi do + root := get_marshalled_data i :: !root + done; + if not keep then root := [] + done + +let check_nosample () = + Printf.printf "check_nosample\n%!"; + precompute_marshalled_data 2 3000; + start { + sampling_rate = 0.; + callstack_size = 10; + callback = fun _ -> + Printf.printf "Callback called with sampling_rate = 0\n"; + assert(false) + }; + do_intern 2 3000 1 false + +let () = check_nosample () + +let check_ephe_full_major () = + Printf.printf "check_ephe_full_major\n%!"; + precompute_marshalled_data 2 3000; + let ephes = ref [] in + start { + sampling_rate = 0.01; + callstack_size = 10; + callback = fun _ -> + let res = Ephemeron.K1.create () in + ephes := res :: !ephes; + Some res + }; + do_intern 2 3000 1 true; + stop (); + List.iter (fun e -> assert (Ephemeron.K1.check_key e)) !ephes; + Gc.full_major (); + List.iter (fun e -> assert (Ephemeron.K1.check_key e)) !ephes; + root := []; + Gc.full_major (); + List.iter (fun e -> assert (not (Ephemeron.K1.check_key e))) !ephes + +let () = check_ephe_full_major () + +let check_no_nested () = + Printf.printf "check_no_nested\n%!"; + precompute_marshalled_data 2 300; + let in_callback = ref false in + start { + (* FIXME: we should use 1. to make sure the block is sampled, + but the runtime does an infinite loop in native mode in this + case. This bug will go away when the sampling of natively + allocated will be correctly implemented. *) + sampling_rate = 0.5; + callstack_size = 10; + callback = fun _ -> + assert (not !in_callback); + in_callback := true; + do_intern 100 200 1 false; + in_callback := false; + None + }; + do_intern 100 200 1 false; + stop () + +let () = check_no_nested () + +let check_distrib lo hi cnt rate = + Printf.printf "check_distrib %d %d %d %f\n%!" lo hi cnt rate; + precompute_marshalled_data lo hi; + let smp = ref 0 in + start { + sampling_rate = rate; + callstack_size = 10; + callback = fun info -> + (* We also allocate the list constructor in the minor heap. *) + if info.kind = Unmarshalled then begin + begin match info.tag, info.size with + | 1, 1 | 2, 2 | 3, 1 -> () + | _ -> assert false + end; + assert (info.n_samples > 0); + smp := !smp + info.n_samples + end; + None + }; + do_intern lo hi cnt false; + stop (); + + (* The probability distribution of the number of samples follows a + binomial distribution of parameters tot_alloc and rate. Given + that tot_alloc*rate and tot_alloc*(1-rate) are large (i.e., > + 100), this distribution is approximately equal to a normal + distribution. We compute a 1e-8 confidence interval for !smp + using quantiles of the normal distribution, and check that we are + in this confidence interval. *) + let tot_alloc = cnt*(lo+hi)*(hi-lo+1)/2 in + assert (float tot_alloc *. rate > 100. && + float tot_alloc *. (1. -. rate) > 100.); + let mean = float tot_alloc *. rate in + let stddev = sqrt (float tot_alloc *. rate *. (1. -. rate)) in + (* This assertion has probability to fail close to 1e-8. *) + assert (abs_float (mean -. float !smp) <= stddev *. 5.7) + +let () = + check_distrib 2 3000 3 0.00001; + check_distrib 2 3000 1 0.0001; + check_distrib 2 2000 1 0.01; + check_distrib 2 2000 1 0.9; + check_distrib 300000 300000 20 0.1 + +(* FIXME : in bytecode mode, the function [caml_get_current_callstack_impl], + which is supposed to capture the current call stack, does not have access + to the current value of [pc]. Therefore, depending on how the C call is + performed, we may miss the first call stack slot in the captured backtraces. + This is the reason why the reference file is different in native and + bytecode modes. + + Note that [Printexc.get_callstack] does not suffer from this problem, because + this function is actually an automatically generated stub which performs th + C call. This is because [Printexc.get_callstack] is not declared as external + in the mli file. *) + +let[@inline never] check_callstack () = + Printf.printf "check_callstack\n%!"; + precompute_marshalled_data 2 300; + let callstack = ref None in + start { + (* FIXME: we should use 1. to make sure the block is sampled, + but the runtime does an infinite loop in native mode in this + case. This bug will go away when the sampling of natively + allocated will be correctly implemented. *) + sampling_rate = 0.5; + callstack_size = 10; + callback = fun info -> + if info.kind = Unmarshalled then callstack := Some info.callstack; + None + }; + do_intern 2 300 1 false; + stop (); + match !callstack with + | None -> assert false + | Some cs -> Printexc.print_raw_backtrace stdout cs + +let () = check_callstack () + +let () = + Printf.printf "OK !\n" diff --git a/testsuite/tests/statmemprof/intern.opt.reference b/testsuite/tests/statmemprof/intern.opt.reference new file mode 100644 index 0000000000..43666c6007 --- /dev/null +++ b/testsuite/tests/statmemprof/intern.opt.reference @@ -0,0 +1,14 @@ +check_nosample +check_ephe_full_major +check_no_nested +check_distrib 2 3000 3 0.000010 +check_distrib 2 3000 1 0.000100 +check_distrib 2 2000 1 0.010000 +check_distrib 2 2000 1 0.900000 +check_distrib 300000 300000 20 0.100000 +check_callstack +Raised by primitive operation at file "marshal.ml", line 61, characters 9-35 +Called from file "intern.ml", line 32, characters 14-35 +Called from file "intern.ml", line 168, characters 2-25 +Called from file "intern.ml", line 174, characters 9-27 +OK ! diff --git a/testsuite/tests/statmemprof/ocamltests b/testsuite/tests/statmemprof/ocamltests index 761380f931..76d7ec9699 100644 --- a/testsuite/tests/statmemprof/ocamltests +++ b/testsuite/tests/statmemprof/ocamltests @@ -2,3 +2,4 @@ arrays_in_major.ml arrays_in_minor.ml lists_in_minor.ml exception_callback.ml +intern.ml diff --git a/testsuite/tests/tool-caml-tex/redirections.reference b/testsuite/tests/tool-caml-tex/redirections.reference index 64c5b10a39..242209c73d 100644 --- a/testsuite/tests/tool-caml-tex/redirections.reference +++ b/testsuite/tests/tool-caml-tex/redirections.reference @@ -18,10 +18,9 @@ \camlexample{toplevel} \caml\camlinput\?[@@@warning "+A"];; \endcamlinput\endcaml -\caml\camlinput\?1 \<+\> \<2.\> ;; +\caml\camlinput\?1 + \<2.\> ;; \endcamlinput\camlerror\:Error: This expression has type float but an expression was expected of type \: int -\: Hint: Did you mean to use \textasciigrave\-+.\textquotesingle\-? \endcamlerror\endcaml \caml\camlinput\?let f \<x\> = () ;; \endcamlinput\camlwarn\:Warning 27: unused variable x. diff --git a/testsuite/tests/tool-lexyacc/grammar.mly b/testsuite/tests/tool-lexyacc/grammar.mly index 00821d5140..24a06c5e46 100644 --- a/testsuite/tests/tool-lexyacc/grammar.mly +++ b/testsuite/tests/tool-lexyacc/grammar.mly @@ -3,6 +3,11 @@ %{ open Syntax open Gram_aux + +(* test f' '"' *) +let () = + let f' = ignore in + f' '"' %} %token <string> Tident diff --git a/testsuite/tests/tool-ocamldoc/Inline_records.man.reference b/testsuite/tests/tool-ocamldoc/Inline_records.man.reference index a2890e4045..040f9fa8c1 100644 --- a/testsuite/tests/tool-ocamldoc/Inline_records.man.reference +++ b/testsuite/tests/tool-ocamldoc/Inline_records.man.reference @@ -7,7 +7,7 @@ Module Inline_records Module .BI "Inline_records" : -.B sig end +.B sig end .sp This test focuses on the printing of documentation for inline record diff --git a/testsuite/tests/tool-ocamldoc/t01.reference b/testsuite/tests/tool-ocamldoc/t01.reference index 0802c2731e..1c2e0a774e 100644 --- a/testsuite/tests/tool-ocamldoc/t01.reference +++ b/testsuite/tests/tool-ocamldoc/t01.reference @@ -1,19 +1,19 @@ # # module T01: # Odoc_info.string_of_module_type: -<[sig end]> +<[sig end]> # Odoc_info.string_of_module_type ~complete: true : -<[sig end]> +<[sig end]> # # module T01.M: # Odoc_info.string_of_module_type: -<[sig end]> +<[sig end]> # Odoc_info.string_of_module_type ~complete: true : <[sig val y : int end]> # # module type T01.MT: # Odoc_info.string_of_module_type: -<[sig end]> +<[sig end]> # Odoc_info.string_of_module_type ~complete: true : <[sig type t = diff --git a/testsuite/tests/tool-ocamldoc/t04.reference b/testsuite/tests/tool-ocamldoc/t04.reference index 924503eabb..fc3c5f655a 100644 --- a/testsuite/tests/tool-ocamldoc/t04.reference +++ b/testsuite/tests/tool-ocamldoc/t04.reference @@ -1,13 +1,13 @@ # # module T04: # Odoc_info.string_of_module_type: -<[sig end]> +<[sig end]> # Odoc_info.string_of_module_type ~complete: true : -<[sig end]> +<[sig end]> # # module T04.A: # Odoc_info.string_of_module_type: -<[sig end]> +<[sig end]> # Odoc_info.string_of_module_type ~complete: true : <[sig type a = A of { lbl : int; } end]> # type T04.A.a: @@ -16,12 +16,12 @@ # # module type T04.E: # Odoc_info.string_of_module_type: -<[sig end]> +<[sig end]> # Odoc_info.string_of_module_type ~complete: true : <[sig exception E of { lbl : int; } end]> # # module T04.E_bis: # Odoc_info.string_of_module_type: -<[sig end]> +<[sig end]> # Odoc_info.string_of_module_type ~complete: true : <[sig exception E of { lbl : int; } end]> diff --git a/testsuite/tests/tool-ocamldoc/type_Linebreaks.reference b/testsuite/tests/tool-ocamldoc/type_Linebreaks.reference index f3df279a6c..86bd864601 100644 --- a/testsuite/tests/tool-ocamldoc/type_Linebreaks.reference +++ b/testsuite/tests/tool-ocamldoc/type_Linebreaks.reference @@ -20,8 +20,8 @@ <span class="keyword">type</span> s = ..<br> <span class="keyword">type</span> s += <span class="constructor">B</span><br> <span class="keyword">val</span> x : <span class="constructor">Linebreaks</span>.a<br> - <span class="keyword">module</span> <span class="constructor">S</span> : <span class="keyword">sig</span> <span class="keyword">module</span> <span class="constructor">I</span> : <span class="keyword">sig</span> <span class="keyword">end</span> <span class="keyword">end</span><br> - <span class="keyword">module</span> <span class="keyword">type</span> s = <span class="keyword">sig</span> <span class="keyword">end</span><br> + <span class="keyword">module</span> <span class="constructor">S</span> : <span class="keyword">sig</span> <span class="keyword">module</span> <span class="constructor">I</span> : <span class="keyword">sig</span> <span class="keyword">end</span> <span class="keyword">end</span><br> + <span class="keyword">module</span> <span class="keyword">type</span> s = <span class="keyword">sig</span> <span class="keyword">end</span><br> <span class="keyword">class</span> <span class="keyword">type</span> d = <span class="keyword">object</span> <span class="keyword">end</span><br> <span class="keyword">exception</span> <span class="constructor">E</span> <span class="keyword">of</span> { inline : int; }<br> <span class="keyword">end</span></code></body></html> diff --git a/testsuite/tests/tool-toplevel/error_highlighting.compilers.reference b/testsuite/tests/tool-toplevel/error_highlighting.compilers.reference index c0edb9c5d8..fe6ac39a72 100644 --- a/testsuite/tests/tool-toplevel/error_highlighting.compilers.reference +++ b/testsuite/tests/tool-toplevel/error_highlighting.compilers.reference @@ -39,6 +39,11 @@ Lines 2-4, characters 8-2: 4 | 2)... Error: This expression has type int but an expression was expected of type float +Line 2, characters 12-17: +2 | let x = 1 + "abc" in + ^^^^^ +Error: This expression has type string but an expression was expected of type + int File "error_highlighting_use1.ml", line 1, characters 8-15: 1 | let x = (1 + 2) +. 3. in ();; ^^^^^^^ diff --git a/testsuite/tests/tool-toplevel/error_highlighting.ml b/testsuite/tests/tool-toplevel/error_highlighting.ml index 832b55da01..5716a7ac9f 100644 --- a/testsuite/tests/tool-toplevel/error_highlighting.ml +++ b/testsuite/tests/tool-toplevel/error_highlighting.ml @@ -26,6 +26,85 @@ let x = (1 2) +. 3. in ();; +let x = 1 + "abc" in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in +let x = 1 in ();; + #use "error_highlighting_use1.ml";; #use "error_highlighting_use2.ml";; #use "error_highlighting_use3.ml";; diff --git a/testsuite/tests/tool-toplevel/pr6468.compilers.reference b/testsuite/tests/tool-toplevel/pr6468.compilers.reference index a63d008d18..a716651e60 100644 --- a/testsuite/tests/tool-toplevel/pr6468.compilers.reference +++ b/testsuite/tests/tool-toplevel/pr6468.compilers.reference @@ -8,5 +8,5 @@ val g : unit -> int = <fun> Exception: Not_found. Raised at file "//toplevel//", line 2, characters 17-26 Called from file "//toplevel//", line 1, characters 11-15 -Called from file "toplevel/toploop.ml", line 208, characters 17-27 +Called from file "toplevel/toploop.ml", line 212, characters 17-27 diff --git a/testsuite/tests/tool-toplevel/redefinition_hints.compilers.reference b/testsuite/tests/tool-toplevel/redefinition_hints.compilers.reference index b9ccb7a214..4fc85aae1c 100644 --- a/testsuite/tests/tool-toplevel/redefinition_hints.compilers.reference +++ b/testsuite/tests/tool-toplevel/redefinition_hints.compilers.reference @@ -1,11 +1,11 @@ -module Empty : sig end +module Empty : sig end type u = A type v = B -module type S = sig end +module type S = sig end val m : (module S) = <module> module M : sig type 'a t = X of 'a end val x : (u * v * (module S)) M.t = M.X (A, B, <module>) -module type S = sig end +module type S = sig end val m : (module S) = <module> type u = A type v = B diff --git a/testsuite/tests/typing-core-bugs/int_operator_hint.ml b/testsuite/tests/typing-core-bugs/int_operator_hint.ml deleted file mode 100644 index af11388d46..0000000000 --- a/testsuite/tests/typing-core-bugs/int_operator_hint.ml +++ /dev/null @@ -1,79 +0,0 @@ -(* TEST - * expect -*) - -let _ = 0. + 0. -[%%expect{| -Line 1, characters 8-10: -1 | let _ = 0. + 0. - ^^ -Error: This expression has type float but an expression was expected of type - int -Line 1, characters 11-12: -1 | let _ = 0. + 0. - ^ - Hint: Did you mean to use `+.'? -|}] - -let _ = 0l - 0l -[%%expect{| -Line 1, characters 8-10: -1 | let _ = 0l - 0l - ^^ -Error: This expression has type int32 but an expression was expected of type - int -Line 1, characters 11-12: -1 | let _ = 0l - 0l - ^ - Hint: Did you mean to use `Int32.sub'? -|}] - -let _ = 0L * 0L -[%%expect{| -Line 1, characters 8-10: -1 | let _ = 0L * 0L - ^^ -Error: This expression has type int64 but an expression was expected of type - int -Line 1, characters 11-12: -1 | let _ = 0L * 0L - ^ - Hint: Did you mean to use `Int64.mul'? -|}] - -let _ = 0n / 0n -[%%expect{| -Line 1, characters 8-10: -1 | let _ = 0n / 0n - ^^ -Error: This expression has type nativeint - but an expression was expected of type int -Line 1, characters 11-12: -1 | let _ = 0n / 0n - ^ - Hint: Did you mean to use `Nativeint.div'? -|}] - -let _ = 0. mod 0. -[%%expect{| -Line 1, characters 8-10: -1 | let _ = 0. mod 0. - ^^ -Error: This expression has type float but an expression was expected of type - int -Line 1, characters 11-14: -1 | let _ = 0. mod 0. - ^^^ - Hint: Did you mean to use `Float.rem'? -|}] - -(* disabled *) -let _ = 0 +. 0 -[%%expect{| -Line 1, characters 8-9: -1 | let _ = 0 +. 0 - ^ -Error: This expression has type int but an expression was expected of type - float - Hint: Did you mean `0.'? -|}] diff --git a/testsuite/tests/typing-core-bugs/ocamltests b/testsuite/tests/typing-core-bugs/ocamltests index a4d4093ec7..02cb7e3ecb 100644 --- a/testsuite/tests/typing-core-bugs/ocamltests +++ b/testsuite/tests/typing-core-bugs/ocamltests @@ -3,4 +3,3 @@ unit_fun_hints.ml type_expected_explanation.ml repeated_did_you_mean.ml const_int_hint.ml -int_operator_hint.ml diff --git a/testsuite/tests/typing-deprecated/deprecated.ml b/testsuite/tests/typing-deprecated/deprecated.ml index 18adcb9951..8429df43e0 100644 --- a/testsuite/tests/typing-deprecated/deprecated.ml +++ b/testsuite/tests/typing-deprecated/deprecated.ml @@ -384,7 +384,7 @@ module D = struct end[@@ocaml.deprecated] open D ;; [%%expect{| -module D : sig end +module D : sig end Line 3, characters 5-6: 3 | open D ^ @@ -575,7 +575,7 @@ Line 8, characters 22-36: 8 | [@@@ocaml.ppwarning "Pp warning2!"] ^^^^^^^^^^^^^^ Warning 22: Pp warning2! -module X : sig end +module X : sig end |}] let x = diff --git a/testsuite/tests/typing-gadts/pr6241.ml b/testsuite/tests/typing-gadts/pr6241.ml index 3a7781446f..330965f7f1 100644 --- a/testsuite/tests/typing-gadts/pr6241.ml +++ b/testsuite/tests/typing-gadts/pr6241.ml @@ -30,7 +30,7 @@ A module M : functor (A : sig module type T end) (B : sig module type T end) -> sig val f : ((module A.T), (module B.T)) t -> string end -module A : sig module type T = sig end end +module A : sig module type T = sig end end module N : sig val f : ((module A.T), (module A.T)) t -> string end Exception: Match_failure ("", 8, 52). |}];; diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml index 63be941dbf..8dbdadbe2e 100644 --- a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml +++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml @@ -470,3 +470,31 @@ Line 4, characters 10-51: Error: The type t in this module cannot be exported. Its type contains local dependencies: %M.elt list |}];; + +type 'a s = (module S with type t = 'a);; +[%%expect{| +type 'a s = (module S with type t = 'a) +|}];; + +let x : 'a s = (module struct type t = int end);; +[%%expect{| +val x : int s = <module> +|}];; + +let x : 'a s = (module struct type t = A end);; +[%%expect{| +Line 1, characters 23-44: +1 | let x : 'a s = (module struct type t = A end);; + ^^^^^^^^^^^^^^^^^^^^^ +Error: The type t in this module cannot be exported. + Its type contains local dependencies: %M.t +|}];; + +let x : 'a s = (module struct end);; +[%%expect{| +Line 1, characters 23-33: +1 | let x : 'a s = (module struct end);; + ^^^^^^^^^^ +Error: The type t in this module cannot be exported. + Its type contains local dependencies: %M.t +|}];; diff --git a/testsuite/tests/typing-misc/pr6416.ml b/testsuite/tests/typing-misc/pr6416.ml index ca8700865f..bda17f1d1c 100644 --- a/testsuite/tests/typing-misc/pr6416.ml +++ b/testsuite/tests/typing-misc/pr6416.ml @@ -78,14 +78,14 @@ Lines 4-7, characters 4-7: 7 | end Error: Signature mismatch: Modules do not match: - sig module type s module A : functor (X : s) -> sig end end + sig module type s module A : functor (X : s) -> sig end end is not included in - sig module A : functor (X : s) -> sig end end + sig module A : functor (X : s) -> sig end end In module A: Modules do not match: - functor (X : s/1) -> sig end + functor (X : s/1) -> sig end is not included in - functor (X : s/2) -> sig end + functor (X : s/2) -> sig end At position module A(X : <here>) : ... Modules do not match: s/2 is not included in s/1 Line 5, characters 6-19: @@ -403,7 +403,7 @@ let add_extra_info arg = arg.Foo.info.doc [%%expect{| module Bar : sig type info = { doc : unit; } end module Foo : sig type t = { info : Bar.info; } end -module Bar : sig end +module Bar : sig end Line 8, characters 38-41: 8 | let add_extra_info arg = arg.Foo.info.doc ^^^ diff --git a/testsuite/tests/typing-misc/pr8548.ml b/testsuite/tests/typing-misc/pr8548.ml index c50809af3f..7053ed6817 100644 --- a/testsuite/tests/typing-misc/pr8548.ml +++ b/testsuite/tests/typing-misc/pr8548.ml @@ -112,7 +112,8 @@ module Assume : range -> 'a end end - end) -> + end) + -> sig module Point : sig type t end module Test_range : diff --git a/testsuite/tests/typing-misc/typecore_errors.ml b/testsuite/tests/typing-misc/typecore_errors.ml index 985e67ec17..9b00a4f692 100644 --- a/testsuite/tests/typing-misc/typecore_errors.ml +++ b/testsuite/tests/typing-misc/typecore_errors.ml @@ -224,7 +224,7 @@ module type empty = sig end let f (x:int) = () let x = f (module struct end) [%%expect {| -module type empty = sig end +module type empty = sig end val f : int -> unit = <fun> Line 3, characters 10-29: 3 | let x = f (module struct end) diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml index 4570ce3cdd..6287a6e6f6 100644 --- a/testsuite/tests/typing-modules/Test.ml +++ b/testsuite/tests/typing-modules/Test.ml @@ -14,8 +14,8 @@ module type S' = sig type s = int end module type S = sig module rec M : sig end and N : sig end end;; module type S' = S with module M := String;; [%%expect{| -module type S = sig module rec M : sig end and N : sig end end -module type S' = sig module rec N : sig end end +module type S = sig module rec M : sig end and N : sig end end +module type S' = sig module rec N : sig end end |}];; (* with module type *) @@ -119,7 +119,7 @@ Error: Multiple definition of the extension constructor name Foo. module F(X : sig end) = struct let x = 3 end;; F.x;; (* fail *) [%%expect{| -module F : functor (X : sig end) -> sig val x : int end +module F : functor (X : sig end) -> sig val x : int end Line 2, characters 0-3: 2 | F.x;; (* fail *) ^^^ diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml index 40727eb783..2f2cfd2432 100644 --- a/testsuite/tests/typing-modules/aliases.ml +++ b/testsuite/tests/typing-modules/aliases.ml @@ -57,7 +57,7 @@ module C4 = F(struct end);; C4.chr 66;; [%%expect{| module F : - functor (X : sig end) -> + functor (X : sig end) -> sig external code : char -> int = "%identity" val chr : int -> char @@ -91,8 +91,8 @@ module C4 : module G(X:sig end) = struct module M = X end;; (* does not alias X *) module M = G(struct end);; [%%expect{| -module G : functor (X : sig end) -> sig module M : sig end end -module M : sig module M : sig end end +module G : functor (X : sig end) -> sig module M : sig end end +module M : sig module M : sig end end |}];; module M' = struct @@ -141,9 +141,9 @@ module M5 = G(struct end);; M5.N'.x;; [%%expect{| module F : - functor (X : sig end) -> + functor (X : sig end) -> sig module N : sig val x : int end module N' = N end -module G : functor (X : sig end) -> sig module N' : sig val x : int end end +module G : functor (X : sig end) -> sig module N' : sig val x : int end end module M5 : sig module N' : sig val x : int end end - : int = 1 |}];; @@ -377,8 +377,8 @@ end;; include T;; let f (x : t) : T.t = x ;; [%%expect{| -module F : functor (M : sig end) -> sig type t end -module T : sig module M : sig end type t = F(M).t end +module F : functor (M : sig end) -> sig type t end +module T : sig module M : sig end type t = F(M).t end module M = T.M type t = F(M).t val f : t -> T.t = <fun> @@ -462,16 +462,11 @@ module G = F (M.Y);; (*module N = G (M);; module N = F (M.Y) (M);;*) [%%expect{| -module FF : functor (X : sig end) -> sig type t end +module FF : functor (X : sig end) -> sig type t end module M : - sig - module X : sig end - module Y : sig type t = FF(X).t end - type t = Y.t - end -module F : - functor (Y : sig type t end) (M : sig type t = Y.t end) -> sig end -module G : functor (M : sig type t = M.Y.t end) -> sig end + sig module X : sig end module Y : sig type t = FF(X).t end type t = Y.t end +module F : functor (Y : sig type t end) (M : sig type t = Y.t end) -> sig end +module G : functor (M : sig type t = M.Y.t end) -> sig end |}];; (* PR#6307 *) @@ -486,13 +481,13 @@ module F (L : (module type of L1 [@remove_aliases])) = struct end;; module F1 = F(L1);; (* ok *) module F2 = F(L2);; (* should succeed too *) [%%expect{| -module A1 : sig end -module A2 : sig end +module A1 : sig end +module A2 : sig end module L1 : sig module X = A1 end module L2 : sig module X = A2 end -module F : functor (L : sig module X : sig end end) -> sig end -module F1 : sig end -module F2 : sig end +module F : functor (L : sig module X : sig end end) -> sig end +module F1 : sig end +module F2 : sig end |}];; (* Counter example: why we need to be careful with PR#6307 *) @@ -663,8 +658,8 @@ module F (X : sig end) = struct type t end;; module type A = Alias with module N := F(List);; module rec Bad : A = Bad;; [%%expect{| -module type Alias = sig module N : sig end module M = N end -module F : functor (X : sig end) -> sig type t end +module type Alias = sig module N : sig end module M = N end +module F : functor (X : sig end) -> sig type t end Line 1: Error: Module type declarations do not match: module type A = sig module M = F(List) end @@ -716,7 +711,7 @@ module type S = sig module Q = M end;; [%%expect{| -module type S = sig module M : sig module P : sig end end module Q = M end +module type S = sig module M : sig module P : sig end end module Q = M end |}];; module type S = sig module M : sig module N : sig end module P : sig end end @@ -730,12 +725,12 @@ module R' : S = R;; [%%expect{| module type S = sig - module M : sig module N : sig end module P : sig end end + module M : sig module N : sig end module P : sig end end module Q : sig module N = M.N module P = M.P end end module R : sig - module M : sig module N : sig end module P : sig end end + module M : sig module N : sig end module P : sig end end module Q = M end module R' : S @@ -756,9 +751,9 @@ end = struct type a = Foo.b end;; [%%expect{| -module F : functor (X : sig end) -> sig type t end +module F : functor (X : sig end) -> sig type t end module M : - sig type a module Foo : sig module Bar : sig end type b = a end end + sig type a module Foo : sig module Bar : sig end type b = a end end |}];; (* PR#6578 *) @@ -796,7 +791,7 @@ end = struct module type S = module type of struct include X end end;; [%%expect{| -module X : sig module N : sig end end +module X : sig module N : sig end end module Y : sig module type S = sig module N = X.N end end |}];; @@ -819,7 +814,7 @@ let s : string = Bar.N.x [%%expect {| module type S = sig - module M : sig module A : sig end module B : sig end end + module M : sig module A : sig end module B : sig end end module N = M.A end module Foo : diff --git a/testsuite/tests/typing-modules/generative.ml b/testsuite/tests/typing-modules/generative.ml index f490f075e7..c9411da3e6 100644 --- a/testsuite/tests/typing-modules/generative.ml +++ b/testsuite/tests/typing-modules/generative.ml @@ -14,8 +14,8 @@ module H (X : sig end) = (val v);; (* ok *) module type S = sig val x : int end val v : (module S) = <module> module F : functor () -> S -module G : functor (X : sig end) -> S -module H : functor (X : sig end) -> S +module G : functor (X : sig end) -> S +module H : functor (X : sig end) -> S |}];; (* With type *) @@ -44,7 +44,7 @@ module H : functor () -> S module U = struct end;; module M = F(struct end);; (* ok *) [%%expect{| -module U : sig end +module U : sig end module M : S |}];; module M = F(U);; (* fail *) @@ -59,28 +59,28 @@ Error: This is a generative functor. It can only be applied to () module F1 (X : sig end) = struct end;; module F2 : functor () -> sig end = F1;; (* fail *) [%%expect{| -module F1 : functor (X : sig end) -> sig end +module F1 : functor (X : sig end) -> sig end Line 2, characters 36-38: 2 | module F2 : functor () -> sig end = F1;; (* fail *) ^^ Error: Signature mismatch: Modules do not match: - functor (X : sig end) -> sig end + functor (X : sig end) -> sig end is not included in - functor () -> sig end + functor () -> sig end |}];; module F3 () = struct end;; module F4 : functor (X : sig end) -> sig end = F3;; (* fail *) [%%expect{| -module F3 : functor () -> sig end +module F3 : functor () -> sig end Line 2, characters 47-49: 2 | module F4 : functor (X : sig end) -> sig end = F3;; (* fail *) ^^ Error: Signature mismatch: Modules do not match: - functor () -> sig end + functor () -> sig end is not included in - functor (X : sig end) -> sig end + functor (X : sig end) -> sig end |}];; (* tests for shortened functor notation () *) @@ -91,8 +91,8 @@ module Z = functor (_: sig end) (_:sig end) (_: sig end) -> struct end;; module GZ : functor (X: sig end) () (Z: sig end) -> sig end = functor (X: sig end) () (Z: sig end) -> struct end;; [%%expect{| -module X : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end -module Y : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end -module Z : sig end -> sig end -> sig end -> sig end -module GZ : functor (X : sig end) () (Z : sig end) -> sig end +module X : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end +module Y : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end +module Z : sig end -> sig end -> sig end -> sig end +module GZ : functor (X : sig end) () (Z : sig end) -> sig end |}];; diff --git a/testsuite/tests/typing-modules/illegal_permutation.ml b/testsuite/tests/typing-modules/illegal_permutation.ml index 12eff93604..66ebb25112 100644 --- a/testsuite/tests/typing-modules/illegal_permutation.ml +++ b/testsuite/tests/typing-modules/illegal_permutation.ml @@ -503,29 +503,23 @@ Error: Signature mismatch: module B : sig module C : - functor - (X : sig end) (Y : sig end) (Z : sig - module D : - sig - module E : - sig - module F : - functor - (X : - sig - - end) (Arg : - sig - val two : - int - val one : - int - end) -> - sig end - end - end - end) -> - sig end + functor (X : sig end) (Y : sig end) + (Z : sig + module D : + sig + module E : + sig + module F : + functor (X : sig end) + (Arg : sig + val two : int + val one : int + end) + -> sig end + end + end + end) + -> sig end end end end @@ -539,29 +533,23 @@ Error: Signature mismatch: module B : sig module C : - functor - (X : sig end) (Y : sig end) (Z : sig - module D : - sig - module E : - sig - module F : - functor - (X : - sig - - end) (Arg : - sig - val one : - int - val two : - int - end) -> - sig end - end - end - end) -> - sig end + functor (X : sig end) (Y : sig end) + (Z : sig + module D : + sig + module E : + sig + module F : + functor (X : sig end) + (Arg : sig + val one : int + val two : int + end) + -> sig end + end + end + end) + -> sig end end end end @@ -574,29 +562,23 @@ Error: Signature mismatch: module B : sig module C : - functor - (X : sig end) (Y : sig end) (Z : sig - module D : - sig - module E : - sig - module F : - functor - (X : - sig - - end) (Arg : - sig - val two : - int - val one : - int - end) -> - sig end - end - end - end) -> - sig end + functor (X : sig end) (Y : sig end) + (Z : sig + module D : + sig + module E : + sig + module F : + functor (X : sig end) + (Arg : sig + val two : int + val one : int + end) + -> sig end + end + end + end) + -> sig end end end end @@ -608,29 +590,23 @@ Error: Signature mismatch: module B : sig module C : - functor - (X : sig end) (Y : sig end) (Z : sig - module D : - sig - module E : - sig - module F : - functor - (X : - sig - - end) (Arg : - sig - val one : - int - val two : - int - end) -> - sig end - end - end - end) -> - sig end + functor (X : sig end) (Y : sig end) + (Z : sig + module D : + sig + module E : + sig + module F : + functor (X : sig end) + (Arg : sig + val one : int + val two : int + end) + -> sig end + end + end + end) + -> sig end end end end diff --git a/testsuite/tests/typing-modules/nondep_private_abbrev.ml b/testsuite/tests/typing-modules/nondep_private_abbrev.ml index 886fcfc593..4c8e4e1e34 100644 --- a/testsuite/tests/typing-modules/nondep_private_abbrev.ml +++ b/testsuite/tests/typing-modules/nondep_private_abbrev.ml @@ -8,7 +8,7 @@ end = struct type t = int end;; [%%expect{| -module F : sig end -> sig type t = private int end +module F : sig end -> sig type t = private int end |}] module Direct = F(struct end);; @@ -20,7 +20,7 @@ module G(X : sig end) : sig type t = F(X).t end = F(X);; [%%expect{| -module G : functor (X : sig end) -> sig type t = F(X).t end +module G : functor (X : sig end) -> sig type t = F(X).t end |}] module Indirect = G(struct end);; @@ -34,14 +34,14 @@ module Pub(_ : sig end) = struct type t = [ `Foo of t ] end;; [%%expect{| -module Pub : sig end -> sig type t = [ `Foo of t ] end +module Pub : sig end -> sig type t = [ `Foo of t ] end |}] module Priv(_ : sig end) = struct type t = private [ `Foo of t ] end;; [%%expect{| -module Priv : sig end -> sig type t = private [ `Foo of t ] end +module Priv : sig end -> sig type t = private [ `Foo of t ] end |}] module DirectPub = Pub(struct end);; @@ -58,14 +58,14 @@ module H(X : sig end) : sig type t = Pub(X).t end = Pub(X);; [%%expect{| -module H : functor (X : sig end) -> sig type t = Pub(X).t end +module H : functor (X : sig end) -> sig type t = Pub(X).t end |}] module I(X : sig end) : sig type t = Priv(X).t end = Priv(X);; [%%expect{| -module I : functor (X : sig end) -> sig type t = Priv(X).t end +module I : functor (X : sig end) -> sig type t = Priv(X).t end |}] module IndirectPub = H(struct end);; @@ -121,14 +121,14 @@ module Priv(_ : sig end) = struct end;; [%%expect{| module Priv : - sig end -> sig type t = private [ `Bar of int | `Foo of t -> int ] end + sig end -> sig type t = private [ `Bar of int | `Foo of t -> int ] end |}] module I(X : sig end) : sig type t = Priv(X).t end = Priv(X);; [%%expect{| -module I : functor (X : sig end) -> sig type t = Priv(X).t end +module I : functor (X : sig end) -> sig type t = Priv(X).t end |}] module IndirectPriv = I(struct end);; diff --git a/testsuite/tests/typing-modules/pr5911.ml b/testsuite/tests/typing-modules/pr5911.ml index 2d8b557f47..1c08b37af2 100644 --- a/testsuite/tests/typing-modules/pr5911.ml +++ b/testsuite/tests/typing-modules/pr5911.ml @@ -12,7 +12,7 @@ module Good (X : S with type t := unit) = struct end;; [%%expect{| module type S = sig type t val x : t end -module Good : functor (X : sig val x : unit end) -> sig end +module Good : functor (X : sig val x : unit end) -> sig end |}];; module type T = sig module M : S end;; @@ -23,6 +23,5 @@ end;; [%%expect{| module type T = sig module M : S end module Bad : - functor (X : sig module M : sig type t = unit val x : t end end) -> - sig end + functor (X : sig module M : sig type t = unit val x : t end end) -> sig end |}];; diff --git a/testsuite/tests/typing-modules/pr7207.ml b/testsuite/tests/typing-modules/pr7207.ml index 8100064875..a061a34d67 100644 --- a/testsuite/tests/typing-modules/pr7207.ml +++ b/testsuite/tests/typing-modules/pr7207.ml @@ -5,7 +5,7 @@ module F (X : sig end) = struct type t = int end;; type t = F(Does_not_exist).t;; [%%expect{| -module F : functor (X : sig end) -> sig type t = int end +module F : functor (X : sig end) -> sig type t = int end Line 2, characters 9-28: 2 | type t = F(Does_not_exist).t;; ^^^^^^^^^^^^^^^^^^^ diff --git a/testsuite/tests/typing-modules/pr7348.ml b/testsuite/tests/typing-modules/pr7348.ml index e24d529f40..dc0cf4050d 100644 --- a/testsuite/tests/typing-modules/pr7348.ml +++ b/testsuite/tests/typing-modules/pr7348.ml @@ -37,5 +37,5 @@ module A : sig end = struct let _ = (N.x = M.x) end;; [%%expect{| -module A : sig end +module A : sig end |}] diff --git a/testsuite/tests/typing-modules/pr7726.ml b/testsuite/tests/typing-modules/pr7726.ml index edc640806e..c404983fe3 100644 --- a/testsuite/tests/typing-modules/pr7726.ml +++ b/testsuite/tests/typing-modules/pr7726.ml @@ -122,7 +122,7 @@ module M = struct end;; type t = F(M).t;; [%%expect{| module F : functor () -> sig type t end -module M : sig end +module M : sig end Line 3, characters 9-15: 3 | type t = F(M).t;; ^^^^^^ @@ -139,7 +139,7 @@ module Fix2 : functor (F : T -> T) -> sig module rec Fixed : sig type t = F(Fixed).t end - module R : functor (X : sig end) -> sig type t = Fixed.t end + module R : functor (X : sig end) -> sig type t = Fixed.t end end Line 5, characters 11-26: 5 | let f (x : Fix2(Id).R(M).t) = x;; diff --git a/testsuite/tests/typing-modules/pr7818.ml b/testsuite/tests/typing-modules/pr7818.ml index 200946ded3..0fafb58162 100644 --- a/testsuite/tests/typing-modules/pr7818.ml +++ b/testsuite/tests/typing-modules/pr7818.ml @@ -19,7 +19,7 @@ end;; [%%expect{| module Termsig : sig - module Term0 : sig module type S = sig module Id : sig end end end + module Term0 : sig module type S = sig module Id : sig end end end module Term : sig module type S = sig module Term0 : Term0.S module T = Term0 end end end @@ -36,9 +36,9 @@ module Make1 : functor (T' : sig module Term0 : Termsig.Term0.S - module T : sig module Id : sig end end - end) -> - sig module T : sig module Id : sig end val u : int end end + module T : sig module Id : sig end end + end) + -> sig module T : sig module Id : sig end val u : int end end |}] module Make2 (T' : Termsig.Term.S) = struct @@ -53,10 +53,11 @@ module Make2 : functor (T' : sig module Term0 : Termsig.Term0.S - module T : sig module Id : sig end end - end) -> + module T : sig module Id : sig end end + end) + -> sig - module T : sig module Id : sig end module Id2 = Id val u : int end + module T : sig module Id : sig end module Id2 = Id val u : int end end |}] @@ -73,10 +74,11 @@ module Make3 : functor (T' : sig module Term0 : Termsig.Term0.S - module T : sig module Id : sig end end - end) -> + module T : sig module Id : sig end end + end) + -> sig - module T : sig module Id : sig end module Id2 = Id val u : int end + module T : sig module Id : sig end module Id2 = Id val u : int end end |}] @@ -92,14 +94,14 @@ module Make1 (T' : S) = struct end;; [%%expect{| module type S = - sig module Term0 : sig module Id : sig end end module T = Term0 end + sig module Term0 : sig module Id : sig end end module T = Term0 end module Make1 : functor (T' : sig - module Term0 : sig module Id : sig end end - module T : sig module Id : sig end end - end) -> - sig module Id : sig end module Id2 = Id end + module Term0 : sig module Id : sig end end + module T : sig module Id : sig end end + end) + -> sig module Id : sig end module Id2 = Id end |}] module Make2 (T' : S) : sig module Id : sig end module Id2 = Id end @@ -115,7 +117,7 @@ Lines 2-5, characters 57-3: 5 | end.. Error: Signature mismatch: Modules do not match: - sig module Id : sig end module Id2 = Id end + sig module Id : sig end module Id2 = Id end is not included in sig module Id2 = T'.Term0.Id end In module Id2: @@ -134,11 +136,12 @@ end;; module Make3 : functor (T' : sig - module Term0 : sig module Id : sig end end - module T : sig module Id : sig end end - end) -> + module Term0 : sig module Id : sig end end + module T : sig module Id : sig end end + end) + -> sig - module T : sig module Id : sig end module Id2 = Id val u : int end + module T : sig module Id : sig end module Id2 = Id val u : int end end |}] @@ -147,7 +150,7 @@ module M = Make1 (struct module Term0 = struct module Id = struct let x = "a" end end module T = Term0 end);; M.Id.x;; [%%expect{| -module M : sig module Id : sig end module Id2 = Id end +module M : sig module Id : sig end module Id2 = Id end Line 3, characters 0-6: 3 | M.Id.x;; ^^^^^^ @@ -177,28 +180,28 @@ end;; module M = Make1(IS);; [%%expect{| -module MkT : functor (X : sig end) -> sig type t end +module MkT : functor (X : sig end) -> sig type t end module type S = sig - module Term0 : sig module Id : sig end end + module Term0 : sig module Id : sig end end module T = Term0 type t = MkT(T).t end module Make1 : functor (T' : sig - module Term0 : sig module Id : sig end end - module T : sig module Id : sig end end + module Term0 : sig module Id : sig end end + module T : sig module Id : sig end end type t = MkT(T).t - end) -> - sig module Id : sig end module Id2 = Id type t = T'.t end + end) + -> sig module Id : sig end module Id2 = Id type t = T'.t end module IS : sig module Term0 : sig module Id : sig val x : string end end module T = Term0 type t = MkT(T).t end -module M : sig module Id : sig end module Id2 = Id type t = IS.t end +module M : sig module Id : sig end module Id2 = Id type t = IS.t end |}] @@ -287,7 +290,8 @@ module F : module T : sig type t = int val compare : t -> t -> int end type t = E of (MkT(T).t, MkT(T).t) eq type u = t = E of (MkT(Term0).t, MkT(T).t) eq - end) -> + end) + -> sig module Term0 : sig type t = int val compare : t -> t -> int end module T : sig type t = int val compare : t -> t -> int end diff --git a/testsuite/tests/typing-modules/printing.ml b/testsuite/tests/typing-modules/printing.ml index f6792ba8b5..796431507e 100644 --- a/testsuite/tests/typing-modules/printing.ml +++ b/testsuite/tests/typing-modules/printing.ml @@ -28,3 +28,31 @@ module M = struct module N = struct let x = 1 end end;; module M : sig module N : sig val x : int end end module M : sig module N : sig ... end end |}];; + +(* Shortcut notation for functors *) +module type A +module type B +module type C +module type D +module type E +module type F +module Test(X: ((A->(B->C)->D) -> (E -> F))) = struct end +[%%expect {| +module type A +module type B +module type C +module type D +module type E +module type F +module Test : functor (X : (A -> (B -> C) -> D) -> E -> F) -> sig end +|}] + +(* test reprinting of functors *) +module type LongFunctor1 = functor (X : A) () (_ : B) () -> C -> D -> sig end +[%%expect {| +module type LongFunctor1 = functor (X : A) () (_ : B) () -> C -> D -> sig end +|}] +module type LongFunctor2 = functor (_ : A) () (_ : B) () -> C -> D -> sig end +[%%expect {| +module type LongFunctor2 = A -> functor () (_ : B) () -> C -> D -> sig end +|}] diff --git a/testsuite/tests/typing-modules/unroll_private_abbrev.ml b/testsuite/tests/typing-modules/unroll_private_abbrev.ml index 3bc65dd7cb..4fa7f7da2f 100644 --- a/testsuite/tests/typing-modules/unroll_private_abbrev.ml +++ b/testsuite/tests/typing-modules/unroll_private_abbrev.ml @@ -48,7 +48,7 @@ end = struct end;; [%%expect{| module F : - functor (X : sig end) -> + functor (X : sig end) -> sig type s = private [ `Bar of 'a | `Foo ] as 'a val from : M.t -> s diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index d63160cb71..72952fb5de 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -728,7 +728,7 @@ val x : '_weak2 list ref = {contents = []} module F(X : sig end) = struct type t = int let _ = (x : < m : t> list ref) end;; [%%expect{| -module F : functor (X : sig end) -> sig type t = int end +module F : functor (X : sig end) -> sig type t = int end |}];; x;; [%%expect{| diff --git a/testsuite/tests/typing-recmod/gpr1626.ml b/testsuite/tests/typing-recmod/gpr1626.ml index ab9563559c..9629f2c603 100644 --- a/testsuite/tests/typing-recmod/gpr1626.ml +++ b/testsuite/tests/typing-recmod/gpr1626.ml @@ -4,7 +4,7 @@ module type S = sig module M : sig end module N = M end;; [%%expect{| -module type S = sig module M : sig end module N = M end +module type S = sig module M : sig end module N = M end |}];; module rec M : S with module M := M = M;; diff --git a/testsuite/tests/typing-signatures/els.ocaml.reference b/testsuite/tests/typing-signatures/els.ocaml.reference index 5254b22bf5..678b88e7da 100644 --- a/testsuite/tests/typing-signatures/els.ocaml.reference +++ b/testsuite/tests/typing-signatures/els.ocaml.reference @@ -71,8 +71,8 @@ module USERCODE : sig type value type state type usert = X.combined end val setglobal : V.state -> string -> V.value -> unit val apply : V.value -> V.state -> V.value list -> V.value - end) -> - sig val init : C.V.state -> unit end + end) + -> sig val init : C.V.state -> unit end end module Weapon : sig type t end module type WEAPON_LIB = @@ -86,8 +86,8 @@ module type WEAPON_LIB = type combined type t = t val map : (combined -> t) * (t -> combined) - end) -> - USERCODE(TV).F + end) + -> USERCODE(TV).F end module type X = functor (X : CORE) -> BARECODE module type X = CORE -> BARECODE diff --git a/testsuite/tests/typing-sigsubst/sig_local_aliases.ml b/testsuite/tests/typing-sigsubst/sig_local_aliases.ml index 0427ad2576..3142a6aa82 100644 --- a/testsuite/tests/typing-sigsubst/sig_local_aliases.ml +++ b/testsuite/tests/typing-sigsubst/sig_local_aliases.ml @@ -88,7 +88,7 @@ module type AcceptAnd = sig and u := int * int end;; [%%expect{| -module type AcceptAnd = sig end +module type AcceptAnd = sig end |}] module type RejectAnd = sig diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml b/testsuite/tests/typing-sigsubst/sigsubst.ml index 1910b8a70e..7e0500d5ff 100644 --- a/testsuite/tests/typing-sigsubst/sigsubst.ml +++ b/testsuite/tests/typing-sigsubst/sigsubst.ml @@ -122,7 +122,7 @@ module type S' = sig val f : M.exp -> M.arg end module type S = sig type 'a t end with type 'a t := unit [%%expect {| -module type S = sig end +module type S = sig end |}] module type S = sig @@ -336,7 +336,7 @@ Lines 2-5, characters 17-25: 5 | end with type M2.t := int Error: This `with' constraint on M2.t makes the applicative functor type Id(M2).t ill-typed in the constrained signature: - Modules do not match: sig end is not included in sig type t end + Modules do not match: sig end is not included in sig type t end The type `t' is required but not provided |}] @@ -356,7 +356,7 @@ module type S = sig end with module M.N := A [%%expect {| module A : sig module P : sig type t val x : int end end -module type S = sig module M : sig end type t = A.P.t end +module type S = sig module M : sig end type t = A.P.t end |}] (* Same as for types, not all substitutions are accepted *) diff --git a/testsuite/tests/typing-unboxed/test.ml b/testsuite/tests/typing-unboxed/test.ml index 3ac3e27a6e..03edd5254a 100644 --- a/testsuite/tests/typing-unboxed/test.ml +++ b/testsuite/tests/typing-unboxed/test.ml @@ -413,10 +413,14 @@ type i = I of int Line 2, characters 0-34: 2 | external id : i -> i = "%identity";; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 61: This primitive declaration uses type i, which is unannotated and -unboxable. The representation of such types may change in future -versions. You should annotate the declaration of i with [@@boxed] -or [@@unboxed]. +Warning 61: This primitive declaration uses type i, whose representation +may be either boxed or unboxed. Without an annotation to indicate +which representation is intended, the boxed representation has been +selected by default. This default choice may change in future +versions of the compiler, breaking the primitive implementation. +You should explicitly annotate the declaration of i +with [@@boxed] or [@@unboxed], so that its external interface +remains stable in the future. external id : i -> i = "%identity" |}];; @@ -429,17 +433,25 @@ type j = J of int Line 3, characters 0-34: 3 | external id : i -> j = "%identity";; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 61: This primitive declaration uses type i, which is unannotated and -unboxable. The representation of such types may change in future -versions. You should annotate the declaration of i with [@@boxed] -or [@@unboxed]. +Warning 61: This primitive declaration uses type i, whose representation +may be either boxed or unboxed. Without an annotation to indicate +which representation is intended, the boxed representation has been +selected by default. This default choice may change in future +versions of the compiler, breaking the primitive implementation. +You should explicitly annotate the declaration of i +with [@@boxed] or [@@unboxed], so that its external interface +remains stable in the future. Line 3, characters 0-34: 3 | external id : i -> j = "%identity";; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 61: This primitive declaration uses type j, which is unannotated and -unboxable. The representation of such types may change in future -versions. You should annotate the declaration of j with [@@boxed] -or [@@unboxed]. +Warning 61: This primitive declaration uses type j, whose representation +may be either boxed or unboxed. Without an annotation to indicate +which representation is intended, the boxed representation has been +selected by default. This default choice may change in future +versions of the compiler, breaking the primitive implementation. +You should explicitly annotate the declaration of j +with [@@boxed] or [@@unboxed], so that its external interface +remains stable in the future. external id : i -> j = "%identity" |}];; diff --git a/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml index 66c6f38938..27b12920de 100644 --- a/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml +++ b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml @@ -343,6 +343,10 @@ let not_ambiguous__module_variable x b = match x with | _ -> 2 ;; [%%expect {| +Line 2, characters 12-13: +2 | | (module M:S),_,(1,_) + ^ +Warning 60: unused module M. val not_ambiguous__module_variable : (module S) * (module S) * (int * int) -> bool -> int = <fun> |}] diff --git a/testsuite/tests/typing-warnings/open_warnings.ml b/testsuite/tests/typing-warnings/open_warnings.ml index 7c5d7a83f9..48f7f94068 100644 --- a/testsuite/tests/typing-warnings/open_warnings.ml +++ b/testsuite/tests/typing-warnings/open_warnings.ml @@ -15,7 +15,7 @@ Line 3, characters 2-8: 3 | open M (* unused open *) ^^^^^^ Warning 33: unused open M. -module T1 : sig end +module T1 : sig end |}] @@ -47,7 +47,7 @@ Line 2, characters 12-13: 2 | type t0 = A (* unused type and constructor *) ^ Warning 37: unused constructor A. -module T3 : sig end +module T3 : sig end |}] module T4 : sig end = struct @@ -69,7 +69,7 @@ Line 4, characters 2-8: 4 | open M (* unused open; no shadowing (A below refers to the one in t0) *) ^^^^^^ Warning 33: unused open M. -module T4 : sig end +module T4 : sig end |}] module T5 : sig end = struct @@ -91,7 +91,7 @@ Line 2, characters 12-13: 2 | type t0 = A (* unused type and constructor *) ^ Warning 37: unused constructor A. -module T5 : sig end +module T5 : sig end |}] @@ -108,7 +108,7 @@ Line 3, characters 2-9: 3 | open! M (* unused open *) ^^^^^^^ Warning 66: unused open! M. -module T1_bis : sig end +module T1_bis : sig end |}] module T2_bis : sig type s end = struct @@ -135,7 +135,7 @@ Line 2, characters 12-13: 2 | type t0 = A (* unused type and constructor *) ^ Warning 37: unused constructor A. -module T3_bis : sig end +module T3_bis : sig end |}] module T4_bis : sig end = struct @@ -157,7 +157,7 @@ Line 4, characters 2-9: 4 | open! M (* unused open; no shadowing (A below refers to the one in t0) *) ^^^^^^^ Warning 66: unused open! M. -module T4_bis : sig end +module T4_bis : sig end |}] module T5_bis : sig end = struct @@ -175,5 +175,5 @@ Line 2, characters 12-13: 2 | type t0 = A (* unused type and constructor *) ^ Warning 37: unused constructor A. -module T5_bis : sig end +module T5_bis : sig end |}] diff --git a/testsuite/tests/typing-warnings/pr7115.ml b/testsuite/tests/typing-warnings/pr7115.ml index ed6f553549..f4f5c35bcf 100644 --- a/testsuite/tests/typing-warnings/pr7115.ml +++ b/testsuite/tests/typing-warnings/pr7115.ml @@ -17,7 +17,7 @@ Line 2, characters 10-11: 2 | let _f ~x (* x unused argument *) = function ^ Warning 27: unused variable x. -module X1 : sig end +module X1 : sig end |}] module X2 : sig end = struct @@ -30,7 +30,7 @@ Line 2, characters 6-7: 2 | let x = 42 (* unused value *) ^ Warning 32: unused value x. -module X2 : sig end +module X2 : sig end |}] module X3 : sig end = struct @@ -49,5 +49,5 @@ Line 3, characters 2-8: 3 | open O (* unused open *) ^^^^^^ Warning 33: unused open O. -module X3 : sig end +module X3 : sig end |}] diff --git a/testsuite/tests/typing-warnings/pr7553.ml b/testsuite/tests/typing-warnings/pr7553.ml index 1b3ac74d3d..d479c41907 100644 --- a/testsuite/tests/typing-warnings/pr7553.ml +++ b/testsuite/tests/typing-warnings/pr7553.ml @@ -24,7 +24,7 @@ Line 2, characters 2-8: 2 | open A ^^^^^^ Warning 33: unused open A. -module rec C : sig end +module rec C : sig end |}] module rec D : sig @@ -46,5 +46,5 @@ Line 4, characters 6-12: 4 | open A ^^^^^^ Warning 33: unused open A. -module rec D : sig module M : sig module X : sig end end end +module rec D : sig module M : sig module X : sig end end end |}] diff --git a/testsuite/tests/typing-warnings/unused_types.ml b/testsuite/tests/typing-warnings/unused_types.ml index e5d94ab1c0..a7385e76d3 100644 --- a/testsuite/tests/typing-warnings/unused_types.ml +++ b/testsuite/tests/typing-warnings/unused_types.ml @@ -13,7 +13,7 @@ Line 3, characters 2-19: 3 | type unused = int ^^^^^^^^^^^^^^^^^ Warning 34: unused type unused. -module Unused : sig end +module Unused : sig end |}] module Unused_nonrec : sig @@ -27,7 +27,7 @@ Line 4, characters 2-27: 4 | type nonrec unused = used ^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 34: unused type unused. -module Unused_nonrec : sig end +module Unused_nonrec : sig end |}] module Unused_rec : sig @@ -44,7 +44,7 @@ Line 3, characters 16-27: 3 | type unused = A of unused ^^^^^^^^^^^ Warning 37: unused constructor A. -module Unused_rec : sig end +module Unused_rec : sig end |}] module Used_constructor : sig @@ -178,7 +178,7 @@ Line 3, characters 2-26: 3 | exception Nobody_uses_me ^^^^^^^^^^^^^^^^^^^^^^^^ Warning 38: unused exception Nobody_uses_me -module Unused_exception : sig end +module Unused_exception : sig end |}] module Unused_extension_constructor : sig @@ -319,7 +319,7 @@ end = struct sig type t = private [> `Foo | `Bar] include S with type t := t end end;; [%%expect {| -module Pr7438 : sig end +module Pr7438 : sig end |}] module Unused_type_disable_warning : sig @@ -331,7 +331,7 @@ Line 3, characters 11-12: 3 | type t = A [@@warning "-34"] ^ Warning 37: unused constructor A. -module Unused_type_disable_warning : sig end +module Unused_type_disable_warning : sig end |}] module Unused_constructor_disable_warning : sig @@ -343,5 +343,5 @@ Line 3, characters 2-30: 3 | type t = A [@@warning "-37"] ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 34: unused type t. -module Unused_constructor_disable_warning : sig end +module Unused_constructor_disable_warning : sig end |}] diff --git a/testsuite/tests/warnings/w60.compilers.reference b/testsuite/tests/warnings/w60.compilers.reference new file mode 100644 index 0000000000..9eec5d1ec5 --- /dev/null +++ b/testsuite/tests/warnings/w60.compilers.reference @@ -0,0 +1,4 @@ +File "w60.ml", line 40, characters 13-14: +40 | let module M = struct end in + ^ +Warning 60: unused module M. diff --git a/testsuite/tests/warnings/w60.ml b/testsuite/tests/warnings/w60.ml index c7007afa73..08d3ecd3db 100644 --- a/testsuite/tests/warnings/w60.ml +++ b/testsuite/tests/warnings/w60.ml @@ -32,3 +32,10 @@ module M = struct end module O = M.N + +(***************) + +let () = + (* M is unused, but no warning was emitted before 4.10. *) + let module M = struct end in + () diff --git a/tools/Makefile b/tools/Makefile index 754c8897c6..81b14d29d7 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -267,9 +267,13 @@ else DEF_SYMBOL_PREFIX = '-Dsymbol_prefix=""' endif -objinfo_helper$(EXE): objinfo_helper.c $(ROOTDIR)/runtime/caml/s.h - $(CC) $(OC_CFLAGS) $(OC_CPPFLAGS) -I$(ROOTDIR)/runtime $(OUTPUTEXE)$@ \ - $(DEF_SYMBOL_PREFIX) $(LIBBFD_INCLUDE) $< $(LIBBFD_LINK) +objinfo_helper$(EXE): objinfo_helper.$(O) + $(CC) $(BFD_LDFLAGS) $(OC_CFLAGS) $(OUTPUTEXE)$@ $< $(BFD_LDLIBS) + +objinfo_helper.$(O): $(ROOTDIR)/runtime/caml/s.h + +objinfo_helper.$(O): \ + OC_CPPFLAGS += -I$(ROOTDIR)/runtime $(DEF_SYMBOL_PREFIX) $(BFD_CPPFLAGS) OBJINFO=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ diff --git a/tools/caml_tex.ml b/tools/caml_tex.ml index f34311c405..d003171d23 100644 --- a/tools/caml_tex.ml +++ b/tools/caml_tex.ml @@ -134,9 +134,20 @@ module Toplevel = struct (** Record locations in the main error and suberrors without printing them *) let printer_register_locs = - { Location.batch_mode_printer with - pp_main_loc = (fun _ _ _ loc -> register_loc loc); + let base = Location.batch_mode_printer in + { Location.pp_main_loc = (fun _ _ _ loc -> register_loc loc); pp_submsg_loc = (fun _ _ _ loc -> register_loc loc); + + (* The following fields are kept identical to [base], + listed explicitly so that future field additions result in an error + -- using (Location.batch_mode_printer with ...) would be the symmetric + problem to a fragile pattern-matching. *) + pp = base.pp; + pp_report_kind = base.pp_report_kind; + pp_main_txt = base.pp_main_txt; + pp_submsgs = base.pp_submsgs; + pp_submsg = base.pp_submsg; + pp_submsg_txt = base.pp_submsg_txt; } (** Capture warnings and keep them in a list *) diff --git a/tools/ci/inria/main b/tools/ci/inria/main index 10f79ccb11..ee72f56e39 100755 --- a/tools/ci/inria/main +++ b/tools/ci/inria/main @@ -134,7 +134,9 @@ case "${OCAML_ARCH}" in bsd) make=gmake ;; - macos) ;; + macos) + confoptions="$confoptions --with-bfd " + ;; linux) check_make_alldepend=true ;; diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index b1226b92ea..6643459c49 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -36,6 +36,10 @@ type directive_info = { doc: string; } +(* Phase buffer that stores the last toplevel phrase (see + [Location.input_phrase_buffer]). *) +let phrase_buffer = Buffer.create 1024 + (* The table of toplevel value bindings and its accessors *) let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty @@ -447,6 +451,8 @@ let read_input_default prompt buffer len = if !i >= len then raise Exit; let c = input_char stdin in Bytes.set buffer !i c; + (* Also populate the phrase buffer as new characters are added. *) + Buffer.add_char phrase_buffer c; incr i; if c = '\n' then raise Exit; done; @@ -544,6 +550,7 @@ let loop ppf = Location.init lb "//toplevel//"; Location.input_name := "//toplevel//"; Location.input_lexbuf := Some lb; + Location.input_phrase_buffer := Some phrase_buffer; Sys.catch_break true; run_hooks After_setup; load_ocamlinit ppf; @@ -551,6 +558,8 @@ let loop ppf = let snap = Btype.snapshot () in try Lexing.flush_input lb; + (* Reset the phrase buffer when we flush the lexing buffer. *) + Buffer.reset phrase_buffer; Location.reset(); Warnings.reset_fatal (); first_line := true; diff --git a/typing/env.ml b/typing/env.ml index 2736c5e6dc..5463d2a783 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1844,8 +1844,9 @@ let enter_extension ~scope name ext env = let env = store_extension ~check:true id addr ext env in (id, env) -let enter_module_declaration ?arg id presence md env = - add_module_declaration ?arg ~check:true id presence md env +let enter_module_declaration ~scope ?arg s presence md env = + let id = Ident.create_scoped ~scope s in + (id, add_module_declaration ?arg ~check:true id presence md env) let enter_modtype ~scope name mtd env = let id = Ident.create_scoped ~scope name in @@ -1864,9 +1865,7 @@ let enter_cltype ~scope name desc env = (id, env) let enter_module ~scope ?arg s presence mty env = - let id = Ident.create_scoped ~scope s in - let env = enter_module_declaration ?arg id presence (md mty) env in - (id, env) + enter_module_declaration ~scope ?arg s presence (md mty) env (* Insertion of all components of a signature *) diff --git a/typing/env.mli b/typing/env.mli index 5aa0c7080a..214ed233ea 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -320,7 +320,8 @@ val enter_module: scope:int -> ?arg:bool -> string -> module_presence -> module_type -> t -> Ident.t * t val enter_module_declaration: - ?arg:bool -> Ident.t -> module_presence -> module_declaration -> t -> t + scope:int -> ?arg:bool -> string -> module_presence -> + module_declaration -> t -> Ident.t * t val enter_modtype: scope:int -> string -> modtype_declaration -> t -> Ident.t * t val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t diff --git a/typing/oprint.ml b/typing/oprint.ml index 218416cda2..d7413654db 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -459,39 +459,85 @@ let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item") let out_signature = ref (fun _ -> failwith "Oprint.out_signature") let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension") -let rec print_out_functor funct ppf = - function - Omty_functor (_, None, mty_res) -> - if funct then fprintf ppf "() %a" (print_out_functor true) mty_res - else fprintf ppf "functor@ () %a" (print_out_functor true) mty_res - | Omty_functor (name, Some mty_arg, mty_res) -> begin - match name, funct with - | "_", true -> - fprintf ppf "->@ %a ->@ %a" - print_out_module_type mty_arg (print_out_functor false) mty_res - | "_", false -> - fprintf ppf "%a ->@ %a" - print_out_module_type mty_arg (print_out_functor false) mty_res - | name, true -> - fprintf ppf "(%s : %a) %a" name - print_out_module_type mty_arg (print_out_functor true) mty_res - | name, false -> - fprintf ppf "functor@ (%s : %a) %a" name - print_out_module_type mty_arg (print_out_functor true) mty_res - end - | m -> - if funct then fprintf ppf "->@ %a" print_out_module_type m - else print_out_module_type ppf m +(* For anonymous functor arguments, the logic to choose between + the long-form + functor (_ : S) -> ... + and the short-form + S -> ... + is as follows: if we are already printing long-form functor arguments, + we use the long form unless all remaining functor arguments can use + the short form. (Otherwise use the short form.) + + For example, + functor (X : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end + will get printed as + functor (X : S1) (_ : S2) (Y : S3) -> S4 -> S5 -> sig end + + but + functor (_ : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end + gets printed as + S1 -> S2 -> functor (Y : S3) -> S4 -> S5 -> sig end +*) + +(* take a module type that may be a functor type, + and return the longest prefix list of arguments + that should be printed in long form. *) +let collect_functor_arguments mty = + let rec collect_args acc = function + | Omty_functor (name, mty_arg, mty_res) -> + collect_args ((name, mty_arg) :: acc) mty_res + | non_functor -> (acc, non_functor) + in + let rec uncollect_anonymous_suffix acc rest = match acc with + | ("_", mty_arg) :: acc -> + uncollect_anonymous_suffix acc (Omty_functor ("_", mty_arg, rest)) + | (_, _) :: _ | [] -> + (acc, rest) + in + let (acc, non_functor) = collect_args [] mty in + let (acc, rest) = uncollect_anonymous_suffix acc non_functor in + (List.rev acc, rest) -and print_out_module_type ppf = +let rec print_out_module_type ppf mty = + print_out_functor ppf mty +and print_out_functor ppf = function + | Omty_functor _ as t -> + let rec print_functor ppf = function + | Omty_functor ("_", Some mty_arg, mty_res) -> + fprintf ppf "%a ->@ %a" + print_simple_out_module_type mty_arg + print_functor mty_res + | Omty_functor _ as non_anonymous_functor -> + let (args, rest) = collect_functor_arguments non_anonymous_functor in + let print_arg ppf = function + | (_, None) -> + fprintf ppf "()" + | (name, Some mty) -> + fprintf ppf "(%s : %a)" + name + print_out_module_type mty + in + fprintf ppf "@[<2>functor@ %a@]@ ->@ %a" + (pp_print_list ~pp_sep:pp_print_space print_arg) args + print_functor rest + | non_functor -> + print_simple_out_module_type ppf non_functor + in + fprintf ppf "@[<2>%a@]" print_functor t + | t -> print_simple_out_module_type ppf t +and print_simple_out_module_type ppf = function Omty_abstract -> () - | Omty_functor _ as t -> - fprintf ppf "@[<2>%a@]" (print_out_functor false) t | Omty_ident id -> fprintf ppf "%a" print_ident id | Omty_signature sg -> - fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" !out_signature sg + begin match sg with + | [] -> fprintf ppf "sig end" + | sg -> + fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" print_out_signature sg + end | Omty_alias id -> fprintf ppf "(module %a)" print_ident id + | Omty_functor _ as non_simple -> + fprintf ppf "(%a)" print_out_module_type non_simple and print_out_signature ppf = function [] -> () diff --git a/typing/typecore.ml b/typing/typecore.ml index 88d25bc06d..584c0a0033 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -34,7 +34,6 @@ type type_forcing_context = | Assert_condition | Sequence_left_hand_side | When_guard - | Application of expression type type_expected = { ty: type_expr; @@ -1485,7 +1484,7 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode if not exception_allowed then raise (Error (loc, !env, Exception_pattern_disallowed)) else begin - let p_exn = type_pat p Predef.type_exn k in + type_pat p Predef.type_exn (fun p_exn -> rp k { pat_desc = Tpat_exception p_exn; pat_loc = sp.ppat_loc; @@ -1493,7 +1492,7 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode pat_type = expected_ty; pat_env = !env; pat_attributes = sp.ppat_attributes; - } + }) end | Ppat_effect _ -> raise (Error (loc, !env, Effect_pattern_below_toplevel)) @@ -2029,7 +2028,7 @@ let create_package_type loc env (p, l) = let open Ast_helper in List.fold_left (fun sexp (name, loc) -> - Exp.letmodule ~loc:sexp.pexp_loc + Exp.letmodule ~loc:{ sexp.pexp_loc with loc_ghost = true } ~attrs:[Attr.mk (mknoloc "#modulepat") (PStr [])] name (Mod.unpack ~loc @@ -3045,8 +3044,11 @@ and type_expect_ | _ -> Mp_present in let scope = create_scope () in + let md = + { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc } + in let (id, new_env) = - Env.enter_module ~scope name.txt pres modl.mod_type env + Env.enter_module_declaration ~scope name.txt pres md env in Typetexp.widen context; (* ideally, we should catch Expr_type_clash errors @@ -3864,7 +3866,6 @@ and type_application env funct sargs = tvar || List.mem l ls in let ignored = ref [] in - let explanation = Application funct in let rec type_unknown_args (args : (Asttypes.arg_label * (unit -> Typedtree.expression) option) list) @@ -3911,7 +3912,7 @@ and type_application env funct sargs = in let optional = is_optional l1 in let arg1 () = - let arg1 = type_expect env sarg1 (mk_expected ~explanation ty1) in + let arg1 = type_expect env sarg1 (mk_expected ty1) in if optional then unify_exp env arg1 (type_option(newvar())); arg1 @@ -3963,7 +3964,7 @@ and type_application env funct sargs = Apply_wrong_label(l', ty_fun'))) else ([], more_sargs, - Some (fun () -> type_argument ~explanation env sarg0 ty ty0)) + Some (fun () -> type_argument env sarg0 ty ty0)) | _ -> assert false end else try @@ -3987,14 +3988,13 @@ and type_application env funct sargs = (Warnings.Nonoptional_label (Printtyp.string_of_label l)); sargs, more_sargs, if not optional || is_optional l' then - Some (fun () -> type_argument ~explanation env sarg0 ty ty0) + Some (fun () -> type_argument env sarg0 ty ty0) else begin may_warn sarg0.pexp_loc (Warnings.Not_principal "using an optional argument here"); - Some (fun () -> - option_some env (type_argument ~explanation env sarg0 - (extract_option_type env ty) - (extract_option_type env ty0))) + Some (fun () -> option_some env (type_argument env sarg0 + (extract_option_type env ty) + (extract_option_type env ty0))) end with Not_found -> sargs, more_sargs, @@ -4807,55 +4807,6 @@ let report_pattern_type_clash_hints pat diff = | Some (Tpat_constant const) -> report_literal_type_constraint const diff | _ -> [] -(* Hint when using int operators (eg. `+`) - on other kind of integer and floats *) -let report_numeric_operator_clash_hints ~loc actual_type operator = - let stdlib = Path.Pident (Ident.create_persistent "Stdlib") in - let stdlib_qualified mod_ val_ = Path.Pdot (Path.Pdot (stdlib, mod_), val_) in - let is_op op = Path.same operator (Path.Pdot (stdlib, op)) in - let expecting_qualified name = - let qualified = stdlib_qualified name in - if is_op "+" then Some (qualified "add") - else if is_op "-" then Some (qualified "sub") - else if is_op "*" then Some (qualified "mul") - else if is_op "/" then Some (qualified "div") - else if is_op "mod" then Some (qualified "rem") - else None - in - let expecting_float () = - let qualified id = Path.Pdot (stdlib, id) in - if is_op "+" then Some (qualified "+.") - else if is_op "-" then Some (qualified "-.") - else if is_op "*" then Some (qualified "*.") - else if is_op "/" then Some (qualified "/.") - else if is_op "mod" then Some (stdlib_qualified "Float" "rem") - else None - in - let expecting_op = - if Path.same actual_type Predef.path_int32 then - expecting_qualified "Int32" - else if Path.same actual_type Predef.path_int64 then - expecting_qualified "Int64" - else if Path.same actual_type Predef.path_nativeint then - expecting_qualified "Nativeint" - else if Path.same actual_type Predef.path_float then - expecting_float () - else None - in - match expecting_op with - | Some op -> - [ Location.msg ~loc "@[Hint:@ Did you mean to use `%a'?@]" - Printtyp.path op ] - | None -> [] - -(* Returns a list of `Location.msg` *) -let report_application_clash_hints diff expl = - match expl, diff with - | Some (Application { exp_desc = Texp_ident (p, _, _); exp_loc = loc; _ }), - Some Unification_trace.{ got = { t = { desc = Tconstr (typ, [], _) } } } -> - report_numeric_operator_clash_hints ~loc typ p - | _ -> [] - let report_type_expected_explanation expl ppf = let because expl_str = fprintf ppf "@ because it is in %s" expl_str in match expl with @@ -4879,7 +4830,6 @@ let report_type_expected_explanation expl ppf = because "the left-hand side of a sequence" | When_guard -> because "a when-guard" - | Application _ -> () let report_type_expected_explanation_opt expl ppf = match expl with @@ -4937,11 +4887,7 @@ let report_error ~loc env = function ) () | Expr_type_clash (trace, explanation, exp) -> let diff = type_clash_of_trace trace in - let sub = List.concat [ - report_application_clash_hints diff explanation; - report_expr_type_clash_hints exp diff; - ] - in + let sub = report_expr_type_clash_hints exp diff in Location.error_of_printer ~loc ~sub (fun ppf () -> Printtyp.report_unification_error ppf env trace ~type_expected_explanation: diff --git a/typing/typecore.mli b/typing/typecore.mli index 19ba97cd36..83f254fbf9 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -37,7 +37,6 @@ type type_forcing_context = | Assert_condition | Sequence_left_hand_side | When_guard - | Application of Typedtree.expression (* The combination of a type and a "type forcing context". The intent is that it describes a type that is "expected" (required) by the context. If unifying diff --git a/typing/typemod.ml b/typing/typemod.ml index 8cbe5a387e..4b668b3f75 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -736,18 +736,18 @@ and approx_sig env ssg = | Psig_typesubst _ -> approx_sig env srem | Psig_module pmd -> let scope = Ctype.create_scope () in - let id = Ident.create_scoped ~scope pmd.pmd_name.txt in let md = approx_module_declaration env pmd in let pres = match md.Types.md_type with | Mty_alias _ -> Mp_absent | _ -> Mp_present in - let newenv = Env.enter_module_declaration id pres md env in + let id, newenv = + Env.enter_module_declaration ~scope pmd.pmd_name.txt pres md env + in Sig_module(id, pres, md, Trec_not, Exported) :: approx_sig newenv srem | Psig_modsubst pms -> let scope = Ctype.create_scope () in - let id = Ident.create_scoped ~scope pms.pms_name.txt in let _, md = Env.lookup_module ~use:false ~loc:pms.pms_manifest.loc pms.pms_manifest.txt env @@ -757,7 +757,9 @@ and approx_sig env ssg = | Mty_alias _ -> Mp_absent | _ -> Mp_present in - let newenv = Env.enter_module_declaration id pres md env in + let _, newenv = + Env.enter_module_declaration ~scope pms.pms_name.txt pres md env + in approx_sig newenv srem | Psig_recmodule sdecls -> let scope = Ctype.create_scope () in @@ -1246,7 +1248,6 @@ and transl_signature env sg = final_env | Psig_module pmd -> let scope = Ctype.create_scope () in - let id = Ident.create_scoped ~scope pmd.pmd_name.txt in let tmty = Builtin_attributes.warning_scope pmd.pmd_attributes (fun () -> transl_modtype env pmd.pmd_type) @@ -1262,8 +1263,10 @@ and transl_signature env sg = md_loc=pmd.pmd_loc; } in + let id, newenv = + Env.enter_module_declaration ~scope pmd.pmd_name.txt pres md env + in Signature_names.check_module names pmd.pmd_name.loc id; - let newenv = Env.enter_module_declaration id pres md env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; md_presence=pres; md_type=tmty; @@ -1274,7 +1277,6 @@ and transl_signature env sg = final_env | Psig_modsubst pms -> let scope = Ctype.create_scope () in - let id = Ident.create_scoped ~scope pms.pms_name.txt in let path, md = Env.lookup_module ~loc:pms.pms_manifest.loc pms.pms_manifest.txt env @@ -1293,11 +1295,13 @@ and transl_signature env sg = | Mty_alias _ -> Mp_absent | _ -> Mp_present in + let id, newenv = + Env.enter_module_declaration ~scope pms.pms_name.txt pres md env + in let info = `Substituted_away (Subst.add_module id path Subst.identity) in Signature_names.check_module ~info names pms.pms_name.loc id; - let newenv = Env.enter_module_declaration id pres md env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; ms_manifest=path; ms_txt=pms.pms_manifest; @@ -2085,11 +2089,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; pmb_loc; } -> + let outer_scope = Ctype.get_current_level () in let scope = Ctype.create_scope () in - let id = - Ident.create_scoped ~scope name.txt (* create early for PR#6752 *) - in - Signature_names.check_module names pmb_loc id; let modl = Builtin_attributes.warning_scope attrs (fun () -> @@ -2109,8 +2110,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = } in (*prerr_endline (Ident.unique_toplevel_name id);*) - Mtype.lower_nongen (scope - 1) md.md_type; - let newenv = Env.enter_module_declaration id pres md env in + Mtype.lower_nongen outer_scope md.md_type; + let id, newenv = + Env.enter_module_declaration ~scope name.txt pres md env + in + Signature_names.check_module names pmb_loc id; Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; }, [Sig_module(id, pres, diff --git a/utils/dune b/utils/dune index e372dcf2a9..39c76af333 100644 --- a/utils/dune +++ b/utils/dune @@ -19,3 +19,27 @@ ../Makefile.config config.mlp) (action (system "make -f %{mk} %{targets}"))) + +(rule + (targets domainstate.ml) + (mode fallback) + (deps (:conf ../Makefile.config) + (:c domainstate.ml.c) + (:tbl ../runtime/caml/domain_state.tbl)) + (action + (with-stdout-to %{targets} + (bash + "`grep '^CPP=' %{conf} | cut -d'=' -f2` -I ../runtime/caml %{c} %{tbl}" + )))) + +(rule + (targets domainstate.mli) + (mode fallback) + (deps (:conf ../Makefile.config) + (:c domainstate.mli.c) + (:tbl ../runtime/caml/domain_state.tbl)) + (action + (with-stdout-to %{targets} + (bash + "`grep '^CPP=' %{conf} | cut -d'=' -f2` -I ../runtime/caml %{c} %{tbl}" + )))) diff --git a/utils/warnings.ml b/utils/warnings.ml index c5044a3ed3..9b1959835e 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -604,10 +604,14 @@ let message = function | Unused_module s -> "unused module " ^ s ^ "." | Unboxable_type_in_prim_decl t -> Printf.sprintf - "This primitive declaration uses type %s, which is unannotated and\n\ - unboxable. The representation of such types may change in future\n\ - versions. You should annotate the declaration of %s with [@@boxed]\n\ - or [@@unboxed]." t t + "This primitive declaration uses type %s, whose representation\n\ + may be either boxed or unboxed. Without an annotation to indicate\n\ + which representation is intended, the boxed representation has been\n\ + selected by default. This default choice may change in future\n\ + versions of the compiler, breaking the primitive implementation.\n\ + You should explicitly annotate the declaration of %s\n\ + with [@@boxed] or [@@unboxed], so that its external interface\n\ + remains stable in the future." t t | Constraint_on_gadt -> "Type constraints do not apply to GADT cases of variant types." | Erroneous_printed_signature s -> diff --git a/yacc/Makefile b/yacc/Makefile index d4a0c8ccc3..7d6c0e1943 100644 --- a/yacc/Makefile +++ b/yacc/Makefile @@ -18,6 +18,7 @@ ROOTDIR = .. include $(ROOTDIR)/Makefile.config +include $(ROOTDIR)/Makefile.common OC_CPPFLAGS += -I$(ROOTDIR)/runtime @@ -58,9 +59,3 @@ skeleton.$(O): defs.h symtab.$(O): defs.h verbose.$(O): defs.h warshall.$(O): defs.h - -# The following rule is similar to make's default one, except that it -# also works for .obj files. - -%.$(O): %.c - $(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) $(OUTPUTOBJ)$@ $< diff --git a/yacc/reader.c b/yacc/reader.c index ea1460b7b8..e81b65fa1d 100644 --- a/yacc/reader.c +++ b/yacc/reader.c @@ -234,6 +234,14 @@ int process_apostrophe(FILE *const f) && cptr[4] == '\'') { fwrite(cptr, 1, 5, f); cptr += 5; + } else if (cptr[0] == '\\' + && cptr[1] == 'o' + && cptr[2] >= '0' && cptr[2] <= '3' + && cptr[3] >= '0' && cptr[3] <= '7' + && cptr[4] >= '0' && cptr[4] <= '7' + && cptr[5] == '\'') { + fwrite(cptr, 1, 6, f); + cptr += 6; } else if (cptr[0] == '\\' && cptr[2] == '\'') { fwrite(cptr, 1, 3, f); cptr += 3; @@ -362,6 +370,9 @@ static void process_comment(FILE *const f) { process_open_curly_bracket(f); continue; default: + if (In_bitmap(caml_ident_start, c)) { + while (In_bitmap(caml_ident_body, *cptr)) cptr++; + } continue; } } @@ -600,6 +611,12 @@ loop: goto loop; default: putc(c, f); + if (In_bitmap(caml_ident_start, c)) { + while (In_bitmap(caml_ident_body, *cptr)) { + putc(*cptr, f); + cptr++; + } + } need_newline = 1; goto loop; } |