Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'upstream/trunk' into trunk

master
John Whitington 2020-09-11 14:14:38 +01:00
parent 69c59b172d 75ec40bdd6
commit c3f6cd7ff7
214 changed files with 10089 additions and 8138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.depend
View File

@ -2877,6 +2877,7 @@ asmcomp/spacetime_profiling.cmo : \
lambda/lambda.cmi \
lambda/debuginfo.cmi \
utils/config.cmi \
asmcomp/cmm_helpers.cmi \
asmcomp/cmm.cmi \
middle_end/backend_var.cmi \
parsing/asttypes.cmi \
@ -2890,6 +2891,7 @@ asmcomp/spacetime_profiling.cmx : \
lambda/lambda.cmx \
lambda/debuginfo.cmx \
utils/config.cmx \
asmcomp/cmm_helpers.cmx \
asmcomp/cmm.cmx \
middle_end/backend_var.cmx \
parsing/asttypes.cmi \

10
.gitattributes vendored
View File

@ -29,9 +29,9 @@
/boot/menhir/parser.ml* -diff
# configure is declared as binary so that it doesn't get included in diffs.
# This also means it will have the correct Unix line-endings, even on Windows.
/configure binary
# configure is a shell-script; the linguist-generated attribute suppresses
# changes being displayed by default in pull requests.
/configure text eol=lf -diff linguist-generated
# 'union' merge driver just unions textual content in case of conflict
# http://krlmlr.github.io/using-gitattributes-to-avoid-merge-conflicts/
@ -119,6 +119,10 @@ testsuite/tests/**/*.reference typo.prune
# Expect tests with overly long lines of expected output
testsuite/tests/parsing/docstrings.ml typo.very-long-line
# The normalisation tests have very specific line endings which mustn't be
# corrupted by git.
testsuite/tests/tool-ocamltest/norm*.reference binary
tools/magic typo.missing-header
tools/eventlog_metadata.in typo.missing-header

2
.gitignore vendored
View File

@ -118,6 +118,7 @@ _build
/ocamltest/ocamltest
/ocamltest/ocamltest.opt
/ocamltest/ocamltest_config.ml
/ocamltest/ocamltest_unix.ml
/ocamltest/tsl_lexer.ml
/ocamltest/tsl_parser.ml
/ocamltest/tsl_parser.mli
@ -163,6 +164,7 @@ _build
/otherlibs/win32unix/time.c
/otherlibs/win32unix/unlink.c
/otherlibs/win32unix/fsync.c
/otherlibs/win32unix/mkdir.c
/parsing/parser.ml
/parsing/parser.mli

465
Changes
View File

@ -16,6 +16,12 @@ Working version
type !'a t = 'a list
(Jacques Garrigue, review by Jeremy Yallop and Leo White)
### Supported platforms:
- #9699: add support for iOS and macOS on ARM 64 bits
(GitHub user @EduardoRFS, review by Xavier Leroy, Nicolás Ojeda Bär
and Anil Madhavapeddy, additional testing by Michael Schmidt)
### Runtime system:
- #1795, #9543: modernize signal handling on Linux i386, PowerPC, and s390x,
@ -48,6 +54,9 @@ Working version
(Nicolás Ojeda Bär, review by Stephen Dolan, Gabriel Scherer, Mark Shinwell,
and Xavier Leroy)
- #8807, #9503: Use different symbols for do_local_roots on bytecode and native
(Stephen Dolan, review by David Allsopp and Xavier Leroy)
- #9619: Change representation of function closures so that code pointers
can be easily distinguished from environment variables
(Xavier Leroy, review by Mark Shinwell and Damien Doligez)
@ -90,6 +99,25 @@ Working version
compaction algorithm and remove its dependence on the page table
(Damien Doligez, review by Jacques-Henri Jourdan and Xavier Leroy)
- #9742: Ephemerons are now compatible with infix pointers occurring
when using mutually recursive functions.
(Jacques-Henri Jourdan, review François Bobot)
* #1128, #7503, #9036, #9722: EINTR-based signal handling.
When a signal arrives, avoid running its OCaml handler in the middle
of a blocking section. Instead, allow control to return quickly to
a polling point where the signal handler can safely run, ensuring that
I/O locks are not held while it runs. A polling point was removed from
caml_leave_blocking_section, and one added to caml_raise.
(Stephen Dolan, review by Goswin von Brederlow, Xavier Leroy, Damien
Doligez, Anil Madhavapeddy, Guillaume Munch-Maccagnoni and Jacques-
Henri Jourdan)
- #9888, #9890: Fixes a bug in the `riscv` backend where register t0 was not
saved/restored when performing a GC. This could potentially lead to a
segfault.
(Nicolás Ojeda Bär, report by Xavier Leroy, review by Xavier Leroy)
### Code generation and optimizations:
- #9551: ocamlc no longer loads DLLs at link time to check that
@ -108,11 +136,19 @@ Working version
so that the ARM64 iOS/macOS calling conventions can be honored.
(Xavier Leroy, review by Mark Shinwell and Github user @EduardoRFS)
- #9838: Ensure that Cmm immediates are generated as Cconst_int where
possible, improving instruction selection.
(Stephen Dolan, review by Leo White and Xavier Leroy)
### Standard library:
- #9781: add injectivity annotations to parameterized abstract types
(Jeremy Yallop, review by Nicolás Ojeda Bär)
* #9765: add init functions to Bigarray.
(Jeremy Yallop, review by Gabriel Scherer, Nicolás Ojeda Bär, and
Xavier Leroy)
* #9554: add primitive __FUNCTION__ that returns the name of the current method
or function, including any enclosing module or class.
(Nicolás Ojeda Bär, Stephen Dolan, review by Stephen Dolan)
@ -131,6 +167,14 @@ Working version
- #9571: Make at_exit and Printexc.register_printer thread-safe.
(Guillaume Munch-Maccagnoni, review by Gabriel Scherer and Xavier Leroy)
- #9066: a new Either module with
type 'a Either.t = Left of 'a | Right of 'b
(Gabriel Scherer, review by Daniel Bünzli, Thomas Refis, Jeremy Yallop)
- #9066: List.partition_map :
('a -> ('b, 'c) Either.t) -> 'a list -> 'b list * 'c list
(Gabriel Scherer, review by Jeremy Yallop)
- #9587: Arg: new Rest_all spec to get all rest arguments in a list
(this is similar to Rest, but makes it possible to detect when there
are no arguments (an empty list) after the rest marker)
@ -148,12 +192,21 @@ Working version
- #9663: Extend Printexc API for raw backtrace entries.
(Stephen Dolan, review by Nicolás Ojeda Bär and Gabriel Scherer)
* #9668: List.equal, List.compare
(This could break code using "open List" by shadowing
Stdlib.{equal,compare}.)
(Gabriel Scherer, review by Nicolás Ojeda Bär, Daniel Bünzli and Alain Frisch)
- #9763: Add function Hashtbl.rebuild to convert from old hash table
formats (that may have been saved to persistent storage) to the
current hash table format. Remove leftover support for the hash
table format and generic hash function that were in use before OCaml 4.00.
(Xavier Leroy, review by Nicolás Ojeda Bär)
- #9797: Add Sys.mkdir and Sys.rmdir.
(David Allsopp, review by Nicolás Ojeda Bär, Sébastien Hinderer and
Xavier Leroy)
### Other libraries:
* #9206, #9419: update documentation of the threads library;
@ -177,6 +230,16 @@ Working version
error handling when Unix.symlink is unavailable)
(David Allsopp, review by Xavier Leroy)
- #9338, #9790: Dynlink: make sure *_units () functions report accurate
information before the first load.
(Daniel Bünzli, review by Xavier Leroy and Nicolás Ojeda Bär)
- #9802: Ensure signals are handled before Unix.kill returns
(Stephen Dolan, review by Jacques-Henri Jourdan)
- #9869: Add Unix.SO_REUSEPORT
(Yishuai Li, review by Xavier Leroy)
### Tools:
- #9551: ocamlobjinfo is now able to display information on .cmxs shared
@ -189,6 +252,10 @@ Working version
(Xavier Leroy, report by Jacques Garrigue and Virgile Prevosto,
review by David Allsopp and Jacques-Henri Jourdan)
* #9299, #9795: ocamldep: do not process files during cli parsing. Fixes
various broken cli behaviours.
(Daniel Bünzli, review by Nicolás Ojeda Bär)
### Manual and documentation:
- #9468: HACKING.adoc: using dune to get merlin's support
@ -235,12 +302,19 @@ Working version
(Nicolás Ojeda Bär, review by Gabriel Scherer, Florian Angeletti and Leo
White)
- #9751: Add warning 68. Pattern-matching depending on mutable state
prevents the remaining arguments from being uncurried.
(Hugo Heuzard, review by Leo White)
### Internal/compiler-libs changes:
- #9216: add Lambda.duplicate which refreshes bound identifiers
(Gabriel Scherer, review by Pierre Chambart and Vincent Laviron)
- #9493, #9520, #9563, #9599, #9608, #9647: refactor
- #9376: Remove spurious Ptop_defs from #use
(Leo White, review by Damien Doligez)
- #9464, #9493, #9520, #9563, #9599, #9608, #9647: refactor
the pattern-matching compiler
(Thomas Refis and Gabriel Scherer, review by Florian Angeletti)
@ -276,6 +350,25 @@ Working version
attributes are present.
(Matthew Ryan, review by Nicolás Ojeda Bär)
- #9797, #9849: Eliminate the routine use of external commands in ocamltest.
ocamltest no longer calls the mkdir, rm and ln external commands (at present,
the only external command ocamltest uses is diff).
(David Allsopp, review by Nicolás Ojeda Bär, Sébastien Hinderer and
Xavier Leroy)
- #9801: Don't ignore EOL-at-EOF differences in ocamltest.
(David Allsopp, review by Damien Doligez, much input and thought from
Daniel Bünzli, Damien Doligez, Sébastien Hinderer, and Xavier Leroy)
- #9889: more caching when printing types with -short-path.
(Florian Angeletti, review by Gabriel Scherer)
- #9591: fix pprint of polyvariants that start with a core_type, closed,
not low (Chet Murthy, review by Florian Angeletti)
- #9590: fix pprint of extension constructors (and exceptions) that rebind
(Chet Murthy, review by octachron@)
### Build system:
- #7121, #9558: Always the autoconf-discovered ld in PACKLD. For
@ -292,6 +385,12 @@ Working version
to avoid C dependency recomputation.
(Gabriel Scherer, review by David Allsopp)
- #9804: Build C stubs of libraries in otherlibs/ with debug info.
(Stephen Dolan, review by Sébastien Hinderer and David Allsopp)
- #9824, #9837: Honour the CFLAGS and CPPFLAGS variables.
(Sébastien Hinderer, review by David Allsopp)
### Bug fixes:
- #7902, #9556: Type-checker infers recursive type, even though -rectypes is
@ -301,6 +400,13 @@ Working version
- #8747, #9709: incorrect principality warning on functional updates of records
(Jacques Garrigue, report and review by Thomas Refis)
- #9421, #9427: fix printing of (::) in ocamldoc
(Florian Angeletti, report by Yawar Amin, review by Damien Doligez)
- #9440: for a type extension constructor with parameterised arguments,
REPL displayed <poly> for each as opposed to the concrete values used.
(Christian Quinn, review by Gabriel Scherer)
- #9469: Better backtraces for lazy values
(Leo White, review by Nicolás Ojeda Bär)
@ -322,51 +428,72 @@ Working version
(Xavier Leroy, Sadiq Jaffer, Gabriel Scherer,
review by Xavier Leroy and Jacques-Henri Jourdan)
- #9714, #9724: Use the C++ alignas keyword when compiling in C++.
Fixes a bug with MSVC C++ 2015/2017. Add a terminator to the
`caml_domain_state` structure to better ensure that members are
correctly spaced.
(Antonin Décimo, review by David Allsopp and Xavier Leroy)
- #9759, #9767: Spurious GADT ambiguity without -principal
(Jacques Garrigue, report by Thomas Refis,
review by Thomas Refis and Gabriel Scherer)
OCaml 4.11
----------
- #9825, #9830: the C global variable caml_fl_merge and the C function
caml_spacetime_my_profinfo (bytecode version) were declared and
defined with different types. This is undefined behavior and
cancause link-time errors with link-time optimization (LTO).
(Xavier Leroy, report by Richard Jones, review by Nicolás Ojeda Bär)
- #9753: fix build for Android
(Github user @EduardoRFS, review by Xavier Leroy)
- #9848, #9855: Fix double free of bytecode in toplevel
(Stephen Dolan, report by Sampsa Kiiskinen, review by Gabriel Scherer)
- #9860: wrong range constraint for subtract immediate on zSystems / s390x
(Xavier Leroy, review by Stephen Dolan)
- #9868, #9872, #9892: bugs in {in,out}_channel_length and seek_in
for files opened in text mode under Windows
(Xavier Leroy, report by Alain Frisch, review by Nicolás Ojeda Bär
and Alain Frisch)
OCaml 4.11.1
------------
### Bug fixes:
- #9856, #9857: Prevent polymorphic type annotations from generalizing
weak polymorphic variables.
(Leo White, review by Jacques Garrigue)
- #9859, #9862: Remove an erroneous assertion when inferred function types
appear in the right hand side of an explicit :> coercion
(Florian Angeletti, review by Thomas Refis)
OCaml 4.11.0 (19 August 2020)
---------------------------
(Changes that can break existing programs are marked with a "*")
### Language features
- #8820, #9166: quoted extensions: {%foo|...|} is lighter syntax for
[%foo {||}], and {%foo bar|...|bar} for [%foo {bar|...|bar}].
(Gabriel Radanne, Leo White, Gabriel Scherer and Pieter Goetschalckx,
request by Bikal Lem)
- #6673, #1132, #9617: Relax the handling of explicit polymorphic types
(Leo White, review by Jacques Garrigue and Gabriel Scherer)
- #9232: allow any class type paths in #-types,
For instance, "val f: #F(X).t -> unit" is now allowed.
(Florian Angeletti, review by Gabriel Scherer, suggestion by Leo White)
- #7364, #2188, #9592, #9609: improvement of the unboxability check for types
with a single constructor. Mutually-recursive type declarations can
now contain unboxed types. This is based on the paper
https://arxiv.org/abs/1811.02300
(Gabriel Scherer and Rodolphe Lepigre,
review by Jeremy Yallop, Damien Doligez and Frédéric Bour)
- #1154, #1706: spellchecker hints and type-directed disambiguation
for extensible sum type constructors
(Florian Angeletti, review by Alain Frisch, Gabriel Radanne, Gabriel Scherer
and Leo White)
### Runtime system:
- #9096: Print function names in backtraces.
Old output:
> Called from file "foo.ml", line 16, characters 42-53
New output:
> Called from Foo.bar in file "foo.ml", line 16, characters 42-53
(Stephen Dolan, review by Leo White and Mark Shinwell)
- #9119: Make [caml_stat_resize_noexc] compatible with the [realloc]
API when the old block is NULL.
(Jacques-Henri Jourdan, review by Xavier Leroy)
- #9082: The instrumented runtime now records logs in the CTF format.
A new API is available in the runtime to collect runtime statistics,
replacing the previous instrumented runtime macros.
Gc.eventlog_pause and Gc.eventlog_resume were added to allow user to control
instrumentation in a running program.
See the manual for more information on how to use this instrumentation mode.
(Enguerrand Decorne and Stephen Dolan, with help and review from
David Allsopp, Sébastien Hinderer, review by Anil Madhavapeddy,
Nicolás Ojeda Bär, Shakthi Kannan, KC Sivaramakrishnan, Gabriel Scherer,
Guillaume Munch-Maccagnoni, Damien Doligez, Leo White, Daniel Bünzli
and Xavier Leroy)
- #9230, #9362: Memprof support for native allocations.
(Jacques-Henri Jourdan and Stephen Dolan, review by Gabriel Scherer)
- #8920, #9238, #9239, #9254, #9458: New API for statistical memory profiling
in Memprof.Gc. The new version does no longer use ephemerons and allows
@ -376,12 +503,20 @@ OCaml 4.11
(Stephen Dolan and Jacques-Henri Jourdan, review by Damien Doligez
and Gabriel Scherer)
- #9353: Reimplement `output_value` and the `Marshal.to_*` functions
using a hash table to detect sharing, instead of temporary in-place
modifications. This is a prerequisite for Multicore OCaml.
(Xavier Leroy and Basile Clément, review by Gabriel Scherer and
Stephen Dolan)
- #9119: Make [caml_stat_resize_noexc] compatible with the [realloc]
API when the old block is NULL.
(Jacques-Henri Jourdan, review by Xavier Leroy)
- #9233: Restore the bytecode stack after an allocation.
(Stephen Dolan, review by Gabriel Scherer and Jacques-Henri Jourdan)
- #9230, #9362: Memprof support for native allocations.
(Jacques-Henri Jourdan and Stephen Dolan, review by Gabriel Scherer)
- #9249: restore definition of ARCH_ALIGN_INT64 in m.h if the architecture
requires 64-bit integers to be double-word aligned (autoconf regression)
(David Allsopp, review by Sébastien Hinderer)
@ -398,11 +533,6 @@ OCaml 4.11
- #9280: Micro-optimise allocations on amd64 to save a register.
(Stephen Dolan, review by Xavier Leroy)
- #9316, #9443, #9463, #9782: Use typing information from Clambda
for mutable Cmm variables.
(Stephen Dolan, review by Vincent Laviron, Guillaume Bury, Xavier Leroy,
and Gabriel Scherer; temporary bug report by Richard Jones)
- #9426: build the Mingw ports with higher levels of GCC optimization
(Xavier Leroy, review by Sébastien Hinderer)
@ -410,12 +540,6 @@ OCaml 4.11
The only release with the inclusion of stdio.h has been 4.10.0
(Christopher Zimmermann, review by Xavier Leroy and David Allsopp)
- #9353: Reimplement `output_value` and the `Marshal.to_*` functions
using a hash table to detect sharing, instead of temporary in-place
modifications. This is a prerequisite for Multicore OCaml.
(Xavier Leroy and Basile Clément, review by Gabriel Scherer and
Stephen Dolan)
- #9282: Make Cconst_symbol have typ_int to fix no-naked-pointers mode.
(Stephen Dolan, review by Mark Shinwell, Xavier Leroy and Vincent Laviron)
@ -428,40 +552,66 @@ OCaml 4.11
avoiding overflow.
(Jeremy Yallop, Stephen Dolan, review by Xavier Leroy)
- #9082: The instrumented runtime now records logs in the CTF format.
A new API is available in the runtime to collect runtime statistics,
replacing the previous instrumented runtime macros.
Gc.eventlog_pause and Gc.eventlog_resume were added to allow user to control
instrumentation in a running program.
(Enguerrand Decorne and Stephen Dolan, with help and review from
David Allsopp, Sébastien Hinderer, review by Anil Madhavapeddy,
Nicolás Ojeda Bär, Shakthi Kannan, KC Sivaramakrishnan, Gabriel Scherer,
Guillaume Munch-Maccagnoni, Damien Doligez, Leo White, Daniel Bünzli
and Xavier Leroy)
### Code generation and optimizations:
- #9441: Add RISC-V RV64G native-code backend.
(Nicolás Ojeda Bär, review by Xavier Leroy and Gabriel Scherer)
- #9316, #9443, #9463, #9782: Use typing information from Clambda
for mutable Cmm variables.
(Stephen Dolan, review by Vincent Laviron, Guillaume Bury, Xavier Leroy,
and Gabriel Scherer; temporary bug report by Richard Jones)
- #8637, #8805, #9247, #9296: Record debug info for each allocation.
(Stephen Dolan and Jacques-Henri Jourdan, review by Damien Doligez,
KC Sivaramakrishnan and Xavier Leroy)
- #9193: Make tuple matching optimisation apply to Lswitch and Lstringswitch.
(Stephen Dolan, review by Thomas Refis and Gabriel Scherer)
- #9392: Visit registers at most once in Coloring.iter_preferred.
(Stephen Dolan, review by Pierre Chambart and Xavier Leroy)
- #9441: Add RISC-V RV64G native-code backend.
(Nicolás Ojeda Bär, review by Xavier Leroy and Gabriel Scherer)
- #9549, #9557: Make -flarge-toc the default for PowerPC and introduce
-fsmall-toc to enable the previous behaviour.
(David Allsopp, report by Nathaniel Wesley Filardo, review by Xavier Leroy)
### Language features
- #8820, #9166: quoted extensions: {%foo|...|} is lighter syntax for
[%foo {||}], and {%foo bar|...|bar} for [%foo {bar|...|bar}].
(Gabriel Radanne, Leo White, Gabriel Scherer and Pieter Goetschalckx,
request by Bikal Lem)
- #7364, #2188, #9592, #9609: improvement of the unboxability check for types
with a single constructor. Mutually-recursive type declarations can
now contain unboxed types. This is based on the paper
https://arxiv.org/abs/1811.02300
(Gabriel Scherer and Rodolphe Lepigre,
review by Jeremy Yallop, Damien Doligez and Frédéric Bour)
- #1154, #1706: spellchecker hints and type-directed disambiguation
for extensible sum type constructors
(Florian Angeletti, review by Alain Frisch, Gabriel Radanne, Gabriel Scherer
and Leo White)
- #6673, #1132, #9617: Relax the handling of explicit polymorphic types.
This improves error messages in some polymorphic recursive definition,
and requires less polymorphic annotations in some cases of
mutually-recursive definitions involving polymorphic recursion.
(Leo White, review by Jacques Garrigue and Gabriel Scherer)
- #9232: allow any class type paths in #-types,
For instance, "val f: #F(X).t -> unit" is now allowed.
(Florian Angeletti, review by Gabriel Scherer, suggestion by Leo White)
### Standard library:
- #9077: Add Seq.cons and Seq.append
(Sébastien Briais, review by Yawar Amin and Florian Angeletti)
- #9248: Add Printexc.default_uncaught_exception_handler
(Raphael Sousa Santos, review by Daniel Bünzli)
- #9235: Add Array.exists2 and Array.for_all2
(Bernhard Schommer, review by Armaël Guéneau)
@ -469,11 +619,6 @@ OCaml 4.11
(Jeremy Yallop, review by Hezekiah M. Carty, Gabriel Scherer and
Gabriel Radanne)
- #8771: Lexing: add set_position and set_filename to change (fake)
the initial tracking position of the lexbuf.
(Konstantin Romanov, Miguel Lumapat, review by Gabriel Scherer,
Sébastien Hinderer, and David Allsopp)
- #9059: Added List.filteri function, same as List.filter but
with the index of the element.
(Léo Andrès, review by Alain Frisch)
@ -481,6 +626,18 @@ OCaml 4.11
- #8894: Added List.fold_left_map function combining map and fold.
(Bernhard Schommer, review by Alain Frisch and github user @cfcs)
- #9365: Set.filter_map and Map.filter_map
(Gabriel Scherer, review by Stephen Dolan and Nicolás Ojeda Bär)
- #9248: Add Printexc.default_uncaught_exception_handler
(Raphael Sousa Santos, review by Daniel Bünzli)
- #8771: Lexing: add set_position and set_filename to change (fake)
the initial tracking position of the lexbuf.
(Konstantin Romanov, Miguel Lumapat, review by Gabriel Scherer,
Sébastien Hinderer, and David Allsopp)
- #9237: `Format.pp_update_geometry ppf (fun geo -> {geo with ...})`
for formatter geometry changes that are robust to new geometry fields.
(Gabriel Scherer, review by Josh Berdine and Florian Angeletti)
@ -488,23 +645,12 @@ OCaml 4.11
- #7110: Added Printf.ikbprintf and Printf.ibprintf
(Muskan Garg, review by Gabriel Scherer and Florian Angeletti)
- #9365: Set.filter_map and Map.filter_map
(Gabriel Scherer, review by Stephen Dolan and Nicolás Ojeda Bär)
- #9266: Install pretty-printer for the exception Fun.Finally_raised.
(Guillaume Munch-Maccagnoni, review by Daniel Bünzli, Gabriel Radanne,
and Gabriel Scherer)
- #9549, #9557: Make -flarge-toc the default for PowerPC and introduce
-fsmall-toc to enable the previous behaviour.
(David Allsopp, report by Nathaniel Wesley Filardo, review by Xavier Leroy)
### Other libraries:
- #9338: Dynlink: make sure *_units () functions report accurate information
before the first load.
(Daniel Bünzli, review by Xavier Leroy and Nicolás Ojeda Bär)
- #9106: Register printer for Unix_error in win32unix, as in unix.
(Christopher Zimmermann, review by David Allsopp)
@ -524,9 +670,10 @@ OCaml 4.11
### Tools:
* #9299: ocamldep: do not process files during cli parsing. Fixes
various broken cli behaviours.
(Daniel Bünzli, review by Nicolás Ojeda Bär)
- #9283, #9455, #9457: add a new toplevel directive `#use_output "<command>"` to
run a command and evaluate its output.
(Jérémie Dimino, review by David Allsopp)
- #6969: Argument -nocwd added to ocamldep
(Muskan Garg, review by Florian Angeletti)
@ -547,10 +694,6 @@ OCaml 4.11
from a different (older or newer), incompatible compiler version.
(Gabriel Scherer, review by Gabriel Radanne and Damien Doligez)
- #9181: make objinfo work on Cygwin and look for the caml_plugin_header
symbol in both the static and the dynamic symbol tables.
(Sébastien Hinderer, review by Gabriel Scherer and David Allsopp)
* #9197: remove compatibility logic from #244 that was designed to
synchronize toplevel printing margins with Format.std_formatter,
but also resulted in unpredictable/fragile changes to formatter
@ -568,29 +711,12 @@ OCaml 4.11
points to the grammar.
(Andreas Abel, review by Xavier Leroy)
- #9283, #9455, #9457: add a new toplevel directive `#use_output "<command>"` to
run a command and evaluate its output.
(Jérémie Dimino, review by David Allsopp)
- #9402: Remove `sudo:false` from .travis.yml
(Hikaru Yoshimura)
- #9414: testsuite, ocamltest: keep test artifacts only on failure.
Use KEEP_TEST_DIR_ON_SUCCESS=1 to keep all artifacts.
(Gabriel Scherer, review by Sébastien Hinderer)
- #9482, #9492: use diversions (@file) to work around OS limitations
on length of Sys.command argument.
(Xavier Leroy, report by Jérémie Dimino, review by David Allsopp)
- #9552: restore ocamloptp build and installation
(Florian Angeletti, review by David Allsopp and Xavier Leroy)
### Manual and documentation:
- #8644: fix formatting comment about @raise in stdlib's mli files
(Élie Brami, review by David Allsopp)
- #9141: beginning of the ocamltest reference manual
(Sébastien Hinderer, review by Gabriel Scherer and Thomas Refis)
@ -605,12 +731,8 @@ OCaml 4.11
- #9325: documented base case for `List.for_all` and `List.exists`
(Glenn Slotte, review by Florian Angeletti)
- #9403: added a description for warning 67 and added a "." at the end of
warnings for consistency.
(Muskan Garg, review by Gabriel Scherer and Florian Angeletti)
- #7708, #9580: Ensure Stdlib documentation index refers to Stdlib.
(Stephen Dolan, review by Florian Angeletti, report by Hannes Mehnert)
- #9410, #9422: replaced naive fibonacci example with gcd
(Anukriti Kumar, review by San Vu Ngoc, Florian Angeletti, Léo Andrès)
- #9541: Add a documentation page for the instrumented runtime;
additional changes to option names in the instrumented runtime.
@ -626,12 +748,41 @@ OCaml 4.11
limit
(Florian Angeletti, review by Josh Berdine)
- #8644: fix formatting comment about @raise in stdlib's mli files
(Élie Brami, review by David Allsopp)
- #9327, #9401: manual, fix infix attribute examples
(Florian Angeletti, report by David Cadé, review by Gabriel Scherer)
- #9403: added a description for warning 67 and added a "." at the end of
warnings for consistency.
(Muskan Garg, review by Gabriel Scherer and Florian Angeletti)
- #7708, #9580: Ensure Stdlib documentation index refers to Stdlib.
(Stephen Dolan, review by Florian Angeletti, report by Hannes Mehnert)
### Compiler user-interface and warnings:
- GPR#1664: make -output-complete-obj link the runtime native c libraries when
- #9712: Update the version format to allow "~".
The new format is "major.minor[.patchlevel][(+|~)additional-info]",
for instance "4.12.0~beta1+flambda".
This is a documentation-only change for the 4.11 branch, the new format
will be used starting with the 4.12 branch.
(Florian Angeletti, review by Damien Doligez and Xavier Leroy)
- #1664: make -output-complete-obj link the runtime native c libraries when
building shared libraries like `-output-obj`.
(Florian Angeletti, review by Nicolás Ojeda Bär)
- #9349: Support [@inlined hint] attribute.
(Leo White, review by Stephen Dolan)
- #2141: generate .annot files from cmt data; deprecate -annot.
(Nicolás Ojeda Bär, review by Alain Frisch, Gabriel Scherer and Damien
Doligez)
* #7678, #8631: ocamlc -c and ocamlopt -c pass same switches to the C
compiler when compiling .c files (in particular, this means ocamlopt
passes -fPIC on systems requiring it for shared library support).
@ -658,25 +809,21 @@ OCaml 4.11
- #9393: Improve recursive module usage warnings
(Leo White, review by Thomas Refis)
- #2141: generate .annot files from cmt data; deprecate -annot.
(Nicolás Ojeda Bär, review by Alain Frisch, Gabriel Scherer and Damien
Doligez)
- #9486: Fix configuration for the Haiku operating system
(Sylvain Kerjean, review by David Allsopp and Sébastien Hinderer)
- #9712: Update the version format to allow "~".
The new format is "major.minor[.patchlevel][(+|~)additional-info]",
for instance "4.12.0~beta1+flambda".
This is a documentation-only change for the 4.11 branch, the new format
will be used starting with the 4.12 branch.
(Florian Angeletti, review by Damien Doligez and Xavier Leroy)
### Internal/compiler-libs changes:
- #463: a new Misc.Magic_number module for user-friendly parsing
and validation of OCaml magic numbers.
(Gabriel Scherer, review by Gabriel Radanne and Damien Doligez)
- #9021: expose compiler Longident.t parsers
(Florian Angeletti, review by Gabriel Scherer)
- #9452: Add locations to docstring attributes
(Leo White, review by Gabriel Scherer)
- #463: a new Misc.Magic_number module for user-friendly parsing
and validation of OCaml magic numbers.
(Gabriel Scherer, review by Gabriel Radanne and Damien Doligez)
- #1176: encourage better compatibility with older Microsoft C compilers by
using GCC's -Wdeclaration-after-statement when available. Introduce
@ -695,9 +842,6 @@ OCaml 4.11
- #9060: ensure that Misc.protect_refs preserves backtraces
(Gabriel Scherer, review by Guillaume Munch-Maccagnoni and David Allsopp)
- #9021: expose compiler Longident.t parsers
(Florian Angeletti, review by Gabriel Scherer)
- #9078: make all compilerlibs/ available to ocamltest.
(Gabriel Scherer, review by Sébastien Hinderer)
@ -713,7 +857,7 @@ OCaml 4.11
(Gabriel Scherer, Thomas Refis, Florian Angeletti and Jacques Garrigue,
reviewing each other without self-loops)
- #9321, #9322, #9359, #9361, #9417, #9447, #9464: refactor the
- #9321, #9322, #9359, #9361, #9417, #9447: refactor the
pattern-matching compiler
(Thomas Refis and Gabriel Scherer, review by Florian Angeletti)
@ -721,6 +865,9 @@ OCaml 4.11
compilerlibs, dynlink, ocamltest.
(Gabriel Scherer, review by Vincent Laviron and David Allsopp)
- #9275: Short circuit simple inclusion checks
(Leo White, review by Thomas Refis)
- #9305: Avoid polymorphic compare in Ident
(Leo White, review by Xavier Leroy and Gabriel Scherer)
@ -734,11 +881,16 @@ OCaml 4.11
- #9246: Avoid rechecking functor applications
(Leo White, review by Jacques Garrigue)
- #9402: Remove `sudo:false` from .travis.yml
(Hikaru Yoshimura)
* #9411: forbid optional arguments reordering with -nolabels
(Thomas Refis, review by Frédéric Bour and Jacques Garrigue)
- #9452: Add locations to docstring attributes
(Leo White, review by Gabriel Scherer)
- #9414: testsuite, ocamltest: keep test artifacts only on failure.
Use KEEP_TEST_DIR_ON_SUCCESS=1 to keep all artifacts.
(Gabriel Scherer, review by Sébastien Hinderer)
### Build system:
@ -839,6 +991,9 @@ OCaml 4.11
* #9388: Prohibit signature local types with constraints
(Leo White, review by Jacques Garrigue)
- #7141, #9389: returns exit_code for better user response on linking_error
(Anukriti Kumar, review by Gabriel Scherer and Valentin Gatien-Baron)
- #9406, #9409: fix an error with packed module types from missing
cmis.
(Florian Angeletti, report by Thomas Leonard, review by Gabriel Radanne
@ -864,6 +1019,10 @@ OCaml 4.11
- #9695, #9702: no error when opening an alias to a missing module
(Jacques Garrigue, report and review by Gabriel Scherer)
- #9714, #9724: Add a terminator to the `caml_domain_state` structure
to better ensure that members are correctly spaced.
(Antonin Décimo, review by David Allsopp and Xavier Leroy)
OCaml 4.10 maintenance branch
-----------------------------
@ -893,9 +1052,18 @@ OCaml 4.10 maintenance branch
output channels would not be flushed).
(Nicolás Ojeda Bär, review by David Allsopp)
- #9714, #9724: Use the C++ alignas keyword when compiling in C++ in MSVC.
Fixes a bug with MSVC C++ 2015 onwards.
(Antonin Décimo, review by David Allsopp and Xavier Leroy)
- #9736, #9749: Compaction must start in a heap where all free blocks are
blue, which was not the case with the best-fit allocator.
(Damien Doligez, report by Leo White, review by ???)
(Damien Doligez, report and review by Leo White)
### Tools:
- #9552: restore ocamloptp build and installation
(Florian Angeletti, review by David Allsopp and Xavier Leroy)
OCaml 4.10.0 (21 February 2020)
-------------------------------
@ -1205,6 +1373,10 @@ OCaml 4.10.0 (21 February 2020)
- #9127, #9130: ocamldoc: fix the formatting of closing brace in record types.
(David Allsopp, report by San Vu Ngoc)
- #9181: make objinfo work on Cygwin and look for the caml_plugin_header
symbol in both the static and the dynamic symbol tables.
(Sébastien Hinderer, review by Gabriel Scherer and David Allsopp)
### Build system:
- #8840: use ocaml{c,opt}.opt when available to build internal tools
@ -1405,9 +1577,6 @@ OCaml 4.10.0 (21 February 2020)
- #9261: Fix a soundness bug in Rec_check, new in 4.10 (from #8908)
(Vincent Laviron, review by Jeremy Yallop and Gabriel Scherer)
- #9389: returns exit_code for better user response on linking_error
(Anukriti Kumar, review by Gabriel Scherer and sliquister)
OCaml 4.09 maintenance branch
-----------------------------
@ -1438,15 +1607,15 @@ OCaml 4.09.1 (16 Mars 2020)
- #9050, #9076: install missing compilerlibs/ocamlmiddleend archives
(Gabriel Scherer, review by Florian Angeletti, report by Olaf Hering)
- #9144, #9180: multiple definitions of global variables in the C runtime,
causing problems with GCC 10.0 and possibly with other C compilers
(Xavier Leroy, report by Jürgen Reuter, review by Mark Shinwell)
- #9180: pass -fno-common option to C compiler when available,
so as to detect problematic multiple definitions of global variables
in the C runtime
(Xavier Leroy, review by Mark Shinwell)
- #9144, #9180: multiple definitions of global variables in the C runtime,
causing problems with GCC 10.0 and possibly with other C compilers
(Xavier Leroy, report by Jürgen Reuter, review by Mark Shinwell)
- #9128: Fix a bug in bytecode mode which could lead to a segmentation
fault. The bug was caused by the fact that the atom table shared a
page with some bytecode. The fix makes sure both the atom table and
@ -1594,9 +1763,6 @@ OCaml 4.09.0 (19 September 2019)
- #8515: manual, precise constraints on reexported types
(Florian Angeletti, review by Gabriel Scherer)
- #9327, #9401: manual, fix infix attribute examples
(Florian Angeletti, report by David Cadé, review by Gabriel Scherer)
### Tools:
- #2221: ocamldep will now correctly allow a .ml file in an include directory
@ -1668,9 +1834,6 @@ OCaml 4.09.0 (19 September 2019)
(Thomas Refis, review by David Allsopp, Florian Angeletti, Gabriel Radanne,
Gabriel Scherer and Xavier Leroy)
- #9275: Short circuit simple inclusion checks
(Leo White, review by Thomas Refis)
### Compiler distribution build system:
- #2267: merge generation of header programs, also fixing parallel build on
@ -2193,9 +2356,6 @@ OCaml 4.08.0 (13 June 2019)
- #8508: refresh \moduleref macro
(Florian Angeletti, review by Gabriel Scherer)
- 9410: replaced fibonacci example with gcd of coreexamples manual
(Anukriti Kumar, review by San Vu Ngoc, Florian Angeletti, Léo Andrès)
### Code generation and optimizations:
- #7725, #1754: improve AFL instrumentation for objects and lazy values.
@ -2922,9 +3082,6 @@ OCaml 4.07.0 (10 July 2018)
platforms, making this option unusable on platforms where it wasn't.
(Jérémie Dimino, review by Sébastien Hinderer and Xavier Leroy)
- #9349: Support [@inlined hint] attribute.
(Leo White, review by Stephen Dolan)
### Runtime system:
- #515 #676 #7173: Add a public C API for weak arrays and

