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

Merge branch 'trunk' into trunk

master
John Whitington 2020-07-27 13:53:52 +01:00 committed by GitHub
parent 33fdfffd5f ea16b1c837
commit d0263ac0e4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
265 changed files with 6461 additions and 4457 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
.depend
View File

@ -3,6 +3,11 @@ utils/arg_helper.cmo : \
utils/arg_helper.cmx : \
utils/arg_helper.cmi
utils/arg_helper.cmi :
utils/binutils.cmo : \
utils/binutils.cmi
utils/binutils.cmx : \
utils/binutils.cmi
utils/binutils.cmi :
utils/build_path_prefix_map.cmo : \
utils/build_path_prefix_map.cmi
utils/build_path_prefix_map.cmx : \
@ -1131,7 +1136,6 @@ typing/typeclass.cmo : \
typing/path.cmi \
parsing/parsetree.cmi \
typing/oprint.cmi \
utils/misc.cmi \
parsing/longident.cmi \
parsing/location.cmi \
typing/includeclass.cmi \
@ -1159,7 +1163,6 @@ typing/typeclass.cmx : \
typing/path.cmx \
parsing/parsetree.cmi \
typing/oprint.cmx \
utils/misc.cmx \
parsing/longident.cmx \
parsing/location.cmx \
typing/includeclass.cmx \
@ -1859,10 +1862,12 @@ bytecomp/bytesections.cmi :
bytecomp/dll.cmo : \
utils/misc.cmi \
utils/config.cmi \
utils/binutils.cmi \
bytecomp/dll.cmi
bytecomp/dll.cmx : \
utils/misc.cmx \
utils/config.cmx \
utils/binutils.cmx \
bytecomp/dll.cmi
bytecomp/dll.cmi :
bytecomp/emitcode.cmo : \
@ -2271,6 +2276,7 @@ asmcomp/cmm.cmo : \
lambda/debuginfo.cmi \
middle_end/backend_var.cmi \
parsing/asttypes.cmi \
asmcomp/arch.cmo \
asmcomp/cmm.cmi
asmcomp/cmm.cmx : \
utils/targetint.cmx \
@ -2278,6 +2284,7 @@ asmcomp/cmm.cmx : \
lambda/debuginfo.cmx \
middle_end/backend_var.cmx \
parsing/asttypes.cmi \
asmcomp/arch.cmx \
asmcomp/cmm.cmi
asmcomp/cmm.cmi : \
utils/targetint.cmi \
@ -2728,7 +2735,8 @@ asmcomp/proc.cmx : \
asmcomp/proc.cmi
asmcomp/proc.cmi : \
asmcomp/reg.cmi \
asmcomp/mach.cmi
asmcomp/mach.cmi \
asmcomp/cmm.cmi
asmcomp/reg.cmo : \
asmcomp/cmm.cmi \
middle_end/backend_var.cmi \
@ -5856,36 +5864,9 @@ driver/errors.cmx : \
driver/errors.cmi
driver/errors.cmi :
driver/main.cmo : \
utils/warnings.cmi \
utils/profile.cmi \
driver/makedepend.cmi \
driver/main_args.cmi \
parsing/location.cmi \
utils/config.cmi \
driver/compmisc.cmi \
driver/compile.cmi \
driver/compenv.cmi \
utils/clflags.cmi \
bytecomp/bytepackager.cmi \
bytecomp/bytelink.cmi \
bytecomp/bytelibrarian.cmi \
driver/main.cmi
driver/maindriver.cmi
driver/main.cmx : \
utils/warnings.cmx \
utils/profile.cmx \
driver/makedepend.cmx \
driver/main_args.cmx \
parsing/location.cmx \
utils/config.cmx \
driver/compmisc.cmx \
driver/compile.cmx \
driver/compenv.cmx \
utils/clflags.cmx \
bytecomp/bytepackager.cmx \
bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx \
driver/main.cmi
driver/main.cmi :
driver/maindriver.cmx
driver/main_args.cmo : \
utils/warnings.cmi \
utils/profile.cmi \
@ -5903,6 +5884,37 @@ driver/main_args.cmx : \
utils/clflags.cmx \
driver/main_args.cmi
driver/main_args.cmi :
driver/maindriver.cmo : \
utils/warnings.cmi \
utils/profile.cmi \
driver/makedepend.cmi \
driver/main_args.cmi \
parsing/location.cmi \
utils/config.cmi \
driver/compmisc.cmi \
driver/compile.cmi \
driver/compenv.cmi \
utils/clflags.cmi \
bytecomp/bytepackager.cmi \
bytecomp/bytelink.cmi \
bytecomp/bytelibrarian.cmi \
driver/maindriver.cmi
driver/maindriver.cmx : \
utils/warnings.cmx \
utils/profile.cmx \
driver/makedepend.cmx \
driver/main_args.cmx \
parsing/location.cmx \
utils/config.cmx \
driver/compmisc.cmx \
driver/compile.cmx \
driver/compenv.cmx \
utils/clflags.cmx \
bytecomp/bytepackager.cmx \
bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx \
driver/maindriver.cmi
driver/maindriver.cmi :
driver/makedepend.cmo : \
driver/pparse.cmi \
parsing/parsetree.cmi \
@ -5972,6 +5984,10 @@ driver/opterrors.cmx : \
driver/opterrors.cmi
driver/opterrors.cmi :
driver/optmain.cmo : \
driver/optmaindriver.cmi
driver/optmain.cmx : \
driver/optmaindriver.cmx
driver/optmaindriver.cmo : \
utils/warnings.cmi \
utils/profile.cmi \
asmcomp/proc.cmi \
@ -5990,8 +6006,8 @@ driver/optmain.cmo : \
asmcomp/asmlink.cmi \
asmcomp/asmlibrarian.cmi \
asmcomp/arch.cmo \
driver/optmain.cmi
driver/optmain.cmx : \
driver/optmaindriver.cmi
driver/optmaindriver.cmx : \
utils/warnings.cmx \
utils/profile.cmx \
asmcomp/proc.cmx \
@ -6010,8 +6026,8 @@ driver/optmain.cmx : \
asmcomp/asmlink.cmx \
asmcomp/asmlibrarian.cmx \
asmcomp/arch.cmx \
driver/optmain.cmi
driver/optmain.cmi :
driver/optmaindriver.cmi
driver/optmaindriver.cmi :
driver/pparse.cmo : \
utils/warnings.cmi \
utils/profile.cmi \

6
.gitattributes vendored
View File