6
HACKING.adoc
View File

@ -330,16 +330,16 @@ file.
Merlin will be looking at the artefacts generated by dune (in `_build`), rather
than trying to open the incompatible artefacts produced by a Makefile build. In
particular, you need to repeat the dune build everytime you change the interface
particular, you need to repeat the dune build every time you change the interface
of some compilation unit, so that merlin is aware of the new interface.
You only need to run `configure` once, but you will need to run `make clean`
everytime you want to run `dune` after you built something with `make`;
every time you want to run `dune` after you built something with `make`;
otherwise dune will complain that build artefacts are present among the sources.
Finally, there will be times where the compiler simply cannot be built with an
older version of itself. One example of this is when a new primitive is added to
the runtime, and then used in the standard library straightaway, since the rest
the runtime, and then used in the standard library straight away, since the rest
of the compiler requires the `stdlib` library to build, nothing can be build. In
such situations, you will have to either live without merlin, or develop on an
older branch of the compiler, for example the maintenance branch of the last

20
Makefile
View File

@ -53,7 +53,6 @@ else
OCAML_NATDYNLINKOPTS = -ccopt "$(NATDYNLINKOPTS)"
endif
YACCFLAGS=-v --strict
CAMLLEX=$(CAMLRUN) boot/ocamllex
CAMLDEP=$(CAMLRUN) boot/ocamlc -depend
DEPFLAGS=-slash
@ -78,10 +77,10 @@ COMPLIBDIR=$(LIBDIR)/compiler-libs
TOPINCLUDES=$(addprefix -I otherlibs/,$(filter-out %threads,$(OTHERLIBRARIES)))
RUNTOP=./runtime/ocamlrun$(EXE) ./ocaml$(EXE) \
-nostdlib -I stdlib \
-nostdlib -I stdlib -I toplevel \
-noinit $(TOPFLAGS) $(TOPINCLUDES)
NATRUNTOP=./ocamlnat$(EXE) \
-nostdlib -I stdlib \
-nostdlib -I stdlib -I toplevel \
-noinit $(TOPFLAGS) $(TOPINCLUDES)
ifeq "$(UNIX_OR_WIN32)" "unix"
EXTRAPATH=
@ -868,7 +867,7 @@ ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex
$(MAKE) -C ocamldoc opt.opt
# OCamltest
ocamltest: ocamlc ocamlyacc ocamllex
ocamltest: ocamlc ocamlyacc ocamllex otherlibraries
$(MAKE) -C ocamltest all
ocamltest.opt: ocamlc.opt ocamlyacc ocamllex
@ -928,13 +927,16 @@ endif
# Check that the stack limit is reasonable (Unix-only)
.PHONY: checkstack
checkstack:
ifeq "$(UNIX_OR_WIN32)" "unix"
if $(MKEXE) $(OUTPUTEXE)tools/checkstack$(EXE) tools/checkstack.c; \
then tools/checkstack$(EXE); \
fi
rm -f tools/checkstack$(EXE)
checkstack := tools/checkstack
checkstack: $(checkstack)$(EXE)
$<
.INTERMEDIATE: $(checkstack)$(EXE) $(checkstack).$(O)
$(checkstack)$(EXE): $(checkstack).$(O)
$(MKEXE) $(OUTPUTEXE)$@ $<
else
checkstack:
@
endif

3
Makefile.common
View File

@ -109,7 +109,8 @@ REQUIRED_HEADERS := $(RUNTIME_HEADERS) $(wildcard *.h)
endif
%.$(O): %.c $(REQUIRED_HEADERS)
$(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) $(OUTPUTOBJ)$@ $<
$(CC) -c $(OC_CFLAGS) $(CFLAGS) $(OC_CPPFLAGS) $(CPPFLAGS) \
$(OUTPUTOBJ)$@ $<
$(DEPDIR):
$(MKDIR) $@