@ -57,7 +57,7 @@ tools/mantis2gh_stripped.csv typo.missing-header
/.mailmap typo.long-line typo.missing-header typo.non-ascii
/.merlin typo.missing-header
/Changes typo.utf8 typo.missing-header
/News typo.utf8 typo.missing-header
/release-info/News typo.utf8 typo.missing-header
/INSTALL typo.missing-header
/LICENSE typo.very-long-line typo.missing-header
# tools/ci/appveyor/appveyor_build.cmd only has missing-header because
@ -65,8 +65,8 @@ tools/mantis2gh_stripped.csv typo.missing-header
/tools/ci/appveyor/appveyor_build.cmd typo.very-long-line typo.missing-header typo.non-ascii
/tools/ci/appveyor/appveyor_build.sh typo.non-ascii
/tools/ci/inria/remove-sinh-primitive.patch typo.white-at-eol typo.missing-header typo.long-line
/tools/release-checklist typo.missing-header typo.very-long-line
/release-info/howto.md typo.missing-header typo.long-line
/release-info/templates/*.md typo.missing-header typo.very-long-line=may
# ignore auto-generated .depend files
.depend typo.prune
/.depend.menhir typo.prune

18
.github/workflows/nnp.yml vendored Normal file
View File

@ -0,0 +1,18 @@
name: main
on: [push, pull_request]
jobs:
no-naked-pointers:
runs-on: ubuntu-latest
steps:
- name: Checkout
uses: actions/checkout@v2
- name: configure tree
run: ./configure --disable-naked-pointers --disable-stdlib-manpages
- name: Build
run: |
make -j world.opt
- name: Run the testsuite
run: |
make -C testsuite USE_RUNTIME=d all

1
.gitignore vendored
View File

@ -246,7 +246,6 @@ _build
/tools/ocamlmklib
/tools/ocamlmklib.opt
/tools/ocamlmklibconfig.ml
/tools/objinfo_helper
/tools/ocamlcmt
/tools/ocamlcmt.opt
/tools/cmpbyt

86
Changes
View File

@ -3,7 +3,10 @@ Working version
### Language features:
* #9500: Injectivity annotations
- #1655: pattern aliases do not ignore type constraints
(Thomas Refis, review by Jacques Garrigue and Gabriel Scherer)
* #9500, #9727: Injectivity annotations
One can now mark type parameters as injective, which is useful for
abstract types:
module Vec : sig type !'a t end = struct type 'a t = 'a array end
@ -38,8 +41,10 @@ Working version
(KC Sivaramakrishnan, review by Stephen Dolan, Gabriel Scherer,
and Xavier Leroy)
- #9569: Add `Val_none`, `Some_val`, `Is_none`, `Is_some`, `caml_alloc_some`,
and `Tag_some`.
* #5154, #9569, #9734: Add `Val_none`, `Some_val`, `Is_none`, `Is_some`,
`caml_alloc_some`, and `Tag_some`. As these macros are sometimes defined by
authors of C bindings, this change may cause warnings/errors in case of
redefinition.
(Nicolás Ojeda Bär, review by Stephen Dolan, Gabriel Scherer, Mark Shinwell,
and Xavier Leroy)
@ -77,15 +82,37 @@ Working version
areas in the page table, subsumed by the new code fragment management API
(Xavier Leroy, review by Jacques-Henri Jourdan)
- #9710: Drop "support" for an hypothetical JIT for OCaml bytecode
which has never existed.
(Jacques-Henri Jourdan, review by Xavier Leroy)
- #9728: Take advantage of the new closure representation to simplify the
compaction algorithm and remove its dependence on the page table
(Damien Doligez, review by Jacques-Henri Jourdan and Xavier Leroy)
### Code generation and optimizations:
- #9551: ocamlc no longer loads DLLs at link time to check that
external functions referenced from OCaml code are defined.
Instead, .so/.dll files are parsed directly by pure OCaml code.
(Nicolás Ojeda Bär, review by Daniel Bünzli, Gabriel Scherer,
Anil Madhavapeddy, and Xavier Leroy)
- #9620: Limit the number of parameters for an uncurried or untupled
function. Functions with more parameters than that are left
partially curried or tupled.
(Xavier Leroy, review by Mark Shinwell)
- #9752: Revised handling of calling conventions for external C functions.
Provide a more precise description of the types of unboxed arguments,
so that the ARM64 iOS/macOS calling conventions can be honored.
(Xavier Leroy, review by Mark Shinwell and Github user @EduardoRFS)
### Standard library:
- #9781: add injectivity annotations to parameterized abstract types
(Jeremy Yallop, review by Nicolás Ojeda Bär)
* #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)
@ -118,6 +145,15 @@ Working version
(Bernhard Schommer, review by Daniel Bünzli, Gabriel Scherer and
Alain Frisch)
- #9663: Extend Printexc API for raw backtrace entries.
(Stephen Dolan, review by Nicolás Ojeda Bär and Gabriel Scherer)
- #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)
### Other libraries:
* #9206, #9419: update documentation of the threads library;
@ -143,6 +179,11 @@ Working version
### Tools:
- #9551: ocamlobjinfo is now able to display information on .cmxs shared
libraries natively; it no longer requires libbfd to do so
(Nicolás Ojeda Bär, review by Daniel Bünzli, Gabriel Scherer,
Anil Madhavapeddy, and Xavier Leroy)
- #9606, #9635, #9637: fix performance regression in the debugger
(behaviors quadratic in the size of the debugged program)
(Xavier Leroy, report by Jacques Garrigue and Virgile Prevosto,
@ -159,6 +200,9 @@ Working version
### Compiler user-interface and warnings:
- #1931: rely on levels to enforce principality in patterns
(Thomas Refis and Leo White, review by Jacques Garrigue)
* #9011: Do not create .a/.lib files when creating a .cmxa with no modules.
macOS ar doesn't support creating empty .a files (#1094) and MSVC doesn't
permit .lib files to contain no objects. When linking with a .cmxa containing
@ -185,12 +229,19 @@ Working version
(Xavier Van de Woestyne, report by whitequark, review by Florian Angeletti
and Gabriel Scherer)
- #9657: Warnings can now be referred to by their mnemonic name. The names are
displayed using `-warn-help` and can be utilized anywhere where a warning list
specification is expected, e.g. `[@@@ocaml.warning ...]`.
(Nicolás Ojeda Bär, review by Gabriel Scherer, Florian Angeletti and 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: refactor the pattern-matching compiler
- #9493, #9520, #9563, #9599, #9608, #9647: refactor
the pattern-matching compiler
(Thomas Refis and Gabriel Scherer, review by Florian Angeletti)
- #9604: refactoring of the ocamltest codebase.
@ -218,6 +269,13 @@ Working version
(Nicolás Ojeda Bär, review by David Allsopp, Sébastien Hinderer and Gabriel
Scherer)
- #9688: Expose the main entrypoint in compilerlibs
(Stephen Dolan, review by Nicolás Ojeda Bär, Greta Yorsh and David Allsopp)
- #9778: Fix printing for bindings where polymorphic type annotations and
attributes are present.
(Matthew Ryan, review by Nicolás Ojeda Bär)
### Build system:
- #7121, #9558: Always the autoconf-discovered ld in PACKLD. For
@ -340,7 +398,7 @@ OCaml 4.11
- #9280: Micro-optimise allocations on amd64 to save a register.
(Stephen Dolan, review by Xavier Leroy)
- #9316, #9443, #9463: Use typing information from Clambda
- #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)
@ -443,6 +501,10 @@ OCaml 4.11
### 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)
@ -462,6 +524,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)
- #6969: Argument -nocwd added to ocamldep
(Muskan Garg, review by Florian Angeletti)
@ -546,6 +612,12 @@ OCaml 4.11
- #7708, #9580: Ensure Stdlib documentation index refers to Stdlib.
(Stephen Dolan, review by Florian Angeletti, report by Hannes Mehnert)
- #9541: Add a documentation page for the instrumented runtime;
additional changes to option names in the instrumented runtime.
(Enguerrand Decorne, review by Anil Madhavapeddy, Gabriel Scherer,
Daniel Bünzli, David Allsopp, Florian Angeletti,
and Sébastien Hinderer)
- #9610: manual, C FFI: naked pointers are deprecated, detail the
forward-compatible options for handling out-of-heap pointers.
(Xavier Leroy, review by Mark Shinwell, David Allsopp and Florian Angeletti)
@ -821,6 +893,10 @@ OCaml 4.10 maintenance branch
output channels would not be flushed).
(Nicolás Ojeda Bär, review by David Allsopp)
- #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 ???)
OCaml 4.10.0 (21 February 2020)
-------------------------------

21
INSTALL.adoc
View File

@ -2,22 +2,23 @@
== Prerequisites
* The GNU C Compiler (gcc) is recommended, as the bytecode interpreter takes
* A C Compiler is required.
The GNU C Compiler (`gcc`) is recommended as the bytecode interpreter takes
advantage of GCC-specific features to enhance performance. gcc is the standard
compiler under Linux, OS X, and many other systems.
compiler under Linux and many other systems.
However `clang` - used in Mac OS, BSDs and others - also works fine.
* GNU `make`, as well as POSIX-compatible `awk` and `sed` are required.
* A POSIX-compatible `diff` is necessary to run the test suite.
* If you do not have write access to `/tmp`, you should set the environment
variable `TMPDIR` to the name of some other temporary directory.
* Under HP/UX, the GNU C Compiler (gcc), the GNU Assembler (gas), and GNU Make
are all *required*. The vendor-provided compiler, assembler and make tools
have major problems.
== Prerequisites (special cases)
* Under Cygwin, the `gcc-core` and `make` packages are required. `flexdll` is
necessary for shared library support. `libX11-devel` is necessary for graph
library support and `libintl-devel` is necessary for the `ocamlobjinfo` tool
to be able to process `.cmxs` files. `diffutils` is necessary to run the test
suite.
* Under Cygwin, the `gcc-core` package is required. `flexdll` is also necessary
for shared library support.
== Configuration

3
Makefile.config.in
View File

@ -176,9 +176,6 @@ PTHREAD_CAML_LINK=$(addprefix -cclib ,$(PTHREAD_LINK))
UNIX_OR_WIN32=@unix_or_win32@
UNIXLIB=@unixlib@
BFD_CPPFLAGS=@bfd_cppflags@
BFD_LDFLAGS=@bfd_ldflags@
BFD_LDLIBS=@bfd_ldlibs@
INSTALL_SOURCE_ARTIFACTS=@install_source_artifacts@
OC_CFLAGS=@oc_cflags@

2
asmcomp/afl_instrument.ml
View File

@ -103,7 +103,7 @@ let instrument_initialiser c dbg =
calls *)
with_afl_logging
(Csequence
(Cop (Cextcall ("caml_setup_afl", typ_int, false, None),
(Cop (Cextcall ("caml_setup_afl", typ_int, [], false, None),
[Cconst_int (0, dbg ())],
dbg ()),
c))

17
asmcomp/amd64/proc.ml
View File

@ -165,7 +165,7 @@ let calling_conventions first_int last_int first_float last_float make_stack
let float = ref first_float in
let ofs = ref 0 in
for i = 0 to Array.length arg - 1 do
match arg.(i).typ with
match arg.(i) with
| Val | Int | Addr as ty ->
if !int <= last_int then begin
loc.(i) <- phys_reg !int;
@ -234,7 +234,7 @@ let win64_loc_external_arguments arg =
let reg = ref 0
and ofs = ref 32 in
for i = 0 to Array.length arg - 1 do
match arg.(i).typ with
match arg.(i) with
| Val | Int | Addr as ty ->
if !reg < 4 then begin
loc.(i) <- phys_reg win64_int_external_arguments.(!reg);
@ -254,15 +254,14 @@ let win64_loc_external_arguments arg =
done;
(loc, Misc.align !ofs 16) (* keep stack 16-aligned *)
let loc_external_arguments arg =
let arg =
Array.map (fun regs -> assert (Array.length regs = 1); regs.(0)) arg
in
let loc, alignment =
if win64 then win64_loc_external_arguments arg
let loc_external_arguments ty_args =
let arg = Cmm.machtype_of_exttype_list ty_args in
let loc, stack_ofs =
if win64
then win64_loc_external_arguments arg
else unix_loc_external_arguments arg
in
Array.map (fun reg -> [|reg|]) loc, alignment
Array.map (fun reg -> [|reg|]) loc, stack_ofs
let loc_exn_bucket = rax

14
asmcomp/amd64/selection.ml
View File

@ -135,7 +135,7 @@ method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
method! is_simple_expr e =
match e with
| Cop(Cextcall (fn, _, _, _), args, _)
| Cop(Cextcall (fn, _, _, _, _), args, _)
when List.mem fn inline_ops ->
(* inlined ops are simple if their arguments are *)
List.for_all self#is_simple_expr args
@ -144,7 +144,7 @@ method! is_simple_expr e =
method! effects_of e =
match e with
| Cop(Cextcall(fn, _, _, _), args, _)
| Cop(Cextcall(fn, _, _, _, _), args, _)
when List.mem fn inline_ops ->
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
| _ ->
@ -197,7 +197,7 @@ method! select_operation op args dbg =
self#select_floatarith true Imulf Ifloatmul args
| Cdivf ->
self#select_floatarith false Idivf Ifloatdiv args
| Cextcall("sqrt", _, false, _) ->
| Cextcall("sqrt", _, _, false, _) ->
begin match args with
[Cop(Cload ((Double|Double_u as chunk), _), [loc], _dbg)] ->
let (addr, arg) = self#select_addressing chunk loc in
@ -217,12 +217,12 @@ method! select_operation op args dbg =
| _ ->
super#select_operation op args dbg
end
| Cextcall("caml_bswap16_direct", _, _, _) ->
| Cextcall("caml_bswap16_direct", _, _, _, _) ->
(Ispecific (Ibswap 16), args)
| Cextcall("caml_int32_direct_bswap", _, _, _) ->
| Cextcall("caml_int32_direct_bswap", _, _, _, _) ->
(Ispecific (Ibswap 32), args)
| Cextcall("caml_int64_direct_bswap", _, _, _)
| Cextcall("caml_nativeint_direct_bswap", _, _, _) ->
| Cextcall("caml_int64_direct_bswap", _, _, _, _)
| Cextcall("caml_nativeint_direct_bswap", _, _, _, _) ->
(Ispecific (Ibswap 64), args)
(* AMD64 does not support immediate operands for multiply high signed *)
| Cmulhi ->

157
asmcomp/arm/proc.ml
View File

@ -111,67 +111,58 @@ let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
(* Calling conventions *)
let loc_int last_int make_stack int ofs =
if !int <= last_int then begin
let l = phys_reg !int in
incr int; l
end else begin
let l = stack_slot (make_stack !ofs) Int in
ofs := !ofs + size_int; l
end
let loc_float last_float make_stack float ofs =
assert (abi = EABI_HF);
assert (!fpu >= VFPv2);
if !float <= last_float then begin
let l = phys_reg !float in
incr float; l
end else begin
ofs := Misc.align !ofs size_float;
let l = stack_slot (make_stack !ofs) Float in
ofs := !ofs + size_float; l
end
let loc_int_pair last_int make_stack int ofs =
(* 64-bit quantities split across two registers must either be in a
consecutive pair of registers where the lowest numbered is an
even-numbered register; or in a stack slot that is 8-byte aligned. *)
int := Misc.align !int 2;
if !int <= last_int - 1 then begin
let reg_lower = phys_reg !int in
let reg_upper = phys_reg (1 + !int) in
int := !int + 2;
[| reg_lower; reg_upper |]
end else begin
let size_int64 = size_int * 2 in
ofs := Misc.align !ofs size_int64;
let stack_lower = stack_slot (make_stack !ofs) Int in
let stack_upper = stack_slot (make_stack (size_int + !ofs)) Int in
ofs := !ofs + size_int64;
[| stack_lower; stack_upper |]
end
let calling_conventions first_int last_int first_float last_float make_stack
arg =
let loc = Array.make (Array.length arg) [| Reg.dummy |] in
let loc = Array.make (Array.length arg) Reg.dummy in
let int = ref first_int in
let float = ref first_float in
let ofs = ref 0 in
for i = 0 to Array.length arg - 1 do
match arg.(i) with
| [| arg |] ->
begin match arg.typ with
| Val | Int | Addr as ty ->
if !int <= last_int then begin
loc.(i) <- [| phys_reg !int |];
incr int
end else begin
loc.(i) <- [| stack_slot (make_stack !ofs) ty |];
ofs := !ofs + size_int
end
| Float ->
assert (abi = EABI_HF);
assert (!fpu >= VFPv2);
if !float <= last_float then begin
loc.(i) <- [| phys_reg !float |];
incr float
end else begin
ofs := Misc.align !ofs size_float;
loc.(i) <- [| stack_slot (make_stack !ofs) Float |];
ofs := !ofs + size_float
end
end
| [| arg1; arg2 |] ->
(* Passing of 64-bit quantities to external functions. *)
begin match arg1.typ, arg2.typ with
| Int, Int ->
(* 64-bit quantities split across two registers must either be in a
consecutive pair of registers where the lowest numbered is an
even-numbered register; or in a stack slot that is 8-byte
aligned. *)
int := Misc.align !int 2;
if !int <= last_int - 1 then begin
let reg_lower = phys_reg !int in
let reg_upper = phys_reg (1 + !int) in
loc.(i) <- [| reg_lower; reg_upper |];
int := !int + 2
end else begin
let size_int64 = size_int * 2 in
ofs := Misc.align !ofs size_int64;
let stack_lower = stack_slot (make_stack !ofs) Int in
let stack_upper = stack_slot (make_stack (size_int + !ofs)) Int in
loc.(i) <- [| stack_lower; stack_upper |];
ofs := !ofs + size_int64
end
| _, _ ->
let f = function Int -> "I" | Addr -> "A" | Val -> "V" | Float -> "F" in
fatal_error (Printf.sprintf "Proc.calling_conventions: bad register \
type(s) for multi-register argument: %s, %s"
(f arg1.typ) (f arg2.typ))
end
| _ ->
fatal_error "Proc.calling_conventions: bad number of registers for \
multi-register argument"
| Val | Int | Addr ->
loc.(i) <- loc_int last_int make_stack int ofs
| Float ->
loc.(i) <- loc_float last_float make_stack float ofs
done;
(loc, Misc.align !ofs 8) (* keep stack 8-aligned *)
@ -187,40 +178,50 @@ let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
let max_arguments_for_tailcalls = 8
let single_regs arg = Array.map (fun arg -> [| arg |]) arg
let ensure_single_regs res =
Array.map (function
| [| res |] -> res
| _ -> failwith "Proc.ensure_single_regs")
res
let loc_arguments arg =
let (loc, alignment) =
calling_conventions 0 7 100 115 outgoing (single_regs arg)
in
ensure_single_regs loc, alignment
calling_conventions 0 7 100 115 outgoing arg
let loc_parameters arg =
let (loc, _) = calling_conventions 0 7 100 115 incoming (single_regs arg) in
ensure_single_regs loc
let (loc, _) = calling_conventions 0 7 100 115 incoming arg in loc
let loc_results res =
let (loc, _) =
calling_conventions 0 7 100 115 not_supported (single_regs res)
in
ensure_single_regs loc
let (loc, _) = calling_conventions 0 7 100 115 not_supported res in loc
(* C calling convention:
first integer args in r0...r3
first 64-bit integer args in r0-r1, r2-r3
first float args in d0...d7 (EABI+VFP)
first float args in r0-r1, r2-r3 (soft FP)
remaining args on stack.
Return values in r0...r1 or d0. *)
Return values in r0, r0-r1, or d0. *)
let external_calling_conventions first_int last_int first_float last_float
make_stack ty_args =
let loc = Array.make (List.length ty_args) [| Reg.dummy |] in
let int = ref first_int in
let float = ref first_float in
let ofs = ref 0 in
List.iteri
(fun i ty_arg ->
match ty_arg with
| XInt | XInt32 ->
loc.(i) <- [| loc_int last_int make_stack int ofs |]
| XInt64 ->
loc.(i) <- loc_int_pair last_int make_stack int ofs
| XFloat ->
loc.(i) <-
(if abi = EABI_HF
then [| loc_float last_float make_stack float ofs |]
else loc_int_pair last_int make_stack int ofs))
ty_args;
(loc, Misc.align !ofs 8) (* keep stack 8-aligned *)
let loc_external_arguments ty_args =
external_calling_conventions 0 3 100 107 outgoing ty_args
let loc_external_arguments arg =
calling_conventions 0 3 100 107 outgoing arg
let loc_external_results res =
let (loc, _) =
calling_conventions 0 1 100 100 not_supported (single_regs res)
in
ensure_single_regs loc
let (loc, _) = calling_conventions 0 1 100 100 not_supported res
in loc
let loc_exn_bucket = phys_reg 0

55
asmcomp/arm/selection.ml
View File

@ -78,7 +78,7 @@ let pseudoregs_for_operation op arg res =
(arg', res)
(* We use __aeabi_idivmod for Cmodi only, and hence we care only
for the remainder in r1, so fix up the destination register. *)
| Iextcall { func = "__aeabi_idivmod"; alloc = false; } ->
| Iextcall { func = "__aeabi_idivmod"; _ } ->
(arg, [|r1|])
(* Other instructions are regular *)
| _ -> raise Use_default
@ -107,25 +107,25 @@ method is_immediate n =
method! is_simple_expr = function
(* inlined floating-point ops are simple if their arguments are *)
| Cop(Cextcall("sqrt", _, _, _), args, _) when !fpu >= VFPv2 ->
| Cop(Cextcall("sqrt", _, _, _, _), args, _) when !fpu >= VFPv2 ->
List.for_all self#is_simple_expr args
(* inlined byte-swap ops are simple if their arguments are *)
| Cop(Cextcall("caml_bswap16_direct", _, _, _), args, _)
| Cop(Cextcall("caml_bswap16_direct", _, _, _, _), args, _)
when !arch >= ARMv6T2 ->
List.for_all self#is_simple_expr args
| Cop(Cextcall("caml_int32_direct_bswap",_,_,_), args, _)
| Cop(Cextcall("caml_int32_direct_bswap", _, _, _, _), args, _)
when !arch >= ARMv6 ->
List.for_all self#is_simple_expr args
| e -> super#is_simple_expr e
method! effects_of e =
match e with
| Cop(Cextcall("sqrt", _, _, _), args, _) when !fpu >= VFPv2 ->
| Cop(Cextcall("sqrt", _, _, _, _), args, _) when !fpu >= VFPv2 ->
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
| Cop(Cextcall("caml_bswap16_direct", _, _, _), args, _)
| Cop(Cextcall("caml_bswap16_direct", _, _, _, _), args, _)
when !arch >= ARMv6T2 ->
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
| Cop(Cextcall("caml_int32_direct_bswap",_,_,_), args, _)
| Cop(Cextcall("caml_int32_direct_bswap",_ ,_ , _, _), args, _)
when !arch >= ARMv6 ->
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
| e -> super#effects_of e
@ -179,8 +179,9 @@ method select_shift_arith op dbg arithop arithrevop args =
| op_args -> op_args
end
method private iextcall (func, alloc) =
Iextcall { func; alloc; label_after = Cmm.new_label (); }
method private iextcall func ty_res ty_args =
Iextcall { func; ty_res; ty_args;
alloc = false; label_after = Cmm.new_label (); }
method! select_operation op args dbg =
match (op, args) with
@ -215,15 +216,15 @@ method! select_operation op args dbg =
(Iintop Imulh, args)
(* Turn integer division/modulus into runtime ABI calls *)
| (Cdivi, args) ->
(self#iextcall("__aeabi_idiv", false), args)
(self#iextcall "__aeabi_idiv" typ_int [], args)
| (Cmodi, args) ->
(* See above for fix up of return register *)
(self#iextcall("__aeabi_idivmod", false), args)
(self#iextcall "__aeabi_idivmod" typ_int [], args)
(* Recognize 16-bit bswap instruction (ARMv6T2 because we need movt) *)
| (Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 ->
| (Cextcall("caml_bswap16_direct", _, _, _, _), args) when !arch >= ARMv6T2 ->
(Ispecific(Ibswap 16), args)
(* Recognize 32-bit bswap instructions (ARMv6 and above) *)
| (Cextcall("caml_int32_direct_bswap", _, _, _), args)
| (Cextcall("caml_int32_direct_bswap", _, _, _, _), args)
when !arch >= ARMv6 ->
(Ispecific(Ibswap 32), args)
(* Turn floating-point operations into runtime ABI calls for softfp *)
@ -234,12 +235,18 @@ method! select_operation op args dbg =
method private select_operation_softfp op args dbg =
match (op, args) with
(* Turn floating-point operations into runtime ABI calls *)
| (Caddf, args) -> (self#iextcall("__aeabi_dadd", false), args)
| (Csubf, args) -> (self#iextcall("__aeabi_dsub", false), args)
| (Cmulf, args) -> (self#iextcall("__aeabi_dmul", false), args)
| (Cdivf, args) -> (self#iextcall("__aeabi_ddiv", false), args)
| (Cfloatofint, args) -> (self#iextcall("__aeabi_i2d", false), args)
| (Cintoffloat, args) -> (self#iextcall("__aeabi_d2iz", false), args)
| (Caddf, args) ->
(self#iextcall "__aeabi_dadd" typ_float [XFloat;XFloat], args)
| (Csubf, args) ->
(self#iextcall "__aeabi_dsub" typ_float [XFloat;XFloat], args)
| (Cmulf, args) ->
(self#iextcall "__aeabi_dmul" typ_float [XFloat;XFloat], args)
| (Cdivf, args) ->
(self#iextcall "__aeabi_ddiv" typ_float [XFloat;XFloat], args)
| (Cfloatofint, args) ->
(self#iextcall "__aeabi_i2d" typ_float [XInt], args)
| (Cintoffloat, args) ->
(self#iextcall "__aeabi_d2iz" typ_int [XFloat], args)
| (Ccmpf comp, args) ->
let comp, func =
match comp with
@ -255,14 +262,16 @@ method private select_operation_softfp op args dbg =
| CFnge -> Ceq, "__aeabi_dcmpge"
in
(Iintop_imm(Icomp(Iunsigned comp), 0),
[Cop(Cextcall(func, typ_int, false, None), args, dbg)])
[Cop(Cextcall(func, typ_int, [XFloat;XFloat], false, None),
args, dbg)])
(* Add coercions around loads and stores of 32-bit floats *)
| (Cload (Single, mut), args) ->
(self#iextcall("__aeabi_f2d", false),
(self#iextcall "__aeabi_f2d" typ_float [XInt],
[Cop(Cload (Word_int, mut), args, dbg)])
| (Cstore (Single, init), [arg1; arg2]) ->
let arg2' =
Cop(Cextcall("__aeabi_d2f", typ_int, false, None), [arg2], dbg) in
Cop(Cextcall("__aeabi_d2f", typ_int, [XFloat], false, None),
[arg2], dbg) in
self#select_operation (Cstore (Word_int, init)) [arg1; arg2'] dbg
(* Other operations are regular *)
| (op, args) -> super#select_operation op args dbg
@ -287,7 +296,7 @@ method private select_operation_vfpv3 op args dbg =
| (Csubf, [Cop(Cmulf, args, _); arg]) ->
(Ispecific Imulsubf, arg :: args)
(* Recognize floating-point square root *)
| (Cextcall("sqrt", _, false, _), args) ->
| (Cextcall("sqrt", _, _, false, _), args) ->
(Ispecific Isqrtf, args)
(* Other operations are regular *)
| (op, args) -> super#select_operation op args dbg

10
asmcomp/arm64/arch.ml
View File

@ -19,6 +19,10 @@
open Format
let macosx = (Config.system = "macosx")
(* Machine-specific command-line options *)
let command_line_options = []
(* Addressing modes *)
@ -56,6 +60,7 @@ type specific_operation =
| Inegmulsubf (* floating-point negate, multiply and subtract *)
| Isqrtf (* floating-point square root *)
| Ibswap of int (* endianness conversion *)
| Imove32 (* 32-bit integer move *)
and arith_operation =
Ishiftadd
@ -65,7 +70,7 @@ let spacetime_node_hole_pointer_is_live_before = function
| Ifar_alloc _ | Ifar_intop_checkbound _ | Ifar_intop_imm_checkbound _
| Ishiftarith _ | Ishiftcheckbound _ | Ifar_shiftcheckbound _ -> false
| Imuladd | Imulsub | Inegmulf | Imuladdf | Inegmuladdf | Imulsubf
| Inegmulsubf | Isqrtf | Ibswap _ -> false
| Inegmulsubf | Isqrtf | Ibswap _ | Imove32 -> false
(* Sizes, endianness *)
@ -170,3 +175,6 @@ let print_specific_operation printreg op ppf arg =
| Ibswap n ->
fprintf ppf "bswap%i %a" n
printreg arg.(0)
| Imove32 ->
fprintf ppf "move32 %a"
printreg arg.(0)

14
asmcomp/arm64/emit.mlp
View File

@ -481,6 +481,7 @@ module BR = Branch_relaxation.Make (struct
| Lop (Ispecific (Imuladd | Imulsub)) -> 1
| Lop (Ispecific (Ibswap 16)) -> 2
| Lop (Ispecific (Ibswap _)) -> 1
| Lop (Ispecific Imove32) -> 1
| Lop (Iname_for_debugger _) -> 0
| Lreloadretaddr -> 0
| Lreturn -> epilogue_size ()
@ -606,6 +607,19 @@ let emit_instr i =
| _ ->
assert false
end
| Lop(Ispecific Imove32) ->
let src = i.arg.(0) and dst = i.res.(0) in
if src.loc <> dst.loc then begin
match (src, dst) with
| {loc = Reg _}, {loc = Reg _} ->
` mov {emit_wreg dst}, {emit_wreg src}\n`
| {loc = Reg _}, {loc = Stack _} ->
` str {emit_wreg src}, {emit_stack dst}\n`
| {loc = Stack _}, {loc = Reg _} ->
` ldr {emit_wreg dst}, {emit_stack src}\n`
| _ ->
assert false
end
| Lop(Iconst_int n) ->
emit_intconst i.res.(0) n
| Lop(Iconst_float f) ->

79
asmcomp/arm64/proc.ml
View File

@ -109,6 +109,36 @@ let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
(* Calling conventions *)
let loc_int last_int make_stack int ofs =
if !int <= last_int then begin
let l = phys_reg !int in
incr int; l
end else begin
ofs := Misc.align !ofs size_int;
let l = stack_slot (make_stack !ofs) Int in
ofs := !ofs + size_int; l
end
let loc_float last_float make_stack float ofs =
if !float <= last_float then begin
let l = phys_reg !float in
incr float; l
end else begin
ofs := Misc.align !ofs size_float;
let l = stack_slot (make_stack !ofs) Float in
ofs := !ofs + size_float; l
end
let loc_int32 last_int make_stack int ofs =
if !int <= last_int then begin
let l = phys_reg !int in
incr int; l
end else begin
let l = stack_slot (make_stack !ofs) Int in
ofs := !ofs + (if macosx then 4 else 8);
l
end
let calling_conventions
first_int last_int first_float last_float make_stack arg =
let loc = Array.make (Array.length arg) Reg.dummy in
@ -116,23 +146,11 @@ let calling_conventions
let float = ref first_float in
let ofs = ref 0 in
for i = 0 to Array.length arg - 1 do
match arg.(i).typ with
| Val | Int | Addr as ty ->
if !int <= last_int then begin
loc.(i) <- phys_reg !int;
incr int
end else begin
loc.(i) <- stack_slot (make_stack !ofs) ty;
ofs := !ofs + size_int
end
match arg.(i) with
| Val | Int | Addr ->
loc.(i) <- loc_int last_int make_stack int ofs
| Float ->
if !float <= last_float then begin
loc.(i) <- phys_reg !float;
incr float
end else begin
loc.(i) <- stack_slot (make_stack !ofs) Float;
ofs := !ofs + size_float
end
loc.(i) <- loc_float last_float make_stack float ofs
done;
(loc, Misc.align !ofs 16) (* keep stack 16-aligned *)
@ -159,14 +177,31 @@ let loc_results res =
first integer args in r0...r7
first float args in d0...d7
remaining args on stack.
macOS/iOS peculiarity: int32 arguments passed on stack occupy 4 bytes,
while the AAPCS64 says 8 bytes.
Return values in r0...r1 or d0. *)
let loc_external_arguments arg =
let arg =
Array.map (fun regs -> assert (Array.length regs = 1); regs.(0)) arg
in
let loc, alignment = calling_conventions 0 7 100 107 outgoing arg in
Array.map (fun reg -> [|reg|]) loc, alignment
let external_calling_conventions
first_int last_int first_float last_float make_stack ty_args =
let loc = Array.make (List.length ty_args) [| Reg.dummy |] in
let int = ref first_int in
let float = ref first_float in
let ofs = ref 0 in
List.iteri (fun i ty_arg ->
begin match ty_arg with
| XInt | XInt64 ->
loc.(i) <- [| loc_int last_int make_stack int ofs |]
| XInt32 ->
loc.(i) <- [| loc_int32 last_int make_stack int ofs |]
| XFloat ->
loc.(i) <- [| loc_float last_float make_stack float ofs |]
end)
ty_args;
(loc, Misc.align !ofs 16) (* keep stack 16-aligned *)
let loc_external_arguments ty_args =
external_calling_conventions 0 7 100 107 outgoing ty_args
let loc_external_results res =
let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc

23
asmcomp/arm64/reload.ml
View File

@ -15,5 +15,26 @@
(* Reloading for the ARM 64 bits *)
open Reg
class reload = object (self)
inherit Reloadgen.reload_generic as super
method! reload_operation op arg res =
match op with
| Ispecific Imove32 ->
(* Like Imove: argument or result can be on stack but not both *)
begin match arg.(0), res.(0) with
| {loc = Stack s1}, {loc = Stack s2} when s1 <> s2 ->
([| self#makereg arg.(0) |], res)
| _ ->
(arg, res)
end
| _ ->
super#reload_operation op arg res
end
let fundecl f num_stack_slots =
(new Reloadgen.reload_generic)#fundecl f num_stack_slots
(new reload)#fundecl f num_stack_slots

21
asmcomp/arm64/selection.ml
View File

@ -85,6 +85,11 @@ let inline_ops =
let use_direct_addressing _symb =
not !Clflags.dlcode
let is_stack_slot rv =
Reg.(match rv with
| [| { loc = Stack _ } |] -> true
| _ -> false)
(* Instruction selection *)
class selector = object(self)
@ -98,13 +103,13 @@ method is_immediate n =
method! is_simple_expr = function
(* inlined floating-point ops are simple if their arguments are *)
| Cop(Cextcall (fn, _, _, _), args, _) when List.mem fn inline_ops ->
| Cop(Cextcall (fn, _, _, _, _), args, _) when List.mem fn inline_ops ->
List.for_all self#is_simple_expr args
| e -> super#is_simple_expr e
method! effects_of e =
match e with
| Cop(Cextcall (fn, _, _, _), args, _) when List.mem fn inline_ops ->
| Cop(Cextcall (fn, _, _, _, _), args, _) when List.mem fn inline_ops ->
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
| e -> super#effects_of e
@ -228,15 +233,15 @@ method! select_operation op args dbg =
super#select_operation op args dbg
end
(* Recognize floating-point square root *)
| Cextcall("sqrt", _, _, _) ->
| Cextcall("sqrt", _, _, _, _) ->
(Ispecific Isqrtf, args)
(* Recognize bswap instructions *)
| Cextcall("caml_bswap16_direct", _, _, _) ->
| Cextcall("caml_bswap16_direct", _, _, _, _) ->
(Ispecific(Ibswap 16), args)
| Cextcall("caml_int32_direct_bswap", _, _, _) ->
| Cextcall("caml_int32_direct_bswap", _, _, _, _) ->
(Ispecific(Ibswap 32), args)
| Cextcall(("caml_int64_direct_bswap"|"caml_nativeint_direct_bswap"),
_, _, _) ->
_, _, _, _) ->
(Ispecific (Ibswap 64), args)
(* Other operations are regular *)
| _ ->
@ -250,6 +255,10 @@ method select_logical op = function
| args ->
(Iintop op, args)
method! insert_move_extcall_arg env ty_arg src dst =
if macosx && ty_arg = XInt32 && is_stack_slot dst
then self#insert env (Iop (Ispecific Imove32)) src dst
else self#insert_moves env src dst
end
let fundecl f = (new selector)#emit_fundecl f

17
asmcomp/cmm.ml
View File

@ -77,6 +77,21 @@ let ge_component comp1 comp2 =
| Float, (Int | Addr | Val) ->
assert false
type exttype =
| XInt
| XInt32
| XInt64
| XFloat
let machtype_of_exttype = function
| XInt -> typ_int
| XInt32 -> typ_int
| XInt64 -> if Arch.size_int = 4 then [|Int;Int|] else typ_int
| XFloat -> typ_float
let machtype_of_exttype_list xtl =
Array.concat (List.map machtype_of_exttype xtl)
type integer_comparison = Lambda.integer_comparison =
| Ceq | Cne | Clt | Cgt | Cle | Cge
@ -124,7 +139,7 @@ type memory_chunk =
and operation =
Capply of machtype
| Cextcall of string * machtype * bool * label option
| Cextcall of string * machtype * exttype list * bool * label option
(** If specified, the given label will be placed immediately after the
call (at the same place as any frame descriptor would reference). *)
| Cload of memory_chunk * Asttypes.mutable_flag

16
asmcomp/cmm.mli
View File

@ -68,6 +68,17 @@ val ge_component
-> machtype_component
-> bool
type exttype =
| XInt (**r OCaml value, word-sized integer *)
| XInt32 (**r 32-bit integer *)
| XInt64 (**r 64-bit integer *)
| XFloat (**r double-precision FP number *)
(** A variant of [machtype] used to describe arguments
to external C functions *)
val machtype_of_exttype: exttype -> machtype
val machtype_of_exttype_list: exttype list -> machtype
type integer_comparison = Lambda.integer_comparison =
| Ceq | Cne | Clt | Cgt | Cle | Cge
@ -127,7 +138,10 @@ type memory_chunk =
and operation =
Capply of machtype
| Cextcall of string * machtype * bool * label option
| Cextcall of string * machtype * exttype list * bool * label option
(** The [machtype] is the machine type of the result.
The [exttype list] describes the unboxing types of the arguments.
An empty list means "all arguments are machine words [XInt]". *)
| Cload of memory_chunk * Asttypes.mutable_flag
| Calloc
| Cstore of memory_chunk * Lambda.initialization_or_assignment

42
asmcomp/cmm_helpers.ml
View File

@ -613,8 +613,8 @@ let rec remove_unit = function
Clet(id, c1, remove_unit c2)
| Cop(Capply _mty, args, dbg) ->
Cop(Capply typ_void, args, dbg)
| Cop(Cextcall(proc, _mty, alloc, label_after), args, dbg) ->
Cop(Cextcall(proc, typ_void, alloc, label_after), args, dbg)
| Cop(Cextcall(proc, _ty_res, ty_args, alloc, label_after), args, dbg) ->
Cop(Cextcall(proc, typ_void, ty_args, alloc, label_after), args, dbg)
| Cexit (_,_) as c -> c
| Ctuple [] as c -> c
| c -> Csequence(c, Ctuple [])
@ -736,10 +736,10 @@ let float_array_ref arr ofs dbg =
box_float dbg (unboxed_float_array_ref arr ofs dbg)
let addr_array_set arr ofs newval dbg =
Cop(Cextcall("caml_modify", typ_void, false, None),
Cop(Cextcall("caml_modify", typ_void, [], false, None),
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
let addr_array_initialize arr ofs newval dbg =
Cop(Cextcall("caml_initialize", typ_void, false, None),
Cop(Cextcall("caml_initialize", typ_void, [], false, None),
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
let int_array_set arr ofs newval dbg =
Cop(Cstore (Word_int, Lambda.Assignment),
@ -775,7 +775,7 @@ let bigstring_length ba dbg =
let lookup_tag obj tag dbg =
bind "tag" tag (fun tag ->
Cop(Cextcall("caml_get_public_method", typ_val, false, None),
Cop(Cextcall("caml_get_public_method", typ_val, [], false, None),
[obj; tag],
dbg))
@ -805,14 +805,14 @@ let make_alloc_generic set_fn dbg tag wordsize args =
| e1::el -> Csequence(set_fn (Cvar id) (Cconst_int (idx, dbg)) e1 dbg,
fill_fields (idx + 2) el) in
Clet(VP.create id,
Cop(Cextcall("caml_alloc", typ_val, true, None),
Cop(Cextcall("caml_alloc", typ_val, [], true, None),
[Cconst_int (wordsize, dbg); Cconst_int (tag, dbg)], dbg),
fill_fields 1 args)
end
let make_alloc dbg tag args =
let addr_array_init arr ofs newval dbg =
Cop(Cextcall("caml_initialize", typ_void, false, None),
Cop(Cextcall("caml_initialize", typ_void, [], false, None),
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
in
make_alloc_generic addr_array_init dbg tag (List.length args) args
@ -2147,18 +2147,18 @@ let arraylength kind arg dbg =
Cop(Cor, [float_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg)
let bbswap bi arg dbg =
let prim = match (bi : Primitive.boxed_integer) with
| Pnativeint -> "nativeint"
| Pint32 -> "int32"
| Pint64 -> "int64"
let prim, tyarg = match (bi : Primitive.boxed_integer) with
| Pnativeint -> "nativeint", XInt
| Pint32 -> "int32", XInt32
| Pint64 -> "int64", XInt64
in
Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim,
typ_int, false, None),
typ_int, [tyarg], false, None),
[arg],
dbg)
let bswap16 arg dbg =
(Cop(Cextcall("caml_bswap16_direct", typ_int, false, None),
(Cop(Cextcall("caml_bswap16_direct", typ_int, [], false, None),
[arg],
dbg))
@ -2183,15 +2183,15 @@ let assignment_kind
let setfield n ptr init arg1 arg2 dbg =
match assignment_kind ptr init with
| Caml_modify ->
return_unit dbg (Cop(Cextcall("caml_modify", typ_void, false, None),
[field_address arg1 n dbg;
arg2],
dbg))
return_unit dbg
(Cop(Cextcall("caml_modify", typ_void, [], false, None),
[field_address arg1 n dbg; arg2],
dbg))
| Caml_initialize ->
return_unit dbg (Cop(Cextcall("caml_initialize", typ_void, false, None),
[field_address arg1 n dbg;
arg2],
dbg))
return_unit dbg
(Cop(Cextcall("caml_initialize", typ_void, [], false, None),
[field_address arg1 n dbg; arg2],
dbg))
| Simple ->
return_unit dbg (set_field arg1 n arg2 init dbg)

36
asmcomp/cmmgen.ml
View File

@ -726,7 +726,7 @@ and transl_catch env nfail ids body handler dbg =
and transl_make_array dbg env kind args =
match kind with
| Pgenarray ->
Cop(Cextcall("caml_make_array", typ_val, true, None),
Cop(Cextcall("caml_make_array", typ_val, [], true, None),
[make_alloc dbg 0 (List.map (transl env) args)], dbg)
| Paddrarray | Pintarray ->
make_alloc dbg 0 (List.map (transl env) args)
@ -737,20 +737,32 @@ and transl_make_array dbg env kind args =
and transl_ccall env prim args dbg =
let transl_arg native_repr arg =
match native_repr with
| Same_as_ocaml_repr -> transl env arg
| Unboxed_float -> transl_unbox_float dbg env arg
| Unboxed_integer bi -> transl_unbox_int dbg env bi arg
| Untagged_int -> untag_int (transl env arg) dbg
| Same_as_ocaml_repr ->
(XInt, transl env arg)
| Unboxed_float ->
(XFloat, transl_unbox_float dbg env arg)
| Unboxed_integer bi ->
let xty =
match bi with
| Pnativeint -> XInt
| Pint32 -> XInt32
| Pint64 -> XInt64 in
(xty, transl_unbox_int dbg env bi arg)
| Untagged_int ->
(XInt, untag_int (transl env arg) dbg)
in
let rec transl_args native_repr_args args =
match native_repr_args, args with
| [], args ->
(* We don't require the two lists to be of the same length as
[default_prim] always sets the arity to [0]. *)
List.map (transl env) args
| _, [] -> assert false
(List.map (fun _ -> XInt) args, List.map (transl env) args)
| _, [] ->
assert false
| native_repr :: native_repr_args, arg :: args ->
transl_arg native_repr arg :: transl_args native_repr_args args
let (ty1, arg') = transl_arg native_repr arg in
let (tys, args') = transl_args native_repr_args args in
(ty1 :: tys, arg' :: args')
in
let typ_res, wrap_result =
match prim.prim_native_repr_res with
@ -761,10 +773,10 @@ and transl_ccall env prim args dbg =
| Unboxed_integer bi -> (typ_int, box_int dbg bi)
| Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
in
let args = transl_args prim.prim_native_repr_args args in
let typ_args, args = transl_args prim.prim_native_repr_args args in
wrap_result
(Cop(Cextcall(Primitive.native_name prim,
typ_res, prim.prim_alloc, None), args, dbg))
typ_res, typ_args, prim.prim_alloc, None), args, dbg))
and transl_prim_1 env p arg dbg =
match p with
@ -1304,7 +1316,7 @@ and transl_letrec env bindings cont =
bindings
in
let op_alloc prim args =
Cop(Cextcall(prim, typ_val, true, None), args, dbg) in
Cop(Cextcall(prim, typ_val, [], true, None), args, dbg) in
let rec init_blocks = function
| [] -> fill_nonrec bsz
| (id, _exp, RHS_block sz) :: rem ->
@ -1330,7 +1342,7 @@ and transl_letrec env bindings cont =
| [] -> cont
| (id, exp, (RHS_block _ | RHS_infix _ | RHS_floatblock _)) :: rem ->
let op =
Cop(Cextcall("caml_update_dummy", typ_void, false, None),
Cop(Cextcall("caml_update_dummy", typ_void, [], false, None),
[Cvar (VP.var id); transl env exp], dbg) in
Csequence(op, fill_blocks rem)
| (_id, _exp, RHS_nonrec) :: rem ->

4
asmcomp/i386/proc.ml
View File

@ -121,7 +121,7 @@ let calling_conventions first_int last_int first_float last_float make_stack
let float = ref first_float in
let ofs = ref (-64) in
for i = 0 to Array.length arg - 1 do
match arg.(i).typ with
match arg.(i) with
Val | Int | Addr as ty ->
if !int <= last_int then begin
loc.(i) <- phys_reg !int;
@ -158,7 +158,7 @@ let loc_external_arguments _arg =
fatal_error "Proc.loc_external_arguments"
let loc_external_results res =
match res with
| [|{typ=Int};{typ=Int}|] -> [|eax; edx|]
| [| Int; Int |] -> [|eax; edx|]
| _ ->
let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc

10
asmcomp/i386/selection.ml
View File

@ -89,7 +89,7 @@ let rec float_needs = function
let n1 = float_needs arg1 in
let n2 = float_needs arg2 in
if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2
| Cop(Cextcall(fn, _ty_res, _alloc, _label), args, _dbg)
| Cop(Cextcall(fn, _ty_res, _ty_args, _alloc, _label), args, _dbg)
when !fast_math && List.mem fn inline_float_ops ->
begin match args with
[arg] -> float_needs arg
@ -162,7 +162,7 @@ method is_immediate (_n : int) = true
method! is_simple_expr e =
match e with
| Cop(Cextcall(fn, _, _alloc, _), args, _)
| Cop(Cextcall(fn, _, _, _, _), args, _)
when !fast_math && List.mem fn inline_float_ops ->
(* inlined float ops are simple if their arguments are *)
List.for_all self#is_simple_expr args
@ -171,7 +171,7 @@ method! is_simple_expr e =
method! effects_of e =
match e with
| Cop(Cextcall(fn, _, _, _), args, _)
| Cop(Cextcall(fn, _, _, _, _), args, _)
when !fast_math && List.mem fn inline_float_ops ->
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
| _ ->
@ -233,7 +233,7 @@ method! select_operation op args dbg =
super#select_operation op args dbg
end
(* Recognize inlined floating point operations *)
| Cextcall(fn, _ty_res, false, _label)
| Cextcall(fn, _ty_res, _ty_args, false, _label)
when !fast_math && List.mem fn inline_float_ops ->
(Ispecific(Ifloatspecial fn), args)
(* i386 does not support immediate operands for multiply high signed *)
@ -297,7 +297,7 @@ method select_push exp =
method! mark_c_tailcall =
contains_calls := true
method! emit_extcall_args env args =
method! emit_extcall_args env _ty_args args =
let rec size_pushes = function
| [] -> 0
| e :: el -> Selectgen.size_expr env e + size_pushes el in

4
asmcomp/mach.ml
View File

@ -50,7 +50,9 @@ type operation =
| Icall_imm of { func : string; label_after : label; }
| Itailcall_ind of { label_after : label; }
| Itailcall_imm of { func : string; label_after : label; }
| Iextcall of { func : string; alloc : bool; label_after : label; }
| Iextcall of { func : string;
ty_res : Cmm.machtype; ty_args : Cmm.exttype list;
alloc : bool; label_after : label; }
| Istackoffset of int
| Iload of Cmm.memory_chunk * Arch.addressing_mode
| Istore of Cmm.memory_chunk * Arch.addressing_mode * bool

4
asmcomp/mach.mli
View File

@ -57,7 +57,9 @@ type operation =
| Icall_imm of { func : string; label_after : label; }
| Itailcall_ind of { label_after : label; }
| Itailcall_imm of { func : string; label_after : label; }
| Iextcall of { func : string; alloc : bool; label_after : label; }
| Iextcall of { func : string;
ty_res : Cmm.machtype; ty_args : Cmm.exttype list;
alloc : bool; label_after : label; }
| Istackoffset of int
| Iload of Cmm.memory_chunk * Arch.addressing_mode
| Istore of Cmm.memory_chunk * Arch.addressing_mode * bool

188
asmcomp/power/proc.ml
View File

@ -95,107 +95,81 @@ let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
(* Calling conventions *)
let calling_conventions
first_int last_int first_float last_float
make_stack stack_ofs reg_use_stack arg =
let loc = Array.make (Array.length arg) [| Reg.dummy |] in
let loc_int last_int make_stack reg_use_stack int ofs =
if !int <= last_int then begin
let l = phys_reg !int in
incr int;
if reg_use_stack then ofs := !ofs + size_int;
l
end else begin
let l = stack_slot (make_stack !ofs) Int in
ofs := !ofs + size_int; l
end
let loc_float last_float make_stack reg_use_stack int float ofs =
if !float <= last_float then begin
let l = phys_reg !float in
incr float;
(* On 64-bit platforms, passing a float in a float register
reserves a normal register as well *)
if size_int = 8 then incr int;
if reg_use_stack then ofs := !ofs + size_float;
l
end else begin
ofs := Misc.align !ofs size_float;
let l = stack_slot (make_stack !ofs) Float in
ofs := !ofs + size_float; l
end
let loc_int_pair last_int make_stack int ofs =
(* 64-bit quantities split across two registers must either be in a
consecutive pair of registers where the lowest numbered is an
even-numbered register; or in a stack slot that is 8-byte aligned. *)
int := Misc.align !int 2;
if !int <= last_int - 1 then begin
let reg_lower = phys_reg !int in
let reg_upper = phys_reg (1 + !int) in
int := !int + 2;
[| reg_lower; reg_upper |]
end else begin
ofs := Misc.align !ofs 8;
let stack_lower = stack_slot (make_stack !ofs) Int in
let stack_upper = stack_slot (make_stack (size_int + !ofs)) Int in
ofs := !ofs + 8;
[| stack_lower; stack_upper |]
end
let calling_conventions first_int last_int first_float last_float make_stack
arg =
let loc = Array.make (Array.length arg) Reg.dummy in
let int = ref first_int in
let float = ref first_float in
let ofs = ref stack_ofs in
let ofs = ref 0 in
for i = 0 to Array.length arg - 1 do
match arg.(i) with
| [| arg |] ->
begin match arg.typ with
| Val | Int | Addr as ty ->
if !int <= last_int then begin
loc.(i) <- [| phys_reg !int |];
incr int;
if reg_use_stack then ofs := !ofs + size_int
end else begin
loc.(i) <- [| stack_slot (make_stack !ofs) ty |];
ofs := !ofs + size_int
end
| Float ->
if !float <= last_float then begin
loc.(i) <- [| phys_reg !float |];
incr float;
(* On 64-bit platforms, passing a float in a float register
reserves a normal register as well *)
if size_int = 8 then incr int;
if reg_use_stack then ofs := !ofs + size_float
end else begin
ofs := Misc.align !ofs size_float;
loc.(i) <- [| stack_slot (make_stack !ofs) Float |];
ofs := !ofs + size_float
end
end
| [| arg1; arg2 |] ->
(* Passing of 64-bit quantities to external functions
on 32-bit platform. *)
assert (size_int = 4);
begin match arg1.typ, arg2.typ with
| Int, Int ->
(* 64-bit quantities split across two registers must either be in a
consecutive pair of registers where the lowest numbered is an
even-numbered register; or in a stack slot that is 8-byte
aligned. *)
int := Misc.align !int 2;
if !int <= last_int - 1 then begin
let reg_lower = phys_reg !int in
let reg_upper = phys_reg (!int + 1) in
loc.(i) <- [| reg_lower; reg_upper |];
int := !int + 2
end else begin
let size_int64 = 8 in
ofs := Misc.align !ofs size_int64;
let ofs_lower = !ofs in
let ofs_upper = !ofs + size_int in
let stack_lower = stack_slot (make_stack ofs_lower) Int in
let stack_upper = stack_slot (make_stack ofs_upper) Int in
loc.(i) <- [| stack_lower; stack_upper |];
ofs := !ofs + size_int64
end
| _, _ ->
let f = function Int -> "I" | Addr -> "A" | Val -> "V" | Float -> "F" in
fatal_error (Printf.sprintf "Proc.calling_conventions: bad register \
type(s) for multi-register argument: %s, %s"
(f arg1.typ) (f arg2.typ))
end
| _ ->
fatal_error "Proc.calling_conventions: bad number of registers for \
multi-register argument"
| Val | Int | Addr ->
loc.(i) <- loc_int last_int make_stack false int ofs
| Float ->
loc.(i) <- loc_float last_float make_stack false int float ofs
done;
(loc, Misc.align !ofs 16)
(* Keep stack 16-aligned. *)
(loc, Misc.align !ofs 16) (* keep stack 16-aligned *)
let incoming ofs = Incoming ofs
let outgoing ofs = Outgoing ofs
let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
let single_regs arg = Array.map (fun arg -> [| arg |]) arg
let ensure_single_regs res =
Array.map (function
| [| res |] -> res
| _ -> failwith "Proc.ensure_single_regs")
res
let max_arguments_for_tailcalls = 8
let loc_arguments arg =
let (loc, ofs) =
calling_conventions 0 7 100 112 outgoing 0 false (single_regs arg)
in
(ensure_single_regs loc, ofs)
calling_conventions 0 7 100 112 outgoing arg
let loc_parameters arg =
let (loc, _ofs) =
calling_conventions 0 7 100 112 incoming 0 false (single_regs arg)
in
ensure_single_regs loc
let (loc, _ofs) = calling_conventions 0 7 100 112 incoming arg
in loc
let loc_results res =
let (loc, _ofs) =
calling_conventions 0 7 100 112 not_supported 0 false (single_regs res)
in
ensure_single_regs loc
let (loc, _ofs) = calling_conventions 0 7 100 112 not_supported res
in loc
(* C calling conventions for ELF32:
use GPR 3-10 and FPR 1-8 just like ML calling conventions.
@ -223,19 +197,43 @@ let loc_results res =
and need not appear here.
*)
let loc_external_arguments =
let external_calling_conventions
first_int last_int first_float last_float
make_stack stack_ofs reg_use_stack ty_args =
let loc = Array.make (List.length ty_args) [| Reg.dummy |] in
let int = ref first_int in
let float = ref first_float in
let ofs = ref stack_ofs in
List.iteri
(fun i ty_arg ->
match ty_arg with
| XInt | XInt32 ->
loc.(i) <-
[| loc_int last_int make_stack reg_use_stack int ofs |]
| XInt64 ->
if size_int = 4 then begin
assert (not reg_use_stack);
loc.(i) <- loc_int_pair last_int make_stack int ofs
end else
loc.(i) <-
[| loc_int last_int make_stack reg_use_stack int ofs |]
| XFloat ->
loc.(i) <-
[| loc_float last_float make_stack reg_use_stack int float ofs |])
ty_args;
(loc, Misc.align !ofs 16) (* Keep stack 16-aligned *)
let loc_external_arguments ty_args =
match abi with
| ELF32 ->
calling_conventions 0 7 100 107 outgoing 8 false
external_calling_conventions 0 7 100 107 outgoing 8 false ty_args
| ELF64v1 ->
fun args ->
let (loc, ofs) =
calling_conventions 0 7 100 112 outgoing 0 true args in
external_calling_conventions 0 7 100 112 outgoing 0 true ty_args in
(loc, max ofs 64)
| ELF64v2 ->
fun args ->
let (loc, ofs) =
calling_conventions 0 7 100 112 outgoing 0 true args in
external_calling_conventions 0 7 100 112 outgoing 0 true ty_args in
if Array.fold_left
(fun stk r ->
assert (Array.length r = 1);
@ -249,10 +247,8 @@ let loc_external_arguments =
(* Results are in GPR 3 and FPR 1 *)
let loc_external_results res =
let (loc, _ofs) =
calling_conventions 0 1 100 100 not_supported 0 false (single_regs res)
in
ensure_single_regs loc
let (loc, _ofs) = calling_conventions 0 1 100 100 not_supported res
in loc
(* Exceptions are in GPR 3 *)

20
asmcomp/printcmm.ml
View File

@ -39,6 +39,21 @@ let machtype ppf mty =
fprintf ppf "*%a" machtype_component mty.(i)
done
let exttype ppf = function
| XInt -> fprintf ppf "int"
| XInt32 -> fprintf ppf "int32"
| XInt64 -> fprintf ppf "int64"
| XFloat -> fprintf ppf "float"
let extcall_signature ppf (ty_res, ty_args) =
begin match ty_args with
| [] -> ()
| ty_arg1 :: ty_args ->
exttype ppf ty_arg1;
List.iter (fun ty -> fprintf ppf ",%a" exttype ty) ty_args
end;
fprintf ppf "->%a" machtype ty_res
let integer_comparison = function
| Ceq -> "=="
| Cne -> "!="
@ -101,7 +116,7 @@ let location d =
let operation d = function
| Capply _ty -> "app" ^ location d
| Cextcall(lbl, _ty, _alloc, _) ->
| Cextcall(lbl, _ty_res, _ty_args, _alloc, _) ->
Printf.sprintf "extcall \"%s\"%s" lbl (location d)
| Cload (c, Asttypes.Immutable) -> Printf.sprintf "load %s" (chunk c)
| Cload (c, Asttypes.Mutable) -> Printf.sprintf "load_mut %s" (chunk c)
@ -207,7 +222,8 @@ let rec expr ppf = function
List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
begin match op with
| Capply mty -> fprintf ppf "@ %a" machtype mty
| Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty
| Cextcall(_, ty_res, ty_args, _, _) ->
fprintf ppf "@ %a" extcall_signature (ty_res, ty_args)
| _ -> ()
end;
fprintf ppf ")@]"

4
asmcomp/printcmm.mli
View File

@ -19,7 +19,9 @@ open Format
val rec_flag : formatter -> Cmm.rec_flag -> unit
val machtype_component : formatter -> Cmm.machtype_component -> unit
val machtype : formatter -> Cmm.machtype_component array -> unit
val machtype : formatter -> Cmm.machtype -> unit
val exttype : formatter -> Cmm.exttype -> unit
val extcall_signature : formatter -> Cmm.machtype * Cmm.exttype list -> unit
val integer_comparison : Cmm.integer_comparison -> string
val float_comparison : Cmm.float_comparison -> string
val chunk : Cmm.memory_chunk -> string

14
asmcomp/proc.mli
View File

@ -28,16 +28,14 @@ val phys_reg: int -> Reg.t
val rotate_registers: bool
(* Calling conventions *)
val loc_arguments: Reg.t array -> Reg.t array * int
val loc_results: Reg.t array -> Reg.t array
val loc_parameters: Reg.t array -> Reg.t array
val loc_arguments: Cmm.machtype -> Reg.t array * int
val loc_results: Cmm.machtype -> Reg.t array
val loc_parameters: Cmm.machtype -> Reg.t array
(* For argument number [n] split across multiple registers, the target-specific
implementation of [loc_external_arguments] must return [regs] such that
[regs.(n).(0)] is to hold the part of the value at the lowest address.
(All that matters for the input to [loc_external_arguments] is the pattern
of lengths and register types of the various supplied arrays.) *)
val loc_external_arguments: Reg.t array array -> Reg.t array array * int
val loc_external_results: Reg.t array -> Reg.t array
[regs.(n).(0)] is to hold the part of the value at the lowest address. *)
val loc_external_arguments: Cmm.exttype list -> Reg.t array array * int
val loc_external_results: Cmm.machtype -> Reg.t array
val loc_exn_bucket: Reg.t
val loc_spacetime_node_hole: Reg.t

3
asmcomp/reg.ml
View File

@ -117,6 +117,9 @@ let at_location ty loc =
incr currstamp;
r
let typv rv =
Array.map (fun r -> r.typ) rv
let anonymous t =
match Raw_name.to_string t.raw_name with
| None -> true

2
asmcomp/reg.mli
View File

@ -49,7 +49,7 @@ val createv: Cmm.machtype -> t array
val createv_like: t array -> t array
val clone: t -> t
val at_location: Cmm.machtype_component -> location -> t
val typv: t array -> Cmm.machtype
val anonymous : t -> bool
(* Name for printing *)

60
asmcomp/riscv/proc.ml
View File

@ -127,7 +127,7 @@ let calling_conventions
let float = ref first_float in
let ofs = ref 0 in
for i = 0 to Array.length arg - 1 do
match arg.(i).typ with
match arg.(i) with
| Val | Int | Addr as ty ->
if !int <= last_int then begin
loc.(i) <- phys_reg !int;
@ -161,13 +161,6 @@ let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
remaining args on stack.
Return values in a0 .. a7, s2 .. s9 or fa0 .. fa7, fs2 .. fs9. *)
let single_regs arg = Array.map (fun arg -> [| arg |]) arg
let ensure_single_regs res =
Array.map (function
| [| res |] -> res
| _ -> failwith "proc.ensure_single_regs"
) res
let loc_arguments arg =
calling_conventions 0 15 110 125 outgoing arg
@ -199,42 +192,35 @@ let external_calling_conventions
let ofs = ref 0 in
for i = 0 to Array.length arg - 1 do
match arg.(i) with
| [| arg |] ->
begin match arg.typ with
| Val | Int | Addr as ty ->
if !int <= last_int then begin
loc.(i) <- [| phys_reg !int |];
incr int
end else begin
loc.(i) <- [| stack_slot (make_stack !ofs) ty |];
ofs := !ofs + size_int
end
| Float ->
if !float <= last_float then begin
loc.(i) <- [| phys_reg !float |];
incr float
end else if !int <= last_int then begin
loc.(i) <- [| phys_reg !int |];
incr int
end else begin
loc.(i) <- [| stack_slot (make_stack !ofs) Float |];
ofs := !ofs + size_float
end
| Val | Int | Addr as ty ->
if !int <= last_int then begin
loc.(i) <- [| phys_reg !int |];
incr int
end else begin
loc.(i) <- [| stack_slot (make_stack !ofs) ty |];
ofs := !ofs + size_int
end
| Float ->
if !float <= last_float then begin
loc.(i) <- [| phys_reg !float |];
incr float
end else if !int <= last_int then begin
loc.(i) <- [| phys_reg !int |];
incr int
end else begin
loc.(i) <- [| stack_slot (make_stack !ofs) Float |];
ofs := !ofs + size_float
end
| _ ->
fatal_error "Proc.calling_conventions: bad number of register for \
multi-register argument"
done;
(loc, Misc.align !ofs 16) (* Keep stack 16-aligned. *)
let loc_external_arguments arg =
let loc_external_arguments ty_args =
let arg = Cmm.machtype_of_exttype_list ty_args in
external_calling_conventions 0 7 110 117 outgoing arg
let loc_external_results res =
let (loc, _ofs) =
external_calling_conventions 0 1 110 111 not_supported (single_regs res)
in
ensure_single_regs loc
let (loc, _ofs) = calling_conventions 0 1 110 111 not_supported res
in loc
(* Exceptions are in a0 *)

10
asmcomp/s390x/proc.ml
View File

@ -105,7 +105,7 @@ let calling_conventions
let float = ref first_float in
let ofs = ref stack_ofs in
for i = 0 to Array.length arg - 1 do
match arg.(i).typ with
match arg.(i) with
| Val | Int | Addr as ty ->
if !int <= last_int then begin
loc.(i) <- phys_reg !int;
@ -145,11 +145,9 @@ let loc_results res =
Always reserve 160 bytes at bottom of stack, plus whatever is needed
to hold the overflow arguments. *)
let loc_external_arguments arg =
let arg =
Array.map (fun regs -> assert (Array.length regs = 1); regs.(0)) arg in
let (loc, ofs) =
calling_conventions 0 4 100 103 outgoing 160 arg in
let loc_external_arguments ty_args =
let arg = Cmm.machtype_of_exttype_list ty_args in
let (loc, ofs) = calling_conventions 0 4 100 103 outgoing 160 arg in
(Array.map (fun reg -> [|reg|]) loc, ofs)
(* Results are in GPR 2 and FPR 0 *)

78
asmcomp/selectgen.ml
View File

@ -66,7 +66,7 @@ let env_empty = {
let oper_result_type = function
Capply ty -> ty
| Cextcall(_s, ty, _alloc, _) -> ty
| Cextcall(_s, ty_res, _ty_args, _alloc, _) -> ty_res
| Cload (c, _) ->
begin match c with
| Word_val -> typ_val
@ -445,13 +445,13 @@ method select_operation op args _dbg =
| (Capply _, _) ->
let label_after = Cmm.new_label () in
(Icall_ind { label_after; }, args)
| (Cextcall(func, _ty, alloc, label_after), _) ->
| (Cextcall(func, ty_res, ty_args, alloc, label_after), _) ->
let label_after =
match label_after with
| None -> Cmm.new_label ()
| Some label_after -> label_after
in
Iextcall { func; alloc; label_after; }, args
Iextcall { func; ty_res; ty_args; alloc; label_after; }, args
| (Cload (chunk, _mut), [arg]) ->
let (addr, eloc) = self#select_addressing chunk arg in
(Iload(chunk, addr), [eloc])
@ -717,8 +717,8 @@ method emit_expr (env:environment) exp =
let r1 = self#emit_tuple env new_args in
let rarg = Array.sub r1 1 (Array.length r1 - 1) in
let rd = self#regs_for ty in
let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
let loc_res = Proc.loc_results rd in
let (loc_arg, stack_ofs) = Proc.loc_arguments (Reg.typv rarg) in
let loc_res = Proc.loc_results (Reg.typv rd) in
let spacetime_reg =
self#about_to_emit_call env (Iop new_op) [| r1.(0) |] dbg
in
@ -731,8 +731,8 @@ method emit_expr (env:environment) exp =
| Icall_imm _ ->
let r1 = self#emit_tuple env new_args in
let rd = self#regs_for ty in
let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
let loc_res = Proc.loc_results rd in
let (loc_arg, stack_ofs) = Proc.loc_arguments (Reg.typv r1) in
let loc_res = Proc.loc_results (Reg.typv rd) in
let spacetime_reg =
self#about_to_emit_call env (Iop new_op) [| |] dbg
in
@ -741,16 +741,16 @@ method emit_expr (env:environment) exp =
self#insert_debug env (Iop new_op) dbg loc_arg loc_res;
self#insert_move_results env loc_res rd stack_ofs;
Some rd
| Iextcall _ ->
| Iextcall { ty_args; _} ->
let spacetime_reg =
self#about_to_emit_call env (Iop new_op) [| |] dbg
in
let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in
self#about_to_emit_call env (Iop new_op) [| |] dbg in
let (loc_arg, stack_ofs) =
self#emit_extcall_args env ty_args new_args in
self#maybe_emit_spacetime_move env ~spacetime_reg;
let rd = self#regs_for ty in
let loc_res =
self#insert_op_debug env new_op dbg
loc_arg (Proc.loc_external_results rd) in
loc_arg (Proc.loc_external_results (Reg.typv rd)) in
self#insert_move_results env loc_res rd stack_ofs;
Some rd
| Ialloc { bytes = _; spacetime_index; label_after_call_gc; } ->
@ -889,7 +889,7 @@ method private bind_let (env:environment) v r1 =
end
method private bind_let_mut (env:environment) v k r1 =
let rv = Reg.createv k in
let rv = self#regs_for k in
name_regs v rv;
self#insert_moves env r1 rv;
env_add ~mut:Mutable v rv env
@ -998,19 +998,26 @@ method private emit_tuple_not_flattened env exp_list =
method private emit_tuple env exp_list =
Array.concat (self#emit_tuple_not_flattened env exp_list)
method emit_extcall_args env args =
method emit_extcall_args env ty_args args =
let args = self#emit_tuple_not_flattened env args in
let arg_hard_regs, stack_ofs =
Proc.loc_external_arguments (Array.of_list args)
in
(* Flattening [args] and [arg_hard_regs] causes parts of values split
across multiple registers to line up correctly, by virtue of the
semantics of [split_int64_for_32bit_target] in cmmgen.ml, and the
required semantics of [loc_external_arguments] (see proc.mli). *)
let args = Array.concat args in
let arg_hard_regs = Array.concat (Array.to_list arg_hard_regs) in
self#insert_move_args env args arg_hard_regs stack_ofs;
arg_hard_regs, stack_ofs
let ty_args =
if ty_args = [] then List.map (fun _ -> XInt) args else ty_args in
let locs, stack_ofs = Proc.loc_external_arguments ty_args in
let ty_args = Array.of_list ty_args in
if stack_ofs <> 0 then
self#insert env (Iop(Istackoffset stack_ofs)) [||] [||];
List.iteri
(fun i arg ->
self#insert_move_extcall_arg env ty_args.(i) arg locs.(i))
args;
Array.concat (Array.to_list locs), stack_ofs
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,
for example a "32-bit move" instruction for int32 arguments. *)
self#insert_moves env src dst
method emit_stores env data regs_addr =
let a =
@ -1042,7 +1049,7 @@ method private emit_return (env:environment) exp =
match self#emit_expr env exp with
None -> ()
| Some r ->
let loc = Proc.loc_results r in
let loc = Proc.loc_results (Reg.typv r) in
self#insert_moves env r loc;
self#insert env Ireturn loc [||]
@ -1069,7 +1076,7 @@ method emit_tail (env:environment) exp =
Icall_ind { label_after; } ->
let r1 = self#emit_tuple env new_args in
let rarg = Array.sub r1 1 (Array.length r1 - 1) in
let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
let (loc_arg, stack_ofs) = Proc.loc_arguments (Reg.typv rarg) in
if stack_ofs = 0 then begin
let call = Iop (Itailcall_ind { label_after; }) in
let spacetime_reg =
@ -1081,7 +1088,7 @@ method emit_tail (env:environment) exp =
(Array.append [|r1.(0)|] loc_arg) [||];
end else begin
let rd = self#regs_for ty in
let loc_res = Proc.loc_results rd in
let loc_res = Proc.loc_results (Reg.typv rd) in
let spacetime_reg =
self#about_to_emit_call env (Iop new_op) [| r1.(0) |] dbg
in
@ -1094,7 +1101,7 @@ method emit_tail (env:environment) exp =
end
| Icall_imm { func; label_after; } ->
let r1 = self#emit_tuple env new_args in
let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
let (loc_arg, stack_ofs) = Proc.loc_arguments (Reg.typv r1) in
if stack_ofs = 0 then begin
let call = Iop (Itailcall_imm { func; label_after; }) in
let spacetime_reg =
@ -1105,7 +1112,7 @@ method emit_tail (env:environment) exp =
self#insert_debug env call dbg loc_arg [||];
end else if func = !current_function_name then begin
let call = Iop (Itailcall_imm { func; label_after; }) in
let loc_arg' = Proc.loc_parameters r1 in
let loc_arg' = Proc.loc_parameters (Reg.typv r1) in
let spacetime_reg =
self#about_to_emit_call env call [| |] dbg
in
@ -1114,7 +1121,7 @@ method emit_tail (env:environment) exp =
self#insert_debug env call dbg loc_arg' [||];
end else begin
let rd = self#regs_for ty in
let loc_res = Proc.loc_results rd in
let loc_res = Proc.loc_results (Reg.typv rd) in
let spacetime_reg =
self#about_to_emit_call env (Iop new_op) [| |] dbg
in
@ -1189,7 +1196,7 @@ method emit_tail (env:environment) exp =
begin match opt_r1 with
None -> ()
| Some r1 ->
let loc = Proc.loc_results r1 in
let loc = Proc.loc_results (Reg.typv r1) in
self#insert_moves env r1 loc;
self#insert env Ireturn loc [||]
end
@ -1224,7 +1231,7 @@ method emit_fundecl f =
(fun (id, ty) -> let r = self#regs_for ty in name_regs id r; r)
f.Cmm.fun_args in
let rarg = Array.concat rargs in
let loc_arg = Proc.loc_parameters rarg in
let loc_arg = Proc.loc_parameters (Reg.typv rarg) in
(* To make it easier to add the Spacetime instrumentation code, we
first emit the body and extract the resulting instruction sequence;
then we emit the prologue followed by any Spacetime instrumentation. The
@ -1268,9 +1275,8 @@ end
*)
let is_tail_call nargs =
assert (Reg.dummy.typ = Int);
let args = Array.make (nargs + 1) Reg.dummy in
let (_loc_arg, stack_ofs) = Proc.loc_arguments args in
let ty = Array.make (nargs + 1) Int in
let (_loc_arg, stack_ofs) = Proc.loc_arguments ty in
stack_ofs = 0
let _ =

7
asmcomp/selectgen.mli
View File

@ -97,8 +97,13 @@ class virtual selector_generic : object
-> Reg.t array -> Reg.t array
(* Can be overridden to deal with 2-address instructions
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,
e.g. on a 64-bit platform, passing unboxed 32-bit arguments
in 32-bit stack slots. *)
method emit_extcall_args :
environment -> Cmm.expression list -> Reg.t array * int
environment -> Cmm.exttype list -> Cmm.expression list -> Reg.t array * int
(* Can be overridden to deal with stack-based calling conventions *)
method emit_stores :
environment -> Cmm.expression list -> Reg.t array -> unit

8
asmcomp/spacetime_profiling.ml
View File

@ -111,7 +111,7 @@ let code_for_function_prologue ~function_name ~fun_dbg:dbg ~node_hole =
Clet (VP.create is_new_node,
Clet (VP.create pc, cconst_symbol function_name,
Cop (Cextcall ("caml_spacetime_allocate_node",
[| Int |], false, None),
typ_int, [], false, None),
[cconst_int (1 (* header *) + !index_within_node);
Cvar pc;
Cvar node_hole;
@ -151,7 +151,7 @@ let code_for_blockheader ~value's_header ~node ~dbg =
the latter table to be used for resolving a program counter at such
a point to a location.
*)
Cop (Cextcall ("caml_spacetime_generate_profinfo", [| Int |],
Cop (Cextcall ("caml_spacetime_generate_profinfo", typ_int, [],
false, Some label),
[Cvar address_of_profinfo;
cconst_int (index_within_node + 1)],
@ -272,7 +272,7 @@ let code_for_call ~node ~callee ~is_tail ~label dbg =
else cconst_int 1 (* [Val_unit] *)
in
Cop (Cextcall ("caml_spacetime_indirect_node_hole_ptr",
[| Int |], false, None),
typ_int, [], false, None),
[callee; Cvar place_within_node; caller_node],
dbg))
@ -336,7 +336,7 @@ class virtual instruction_selection = object (self)
assert (Array.length arg = 1);
self#instrument_indirect_call ~env ~callee:arg.(0)
~is_tail:true ~label_after dbg
| M.Iop (M.Iextcall { func; alloc = true; label_after; }) ->
| M.Iop (M.Iextcall { func; alloc = true; label_after; _}) ->
(* N.B. No need to instrument "noalloc" external calls. *)
assert (Array.length arg = 0);
self#instrument_direct_call ~env ~func ~is_tail:false ~label_after dbg

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

385
build-aux/config.guess vendored
View File

@ -1,8 +1,8 @@
#! /bin/sh
# Attempt to guess a canonical system name.
# Copyright 1992-2018 Free Software Foundation, Inc.
# Copyright 1992-2020 Free Software Foundation, Inc.
timestamp='2018-02-24'
timestamp='2020-07-12'
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
@ -50,7 +50,7 @@ version="\
GNU config.guess ($timestamp)
Originally written by Per Bothner.
Copyright 1992-2018 Free Software Foundation, Inc.
Copyright 1992-2020 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
@ -84,8 +84,6 @@ if test $# != 0; then
exit 1
fi
trap 'exit 1' 1 2 15
# CC_FOR_BUILD -- compiler used by this script. Note that the use of a
# compiler to aid in system detection is discouraged as it requires
# temporary files to be created and, as you can see below, it is a
@ -96,34 +94,40 @@ trap 'exit 1' 1 2 15
# Portable tmp directory creation inspired by the Autoconf team.
set_cc_for_build='
trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ;
trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ;
: ${TMPDIR=/tmp} ;
{ tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
{ test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } ||
{ tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } ||
{ echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ;
dummy=$tmp/dummy ;
tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ;
case $CC_FOR_BUILD,$HOST_CC,$CC in
,,) echo "int x;" > "$dummy.c" ;
for c in cc gcc c89 c99 ; do
if ($c -c -o "$dummy.o" "$dummy.c") >/dev/null 2>&1 ; then
CC_FOR_BUILD="$c"; break ;
fi ;
done ;
if test x"$CC_FOR_BUILD" = x ; then
CC_FOR_BUILD=no_compiler_found ;
fi
;;
,,*) CC_FOR_BUILD=$CC ;;
,*,*) CC_FOR_BUILD=$HOST_CC ;;
esac ; set_cc_for_build= ;'
tmp=
# shellcheck disable=SC2172
trap 'test -z "$tmp" || rm -fr "$tmp"' 0 1 2 13 15
set_cc_for_build() {
# prevent multiple calls if $tmp is already set
test "$tmp" && return 0
: "${TMPDIR=/tmp}"
# shellcheck disable=SC2039
{ tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
{ test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir "$tmp" 2>/dev/null) ; } ||
{ tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir "$tmp" 2>/dev/null) && echo "Warning: creating insecure temp directory" >&2 ; } ||
{ echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; }
dummy=$tmp/dummy
case ${CC_FOR_BUILD-},${HOST_CC-},${CC-} in
,,) echo "int x;" > "$dummy.c"
for driver in cc gcc c89 c99 ; do
if ($driver -c -o "$dummy.o" "$dummy.c") >/dev/null 2>&1 ; then
CC_FOR_BUILD="$driver"
break
fi
done
if test x"$CC_FOR_BUILD" = x ; then
CC_FOR_BUILD=no_compiler_found
fi
;;
,,*) CC_FOR_BUILD=$CC ;;
,*,*) CC_FOR_BUILD=$HOST_CC ;;
esac
}
# This is needed to find uname on a Pyramid OSx when run in the BSD universe.
# (ghazi@noc.rutgers.edu 1994-08-24)
if (test -f /.attbin/uname) >/dev/null 2>&1 ; then
if test -f /.attbin/uname ; then
PATH=$PATH:/.attbin ; export PATH
fi
@ -138,7 +142,7 @@ Linux|GNU|GNU/*)
# We could probably try harder.
LIBC=gnu
eval "$set_cc_for_build"
set_cc_for_build
cat <<-EOF > "$dummy.c"
#include <features.h>
#if defined(__UCLIBC__)
@ -199,7 +203,7 @@ case "$UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION" in
os=netbsdelf
;;
arm*|i386|m68k|ns32k|sh3*|sparc|vax)
eval "$set_cc_for_build"
set_cc_for_build
if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \
| grep -q __ELF__
then
@ -237,7 +241,7 @@ case "$UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION" in
# Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM:
# contains redundant information, the shorter form:
# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.
echo "$machine-${os}${release}${abi}"
echo "$machine-${os}${release}${abi-}"
exit ;;
*:Bitrig:*:*)
UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'`
@ -260,6 +264,9 @@ case "$UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION" in
*:SolidBSD:*:*)
echo "$UNAME_MACHINE"-unknown-solidbsd"$UNAME_RELEASE"
exit ;;
*:OS108:*:*)
echo "$UNAME_MACHINE"-unknown-os108_"$UNAME_RELEASE"
exit ;;
macppc:MirBSD:*:*)
echo powerpc-unknown-mirbsd"$UNAME_RELEASE"
exit ;;
@ -269,12 +276,15 @@ case "$UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION" in
*:Sortix:*:*)
echo "$UNAME_MACHINE"-unknown-sortix
exit ;;
*:Twizzler:*:*)
echo "$UNAME_MACHINE"-unknown-twizzler
exit ;;
*:Redox:*:*)
echo "$UNAME_MACHINE"-unknown-redox
exit ;;
mips:OSF1:*.*)
echo mips-dec-osf1
exit ;;
echo mips-dec-osf1
exit ;;
alpha:OSF1:*:*)
case $UNAME_RELEASE in
*4.0)
@ -389,7 +399,7 @@ case "$UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION" in
echo i386-pc-auroraux"$UNAME_RELEASE"
exit ;;
i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*)
eval "$set_cc_for_build"
set_cc_for_build
SUN_ARCH=i386
# If there is a compiler, see if it is configured for 64-bit objects.
# Note that the Sun cc does not turn __LP64__ into 1 like gcc does.
@ -482,7 +492,7 @@ case "$UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION" in
echo clipper-intergraph-clix"$UNAME_RELEASE"
exit ;;
mips:*:*:UMIPS | mips:*:*:RISCos)
eval "$set_cc_for_build"
set_cc_for_build
sed 's/^ //' << EOF > "$dummy.c"
#ifdef __cplusplus
#include <stdio.h> /* for printf() prototype */
@ -579,7 +589,7 @@ EOF
exit ;;
*:AIX:2:3)
if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
eval "$set_cc_for_build"
set_cc_for_build
sed 's/^ //' << EOF > "$dummy.c"
#include <sys/systemcfg.h>
@ -660,7 +670,7 @@ EOF
esac
fi
if [ "$HP_ARCH" = "" ]; then
eval "$set_cc_for_build"
set_cc_for_build
sed 's/^ //' << EOF > "$dummy.c"
#define _HPUX_SOURCE
@ -700,7 +710,7 @@ EOF
esac
if [ "$HP_ARCH" = hppa2.0w ]
then
eval "$set_cc_for_build"
set_cc_for_build
# hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating
# 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler
@ -726,7 +736,7 @@ EOF
echo ia64-hp-hpux"$HPUX_REV"
exit ;;
3050*:HI-UX:*:*)
eval "$set_cc_for_build"
set_cc_for_build
sed 's/^ //' << EOF > "$dummy.c"
#include <unistd.h>
int
@ -840,6 +850,17 @@ EOF
*:BSD/OS:*:*)
echo "$UNAME_MACHINE"-unknown-bsdi"$UNAME_RELEASE"
exit ;;
arm:FreeBSD:*:*)
UNAME_PROCESSOR=`uname -p`
set_cc_for_build
if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \
| grep -q __ARM_PCS_VFP
then
echo "${UNAME_PROCESSOR}"-unknown-freebsd"`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`"-gnueabi
else
echo "${UNAME_PROCESSOR}"-unknown-freebsd"`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`"-gnueabihf
fi
exit ;;
*:FreeBSD:*:*)
UNAME_PROCESSOR=`/usr/bin/uname -p`
case "$UNAME_PROCESSOR" in
@ -881,7 +902,7 @@ EOF
echo "$UNAME_MACHINE"-pc-uwin
exit ;;
amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*)
echo x86_64-unknown-cygwin
echo x86_64-pc-cygwin
exit ;;
prep*:SunOS:5.*:*)
echo powerpcle-unknown-solaris2"`echo "$UNAME_RELEASE"|sed -e 's/[^.]*//'`"
@ -894,8 +915,8 @@ EOF
# other systems with GNU libc and userland
echo "$UNAME_MACHINE-unknown-`echo "$UNAME_SYSTEM" | sed 's,^[^/]*/,,' | tr "[:upper:]" "[:lower:]"``echo "$UNAME_RELEASE"|sed -e 's/[-(].*//'`-$LIBC"
exit ;;
i*86:Minix:*:*)
echo "$UNAME_MACHINE"-pc-minix
*:Minix:*:*)
echo "$UNAME_MACHINE"-unknown-minix
exit ;;
aarch64:Linux:*:*)
echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
@ -905,7 +926,7 @@ EOF
echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
alpha:Linux:*:*)
case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in
case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' /proc/cpuinfo 2>/dev/null` in
EV5) UNAME_MACHINE=alphaev5 ;;
EV56) UNAME_MACHINE=alphaev56 ;;
PCA56) UNAME_MACHINE=alphapca56 ;;
@ -922,7 +943,7 @@ EOF
echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
arm*:Linux:*:*)
eval "$set_cc_for_build"
set_cc_for_build
if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \
| grep -q __ARM_EABI__
then
@ -971,23 +992,51 @@ EOF
echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
mips:Linux:*:* | mips64:Linux:*:*)
eval "$set_cc_for_build"
set_cc_for_build
IS_GLIBC=0
test x"${LIBC}" = xgnu && IS_GLIBC=1
sed 's/^ //' << EOF > "$dummy.c"
#undef CPU
#undef ${UNAME_MACHINE}
#undef ${UNAME_MACHINE}el
#undef mips
#undef mipsel
#undef mips64
#undef mips64el
#if ${IS_GLIBC} && defined(_ABI64)
LIBCABI=gnuabi64
#else
#if ${IS_GLIBC} && defined(_ABIN32)
LIBCABI=gnuabin32
#else
LIBCABI=${LIBC}
#endif
#endif
#if ${IS_GLIBC} && defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6
CPU=mipsisa64r6
#else
#if ${IS_GLIBC} && !defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6
CPU=mipsisa32r6
#else
#if defined(__mips64)
CPU=mips64
#else
CPU=mips
#endif
#endif
#endif
#if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
CPU=${UNAME_MACHINE}el
MIPS_ENDIAN=el
#else
#if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
CPU=${UNAME_MACHINE}
MIPS_ENDIAN=
#else
CPU=
MIPS_ENDIAN=
#endif
#endif
EOF
eval "`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^CPU'`"
test "x$CPU" != x && { echo "$CPU-unknown-linux-$LIBC"; exit; }
eval "`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^CPU\|^MIPS_ENDIAN\|^LIBCABI'`"
test "x$CPU" != x && { echo "$CPU${MIPS_ENDIAN}-unknown-linux-$LIBCABI"; exit; }
;;
mips64el:Linux:*:*)
echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
@ -1046,11 +1095,17 @@ EOF
echo "$UNAME_MACHINE"-dec-linux-"$LIBC"
exit ;;
x86_64:Linux:*:*)
if objdump -f /bin/sh | grep -q elf32-x86-64; then
echo "$UNAME_MACHINE"-pc-linux-"$LIBC"x32
else
echo "$UNAME_MACHINE"-pc-linux-"$LIBC"
set_cc_for_build
LIBCABI=$LIBC
if [ "$CC_FOR_BUILD" != no_compiler_found ]; then
if (echo '#ifdef __ILP32__'; echo IS_X32; echo '#endif') | \
(CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \
grep IS_X32 >/dev/null
then
LIBCABI="$LIBC"x32
fi
fi
echo "$UNAME_MACHINE"-pc-linux-"$LIBCABI"
exit ;;
xtensa*:Linux:*:*)
echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
@ -1104,7 +1159,7 @@ EOF
*Pentium) UNAME_MACHINE=i586 ;;
*Pent*|*Celeron) UNAME_MACHINE=i686 ;;
esac
echo "$UNAME_MACHINE-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}{$UNAME_VERSION}"
echo "$UNAME_MACHINE-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}"
exit ;;
i*86:*:3.2:*)
if test -f /usr/options/cb.name; then
@ -1287,39 +1342,43 @@ EOF
*:Rhapsody:*:*)
echo "$UNAME_MACHINE"-apple-rhapsody"$UNAME_RELEASE"
exit ;;
arm64:Darwin:*:*)
echo aarch64-apple-darwin"$UNAME_RELEASE"
exit ;;
*:Darwin:*:*)
UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown
eval "$set_cc_for_build"
if test "$UNAME_PROCESSOR" = unknown ; then
UNAME_PROCESSOR=powerpc
UNAME_PROCESSOR=`uname -p`
case $UNAME_PROCESSOR in
unknown) UNAME_PROCESSOR=powerpc ;;
esac
if command -v xcode-select > /dev/null 2> /dev/null && \
! xcode-select --print-path > /dev/null 2> /dev/null ; then
# Avoid executing cc if there is no toolchain installed as
# cc will be a stub that puts up a graphical alert
# prompting the user to install developer tools.
CC_FOR_BUILD=no_compiler_found
else
set_cc_for_build
fi
if test "`echo "$UNAME_RELEASE" | sed -e 's/\..*//'`" -le 10 ; then
if [ "$CC_FOR_BUILD" != no_compiler_found ]; then
if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \
(CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \
grep IS_64BIT_ARCH >/dev/null
then
case $UNAME_PROCESSOR in
i386) UNAME_PROCESSOR=x86_64 ;;
powerpc) UNAME_PROCESSOR=powerpc64 ;;
esac
fi
# On 10.4-10.6 one might compile for PowerPC via gcc -arch ppc
if (echo '#ifdef __POWERPC__'; echo IS_PPC; echo '#endif') | \
(CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \
grep IS_PPC >/dev/null
then
UNAME_PROCESSOR=powerpc
fi
if [ "$CC_FOR_BUILD" != no_compiler_found ]; then
if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \
(CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \
grep IS_64BIT_ARCH >/dev/null
then
case $UNAME_PROCESSOR in
i386) UNAME_PROCESSOR=x86_64 ;;
powerpc) UNAME_PROCESSOR=powerpc64 ;;
esac
fi
# On 10.4-10.6 one might compile for PowerPC via gcc -arch ppc
if (echo '#ifdef __POWERPC__'; echo IS_PPC; echo '#endif') | \
(CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \
grep IS_PPC >/dev/null
then
UNAME_PROCESSOR=powerpc
fi
elif test "$UNAME_PROCESSOR" = i386 ; then
# Avoid executing cc on OS X 10.9, as it ships with a stub
# that puts up a graphical alert prompting to install
# developer tools. Any system running Mac OS X 10.7 or
# later (Darwin 11 and later) is required to have a 64-bit
# processor. This is not true of the ARM version of Darwin
# that Apple uses in portable devices.
UNAME_PROCESSOR=x86_64
# uname -m returns i386 or x86_64
UNAME_PROCESSOR=$UNAME_MACHINE
fi
echo "$UNAME_PROCESSOR"-apple-darwin"$UNAME_RELEASE"
exit ;;
@ -1362,6 +1421,7 @@ EOF
# "uname -m" is not consistent, so use $cputype instead. 386
# is converted to i386 for consistency with other x86
# operating systems.
# shellcheck disable=SC2154
if test "$cputype" = 386; then
UNAME_MACHINE=i386
else
@ -1418,8 +1478,148 @@ EOF
amd64:Isilon\ OneFS:*:*)
echo x86_64-unknown-onefs
exit ;;
*:Unleashed:*:*)
echo "$UNAME_MACHINE"-unknown-unleashed"$UNAME_RELEASE"
exit ;;
esac
# No uname command or uname output not recognized.
set_cc_for_build
cat > "$dummy.c" <<EOF
#ifdef _SEQUENT_
#include <sys/types.h>
#include <sys/utsname.h>
#endif
#if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__)
#if defined (vax) || defined (__vax) || defined (__vax__) || defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__)
#include <signal.h>
#if defined(_SIZE_T_) || defined(SIGLOST)
#include <sys/utsname.h>
#endif
#endif
#endif
main ()
{
#if defined (sony)
#if defined (MIPSEB)
/* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed,
I don't know.... */
printf ("mips-sony-bsd\n"); exit (0);
#else
#include <sys/param.h>
printf ("m68k-sony-newsos%s\n",
#ifdef NEWSOS4
"4"
#else
""
#endif
); exit (0);
#endif
#endif
#if defined (NeXT)
#if !defined (__ARCHITECTURE__)
#define __ARCHITECTURE__ "m68k"
#endif
int version;
version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
if (version < 4)
printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);
else
printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version);
exit (0);
#endif
#if defined (MULTIMAX) || defined (n16)
#if defined (UMAXV)
printf ("ns32k-encore-sysv\n"); exit (0);
#else
#if defined (CMU)
printf ("ns32k-encore-mach\n"); exit (0);
#else
printf ("ns32k-encore-bsd\n"); exit (0);
#endif
#endif
#endif
#if defined (__386BSD__)
printf ("i386-pc-bsd\n"); exit (0);
#endif
#if defined (sequent)
#if defined (i386)
printf ("i386-sequent-dynix\n"); exit (0);
#endif
#if defined (ns32000)
printf ("ns32k-sequent-dynix\n"); exit (0);
#endif
#endif
#if defined (_SEQUENT_)
struct utsname un;
uname(&un);
if (strncmp(un.version, "V2", 2) == 0) {
printf ("i386-sequent-ptx2\n"); exit (0);
}
if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */
printf ("i386-sequent-ptx1\n"); exit (0);
}
printf ("i386-sequent-ptx\n"); exit (0);
#endif
#if defined (vax)
#if !defined (ultrix)
#include <sys/param.h>
#if defined (BSD)
#if BSD == 43
printf ("vax-dec-bsd4.3\n"); exit (0);
#else
#if BSD == 199006
printf ("vax-dec-bsd4.3reno\n"); exit (0);
#else
printf ("vax-dec-bsd\n"); exit (0);
#endif
#endif
#else
printf ("vax-dec-bsd\n"); exit (0);
#endif
#else
#if defined(_SIZE_T_) || defined(SIGLOST)
struct utsname un;
uname (&un);
printf ("vax-dec-ultrix%s\n", un.release); exit (0);
#else
printf ("vax-dec-ultrix\n"); exit (0);
#endif
#endif
#endif
#if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__)
#if defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__)
#if defined(_SIZE_T_) || defined(SIGLOST)
struct utsname *un;
uname (&un);
printf ("mips-dec-ultrix%s\n", un.release); exit (0);
#else
printf ("mips-dec-ultrix\n"); exit (0);
#endif
#endif
#endif
#if defined (alliant) && defined (i860)
printf ("i860-alliant-bsd\n"); exit (0);
#endif
exit (1);
}
EOF
$CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null && SYSTEM_NAME=`$dummy` &&
{ echo "$SYSTEM_NAME"; exit; }
# Apollos put the system type in the environment.
test -d /usr/apollo && { echo "$ISP-apollo-$SYSTYPE"; exit; }
echo "$0: unable to guess system type" >&2
case "$UNAME_MACHINE:$UNAME_SYSTEM" in
@ -1442,6 +1642,12 @@ copies of config.guess and config.sub with the latest versions from:
https://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess
and
https://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub
EOF
year=`echo $timestamp | sed 's,-.*,,'`
# shellcheck disable=SC2003
if test "`expr "\`date +%Y\`" - "$year"`" -lt 3 ; then
cat >&2 <<EOF
If $0 has already been updated, send the following data and any
information you think might be pertinent to config-patches@gnu.org to
@ -1469,11 +1675,12 @@ UNAME_RELEASE = "$UNAME_RELEASE"
UNAME_SYSTEM = "$UNAME_SYSTEM"
UNAME_VERSION = "$UNAME_VERSION"
EOF
fi
exit 1
# Local variables:
# eval: (add-hook 'write-file-functions 'time-stamp)
# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "timestamp='"
# time-stamp-format: "%:y-%02m-%02d"
# time-stamp-end: "'"

2802
build-aux/config.sub vendored
View File

File diff suppressed because it is too large Load Diff

2
bytecomp/bytelink.ml
View File

@ -188,7 +188,7 @@ let check_consistency file_name cu =
begin try
let source = List.assoc cu.cu_name !implementations_defined in
Location.prerr_warning (Location.in_file file_name)
(Warnings.Multiple_definition(cu.cu_name,
(Warnings.Module_linked_twice(cu.cu_name,
Location.show_filename file_name,
Location.show_filename source))
with Not_found -> ()

63
bytecomp/dll.ml
View File

@ -31,8 +31,16 @@ external get_current_dlls: unit -> dll_handle array
(* Current search path for DLLs *)
let search_path = ref ([] : string list)
type opened_dll =
| Checking of Binutils.t
| Execution of dll_handle
let dll_close = function
| Checking _ -> ()
| Execution dll -> dll_close dll
(* DLLs currently opened *)
let opened_dlls = ref ([] : dll_handle list)
let opened_dlls = ref ([] : opened_dll list)
(* File names for those DLLs *)
let names_of_opened_dlls = ref ([] : string list)
@ -67,12 +75,24 @@ let open_dll mode name =
else fullname
with Not_found -> name in
if not (List.mem fullname !names_of_opened_dlls) then begin
try
let dll = dll_open mode fullname in
names_of_opened_dlls := fullname :: !names_of_opened_dlls;
opened_dlls := dll :: !opened_dlls
with Failure msg ->
failwith (fullname ^ ": " ^ msg)
let dll =
match mode with
| For_checking ->
begin match Binutils.read fullname with
| Ok t -> Checking t
| Error err ->
failwith (fullname ^ ": " ^ Binutils.error_to_string err)
end
| For_execution ->
begin match dll_open mode fullname with
| dll ->
Execution dll
| exception Failure msg ->
failwith (fullname ^ ": " ^ msg)
end
in
names_of_opened_dlls := fullname :: !names_of_opened_dlls;
opened_dlls := dll :: !opened_dlls
end
let open_dlls mode names =
@ -85,19 +105,28 @@ let close_all_dlls () =
opened_dlls := [];
names_of_opened_dlls := []
(* Find a primitive in the currently opened DLLs.
Raise [Not_found] if not found. *)
(* Find a primitive in the currently opened DLLs. *)
type primitive_address =
| Prim_loaded of dll_address
| Prim_exists
let find_primitive prim_name =
let rec find seen = function
[] ->
raise Not_found
| dll :: rem ->
None
| Execution dll as curr :: rem ->
let addr = dll_sym dll prim_name in
if addr == Obj.magic () then find (dll :: seen) rem else begin
if seen <> [] then opened_dlls := dll :: List.rev_append seen rem;
addr
end in
if addr == Obj.magic () then find (curr :: seen) rem else begin
if seen <> [] then opened_dlls := curr :: List.rev_append seen rem;
Some (Prim_loaded addr)
end
| Checking t as curr :: rem ->
if Binutils.defines_symbol t prim_name then
Some Prim_exists
else
find (curr :: seen) rem
in
find [] !opened_dlls
(* If linking in core (dynlink or toplevel), synchronize the VM
@ -156,7 +185,9 @@ let init_toplevel dllpath =
ld_library_path_contents() @
split_dll_path dllpath @
ld_conf_contents();
opened_dlls := Array.to_list (get_current_dlls());
opened_dlls :=
List.map (fun dll -> Execution dll)
(Array.to_list (get_current_dlls()));
names_of_opened_dlls := [];
linking_in_core := true

9
bytecomp/dll.mli
View File

@ -34,9 +34,14 @@ val close_all_dlls: unit -> unit
(* The abstract type representing C function pointers *)
type dll_address
type primitive_address =
| Prim_loaded of dll_address (* Primitive found in a DLL opened
"for execution" *)
| Prim_exists (* Primitive found in a DLL opened "for checking" *)
(* Find a primitive in the currently opened DLLs and return its address.
Raise [Not_found] if not found. *)
val find_primitive: string -> dll_address
Return [None] if the primitive is not found. *)
val find_primitive: string -> primitive_address option
(* If linking in core (dynlink or toplevel), synchronize the VM
table of primitive with the linker's table of primitive

14
bytecomp/symtable.ml
View File

@ -98,12 +98,14 @@ let of_prim name =
then
PrimMap.enter c_prim_table name
else begin
let symb =
try Dll.find_primitive name
with Not_found -> raise(Error(Unavailable_primitive name)) in
let num = PrimMap.enter c_prim_table name in
Dll.synchronize_primitive num symb;
num
match Dll.find_primitive name with
| None -> raise(Error(Unavailable_primitive name))
| Some Prim_exists ->
PrimMap.enter c_prim_table name
| Some (Prim_loaded symb) ->
let num = PrimMap.enter c_prim_table name in
Dll.synchronize_primitive num symb;
num
end
let require_primitive name =

6
compilerlibs/Makefile.compilerlibs
View File

@ -30,7 +30,7 @@ UTILS=utils/config.cmo utils/build_path_prefix_map.cmo utils/misc.cmo \
utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
utils/consistbl.cmo utils/strongly_connected_components.cmo \
utils/targetint.cmo utils/int_replace_polymorphic_compare.cmo \
utils/domainstate.cmo
utils/domainstate.cmo utils/binutils.cmo
UTILS_CMI=
PARSING=parsing/location.cmo parsing/longident.cmo \
@ -99,7 +99,7 @@ COMMON=$(UTILS) $(PARSING) $(TYPING) $(LAMBDA) $(COMP)
BYTECOMP=bytecomp/instruct.cmo bytecomp/bytegen.cmo \
bytecomp/printinstr.cmo bytecomp/emitcode.cmo \
bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \
driver/errors.cmo driver/compile.cmo
driver/errors.cmo driver/compile.cmo driver/maindriver.cmo
BYTECOMP_CMI=
INTEL_ASM=\
@ -153,7 +153,7 @@ ASMCOMP=\
asmcomp/branch_relaxation.cmo \
asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \
asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \
driver/opterrors.cmo driver/optcompile.cmo
driver/opterrors.cmo driver/optcompile.cmo driver/optmaindriver.cmo
ASMCOMP_CMI=$(ARCH_SPECIFIC_ASMCOMP_CMI)
# Files under middle_end/ are not to reference files under asmcomp/.

333
configure vendored
View File

@ -731,8 +731,6 @@ ac_ct_LD
LD
DEFAULT_STRING
WINDOWS_UNICODE_MODE
BFD_LIB_DIR
BFD_INCLUDE_DIR
LIBUNWIND_LIB_DIR
LIBUNWIND_INCLUDE_DIR
DLLIBS
@ -783,9 +781,6 @@ asm_cfi_supported
AS
endianness
ASPP
bfd_ldlibs
bfd_ldflags
bfd_cppflags
x_libraries
x_includes
pthread_link
@ -894,7 +889,6 @@ enable_instrumented_runtime
enable_vmthreads
enable_systhreads
with_libunwind
with_bfd
enable_graph_lib
enable_str_lib
enable_unix_lib
@ -937,8 +931,6 @@ PARTIALLD
DLLIBS
LIBUNWIND_INCLUDE_DIR
LIBUNWIND_LIB_DIR
BFD_INCLUDE_DIR
BFD_LIB_DIR
WINDOWS_UNICODE_MODE
DEFAULT_STRING
CC
@ -1612,8 +1604,6 @@ Optional Packages:
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
--without-libunwind disable libunwind support for Spacetime profiling
--without-bfd disable BFD (Binary File Description) library
support
--with-target-bindir location of binary programs on target system
--with-afl use the AFL fuzzer
--with-pic[=PKGS] try to use only PIC/non-PIC objects [default=use
@ -1635,9 +1625,6 @@ Some influential environment variables:
location of header files for libunwind
LIBUNWIND_LIB_DIR
location of library files for libunwind
BFD_INCLUDE_DIR
location of header files for the BFD library
BFD_LIB_DIR location of library files for the BFD library
WINDOWS_UNICODE_MODE
how to handle Unicode under Windows: ansi, compatible
DEFAULT_STRING
@ -2902,9 +2889,6 @@ VERSION=4.12.0+dev0-2020-04-22
@ -3115,19 +3099,6 @@ fi
# Check whether --with-bfd was given.
if test "${with_bfd+set}" = set; then :
withval=$with_bfd;
else
with_bfd=auto
fi
# Check whether --enable-graph-lib was given.
if test "${enable_graph_lib+set}" = set; then :
enableval=$enable_graph_lib; as_fn_error $? "The graphics library is no longer distributed with OCaml \
@ -13027,13 +12998,6 @@ if test "x$ac_cv_header_stdint_h" = xyes; then :
fi
ac_fn_c_check_header_mongrel "$LINENO" "sys/shm.h" "ac_cv_header_sys_shm_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_shm_h" = xyes; then :
$as_echo "#define HAS_SYS_SHM_H 1" >>confdefs.h
fi
ac_fn_c_check_header_compile "$LINENO" "dirent.h" "ac_cv_header_dirent_h" "#include <sys/types.h>
"
if test "x$ac_cv_header_dirent_h" = xyes; then :
@ -13484,7 +13448,7 @@ $as_echo "$ac_cv_c_bigendian" >&6; }
yes)
$as_echo "#define ARCH_BIG_ENDIAN 1" >>confdefs.h
,
endianness="be"
;; #(
no)
@ -15633,6 +15597,23 @@ if test "x$ac_cv_func_getauxval" = xyes; then :
fi
## shmat
ac_fn_c_check_header_mongrel "$LINENO" "sys/shm.h" "ac_cv_header_sys_shm_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_shm_h" = xyes; then :
$as_echo "#define HAS_SYS_SHM_H 1" >>confdefs.h
ac_fn_c_check_func "$LINENO" "shmat" "ac_cv_func_shmat"
if test "x$ac_cv_func_shmat" = xyes; then :
$as_echo "#define HAS_SHMAT 1" >>confdefs.h
fi
fi
## execvpe
ac_fn_c_check_func "$LINENO" "execvpe" "ac_cv_func_execvpe"
@ -16367,6 +16348,8 @@ if test "x$ax_pthread_ok" = "xyes"; then
pthread_link="-lpthread -lposix4" ;; #(
*-*-haiku*) :
pthread_link="" ;; #(
*-*-android*) :
pthread_link="" ;; #(
*) :
pthread_link="-lpthread" ;;
esac
@ -16406,282 +16389,6 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
esac
fi
## BFD (Binary File Description) library
bfd_cppflags=""
bfd_ldflags=""
bfd_ldlibs=""
if test x"$with_bfd" != "xno"; then :
bfd_available=false
case $host in #(
x86_64-*-darwin*) :
if test -z "$BFD_INCLUDE_DIR"; then :
BFD_INCLUDE_DIR="/opt/local/include"
fi
if test -z "$BFD_LIB_DIR"; then :
BFD_LIB_DIR="/opt/local/lib"
fi ;; #(
*-*-openbsd*|*-*-freebsd*) :
if test -z "$BFD_INCLUDE_DIR"; then :
BFD_INCLUDE_DIR="/usr/local/include"
fi
if test -z "$BFD_LIB_DIR"; then :
BFD_LIB_DIR="/usr/local/lib"
fi ;; #(
*) :
;;
esac
if test -n "$BFD_INCLUDE_DIR"; then :
bfd_cppflags="-I$BFD_INCLUDE_DIR"
fi
if test -n "$BFD_LIB_DIR"; then :
bfd_ldflags="-L$BFD_LIB_DIR"
fi
SAVED_CPPFLAGS="$CPPFLAGS"
SAVED_LDFLAGS="$LDFLAGS"
CPPFLAGS="$CPPFLAGS $bfd_cppflags"
LDFLAGS="$LDFLAGS $bfd_ldflags"
ac_fn_c_check_header_mongrel "$LINENO" "bfd.h" "ac_cv_header_bfd_h" "$ac_includes_default"
if test "x$ac_cv_header_bfd_h" = xyes; then :
bfd_ldlibs=""
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5
$as_echo_n "checking for bfd_openr in -lbfd... " >&6; }
if ${ac_cv_lib_bfd_bfd_openr+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lbfd $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char bfd_openr ();
int
main ()
{
return bfd_openr ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_bfd_bfd_openr=yes
else
ac_cv_lib_bfd_bfd_openr=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_openr" >&5
$as_echo "$ac_cv_lib_bfd_bfd_openr" >&6; }
if test "x$ac_cv_lib_bfd_bfd_openr" = xyes; then :
bfd_ldlibs="-lbfd"
fi
if test -z "$bfd_ldlibs"; then :
unset ac_cv_lib_bfd_bfd_openr
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5
$as_echo_n "checking for bfd_openr in -lbfd... " >&6; }
if ${ac_cv_lib_bfd_bfd_openr+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lbfd $DLLIBS $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char bfd_openr ();
int
main ()
{
return bfd_openr ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_bfd_bfd_openr=yes
else
ac_cv_lib_bfd_bfd_openr=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_openr" >&5
$as_echo "$ac_cv_lib_bfd_bfd_openr" >&6; }
if test "x$ac_cv_lib_bfd_bfd_openr" = xyes; then :
bfd_ldlibs="-lbfd $DLLIBS"
fi
fi
if test -z "$bfd_ldlibs"; then :
unset ac_cv_lib_bfd_bfd_openr
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5
$as_echo_n "checking for bfd_openr in -lbfd... " >&6; }
if ${ac_cv_lib_bfd_bfd_openr+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lbfd $DLLIBS -liberty $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char bfd_openr ();
int
main ()
{
return bfd_openr ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_bfd_bfd_openr=yes
else
ac_cv_lib_bfd_bfd_openr=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_openr" >&5
$as_echo "$ac_cv_lib_bfd_bfd_openr" >&6; }
if test "x$ac_cv_lib_bfd_bfd_openr" = xyes; then :
bfd_ldlibs="-lbfd $DLLIBS -liberty"
fi
fi
if test -z "$bfd_ldlibs"; then :
unset ac_cv_lib_bfd_bfd_openr
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5
$as_echo_n "checking for bfd_openr in -lbfd... " >&6; }
if ${ac_cv_lib_bfd_bfd_openr+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lbfd $DLLIBS -liberty -lz $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char bfd_openr ();
int
main ()
{
return bfd_openr ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_bfd_bfd_openr=yes
else
ac_cv_lib_bfd_bfd_openr=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_openr" >&5
$as_echo "$ac_cv_lib_bfd_bfd_openr" >&6; }
if test "x$ac_cv_lib_bfd_bfd_openr" = xyes; then :
bfd_ldlibs="-lbfd $DLLIBS -liberty -lz"
fi
fi
if test -z "$bfd_ldlibs"; then :
unset ac_cv_lib_bfd_bfd_openr
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_openr in -lbfd" >&5
$as_echo_n "checking for bfd_openr in -lbfd... " >&6; }
if ${ac_cv_lib_bfd_bfd_openr+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lbfd $DLLIBS -liberty -lz -lintl $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char bfd_openr ();
int
main ()
{
return bfd_openr ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_bfd_bfd_openr=yes
else
ac_cv_lib_bfd_bfd_openr=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_openr" >&5
$as_echo "$ac_cv_lib_bfd_bfd_openr" >&6; }
if test "x$ac_cv_lib_bfd_bfd_openr" = xyes; then :
bfd_ldlibs="-lbfd $DLLIBS -liberty -lz -lintl"
fi
fi
if test -n "$bfd_ldlibs"; then :
bfd_available=true
$as_echo "#define HAS_LIBBFD 1" >>confdefs.h
fi
fi
if ! $bfd_available; then :
if test x"$with_bfd" = "xyes"; then :
as_fn_error $? "BFD library support requested but not available" "$LINENO" 5
else
bfd_cppflags=""
bfd_ldflags=""
{ $as_echo "$as_me:${as_lineno-$LINENO}: BFD library not found, 'ocamlobjinfo' will be unable to display info on .cmxs files." >&5
$as_echo "$as_me: BFD library not found, 'ocamlobjinfo' will be unable to display info on .cmxs files." >&6;}
fi
fi
LDFLAGS="$SAVED_LDFLAGS"
CPP_FLAGS="$SAVED_CPPFLAGS"
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: Support for the BFD (Binary File Description) library disabled, 'ocamlobjinfo' will be unable to display info on .cmxs files." >&5
$as_echo "$as_me: Support for the BFD (Binary File Description) library disabled, 'ocamlobjinfo' will be unable to display info on .cmxs files." >&6;}
fi
## Does the assembler support debug prefix map and CFI directives
as_has_debug_prefix_map=false
asm_cfi_supported=false