8
Makefile.config.in
View File

@ -129,7 +129,7 @@ ARCH=@arch@
# Whether the architecture has 64 bits
ARCH64=@arch64@
# Endianess for this architecture
# Endianness for this architecture
ENDIANNESS=@endianness@
### Name of architecture model for the native-code compiler.
@ -179,7 +179,9 @@ UNIXLIB=@unixlib@
INSTALL_SOURCE_ARTIFACTS=@install_source_artifacts@
OC_CFLAGS=@oc_cflags@
CFLAGS?=@CFLAGS@
OC_CPPFLAGS=@oc_cppflags@
CPPFLAGS?=@CPPFLAGS@
OCAMLC_CFLAGS=@ocamlc_cflags@
OCAMLC_CPPFLAGS=@ocamlc_cppflags@
@ -252,10 +254,10 @@ ifeq "$(TOOLCHAIN)" "msvc"
MERGEMANIFESTEXE=test ! -f $(1).manifest \
|| mt -nologo -outputresource:$(1) -manifest $(1).manifest \
&& rm -f $(1).manifest
MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OUTPUTEXE)$(1) $(2) \
MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(CFLAGS) $(OUTPUTEXE)$(1) $(2) \
/link /subsystem:console $(OC_LDFLAGS) && ($(MERGEMANIFESTEXE))
else
MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OC_LDFLAGS) $(OUTPUTEXE)$(1) $(2)
MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(CFLAGS) $(OC_LDFLAGS) $(OUTPUTEXE)$(1) $(2)
endif # ifeq "$(TOOLCHAIN)" "msvc"
# The following variables were defined only in the Windows-specific makefiles.

9
README.adoc
View File

@ -76,11 +76,10 @@ the compiler may work under other operating systems with little work.
== Copyright
All files marked "Copyright INRIA" in this distribution are copyright 1996,
1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019
Institut National de Recherche en Informatique et en Automatique (INRIA)
and distributed under the conditions stated in file LICENSE.
All files marked "Copyright INRIA" in this distribution are
Copyright (C) 1996-2020 Institut National de Recherche en Informatique et
en Automatique (INRIA) and distributed under the conditions stated in
file LICENSE.
== Installation

1
asmcomp/arm64/NOTES.md
View File

@ -10,3 +10,4 @@ Debian architecture name: `arm64`.
_ARM Architecture Reference Manual, ARMv8_, restricted to the AArch64 subset.
* Application binary interface:
_Procedure Call Standard for the ARM 64-bit Architecture (AArch64)_
_Apple ARM64 Function Calling Conventions_

71
asmcomp/arm64/emit.mlp
View File

@ -38,18 +38,35 @@ let reg_trap_ptr = phys_reg 23
let reg_alloc_ptr = phys_reg 24
let reg_alloc_limit = phys_reg 25
let reg_tmp1 = phys_reg 26
let reg_x15 = phys_reg 15
let reg_x8 = phys_reg 8
(* Output a label *)
let label_prefix =
if macosx then "L" else ".L"
let emit_label lbl =
emit_string ".L"; emit_int lbl
emit_string label_prefix; emit_int lbl
(* Symbols *)
let emit_symbol s =
if macosx then emit_string "_";
Emitaux.emit_symbol '$' s
(* Object types *)
let emit_symbol_type emit_lbl_or_sym lbl_or_sym ty =
if not macosx then begin
` .type {emit_lbl_or_sym lbl_or_sym}, %{emit_string ty}\n`
end
let emit_symbol_size sym =
if not macosx then begin
` .size {emit_symbol sym}, .-{emit_symbol sym}\n`
end
(* Output a pseudo-register *)
let emit_reg = function
@ -78,12 +95,15 @@ let prologue_required = ref false
let contains_calls = ref false
let frame_size () =
let sz =
!stack_offset +
let initial_stack_offset () =
8 * num_stack_slots.(0) +
8 * num_stack_slots.(1) +
(if !contains_calls then 8 else 0)
let frame_size () =
let sz =
!stack_offset +
initial_stack_offset ()
in Misc.align sz 16
let slot_offset loc cl =
@ -320,6 +340,8 @@ let float_literal f =
(* Emit all pending literals *)
let emit_literals() =
if !float_literals <> [] then begin
if macosx then
` .section __TEXT,__literal8,8byte_literals\n`;
` .align 3\n`;
List.iter
(fun (f, lbl) ->
@ -331,7 +353,10 @@ let emit_literals() =
(* Emit code to load the address of a symbol *)
let emit_load_symbol_addr dst s =
if not !Clflags.dlcode then begin
if macosx then begin
` adrp {emit_reg dst}, {emit_symbol s}@GOTPAGE\n`;
` ldr {emit_reg dst}, [{emit_reg dst}, {emit_symbol s}@GOTPAGEOFF]\n`
end else if not !Clflags.dlcode then begin
` adrp {emit_reg dst}, {emit_symbol s}\n`;
` add {emit_reg dst}, {emit_reg dst}, #:lo12:{emit_symbol s}\n`
end else begin
@ -427,7 +452,7 @@ module BR = Branch_relaxation.Make (struct
let offset_pc_at_branch = 0
let prologue_size () =
(if frame_size () > 0 then 2 else 0)
(if initial_stack_offset () > 0 then 2 else 0)
+ (if !contains_calls then 1 else 0)
let epilogue_size () =
@ -562,7 +587,7 @@ let assembly_code_for_allocation ~label_after_call_gc i ~n ~far ~dbginfo =
| 16 -> ` bl {emit_symbol "caml_alloc1"}\n`
| 24 -> ` bl {emit_symbol "caml_alloc2"}\n`
| 32 -> ` bl {emit_symbol "caml_alloc3"}\n`
| _ -> emit_intconst reg_x15 (Nativeint.of_int n);
| _ -> emit_intconst reg_x8 (Nativeint.of_int n);
` bl {emit_symbol "caml_allocN"}\n`
end;
`{emit_label lbl_frame}: add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`
@ -577,6 +602,17 @@ let emit_named_text_section func_name =
else
` .text\n`
(* Emit code to load an emitted literal *)
let emit_load_literal dst lbl =
if macosx then begin
` adrp {emit_reg reg_tmp1}, {emit_label lbl}@PAGE\n`;
` ldr {emit_reg dst}, [{emit_reg reg_tmp1}, {emit_label lbl}@PAGEOFF]\n`
end else begin
` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`;
` ldr {emit_reg dst}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n`
end
(* Output the assembly code for an instruction *)
let emit_instr i =
@ -629,8 +665,7 @@ let emit_instr i =
` fmov {emit_reg i.res.(0)}, #{emit_printf "%.7f" (Int64.float_of_bits f)}\n`
else begin
let lbl = float_literal f in
` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`;
` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n`
emit_load_literal i.res.(0) lbl
end
| Lop(Iconst_symbol s) ->
emit_load_symbol_addr i.res.(0) s
@ -650,7 +685,7 @@ let emit_instr i =
| Lop(Iextcall { func; alloc = false; label_after = _; }) ->
` bl {emit_symbol func}\n`
| Lop(Iextcall { func; alloc = true; label_after; }) ->
emit_load_symbol_addr reg_x15 func;
emit_load_symbol_addr reg_x8 func;
` bl {emit_symbol "caml_c_call"}\n`;
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
| Lop(Istackoffset n) ->
@ -950,7 +985,7 @@ let fundecl fundecl =
emit_named_text_section !function_name;
` .align 3\n`;
` .globl {emit_symbol fundecl.fun_name}\n`;
` .type {emit_symbol fundecl.fun_name}, %function\n`;
emit_symbol_type emit_symbol fundecl.fun_name "function";
`{emit_symbol fundecl.fun_name}:\n`;
emit_debug_info fundecl.fun_dbg;
cfi_startproc();
@ -968,8 +1003,8 @@ let fundecl fundecl =
assert (List.length !call_gc_sites = num_call_gc);
assert (List.length !bound_error_sites = num_check_bound);
cfi_endproc();
` .type {emit_symbol fundecl.fun_name}, %function\n`;
` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`;
emit_symbol_type emit_symbol fundecl.fun_name "function";
emit_symbol_size fundecl.fun_name;
emit_literals()
(* Emission of data *)
@ -1032,10 +1067,10 @@ let end_assembly () =
`{emit_symbol lbl}:\n`;
emit_frames
{ efa_code_label = (fun lbl ->
` .type {emit_label lbl}, %function\n`;
emit_symbol_type emit_label lbl "function";
` .quad {emit_label lbl}\n`);
efa_data_label = (fun lbl ->
` .type {emit_label lbl}, %object\n`;
emit_symbol_type emit_label lbl "object";
` .quad {emit_label lbl}\n`);
efa_8 = (fun n -> ` .byte {emit_int n}\n`);
efa_16 = (fun n -> ` .short {emit_int n}\n`);
@ -1046,8 +1081,8 @@ let end_assembly () =
` .long {emit_label lbl} - . + {emit_int32 ofs}\n`);
efa_def_label = (fun lbl -> `{emit_label lbl}:\n`);
efa_string = (fun s -> emit_string_directive " .asciz " s) };
` .type {emit_symbol lbl}, %object\n`;
` .size {emit_symbol lbl}, .-{emit_symbol lbl}\n`;
emit_symbol_type emit_symbol lbl "object";
emit_symbol_size lbl;
begin match Config.system with
| "linux" ->
(* Mark stack as non-executable *)

17
asmcomp/arm64/proc.ml
View File

@ -99,7 +99,7 @@ let all_phys_regs =
let phys_reg n =
if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
let reg_x15 = phys_reg 15
let reg_x8 = phys_reg 8
let reg_d7 = phys_reg 107
let stack_slot slot ty =
@ -165,13 +165,20 @@ let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
Return values in r0...r15 or d0...d15. *)
let max_arguments_for_tailcalls = 16
let last_int_register = if macosx then 7 else 15
let loc_arguments arg =
calling_conventions 0 15 100 115 outgoing arg
calling_conventions 0 last_int_register 100 115 outgoing arg
let loc_parameters arg =
let (loc, _) = calling_conventions 0 15 100 115 incoming arg in loc
let (loc, _) =
calling_conventions 0 last_int_register 100 115 incoming arg
in
loc
let loc_results res =
let (loc, _) = calling_conventions 0 15 100 115 not_supported res in loc
let (loc, _) =
calling_conventions 0 last_int_register 100 115 not_supported res
in
loc
(* C calling convention:
first integer args in r0...r7
@ -252,7 +259,7 @@ let destroyed_at_oper = function
| Iop(Iextcall { alloc = false; }) ->
destroyed_at_c_call
| Iop(Ialloc _) ->
[| reg_x15 |]
[| reg_x8 |]
| Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) ->
[| reg_d7 |] (* d7 / s7 destroyed *)
| _ -> [||]

2
asmcomp/arm64/selection.ml
View File

@ -83,7 +83,7 @@ let inline_ops =
"caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ]
let use_direct_addressing _symb =
not !Clflags.dlcode
(not !Clflags.dlcode) && (not Arch.macosx)
let is_stack_slot rv =
Reg.(match rv with

16
asmcomp/cmm_helpers.ml
View File

@ -454,7 +454,7 @@ let rec div_int c1 c2 is_safe dbg =
res = t + sign-bit(c1)
*)
bind "dividend" c1 (fun c1 ->
let t = Cop(Cmulhi, [c1; Cconst_natint (m, dbg)], dbg) in
let t = Cop(Cmulhi, [c1; natint_const_untagged dbg m], dbg) in
let t = if m < 0n then Cop(Caddi, [t; c1], dbg) else t in
let t =
if p > 0 then Cop(Casr, [t; Cconst_int (p, dbg)], dbg) else t
@ -995,7 +995,7 @@ let sign_extend_32 dbg e =
(if the word size is 32, this is a no-op) *)
let zero_extend_32 dbg e =
if size_int = 4 then e else
Cop(Cand, [low_32 dbg e; Cconst_natint(0xFFFFFFFFn, dbg)], dbg)
Cop(Cand, [low_32 dbg e; natint_const_untagged dbg 0xFFFFFFFFn], dbg)
(* Boxed integers *)
@ -1074,21 +1074,23 @@ let unbox_int dbg bi =
| Cconst_symbol (s, _dbg) as cmm ->
begin match Cmmgen_state.structured_constant_of_sym s, bi with
| Some (Uconst_nativeint n), Primitive.Pnativeint ->
Cconst_natint (n, dbg)
natint_const_untagged dbg n
| Some (Uconst_int32 n), Primitive.Pint32 ->
Cconst_natint (Nativeint.of_int32 n, dbg)
natint_const_untagged dbg (Nativeint.of_int32 n)
| Some (Uconst_int64 n), Primitive.Pint64 ->
if size_int = 8 then
Cconst_natint (Int64.to_nativeint n, dbg)
natint_const_untagged dbg (Int64.to_nativeint n)
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)]
Ctuple [natint_const_untagged dbg high;
natint_const_untagged dbg low]
else
Ctuple [Cconst_natint (low, dbg); Cconst_natint (high, dbg)]
Ctuple [natint_const_untagged dbg low;
natint_const_untagged dbg high]
| _ ->
default cmm
end

14
asmcomp/power/emit.mlp
View File