92
configure.ac
View File

@ -132,9 +132,6 @@ AC_SUBST([ocamltest])
AC_SUBST([pthread_link])
AC_SUBST([x_includes])
AC_SUBST([x_libraries])
AC_SUBST([bfd_cppflags])
AC_SUBST([bfd_ldflags])
AC_SUBST([bfd_ldlibs])
AC_SUBST([ASPP])
AC_SUBST([endianness])
AC_SUBST([AS])
@ -250,18 +247,6 @@ AC_ARG_VAR([LIBUNWIND_INCLUDE_DIR],
AC_ARG_VAR([LIBUNWIND_LIB_DIR],
[location of library files for libunwind])
AC_ARG_WITH([bfd],
[AS_HELP_STRING([--without-bfd],
[disable BFD (Binary File Description) library support])],
[],
[with_bfd=auto])
AC_ARG_VAR([BFD_INCLUDE_DIR],
[location of header files for the BFD library])
AC_ARG_VAR([BFD_LIB_DIR],
[location of library files for the BFD library])
AC_ARG_ENABLE([graph-lib], [],
[AC_MSG_ERROR([The graphics library is no longer distributed with OCaml \
since version 4.09. It is now distributed as a separate "graphics" package: \
@ -755,7 +740,6 @@ AS_IF([test "x$ac_cv_lib_m_cos" = xyes ], [mathlib="-lm"], [mathlib=""])
AC_CHECK_HEADER([math.h])
AC_CHECK_HEADERS([unistd.h],[AC_DEFINE([HAS_UNISTD])])
AC_CHECK_HEADER([stdint.h],[AC_DEFINE([HAS_STDINT_H])])
AC_CHECK_HEADER([sys/shm.h],[AC_DEFINE([HAS_SYS_SHM_H])])
AC_CHECK_HEADER([dirent.h], [AC_DEFINE([HAS_DIRENT])], [],
[#include <sys/types.h>])
@ -804,7 +788,7 @@ AC_MSG_NOTICE([Target is a $bits bits architecture])
AC_C_BIGENDIAN(
[
AC_DEFINE([ARCH_BIG_ENDIAN], [1]),
AC_DEFINE([ARCH_BIG_ENDIAN], [1])
[endianness="be"]
],
[endianness="le"],
@ -1579,6 +1563,13 @@ AC_CHECK_FUNC([accept4], [AC_DEFINE([HAS_ACCEPT4])])
AC_CHECK_FUNC([getauxval], [AC_DEFINE([HAS_GETAUXVAL])])
## shmat
AC_CHECK_HEADER([sys/shm.h],
[
AC_DEFINE([HAS_SYS_SHM_H])
AC_CHECK_FUNC([shmat], [AC_DEFINE([HAS_SHMAT])])
])
## execvpe
AC_CHECK_FUNC([execvpe], [AC_DEFINE([HAS_EXECVPE])])
@ -1639,6 +1630,7 @@ AS_IF([test x"$enable_systhreads" = "xno"],
AS_CASE([$host],
[*-*-solaris*], [pthread_link="-lpthread -lposix4"],
[*-*-haiku*], [pthread_link=""],
[*-*-android*], [pthread_link=""],
[pthread_link="-lpthread"])
common_cppflags="$common_cppflags -D_REENTRANT"
AC_MSG_NOTICE([the POSIX threads library is supported])
@ -1654,72 +1646,6 @@ AS_IF([test x"$enable_systhreads" = "xno"],
[systhread_support=false
AC_MSG_NOTICE([the POSIX threads library is not supported])])])])])
## BFD (Binary File Description) library
bfd_cppflags=""
bfd_ldflags=""
bfd_ldlibs=""
AS_IF([test x"$with_bfd" != "xno"],
[bfd_available=false
AS_CASE([$host],
[x86_64-*-darwin*],
[AS_IF([test -z "$BFD_INCLUDE_DIR"],
[BFD_INCLUDE_DIR="/opt/local/include"])
AS_IF([test -z "$BFD_LIB_DIR"],
[BFD_LIB_DIR="/opt/local/lib"])],
[*-*-openbsd*|*-*-freebsd*],
[AS_IF([test -z "$BFD_INCLUDE_DIR"],
[BFD_INCLUDE_DIR="/usr/local/include"])
AS_IF([test -z "$BFD_LIB_DIR"],
[BFD_LIB_DIR="/usr/local/lib"])])
AS_IF([test -n "$BFD_INCLUDE_DIR"],
[bfd_cppflags="-I$BFD_INCLUDE_DIR"])
AS_IF([test -n "$BFD_LIB_DIR"],
[bfd_ldflags="-L$BFD_LIB_DIR"])
SAVED_CPPFLAGS="$CPPFLAGS"
SAVED_LDFLAGS="$LDFLAGS"
CPPFLAGS="$CPPFLAGS $bfd_cppflags"
LDFLAGS="$LDFLAGS $bfd_ldflags"
AC_CHECK_HEADER([bfd.h],
[bfd_ldlibs=""
AC_CHECK_LIB([bfd], [bfd_openr], [bfd_ldlibs="-lbfd"])
AS_IF([test -z "$bfd_ldlibs"],
[unset ac_cv_lib_bfd_bfd_openr
AC_CHECK_LIB([bfd], [bfd_openr],
[bfd_ldlibs="-lbfd $DLLIBS"], [], [$DLLIBS])])
AS_IF([test -z "$bfd_ldlibs"],
[unset ac_cv_lib_bfd_bfd_openr
AC_CHECK_LIB([bfd], [bfd_openr],
[bfd_ldlibs="-lbfd $DLLIBS -liberty"], [], [$DLLIBS -liberty])])
AS_IF([test -z "$bfd_ldlibs"],
[unset ac_cv_lib_bfd_bfd_openr
AC_CHECK_LIB([bfd], [bfd_openr],
[bfd_ldlibs="-lbfd $DLLIBS -liberty -lz"], [], [$DLLIBS -liberty -lz])])
AS_IF([test -z "$bfd_ldlibs"],
[unset ac_cv_lib_bfd_bfd_openr
AC_CHECK_LIB([bfd], [bfd_openr],
[bfd_ldlibs="-lbfd $DLLIBS -liberty -lz -lintl"], [],
[$DLLIBS -liberty -lz -lintl])])
AS_IF([test -n "$bfd_ldlibs"],
[bfd_available=true
AC_DEFINE([HAS_LIBBFD])])])
AS_IF([! $bfd_available],
[AS_IF([test x"$with_bfd" = "xyes"],
[AC_MSG_ERROR([BFD library support requested but not available])],
[bfd_cppflags=""
bfd_ldflags=""
AC_MSG_NOTICE(m4_normalize([
BFD library not found, 'ocamlobjinfo' will be unable to display
info on .cmxs files.
]))])])
LDFLAGS="$SAVED_LDFLAGS"
CPP_FLAGS="$SAVED_CPPFLAGS"],
[AC_MSG_NOTICE(m4_normalize([
Support for the BFD (Binary File Description) library disabled,
'ocamlobjinfo' will be unable to display info on .cmxs files.
]))])
## Does the assembler support debug prefix map and CFI directives
as_has_debug_prefix_map=false
asm_cfi_supported=false

14
driver/compenv.ml
View File

@ -15,6 +15,8 @@
open Clflags
exception Exit_compiler of int
let output_prefix name =
let oname =
match !output_name with
@ -27,17 +29,19 @@ let print_version_and_library compiler =
print_string Config.version; print_newline();
print_string "Standard library directory: ";
print_string Config.standard_library; print_newline();
exit 0
raise (Exit_compiler 0)
let print_version_string () =
print_string Config.version; print_newline(); exit 0
print_string Config.version; print_newline();
raise (Exit_compiler 0)
let print_standard_library () =
print_string Config.standard_library; print_newline(); exit 0
print_string Config.standard_library; print_newline();
raise (Exit_compiler 0)
let fatal err =
prerr_endline err;
exit 2
raise (Exit_compiler 2)
let extract_output = function
| Some s -> s
@ -603,7 +607,7 @@ let process_action
| ProcessCFile name ->
readenv ppf (Before_compile name);
Location.input_name := name;
if Ccomp.compile_file name <> 0 then exit 2;
if Ccomp.compile_file name <> 0 then raise (Exit_compiler 2);
ccobjs := c_object_of_filename name :: !ccobjs
| ProcessObjects names ->
ccobjs := names @ !ccobjs

2
driver/compenv.mli
View File

@ -13,6 +13,8 @@
(* *)
(**************************************************************************)
exception Exit_compiler of int
val module_of_filename : string -> string -> string
val output_prefix : string -> string

116
driver/main.ml
View File

@ -1,116 +1,2 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Clflags
open Compenv
let usage = "Usage: ocamlc <options> <files>\nOptions are:"
(* Error messages to standard error formatter *)
let ppf = Format.err_formatter
module Options = Main_args.Make_bytecomp_options (Main_args.Default.Main)
let main () =
Clflags.add_arguments __LOC__ Options.list;
Clflags.add_arguments __LOC__
["-depend", Arg.Unit Makedepend.main_from_option,
"<options> Compute dependencies (use 'ocamlc -depend -help' for details)"];
try
readenv ppf Before_args;
Clflags.parse_arguments anonymous usage;
Compmisc.read_clflags_from_env ();
if !Clflags.plugin then
fatal "-plugin is only supported up to OCaml 4.08.0";
begin try
Compenv.process_deferred_actions
(ppf,
Compile.implementation,
Compile.interface,
".cmo",
".cma");
with Arg.Bad msg ->
begin
prerr_endline msg;
Clflags.print_arguments usage;
exit 2
end
end;
readenv ppf Before_link;
if
List.length
(List.filter (fun x -> !x)
[make_archive;make_package;stop_early;output_c_object])
> 1
then begin
let module P = Clflags.Compiler_pass in
match !stop_after with
| None ->
fatal "Please specify at most one of -pack, -a, -c, -output-obj";
| Some ((P.Parsing | P.Typing) as p) ->
assert (P.is_compilation_pass p);
Printf.ksprintf fatal
"Options -i and -stop-after (%s) \
are incompatible with -pack, -a, -output-obj"
(String.concat "|"
(Clflags.Compiler_pass.available_pass_names ~native:false))
| Some P.Scheduling -> assert false (* native only *)
end;
if !make_archive then begin
Compmisc.init_path ();
Bytelibrarian.create_archive
(Compenv.get_objfiles ~with_ocamlparam:false)
(extract_output !output_name);
Warnings.check_fatal ();
end
else if !make_package then begin
Compmisc.init_path ();
let extracted_output = extract_output !output_name in
let revd = get_objfiles ~with_ocamlparam:false in
Compmisc.with_ppf_dump ~file_prefix:extracted_output (fun ppf_dump ->
Bytepackager.package_files ~ppf_dump (Compmisc.initial_env ())
revd (extracted_output));
Warnings.check_fatal ();
end
else if not !stop_early && !objfiles <> [] then begin
let target =
if !output_c_object && not !output_complete_executable then
let s = extract_output !output_name in
if (Filename.check_suffix s Config.ext_obj
|| Filename.check_suffix s Config.ext_dll
|| Filename.check_suffix s ".c")
then s
else
fatal
(Printf.sprintf
"The extension of the output file must be .c, %s or %s"
Config.ext_obj Config.ext_dll
)
else
default_output !output_name
in
Compmisc.init_path ();
Bytelink.link (get_objfiles ~with_ocamlparam:true) target;
Warnings.check_fatal ();
end;
with x ->
Location.report_exception ppf x;
exit 2
let () =
main ();
Profile.print Format.std_formatter !Clflags.profile_columns;
exit 0
exit (Maindriver.main Sys.argv Format.err_formatter)

4
driver/main_args.ml
View File

@ -1875,12 +1875,12 @@ module Default = struct
let print_version () =
Printf.printf "The OCaml toplevel, version %s\n" Sys.ocaml_version;
exit 0;
raise (Compenv.Exit_compiler 0);
;;
let print_version_num () =
Printf.printf "%s\n" Sys.ocaml_version;
exit 0;
raise (Compenv.Exit_compiler 0);
;;
let _args (_:string) = (* placeholder: wrap_expand Arg.read_arg *) [||]

114
driver/maindriver.ml Normal file
View File

@ -0,0 +1,114 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Clflags
open Compenv
let usage = "Usage: ocamlc <options> <files>\nOptions are:"
module Options = Main_args.Make_bytecomp_options (Main_args.Default.Main)
let main argv ppf =
Clflags.add_arguments __LOC__ Options.list;
Clflags.add_arguments __LOC__
["-depend", Arg.Unit Makedepend.main_from_option,
"<options> Compute dependencies (use 'ocamlc -depend -help' for details)"];
match
readenv ppf Before_args;
Clflags.parse_arguments argv anonymous usage;
Compmisc.read_clflags_from_env ();
if !Clflags.plugin then
fatal "-plugin is only supported up to OCaml 4.08.0";
begin try
Compenv.process_deferred_actions
(ppf,
Compile.implementation,
Compile.interface,
".cmo",
".cma");
with Arg.Bad msg ->
begin
prerr_endline msg;
Clflags.print_arguments usage;
exit 2
end
end;
readenv ppf Before_link;
if
List.length
(List.filter (fun x -> !x)
[make_archive;make_package;stop_early;output_c_object])
> 1
then begin
let module P = Clflags.Compiler_pass in
match !stop_after with
| None ->
fatal "Please specify at most one of -pack, -a, -c, -output-obj";
| Some ((P.Parsing | P.Typing) as p) ->
assert (P.is_compilation_pass p);
Printf.ksprintf fatal
"Options -i and -stop-after (%s) \
are incompatible with -pack, -a, -output-obj"
(String.concat "|"
(Clflags.Compiler_pass.available_pass_names ~native:false))
| Some P.Scheduling -> assert false (* native only *)
end;
if !make_archive then begin
Compmisc.init_path ();
Bytelibrarian.create_archive
(Compenv.get_objfiles ~with_ocamlparam:false)
(extract_output !output_name);
Warnings.check_fatal ();
end
else if !make_package then begin
Compmisc.init_path ();
let extracted_output = extract_output !output_name in
let revd = get_objfiles ~with_ocamlparam:false in
Compmisc.with_ppf_dump ~file_prefix:extracted_output (fun ppf_dump ->
Bytepackager.package_files ~ppf_dump (Compmisc.initial_env ())
revd (extracted_output));
Warnings.check_fatal ();
end
else if not !stop_early && !objfiles <> [] then begin
let target =
if !output_c_object && not !output_complete_executable then
let s = extract_output !output_name in
if (Filename.check_suffix s Config.ext_obj
|| Filename.check_suffix s Config.ext_dll
|| Filename.check_suffix s ".c")
then s
else
fatal
(Printf.sprintf
"The extension of the output file must be .c, %s or %s"
Config.ext_obj Config.ext_dll
)
else
default_output !output_name
in
Compmisc.init_path ();
Bytelink.link (get_objfiles ~with_ocamlparam:true) target;
Warnings.check_fatal ();
end;
with
| exception (Compenv.Exit_compiler n) ->
n
| exception x ->
Location.report_exception ppf x;
2
| () ->
Profile.print Format.std_formatter !Clflags.profile_columns;
0

9
driver/main.mli → driver/maindriver.mli
View File

@ -13,6 +13,9 @@
(* *)
(**************************************************************************)
(*
this "empty" file is here to speed up garbage collection in ocamlc.opt
*)
(* [main argv ppf] runs the compiler with arguments [argv], printing any
errors encountered to [ppf], and returns the exit code.
NB: Due to internal state in the compiler, calling [main] twice during
the same process is unsupported. *)
val main : string array -> Format.formatter -> int

38
driver/makedepend.ml
View File

@ -562,6 +562,18 @@ let parse_map fname =
module_map := String.Map.add modname mm !module_map
;;
(* Dependency processing *)
type dep_arg =
| Map of Misc.filepath (* -map option *)
| Src of Misc.filepath * file_kind option (* -impl, -intf or anon arg *)
let process_dep_arg = function
| Map file -> parse_map file
| Src (file, None) -> file_dependencies file
| Src (file, (Some file_kind)) -> file_dependencies_as file_kind file
let process_dep_args dep_args = List.iter process_dep_arg dep_args
(* Entry point *)
@ -575,7 +587,10 @@ let print_version_num () =
exit 0;
;;
let main () =
let run_main argv =
let dep_args_rev : dep_arg list ref = ref [] in
let add_dep_arg f s = dep_args_rev := (f s) :: !dep_args_rev in
Clflags.classic := false;
Compenv.readenv ppf Before_args;
Clflags.reset_arguments (); (* reset arguments from ocamlc/ocamlopt *)
@ -596,11 +611,11 @@ let main () =
"-nocwd", Arg.Set nocwd,
" Do not add current working directory to \
the list of include directories";
"-impl", Arg.String (file_dependencies_as ML),
"-impl", Arg.String (add_dep_arg (fun f -> Src (f, Some ML))),
"<f> Process <f> as a .ml file";
"-intf", Arg.String (file_dependencies_as MLI),
"-intf", Arg.String (add_dep_arg (fun f -> Src (f, Some MLI))),
"<f> Process <f> as a .mli file";
"-map", Arg.String parse_map,
"-map", Arg.String (add_dep_arg (fun f -> Map f)),
"<f> Read <f> and propagate delayed dependencies to following files";
"-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms),
"<e> Consider <e> as a synonym of the .ml extension";
@ -643,19 +658,24 @@ let main () =
Printf.sprintf "Usage: %s [options] <source files>\nOptions are:"
(Filename.basename Sys.argv.(0))
in
Clflags.parse_arguments file_dependencies usage;
Clflags.parse_arguments argv (add_dep_arg (fun f -> Src (f, None))) usage;
process_dep_args (List.rev !dep_args_rev);
Compenv.readenv ppf Before_link;
if !sort_files then sort_files_by_dependencies !files
else List.iter print_file_dependencies (List.sort compare !files);
exit (if Error_occurred.get () then 2 else 0)
let main () =
run_main Sys.argv
let main_from_option () =
if Sys.argv.(1) <> "-depend" then begin
Printf.eprintf
"Fatal error: argument -depend must be used as first argument.\n%!";
exit 2;
end;
incr Arg.current;
Sys.argv.(0) <- Sys.argv.(0) ^ " -depend";
Sys.argv.(!Arg.current) <- Sys.argv.(0);
main ()
let args =
Array.concat [ [| Sys.argv.(0) ^ " -depend" |];
Array.sub Sys.argv 2 (Array.length Sys.argv - 2) ] in
Sys.argv.(0) <- args.(0);
run_main args

139
driver/optmain.ml
View File

@ -1,139 +1,2 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Clflags
open Compenv
module Backend = struct
(* See backend_intf.mli. *)
let symbol_for_global' = Compilenv.symbol_for_global'
let closure_symbol = Compilenv.closure_symbol
let really_import_approx = Import_approx.really_import_approx
let import_symbol = Import_approx.import_symbol
let size_int = Arch.size_int
let big_endian = Arch.big_endian
let max_sensible_number_of_arguments =
(* The "-1" is to allow for a potential closure environment parameter. *)
Proc.max_arguments_for_tailcalls - 1
end
let backend = (module Backend : Backend_intf.S)
let usage = "Usage: ocamlopt <options> <files>\nOptions are:"
module Options = Main_args.Make_optcomp_options (Main_args.Default.Optmain)
let main () =
native_code := true;
let ppf = Format.err_formatter in
try
readenv ppf Before_args;
Clflags.add_arguments __LOC__ (Arch.command_line_options @ Options.list);
Clflags.add_arguments __LOC__
["-depend", Arg.Unit Makedepend.main_from_option,
"<options> Compute dependencies \
(use 'ocamlopt -depend -help' for details)"];
Clflags.parse_arguments anonymous usage;
Compmisc.read_clflags_from_env ();
if !Clflags.plugin then
fatal "-plugin is only supported up to OCaml 4.08.0";
begin try
Compenv.process_deferred_actions
(ppf,
Optcompile.implementation ~backend,
Optcompile.interface,
".cmx",
".cmxa");
with Arg.Bad msg ->
begin
prerr_endline msg;
Clflags.print_arguments usage;
exit 2
end
end;
readenv ppf Before_link;
if
List.length (List.filter (fun x -> !x)
[make_package; make_archive; shared;
stop_early; output_c_object]) > 1
then
begin
let module P = Clflags.Compiler_pass in
match !stop_after with
| None ->
fatal "Please specify at most one of -pack, -a, -shared, -c, \
-output-obj";
| Some ((P.Parsing | P.Typing | P.Scheduling) as p) ->
assert (P.is_compilation_pass p);
Printf.ksprintf fatal
"Options -i and -stop-after (%s) \
are incompatible with -pack, -a, -shared, -output-obj"
(String.concat "|"
(Clflags.Compiler_pass.available_pass_names ~native:true))
end;
if !make_archive then begin
Compmisc.init_path ();
let target = extract_output !output_name in
Asmlibrarian.create_archive
(get_objfiles ~with_ocamlparam:false) target;
Warnings.check_fatal ();
end
else if !make_package then begin
Compmisc.init_path ();
let target = extract_output !output_name in
Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump ->
Asmpackager.package_files ~ppf_dump (Compmisc.initial_env ())
(get_objfiles ~with_ocamlparam:false) target ~backend);
Warnings.check_fatal ();
end
else if !shared then begin
Compmisc.init_path ();
let target = extract_output !output_name in
Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump ->
Asmlink.link_shared ~ppf_dump
(get_objfiles ~with_ocamlparam:false) target);
Warnings.check_fatal ();
end
else if not !stop_early && !objfiles <> [] then begin
let target =
if !output_c_object then
let s = extract_output !output_name in
if (Filename.check_suffix s Config.ext_obj
|| Filename.check_suffix s Config.ext_dll)
then s
else
fatal
(Printf.sprintf
"The extension of the output file must be %s or %s"
Config.ext_obj Config.ext_dll
)
else
default_output !output_name
in
Compmisc.init_path ();
Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump ->
Asmlink.link ~ppf_dump (get_objfiles ~with_ocamlparam:true) target);
Warnings.check_fatal ();
end;
with x ->
Location.report_exception ppf x;
exit 2
let () =
main ();
Profile.print Format.std_formatter !Clflags.profile_columns;
exit 0
exit (Optmaindriver.main Sys.argv Format.err_formatter)

139
driver/optmaindriver.ml Normal file
View File

@ -0,0 +1,139 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Clflags
open Compenv
module Backend = struct
(* See backend_intf.mli. *)
let symbol_for_global' = Compilenv.symbol_for_global'
let closure_symbol = Compilenv.closure_symbol
let really_import_approx = Import_approx.really_import_approx
let import_symbol = Import_approx.import_symbol
let size_int = Arch.size_int
let big_endian = Arch.big_endian
let max_sensible_number_of_arguments =
(* The "-1" is to allow for a potential closure environment parameter. *)
Proc.max_arguments_for_tailcalls - 1
end
let backend = (module Backend : Backend_intf.S)
let usage = "Usage: ocamlopt <options> <files>\nOptions are:"
module Options = Main_args.Make_optcomp_options (Main_args.Default.Optmain)
let main argv ppf =
native_code := true;
match
readenv ppf Before_args;
Clflags.add_arguments __LOC__ (Arch.command_line_options @ Options.list);
Clflags.add_arguments __LOC__
["-depend", Arg.Unit Makedepend.main_from_option,
"<options> Compute dependencies \
(use 'ocamlopt -depend -help' for details)"];
Clflags.parse_arguments argv anonymous usage;
Compmisc.read_clflags_from_env ();
if !Clflags.plugin then
fatal "-plugin is only supported up to OCaml 4.08.0";
begin try
Compenv.process_deferred_actions
(ppf,
Optcompile.implementation ~backend,
Optcompile.interface,
".cmx",
".cmxa");
with Arg.Bad msg ->
begin
prerr_endline msg;
Clflags.print_arguments usage;
exit 2
end
end;
readenv ppf Before_link;
if
List.length (List.filter (fun x -> !x)
[make_package; make_archive; shared;
stop_early; output_c_object]) > 1
then
begin
let module P = Clflags.Compiler_pass in
match !stop_after with
| None ->
fatal "Please specify at most one of -pack, -a, -shared, -c, \
-output-obj";
| Some ((P.Parsing | P.Typing | P.Scheduling) as p) ->
assert (P.is_compilation_pass p);
Printf.ksprintf fatal
"Options -i and -stop-after (%s) \
are incompatible with -pack, -a, -shared, -output-obj"
(String.concat "|"
(Clflags.Compiler_pass.available_pass_names ~native:true))
end;
if !make_archive then begin
Compmisc.init_path ();
let target = extract_output !output_name in
Asmlibrarian.create_archive
(get_objfiles ~with_ocamlparam:false) target;
Warnings.check_fatal ();
end
else if !make_package then begin
Compmisc.init_path ();
let target = extract_output !output_name in
Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump ->
Asmpackager.package_files ~ppf_dump (Compmisc.initial_env ())
(get_objfiles ~with_ocamlparam:false) target ~backend);
Warnings.check_fatal ();
end
else if !shared then begin
Compmisc.init_path ();
let target = extract_output !output_name in
Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump ->
Asmlink.link_shared ~ppf_dump
(get_objfiles ~with_ocamlparam:false) target);
Warnings.check_fatal ();
end
else if not !stop_early && !objfiles <> [] then begin
let target =
if !output_c_object then
let s = extract_output !output_name in
if (Filename.check_suffix s Config.ext_obj
|| Filename.check_suffix s Config.ext_dll)
then s
else
fatal
(Printf.sprintf
"The extension of the output file must be %s or %s"
Config.ext_obj Config.ext_dll
)
else
default_output !output_name
in
Compmisc.init_path ();
Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump ->
Asmlink.link ~ppf_dump (get_objfiles ~with_ocamlparam:true) target);
Warnings.check_fatal ();
end;
with
| exception (Exit_compiler n) ->
n
| exception x ->
Location.report_exception ppf x;
2
| () ->
Profile.print Format.std_formatter !Clflags.profile_columns;
0