@ -42,14 +42,16 @@ let prologue_required = ref false
let contains_calls = ref false
let initial_stack_offset () =
reserved_stack_space +
size_int * num_stack_slots.(0) + (* Local int variables *)
size_float * num_stack_slots.(1) + (* Local float variables *)
(if !contains_calls && abi = ELF32 then size_int else 0)
(* The return address *)
let frame_size () =
let size =
reserved_stack_space +
!stack_offset + (* Trap frame, outgoing parameters *)
size_int * num_stack_slots.(0) + (* Local int variables *)
size_float * num_stack_slots.(1) + (* Local float variables *)
(if !contains_calls && abi = ELF32 then size_int else 0) in
(* The return address *)
initial_stack_offset () in
Misc.align size 16
let slot_offset loc cls =
@ -439,7 +441,7 @@ module BR = Branch_relaxation.Make (struct
let prologue_size () =
profiling_prologue_size ()
+ (if frame_size () > 0 then 1 else 0)
+ (if initial_stack_offset () > 0 then 1 else 0)
+ (if !contains_calls then
2 +
match abi with

7
asmcomp/riscv/proc.ml
View File

@ -36,7 +36,8 @@ let word_addressed = false
a0-a7 0-7 arguments/results
s2-s9 8-15 arguments/results (preserved by C)
t2-t6 16-20 temporary
t0-t1 21-22 temporary (used by code generator)
t0 21 temporary
t1 22 temporary (used by code generator)
s0 23 domain pointer (preserved by C)
s1 24 trap pointer (preserved by C)
s10 25 allocation pointer (preserved by C)
@ -55,8 +56,8 @@ let word_addressed = false
Additional notes
----------------
- t0-t1 are used by the assembler and code generator, so
not available for register allocation.
- t1 is used by the code generator, so not available for register
allocation.
- t0-t6 may be used by PLT stubs, so should not be used to pass
arguments and may be clobbered by [Ialloc] in the presence of dynamic

6
asmcomp/s390x/selection.ml
View File

@ -80,6 +80,12 @@ method! select_operation op args dbg =
match (op, args) with
(* Z does not support immediate operands for multiply high *)
(Cmulhi, _) -> (Iintop Imulh, args)
(* sub immediate is turned into add immediate opposite,
hence the immediate range is special *)
| (Csubi, [arg; Cconst_int (n, _)]) when self#is_immediate (-n) ->
(Iintop_imm(Isub, n), [arg])
| (Csubi, _) ->
(Iintop Isub, args)
(* The and, or and xor instructions have a different range of immediate
operands than the other instructions *)
| (Cand, _) ->

2
asmcomp/selectgen.ml
View File

@ -1015,7 +1015,7 @@ method emit_extcall_args env ty_args args =
method insert_move_extcall_arg env _ty_arg src dst =
(* The default implementation is one or two ordinary moves.
(Two in the case of an int64 argument on a 32-bit platform.)
It can be overriden to use special move instructions,
It can be overridden to use special move instructions,
for example a "32-bit move" instruction for int32 arguments. *)
self#insert_moves env src dst

2
asmcomp/selectgen.mli
View File

@ -99,7 +99,7 @@ class virtual selector_generic : object
or instructions with hardwired input/output registers *)
method insert_move_extcall_arg :
environment -> Cmm.exttype -> Reg.t array -> Reg.t array -> unit
(* Can be overriden to deal with unusual unboxed calling conventions,
(* Can be overridden to deal with unusual unboxed calling conventions,
e.g. on a 64-bit platform, passing unboxed 32-bit arguments
in 32-bit stack slots. *)
method emit_extcall_args :

2
asmcomp/spacetime_profiling.ml
View File

@ -33,7 +33,7 @@ let reverse_shape = ref ([] : Mach.spacetime_shape)
(* CR-someday mshinwell: This code could be updated to use [placeholder_dbg] as
in [Cmmgen]. *)
let cconst_int i = Cmm.Cconst_int (i, Debuginfo.none)
let cconst_natint i = Cmm.Cconst_natint (i, Debuginfo.none)
let cconst_natint i = Cmm_helpers.natint_const_untagged Debuginfo.none i
let cconst_symbol s = Cmm.Cconst_symbol (s, Debuginfo.none)
let something_was_instrumented () =

13315
boot/menhir/parser.ml
View File

File diff suppressed because it is too large Load Diff

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

81
configure generated vendored
View File

@ -2310,6 +2310,52 @@ rm -f conftest.val
} # ac_fn_c_compute_int
# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES
# ---------------------------------------------
# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR
# accordingly.
ac_fn_c_check_decl ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
as_decl_name=`echo $2|sed 's/ *(.*//'`
as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'`
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5
$as_echo_n "checking whether $as_decl_name is declared... " >&6; }
if eval \${$3+:} false; then :
$as_echo_n "(cached) " >&6
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$4
int
main ()
{
#ifndef $as_decl_name
#ifdef __cplusplus
(void) $as_decl_use;
#else
(void) $as_decl_name;
#endif
#endif
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"; then :
eval "$3=yes"
else
eval "$3=no"
fi
rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
eval ac_res=\$$3
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
$as_echo "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_decl
# ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES
# ----------------------------------------------------
# Tries to find if the field MEMBER exists in type AGGR, after including
@ -2734,7 +2780,11 @@ programs_man_section=1
libraries_man_section=3
# Command to build executalbes
mkexe="\$(CC) \$(OC_CFLAGS) \$(OC_CPPFLAGS) \$(OC_LDFLAGS)"
# In general this command is supposed to use the CFLAGs-related variables
# ($OC_CFLAGS and $CFLAGS), but at the moment they are not taken into
# account on Windows, because flexlink, which is used to build
# executables on this platform, can not handle them.
mkexe="\$(CC) \$(OC_CFLAGS) \$(CFLAGS) \$(OC_LDFLAGS)"
# Flags for building executable files with debugging symbols
mkexedebugflag="-g"
@ -2761,7 +2811,7 @@ instrumented_runtime_ldlibs=""
## Source directory
## Directory containing auxiliary scripts used dugring build
## Directory containing auxiliary scripts used during build
ac_aux_dir=
for ac_dir in build-aux "$srcdir"/build-aux; do
if test -f "$ac_dir/install-sh"; then
@ -3414,10 +3464,14 @@ esac
fi
# libtool expects host_os=mingw for native Windows
# Also, it has been observed that, on some platforms (e.g. msvc) LT_INIT
# alters the CFLAGS variable, so we save its value before calling the macro
# and restore it after the call
old_host_os=$host_os
if test x"$host_os" = "xwindows"; then :
host_os=mingw
fi
saved_CFLAGS="$CFLAGS"
case `pwd` in
*\ * | *\ *)
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Libtool does not cope well with whitespace in \`pwd\`" >&5
@ -12263,6 +12317,7 @@ CC=$lt_save_CC
# Only expand once:
CFLAGS="$saved_CFLAGS"
host_os=$old_host_os
case $host in #(
@ -12681,7 +12736,7 @@ $as_echo "$as_me: WARNING: Consider using GCC version 4.2 or above." >&2;};
internal_cppflags="$internal_cppflags -DWINDOWS_UNICODE="
internal_cppflags="${internal_cppflags}\$(WINDOWS_UNICODE)" ;; #(
xlc-*) :
common_cflags="-O5 -qtune=balanced -qnoipa -qinline $CFLAGS";
common_cflags="-O5 -qtune=balanced -qnoipa -qinline";
internal_cflags="$cc_warnings" ;; #(
*) :
common_cflags="-O" ;;
@ -13668,6 +13723,10 @@ if test x"$enable_shared" != "xno"; then :
natdynlink=true ;; #(
x86_64-*-linux*) :
natdynlink=true ;; #(
arm64-*-darwin*) :
natdynlink=true ;; #(
aarch64-*-darwin*) :
natdynlink=true ;; #(
x86_64-*-darwin*) :
natdynlink=true ;; #(
s390x*-*-linux*) :
@ -13865,6 +13924,10 @@ fi; system=elf ;; #(
arch=amd64; system=netbsd ;; #(
x86_64-*-openbsd*) :
arch=amd64; system=openbsd ;; #(
arm64-*-darwin*) :
arch=arm64; system=macosx ;; #(
aarch64-*-darwin*) :
arch=arm64; system=macosx ;; #(
x86_64-*-darwin*) :
arch=amd64; system=macosx ;; #(
x86_64-*-mingw32) :
@ -14621,6 +14684,14 @@ if test "x$ac_cv_func_getcwd" = xyes; then :
fi
ac_fn_c_check_decl "$LINENO" "system" "ac_cv_have_decl_system" "#include <stdlib.h>
"
if test "x$ac_cv_have_decl_system" = xyes; then :
$as_echo "#define HAS_SYSTEM 1" >>confdefs.h
fi
## utime
## Note: this was defined in config/s-nt.h but the autoconf macros do not
# seem to detect it properly on Windows so we hardcode the definition
@ -16918,8 +16989,8 @@ fi
oc_cflags="$common_cflags $internal_cflags"
oc_cppflags="$common_cppflags $internal_cppflags"
ocamlc_cflags="$common_cflags $sharedlib_cflags"
ocamlc_cppflags="$common_cppflags"
ocamlc_cflags="$common_cflags $sharedlib_cflags \$(CFLAGS)"
ocamlc_cppflags="$common_cppflags \$(CPPFLAGS)"
cclibs="$cclibs $mathlib"
case $host in #(

27
configure.ac
View File

@ -37,7 +37,11 @@ programs_man_section=1
libraries_man_section=3
# Command to build executalbes
mkexe="\$(CC) \$(OC_CFLAGS) \$(OC_CPPFLAGS) \$(OC_LDFLAGS)"
# In general this command is supposed to use the CFLAGs-related variables
# ($OC_CFLAGS and $CFLAGS), but at the moment they are not taken into
# account on Windows, because flexlink, which is used to build
# executables on this platform, can not handle them.
mkexe="\$(CC) \$(OC_CFLAGS) \$(CFLAGS) \$(OC_LDFLAGS)"
# Flags for building executable files with debugging symbols
mkexedebugflag="-g"
@ -64,7 +68,7 @@ instrumented_runtime_ldlibs=""
## Source directory
AC_CONFIG_SRCDIR([runtime/interp.c])
## Directory containing auxiliary scripts used dugring build
## Directory containing auxiliary scripts used during build
AC_CONFIG_AUX_DIR([build-aux])
## Output variables
@ -406,9 +410,14 @@ AS_IF([test x"$enable_unix_lib" = "xno" -o x"$enable_str_lib" = "xno"],
# User-specified LD still takes precedence.
AC_CHECK_TOOLS([LD],[ld link])
# libtool expects host_os=mingw for native Windows
# Also, it has been observed that, on some platforms (e.g. msvc) LT_INIT
# alters the CFLAGS variable, so we save its value before calling the macro
# and restore it after the call
old_host_os=$host_os
AS_IF([test x"$host_os" = "xwindows"],[host_os=mingw])
saved_CFLAGS="$CFLAGS"
LT_INIT
CFLAGS="$saved_CFLAGS"
host_os=$old_host_os
AS_CASE([$host],
@ -628,7 +637,7 @@ AS_CASE([$host],
internal_cppflags="$internal_cppflags -DWINDOWS_UNICODE="
internal_cppflags="${internal_cppflags}\$(WINDOWS_UNICODE)"],
[xlc-*],
[common_cflags="-O5 -qtune=balanced -qnoipa -qinline $CFLAGS";
[common_cflags="-O5 -qtune=balanced -qnoipa -qinline";
internal_cflags="$cc_warnings"],
[common_cflags="-O"])])
@ -871,6 +880,8 @@ AS_IF([test x"$enable_shared" != "xno"],
[[i[3456]86-*-linux*]], [natdynlink=true],
[[i[3456]86-*-gnu*]], [natdynlink=true],
[[x86_64-*-linux*]], [natdynlink=true],
[arm64-*-darwin*], [natdynlink=true],
[aarch64-*-darwin*], [natdynlink=true],
[x86_64-*-darwin*], [natdynlink=true],
[s390x*-*-linux*], [natdynlink=true],
[powerpc*-*-linux*], [natdynlink=true],
@ -977,6 +988,10 @@ AS_CASE([$host],
[arch=amd64; system=netbsd],
[x86_64-*-openbsd*],
[arch=amd64; system=openbsd],
[arm64-*-darwin*],
[arch=arm64; system=macosx],
[aarch64-*-darwin*],
[arch=arm64; system=macosx],
[x86_64-*-darwin*],
[arch=amd64; system=macosx],
[x86_64-*-mingw32],
@ -1314,6 +1329,8 @@ AC_CHECK_FUNC([mkfifo], [AC_DEFINE([HAS_MKFIFO])])
AC_CHECK_FUNC([getcwd], [AC_DEFINE([HAS_GETCWD])])
AC_CHECK_DECL([system], [AC_DEFINE([HAS_SYSTEM])], [], [[#include <stdlib.h>]])
## utime
## Note: this was defined in config/s-nt.h but the autoconf macros do not
# seem to detect it properly on Windows so we hardcode the definition
@ -1843,8 +1860,8 @@ AS_IF([test x"$DEFAULT_STRING" = "xunsafe"],
oc_cflags="$common_cflags $internal_cflags"
oc_cppflags="$common_cppflags $internal_cppflags"
ocamlc_cflags="$common_cflags $sharedlib_cflags"
ocamlc_cppflags="$common_cppflags"
ocamlc_cflags="$common_cflags $sharedlib_cflags \$(CFLAGS)"
ocamlc_cppflags="$common_cppflags \$(CPPFLAGS)"
cclibs="$cclibs $mathlib"
AS_CASE([$host],

1
debugger/Makefile
View File

@ -27,7 +27,6 @@ CAMLC=$(BEST_OCAMLC) -g -nostdlib -I $(ROOTDIR)/stdlib
COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \
-safe-string -strict-sequence -strict-formats
LINKFLAGS=-linkall -I $(UNIXDIR) -I $(DYNLINKDIR)
YACCFLAGS=
CAMLLEX=$(BEST_OCAMLLEX)
CAMLDEP=$(BEST_OCAMLDEP)
DEPFLAGS=-slash

2
debugger/time_travel.ml
View File

@ -181,7 +181,7 @@ let new_checkpoint_list checkpoint_count accepted rejected =
let (k, l) =
list_truncate2 (checkpoint_count - List.length accepted) rejected
in
(List.merge (fun {c_time = t1} {c_time = t2} -> compare t2 t1) accepted k,
(List.merge (fun t1 t2 -> compare t2.c_time t1.c_time) accepted k,
l)
(* Clean the checkpoint list. *)

23
driver/compenv.ml
View File

@ -458,17 +458,18 @@ let read_one_param ppf position name v =
let read_OCAMLPARAM ppf position =
try
let s = Sys.getenv "OCAMLPARAM" in
let (before, after) =
try
parse_args s
with SyntaxError s ->
print_error ppf s;
[],[]
in
List.iter (fun (name, v) -> read_one_param ppf position name v)
(match position with
Before_args -> before
| Before_compile _ | Before_link -> after)
if s <> "" then
let (before, after) =
try
parse_args s
with SyntaxError s ->
print_error ppf s;
[],[]
in
List.iter (fun (name, v) -> read_one_param ppf position name v)
(match position with
Before_args -> before
| Before_compile _ | Before_link -> after)
with Not_found -> ()
(* OCAMLPARAM passed as file *)

2
lambda/simplif.ml
View File

@ -615,7 +615,7 @@ let rec emit_tail_infos is_tail lambda =
| Default_tailcall -> ()
| Should_be_tailcall ->
(* Note: we may want to instead check the call_kind,
which takes [is_tail_native_heuristic] into accout.
which takes [is_tail_native_heuristic] into account.
But then this means getting different warnings depending
on whether the native or bytecode compiler is used. *)
if not is_tail

102
lambda/translcore.ml
View File

@ -733,25 +733,53 @@ and transl_apply ~scopes
sargs)
: Lambda.lambda)
and transl_function0
~scopes loc return untuplify_fn max_arity
and transl_curried_function
~scopes loc return
repr partial (param:Ident.t) cases =
let max_arity = Lambda.max_arity () in
let rec loop ~scopes loc return ~arity partial (param:Ident.t) cases =
match cases with
[{c_lhs=pat; c_guard=None;
c_rhs={exp_desc =
Texp_function
{ arg_label = _; param = param'; cases = cases';
partial = partial'; }; exp_env; exp_type;exp_loc}}]
when arity < max_arity ->
if Parmatch.inactive ~partial pat
then
let kind = value_kind pat.pat_env pat.pat_type in
let return_kind = function_return_value_kind exp_env exp_type in
let ((_, params, return), body) =
loop ~scopes exp_loc return_kind ~arity:(arity + 1)
partial' param' cases'
in
((Curried, (param, kind) :: params, return),
Matching.for_function ~scopes loc None (Lvar param)
[pat, body] partial)
else begin
begin match partial with
| Total ->
Location.prerr_warning pat.pat_loc
Match_on_mutable_state_prevent_uncurry
| Partial -> ()
end;
transl_tupled_function ~scopes ~arity
loc return repr partial param cases
end
| cases ->
transl_tupled_function ~scopes ~arity
loc return repr partial param cases
in
loop ~scopes loc return ~arity:1 partial param cases
and transl_tupled_function
~scopes ~arity loc return
repr partial (param:Ident.t) cases =
match cases with
[{c_lhs=pat; c_guard=None;
c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases;
partial = partial'; }; exp_env; exp_type} as exp}]
when max_arity > 1 && Parmatch.inactive ~partial pat ->
let kind = value_kind pat.pat_env pat.pat_type in
let return_kind = function_return_value_kind exp_env exp_type in
let ((_, params, return), body) =
transl_function0 ~scopes exp.exp_loc return_kind false (max_arity - 1)
repr partial' param' cases
in
((Curried, (param, kind) :: params, return),
Matching.for_function ~scopes loc None (Lvar param)
[pat, body] partial)
| {c_lhs={pat_desc = Tpat_tuple pl}} :: _
when untuplify_fn && List.length pl <= max_arity ->
when !Clflags.native_code
&& arity = 1
&& List.length pl <= (Lambda.max_arity ()) ->
begin try
let size = List.length pl in
let pats_expr_list =
@ -783,28 +811,30 @@ and transl_function0
((Tupled, tparams, return),
Matching.for_tupled_function ~scopes loc params
(transl_tupled_cases ~scopes pats_expr_list) partial)
with Matching.Cannot_flatten ->
((Curried, [param, Pgenval], return),
Matching.for_function ~scopes loc repr (Lvar param)
(transl_cases ~scopes cases) partial)
with Matching.Cannot_flatten ->
transl_function0 ~scopes loc return repr partial param cases
end
| {c_lhs=pat} :: other_cases ->
let kind =
| _ -> transl_function0 ~scopes loc return repr partial param cases
and transl_function0
~scopes loc return
repr partial (param:Ident.t) cases =
let kind =
match cases with
| [] ->
(* With Camlp4, a pattern matching might be empty *)
Pgenval
| {c_lhs=pat} :: other_cases ->
(* All the patterns might not share the same types. We must take the
union of the patterns types *)
List.fold_left (fun k {c_lhs=pat} ->
Typeopt.value_kind_union k
(value_kind pat.pat_env pat.pat_type))
Typeopt.value_kind_union k
(value_kind pat.pat_env pat.pat_type))
(value_kind pat.pat_env pat.pat_type) other_cases
in
((Curried, [param, kind], return),
Matching.for_function ~scopes loc repr (Lvar param)
(transl_cases ~scopes cases) partial)
| [] ->
(* With Camlp4, a pattern matching might be empty *)
((Curried, [param, Pgenval], return),
Matching.for_function ~scopes loc repr (Lvar param)
(transl_cases ~scopes cases) partial)
in
((Curried, [param, kind], return),
Matching.for_function ~scopes loc repr (Lvar param)
(transl_cases ~scopes cases) partial)
and transl_function ~scopes e param cases partial =
let ((kind, params, return), body) =
@ -812,8 +842,7 @@ and transl_function ~scopes e param cases partial =
(function repr ->
let pl = push_defaults e.exp_loc [] cases partial in
let return_kind = function_return_value_kind e.exp_env e.exp_type in
transl_function0 ~scopes e.exp_loc return_kind
!Clflags.native_code (Lambda.max_arity())
transl_curried_function ~scopes e.exp_loc return_kind
repr partial param pl)
in
let attr = default_function_attribute in
@ -1107,8 +1136,7 @@ and transl_letop ~scopes loc env let_ ands param case partial =
let (kind, params, return), body =
event_function ~scopes case.c_rhs
(function repr ->
transl_function0 ~scopes case.c_rhs.exp_loc return_kind
!Clflags.native_code (Lambda.max_arity())
transl_curried_function ~scopes case.c_rhs.exp_loc return_kind
repr partial param [case])
in
let attr = default_function_attribute in

3
lex/Makefile
View File

@ -27,7 +27,6 @@ CAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt$(EXE) -nostdlib -I $(ROOTDIR)/stdlib
COMPFLAGS = -absname -w +a-4-9-41-42-44-45-48 -warn-error A \
-safe-string -strict-sequence -strict-formats -bin-annot
LINKFLAGS =
YACCFLAGS = -v
CAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex
CAMLDEP = $(BOOT_OCAMLC) -depend
DEPFLAGS = -slash
@ -56,7 +55,7 @@ clean::
rm -f *.cmo *.cmi *.cmx *.cmt *.cmti *.o *.obj
parser.ml parser.mli: parser.mly
$(CAMLYACC) $(YACCFLAGS) parser.mly
$(CAMLYACC) -v parser.mly
clean::
rm -f parser.ml parser.mli parser.output

6
man/ocamlc.m
View File

@ -960,6 +960,10 @@ mutually recursive types.
67
\ \ Unused functor parameter.
68
\ \ Pattern-matching depending on mutable state prevents the remaining
arguments from being uncurried.
The letters stand for the following sets of warnings. Any letter not
mentioned here corresponds to the empty set.
@ -1013,7 +1017,7 @@ mentioned here corresponds to the empty set.
.IP
The default setting is
.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-30\-32..42\-44\-45\-48\-50\-60\-66 .
.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-30\-32..42\-44\-45\-48\-50\-60\-66\-67\-68 .
Note that warnings
.BR 5 \ and \ 10
are not always triggered, depending on the internals of the type checker.

1
manual/manual/library/stdlib-blurb.etex
View File

@ -46,6 +46,7 @@ the above 4 modules \\
"Int" & p.~\pageref{Int} & integer values \\
"Option" & p.~\pageref{Option} & option values \\
"Result" & p.~\pageref{Result} & result values \\
"Either" & p.~\pageref{Either} & either values \\
"Hashtbl" & p.~\pageref{Hashtbl} & hash tables and hash functions \\
"Random" & p.~\pageref{Random} & pseudo-random number generator \\
"Set" & p.~\pageref{Set} & sets over ordered types \\

2
manual/manual/tutorials/lablexamples.etex
View File

@ -42,7 +42,7 @@ Labels obey the same rules as other identifiers in OCaml, that is you
cannot use a reserved keyword (like "in" or "to") as label.
Formal parameters and arguments are matched according to their
respective labels\footnote{This correspond to the commuting label mode
respective labels\footnote{This corresponds to the commuting label mode
of Objective Caml 3.00 through 3.02, with some additional flexibility
on total applications. The so-called classic mode ("-nolabels"
options) is now deprecated for normal use.}, the absence of label

8
ocamldoc/odoc_sig.ml
View File

@ -388,8 +388,14 @@ module Analyser =
| Cstr_record l ->
Cstr_record (List.map (get_field env name_comment_list) l)
in
let vc_name = match constructor_name with
| "::" ->
(* The only infix constructor is always printed (::) *)
"(::)"
| s -> s
in
{
vc_name = constructor_name ;
vc_name;
vc_args;
vc_ret = Option.map (Odoc_env.subst_type env) ret_type;
vc_text = comment_opt

10
ocamltest/.depend
View File

@ -346,12 +346,20 @@ ocamltest_config.cmx : \
ocamltest_config.cmi
ocamltest_config.cmi :
ocamltest_stdlib.cmo : \
ocamltest_unix.cmi \
ocamltest_config.cmi \
ocamltest_stdlib.cmi
ocamltest_stdlib.cmx : \
ocamltest_unix.cmx \
ocamltest_config.cmx \
ocamltest_stdlib.cmi
ocamltest_stdlib.cmi :
ocamltest_stdlib.cmi : \
ocamltest_unix.cmi
ocamltest_unix.cmo : \
ocamltest_unix.cmi
ocamltest_unix.cmx : \
ocamltest_unix.cmi
ocamltest_unix.cmi :
options.cmo : \
variables.cmi \
tests.cmi \

42
ocamltest/Makefile
View File

@ -33,8 +33,16 @@ else
endif
ifeq "$(filter $(UNIXLIB),$(OTHERLIBRARIES))" ""
ocamltest_unix := dummy
unix_name :=
unix_path :=
unix := None
unix_include :=
else
ocamltest_unix := real
unix_name := unix
unix_path := $(ROOTDIR)/otherlibs/$(UNIXLIB)
unix_include := -I $(unix_path) $(EMPTY)
ifeq "$(UNIX_OR_WIN32)" "win32"
unix := Some false
else
@ -97,8 +105,8 @@ endif
core := \
$(run_source) run_stubs.c \
ocamltest_stdlib_stubs.c \
ocamltest_config.mli ocamltest_config.ml.in \
ocamltest_unix.mli ocamltest_unix.ml \
ocamltest_stdlib.mli ocamltest_stdlib.ml \
run_command.mli run_command.ml \
filecompare.mli filecompare.ml \
@ -166,6 +174,7 @@ parsers := $(filter %.mly,$(sources))
config_files := $(filter %.ml.in,$(sources))
dependencies_generated_prereqs := \
ocamltest_unix.ml \
$(config_files:.ml.in=.ml) \
$(lexers:.mll=.ml) \
$(parsers:.mly=.mli) $(parsers:.mly=.ml)
@ -185,9 +194,9 @@ flags := -g -nostdlib $(include_directories) \
-strict-sequence -safe-string -strict-formats \
-w +a-4-9-41-42-44-45-48 -warn-error A
ocamlc := $(BEST_OCAMLC) $(flags)
ocamlc = $(BEST_OCAMLC) $(flags)
ocamlopt := $(BEST_OCAMLOPT) $(flags)
ocamlopt = $(BEST_OCAMLOPT) $(flags)
ocamldep := $(BEST_OCAMLDEP)
depflags := -slash
@ -210,26 +219,29 @@ opt.opt: allopt
compdeps_names=ocamlcommon ocamlbytecomp
compdeps_paths=$(addprefix $(ROOTDIR)/compilerlibs/,$(compdeps_names))
compdeps_byte=$(addsuffix .cma,$(compdeps_paths))
compdeps_opt=$(addsuffix .cmxa,$(compdeps_paths))
deps_paths=$(compdeps_paths) $(addprefix $(unix_path)/,$(unix_name))
deps_byte=$(addsuffix .cma,$(deps_paths))
deps_opt=$(addsuffix .cmxa,$(deps_paths))
$(eval $(call PROGRAM_SYNONYM,ocamltest))
ocamltest$(EXE): $(compdeps_byte) $(bytecode_modules)
$(ocamlc_cmd) -custom -o $@ $^
ocamltest_unix.%: flags+=$(unix_include) -opaque
%.cmo: %.ml $(compdeps_byte)
ocamltest$(EXE): $(deps_byte) $(bytecode_modules)
$(ocamlc_cmd) $(unix_include)-custom -o $@ $^
%.cmo: %.ml $(deps_byte)
$(ocamlc) -c $<
$(eval $(call PROGRAM_SYNONYM,ocamltest.opt))
ocamltest.opt$(EXE): $(compdeps_opt) $(native_modules)
$(ocamlopt_cmd) -o $@ $^
ocamltest.opt$(EXE): $(deps_opt) $(native_modules)
$(ocamlopt_cmd) $(unix_include)-o $@ $^
%.cmx: %.ml $(compdeps_opt)
%.cmx: %.ml $(deps_opt)
$(ocamlopt) -c $<
%.cmi: %.mli $(compdeps_byte)
%.cmi: %.mli $(deps_byte)
$(ocamlc) -c $<
%.ml %.mli: %.mly
@ -238,6 +250,10 @@ ocamltest.opt$(EXE): $(compdeps_opt) $(native_modules)
%.ml: %.mll
$(ocamllex) $(OCAMLLEX_FLAGS) $<
ocamltest_unix.ml: ocamltest_unix_$(ocamltest_unix).ml
echo '# 1 "$^"' > $@
cat $^ >> $@
ocamltest_config.ml: ocamltest_config.ml.in Makefile ../Makefile.config
sed $(call SUBST,AFL_INSTRUMENT) \
$(call SUBST,RUNTIMEI) \
@ -304,7 +320,7 @@ include $(addprefix $(DEPDIR)/, $(c_files:.c=.$(D)))
endif
$(DEPDIR)/%.$(D): %.c | $(DEPDIR)
$(DEP_CC) $(OC_CPPFLAGS) $< -MT '$*.$(O)' -MF $@
$(DEP_CC) $(OC_CPPFLAGS) $(CPPFLAGS) $< -MT '$*.$(O)' -MF $@
.PHONY: depend
depend: $(dependencies_generated_prereqs)

16
ocamltest/actions_helpers.ml
View File

@ -62,13 +62,25 @@ let files env = words_of_variable env Builtin_variables.files
let setup_symlinks test_source_directory build_directory files =
let symlink filename =
(* Emulate ln -sfT *)
let src = Filename.concat test_source_directory filename in
Sys.run_system_command "ln" ["-sf"; src; build_directory] in
let dst = Filename.concat build_directory filename in
let () =
if Sys.file_exists dst then
if Sys.win32 && Sys.is_directory dst then
(* Native symbolic links to directories don't disappear with unlink;
doing rmdir here is technically slightly more than ln -sfT would
do *)
Sys.rmdir dst
else
Sys.remove dst
in
Unix.symlink src dst in
let copy filename =
let src = Filename.concat test_source_directory filename in
let dst = Filename.concat build_directory filename in
Sys.copy_file src dst in
let f = if Sys.win32 then copy else symlink in
let f = if Unix.has_symlink () then symlink else copy in
Sys.make_directory build_directory;
List.iter f files

2
ocamltest/builtin_actions.ml
View File

@ -195,7 +195,7 @@ let naked_pointers = make
let has_symlink = make
"has_symlink"
(Actions_helpers.pass_or_skip (Sys.has_symlink () )
(Actions_helpers.pass_or_skip (Unix.has_symlink () )
"symlinks available"
"symlinks not available")

130
ocamltest/filecompare.ml
View File

@ -59,33 +59,103 @@ type files = {
output_filename : string;
}
let read_text_file lines_to_drop fn =
Sys.with_input_file ~bin:true fn @@ fun ic ->
let drop_cr s =
let l = String.length s in
if l > 0 && s.[l - 1] = '\r' then String.sub s 0 (l - 1)
else raise Exit
in
let rec drop k =
if k = 0 then
loop []
else
let stop = try ignore (input_line ic); false with End_of_file -> true in
if stop then [] else drop (k-1)
and loop acc =
match input_line ic with
| s -> loop (s :: acc)
| exception End_of_file ->
try List.rev_map drop_cr acc
with Exit -> List.rev acc
in
drop lines_to_drop
let last_is_cr s =
let l = String.length s in
l > 0 && s.[l - 1] = '\r'
let compare_text_files dropped_lines file1 file2 =
if read_text_file 0 file1 = read_text_file dropped_lines file2 then
Same
else
Different
(* Returns last character of an input file. Fails for an empty file. *)
let last_char ic =
seek_in ic (in_channel_length ic - 1);
input_char ic
(* [line_seq_of_in_channel ~normalise ic first_line] constructs a sequence of
the lines of [ic] where [first_line] is the already read first line of [ic].
Strings include the line terminator and CRLF is normalised to LF if
[normalise] is [true]. The sequence raises [Exit] if normalise is [true] and
a terminated line is encountered which does not end CRLF. The final line of
the sequence only includes a terminator if it is present in the file (and a
terminating CR is never normalised if not strictly followed by LF). *)
let line_seq_of_in_channel ~normalise ic =
let normalise =
if normalise then
fun s ->
if last_is_cr s then
String.sub s 0 (String.length s - 1)
else
raise Exit
else
Fun.id
in
let rec read_line last () =
(* Read the next line to determine if the last line ended with LF *)
match input_line ic with
| line ->
Seq.Cons (normalise last ^ "\n", read_line line)
| exception End_of_file ->
(* EOF reached - seek the last character to determine if the final
line ends in LF *)
let last =
if last_char ic = '\n' then
normalise last ^ "\n"
else
last
in
Seq.Cons (last, Seq.empty)
in
read_line
let compare_text_files ignored_lines file1 file2 =
Sys.with_input_file ~bin:true file2 @@ fun ic2 ->
(* Get the first non-dropped line of file2 and determine if could be
CRLF-normalised (it can't be in any of the dropped lines didn't end
CRLF. *)
let (crlf_endings2, line2, reached_end_file2) =
let rec loop crlf_endings2 k =
match input_line ic2 with
| line ->
let crlf_endings2 = crlf_endings2 && last_is_cr line in
if k = 0 then
(crlf_endings2, line, false)
else
loop crlf_endings2 (pred k)
| exception End_of_file ->
(false, "", true)
in
loop true ignored_lines
in
Sys.with_input_file ~bin:true file1 @@ fun ic1 ->
if reached_end_file2 then
(* We reached the end of file2 while ignoring lines, so only an empty
file can be identical, as in the binary comparison case. *)
if in_channel_length ic1 = 0 then
Same
else
Different
else
(* file2 has at least one non-ignored line *)
match input_line ic1 with
| exception End_of_file -> Different
| line1 ->
let crlf_endings1 = last_is_cr line1 in
(* If both files appear to have CRLF endings, then there's no need
to attempt to normalise either. *)
let seq1 =
let normalise = crlf_endings1 && not crlf_endings2 in
line_seq_of_in_channel ~normalise ic1 line1 in
let seq2 =
let normalise = crlf_endings2 && not crlf_endings1 in
line_seq_of_in_channel ~normalise ic2 line2 in
try
if Seq.equal seq1 seq2 then
Same
else
raise Exit
with Exit ->
(* Either the lines weren't equal, or the file which was being
normalised suddenly had a line which didn't end CRLF. In this
case, the files must differ since only one file is ever being
normalised, so the earlier lines differed too. *)
Different
(* Version of Stdlib.really_input which stops at EOF, rather than raising
an exception. *)
@ -161,13 +231,15 @@ let diff files =
let temporary_file = Filename.temp_file "ocamltest" "diff" in
let diff_commandline =
Filename.quote_command "diff" ~stdout:temporary_file
[ "-u";
[ "--strip-trailing-cr"; "-u";
files.reference_filename;
files.output_filename ]
in
let result =
if (Sys.command diff_commandline) = 2 then Stdlib.Error "diff"
else Ok (Sys.string_of_file temporary_file)
match Sys.command diff_commandline with
| 0 -> Ok "Inconsistent LF/CRLF line-endings"
| 2 -> Stdlib.Error "diff"
| _ -> Ok (Sys.string_of_file temporary_file)
in
Sys.force_remove temporary_file;
result

12
ocamltest/main.ml
View File

@ -152,9 +152,9 @@ let test_file test_filename =
let test_build_directory_prefix =
get_test_build_directory_prefix test_directory in
let clean_test_build_directory () =
ignore
(Sys.command
(Filename.quote_command "rm" ["-rf"; test_build_directory_prefix]))
try
Sys.rm_rf test_build_directory_prefix
with Sys_error _ -> ()
in
clean_test_build_directory ();
Sys.make_directory test_build_directory_prefix;
@ -221,6 +221,8 @@ let is_test s =
let ignored s =
s = "" || s.[0] = '_' || s.[0] = '.'
let sort_strings = List.sort String.compare
let find_test_dirs dir =
let res = ref [] in
let rec loop dir =
@ -236,7 +238,7 @@ let find_test_dirs dir =
if !contains_tests then res := dir :: !res
in
loop dir;
List.rev !res
sort_strings !res
let list_tests dir =
let res = ref [] in
@ -250,7 +252,7 @@ let list_tests dir =
end
) (Sys.readdir dir)
end;
List.rev !res
sort_strings !res
let () =
init_tests_to_skip()

147
ocamltest/ocaml_actions.ml
View File

@ -977,83 +977,80 @@ let run_test_program_in_toplevel (toplevel : Ocaml_toplevels.toplevel) log env =
(* This is a sub-optimal check - skip the test if any libraries requiring
C stubs are loaded. It would be better at this point to build a custom
toplevel. *)
let toplevel_can_run =
let toplevel_supports_dynamic_loading =
Config.supports_shared_libraries || backend <> Ocaml_backends.Bytecode
in
if not toplevel_can_run then
(Result.skip, env)
else
match cmas_need_dynamic_loading (directories env) libraries with
| Some (Error reason) ->
(Result.fail_with_reason reason, env)
| Some (Ok ()) ->
(Result.skip, env)
| None ->
let testfile = Actions_helpers.testfile env in
let expected_exit_status =
Ocaml_tools.expected_exit_status env (toplevel :> Ocaml_tools.tool) in
let compiler_output_variable = toplevel#output_variable in
let compiler = toplevel#compiler in
let compiler_name = compiler#name in
let modules_with_filetypes =
List.map Ocaml_filetypes.filetype (modules env) in
let (result, env) = compile_modules
compiler compiler_name compiler_output_variable
modules_with_filetypes log env in
if Result.is_pass result then begin
let what =
Printf.sprintf "Running %s in %s toplevel \
(expected exit status: %d)"
testfile
(Ocaml_backends.string_of_backend backend)
expected_exit_status in
Printf.fprintf log "%s\n%!" what;
let toplevel_name = toplevel#name in
let ocaml_script_as_argument =
match
Environments.lookup_as_bool
Ocaml_variables.ocaml_script_as_argument env
with
| None -> false
| Some b -> b
in
let commandline =
[
toplevel_name;
Ocaml_flags.toplevel_default_flags;
toplevel#flags;
Ocaml_flags.stdlib;
directory_flags env;
Ocaml_flags.include_toplevel_directory;
flags env;
libraries;
binary_modules backend env;
if ocaml_script_as_argument then testfile else "";
Environments.safe_lookup Builtin_variables.arguments env
] in
let exit_status =
if ocaml_script_as_argument
then Actions_helpers.run_cmd
~environment:default_ocaml_env
~stdout_variable:compiler_output_variable
~stderr_variable:compiler_output_variable
log env commandline
else Actions_helpers.run_cmd
~environment:default_ocaml_env
~stdin_variable:Builtin_variables.test_file
~stdout_variable:compiler_output_variable
~stderr_variable:compiler_output_variable
log env commandline
in
if exit_status=expected_exit_status
then (Result.pass, env)
else begin
let reason =
(Actions_helpers.mkreason
what (String.concat " " commandline) exit_status) in
(Result.fail_with_reason reason, env)
end
end else (result, env)
match cmas_need_dynamic_loading (directories env) libraries with
| Some (Error reason) ->
(Result.fail_with_reason reason, env)
| Some (Ok ()) when not toplevel_supports_dynamic_loading ->
(Result.skip, env)
| _ ->
let testfile = Actions_helpers.testfile env in
let expected_exit_status =
Ocaml_tools.expected_exit_status env (toplevel :> Ocaml_tools.tool) in
let compiler_output_variable = toplevel#output_variable in
let compiler = toplevel#compiler in
let compiler_name = compiler#name in
let modules_with_filetypes =
List.map Ocaml_filetypes.filetype (modules env) in
let (result, env) = compile_modules
compiler compiler_name compiler_output_variable
modules_with_filetypes log env in
if Result.is_pass result then begin
let what =
Printf.sprintf "Running %s in %s toplevel \
(expected exit status: %d)"
testfile
(Ocaml_backends.string_of_backend backend)
expected_exit_status in
Printf.fprintf log "%s\n%!" what;
let toplevel_name = toplevel#name in
let ocaml_script_as_argument =
match
Environments.lookup_as_bool
Ocaml_variables.ocaml_script_as_argument env
with
| None -> false
| Some b -> b
in
let commandline =
[
toplevel_name;
Ocaml_flags.toplevel_default_flags;
toplevel#flags;
Ocaml_flags.stdlib;
directory_flags env;
Ocaml_flags.include_toplevel_directory;
flags env;
libraries;
binary_modules backend env;
if ocaml_script_as_argument then testfile else "";
Environments.safe_lookup Builtin_variables.arguments env
] in
let exit_status =
if ocaml_script_as_argument
then Actions_helpers.run_cmd
~environment:default_ocaml_env
~stdout_variable:compiler_output_variable
~stderr_variable:compiler_output_variable
log env commandline
else Actions_helpers.run_cmd
~environment:default_ocaml_env
~stdin_variable:Builtin_variables.test_file
~stdout_variable:compiler_output_variable
~stderr_variable:compiler_output_variable
log env commandline
in
if exit_status=expected_exit_status
then (Result.pass, env)
else begin
let reason =
(Actions_helpers.mkreason
what (String.concat " " commandline) exit_status) in
(Result.fail_with_reason reason, env)
end
end else (result, env)
let ocaml = Actions.make
"ocaml"

53
ocamltest/ocamltest_stdlib.ml
View File

@ -15,7 +15,7 @@
(* A few extensions to OCaml's standard library *)
(* Pervaisive *)
module Unix = Ocamltest_unix
let input_line_opt ic =
try Some (input_line ic) with End_of_file -> None
@ -84,22 +84,37 @@ end
module Sys = struct
include Sys
let run_system_command prog args =
let command = Filename.quote_command prog args in
match Sys.command command with
| 0 -> ()
| _ as exitcode ->
Printf.eprintf "System command %s failed with status %d\n%!"
command exitcode;
exit 3
let erase_file path =
try Sys.remove path
with Sys_error _ when Sys.win32 && Ocamltest_config.libunix <> None ->
(* Deal with read-only attribute on Windows. Ignore any error from chmod
so that the message always come from Sys.remove *)
let () = try Unix.chmod path 0o666 with Sys_error _ -> () in
Sys.remove path
let mkdir dir =
if not (Sys.file_exists dir) then
run_system_command "mkdir" [dir]
let rm_rf path =
let rec erase path =
if Sys.is_directory path then begin
Array.iter (fun entry -> erase (Filename.concat path entry))
(Sys.readdir path);
Sys.rmdir path
end else erase_file path
in
try if Sys.file_exists path then erase path
with Sys_error err ->
raise (Sys_error (Printf.sprintf "Failed to remove %S (%s)" path err))
let rec make_directory dir =
if Sys.file_exists dir then ()
else (make_directory (Filename.dirname dir); mkdir dir)
else let () = make_directory (Filename.dirname dir) in
if not (Sys.file_exists dir) then
Sys.mkdir dir 0o777
else ()
let make_directory dir =
try make_directory dir
with Sys_error err ->
raise (Sys_error (Printf.sprintf "Failed to create %S (%s)" dir err))
let with_input_file ?(bin=false) x f =
let ic = (if bin then open_in_bin else open_in) x in
@ -161,8 +176,6 @@ module Sys = struct
let force_remove file =
if file_exists file then remove file
external has_symlink : unit -> bool = "caml_has_symlink"
let with_chdir path f =
let oldcwd = Sys.getcwd () in
Sys.chdir path;
@ -172,3 +185,13 @@ module Sys = struct
try Sys.getenv variable with Not_found -> default_value
let safe_getenv variable = getenv_with_default_value variable ""
end
module Seq = struct
include Seq
let rec equal s1 s2 =
match s1 (), s2 () with
| Nil, Nil -> true
| Cons(e1, s1), Cons(e2, s2) -> e1 = e2 && equal s1 s2
| _, _ -> false
end

13
ocamltest/ocamltest_stdlib.mli
View File

@ -46,18 +46,27 @@ end
module Sys : sig
include module type of Sys
val file_is_empty : string -> bool
val run_system_command : string -> string list -> unit
val make_directory : string -> unit
val rm_rf : string -> unit
val string_of_file : string -> string
val iter_lines_of_file : (string -> unit) -> string -> unit
val dump_file : out_channel -> ?prefix:string -> string -> unit
val copy_chan : in_channel -> out_channel -> unit
val copy_file : string -> string -> unit
val force_remove : string -> unit
val has_symlink : unit -> bool
val with_chdir : string -> (unit -> 'a) -> 'a
val getenv_with_default_value : string -> string -> string
val safe_getenv : string -> string
val with_input_file : ?bin:bool -> string -> (in_channel -> 'a) -> 'a
val with_output_file : ?bin:bool -> string -> (out_channel -> 'a) -> 'a
end
module Seq : sig
include module type of struct include Seq end
val equal : 'a t -> 'a t -> bool
end
module Unix : sig
include module type of Ocamltest_unix
end

154
ocamltest/ocamltest_stdlib_stubs.c
View File

@ -1,154 +0,0 @@
/**************************************************************************/
/* */
/* OCaml */
/* */
/* Sebastien Hinderer, projet Gallium, INRIA Paris */
/* */
/* Copyright 2018 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. */
/* */
/**************************************************************************/
/* Stubs for ocamltest's standard library */
#include <stdio.h>
#include <stdlib.h>
#include <caml/config.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/alloc.h>
/*
#include <caml/fail.h>
*/
#include <caml/signals.h>
#include <caml/osdeps.h>
#ifdef _WIN32
/*
* Windows Vista functions enabled
*/
#undef _WIN32_WINNT
#define _WIN32_WINNT 0x0600
#include <wtypes.h>
#include <winbase.h>
#include <process.h>
#include <sys/types.h>
// Developer Mode allows the creation of symlinks without elevation - see
// https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-createsymboliclinkw
static BOOL IsDeveloperModeEnabled()
{
HKEY hKey;
LSTATUS status;
DWORD developerModeRegistryValue, dwordSize = sizeof(DWORD);
status = RegOpenKeyExW(
HKEY_LOCAL_MACHINE,
L"SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\AppModelUnlock",
0,
KEY_READ | KEY_WOW64_64KEY,
&hKey
);
if (status != ERROR_SUCCESS) {
return FALSE;
}
status = RegQueryValueExW(
hKey,
L"AllowDevelopmentWithoutDevLicense",
NULL,
NULL,
(LPBYTE)&developerModeRegistryValue,
&dwordSize
);
RegCloseKey(hKey);
if (status != ERROR_SUCCESS) {
return FALSE;
}
return developerModeRegistryValue != 0;
}
#define luid_eq(l, r) (l.LowPart == r.LowPart && l.HighPart == r.HighPart)
CAMLprim value caml_has_symlink(value unit)
{
CAMLparam1(unit);
HANDLE hProcess = GetCurrentProcess();
BOOL result = FALSE;
if (IsDeveloperModeEnabled()) {
CAMLreturn(Val_true);
}
if (OpenProcessToken(hProcess, TOKEN_READ, &hProcess)) {
LUID seCreateSymbolicLinkPrivilege;
if (LookupPrivilegeValue(NULL,
SE_CREATE_SYMBOLIC_LINK_NAME,
&seCreateSymbolicLinkPrivilege)) {
DWORD length;
if (!GetTokenInformation(hProcess, TokenPrivileges, NULL, 0, &length)) {
if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
TOKEN_PRIVILEGES* privileges =
(TOKEN_PRIVILEGES*)caml_stat_alloc(length);
if (GetTokenInformation(hProcess,
TokenPrivileges,
privileges,
length,
&length)) {
DWORD count = privileges->PrivilegeCount;
if (count) {
LUID_AND_ATTRIBUTES* privs = privileges->Privileges;
while (count-- &&
!(result = luid_eq(privs->Luid,
seCreateSymbolicLinkPrivilege)))
privs++;
}
}
caml_stat_free(privileges);
}
}
}
CloseHandle(hProcess);
}
CAMLreturn(Val_bool(result));
}
#else /* _WIN32 */
#ifdef HAS_SYMLINK
CAMLprim value caml_has_symlink(value unit)
{
CAMLparam0();
CAMLreturn(Val_true);
}
#else /* HAS_SYMLINK */
CAMLprim value unix_symlink(value to_dir, value path1, value path2)
{ caml_invalid_argument("symlink not implemented"); }
CAMLprim value caml_has_symlink(value unit)
{
CAMLparam0();
CAMLreturn(Val_false);
}
#endif
#endif /* _WIN32 */

20
ocamltest/ocamltest_unix.mli Normal file
View File

@ -0,0 +1,20 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* David Allsopp, OCaml Labs, Cambridge. *)
(* *)
(* Copyright 2020 David Allsopp Ltd. *)
(* *)
(* 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. *)
(* *)
(**************************************************************************)
(** Functions imported from Unix. They are explicitly here to remove the
temptation to use the Unix module directly in ocamltest. *)
val has_symlink : unit -> bool
val symlink : ?to_dir:bool -> string -> string -> unit
val chmod : string -> int -> unit

18
ocamltest/ocamltest_unix_dummy.ml Normal file
View File

@ -0,0 +1,18 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* David Allsopp, OCaml Labs, Cambridge. *)
(* *)
(* Copyright 2020 David Allsopp Ltd. *)
(* *)
(* 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. *)
(* *)
(**************************************************************************)
(* Dummy implementations for when the Unix library isn't built *)
let has_symlink () = false
let symlink ?to_dir:_ _ _ = invalid_arg "symlink not available"
let chmod _ _ = invalid_arg "chmod not available"

29
ocamltest/ocamltest_unix_real.ml Normal file
View File

@ -0,0 +1,29 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* David Allsopp, OCaml Labs, Cambridge. *)
(* *)
(* Copyright 2020 David Allsopp Ltd. *)
(* *)
(* 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. *)
(* *)
(**************************************************************************)
(* Unix.has_symlink never raises *)
let has_symlink = Unix.has_symlink
(* Convert Unix_error to Sys_error *)
let wrap f x =
try f x
with Unix.Unix_error(err, fn_name, arg) ->
let msg =
Printf.sprintf "%s failed on %S with %s"
fn_name arg (Unix.error_message err)
in
raise (Sys_error msg)
let symlink ?to_dir source = wrap (Unix.symlink ?to_dir source)
let chmod file = wrap (Unix.chmod file)

2
ocamltest/run_stubs.c
View File

@ -71,8 +71,10 @@ static void logToChannel(void *voidchannel, const char *fmt, va_list ap)
if (text == NULL) return;
if (vsnprintf(text, length, fmt, ap) != length) goto end;
}
Lock(channel);
caml_putblock(channel, text, length);
caml_flush(channel);
Unlock(channel);
end:
free(text);
}

6
otherlibs/Makefile.otherlibs.common
View File

@ -24,6 +24,10 @@ CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
CAMLC := $(BEST_OCAMLC) -nostdlib -I $(ROOTDIR)/stdlib
CAMLOPT := $(BEST_OCAMLOPT) -nostdlib -I $(ROOTDIR)/stdlib
ifneq "$(CCOMPTYPE)" "msvc"
OC_CFLAGS += -g
endif
OC_CFLAGS += $(SHAREDLIB_CFLAGS) $(EXTRACFLAGS)
OC_CPPFLAGS += -I$(ROOTDIR)/runtime $(EXTRACPPFLAGS)
@ -140,4 +144,4 @@ endif
endif
$(DEPDIR)/%.$(D): %.c | $(DEPDIR)
$(DEP_CC) $(OC_CPPFLAGS) $< -MT '$*.$(O)' -MF $@
$(DEP_CC) $(OC_CPPFLAGS) $(CPPFLAGS) $< -MT '$*.$(O)' -MF $@

9
otherlibs/systhreads/Makefile
View File

@ -18,6 +18,10 @@ ROOTDIR=../..
include $(ROOTDIR)/Makefile.common
include $(ROOTDIR)/Makefile.best_binaries
ifneq "$(CCOMPTYPE)" "msvc"
OC_CFLAGS += -g
endif
OC_CFLAGS += $(SHAREDLIB_CFLAGS)
OC_CPPFLAGS += -I$(ROOTDIR)/runtime
@ -96,7 +100,8 @@ st_stubs.%.$(O): st_stubs.c
else
st_stubs.%.$(O): st_stubs.c $(RUNTIME_HEADERS) $(wildcard *.h)
endif
$(CC) -c $(OC_CFLAGS) $(OC_CPPFLAGS) $(OUTPUTOBJ)$@ $<
$(CC) -c $(OC_CFLAGS) $(CFLAGS) $(OC_CPPFLAGS) $(CPPFLAGS) \
$(OUTPUTOBJ)$@ $<
partialclean:
rm -f *.cm*
@ -158,7 +163,7 @@ endif
define GEN_RULE
$(DEPDIR)/%.$(1).$(D): %.c | $(DEPDIR)
$$(DEP_CC) $$(OC_CPPFLAGS) $$< -MT '$$*.$(1).$(O)' -MF $$@
$$(DEP_CC) $$(OC_CPPFLAGS) $$(CPPFLAGS) $$< -MT '$$*.$(1).$(O)' -MF $$@
endef
$(foreach object_type, b n, $(eval $(call GEN_RULE,$(object_type))))

2
otherlibs/systhreads/st_posix.h
View File

@ -437,6 +437,8 @@ value caml_thread_sigmask(value cmd, value sigs) /* ML */
retcode = pthread_sigmask(how, &set, &oldset);
caml_leave_blocking_section();
st_check_error(retcode, "Thread.sigmask");
/* Run any handlers for just-unmasked pending signals */
caml_process_pending_actions();
return st_encode_sigset(&oldset);
}

10
otherlibs/systhreads/st_stubs.c
View File

@ -253,15 +253,6 @@ static void caml_thread_leave_blocking_section(void)
caml_thread_restore_runtime_state();
}
static int caml_thread_try_leave_blocking_section(void)
{
/* Disable immediate processing of signals (PR#3659).
try_leave_blocking_section always fails, forcing the signal to be
recorded and processed at the next leave_blocking_section or
polling. */
return 0;
}
/* Hooks for I/O locking */
static void caml_io_mutex_free(struct channel *chan)
@ -496,7 +487,6 @@ CAMLprim value caml_thread_initialize(value unit) /* ML */
caml_scan_roots_hook = caml_thread_scan_roots;
caml_enter_blocking_section_hook = caml_thread_enter_blocking_section;
caml_leave_blocking_section_hook = caml_thread_leave_blocking_section;
caml_try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
#ifdef NATIVE_CODE
caml_termination_hook = st_thread_exit;
#endif

4
otherlibs/unix/channels.c
View File

@ -64,10 +64,6 @@ static int unix_check_stream_semantics(int fd)
}
}
/* From runtime/io.c. To be declared in <caml/io.h> ? */
extern value caml_ml_open_descriptor_in(value fd);
extern value caml_ml_open_descriptor_out(value fd);
CAMLprim value unix_inchannel_of_filedescr(value fd)
{
int err;

1
otherlibs/unix/kill.c
View File

@ -27,5 +27,6 @@ CAMLprim value unix_kill(value pid, value signal)
sig = caml_convert_signal_number(Int_val(signal));
if (kill(Int_val(pid), sig) == -1)
uerror("kill", Nothing);
caml_process_pending_actions();
return Val_unit;
}

12
otherlibs/unix/mkdir.c
View File

@ -13,9 +13,15 @@
/* */
/**************************************************************************/
#ifndef _WIN32
#include <sys/types.h>
#include <sys/stat.h>
#endif
#define CAML_INTERNALS
#include <caml/mlvalues.h>
#include <caml/osdeps.h>
#include <caml/misc.h>
#include <caml/memory.h>
#include <caml/signals.h>
#include "unixsupport.h"
@ -23,12 +29,12 @@
CAMLprim value unix_mkdir(value path, value perm)
{
CAMLparam2(path, perm);
char * p;
char_os * p;
int ret;
caml_unix_check_path(path, "mkdir");
p = caml_stat_strdup(String_val(path));
p = caml_stat_strdup_to_os(String_val(path));
caml_enter_blocking_section();
ret = mkdir(p, Int_val(perm));
ret = mkdir_os(p, Int_val(perm));
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1) uerror("mkdir", path);

3
otherlibs/unix/mmap.c
View File

@ -39,8 +39,7 @@
#endif
/* Defined in [mmap_ba.c] */
CAMLextern value
caml_unix_mapped_alloc(int flags, int num_dims, void * data, intnat * dim);
extern value caml_unix_mapped_alloc(int, int, void *, intnat *);
#if defined(HAS_MMAP)

2
otherlibs/unix/mmap_ba.c
View File

@ -24,7 +24,7 @@
/* Allocation of bigarrays for memory-mapped files.
This is the OS-independent part of [mmap.c]. */
CAMLextern void caml_ba_unmap_file(void * addr, uintnat len);
extern void caml_ba_unmap_file(void *, uintnat);
static void caml_ba_mapped_finalize(value v)
{

2
otherlibs/unix/signals.c
View File

@ -71,6 +71,8 @@ CAMLprim value unix_sigprocmask(value vaction, value vset)
caml_enter_blocking_section();
retcode = caml_sigmask_hook(how, &set, &oldset);
caml_leave_blocking_section();
/* Run any handlers for just-unmasked pending signals */
caml_process_pending_actions();
if (retcode != 0) unix_error(retcode, "sigprocmask", Nothing);
return encode_sigset(&oldset);
}

4
otherlibs/unix/sockopt.c
View File

@ -38,6 +38,9 @@
#ifndef SO_REUSEADDR
#define SO_REUSEADDR (-1)
#endif
#ifndef SO_REUSEPORT
#define SO_REUSEPORT (-1)
#endif
#ifndef SO_KEEPALIVE
#define SO_KEEPALIVE (-1)
#endif
@ -109,6 +112,7 @@ static struct socket_option sockopt_bool[] = {
{ SOL_SOCKET, SO_DEBUG },
{ SOL_SOCKET, SO_BROADCAST },
{ SOL_SOCKET, SO_REUSEADDR },
{ SOL_SOCKET, SO_REUSEPORT },
{ SOL_SOCKET, SO_KEEPALIVE },
{ SOL_SOCKET, SO_DONTROUTE },
{ SOL_SOCKET, SO_OOBINLINE },

1
otherlibs/unix/unix.ml
View File

@ -597,6 +597,7 @@ type socket_bool_option =
SO_DEBUG
| SO_BROADCAST
| SO_REUSEADDR
| SO_REUSEPORT
| SO_KEEPALIVE
| SO_DONTROUTE
| SO_OOBINLINE

1
otherlibs/unix/unix.mli
View File

@ -1477,6 +1477,7 @@ type socket_bool_option =
SO_DEBUG (** Record debugging information *)
| SO_BROADCAST (** Permit sending of broadcast messages *)
| SO_REUSEADDR (** Allow reuse of local addresses for bind *)
| SO_REUSEPORT (** Allow reuse of address and port bindings *)
| SO_KEEPALIVE (** Keep connection active *)
| SO_DONTROUTE (** Bypass the standard routing algorithms *)
| SO_OOBINLINE (** Leave out-of-band data in line *)

1
otherlibs/unix/unixLabels.mli
View File

@ -1477,6 +1477,7 @@ type socket_bool_option = Unix.socket_bool_option =
SO_DEBUG (** Record debugging information *)
| SO_BROADCAST (** Permit sending of broadcast messages *)
| SO_REUSEADDR (** Allow reuse of local addresses for bind *)
| SO_REUSEPORT (** Allow reuse of address and port bindings *)
| SO_KEEPALIVE (** Keep connection active *)
| SO_DONTROUTE (** Bypass the standard routing algorithms *)
| SO_OOBINLINE (** Leave out-of-band data in line *)

4
otherlibs/win32unix/Makefile
View File

@ -22,7 +22,7 @@ WIN_FILES = accept.c bind.c channels.c close.c \
close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c envir.c \
getpeername.c getpid.c getsockname.c gettimeofday.c isatty.c \
link.c listen.c lockf.c lseek.c nonblock.c \
mkdir.c mmap.c open.c pipe.c read.c readlink.c rename.c \
mmap.c open.c pipe.c read.c readlink.c rename.c \
select.c sendrecv.c \
shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
symlink.c system.c times.c truncate.c unixsupport.c windir.c winwait.c \
@ -30,7 +30,7 @@ WIN_FILES = accept.c bind.c channels.c close.c \
# Files from the ../unix directory
UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
cstringv.c execv.c execve.c execvp.c \
cstringv.c execv.c execve.c execvp.c mkdir.c \
exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
getnameinfo.c getproto.c \
getserv.c gmtime.c mmap_ba.c putenv.c rmdir.c \

3
otherlibs/win32unix/mmap.c
View File

@ -30,8 +30,7 @@
do { win32_maperr(GetLastError()); uerror(func, arg); } while(0)
/* Defined in [mmap_ba.c] */
CAMLextern value
caml_unix_mapped_alloc(int flags, int num_dims, void * data, intnat * dim);
extern value caml_unix_mapped_alloc(int, int, void *, intnat *);
#ifndef INVALID_SET_FILE_POINTER
#define INVALID_SET_FILE_POINTER (-1)

4
otherlibs/win32unix/sockopt.c
View File

@ -21,6 +21,9 @@
#include "unixsupport.h"
#include "socketaddr.h"
#ifndef SO_REUSEPORT
#define SO_REUSEPORT (-1)
#endif
#ifndef IPPROTO_IPV6
#define IPPROTO_IPV6 (-1)
#endif
@ -47,6 +50,7 @@ static struct socket_option sockopt_bool[] = {
{ SOL_SOCKET, SO_DEBUG },
{ SOL_SOCKET, SO_BROADCAST },
{ SOL_SOCKET, SO_REUSEADDR },
{ SOL_SOCKET, SO_REUSEPORT },
{ SOL_SOCKET, SO_KEEPALIVE },
{ SOL_SOCKET, SO_DONTROUTE },
{ SOL_SOCKET, SO_OOBINLINE },

1
otherlibs/win32unix/unix.ml
View File

@ -729,6 +729,7 @@ type socket_bool_option =
SO_DEBUG
| SO_BROADCAST
| SO_REUSEADDR
| SO_REUSEPORT
| SO_KEEPALIVE
| SO_DONTROUTE
| SO_OOBINLINE

2
parsing/parse.mli
View File

@ -32,7 +32,7 @@ val pattern : Lexing.lexbuf -> Parsetree.pattern
val longident: Lexing.lexbuf -> Longident.t
(**
The function [longident] is guaranted to parse all subclasses
The function [longident] is guaranteed to parse all subclasses
of {!Longident.t} used in OCaml: values, constructors, simple or extended
module paths, and types or module types.

7
parsing/parser.mly
View File

@ -427,7 +427,8 @@ let text_str pos = Str.text (rhs_text pos)
let text_sig pos = Sig.text (rhs_text pos)
let text_cstr pos = Cf.text (rhs_text pos)
let text_csig pos = Ctf.text (rhs_text pos)
let text_def pos = [Ptop_def (Str.text (rhs_text pos))]
let text_def pos =
List.map (fun def -> Ptop_def [def]) (Str.text (rhs_text pos))
let extra_text startpos endpos text items =
match items with
@ -445,7 +446,9 @@ let extra_sig p1 p2 items = extra_text p1 p2 Sig.text items
let extra_cstr p1 p2 items = extra_text p1 p2 Cf.text items
let extra_csig p1 p2 items = extra_text p1 p2 Ctf.text items
let extra_def p1 p2 items =
extra_text p1 p2 (fun txt -> [Ptop_def (Str.text txt)]) items
extra_text p1 p2
(fun txt -> List.map (fun def -> Ptop_def [def]) (Str.text txt))
items
let extra_rhs_core_type ct ~pos =
let docs = rhs_info pos in

2
parsing/parsetree.mli
View File

@ -174,7 +174,7 @@ and row_field_desc =
(see 4.2 in the manual)
*)
| Rinherit of core_type
(* [ T ] *)
(* [ | t ] *)
and object_field = {
pof_desc : object_field_desc;

9
parsing/pprintast.ml
View File

@ -330,6 +330,9 @@ and core_type1 ctxt f x =
| _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l)
l longident_loc li
| Ptyp_variant (l, closed, low) ->
let first_is_inherit = match l with
| {Parsetree.prf_desc = Rinherit _}::_ -> true
| _ -> false in
let type_variant_helper f x =
match x.prf_desc with
| Rtag (l, _, ctl) ->
@ -348,7 +351,7 @@ and core_type1 ctxt f x =
| _ ->
pp f "%s@;%a"
(match (closed,low) with
| (Closed,None) -> ""
| (Closed,None) -> if first_is_inherit then " |" else ""
| (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
| (Open,_) -> ">")
(list type_variant_helper ~sep:"@;<1 -2>| ") l) l
@ -1584,9 +1587,9 @@ and extension_constructor ctxt f x =
| Pext_decl(l, r) ->
constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes)
| Pext_rebind li ->
pp f "%s%a@;=@;%a" x.pext_name.txt
(attributes ctxt) x.pext_attributes
pp f "%s@;=@;%a%a" x.pext_name.txt
longident_loc li
(attributes ctxt) x.pext_attributes
and case_list ctxt f l : unit =
let aux f {pc_lhs; pc_guard; pc_rhs} =

3
release-info/howto.md
View File

@ -234,6 +234,9 @@ opam switch create --repo=local,beta=git+https://github.com/ocaml/ocaml-beta-rep
```
The switch should build.
For a production release, you also need to create new opam files for the ocaml-manual and
ocaml-src packages.
## 6.1 Update OPAM dev packages after branching
Create a new ocaml/ocaml.$NEXT/opam file.