9
driver/optmain.mli → driver/optmaindriver.mli
View File

@ -13,6 +13,9 @@
(* *)
(**************************************************************************)
(*
this "empty" file is here to speed up garbage collection in ocamlopt.opt
*)
(* [main argv ppf] runs the compiler with arguments [argv], printing any
errors encountered to [ppf], and returns the exit code.
NB: Due to internal state in the compiler, calling [main] twice during
the same process is unsupported. *)
val main : string array -> Format.formatter -> int

2
driver/pparse.ml
View File

@ -175,7 +175,7 @@ let file_aux ~tool_name inputfile (type a) parse_fun invariant_fun
Location.input_name := (input_value ic : string);
if !Clflags.unsafe then
Location.prerr_warning (Location.in_file !Location.input_name)
Warnings.Unsafe_without_parsing;
Warnings.Unsafe_array_syntax_without_parsing;
let ast = (input_value ic : a) in
if !Clflags.all_ppx = [] then invariant_fun ast;
(* if all_ppx <> [], invariant_fun will be called by apply_rewriters *)

100
lambda/matching.ml
View File

@ -3325,13 +3325,47 @@ let check_partial pat_act_list =
(* have toplevel handler when appropriate *)
let check_total total lambda i handler_fun =
type failer_kind =
| Raise_match_failure
| Reraise_noloc of lambda
let failure_handler ~scopes loc ~failer () =
match failer with
| Reraise_noloc exn_lam ->
Lprim (Praise Raise_reraise, [ exn_lam ], Scoped_location.Loc_unknown)
| Raise_match_failure ->
let sloc = Scoped_location.of_location ~scopes loc in
let slot =
transl_extension_path sloc
Env.initial_safe_string Predef.path_match_failure
in
let fname, line, char =
Location.get_pos_info loc.Location.loc_start in
Lprim
( Praise Raise_regular,
[ Lprim
( Pmakeblock (0, Immutable, None),
[ slot;
Lconst
(Const_block
( 0,
[ Const_base (Const_string (fname, loc, None));
Const_base (Const_int line);
Const_base (Const_int char)
] ))
],
sloc )
],
sloc )
let check_total ~scopes loc ~failer total lambda i =
if Jumps.is_empty total then
lambda
else
Lstaticcatch (lambda, (i, []), handler_fun ())
Lstaticcatch (lambda, (i, []),
failure_handler ~scopes loc ~failer ())
let compile_matching ~scopes repr handler_fun arg pat_act_list partial =
let compile_matching ~scopes loc ~failer repr arg pat_act_list partial =
let partial = check_partial pat_act_list partial in
match partial with
| Partial -> (
@ -3346,7 +3380,7 @@ let compile_matching ~scopes repr handler_fun arg pat_act_list partial =
try
let lambda, total =
compile_match ~scopes repr partial (Context.start 1) pm in
check_total total lambda raise_num handler_fun
check_total ~scopes loc ~failer total lambda raise_num
with Unused -> assert false
(* ; handler_fun() *)
)
@ -3362,43 +3396,25 @@ let compile_matching ~scopes repr handler_fun arg pat_act_list partial =
assert (Jumps.is_empty total);
lambda
let partial_function ~scopes loc () =
let sloc = Scoped_location.of_location ~scopes loc in
let slot =
transl_extension_path sloc Env.initial_safe_string Predef.path_match_failure
in
let fname, line, char =
Location.get_pos_info loc.Location.loc_start in
Lprim
( Praise Raise_regular,
[ Lprim
( Pmakeblock (0, Immutable, None),
[ slot;
Lconst
(Const_block
( 0,
[ Const_base (Const_string (fname, loc, None));
Const_base (Const_int line);
Const_base (Const_int char)
] ))
],
sloc )
],
sloc )
let for_function ~scopes loc repr param pat_act_list partial =
let f () = partial_function ~scopes loc () in
compile_matching ~scopes repr f param pat_act_list partial
compile_matching ~scopes loc ~failer:Raise_match_failure
repr param pat_act_list partial
(* In the following two cases, exhaustiveness info is not available! *)
let for_trywith ~scopes param pat_act_list =
compile_matching ~scopes None
(fun () -> Lprim (Praise Raise_reraise, [ param ], Loc_unknown))
param pat_act_list Partial
let for_trywith ~scopes loc param pat_act_list =
(* Note: the failure action of [for_trywith] corresponds
to an exception that is not matched by a try..with handler,
and is thus reraised for the next handler in the stack.
It is important to *not* include location information in
the reraise (hence the [_noloc]) to avoid seeing this
silent reraise in exception backtraces. *)
compile_matching ~scopes loc ~failer:(Reraise_noloc param)
None param pat_act_list Partial
let simple_for_let ~scopes loc param pat body =
compile_matching ~scopes None (partial_function ~scopes loc)
param [ (pat, body) ] Partial
compile_matching ~scopes loc ~failer:Raise_match_failure
None param [ (pat, body) ] Partial
(* Optimize binding of immediate tuples
@ -3576,8 +3592,10 @@ let for_tupled_function ~scopes loc paraml pats_act_list partial =
compile_match ~scopes None partial
(Context.start (List.length paraml)) pm
in
check_total total lambda raise_num (partial_function ~scopes loc)
with Unused -> partial_function ~scopes loc ()
check_total ~scopes loc ~failer:Raise_match_failure
total lambda raise_num
with Unused ->
failure_handler ~scopes loc ~failer:Raise_match_failure ()
let flatten_pattern size p =
match p.pat_desc with
@ -3684,7 +3702,8 @@ let do_for_multiple_match ~scopes loc paraml pat_act_list partial =
compile_match ~scopes None partial (Context.start 1) pm1 in
begin match partial with
| Partial ->
check_total total lambda raise_num (partial_function ~scopes loc)
check_total ~scopes loc ~failer:Raise_match_failure
total lambda raise_num
| Total ->
assert (Jumps.is_empty total);
lambda
@ -3704,7 +3723,8 @@ let do_for_multiple_match ~scopes loc paraml pat_act_list partial =
List.fold_right2 (bind Strict) idl paraml
( match partial with
| Partial ->
check_total total lam raise_num (partial_function ~scopes loc)
check_total ~scopes loc ~failer:Raise_match_failure
total lam raise_num
| Total ->
assert (Jumps.is_empty total);
lam

2
lambda/matching.mli
View File

@ -25,7 +25,7 @@ val for_function:
int ref option -> lambda -> (pattern * lambda) list -> partial ->
lambda
val for_trywith:
scopes:scopes ->
scopes:scopes -> Location.t ->
lambda -> (pattern * lambda) list ->
lambda
val for_let:

6
lambda/simplif.ml
View File

@ -619,9 +619,9 @@ let rec emit_tail_infos is_tail lambda =
But then this means getting different warnings depending
on whether the native or bytecode compiler is used. *)
if not is_tail
&& Warnings.is_active Warnings.Expect_tailcall
&& Warnings.is_active Warnings.Tailcall_expected
then Location.prerr_warning (to_location ap.ap_loc)
Warnings.Expect_tailcall;
Warnings.Tailcall_expected;
end;
emit_tail_infos false ap.ap_func;
list_emit_tail_infos false ap.ap_args
@ -887,6 +887,6 @@ let simplify_lambda lam =
|> simplify_exits
|> simplify_lets
in
if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall
if !Clflags.annotations || Warnings.is_active Warnings.Tailcall_expected
then emit_tail_infos true lam;
lam

4
lambda/translcore.ml
View File

@ -292,7 +292,7 @@ and transl_exp0 ~scopes e =
| Texp_try(body, pat_expr_list) ->
let id = Typecore.name_cases "exn" pat_expr_list in
Ltrywith(transl_exp ~scopes body, id,
Matching.for_trywith ~scopes (Lvar id)
Matching.for_trywith ~scopes e.exp_loc (Lvar id)
(transl_cases_try ~scopes pat_expr_list))
| Texp_tuple el ->
let ll, shape = transl_list_with_shape ~scopes el in
@ -1035,7 +1035,7 @@ and transl_match ~scopes e arg pat_expr_list partial =
let static_exception_id = next_raise_count () in
Lstaticcatch
(Ltrywith (Lstaticraise (static_exception_id, body), id,
Matching.for_trywith ~scopes (Lvar id) exn_cases),
Matching.for_trywith ~scopes e.exp_loc (Lvar id) exn_cases),
(static_exception_id, val_ids),
handler)
in

2
man/ocamlc.m
View File

@ -697,7 +697,7 @@ Enable, disable, or mark as fatal the warnings specified by the argument
Each warning can be
.IR enabled \ or\ disabled ,
and each warning can be
.IR fatal or
.IR fatal \ or
.IR non-fatal .
If a warning is disabled, it isn't displayed and doesn't affect
compilation in any way (even if it is fatal). If a warning is enabled,

1
manual/README.md
View File

@ -87,6 +87,7 @@ chapters (or sometimes sections) are mapped to a distinct `.etex` file:
- Optimisation with Flambda: `flambda.etex`
- Memory profiling with Spacetime: `spacetime-chapter.etex`
- Fuzzing with afl-fuzz: `afl-fuzz.etex`
- Runtime tracing with the instrumented runtime: `instrumented-runtime.etex`
Note that ocamlc,ocamlopt and the toplevel options overlap a lot.
Consequently, these options are described together in the file

5
manual/manual/Makefile
View File

@ -147,12 +147,13 @@ warnings-help.etex: $(SRC)/utils/warnings.ml $(SRC)/ocamlc
echo "% when a new warning is documented.";\
echo "%";\
$(SET_LD_PATH) $(SRC)/boot/ocamlrun $(SRC)/ocamlc -warn-help \
| sed -e 's/^ *\([0-9A-Z][0-9]*\)\(.*\)/\\item[\1] \2/'\
| sed -e 's/^ *\([0-9][0-9]*\) *\[\([a-z][a-z-]*\)\]\(.*\)/\\item[\1 "\2"] \3/' \
-e 's/^ *\([0-9A-Z][0-9]*\) *\([^]].*\)/\\item[\1] \2/'\
) >$@
# sed --inplace is not portable, emulate
for i in 52 57; do\
sed\
s'/\\item\['$$i'\]/\\item\['$$i' (see \\ref{ss:warn'$$i'})\]/'\
s'/\\item\[\('$$i'[^]]*\)\]/\\item\[\1 (see \\ref{ss:warn'$$i'})\]/'\
$@ > $@.tmp;\
mv $@.tmp $@;\
done

1
manual/manual/allfiles.etex
View File

@ -73,6 +73,7 @@ and as a
\input{flambda.tex}
\input{spacetime-chapter.tex}
\input{afl-fuzz.tex}
\input{instrumented-runtime.tex}
\part{The OCaml library}
\label{p:library}

4
manual/manual/cmds/Makefile
View File

@ -13,12 +13,12 @@ TRANSF = $(SET_LD_PATH) $(OCAMLRUN) $(TOOLS)/transf
FILES = comp.tex top.tex runtime.tex native.tex lexyacc.tex intf-c.tex \
ocamldep.tex profil.tex debugger.tex browser.tex ocamldoc.tex \
warnings-help.tex ocamlbuild.tex flambda.tex spacetime-chapter.tex \
afl-fuzz.tex unified-options.tex
afl-fuzz.tex instrumented-runtime.tex unified-options.tex
WITH_TRANSF = top.tex intf-c.tex flambda.tex spacetime-chapter.tex \
afl-fuzz.tex lexyacc.tex debugger.tex
WITH_CAMLEXAMPLE = ocamldoc.tex
WITH_CAMLEXAMPLE = instrumented-runtime.tex ocamldoc.tex
etex-files: $(FILES)

315
manual/manual/cmds/instrumented-runtime.etex Normal file
View File

@ -0,0 +1,315 @@
\chapter{Runtime tracing with the instrumented runtime}
%HEVEA\cutname{instrumented-runtime.html}
This chapter describes the OCaml instrumented runtime, a runtime variant
allowing the collection of events and metrics.
Collected metrics include time spent executing the {\em garbage collector}.
The overall execution time of individual pauses are measured
down to the time spent in specific parts of the garbage collection.
Insight is also given on memory allocation and motion by recording
the size of allocated memory blocks, as well as value promotions from the
{\em minor heap} to the {\em major heap}.
\section{s:instr-runtime-overview}{Overview}
Once compiled and linked with the instrumented runtime, any OCaml program
can generate {\em trace files} that can then be read
and analyzed by users in order to understand specific runtime behaviors.
The generated trace files are stored using the {\em Common Trace Format}, which
is a general purpose binary tracing format.
A complete trace consists of:
\begin{itemize}
\item a {\em metadata file}, part of the OCaml distribution
\item and a {\em trace file}, generated by the runtime\
in the program being traced.
\end{itemize}
For more information on the {\em Common Trace Format}, see
\href{https://diamon.org/ctf/}{https://diamon.org/ctf/}.
\section{s:instr-runtime-enabling}{Enabling runtime instrumentation}
For the following examples, we will use the following example program:
\begin{caml_example*}{verbatim}
module SMap = Map.Make(String)
let s i = String.make 512 (Char.chr (i mod 256))
let clear map = SMap.fold (fun k _ m -> SMap.remove k m) map map
let rec seq i =
if i = 0 then Seq.empty else fun () -> (Seq.Cons (i, seq (i - 1)))
let () =
seq 1_000_000
|> Seq.fold_left (fun m i -> SMap.add (s i) i m) SMap.empty
|> clear
|> ignore
\end{caml_example*}
The next step is to compile and link the program with the instrumented runtime.
This can be done by using the "-runtime-variant" flag:
\begin{verbatim}
ocamlopt -runtime-variant i program.ml -o program
\end{verbatim}
Note that the instrumented runtime is an alternative runtime for OCaml
programs. It is only referenced during the linking stage of the final
executable. This means that the compilation stage does not need to be altered
to enable instrumentation.
The resulting program can then be traced by running it with the environment
variable "OCAML_EVENTLOG_ENABLED":
\begin{verbatim}
OCAML_EVENTLOG_ENABLED=1 ./program
\end{verbatim}
During execution, a trace file will be generated in the
program's current working directory.
\subsubsection*{sss:instr-runtime-build-more}{More build examples}
When using the {\em dune} build system, this compiler invocation can be
replicated using the {\tt flags} {\tt stanza} when building an executable.
\begin{verbatim}
(executable
(name program)
(flags "-runtime-variant=i"))
\end{verbatim}
The instrumented runtime can also be used with the OCaml bytecode interpreter.
This can be done by either using the
"-runtime-variant=i" flag when linking the program with {\tt ocamlc}, or by running the generated
bytecode through {\tt ocamlruni}:
\begin{verbatim}
ocamlc program.ml -o program.byte
OCAML_EVENTLOG_ENABLED=1 ocamlruni program.byte
\end{verbatim}
See chapter~\ref{c:camlc} and chapter~\ref{c:runtime} for more information about
{\tt ocamlc} and {\tt ocamlrun}.
\section{s:instr-runtime-read}{Reading traces}
Traces generated by the instrumented runtime can be analyzed with tooling
available outside of the OCaml distribution.
A complete trace consists of a {\em metadata file} and a {\em trace file}.
Two simple ways to work with the traces are the {\em eventlog-tools} and
{\em babeltrace} libraries.
\subsection{ss:instr-runtime-tools}{eventlog-tools}
{\em eventlog-tools} is a library implementing a parser, as well as a
a set of tools that allows to perform basic format conversions and analysis.
For more information about {\em eventlog-tools}, refer to the project's
main page: \href{https://github.com/ocaml-multicore/eventlog-tools}{https://github.com/ocaml-multicore/eventlog-tools}
\subsection{ss:instr-runtime-babeltrace}{babeltrace}
{\em babeltrace} is a C library, as well as a Python binding and set of tools
that serve as the reference implementation for the {\em Common Trace Format}.
The {\em babeltrace} command line utility allows for a basic rendering
of a trace's content, while the high level Python API can be used to
decode the trace and process them programmatically with libraries
such as {\em numpy} or {\em Jupyter}.
Unlike {\em eventlog-tools}, which possesses a specific knowledge of
OCaml's {\em Common Trace Format} schema, it is required to provide
the OCaml {\em metadata} file to {\em babeltrace}.
The metadata file is available in the OCaml installation.
Its location can be obtained using the following command:
\begin{verbatim}
ocamlc -where
\end{verbatim}
The {\em eventlog_metadata} file can be found at this path and
copied in the same directory as the generated trace file.
However, {\em babeltrace} expects the file to be named
{\tt metadata} in order to process the trace.
Thus, it will need to be renamed when copied to the trace's directory.
Here is a naive decoder example, using {\em babeltrace}'s Python
library, and {\em Python 3.8}:
\begin{verbatim}
import subprocess
import shutil
import sys
import babeltrace as bt
def print_event(ev):
print(ev['timestamp'])
print(ev['pid'])
if ev.name == "entry":
print('entry_event')
print(ev['phase'])
if ev.name == "exit":
print('exit_event')
print(ev['phase'])
if ev.name == "alloc":
print(ev['count'])
print(ev['bucket'])
if ev.name == "counter":
print(ev['count'])
print(ev['kind'])
if ev.name == "flush":
print("flush")
def get_ocaml_dir():
# Fetching OCaml's installation directory to extract the CTF metadata
ocamlc_where = subprocess.run(['ocamlc', '-where'], stdout=subprocess.PIPE)
ocaml_dir = ocamlc_where.stdout.decode('utf-8').rstrip('\n')
return(ocaml_dir)
def main():
trace_dir = sys.argv[1]
ocaml_dir = get_ocaml_dir()
metadata_path = ocaml_dir + "/eventlog_metadata"
# copying the metadata to the trace's directory,
# and renaming it to 'metadata'.
shutil.copyfile(metadata_path, trace_dir + "/metadata")
tr = bt.TraceCollection()
tr.add_trace(trace_dir, 'ctf')
for event in tr.events:
print_event(event)
if __name__ == '__main__':
main()
\end{verbatim}
This script expect to receive as an argument the directory containing the
trace file. It will then copy the {\em CTF} metadata file to the trace's
directory, and then decode the trace, printing each event in the process.
For more information on {\em babeltrace}, see the website at:
\href{https://babeltrace.org/}{https://babeltrace.org/}
\section{s:instr-runtime-more}{Controlling instrumentation and limitations}
\subsection{ss:instr-runtime-prefix}{Trace filename}
The default trace filename is {\tt caml-\{PID\}.eventlog}, where {\tt \{PID\}}
is the process identifier of the traced program.
This filename can also be specified using the
"OCAML_EVENTLOG_PREFIX" environment variable.
The given path will be suffixed with {\tt \{.PID\}.eventlog}.
\begin{verbatim}
OCAML_EVENTLOG_PREFIX=/tmp/a_prefix OCAML_EVENTLOG_ENABLED=1 ./program
\end{verbatim}
In this example, the trace will be available at path
{\tt /tmp/a_prefix.\{PID\}.eventlog}.
Note that this will only affect the prefix of the trace file, there is no
option to specify the full effective file name.
This restriction is in place to make room for future improvements to the
instrumented runtime, where the single trace file per session design
may be replaced.
For scripting purpose, matching against `\{PID\}`, as well as the
{\tt .eventlog} file extension should provide enough control over
the generated files.
Note as well that parent directories in the given path will not be created
when opening the trace. The runtime assumes the path is
accessible for creating and writing the trace. The program will
fail to start if this requirement isn't met.
\subsection{ss:instr-runtime-pause}{Pausing and resuming tracing}
Mechanisms are available to control event collection at runtime.
"OCAML_EVENTLOG_ENABLED" can be set to the {\tt p} flag in order
to start the program with event collection paused.
\begin{verbatim}
OCAML_EVENTLOG_ENABLED=p ./program
\end{verbatim}
The program will have to start event collection explicitly.
Starting and stopping event collection programmatically can be done by calling
{\tt Gc.eventlog_resume} and {\tt Gc.eventlog_pause}) from within the program.
Refer to the {\stdmoduleref{Gc}} module documentation for more information.
Running the program provided earlier with "OCAML_EVENTLOG_ENABLED=p"
will for example yield the following result.
\begin{verbatim}
$ OCAML_EVENTLOG_ENABLED=p ./program
$ ocaml-eventlog-report caml-{PID}.eventlog
==== eventlog/flush
median flush time: 58ns
total flush time: 58ns
flush count: 1
\end{verbatim}
The resulting trace contains only one event payload, namely a {\em flush} event,
indicating how much time was spent flushing the trace file to disk.
However, if the program is changed to include a call to
{\tt Gc.eventlog_resume}, events payloads can be seen again
in the trace file.
\begin{caml_example*}{verbatim}
let () =
Gc.eventlog_resume();
seq 1_000_000
|> Seq.fold_left (fun m i -> SMap.add (s i) i m) SMap.empty
|> clear
|> ignore
\end{caml_example*}
The resulting trace will contain all events encountered during
the program's execution:
\begin{verbatim}
$ ocaml-eventlog-report caml-{PID}.eventlog
[..omitted..]
==== force_minor/alloc_small
100.0K..200.0K: 174
20.0K..30.0K: 1
0..100: 1
==== eventlog/flush
median flush time: 207.8us
total flush time: 938.1us
flush count: 5
\end{verbatim}
\subsection{ss:instr-runtime-limitations}{Limitations}
The instrumented runtime does not support the {\tt fork} system call.
A child process forked from an instrumented program will not be traced.
The instrumented runtime aims to provide insight into the runtime's execution
while maintaining a low overhead.
However, this overhead may become more noticeable depending on how a program
executes.
The instrumented runtime currently puts a strong emphasis on
tracing {\em garbage collection} events. This means that programs
with heavy garbage collection activity may be more susceptible to
tracing induced performance penalties.
While providing an accurate estimate of potential performance loss is difficult,
test on various OCaml programs showed a total running time increase ranging
from 1\% to 8\%.
For a program with an extended running time where the collection of only a
small sample of events is required, using the {\em eventlog_resume} and
{\em eventlog_pause} primitives may help relieve some of the
tracing induced performance impact.

2
manual/manual/cmds/intf-c.etex
View File

@ -185,7 +185,7 @@ serialization and deserialization functions for custom blocks
\entree{"caml/threads.h"}{operations for interfacing in the presence
of multiple threads (see section~\ref{s:C-multithreading}).}
\end{tableau}
Before including any of these files, you should define the "OCAML_NAME_SPACE"
Before including any of these files, you should define the "CAML_NAME_SPACE"
macro. For instance,
\begin{verbatim}
#define CAML_NAME_SPACE

14
manual/manual/cmds/unified-options.etex
View File

@ -753,8 +753,18 @@ to \var{uppercase-letter}.
to \var{lowercase-letter}.
\end{options}
Warning numbers and letters which are out of the range of warnings
that are currently defined are ignored. The warnings are as follows.
Alternatively, \var{warning-list} can specify a single warning using its
mnemonic name (see below), as follows:
\begin{options}
\item["+"\var{name}] Enable warning \var{name}.
\item["-"\var{name}] Disable warning \var{name}.
\item["@"\var{name}] Enable and mark as fatal warning \var{name}.
\end{options}
Warning numbers, letters and names which are not currently defined are
ignored. The warnings are as follows (the name following each number specifies
the mnemonic for that warning).
\begin{options}
\input{warnings-help.tex}
\end{options}

4
middle_end/flambda/inline_and_simplify.ml
View File

@ -1026,7 +1026,7 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t =
[block_approx; _field_approx; value_approx] ->
if A.warn_on_mutation block_approx then begin
Location.prerr_warning (Debuginfo.to_location dbg)
Warnings.Assignment_to_non_mutable_value
Warnings.Flambda_assignment_to_non_mutable_value
end;
let kind =
let check () =
@ -1055,7 +1055,7 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t =
| Psetfield _, _block::_, block_approx::_ ->
if A.warn_on_mutation block_approx then begin
Location.prerr_warning (Debuginfo.to_location dbg)
Warnings.Assignment_to_non_mutable_value
Warnings.Flambda_assignment_to_non_mutable_value
end;
tree, ret r (A.value_unknown Other)
| (Psetfield _ | Parraysetu _ | Parraysets _), _, _ ->

68
ocamltest/ocaml_modifiers.ml
View File

@ -18,51 +18,53 @@
open Ocamltest_stdlib
open Environments
let wrap sl = " " ^ String.concat " " sl ^ " "
let append var sl = Append (var, wrap sl)
let add var s = Add (var, s)
let principal =
[
Append (Ocaml_variables.flags, " -principal ");
Add (Ocaml_variables.compiler_directory_suffix, ".principal");
Add (Ocaml_variables.compiler_reference_suffix, ".principal");
append Ocaml_variables.flags ["-principal"];
add Ocaml_variables.compiler_directory_suffix ".principal";
add Ocaml_variables.compiler_reference_suffix ".principal";
]
let latex =
[
Add (Ocaml_variables.ocamldoc_backend, "latex");
Append (Ocaml_variables.ocamldoc_flags, "-latex-type-prefix=TYP ");
Append (Ocaml_variables.ocamldoc_flags, "-latex-module-prefix= ");
Append (Ocaml_variables.ocamldoc_flags, "-latex-value-prefix= ");
Append (Ocaml_variables.ocamldoc_flags, "-latex-module-type-prefix= ");
Append (Ocaml_variables.ocamldoc_flags, "-latextitle=1,subsection* ");
Append (Ocaml_variables.ocamldoc_flags, "-latextitle=2,subsubsection* ");
Append (Ocaml_variables.ocamldoc_flags, "-latextitle=6,subsection* ");
Append (Ocaml_variables.ocamldoc_flags, "-latextitle=7,subsubsection* ");
add Ocaml_variables.ocamldoc_backend "latex";
append Ocaml_variables.ocamldoc_flags ["-latex-type-prefix=TYP"];
append Ocaml_variables.ocamldoc_flags ["-latex-module-prefix="];
append Ocaml_variables.ocamldoc_flags ["-latex-value-prefix="];
append Ocaml_variables.ocamldoc_flags ["-latex-module-type-prefix="];
append Ocaml_variables.ocamldoc_flags ["-latextitle=1,subsection*"];
append Ocaml_variables.ocamldoc_flags ["-latextitle=2,subsubsection*"];
append Ocaml_variables.ocamldoc_flags ["-latextitle=6,subsection*"];
append Ocaml_variables.ocamldoc_flags ["-latextitle=7,subsubsection*"];
]
let html =
[
Add (Ocaml_variables.ocamldoc_backend, "html");
Append (Ocaml_variables.ocamldoc_flags, "-colorize-code ");
add Ocaml_variables.ocamldoc_backend "html";
append Ocaml_variables.ocamldoc_flags ["-colorize-code"];
]
let man =
[
Add (Ocaml_variables.ocamldoc_backend, "man");
add Ocaml_variables.ocamldoc_backend "man";
]
let wrap str = (" " ^ str ^ " ")
let make_library_modifier library directory =
let make_library_modifier library directories =
[
Append (Ocaml_variables.directories, (wrap directory));
Append (Ocaml_variables.libraries, (wrap library));
Append (Ocaml_variables.caml_ld_library_path, (wrap directory));
append Ocaml_variables.directories directories;
append Ocaml_variables.libraries [library];
append Ocaml_variables.caml_ld_library_path directories;
]
let make_module_modifier unit_name directory =
[
Append (Ocaml_variables.directories, (wrap directory));
Append (Ocaml_variables.binary_modules, (wrap unit_name));
append Ocaml_variables.directories [directory];
append Ocaml_variables.binary_modules [unit_name];
]
let compiler_subdir subdir =
@ -70,11 +72,11 @@ let compiler_subdir subdir =
let config =
[
Append (Ocaml_variables.directories, (wrap (compiler_subdir ["utils"])));
append Ocaml_variables.directories [compiler_subdir ["utils"]];
]
let testing = make_library_modifier
"testing" (compiler_subdir ["testsuite"; "lib"])
"testing" [compiler_subdir ["testsuite"; "lib"]]
let tool_ocaml_lib = make_module_modifier
"lib" (compiler_subdir ["testsuite"; "lib"])
@ -82,18 +84,20 @@ let tool_ocaml_lib = make_module_modifier
let unixlibdir = if Sys.win32 then "win32unix" else "unix"
let unix = make_library_modifier
"unix" (compiler_subdir ["otherlibs"; unixlibdir])
"unix" [compiler_subdir ["otherlibs"; unixlibdir]]
let dynlink =
make_library_modifier "dynlink" (compiler_subdir ["otherlibs"; "dynlink"])
make_library_modifier "dynlink"
[compiler_subdir ["otherlibs"; "dynlink"];
compiler_subdir ["otherlibs"; "dynlink"; "native"]]
let str = make_library_modifier
"str" (compiler_subdir ["otherlibs"; "str"])
"str" [compiler_subdir ["otherlibs"; "str"]]
let systhreads =
unix @
(make_library_modifier
"threads" (compiler_subdir ["otherlibs"; "systhreads"]))
"threads" [compiler_subdir ["otherlibs"; "systhreads"]])
let compilerlibs_subdirs =
[
@ -111,11 +115,11 @@ let compilerlibs_subdirs =
]
let add_compiler_subdir subdir =
Append (Ocaml_variables.directories, (wrap (compiler_subdir [subdir])))
append Ocaml_variables.directories [compiler_subdir [subdir]]
let compilerlibs_archive archive =
(Append (Ocaml_variables.libraries, wrap archive)) ::
(List.map add_compiler_subdir compilerlibs_subdirs)
append Ocaml_variables.libraries [archive] ::
List.map add_compiler_subdir compilerlibs_subdirs
let debugger = [add_compiler_subdir "debugger"]

2
ocamltest/run_unix.c
View File

@ -147,6 +147,8 @@ static void update_environment(array local_env)
memcpy(value, pos_eq + 1, value_length);
value[value_length] = '\0';
setenv(name, value, 1); /* 1 means overwrite */
free(name);
free(value);
}
}
}

1
otherlibs/dynlink/Makefile
View File

@ -70,6 +70,7 @@ COMPILERLIBS_INTFS=\
# .ml files from compilerlibs that have corresponding .mli files.
COMPILERLIBS_SOURCES=\
utils/binutils.ml \
utils/config.ml \
utils/build_path_prefix_map.ml \
utils/misc.ml \

3
otherlibs/dynlink/dynlink_common.ml
View File

@ -316,12 +316,15 @@ module Make (P : Dynlink_platform_intf.S) = struct
global_state := state
let main_program_units () =
init ();
String.Set.elements (!global_state).main_program_units
let public_dynamically_loaded_units () =
init ();
String.Set.elements (!global_state).public_dynamically_loaded_units
let all_units () =
init ();
String.Set.elements (String.Set.union
(!global_state).main_program_units
(!global_state).public_dynamically_loaded_units)

6
parsing/docstrings.ml
View File

@ -44,18 +44,18 @@ let docstrings : docstring list ref = ref []
(* Warn for unused and ambiguous docstrings *)
let warn_bad_docstrings () =
if Warnings.is_active (Warnings.Bad_docstring true) then begin
if Warnings.is_active (Warnings.Unexpected_docstring true) then begin
List.iter
(fun ds ->
match ds.ds_attached with
| Info -> ()
| Unattached ->
prerr_warning ds.ds_loc (Warnings.Bad_docstring true)
prerr_warning ds.ds_loc (Warnings.Unexpected_docstring true)
| Docs ->
match ds.ds_associated with
| Zero | One -> ()
| Many ->
prerr_warning ds.ds_loc (Warnings.Bad_docstring false))
prerr_warning ds.ds_loc (Warnings.Unexpected_docstring false))
(List.rev !docstrings)
end

11
parsing/pprintast.ml
View File

@ -1255,7 +1255,16 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
Some (p, pt_tyvars, e_ct, e) else None
| _ -> None in
if x.pexp_attributes <> []
then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else
then
match p with
| {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _; _} as pat,
({ptyp_desc=Ptyp_poly _; _} as typ));
ppat_attributes=[]; _} ->
pp f "%a@;: %a@;=@;%a"
(simple_pattern ctxt) pat (core_type ctxt) typ (expression ctxt) x
| _ ->
pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
else
match is_desugared_gadt p x with
| Some (p, [], ct, e) ->
pp f "%a@;: %a@;=@;%a"

65
News → release-info/News
View File

@ -1,3 +1,68 @@
OCaml 4.10.0 (21 February 2020)
-------------------------------
- New best-fit allocator for the major heap
- Preliminary runtime work for OCaml multicore
- Immutable strings are now enforced at configuration time
- User-defined indexing operators for multidimensional arrays
- Coming soon: statmemprof, a new statistical memory profiler.
- The external API will be released next version.
- Various improvements to the manual
- More precise exhaustiveness check for GADTs
- Many bug fixes
OCaml 4.09.1 (18 March 2020)
----------------------------
Bug fixes.
OCaml 4.09.0 (18 September 2019)
--------------------------------
- New optimisations, in particular for affine functions in matches,
for instance:
type t = A | B | C
let affine = function
| A -> 4
| B -> 3
| C -> 2
- The `graphics` library was moved out of the compiler distribution.
- The `vmthread` library was removed.
- Support for compiler plugins was removed.
- Many bug fixes.
OCaml 4.08.1 (5 August 2019)
----------------------------
Bug fixes.
OCaml 4.08.0 (14 June 2019)
---------------------------
- Binding operators (let*, let+, and*, etc). They can be used to
streamline monadic code.
- `open` now applies to arbitrary module expression in structures and
to applicative paths in signatures.
- A new notion of (user-defined) "alerts" generalizes the deprecated
warning.
- New modules in the standard library: Fun, Bool, Int, Option, Result.
- A significant number of new functions in Float, including FMA
support, and a new Float.Array submodule.
- Source highlighting for errors and warnings in batch mode.
- Many error messages were improved.
- Improved AFL instrumentation for objects and lazy values.
OCaml 4.07.1 (4 October 2018)
-----------------------------

165
tools/release-checklist → release-info/howto.md
View File