6
runtime/Makefile
View File

@ -349,13 +349,15 @@ ifneq "$(1)" "%"
# don't use -MG and instead include $(GENERATED_HEADERS) in the order only
# dependencies to ensure that they exist before dependencies are computed.
$(DEPDIR)/$(1).$(D): %.c | $(DEPDIR) $(GENERATED_HEADERS)
$$(DEP_CC) $$(OC_CPPFLAGS) $$< -MT '$$*$(subst %,,$(1)).$(O)' -MF $$@
$$(DEP_CC) $$(OC_CPPFLAGS) $$(CPPFLAGS) $$< -MT \
'$$*$(subst %,,$(1)).$(O)' -MF $$@
endif
$(1).$(O): %.c
else
$(1).$(O): %.c $(CONFIG_HEADERS) $(GENERATED_HEADERS) $(RUNTIME_HEADERS)
endif
$$(CC) -c $$(OC_CFLAGS) $$(OC_CPPFLAGS) $$(OUTPUTOBJ)$$@ $$<
$$(CC) -c $$(OC_CFLAGS) $$(CFLAGS) $$(OC_CPPFLAGS) $$(CPPFLAGS) \
$$(OUTPUTOBJ)$$@ $$<
endef
object_types := % %.b %.bd %.bi %.bpic