@ -23,19 +23,25 @@ OCamlLabs folks (for OPAM testing).
```
rm -f /tmp/env-$USER.sh
cat >/tmp/env-$USER.sh <<EOF
# Update the data below
export MAJOR=4
export MINOR=08
export BUGFIX=0
export PLUSEXT=
# names for the release announce
export HUMAN=
# do we need to use tar or gtar?
export TAR=tar
export WORKTREE=~/o/\$MAJOR.\$MINOR
# must be the git worktree for the branch you are releasing
export BRANCH=\$MAJOR.\$MINOR
export VERSION=\$MAJOR.\$MINOR.\$BUGFIX\$PLUSEXT
export REPO=http://github.com/ocaml/ocaml
export REPO=https://github.com/ocaml/ocaml
# these values are specific to caml.inria's host setup
# they are defined in the release manager's .bashrc file
@ -45,6 +51,9 @@ export WEB_HOST="$OCAML_RELEASE_WEB_HOST"
export WEB_PATH="$OCAML_RELEASE_WEB_PATH"
export DIST="\$ARCHIVE_PATH/ocaml/ocaml-\$MAJOR.\$MINOR"
export INSTDIR="/tmp/ocaml-\$VERSION"
EOF
source /tmp/env-$USER.sh
echo $VERSION
@ -55,6 +64,7 @@ echo $VERSION
```
cd $WORKTREE
git checkout $MAJOR.$MINOR
git status # check that the local repo is in a clean state
git pull
```
@ -66,7 +76,7 @@ magic numbers have been updated since the last major release. It is
preferable to do this just before the first testing release for this
major version, typically the first beta.
See the HACKING file of `utils/` for documentation on how to bump the
See the `utils/HACKING.adoc` file for documentation on how to bump the
magic numbers.
## 3: build, refresh dependencies, sanity checks
@ -75,17 +85,25 @@ magic numbers.
make distclean
git clean -n -d -f -x # Check that "make distclean" removed everything
INSTDIR=/tmp/ocaml-${VERSION}
rm -rf ${INSTDIR}
./configure -prefix ${INSTDIR}
./configure --prefix=${INSTDIR}
make -j5
# Check that dependencies are up-to-date
make alldepend
git diff
# should have empty output
# check that .depend files have no absolute path in them
find . -name .depend | xargs grep ' /'
# must have empty output
# Run the check-typo script
./tools/check-typo
make install
./tools/check-symbol-names runtime/*.a
# must have empty output and return 0
@ -114,8 +132,8 @@ git commit -a -m "last commit before tagging $VERSION"
# 4.07.0+dev9-2018-06-26 => 4.07.0+rc2
# Update ocaml-variants.opam with new version.
# Update \year in manual/manual/macros.hva
rm -r autom4te.cache
make -B configure
# For a production release
make coreboot -j5
make coreboot -j5 # must say "Fixpoint reached, bootstrap succeeded."
git commit -m "release $VERSION" -a
@ -126,7 +144,6 @@ git tag -m "release $VERSION" $VERSION
# for testing candidates, use N+dev(D+2) instead; for example,
# 4.07.0+rc2 => 4.07.0+dev10-2018-06-26
# Revert ocaml-variants.opam to its "trunk" version.
rm -r autom4te.cache
make -B configure
git commit -m "increment version number after tagging $VERSION" VERSION configure ocaml-variants.opam
git push
@ -191,6 +208,16 @@ Remove any badge that tracks a version older than Debian stable.
## 6: create OPAM packages
Clone the opam-repository
```
git clone https://github.com/ocaml/opam-repository
```
Create a branch for the new release
```
git checkout -b OCaml_$VERSION
```
Create ocaml-variants packages for the new version, copying the particular
switch configuration choices from the previous version.
@ -198,6 +225,15 @@ Do not forget to add/update the checksum field for the tarballs in the
"url" section of the opam files. Use opam-lint before sending the pull
request.
You can test the new opam package before sending a PR to the
main opam-repository by using the local repository:
```
opam repo add local /path/to/your/opam-repository
opam switch create --repo=local,beta=git+https://github.com/ocaml/ocaml-beta-repository.git ocaml-variants.$VERSION
```
The switch should build.
## 6.1 Update OPAM dev packages after branching
Create a new ocaml/ocaml.$NEXT/opam file.
@ -210,6 +246,7 @@ The "src" field should point to
src: "https://github.com/ocaml/ocaml/archive/$VERSION.tar.gz"
The synopsis should be "latest $VERSION development(,...)".
## 7: build the release archives
```
@ -218,12 +255,11 @@ TMPDIR=/tmp/ocaml-release
git checkout $VERSION
git checkout-index -a -f --prefix=$TMPDIR/ocaml-$VERSION/
cd $TMPDIR
gtar -c --owner 0 --group 0 -f ocaml-$VERSION.tar ocaml-$VERSION
$TAR -c --owner 0 --group 0 -f ocaml-$VERSION.tar ocaml-$VERSION
gzip -9 <ocaml-$VERSION.tar >ocaml-$VERSION.tar.gz
xz <ocaml-$VERSION.tar >ocaml-$VERSION.tar.xz
```
## 8: upload the archives and compute checksums
For the first beta of a major version, create the distribution directory on
@ -341,112 +377,22 @@ organize the webpage for the new release. See
<https://github.com/ocaml/ocaml.org/issues/819>
## 13: announce the release on caml-list and caml-announce
## 13: announce the release on caml-list, caml-announce, and discuss.ocaml.org
See the email announce templates at the end of this file.
See the email announce templates in the `templates/` directory.
# Appendix
## Announcing a production release:
## Announce templates
```
Dear OCaml users,
See
We have the pleasure of celebrating <event> by announcing the release of
OCaml version $VERSION.
This is mainly a bug-fix release, see the list of changes below.
- templates/beta.md for alpha and beta releases
- templates/rc.md for release candidate
- templates/production.md for the production release
It is (or soon will be) available as a set of OPAM switches,
and as a source download here:
https://caml.inria.fr/pub/distrib/ocaml-$BRANCH/
Happy hacking,
-- Damien Doligez for the OCaml team.
<< insert the relevant Changes section >>
```
## Announcing a release candidate:
```
Dear OCaml users,
The release of OCaml version $MAJOR.$MINOR.$BUGFIX is imminent. We have
created a release candidate that you can test.
The source code is available at these addresses:
https://github.com/ocaml/ocaml/archive/$VERSION.tar.gz
https://caml.inria.fr/pub/distrib/ocaml-$BRANCH/ocaml-$VERSION.tar.gz
The compiler can also be installed as an OPAM switch with one of the
following commands.
opam switch create ocaml-variants.$VERSION --repositories=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git
or
opam switch create ocaml-variants.$VERSION+<VARIANT> --repositories=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git
where you replace <VARIANT> with one of these:
afl
default-unsafe-string
force-safe-string
flambda
fp
fp+flambda
We want to know about all bugs. Please report them here:
https://github.com/ocaml/ocaml/issues
Happy hacking,
-- Damien Doligez for the OCaml team.
<< insert the relevant Changes section >>
```
## Announcing a beta version:
```
Dear OCaml users,
The release of OCaml $MAJOR.$MINOR.$BUGFIX is approaching. We have created
a beta version to help you adapt your software to the new features
ahead of the release.
The source code is available at these addresses:
https://github.com/ocaml/ocaml/archive/$VERSION.tar.gz
https://caml.inria.fr/pub/distrib/ocaml-$BRANCH/$VERSION.tar.gz
The compiler can also be installed as an OPAM switch with one of the
following commands.
opam switch create ocaml-variants.$VERSION --repositories=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git
or
opam switch create ocaml-variants.$VERSION+<VARIANT> --repositories=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git
where you replace <VARIANT> with one of these:
afl
default-unsafe-string
force-safe-string
flambda
fp
fp+flambda
We want to know about all bugs. Please report them here:
https://github.com/ocaml/ocaml/issues
Happy hacking,
-- Damien Doligez for the OCaml team.
```
## Changelog template for a new version
@ -508,7 +454,7 @@ Here are typical forms of divergence and their usual solutions:
Fix: ensure that the entry is in the same section on all branches,
by putting it in the "smallest" version -- assuming that all bigger
versions also contain this cange.
versions also contain this change.
- A change entry is present in a given section, but the change is not
present in the corresponding release branch.
@ -592,3 +538,8 @@ release don't. Usually "Language features" is among the first, and
If some entries feel very anecdotal, consider moving them to the Bug
Fixes section.
### Extract release highlights to News
From time to time, synchronize the `News` file with the release highlights
of each version.

16
tools/markdown-add-pr-links.sh → release-info/markdown-add-pr-links.sh
View File

@ -15,20 +15,16 @@
#* *
#**************************************************************************
# This script performs a series of transformation on standard input to
# This script performs a series of transformation on its argument to
# turn ASCII references into Markdown-format links:
# - GPR#NNNN links to Github
# - MPR#NNNN and PR#NNNN link to Mantis
# - #NNNN links to Github
# - (Changes#VERSION) link to the Changes file
# Breaking change list bullet are converted into annotations
# It was only tested with GNU sed. Sorry!
GITHUB=https://github.com/ocaml/ocaml
MANTIS=https://caml.inria.fr/mantis
cat \
| sed "s,GPR#\\([0-9]*\\),[GPR~#~\\1]($GITHUB/pull/\\1),g"\
| sed "s,MPR#\\([0-9]*\\),[PR~#~\\1]($MANTIS/view.php?id=\\1),g"\
| sed "s,PR#\\([0-9]*\\),[PR~#~\\1]($MANTIS/view.php?id=\\1),g"\
| sed "s,(Changes#\\(.*\\)),[Changes file for \\1]($GITHUB/blob/\\1/Changes),g"\
| sed "s,PR~#~,PR#,g" \
sed "s,(Changes#\(.*\)),[Changes file for \\1]($GITHUB/blob/\\1/Changes),g" $1 \
| sed "s,#\([0-9]\+\),[#\\1]($GITHUB/issues/\\1),g" \
| sed "s/^*/* [*breaking change*]/g"

39
release-info/templates/beta.md Normal file
View File

@ -0,0 +1,39 @@
## Announcing a beta version:
```
Dear OCaml users,
The release of OCaml $MAJOR.$MINOR.$BUGFIX is approaching. We have created
a beta version to help you adapt your software to the new features
ahead of the release.
The source code is available at these addresses:
https://github.com/ocaml/ocaml/archive/$VERSION.tar.gz
https://caml.inria.fr/pub/distrib/ocaml-$BRANCH/ocaml-$VERSION.tar.gz
The compiler can also be installed as an OPAM switch with one of the
following commands:
opam update
opam switch create ocaml-variants.$VERSION --repositories=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git
or
opam update
opam switch create ocaml-variants.$VERSION+<VARIANT> --repositories=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git
where you replace <VARIANT> with one of these:
afl
flambda
fp
fp+flambda
We want to know about all bugs. Please report them here:
https://github.com/ocaml/ocaml/issues
Happy hacking,
-- $HUMAN for the OCaml team.
```

19
release-info/templates/production.md Normal file
View File

@ -0,0 +1,19 @@
## Announcing a production release:
```
Dear OCaml users,
We have the pleasure of celebrating <event> by announcing the release of
OCaml version $VERSION.
This is mainly a bug-fix release, see the list of changes below.
It is (or soon will be) available as a set of OPAM switches,
and as a source download here:
https://caml.inria.fr/pub/distrib/ocaml-$BRANCH/
Happy hacking,
-- $HUMAN for the OCaml team.
<< insert the relevant Changes section >>
```

40
release-info/templates/rc.md Normal file
View File

@ -0,0 +1,40 @@
## Announcing a release candidate:
```
Dear OCaml users,
The release of OCaml version $MAJOR.$MINOR.$BUGFIX is imminent. We have
created a release candidate that you can test.
The source code is available at these addresses:
https://github.com/ocaml/ocaml/archive/$VERSION.tar.gz
https://caml.inria.fr/pub/distrib/ocaml-$BRANCH/ocaml-$VERSION.tar.gz
The compiler can also be installed as an OPAM switch with one of the
following commands:
opam update
opam switch create ocaml-variants.$VERSION --repositories=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git
or
opam update
opam switch create ocaml-variants.$VERSION+<VARIANT> --repositories=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git
where you replace <VARIANT> with one of these:
afl
flambda
fp
fp+flambda
We want to know about all bugs. Please report them here:
https://github.com/ocaml/ocaml/issues
Happy hacking,
-- $HUMAN for the OCaml team.
<< insert the relevant Changes section >>
```

2
runtime/afl.c
View File

@ -15,7 +15,7 @@
/* Runtime support for afl-fuzz */
#include "caml/config.h"
#if !defined(HAS_SYS_SHM_H)
#if !defined(HAS_SYS_SHM_H) || !defined(HAS_SHMAT)
#include "caml/mlvalues.h"

32
runtime/callback.c
View File

@ -36,7 +36,6 @@
CAMLexport int caml_callback_depth = 0;
#ifndef LOCAL_CALLBACK_BYTECODE
static opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP };
static int callback_code_inited = 0;
@ -52,25 +51,15 @@ static void init_callback_code(void)
callback_code_inited = 1;
}
#endif
CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
{
int i;
value res;
/* some alternate bytecode implementations (e.g. a JIT translator)
might require that the bytecode is kept in a local variable on
the C stack */
#ifdef LOCAL_CALLBACK_BYTECODE
opcode_t local_callback_code[7];
#endif
CAMLassert(narg + 4 <= 256);
Caml_state->extern_sp -= narg + 4;
for (i = 0; i < narg; i++) Caml_state->extern_sp[i] = args[i]; /* arguments */
#ifndef LOCAL_CALLBACK_BYTECODE
Caml_state->extern_sp[narg] = (value)(callback_code + 4); /* return address */
Caml_state->extern_sp[narg + 1] = Val_unit; /* environment */
Caml_state->extern_sp[narg + 2] = Val_long(0); /* extra args */
@ -79,27 +68,6 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
callback_code[1] = narg + 3;
callback_code[3] = narg;
res = caml_interprete(callback_code, sizeof(callback_code));
#else /*have LOCAL_CALLBACK_BYTECODE*/
/* return address */
Caml_state->extern_sp[narg] = (value) (local_callback_code + 4);
Caml_state->extern_sp[narg + 1] = Val_unit; /* environment */
Caml_state->extern_sp[narg + 2] = Val_long(0); /* extra args */
Caml_state->extern_sp[narg + 3] = closure;
local_callback_code[0] = ACC;
local_callback_code[1] = narg + 3;
local_callback_code[2] = APPLY;
local_callback_code[3] = narg;
local_callback_code[4] = POP;
local_callback_code[5] = 1;
local_callback_code[6] = STOP;
/* Not registering the code fragment, as code fragment management
would need to be revised thoroughly for an hypothetical JIT */
#ifdef THREADED_CODE
caml_thread_code(local_callback_code, sizeof(local_callback_code));
#endif /*THREADED_CODE*/
res = caml_interprete(local_callback_code, sizeof(local_callback_code));
caml_release_bytecode(local_callback_code, sizeof(local_callback_code));
#endif /*LOCAL_CALLBACK_BYTECODE*/
if (Is_exception_result(res)) Caml_state->extern_sp += narg + 4; /* PR#3419 */
return res;
}

2
runtime/caml/config.h
View File

@ -166,7 +166,7 @@ typedef uint64_t uintnat;
as first-class values (GCC 2.x). */
#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) \
&& !defined (SHRINKED_GNUC) && !defined(CAML_JIT)
&& !defined (SHRINKED_GNUC)
#define THREADED_CODE
#endif

2
runtime/caml/domain_state.tbl
View File

@ -76,7 +76,7 @@ DOMAIN_STATE(intnat, stat_heap_chunks)
/* See gc_ctrl.c */
DOMAIN_STATE(uintnat, eventlog_startup_timestamp)
DOMAIN_STATE(uint32_t, eventlog_startup_pid)
DOMAIN_STATE(long, eventlog_startup_pid)
DOMAIN_STATE(uintnat, eventlog_paused)
DOMAIN_STATE(uintnat, eventlog_enabled)
DOMAIN_STATE(FILE*, eventlog_out)

5
runtime/caml/freelist.h
View File

@ -28,7 +28,6 @@ extern asize_t caml_fl_cur_wsz;
/* See [freelist.c] for usage info on these functions. */
extern header_t *(*caml_fl_p_allocate) (mlsize_t wo_sz);
extern void (*caml_fl_p_init_merge) (void);
extern void (*caml_fl_p_reset) (void);
extern header_t *(*caml_fl_p_merge_block) (value bp, char *limit);
extern void (*caml_fl_p_add_blocks) (value bp);
extern void (*caml_fl_p_make_free_blocks)
@ -43,9 +42,6 @@ Caml_inline header_t *caml_fl_allocate (mlsize_t wo_sz)
Caml_inline void caml_fl_init_merge (void)
{ (*caml_fl_p_init_merge) (); }
Caml_inline void caml_fl_reset (void)
{ (*caml_fl_p_reset) (); }
Caml_inline header_t *caml_fl_merge_block (value bp, char *limit)
{ return (*caml_fl_p_merge_block) (bp, limit); }
@ -57,6 +53,7 @@ Caml_inline void caml_make_free_blocks
{ (*caml_fl_p_make_free_blocks) (p, size, do_merge, color); }
extern void caml_set_allocation_policy (intnat);
extern void caml_fl_reset_and_switch_policy (intnat);
#ifdef DEBUG
Caml_inline void caml_fl_check (void)

6
runtime/caml/interp.h
View File

@ -26,12 +26,6 @@
/* interpret a bytecode */
value caml_interprete (code_t prog, asize_t prog_size);
/* tell the runtime that a bytecode program might be needed */
void caml_prepare_bytecode(code_t prog, asize_t prog_size);
/* tell the runtime that a bytecode program is no more needed */
void caml_release_bytecode(code_t prog, asize_t prog_size);
#endif /* CAML_INTERNALS */
#endif /* CAML_INTERP_H */

2
runtime/caml/mlvalues.h
View File

@ -214,7 +214,7 @@ typedef opcode_t * code_t;
/* If tag == Infix_tag : an infix header inside a closure */
/* Infix_tag must be odd so that the infix header is scanned as an integer */
/* Infix_tag must be 1 modulo 4 and infix headers can only occur in blocks
/* Infix_tag must be 1 modulo 2 and infix headers can only occur in blocks
with tag Closure_tag (see compact.c). */
#define Infix_tag 249

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

@ -245,6 +245,8 @@
#undef HAS_SYS_SHM_H
#undef HAS_SHMAT
#undef HAS_EXECVPE
#undef HAS_POSIX_SPAWN
@ -256,8 +258,6 @@
#undef HAS_SIGWAIT
#undef HAS_LIBBFD
#undef HAS_HUGE_PAGES
#undef HUGE_PAGE_SIZE

298
runtime/compact.c
View File

@ -35,88 +35,59 @@
extern uintnat caml_percent_free; /* major_gc.c */
extern void caml_shrink_heap (char *); /* memory.c */
/* Encoded headers: the color is stored in the 2 least significant bits.
(For pointer inversion, we need to distinguish headers from pointers.)
s is a Wosize, t is a tag, and c is a color (a two-bit number)
/* Colors
For the purpose of compaction, "colors" are:
0: pointers (direct or inverted)
1: integer or (unencoded) infix header
2: inverted pointer for infix header
3: integer or encoded (noninfix) header
We use the GC's color bits in the following way:
XXX Should be fixed:
XXX The above assumes that all roots are aligned on a 4-byte boundary,
XXX which is not always guaranteed by C.
XXX (see [caml_register_global_roots])
XXX Should be able to fix it to only assume 2-byte alignment.
- White words are headers of live blocks.
- Blue words are headers of free blocks.
- Black words are headers of out-of-heap "blocks".
- Gray words are the encoding of pointers in inverted lists.
Encoded pointers:
Pointers always have their two low-order bits clear. We make use of
this to encode pointers by shifting bits 2-9 to 0-7:
...XXXyyyyyyyy00 becomes ...XXX01yyyyyyyy
Note that 01 corresponds to the "gray" color of the GC, so we can now
mix pointers and headers because there are no gray headers anywhere in
the heap (or outside) when we start a compaction (which must be done at
the end of a sweep phase).
*/
#ifdef WITH_PROFINFO
#define Make_ehd(s,t,c,p) \
(((s) << 10) | (t) << 2 | (c) | ((p) << PROFINFO_SHIFT))
#else
#define Make_ehd(s,t,c,p) (((s) << 10) | (t) << 2 | (c))
#endif
#define Whsize_ehd(h) Whsize_hd (h)
#define Wosize_ehd(h) Wosize_hd (h)
#define Tag_ehd(h) (((h) >> 2) & 0xFF)
#ifdef WITH_PROFINFO
#define Profinfo_ehd(hd) Profinfo_hd(hd)
#endif
#define Ecolor(w) ((w) & 3)
typedef uintnat word;
#define eptr(p) \
(((word) (p) & ~0x3FF) | ((((word) p) & 0x3FF) >> 2) | Caml_gray)
#define dptr(p) ((word *) (((word) (p) & ~0x3FF) | ((((word) p) & 0xFF) << 2)))
static void invert_pointer_at (word *p)
{
word q = *p;
CAMLassert (Ecolor ((intnat) p) == 0);
header_t h;
/* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an
inverted pointer for an infix header (with Ecolor == 2). */
if (Ecolor (q) == 0 && Is_in_heap (q)){
switch (Ecolor (Hd_val (q))){
case 0:
case 3: /* Pointer or header: insert in inverted list. */
*p = Hd_val (q);
Hd_val (q) = (header_t) p;
break;
case 1: /* Infix header: make inverted infix list. */
/* Double inversion: the last of the inverted infix list points to
the next infix header in this block. The last of the last list
contains the original block header. */
{
/* This block as a value. */
value val = (value) q - Infix_offset_val (q);
/* Get the block header. */
word *hp = (word *) Hp_val (val);
CAMLassert (((uintnat) p & 3) == 0);
while (Ecolor (*hp) == 0) hp = (word *) *hp;
CAMLassert (Ecolor (*hp) == 3);
if (Tag_ehd (*hp) == Closure_tag){
/* This is the first infix found in this block. */
/* Save original header. */
*p = *hp;
/* Link inverted infix list. */
Hd_val (q) = (header_t) ((word) p | 2);
/* Change block header's tag to Infix_tag, and change its size
to point to the infix list. */
*hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3, (uintnat) 0);
}else{
CAMLassert (Tag_ehd (*hp) == Infix_tag);
/* Point the last of this infix list to the current first infix
list of the block. */
*p = (word) &Field (val, Wosize_ehd (*hp)) | 1;
/* Point the head of this infix list to the above. */
Hd_val (q) = (header_t) ((word) p | 2);
/* Change block header's size to point to this infix list. */
*hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3, (uintnat) 0);
}
if (Is_block (q) && Is_in_value_area (q)){
h = Hd_val (q);
switch (Color_hd (h)){
case Caml_white:
if (Tag_hd (h) == Infix_tag){
value realvalue = (value) q - Infix_offset_val (q);
if (Is_black_val (realvalue)) break;
}
/* FALL THROUGH */
case Caml_gray:
CAMLassert (Is_in_heap (q));
/* [q] points to some inverted list, insert it. */
*p = h;
Hd_val (q) = eptr (p);
break;
case 2: /* Inverted infix list: insert. */
*p = Hd_val (q);
Hd_val (q) = (header_t) ((word) p | 2);
case Caml_black:
/* [q] points to an out-of-heap value. Leave it alone. */
break;
default: /* Caml_blue */
/* We found a pointer to a free block. This cannot happen. */
CAMLassert (0);
break;
}
}
@ -124,6 +95,13 @@ static void invert_pointer_at (word *p)
void caml_invert_root (value v, value *p)
{
#ifdef NO_NAKED_POINTERS
/* Note: this assertion will become tautological and should be removed when
we finally get rid of the page table in NNP mode.
*/
CAMLassert (Is_long (*p) || Is_in_heap (*p) || Is_black_val (*p)
|| Tag_val (*p) == Infix_tag);
#endif
invert_pointer_at ((word *) p);
}
@ -170,39 +148,19 @@ static void do_compaction (intnat new_allocation_policy)
caml_heap_check ();
#endif
/* First pass: encode all noninfix headers. */
{
ch = caml_heap_start;
while (ch != NULL){
header_t *p = (header_t *) ch;
/* Make sure the heap is in the right state for compaction:
- all free blocks are blue
- all other blocks are white and contain valid pointers
*/
caml_fl_reset_and_switch_policy (new_allocation_policy);
chend = ch + Chunk_size (ch);
while ((char *) p < chend){
header_t hd = Hd_hp (p);
mlsize_t sz = Wosize_hd (hd);
if (Is_blue_hd (hd)){
/* Free object. Give it a string tag. */
Hd_hp (p) = Make_ehd (sz, String_tag, 3, (uintnat) 0);
}else{
CAMLassert (Is_white_hd (hd));
/* Live object. Keep its tag. */
Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3, Profinfo_hd (hd));
}
p += Whsize_wosize (sz);
}
ch = Chunk_next (ch);
}
}
/* First pass: removed in 4.12 thanks to the new closure representation. */
/* Second pass: invert pointers.
Link infix headers in each block in an inverted list of inverted lists.
Don't forget roots and weak pointers. */
Don't forget roots and weak pointers.
This is a mark-like pass. */
{
/* Invert roots first because the threads library needs some heap
data structures to find its roots. Fortunately, it doesn't need
the headers (see above). */
caml_do_roots (caml_invert_root, 1);
/* The values to be finalised are not roots but should still be inverted */
caml_final_invert_finalisable_values ();
@ -216,27 +174,27 @@ static void do_compaction (intnat new_allocation_policy)
while ((char *) p < chend){
word q = *p;
size_t sz, i;
mlsize_t wosz, i, first_field;
tag_t t;
word *infixes;
while (Ecolor (q) == 0) q = * (word *) q;
sz = Whsize_ehd (q);
t = Tag_ehd (q);
if (t == Infix_tag){
/* Get the original header of this block. */
infixes = p + sz;
q = *infixes;
while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3);
sz = Whsize_ehd (q);
t = Tag_ehd (q);
while (Is_gray_hd (q)) q = * dptr (q);
wosz = Wosize_hd (q);
if (Is_white_hd (q)){
t = Tag_hd (q);
CAMLassert (t != Infix_tag);
if (t < No_scan_tag){
value v = Val_hp (p);
if (t == Closure_tag){
first_field = Start_env_closinfo (Closinfo_val (v));
}else{
first_field = 0;
}
for (i = first_field; i < wosz; i++){
invert_pointer_at ((word *) &Field (v,i));
}
}
}
if (t < No_scan_tag){
for (i = 1; i < sz; i++) invert_pointer_at (&(p[i]));
}
p += sz;
p += Whsize_wosize (wosz);
}
ch = Chunk_next (ch);
}
@ -251,8 +209,9 @@ static void do_compaction (intnat new_allocation_policy)
p = *pp;
if (p == (value) NULL) break;
q = Hd_val (p);
while (Ecolor (q) == 0) q = * (word *) q;
sz = Wosize_ehd (q);
while (Is_gray_hd (q)) q = * dptr (q);
CAMLassert (Is_white_hd (q));
sz = Wosize_hd (q);
for (i = 1; i < sz; i++){
if (Field (p,i) != caml_ephe_none){
invert_pointer_at ((word *) &(Field (p,i)));
@ -265,8 +224,8 @@ static void do_compaction (intnat new_allocation_policy)
}
/* Third pass: reallocate virtually; revert pointers; decode headers.
Rebuild infix headers. */
/* Third pass: reallocate virtually; revert pointers.
This is a sweep-like pass. */
{
init_compact_allocate ();
ch = caml_heap_start;
@ -275,75 +234,59 @@ static void do_compaction (intnat new_allocation_policy)
chend = ch + Chunk_size (ch);
while ((char *) p < chend){
word q = *p;
header_t h = Hd_hp (p);
size_t sz;
if (Ecolor (q) == 0 || Tag_ehd (q) == Infix_tag){
/* There were (normal or infix) pointers to this block. */
size_t sz;
while (Is_gray_hd (h)) h = * dptr (h);
sz = Whsize_hd (h);
CAMLassert (!Is_black_hd (h));
CAMLassert (!Is_gray_hd (h));
if (Is_white_hd (h)){
word q;
tag_t t;
char *newadr;
#ifdef WITH_PROFINFO
uintnat profinfo;
#endif
word *infixes = NULL;
while (Ecolor (q) == 0) q = * (word *) q;
sz = Whsize_ehd (q);
t = Tag_ehd (q);
#ifdef WITH_PROFINFO
profinfo = Profinfo_ehd (q);
#endif
if (t == Infix_tag){
/* Get the original header of this block. */
infixes = p + sz;
q = *infixes;
CAMLassert (Ecolor (q) == 2);
while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3);
sz = Whsize_ehd (q);
t = Tag_ehd (q);
}
t = Tag_hd (h);
CAMLassert (t != Infix_tag);
newadr = compact_allocate (Bsize_wsize (sz));
q = *p;
while (Ecolor (q) == 0){
word next = * (word *) q;
* (word *) q = (word) Val_hp (newadr);
q = next;
while (Is_gray_hd (q)){
word *pp = dptr (q);
q = *pp;
*pp = (word) Val_hp (newadr);
}
*p = Make_header_with_profinfo (Wosize_whsize (sz), t, Caml_white,
profinfo);
CAMLassert (q == h);
*p = q;
if (infixes != NULL){
/* Rebuild the infix headers and revert the infix pointers. */
while (Ecolor ((word) infixes) != 3){
infixes = (word *) ((word) infixes & ~(uintnat) 3);
q = *infixes;
while (Ecolor (q) == 2){
word next;
q = (word) q & ~(uintnat) 3;
next = * (word *) q;
* (word *) q = (word) Val_hp ((word *) newadr + (infixes - p));
q = next;
if (t == Closure_tag){
/* Revert the infix pointers to this block. */
mlsize_t i, startenv;
value v;
v = Val_hp (p);
startenv = Start_env_closinfo (Closinfo_val (v));
i = 0;
while (1){
int arity = Arity_closinfo (Field (v, i+1));
i += 2 + (arity != 0 && arity != 1);
if (i >= startenv) break;
/* Revert the inverted list for infix header at offset [i]. */
q = Field (v, i);
while (Is_gray_hd (q)){
word *pp = dptr (q);
q = *pp;
*pp = (word) Val_hp ((header_t *) &Field (Val_hp (newadr), i));
}
CAMLassert (Ecolor (q) == 1 || Ecolor (q) == 3);
/* No need to preserve any profinfo value on the [Infix_tag]
headers; the Spacetime profiling heap snapshot code doesn't
look at them. */
*infixes = Make_header (infixes - p, Infix_tag, Caml_white);
infixes = (word *) q;
CAMLassert (Tag_hd (q) == Infix_tag);
Field (v, i) = q;
++i;
}
}
p += sz;
}else{
CAMLassert (Ecolor (q) == 3);
/* This is guaranteed only if caml_compact_heap was called after a
nonincremental major GC: CAMLassert (Tag_ehd (q) == String_tag);
*/
/* No pointers to the header and no infix header:
the object was free. */
*p = Make_header (Wosize_ehd (q), Tag_ehd (q), Caml_blue);
p += Whsize_ehd (q);
}
p += sz;
}
ch = Chunk_next (ch);
}
@ -414,10 +357,7 @@ static void do_compaction (intnat new_allocation_policy)
structures from scratch. */
{
ch = caml_heap_start;
if (new_allocation_policy != -1){
caml_set_allocation_policy (new_allocation_policy);
}
caml_fl_reset ();
caml_fl_init_merge ();
while (ch != NULL){
if (Chunk_size (ch) > Chunk_alloc (ch)){
caml_make_free_blocks ((value *) (ch + Chunk_alloc (ch)),

8
runtime/eventlog.c
View File

@ -136,15 +136,15 @@ static void setup_eventlog_file()
char_os output_file[OUTPUT_FILE_LEN];
char_os *eventlog_filename = NULL;
eventlog_filename = caml_secure_getenv(T("OCAML_EVENTLOG_FILE"));
eventlog_filename = caml_secure_getenv(T("OCAML_EVENTLOG_PREFIX"));
if (eventlog_filename) {
int ret = snprintf_os(output_file, OUTPUT_FILE_LEN, T("%s.%d.eventlog"),
int ret = snprintf_os(output_file, OUTPUT_FILE_LEN, T("%s.%ld.eventlog"),
eventlog_filename, Caml_state->eventlog_startup_pid);
if (ret > OUTPUT_FILE_LEN)
caml_fatal_error("eventlog: specified OCAML_EVENTLOG_FILE is too long");
caml_fatal_error("eventlog: specified OCAML_EVENTLOG_PREFIX is too long");
} else {
snprintf_os(output_file, OUTPUT_FILE_LEN, T("caml-eventlog-%d"),
snprintf_os(output_file, OUTPUT_FILE_LEN, T("caml-%ld.eventlog"),
Caml_state->eventlog_startup_pid);
}

64
runtime/freelist.c
View File

@ -202,12 +202,16 @@ static void nf_init_merge (void)
#endif
}
static void nf_reset (void)
static void nf_init (void)
{
Next_small (Nf_head) = Val_NULL;
nf_prev = Nf_head;
caml_fl_cur_wsz = 0;
nf_init_merge ();
}
static void nf_reset (void)
{
nf_init ();
}
/* Note: the [limit] parameter is unused because we merge blocks one by one. */
@ -634,12 +638,16 @@ static void ff_truncate_flp (value changed)
}
}
static void ff_reset (void)
static void ff_init (void)
{
Next_small (Ff_head) = Val_NULL;
ff_truncate_flp (Ff_head);
caml_fl_cur_wsz = 0;
ff_init_merge ();
}
static void ff_reset (void)
{
ff_init ();
}
/* Note: the [limit] parameter is unused because we merge blocks one by one. */
@ -1515,7 +1523,7 @@ static header_t *bf_allocate (mlsize_t wosz)
return Hp_val (block);
}else{
/* allocate from the next available size */
mlsize_t s = ffs (bf_small_map & ((-1) << wosz));
mlsize_t s = ffs (bf_small_map & ((~0U) << wosz));
FREELIST_DEBUG_bf_check ();
if (s != 0){
block = bf_small_fl[s].free;
@ -1587,7 +1595,7 @@ static void bf_init_merge (void)
}
}
static void bf_reset (void)
static void bf_init (void)
{
mlsize_t i;
@ -1599,7 +1607,30 @@ static void bf_reset (void)
bf_large_tree = NULL;
bf_large_least = NULL;
caml_fl_cur_wsz = 0;
bf_init_merge ();
}
/* Make sure all free blocks are blue and tear down the BF data structures. */
static void bf_reset (void)
{
mlsize_t i;
for (i = 1; i <= BF_NUM_SMALL; i++){
/* At the beginning of each small free list is a segment of remnants
that were pushed back to the list after splitting. These are white
and they are not in order. We must make them blue before we can
compact or change the allocator policy.
*/
value p = bf_small_fl[i].free;
while (1){
if (p == Val_NULL || Color_val (p) == Caml_blue) break;
CAMLassert (Color_val (p) == Caml_white);
Hd_val (p) = Bluehd_hd (Hd_val (p));
p = Next_small (p);
}
}
/* We have no malloced data structures, so we can just call [bf_init] to
clear all our pointers. */
bf_init ();
}
static header_t *bf_merge_block (value bp, char *limit)
@ -1738,8 +1769,9 @@ header_t *(*caml_fl_p_allocate) (mlsize_t wo_sz) = &nf_allocate;
/* Initialize the merge_block machinery (at start of sweeping). */
void (*caml_fl_p_init_merge) (void) = &nf_init_merge;
/* This is called by caml_compact_heap. */
void (*caml_fl_p_reset) (void) = &nf_reset;
/* These are called internally. */
static void (*caml_fl_p_init) (void) = &nf_init;
static void (*caml_fl_p_reset) (void) = &nf_reset;
/* [caml_fl_merge_block] returns the head pointer of the next block after [bp],
because merging blocks may change the size of [bp]. */
@ -1777,6 +1809,7 @@ void caml_set_allocation_policy (intnat p)
caml_fl_p_allocate = &nf_allocate;
caml_fl_p_init_merge = &nf_init_merge;
caml_fl_p_reset = &nf_reset;
caml_fl_p_init = &nf_init;
caml_fl_p_merge_block = &nf_merge_block;
caml_fl_p_add_blocks = &nf_add_blocks;
caml_fl_p_make_free_blocks = &nf_make_free_blocks;
@ -1789,6 +1822,7 @@ void caml_set_allocation_policy (intnat p)
caml_fl_p_allocate = &ff_allocate;
caml_fl_p_init_merge = &ff_init_merge;
caml_fl_p_reset = &ff_reset;
caml_fl_p_init = &ff_init;
caml_fl_p_merge_block = &ff_merge_block;
caml_fl_p_add_blocks = &ff_add_blocks;
caml_fl_p_make_free_blocks = &ff_make_free_blocks;
@ -1801,6 +1835,7 @@ void caml_set_allocation_policy (intnat p)
caml_fl_p_allocate = &bf_allocate;
caml_fl_p_init_merge = &bf_init_merge;
caml_fl_p_reset = &bf_reset;
caml_fl_p_init = &bf_init;
caml_fl_p_merge_block = &bf_merge_block;
caml_fl_p_add_blocks = &bf_add_blocks;
caml_fl_p_make_free_blocks = &bf_make_free_blocks;
@ -1810,3 +1845,14 @@ void caml_set_allocation_policy (intnat p)
break;
}
}
/* This is called by caml_compact_heap. */
void caml_fl_reset_and_switch_policy (intnat new_allocation_policy)
{
/* reset the fl data structures */
(*caml_fl_p_reset) ();
if (new_allocation_policy != -1){
caml_set_allocation_policy (new_allocation_policy);
(*caml_fl_p_init) (); /* initialize the new allocation policy */
}
}

144
runtime/hash.c
View File

@ -25,8 +25,8 @@
#include "caml/memory.h"
#include "caml/hash.h"
/* The new implementation, based on MurmurHash 3,
http://code.google.com/p/smhasher/ */
/* The implementation based on MurmurHash 3,
https://github.com/aappleby/smhasher/ */
#define ROTL32(x,n) ((x) << n | (x) >> (32-n))
@ -301,146 +301,6 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj)
return Val_int(h & 0x3FFFFFFFU);
}
/* The old implementation */
struct hash_state {
uintnat accu;
intnat univ_limit, univ_count;
};
static void hash_aux(struct hash_state*, value obj);
CAMLprim value caml_hash_univ_param(value count, value limit, value obj)
{
struct hash_state h;
h.univ_limit = Long_val(limit);
h.univ_count = Long_val(count);
h.accu = 0;
hash_aux(&h, obj);
return Val_long(h.accu & 0x3FFFFFFF);
/* The & has two purposes: ensure that the return value is positive
and give the same result on 32 bit and 64 bit architectures. */
}
#define Alpha 65599
#define Beta 19
#define Combine(new) (h->accu = h->accu * Alpha + (new))
#define Combine_small(new) (h->accu = h->accu * Beta + (new))
static void hash_aux(struct hash_state* h, value obj)
{
unsigned char * p;
mlsize_t i, j;
tag_t tag;
h->univ_limit--;
if (h->univ_count < 0 || h->univ_limit < 0) return;
again:
if (Is_long(obj)) {
h->univ_count--;
Combine(Long_val(obj));
return;
}
if (! Is_in_value_area(obj)) {
/* obj is a pointer outside the heap, to an object with
a priori unknown structure. Use its physical address as hash key. */
Combine((intnat) obj);
return;
}
/* Pointers into the heap are well-structured blocks. So are atoms.
We can inspect the block contents. */
/* The code needs reindenting later. Leaving as is to facilitate review. */
tag = Tag_val(obj);
switch (tag) {
case String_tag:
h->univ_count--;
i = caml_string_length(obj);
for (p = &Byte_u(obj, 0); i > 0; i--, p++)
Combine_small(*p);
break;
case Double_tag:
/* For doubles, we inspect their binary representation, LSB first.
The results are consistent among all platforms with IEEE floats. */
h->univ_count--;
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, 0), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
break;
case Double_array_tag:
h->univ_count--;
for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, j), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
}
break;
case Abstract_tag:
/* We don't know anything about the contents of the block.
Better do nothing. */
break;
case Infix_tag:
hash_aux(h, obj - Infix_offset_val(obj));
break;
case Forward_tag:
obj = Forward_val (obj);
goto again;
case Object_tag:
h->univ_count--;
Combine(Oid_val(obj));
break;
case Custom_tag:
/* If no hashing function provided, do nothing */
if (Custom_ops_val(obj)->hash != NULL) {
h->univ_count--;
Combine(Custom_ops_val(obj)->hash(obj));
}
break;
#ifdef NO_NAKED_POINTERS
case Closure_tag:
h->univ_count--;
Combine_small(tag);
/* Recursively hash the environment fields */
i = Wosize_val(obj);
j = Start_env_closinfo(Closinfo_val(obj));
while (i > j) {
i--;
hash_aux(h, Field(obj, i));
}
/* Combine the code pointers, closure info fields, and infix headers */
while (i > 0) {
i--;
Combine(Field(obj, i));
h->univ_count--;
}
break;
#endif
default:
h->univ_count--;
Combine_small(tag);
i = Wosize_val(obj);
while (i != 0) {
i--;
hash_aux(h, Field(obj, i));
}
break;
}
}
/* Hashing variant tags */
CAMLexport value caml_hash_variant(char const * tag)

2
runtime/instrtrace.c
View File

@ -149,7 +149,7 @@ char * caml_instr_string (code_t pc)
snprintf(buf, sizeof(buf), "%s %d, %d", nam, pc[0], pc[1]);
break;
case SWITCH:
snprintf(buf, sizeof(buf), "SWITCH sz%#lx=%ld::ntag%ld nint%ld",
snprintf(buf, sizeof(buf), "SWITCH sz%#lx=%ld::ntag%lu nint%lu",
(long) pc[0], (long) pc[0], (unsigned long) pc[0] >> 16,
(unsigned long) pc[0] & 0xffff);
break;

5
runtime/intern.c
View File

@ -868,11 +868,6 @@ CAMLexport value caml_input_val_from_bytes(value str, intnat ofs)
CAMLreturn (intern_end(obj, h.whsize));
}
CAMLprim value caml_input_value_from_string(value str, value ofs)
{
return caml_input_val_from_bytes(str, Long_val(ofs));
}
CAMLprim value caml_input_value_from_bytes(value str, value ofs)
{
return caml_input_val_from_bytes(str, Long_val(ofs));

21
runtime/interp.c
View File

@ -1082,10 +1082,6 @@ value caml_interprete(code_t prog, asize_t prog_size)
#define Lookup(obj, lab) Field (Field (obj, 0), Int_val(lab))
/* please don't forget to keep below code in sync with the
functions caml_cache_public_method and
caml_cache_public_method2 in obj.c */
Instruct(GETMETHOD):
accu = Lookup(sp[0], accu);
Next;
@ -1182,20 +1178,3 @@ value caml_interprete(code_t prog, asize_t prog_size)
}
#endif
}
void caml_prepare_bytecode(code_t prog, asize_t prog_size) {
/* other implementations of the interpreter (such as an hypothetical
JIT translator) might want to do something with a bytecode before
running it */
CAMLassert(prog);
CAMLassert(prog_size>0);
/* actually, the threading of the bytecode might be done here */
}
void caml_release_bytecode(code_t prog, asize_t prog_size) {
/* other implementations of the interpreter (such as an hypothetical
JIT translator) might want to know when a bytecode is removed */
/* check that we have a program */
CAMLassert(prog);
CAMLassert(prog_size>0);
}

26
runtime/io.c
View File

@ -601,19 +601,6 @@ CAMLprim value caml_ml_set_binary_mode(value vchannel, value mode)
file descriptors that may be closed.
*/
CAMLprim value caml_ml_flush_partial(value vchannel)
{
CAMLparam1 (vchannel);
struct channel * channel = Channel(vchannel);
int res;
if (channel->fd == -1) CAMLreturn(Val_true);
Lock(channel);
res = caml_flush_partial(channel);
Unlock(channel);
CAMLreturn (Val_bool(res));
}
CAMLprim value caml_ml_flush(value vchannel)
{
CAMLparam1 (vchannel);
@ -648,19 +635,6 @@ CAMLprim value caml_ml_output_int(value vchannel, value w)
CAMLreturn (Val_unit);
}
CAMLprim value caml_ml_output_partial(value vchannel, value buff, value start,
value length)
{
CAMLparam4 (vchannel, buff, start, length);
struct channel * channel = Channel(vchannel);
int res;
Lock(channel);
res = caml_putblock(channel, &Byte(buff, Long_val(start)), Long_val(length));
Unlock(channel);
CAMLreturn (Val_int(res));
}
CAMLprim value caml_ml_output_bytes(value vchannel, value buff, value start,
value length)
{

7
runtime/major_gc.c
View File

@ -160,11 +160,8 @@ void caml_darken (value v, value *p /* not used */)
}
#ifdef NO_NAKED_POINTERS
/* We insist that naked pointers to outside the heap point to things that
look like values with headers coloured black. This isn't always
strictly necessary but is essential in certain cases---in particular
when the value is allocated in a read-only section. (For the values
where it would be safe it is a performance improvement since we avoid
putting them on the grey list.) */
look like values with headers coloured black. This is always
strictly necessary because the compactor relies on it. */
CAMLassert (Is_in_heap (v) || Is_black_hd (h));
#endif
CAMLassert (!Is_blue_hd (h));

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