2
runtime/alloc.c
View File

@ -289,6 +289,6 @@ CAMLexport value caml_alloc_some(value v)
{
CAMLparam1(v);
value some = caml_alloc_small(1, 0);
Store_field(some, 0, v);
Field(some, 0) = v;
CAMLreturn(some);
}

221
runtime/arm64.S
View File

@ -24,10 +24,9 @@
#define TRAP_PTR x26
#define ALLOC_PTR x27
#define ALLOC_LIMIT x28
#define ARG x15
#define ADDITIONAL_ARG x8
#define TMP x16
#define TMP2 x17
#define ARG_DOMAIN_STATE_PTR x18
#define C_ARG_1 x0
#define C_ARG_2 x1
@ -51,24 +50,47 @@
#endif
.set domain_curr_field, 0
#if defined(SYS_macosx)
#define DOMAIN_STATE(c_type, name) DOMAIN_STATE c_type, name
.macro DOMAIN_STATE c_type, name
.equ domain_field_caml_\name, domain_curr_field
.set domain_curr_field, domain_curr_field + 1
.endm
#else
#define DOMAIN_STATE(c_type, name) \
.equ domain_field_caml_##name, domain_curr_field ; \
.set domain_curr_field, domain_curr_field + 1
#endif
#include "../runtime/caml/domain_state.tbl"
#undef DOMAIN_STATE
#define Caml_state(var) [x25, 8*domain_field_caml_##var]
#if defined(__PIC__)
/* Globals and labels */
#if defined(SYS_macosx)
#define G(sym) _##sym
#define L(lbl) L##lbl
#else
#define G(sym) sym
#define L(lbl) .L##lbl
#endif
#if defined(SYS_macosx)
#define ADDRGLOBAL(reg,symb) ADDRGLOBAL reg, symb
.macro ADDRGLOBAL reg, symb
adrp TMP2, G(\symb)@GOTPAGE
ldr \reg, [TMP2, G(\symb)@GOTPAGEOFF]
.endm
#elif defined(__PIC__)
#define ADDRGLOBAL(reg,symb) \
adrp TMP2, :got:symb; \
ldr reg, [TMP2, #:got_lo12:symb]
adrp TMP2, :got:G(symb); \
ldr reg, [TMP2, #:got_lo12:G(symb)]
#else
#define ADDRGLOBAL(reg,symb) \
adrp reg, symb; \
add reg, reg, #:lo12:symb
adrp reg, G(symb); \
add reg, reg, #:lo12:G(symb)
#endif
@ -80,28 +102,62 @@
#if defined(FUNCTION_SECTIONS)
TEXT_SECTION(caml_hot__code_begin)
.globl caml_hot__code_begin
caml_hot__code_begin:
.globl G(caml_hot__code_begin)
G(caml_hot__code_begin):
TEXT_SECTION(caml_hot__code_end)
.globl caml_hot__code_end
caml_hot__code_end:
.globl G(caml_hot__code_end)
G(caml_hot__code_end):
#endif
#if defined(SYS_macosx)
#define FUNCTION(name) FUNCTION name
.macro FUNCTION name
TEXT_SECTION(caml.##G(\name))
.align 2
.globl G(\name)
G(\name):
.endm
#define END_FUNCTION(name)
#define OBJECT(name) OBJECT name
.macro OBJECT name
.data
.align 3
.globl G(\name)
G(\name):
.endm
#define END_OBJECT(name)
#else
#define FUNCTION(name) \
TEXT_SECTION(caml.##name); \
.align 2; \
.globl name; \
.type name, %function; \
name:
.align 2; \
.globl G(name); \
.type G(name), %function; \
G(name):
#define END_FUNCTION(name) \
.size G(name), .-G(name)
#define OBJECT(name) \
.data; \
.align 3; \
.globl G(name); \
.type G(name), %object; \
G(name):
#define END_OBJECT(name) \
.size G(name), .-G(name)
#endif
/* Allocation functions and GC interface */
.globl caml_system__code_begin
caml_system__code_begin:
.globl G(caml_system__code_begin)
G(caml_system__code_begin):
FUNCTION(caml_call_gc)
CFI_STARTPROC
.Lcaml_call_gc:
L(caml_call_gc):
/* Record return address */
str x30, Caml_state(last_return_address)
/* Record lowest stack address */
@ -150,7 +206,7 @@ FUNCTION(caml_call_gc)
/* Save trap pointer in case an exception is raised during GC */
str TRAP_PTR, Caml_state(exception_pointer)
/* Call the garbage collector */
bl caml_garbage_collection
bl G(caml_garbage_collection)
/* Restore registers */
ldp x0, x1, [sp, 16]
ldp x2, x3, [sp, 32]
@ -183,46 +239,46 @@ FUNCTION(caml_call_gc)
ldp x29, x30, [sp], 400
ret
CFI_ENDPROC
.size caml_call_gc, .-caml_call_gc
END_FUNCTION(caml_call_gc)
FUNCTION(caml_alloc1)
CFI_STARTPROC
sub ALLOC_PTR, ALLOC_PTR, #16
cmp ALLOC_PTR, ALLOC_LIMIT
b.lo .Lcaml_call_gc
b.lo L(caml_call_gc)
ret
CFI_ENDPROC
.size caml_alloc1, .-caml_alloc1
END_FUNCTION(caml_alloc1)
FUNCTION(caml_alloc2)
CFI_STARTPROC
sub ALLOC_PTR, ALLOC_PTR, #24
cmp ALLOC_PTR, ALLOC_LIMIT
b.lo .Lcaml_call_gc
b.lo L(caml_call_gc)
ret
CFI_ENDPROC
.size caml_alloc2, .-caml_alloc2
END_FUNCTION(caml_alloc2)
FUNCTION(caml_alloc3)
CFI_STARTPROC
sub ALLOC_PTR, ALLOC_PTR, #32
cmp ALLOC_PTR, ALLOC_LIMIT
b.lo .Lcaml_call_gc
b.lo L(caml_call_gc)
ret
CFI_ENDPROC
.size caml_alloc3, .-caml_alloc3
END_FUNCTION(caml_alloc3)
FUNCTION(caml_allocN)
CFI_STARTPROC
sub ALLOC_PTR, ALLOC_PTR, ARG
sub ALLOC_PTR, ALLOC_PTR, ADDITIONAL_ARG
cmp ALLOC_PTR, ALLOC_LIMIT
b.lo .Lcaml_call_gc
b.lo L(caml_call_gc)
ret
CFI_ENDPROC
.size caml_allocN, .-caml_allocN
END_FUNCTION(caml_allocN)
/* Call a C function from OCaml */
/* Function to call is in ARG */
/* Function to call is in ADDITIONAL_ARG */
FUNCTION(caml_c_call)
CFI_STARTPROC
@ -237,27 +293,28 @@ FUNCTION(caml_c_call)
str ALLOC_PTR, Caml_state(young_ptr)
str TRAP_PTR, Caml_state(exception_pointer)
/* Call the function */
blr ARG
blr ADDITIONAL_ARG
/* Reload alloc ptr and alloc limit */
ldr ALLOC_PTR, Caml_state(young_ptr)
ldr ALLOC_LIMIT, Caml_state(young_limit)
/* Return */
ret x19
CFI_ENDPROC
.size caml_c_call, .-caml_c_call
END_FUNCTION(caml_c_call)
/* Start the OCaml program */
FUNCTION(caml_start_program)
CFI_STARTPROC
mov ARG_DOMAIN_STATE_PTR, C_ARG_1
ADDRGLOBAL(ARG, caml_program)
mov TMP, C_ARG_1
ADDRGLOBAL(TMP2, caml_program)
/* Code shared with caml_callback* */
/* Address of OCaml code to call is in ARG */
/* Address of domain state is in TMP */
/* Address of OCaml code to call is in TMP2 */
/* Arguments to the OCaml code are in x0...x7 */
.Ljump_to_caml:
L(jump_to_caml):
/* Set up stack frame and save callee-save registers */
CFI_OFFSET(29, -160)
CFI_OFFSET(30, -152)
@ -274,7 +331,7 @@ FUNCTION(caml_start_program)
stp d12, d13, [sp, 128]
stp d14, d15, [sp, 144]
/* Load domain state pointer from argument */
mov DOMAIN_STATE_PTR, ARG_DOMAIN_STATE_PTR
mov DOMAIN_STATE_PTR, TMP
/* Setup a callback link on the stack */
ldr x8, Caml_state(bottom_of_stack)
ldr x9, Caml_state(last_return_address)
@ -284,7 +341,7 @@ FUNCTION(caml_start_program)
str x10, [sp, 16]
/* Setup a trap frame to catch exceptions escaping the OCaml code */
ldr x8, Caml_state(exception_pointer)
adr x9, .Ltrap_handler
adr x9, L(trap_handler)
stp x8, x9, [sp, -16]!
CFI_ADJUST(16)
add TRAP_PTR, sp, #0
@ -292,14 +349,14 @@ FUNCTION(caml_start_program)
ldr ALLOC_PTR, Caml_state(young_ptr)
ldr ALLOC_LIMIT, Caml_state(young_limit)
/* Call the OCaml code */
blr ARG
.Lcaml_retaddr:
blr TMP2
L(caml_retaddr):
/* Pop the trap frame, restoring caml_exception_pointer */
ldr x8, [sp], 16
CFI_ADJUST(-16)
str x8, Caml_state(exception_pointer)
/* Pop the callback link, restoring the global variables */
.Lreturn_result:
L(return_result):
ldr x10, [sp, 16]
ldp x8, x9, [sp], 32
CFI_ADJUST(-32)
@ -323,24 +380,20 @@ FUNCTION(caml_start_program)
/* Return to C caller */
ret
CFI_ENDPROC
.type .Lcaml_retaddr, %function
.size .Lcaml_retaddr, .-.Lcaml_retaddr
.size caml_start_program, .-caml_start_program
END_FUNCTION(caml_start_program)
/* The trap handler */
.align 2
.Ltrap_handler:
L(trap_handler):
CFI_STARTPROC
/* Save exception pointer */
str TRAP_PTR, Caml_state(exception_pointer)
/* Encode exception bucket as an exception result */
orr x0, x0, #2
/* Return it */
b .Lreturn_result
b L(return_result)
CFI_ENDPROC
.type .Ltrap_handler, %function
.size .Ltrap_handler, .-.Ltrap_handler
/* Raise an exception from OCaml */
@ -362,12 +415,12 @@ FUNCTION(caml_raise_exn)
mov x1, x30 /* arg2: pc of raise */
add x2, sp, #0 /* arg3: sp of raise */
mov x3, TRAP_PTR /* arg4: sp of handler */
bl caml_stash_backtrace
bl G(caml_stash_backtrace)
/* Restore exception bucket and raise */
mov x0, x19
b 1b
CFI_ENDPROC
.size caml_raise_exn, .-caml_raise_exn
END_FUNCTION(caml_raise_exn)
/* Raise an exception from C */
@ -397,12 +450,12 @@ FUNCTION(caml_raise_exception)
ldr x1, Caml_state(last_return_address) /* arg2: pc of raise */
ldr x2, Caml_state(bottom_of_stack) /* arg3: sp of raise */
mov x3, TRAP_PTR /* arg4: sp of handler */
bl caml_stash_backtrace
bl G(caml_stash_backtrace)
/* Restore exception bucket and raise */
mov x0, x19
b 1b
CFI_ENDPROC
.size caml_raise_exception, .-caml_raise_exception
END_FUNCTION(caml_raise_exception)
/* Callback from C to OCaml */
@ -410,74 +463,64 @@ FUNCTION(caml_callback_asm)
CFI_STARTPROC
/* Initial shuffling of arguments */
/* (x0 = Caml_state, x1 = closure, [x2] = first arg) */
mov ARG_DOMAIN_STATE_PTR, x0
mov TMP, x0
ldr x0, [x2] /* x0 = first arg */
/* x1 = closure environment */
ldr ARG, [x1] /* code pointer */
b .Ljump_to_caml
ldr TMP2, [x1] /* code pointer */
b L(jump_to_caml)
CFI_ENDPROC
.type caml_callback_asm, %function
.size caml_callback_asm, .-caml_callback_asm
END_FUNCTION(caml_callback_asm)
TEXT_SECTION(caml_callback2_asm)
.align 2
.globl caml_callback2_asm
caml_callback2_asm:
FUNCTION(caml_callback2_asm)
CFI_STARTPROC
/* Initial shuffling of arguments */
/* (x0 = Caml_state, x1 = closure, [x2] = arg1, [x2,8] = arg2) */
mov ARG_DOMAIN_STATE_PTR, x0
mov TMP, x1
mov TMP, x0
mov TMP2, x1
ldp x0, x1, [x2, 0] /* x0 = first arg, x1 = second arg */
mov x2, TMP /* x2 = closure environment */
ADDRGLOBAL(ARG, caml_apply2)
b .Ljump_to_caml
mov x2, TMP2 /* x2 = closure environment */
ADDRGLOBAL(TMP2, caml_apply2)
b L(jump_to_caml)
CFI_ENDPROC
.type caml_callback2_asm, %function
.size caml_callback2_asm, .-caml_callback2_asm
END_FUNCTION(caml_callback2_asm)
TEXT_SECTION(caml_callback3_asm)
.align 2
.globl caml_callback3_asm
caml_callback3_asm:
FUNCTION(caml_callback3_asm)
CFI_STARTPROC
/* Initial shuffling of arguments */
/* (x0 = Caml_state, x1 = closure, [x2] = arg1, [x2,8] = arg2,
[x2,16] = arg3) */
mov ARG_DOMAIN_STATE_PTR, x0
mov TMP, x0
mov x3, x1 /* x3 = closure environment */
ldp x0, x1, [x2, 0] /* x0 = first arg, x1 = second arg */
ldr x2, [x2, 16] /* x2 = third arg */
ADDRGLOBAL(ARG, caml_apply3)
b .Ljump_to_caml
ADDRGLOBAL(TMP2, caml_apply3)
b L(jump_to_caml)
CFI_ENDPROC
.size caml_callback3_asm, .-caml_callback3_asm
END_FUNCTION(caml_callback3_asm)
FUNCTION(caml_ml_array_bound_error)
CFI_STARTPROC
/* Load address of [caml_array_bound_error] in ARG */
ADDRGLOBAL(ARG, caml_array_bound_error)
/* Load address of [caml_array_bound_error] in ADDITIONAL_ARG */
ADDRGLOBAL(ADDITIONAL_ARG, caml_array_bound_error)
/* Call that function */
b caml_c_call
b G(caml_c_call)
CFI_ENDPROC
.size caml_ml_array_bound_error, .-caml_ml_array_bound_error
END_FUNCTION(caml_ml_array_bound_error)
.globl caml_system__code_end
caml_system__code_end:
.globl G(caml_system__code_end)
G(caml_system__code_end):
/* GC roots for callback */
.data
.align 3
.globl caml_system__frametable
caml_system__frametable:
OBJECT(caml_system__frametable)
.quad 1 /* one descriptor */
.quad .Lcaml_retaddr /* return address into callback */
.quad L(caml_retaddr) /* return address into callback */
.short -1 /* negative frame size => use callback link */
.short 0 /* no roots */
.align 3
.type caml_system__frametable, %object
.size caml_system__frametable, .-caml_system__frametable
END_OBJECT(caml_system__frametable)
#if !defined(SYS_macosx)
/* Mark stack as non-executable */
.section .note.GNU-stack,"",%progbits
#endif

2
runtime/backtrace_byt.c
View File

@ -386,6 +386,7 @@ static void read_main_debug_info(struct debug_info *di)
if (caml_seek_optional_section(fd, &trail, "DBUG") != -1) {
chan = caml_open_descriptor_in(fd);
Lock(chan);
num_events = caml_getword(chan);
events = caml_alloc(num_events, 0);
@ -401,6 +402,7 @@ static void read_main_debug_info(struct debug_info *di)
/* Record event list */
Store_field(events, i, evl);
}
Unlock(chan);
caml_close_channel(chan);

2
runtime/caml/alloc.h
View File

@ -51,10 +51,8 @@ CAMLextern value caml_alloc_sprintf(const char * format, ...)
;
CAMLextern value caml_alloc_some(value);
CAMLextern value caml_alloc_with_profinfo (mlsize_t, tag_t, intnat);
CAMLextern value caml_alloc_small_with_my_or_given_profinfo (
mlsize_t, tag_t, uintnat);
CAMLextern value caml_alloc_small_with_profinfo (mlsize_t, tag_t, intnat);
typedef void (*final_fun)(value);
CAMLextern value caml_alloc_final (mlsize_t wosize,

4
runtime/caml/backtrace.h
View File

@ -96,7 +96,7 @@
* It might be called before GC initialization, so it shouldn't do OCaml
* allocation.
*/
CAMLprim value caml_record_backtrace(value vflag);
CAMLextern value caml_record_backtrace(value vflag);
#ifndef NATIVE_CODE
@ -122,7 +122,7 @@ extern void caml_stash_backtrace(value exn, value * sp, int reraise);
CAMLextern void caml_print_exception_backtrace(void);
void caml_init_backtrace(void);
CAMLexport void caml_init_debug_info(void);
CAMLextern void caml_init_debug_info(void);
#endif /* CAML_INTERNALS */

1
runtime/caml/compatibility.h
View File

@ -264,7 +264,6 @@
#define something_to_do caml_something_to_do
#define enter_blocking_section_hook caml_enter_blocking_section_hook
#define leave_blocking_section_hook caml_leave_blocking_section_hook
#define try_leave_blocking_section_hook caml_try_leave_blocking_section_hook
#define enter_blocking_section caml_enter_blocking_section
#define leave_blocking_section caml_leave_blocking_section
#define convert_signal_number caml_convert_signal_number

5
runtime/caml/custom.h
View File

@ -75,6 +75,11 @@ extern struct custom_operations *
caml_final_custom_operations(void (*fn)(value));
extern void caml_init_custom_operations(void);
extern struct custom_operations caml_nativeint_ops;
extern struct custom_operations caml_int32_ops;
extern struct custom_operations caml_int64_ops;
extern struct custom_operations caml_ba_ops;
#endif /* CAML_INTERNALS */
#ifdef __cplusplus

25
runtime/caml/io.h
View File

@ -56,6 +56,7 @@ enum {
CHANNEL_FLAG_BLOCKING_WRITE = 2, /* Don't release master lock when writing */
#endif
CHANNEL_FLAG_MANAGED_BY_GC = 4, /* Free and close using GC finalization */
CHANNEL_TEXT_MODE = 8, /* "Text mode" for Windows and Cygwin */
};
/* For an output channel:
@ -64,8 +65,19 @@ enum {
[offset] is the absolute position of the logical end of the buffer, [max].
*/
/* Functions and macros that can be called from C. Take arguments of
type struct channel *. No locking is performed. */
/* Creating and closing channels from C */
CAMLextern struct channel * caml_open_descriptor_in (int);
CAMLextern struct channel * caml_open_descriptor_out (int);
CAMLextern void caml_close_channel (struct channel *);
CAMLextern file_offset caml_channel_size (struct channel *);
CAMLextern void caml_seek_in (struct channel *, file_offset);
CAMLextern void caml_seek_out (struct channel *, file_offset);
CAMLextern file_offset caml_pos_in (struct channel *);
CAMLextern file_offset caml_pos_out (struct channel *);
/* I/O on channels from C. The channel must be locked (see below) before
calling any of the functions and macros below */
#define caml_putch(channel, ch) do{ \
if ((channel)->curr >= (channel)->end) caml_flush_partial(channel); \
@ -77,11 +89,8 @@ enum {
? caml_refill(channel) \
: (unsigned char) *((channel)->curr)++)
CAMLextern struct channel * caml_open_descriptor_in (int);
CAMLextern struct channel * caml_open_descriptor_out (int);
CAMLextern void caml_close_channel (struct channel *);
CAMLextern int caml_channel_binary_mode (struct channel *);
CAMLextern value caml_alloc_channel(struct channel *chan);
CAMLextern int caml_channel_binary_mode (struct channel *);
CAMLextern int caml_flush_partial (struct channel *);
CAMLextern void caml_flush (struct channel *);
@ -119,6 +128,10 @@ CAMLextern struct channel * caml_all_opened_channels;
#define Val_file_offset(fofs) caml_copy_int64(fofs)
#define File_offset_val(v) ((file_offset) Int64_val(v))
/* Primitives required by the Unix library */
CAMLextern value caml_ml_open_descriptor_in(value fd);
CAMLextern value caml_ml_open_descriptor_out(value fd);
#endif /* CAML_INTERNALS */
#endif /* CAML_IO_H */

4
runtime/caml/memory.h
View File

@ -57,11 +57,13 @@ CAMLextern void caml_free_dependent_memory (mlsize_t bsz);
CAMLextern void caml_modify (value *, value);
CAMLextern void caml_initialize (value *, value);
CAMLextern value caml_check_urgent_gc (value);
CAMLextern color_t caml_allocation_color (void *hp);
#ifdef CAML_INTERNALS
CAMLextern char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */
CAMLextern void caml_free_for_heap (char *mem);
CAMLextern void caml_disown_for_heap (char *mem);
CAMLextern int caml_add_to_heap (char *mem);
CAMLextern color_t caml_allocation_color (void *hp);
#endif /* CAML_INTERNALS */
CAMLextern int caml_huge_fallback_count;

10
runtime/caml/minor_gc.h
View File

@ -63,11 +63,13 @@ struct caml_custom_table CAML_TABLE_STRUCT(struct caml_custom_elt);
/* Table of custom blocks in the minor heap that contain finalizers
or GC speed parameters. */
CAMLextern void caml_minor_collection (void);
#ifdef CAML_INTERNALS
extern void caml_set_minor_heap_size (asize_t); /* size in bytes */
extern void caml_empty_minor_heap (void);
CAMLextern void caml_gc_dispatch (void);
CAMLextern void caml_minor_collection (void);
CAMLextern void garbage_collection (void); /* runtime/signals_nat.c */
extern void caml_gc_dispatch (void);
extern void caml_garbage_collection (void); /* runtime/signals_nat.c */
extern void caml_oldify_one (value, value *);
extern void caml_oldify_mopup (void);
@ -131,4 +133,6 @@ Caml_inline void add_to_custom_table (struct caml_custom_table *tbl, value v,
elt->max = max;
}
#endif /* CAML_INTERNALS */
#endif /* CAML_MINOR_GC_H */

2
runtime/caml/misc.h
View File

@ -259,6 +259,7 @@ extern double caml_log1p(double);
#define unlink_os _wunlink
#define rename_os caml_win32_rename
#define chdir_os _wchdir
#define mkdir_os(path, perm) _wmkdir(path)
#define getcwd_os _wgetcwd
#define system_os _wsystem
#define rmdir_os _wrmdir
@ -294,6 +295,7 @@ extern double caml_log1p(double);
#define unlink_os unlink
#define rename_os rename
#define chdir_os chdir
#define mkdir_os mkdir
#define getcwd_os getcwd
#define system_os system
#define rmdir_os rmdir

12
runtime/caml/osdeps.h
View File

@ -30,12 +30,16 @@ extern unsigned short caml_win32_revision;
#include "misc.h"
#include "memory.h"
#define Io_interrupted (-1)
/* Read at most [n] bytes from file descriptor [fd] into buffer [buf].
[flags] indicates whether [fd] is a socket
(bit [CHANNEL_FLAG_FROM_SOCKET] is set in this case, see [io.h]).
(This distinction matters for Win32, but not for Unix.)
Return number of bytes read.
In case of error, raises [Sys_error] or [Sys_blocked_io]. */
In case of error, raises [Sys_error] or [Sys_blocked_io].
If interrupted by a signal and no bytes where read, returns
Io_interrupted without raising. */
extern int caml_read_fd(int fd, int flags, void * buf, int n);
/* Write at most [n] bytes from buffer [buf] onto file descriptor [fd].
@ -43,7 +47,9 @@ extern int caml_read_fd(int fd, int flags, void * buf, int n);
(bit [CHANNEL_FLAG_FROM_SOCKET] is set in this case, see [io.h]).
(This distinction matters for Win32, but not for Unix.)
Return number of bytes written.
In case of error, raises [Sys_error] or [Sys_blocked_io]. */
In case of error, raises [Sys_error] or [Sys_blocked_io].
If interrupted by a signal and no bytes were written, returns
Io_interrupted without raising. */
extern int caml_write_fd(int fd, int flags, void * buf, int n);
/* Decompose the given path into a list of directories, and add them
@ -153,6 +159,8 @@ extern value caml_copy_string_of_utf16(const wchar_t *s);
extern int caml_win32_isatty(int fd);
CAMLextern void caml_expand_command_line (int *, wchar_t ***);
#endif /* _WIN32 */
#endif /* CAML_INTERNALS */

2
runtime/caml/printexc.h
View File

@ -26,7 +26,9 @@ extern "C" {
CAMLextern char * caml_format_exception (value);
#ifdef CAML_INTERNALS
CAMLnoreturn_start void caml_fatal_uncaught_exception (value) CAMLnoreturn_end;
#endif /* CAML_INTERNALS */
#ifdef __cplusplus
}

13
runtime/caml/roots.h
View File

@ -29,12 +29,15 @@ intnat caml_darken_all_roots_slice (intnat);
void caml_do_roots (scanning_action, int);
extern uintnat caml_incremental_roots_count;
#ifndef NATIVE_CODE
CAMLextern void caml_do_local_roots (scanning_action, value *, value *,
struct caml__roots_block *);
CAMLextern void caml_do_local_roots_byt (scanning_action, value *, value *,
struct caml__roots_block *);
#define caml_do_local_roots caml_do_local_roots_byt
#else
CAMLextern void caml_do_local_roots(scanning_action f, char * c_bottom_of_stack,
uintnat last_retaddr, value * v_gc_regs,
struct caml__roots_block * gc_local_roots);
CAMLextern void caml_do_local_roots_nat (
scanning_action f, char * c_bottom_of_stack,
uintnat last_retaddr, value * v_gc_regs,
struct caml__roots_block * gc_local_roots);
#define caml_do_local_roots caml_do_local_roots_nat
#endif
CAMLextern void (*caml_scan_roots_hook) (scanning_action);

4
runtime/caml/s.h.in
View File

@ -106,6 +106,10 @@
/* Define HAS_GETCWD if the library provides the getcwd() function. */
#undef HAS_SYSTEM
/* Define HAS_SYSTEM if the library provides the system() function. */
#undef HAS_UTIME
#undef HAS_UTIMES

5
runtime/caml/signals.h
View File

@ -31,6 +31,7 @@ extern "C" {
#endif
CAMLextern void caml_enter_blocking_section (void);
CAMLextern void caml_enter_blocking_section_no_pending (void);
CAMLextern void caml_leave_blocking_section (void);
CAMLextern void caml_process_pending_actions (void);
@ -39,6 +40,9 @@ CAMLextern void caml_process_pending_actions (void);
Memprof callbacks. Assumes that the runtime lock is held. Can raise
exceptions asynchronously into OCaml code. */
CAMLextern int caml_check_pending_actions (void);
/* Returns 1 if there are pending actions, 0 otherwise. */
CAMLextern value caml_process_pending_actions_exn (void);
/* Same as [caml_process_pending_actions], but returns the exception
if any (otherwise returns [Val_unit]). */
@ -86,7 +90,6 @@ void caml_setup_stack_overflow_detection(void);
CAMLextern void (*caml_enter_blocking_section_hook)(void);
CAMLextern void (*caml_leave_blocking_section_hook)(void);
CAMLextern int (*caml_try_leave_blocking_section_hook)(void);
#ifdef POSIX_SIGNALS
CAMLextern int (*caml_sigmask_hook)(int, const sigset_t *, sigset_t *);
#endif

2
runtime/caml/startup.h
View File

@ -21,8 +21,6 @@
#include "mlvalues.h"
#include "exec.h"
CAMLextern void caml_main(char_os **argv);
CAMLextern void caml_startup_code(
code_t code, asize_t code_size,
char *data, asize_t data_size,

1
runtime/caml/sys.h
View File

@ -41,7 +41,6 @@ CAMLnoreturn_start
CAMLextern value caml_sys_exit (value)
CAMLnoreturn_end;
extern double caml_sys_time_unboxed(value);
CAMLextern value caml_sys_get_argv(value unit);
extern char_os * caml_exe_name;

20
runtime/caml/weak.h
View File

@ -191,6 +191,7 @@ Caml_inline void caml_ephe_clean_partial (value v,
}
}
}
if (Tag_val (child) == Infix_tag) child -= Infix_offset_val (child);
if (Is_white_val (child) && !Is_young (child)){
release_data = 1;
Field (v, i) = caml_ephe_none;
@ -200,15 +201,16 @@ Caml_inline void caml_ephe_clean_partial (value v,
child = Field (v, 1);
if(child != caml_ephe_none){
if (release_data){
Field (v, 1) = caml_ephe_none;
} else {
/* If we scanned all the keys and the data field remains filled,
then the mark phase must have marked it */
CAMLassert( !(offset_start == 2 && offset_end == Wosize_hd (Hd_val(v))
&& Is_block (child) && Is_in_heap (child)
&& Is_white_val (child)));
}
if (release_data) Field (v, 1) = caml_ephe_none;
#ifdef DEBUG
else if (offset_start == 2 && offset_end == Wosize_hd (Hd_val(v)) &&
Is_block (child) && Is_in_heap (child)) {
if (Tag_val (child) == Infix_tag) child -= Infix_offset_val (child);
/* If we scanned all the keys and the data field remains filled,
then the mark phase must have marked it */
CAMLassert( !Is_white_val (child) );
}
#endif
}
}

5
runtime/custom.c
View File

@ -155,11 +155,6 @@ struct custom_operations * caml_final_custom_operations(final_fun fn)
return ops;
}
extern struct custom_operations caml_int32_ops,
caml_nativeint_ops,
caml_int64_ops,
caml_ba_ops;
void caml_init_custom_operations(void)
{
caml_register_custom_operations(&caml_int32_ops);

6
runtime/debugger.c
View File

@ -141,6 +141,12 @@ static void open_connection(void)
#endif
dbg_in = caml_open_descriptor_in(dbg_socket);
dbg_out = caml_open_descriptor_out(dbg_socket);
/* The code in this file does not bracket channel I/O operations with
Lock and Unlock, so fail if those are not no-ops. */
if (caml_channel_mutex_lock != NULL ||
caml_channel_mutex_unlock != NULL ||
caml_channel_mutex_unlock_exn != NULL)
caml_fatal_error("debugger does not support channel locks");
if (!caml_debugger_in_use) caml_putword(dbg_out, -1); /* first connection */
#ifdef _WIN32
caml_putword(dbg_out, _getpid());

2
runtime/fail_byt.c
View File

@ -34,6 +34,8 @@
CAMLexport void caml_raise(value v)
{
Unlock_exn();
CAMLassert(!Is_exception_result(v));
v = caml_process_pending_actions_with_root(v);
Caml_state->exn_bucket = v;
if (Caml_state->external_raise == NULL) caml_fatal_uncaught_exception(v);
siglongjmp(Caml_state->external_raise->buf, 1);

4
runtime/fail_nat.c
View File

@ -62,6 +62,10 @@ CAMLno_asan
void caml_raise(value v)
{
Unlock_exn();
CAMLassert(!Is_exception_result(v));
v = caml_process_pending_actions_with_root(v);
if (Caml_state->exception_pointer == NULL) caml_fatal_uncaught_exception(v);
while (Caml_state->local_roots != NULL &&

133
runtime/io.c
View File

@ -69,13 +69,35 @@ CAMLexport struct channel * caml_all_opened_channels = NULL;
/* Functions shared between input and output */
static void check_pending(struct channel *channel)
{
if (caml_check_pending_actions()) {
/* Temporarily unlock the channel, to ensure locks are not held
while any signal handlers (or finalisers, etc) are running */
Unlock(channel);
caml_process_pending_actions();
Lock(channel);
}
}
Caml_inline int descriptor_is_in_binary_mode(int fd)
{
#if defined(_WIN32) || defined(__CYGWIN__)
int oldmode = setmode(fd, O_TEXT);
if (oldmode != -1 && oldmode != O_TEXT) setmode(fd, oldmode);
return oldmode == O_BINARY;
#else
return 1;
#endif
}
CAMLexport struct channel * caml_open_descriptor_in(int fd)
{
struct channel * channel;
channel = (struct channel *) caml_stat_alloc(sizeof(struct channel));
channel->fd = fd;
caml_enter_blocking_section();
caml_enter_blocking_section_no_pending();
channel->offset = lseek(fd, 0, SEEK_CUR);
caml_leave_blocking_section();
channel->curr = channel->max = channel->buff;
@ -84,7 +106,7 @@ CAMLexport struct channel * caml_open_descriptor_in(int fd)
channel->revealed = 0;
channel->old_revealed = 0;
channel->refcount = 0;
channel->flags = 0;
channel->flags = descriptor_is_in_binary_mode(fd) ? 0 : CHANNEL_TEXT_MODE;
channel->next = caml_all_opened_channels;
channel->prev = NULL;
channel->name = NULL;
@ -128,33 +150,32 @@ CAMLexport void caml_close_channel(struct channel *channel)
CAMLexport file_offset caml_channel_size(struct channel *channel)
{
file_offset offset;
file_offset end;
file_offset here, end;
int fd;
check_pending(channel);
/* We extract data from [channel] before dropping the OCaml lock, in case
someone else touches the block. */
fd = channel->fd;
offset = channel->offset;
caml_enter_blocking_section();
end = lseek(fd, 0, SEEK_END);
if (end == -1 || lseek(fd, offset, SEEK_SET) != offset) {
caml_leave_blocking_section();
caml_sys_error(NO_ARG);
here = channel->flags & CHANNEL_TEXT_MODE ? -1 : channel->offset;
caml_enter_blocking_section_no_pending();
if (here == -1) {
here = lseek(fd, 0, SEEK_CUR);
if (here == -1) goto error;
}
end = lseek(fd, 0, SEEK_END);
if (end == -1) goto error;
if (lseek(fd, here, SEEK_SET) != here) goto error;
caml_leave_blocking_section();
return end;
error:
caml_leave_blocking_section();
caml_sys_error(NO_ARG);
}
CAMLexport int caml_channel_binary_mode(struct channel *channel)
{
#if defined(_WIN32) || defined(__CYGWIN__)
int oldmode = setmode(channel->fd, O_BINARY);
if (oldmode == O_TEXT) setmode(channel->fd, O_TEXT);
return oldmode == O_BINARY;
#else
return 1;
#endif
return channel->flags & CHANNEL_TEXT_MODE ? 0 : 1;
}
/* Output */
@ -167,12 +188,15 @@ CAMLexport int caml_channel_binary_mode(struct channel *channel)
CAMLexport int caml_flush_partial(struct channel *channel)
{
int towrite, written;
again:
check_pending(channel);
towrite = channel->curr - channel->buff;
CAMLassert (towrite >= 0);
if (towrite > 0) {
written = caml_write_fd(channel->fd, channel->flags,
channel->buff, towrite);
if (written == Io_interrupted) goto again;
channel->offset += written;
if (written < towrite)
memmove(channel->buff, channel->buff + written, towrite - written);
@ -202,7 +226,7 @@ CAMLexport void caml_putword(struct channel *channel, uint32_t w)
CAMLexport int caml_putblock(struct channel *channel, char *p, intnat len)
{
int n, free, towrite, written;
int n, free;
n = len >= INT_MAX ? INT_MAX : (int) len;
free = channel->end - channel->curr;
@ -215,13 +239,8 @@ CAMLexport int caml_putblock(struct channel *channel, char *p, intnat len)
/* Write request overflows buffer (or just fills it up): transfer whatever
fits to buffer and write the buffer */
memmove(channel->curr, p, free);
towrite = channel->end - channel->buff;
written = caml_write_fd(channel->fd, channel->flags,
channel->buff, towrite);
if (written < towrite)
memmove(channel->buff, channel->buff + written, towrite - written);
channel->offset += written;
channel->curr = channel->end - written;
channel->curr = channel->end;
caml_flush_partial(channel);
return free;
}
}
@ -240,7 +259,7 @@ CAMLexport void caml_really_putblock(struct channel *channel,
CAMLexport void caml_seek_out(struct channel *channel, file_offset dest)
{
caml_flush(channel);
caml_enter_blocking_section();
caml_enter_blocking_section_no_pending();
if (lseek(channel->fd, dest, SEEK_SET) != dest) {
caml_leave_blocking_section();
caml_sys_error(NO_ARG);
@ -256,19 +275,24 @@ CAMLexport file_offset caml_pos_out(struct channel *channel)
/* Input */
/* caml_do_read is exported for Cash */
CAMLexport int caml_do_read(int fd, char *p, unsigned int n)
int caml_do_read(int fd, char *p, unsigned int n)
{
return caml_read_fd(fd, 0, p, n);
int r;
do {
r = caml_read_fd(fd, 0, p, n);
} while (r == Io_interrupted);
return r;
}
CAMLexport unsigned char caml_refill(struct channel *channel)
{
int n;
again:
check_pending(channel);
n = caml_read_fd(channel->fd, channel->flags,
channel->buff, channel->end - channel->buff);
if (n == 0) caml_raise_end_of_file();
if (n == Io_interrupted) goto again;
else if (n == 0) caml_raise_end_of_file();
channel->offset += n;
channel->max = channel->buff + n;
channel->curr = channel->buff + 1;
@ -292,7 +316,8 @@ CAMLexport uint32_t caml_getword(struct channel *channel)
CAMLexport int caml_getblock(struct channel *channel, char *p, intnat len)
{
int n, avail, nread;
again:
check_pending(channel);
n = len >= INT_MAX ? INT_MAX : (int) len;
avail = channel->max - channel->curr;
if (n <= avail) {
@ -306,6 +331,7 @@ CAMLexport int caml_getblock(struct channel *channel, char *p, intnat len)
} else {
nread = caml_read_fd(channel->fd, channel->flags, channel->buff,
channel->end - channel->buff);
if (nread == Io_interrupted) goto again;
channel->offset += nread;
channel->max = channel->buff + nread;
if (n > nread) n = nread;
@ -331,11 +357,12 @@ CAMLexport intnat caml_really_getblock(struct channel *chan, char *p, intnat n)
CAMLexport void caml_seek_in(struct channel *channel, file_offset dest)
{
if (dest >= channel->offset - (channel->max - channel->buff) &&
dest <= channel->offset) {
if (dest >= channel->offset - (channel->max - channel->buff)
&& dest <= channel->offset
&& (channel->flags & CHANNEL_TEXT_MODE) == 0) {
channel->curr = channel->max - (channel->offset - dest);
} else {
caml_enter_blocking_section();
caml_enter_blocking_section_no_pending();
if (lseek(channel->fd, dest, SEEK_SET) != dest) {
caml_leave_blocking_section();
caml_sys_error(NO_ARG);
@ -351,11 +378,12 @@ CAMLexport file_offset caml_pos_in(struct channel *channel)
return channel->offset - (file_offset)(channel->max - channel->curr);
}
CAMLexport intnat caml_input_scan_line(struct channel *channel)
intnat caml_input_scan_line(struct channel *channel)
{
char * p;
int n;
again:
check_pending(channel);
p = channel->curr;
do {
if (p >= channel->max) {
@ -378,7 +406,8 @@ CAMLexport intnat caml_input_scan_line(struct channel *channel)
/* Fill the buffer as much as possible */
n = caml_read_fd(channel->fd, channel->flags,
channel->max, channel->end - channel->max);
if (n == 0) {
if (n == Io_interrupted) goto again;
else if (n == 0) {
/* End-of-file encountered. Return the number of characters in the
buffer, with negative sign since we haven't encountered
a newline. */
@ -396,8 +425,7 @@ CAMLexport intnat caml_input_scan_line(struct channel *channel)
objects into a heap-allocated object. Perform locking
and unlocking around the I/O operations. */
/* FIXME CAMLexport, but not in io.h exported for Cash ? */
CAMLexport void caml_finalize_channel(value vchan)
void caml_finalize_channel(value vchan)
{
struct channel * chan = Channel(vchan);
if ((chan->flags & CHANNEL_FLAG_MANAGED_BY_GC) == 0) return;
@ -545,7 +573,7 @@ CAMLprim value caml_ml_close_channel(value vchannel)
channel->curr = channel->max = channel->end;
if (do_syscall) {
caml_enter_blocking_section();
caml_enter_blocking_section_no_pending();
result = close(fd);
caml_leave_blocking_section();
}
@ -563,16 +591,28 @@ CAMLprim value caml_ml_close_channel(value vchannel)
#define EOVERFLOW ERANGE
#endif
static file_offset ml_channel_size(value vchannel)
{
CAMLparam1 (vchannel);
struct channel * channel = Channel(vchannel);
file_offset size;
Lock(channel);
size = caml_channel_size(Channel(vchannel));
Unlock(channel);
CAMLreturnT(file_offset, size);
}
CAMLprim value caml_ml_channel_size(value vchannel)
{
file_offset size = caml_channel_size(Channel(vchannel));
file_offset size = ml_channel_size(vchannel);
if (size > Max_long) { errno = EOVERFLOW; caml_sys_error(NO_ARG); }
return Val_long(size);
}
CAMLprim value caml_ml_channel_size_64(value vchannel)
{
return Val_file_offset(caml_channel_size(Channel(vchannel)));
return Val_file_offset(ml_channel_size(vchannel));
}
CAMLprim value caml_ml_set_binary_mode(value vchannel, value mode)
@ -590,6 +630,10 @@ CAMLprim value caml_ml_set_binary_mode(value vchannel, value mode)
#endif
if (setmode(channel->fd, Bool_val(mode) ? O_BINARY : O_TEXT) == -1)
caml_sys_error(NO_ARG);
if (Bool_val(mode))
channel->flags &= ~CHANNEL_TEXT_MODE;
else
channel->flags |= CHANNEL_TEXT_MODE;
#endif
return Val_unit;
}
@ -731,6 +775,8 @@ CAMLprim value caml_ml_input(value vchannel, value buff, value vstart,
int n, avail, nread;
Lock(channel);
again:
check_pending(channel);
/* We cannot call caml_getblock here because buff may move during
caml_read_fd */
start = Long_val(vstart);
@ -747,6 +793,7 @@ CAMLprim value caml_ml_input(value vchannel, value buff, value vstart,
} else {
nread = caml_read_fd(channel->fd, channel->flags, channel->buff,
channel->end - channel->buff);
if (nread == Io_interrupted) goto again;
channel->offset += nread;
channel->max = channel->buff + nread;
if (n > nread) n = nread;

5
runtime/main.c
View File

@ -22,15 +22,12 @@
#include "caml/mlvalues.h"
#include "caml/sys.h"
#include "caml/osdeps.h"
#include "caml/callback.h"
#ifdef _WIN32
#include <windows.h>
#endif
CAMLextern void caml_main (char_os **);
#ifdef _WIN32
CAMLextern void caml_expand_command_line (int *, wchar_t ***);
int wmain(int argc, wchar_t **argv)
#else
int main(int argc, char **argv)

4
runtime/major_gc.c
View File

@ -57,7 +57,7 @@ uintnat caml_dependent_size, caml_dependent_allocated;
double caml_extra_heap_resources;
uintnat caml_fl_wsz_at_phase_change = 0;
extern char *caml_fl_merge; /* Defined in freelist.c. */
extern value caml_fl_merge; /* Defined in freelist.c. */
static char *markhp, *chunk, *limit;
static double p_backlog = 0.0; /* backlog for the gc speedup parameter */
@ -586,7 +586,7 @@ static void sweep_slice (intnat work)
break;
case Caml_blue:
/* Only the blocks of the free-list are blue. See [freelist.c]. */
caml_fl_merge = Bp_hp (hp);
caml_fl_merge = (value) Bp_hp (hp);
break;
default: /* gray or black */
CAMLassert (Color_hd (hd) == Caml_black);

2
runtime/memory.c
View File

@ -455,7 +455,7 @@ void caml_shrink_heap (char *chunk)
caml_free_for_heap (chunk);
}
color_t caml_allocation_color (void *hp)
CAMLexport color_t caml_allocation_color (void *hp)
{
if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean ||
(caml_gc_phase == Phase_sweep && (char *)hp >= (char *)caml_gc_sweep_hp)){

Some files were not shown because too many files have changed in this diff Show More